C LABOUT.FTN C C A PROGRAM TO READ THE DATA IN THE FILE, LABEL.DAT C THIS WAS 22 BLOCKS LONG WHEN SORTED BY ZIP WITH 100 REC C 26 BLOCKS ZIP WITH 400 RECORDS C 38 BLOCKS NAME WITH 400 RECORDS C BYTE NAME(84) BYTE LIN1(108) BYTE LIN2(108) BYTE LIN3(108) BYTE LIN4(108) BYTE ZSAV(5) BYTE FZIP(5) BYTE LZIP(5) BYTE SPA,LF,EXC,COM,NULL BYTE LISCOD(5) BYTE SELORG ! PRINT SELECTION BY ORGANIZATION BYTE SELPRO ! PRINT SELECTION BY PROFESSION INTEGER REC ! RECORD NUMBER TO WRITE TO INTEGER RECDES ! DESIRED REC WHEN WRITING MANY COPIES 1 REC INTEGER LASREC ! LAST RECORD INTEGER OUT,COUN INTEGER COL ! COLUMN NUMBER INTEGER COMPAR,DAYS ! TWO SUBROUTINES INTEGER MAXCOL ! MAXIMUM NUMBER OF COLUMNS INTEGER LIST ! WHICH LIST TO PRINT (ST & PRIV, AMER C) INTEGER BITTER ! FUNCTION TO TEST IF BIT IS SET INTEGER DAY,DA,MO,YR,EXPDAY, PROF, ORG EQUIVALENCE (COUN,NAME(81)), (DAY, NAME(79)) DATA SPA,LF,EXC,COM,NULL/"40,"12,"41,"54,"00/ EXPDAY=DAYS(I,J,K,1)-365 ! EXP DAY 1 YEAR AGO WRITE(5,100) 100 FORMAT('$ENTER 1 IF PRINT ON ZIP SORT FILE ') READ(5,140)IZIP IF(IZIP.NE.1)GO TO 130 CALL ASSIGN(2,'SORTL.DAT;1') 110 WRITE(5,115) 115 FORMAT('$ENTER LOW ZIP: ') READ(5,125)FZIP CALL TRIM(FZIP,5) WRITE(5,120) 120 FORMAT('$ENTER HIGH ZIP ') READ(5,125)LZIP IF(COMPAR(FZIP(1),LZIP(1),5).NE.2)GO TO 110 125 FORMAT(5A1) 130 DEFINE FILE 2(32000,42,U,NXT) CALL FDBSET(2,'OLD','SHARE') IF(IZIP.NE.1)CALL ASSIGN(2,'LABEL.DAT;1') READ(2'1)LASREC, I, NLIST ! LAST REC AND NUMBER OF LISTS LASREC=LASREC-1 ! CHANGE TO LAST REC WRITE(5,135)LASREC, NLIST 135 FORMAT(' LAST REC STORED IS ',I8,' NUMBER OF LISTS',I5) IF(NLIST.GT.4)NLIST=4 ! MAX NO. OF LISTS RIGHT NOW IS 4 IF(NLIST.LE.0)NLIST=1 140 FORMAT(I5) WRITE(5,145) 145 FORMAT('$ENTER 1 FOR STRAIGHT IMAGE PRINT OF FILE ') READ(5,140)IMAG IF(IMAG.EQ.1)GO TO 170 WRITE(5,150) 150 FORMAT('$ENTER NO. OF COLUMNS TO PRINT ') READ(5,140)I IF(I.LE.0)I=3 ! LET THE DEFAULT BE 3 MAXCOL=5+(I-1)*36 IF(MAXCOL.GT.77)MAXCOL=77 155 WRITE(5,160) 160 FORMAT('$If you want many labels of the same record, enter number 1 wanted ') READ(5,140,ERR=155)NBER IF(NBER.LE.0)GO TO 170 NBER=NBER+1 ! SO CAN SEARCH TIL REACH 1, NOT 0 WRITE(5,165) 165 FORMAT('$What is the record number desired: ') READ(5,140)RECDES GO TO 205 170 WRITE(5,171) 171 FORMAT(' Coose one of the following mailing lists to print ') WRITE(5,172) 172 FORMAT(' 0 ALL LISTS') CALL PRILIS(5, NLIST) ! PRINT ALL THE LISTS READ(5,140,ERR=170)LIST LIST=LIST+1 ! COMPANYS ARE ACTUALLY 1 IF((LIST.LT.0).OR.(LIST.GT.8))GO TO 170 180 WRITE(5,185) 185 FORMAT('$ENTER ORGANIZATION CODE TO PRINT, 0=ALL') READ(5,140)ORG DECODE(1,190,ORG,ERR=180)SELORG 190 FORMAT(A1) 195 WRITE(5,200) 200 FORMAT('$ENTER PROFESSION CODE TO PRINT, 0=ALL ') READ(5,140)PROF DECODE(1,190,PROF,ERR=195)SELPRO 205 WRITE(5,210) 210 FORMAT('$Enter 0 for this terminal, 5 for TT5:, 13 for 1 TT13: ') READ(5,140)OUT IF(OUT.EQ.5)CALL ASNLUN(1,'TT',5) ! PRINT ON TT5: IF(OUT.EQ.13)CALL ASNLUN(1,'TT',11) ! PRINT ON TT13: IF(OUT.LE.0)CALL ASNLUN(1,'TI',0) ! DON'T WANT WRITTEN REPORT IF(OUT.EQ.16)CALL ASSIGN(1,'EDIT.DAT;1') ! WRITE TO A FILE ON DISK IF(IMAG.NE.1)GO TO 225 IF(ORG.GT.1)WRITE(1,215)ORG 215 FORMAT(' ORGANIZATION ',I4) IF(PROF.GT.1)WRITE(1,220)PROF 220 FORMAT(' PROFESSION ',I4) C C C C 225 WRITE(5,230) 230 FORMAT('$GIVE ME THE BEGINNING RECORD NO. ') READ(5,140)REC IF(REC.LT.3)REC=3 IF(REC.GT.LASREC)REC=LASREC 235 IF(IMAG.EQ.1)GO TO 240 CALL LOA(LIN1,108,SPA) CALL LOA(LIN2,108,SPA) CALL LOA(LIN3,108,SPA) CALL LOA(LIN4,108,SPA) COL=1 240 IF(NBER.GE.1) REC=RECDES ! PRINTING MANY COP OF SAME LABEL READ(2'REC)NAME IF(IZIP.NE.1)GO TO 245 IF(COMPAR(NAME(71),FZIP(1),5).EQ.2)GO TO 395 IF(COMPAR(NAME(71),LZIP(1),3).EQ.1)REC=LASREC IF(REC.EQ.LASREC)GO TO 395 IF(COMPAR(NAME(71),LZIP(1),5).EQ.1)GO TO 395 245 IF(NAME(2).EQ.EXC)GO TO 395 IF(NAME(1).EQ.NULL)GO TO 395 IF((NAME(1).EQ.SPA).AND.(NAME(2).EQ.SPA))GO TO 395 IF(NAME(1).EQ.9)GO TO 395 IF(NAME(1).EQ."71)GO TO 395 IF((NAME(1).LT."101).OR.(NAME(1).GT."132))GO TO 395 IF(LIST.LE.1)GO TO 250 IF(BITTER(COUN,LIST,3).NE.1)GO TO 395 250 IF(ORG.LT.1)GO TO 255 IF(NAME(76).NE.SELORG)GO TO 395 255 IF(PROF.LT.1)GO TO 260 IF(NAME(77).NE.SELPRO)GO TO 395 C 260 IF(IMAG.EQ.1)GO TO 375 J2=0 C DOES THE FIRST LINE HAVE TO BE INVERTED IF(BITTER(COUN,1,3).NE.1)GO TO 275 ! NEED TO INVERT THE LINE DO 265 J=1,36 IF(NAME(J).EQ.EXC)GO TO 270 IF(NAME(J).EQ.NULL)GO TO 270 265 CONTINUE 270 J2=J-1 CALL SCOPY(NAME,LIN1,J2,1,COL) J1=J2+2 GO TO 315 C C FIND END OF LAST NAME C 275 DO 280 J=1,36 IF(NAME(J).EQ."54)GO TO 290 ! FOUND A COMMA IF(NAME(J).EQ."40)GO TO 290 ! FOUND A SPACE IF(NAME(J).EQ.EXC)GO TO 270 ! FOUND EXCLA, END OF LINE IF(NAME(J).EQ.NULL)GO TO 285 280 CONTINUE 285 CALL SCOPY(NAME,LIN1,J-1,1,COL) ! TRANSFER THE ONE NAME J1=J+1 GO TO 315 290 J1=J-1 ! J1 IS END OF LAST NAME DO 295 J=J1+2,J1+2+36 IF(NAME(J).EQ.COM)J2=J-1 ! END OF NAME, BEG OF TITLE IF(J.EQ.70)GO TO 300 IF(NAME(J).EQ.EXC)GO TO 300 ! END OF NAME, NO TITLE IF(NAME(J).EQ.NULL)GO TO 300 295 CONTINUE 300 J3=J-1 IF(J2.EQ.0)J2=J3 305 CALL SCOPY(NAME,LIN1,J2-J1-1,J1+2,COL) ! TRANSFER FIRST NAME CALL SCOPY(NAME,LIN1,J1,1,J2-J1+COL) ! TRANSFER THE LAST NAME IF(J2.EQ.J3)GO TO 310 ! NO TITLE CALL SCOPY(NAME,LIN1,J3-J2,J2+1,J2+COL) ! TRANSFER TITLE 310 J1=J3+2 ! J1 IS NOW BEGINNING OF 2ND LINE C C GET THE 2ND LINE 315 IF(DAY.GT.EXPDAY)LIN1(COL+32)="52 ! PUT STAR ON LINE 1 IF DAY > YR AGO IF(J1.GT.70)GO TO 335 DO 320 J=J1,J1+36 IF(J.EQ.70)GO TO 325 IF(NAME(J).EQ.EXC)GO TO 325 IF(NAME(J).EQ.NULL)GO TO 325 320 CONTINUE 325 J2=J-1 ! J2 IS LAST CHAR OF 2ND LINE CALL SCOPY(NAME,LIN2,J2-J1+1,J1,COL) IF(NAME(J2+2).EQ.SPA)GO TO 330 IF(NAME(J).EQ.NULL)GO TO 330 IF(NAME(J2+2).NE."00)GO TO 335 ! THERE IS A 3RD LINE 330 CALL SCOPY(NAME,LIN2,5,71,J2-J1+3+COL) ! GET ZIP CODE GO TO 370 C C GET THE 3RD LINE 335 IF(J2.GT.69)GO TO 355 J1=J2+2 DO 340 J=J1,J1+36 IF(J.EQ.70)GO TO 345 IF(NAME(J).EQ.EXC)GO TO 345 IF(NAME(J).EQ.NULL)GO TO 345 340 CONTINUE 345 J2=J-1 CALL SCOPY(NAME,LIN3,J2-J1+1,J1,COL) IF(J2.GE.69)GO TO 350 IF(NAME(J2+2).EQ.SPA)GO TO 350 IF(NAME(J).EQ.NULL)GO TO 350 IF(NAME(J2+2) .GT. EXC)GO TO 355 ! THERE IS A 4TH LINE 350 CALL SCOPY(NAME,LIN3,5,71,J2-J1+3+COL) ! GET ZIP CODE GO TO 370 C C GET THE 4TH LINE 355 J1=J2+2 DO 360 J=J1,J1+28 IF(J.EQ.70)GO TO 365 IF(NAME(J).EQ.EXC)GO TO 365 IF(NAME(J).EQ.NULL)GO TO 365 360 CONTINUE 365 J2=J-1 CALL SCOPY(NAME,LIN4,J2-J1+1,J1,COL) CALL SCOPY(NAME,LIN4,5,71,J2-J1+3+COL) ! GET ZIP CODE 370 COL=COL+36 GO TO 395 375 IF(LNO.LT.18) GO TO 377 ! MAX OF 17 LINES PER PAGE WRITE(1,376) 376 FORMAT('1') LNO=0 377 LNO=LNO+1 IF(LNO.NE.1)GO TO 379 WRITE(1,378) ! REPRINT MAILING LIST KEY 378 FORMAT(' MAILING LIST KEY') CALL PRILIS(1, NLIST) WRITE(1,381) 381 FORMAT(' ') 379 DO 380 I=2,5 LISCOD(I)="40 ! DEFAULT IS BLANK SPACE IF(I.GT.NLIST+1)GO TO 380 LISCOD(I)="116 ! SO FAR, ASSUME, NOT ON THIS LIST IF(BITTER(COUN,I,3).NE.1)GO TO 380 LISCOD(I)="131 ! HE IS ON THIS LIST 380 CONTINUE IPORG=NAME(76) IPPROF=NAME(77) K=DAYS(MO,DA,YR,1) ! GET TODAY'S DATE IF(DAY.GT.K)DAY=0 ! DATE OF LAST CONTACT > TODAY CALL DATODA(MO,DA,YR,DAY,3) ! CHANGE DAY INTO MO, DA, AND YR WRITE(1,390)(NAME(LP),LP=1,75) WRITE(1,385)(LISCOD(J),J=2,5), IPORG,IPPROF,MO,DA, YR 385 FORMAT(10X,'LISTS ',4(A1,X),' ORG',I4,' PROF',I4, I5, 2I3) WRITE(1,140) 390 FORMAT(' ',75A1) 395 REC=REC+1 IF(REC.GT.LASREC)GO TO 400 ! REMOVE THIS TEMPORARILY IF(NBER.EQ.1)GO TO 400 ! FIN PRINTING MANY COP 1 LABEL NBER=NBER-1 IF(IMAG.EQ.1)GO TO 235 IF(COL.LT.MAXCOL)GO TO 240 400 IF(IMAG.EQ.1)GO TO 410 J=70 IF(MAXCOL.GT.41)J=108 WRITE(1,405)(LIN1(K),K=1,J) WRITE(1,405)(LIN2(K),K=1,J) WRITE(1,405)(LIN3(K),K=1,J) WRITE(1,405)(LIN4(K),K=1,J) 405 FORMAT(1X,108A1) WRITE(1,140) WRITE(1,140) IF(NBER.LE.0)GO TO 410 IF(NBER.EQ.1) GO TO 415 410 IF(REC .LE. LASREC) GO TO 235 415 CALL CLOSE(2) CALL EXIT END