C
C         ADDRESS / PHONE NO. LIST        by Bruce W. Roeckel
C       *--------------------------*
C          OPTION #1 - UPDATE
C
C
$STORAGE:2
C
C
     SUBROUTINE UPDATE
C
C          CONTROLS UPDATING OF MASTER RECORDS
C
     CHARACTER*1 SEL
     CHARACTER*25 OPTION
C
C          CALL HEADER WITH OPTION PARAMETER
C
  50 CONTINUE
     OPTION='Update Master File'
     CALL HEADER(OPTION)
C
C          PRINT OPTIONS MENU
C
     IH=1
     IV=20
     CALL UPTOP(IH,IV)
        WRITE(*,'(X)')
     CALL ULINE
        WRITE(*,'(80X)')
     CALL OFF
C
C          PRINT MAP , THEN PROCESS DATA
C
 100 CONTINUE
     CALL MAP
        IH=1
        IV=23
        CALL UPTOP(IH,IV)
        WRITE(*,150)
 150    FORMAT('    ( )dd  ( )elete  ( )dit  ( )elp  ( )uit       ',
    A          '       Option ==> [ ]       ',\)
     CALL BOLD
     IH=8
     CALL UPTOP(IH,IV)
        WRITE(*,'(A1)') 'A'
     IH=15
     CALL UPTOP(IH,IV)
        WRITE(*,'(A1)') 'D'
     IH=25
     CALL UPTOP(IH,IV)
        WRITE(*,'(A1)') 'E'
     IH=33
     CALL UPTOP(IH,IV)
        WRITE(*,'(A1)') 'H'
     IH=41
     CALL UPTOP(IH,IV)
        WRITE(*,'(A1)') 'Q'
     IH=75
     CALL UPTOP(IH,IV)
     CALL OFF
     ILEN=4
     CALL CURLT(ILEN)
        READ(*,'(A1)') SEL
           IF((SEL.EQ.'A') .OR. (SEL.EQ.'a')) THEN
              CALL ADDIT
           ELSEIF((SEL.EQ.'D') .OR. (SEL.EQ.'d')) THEN
              CALL DELIT
           ELSEIF((SEL.EQ.'E') .OR. (SEL.EQ.'e')) THEN
              CALL EDTIT
           ELSEIF((SEL.EQ.'Q') .OR. (SEL.EQ.'q')) THEN
              CALL SORTIT
              RETURN
           ELSEIF((SEL.EQ.'H') .OR. (SEL.EQ.'h')) THEN
              SEL='1'
              LU=15
              CALL HELP(SEL,LU)
              GOTO 50
           ENDIF
     GOTO 100
     END
C
C
C
     SUBROUTINE DELIT
C
     COMMON/MAIN1/ LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
     CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
     CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
     CHARACTER PH1(200)*14,PH2(200)*14
C
     COMMON/MAIN2/ STRID,SORT,MNUM
     INTEGER*4 STRID(200),SORT(200),MNUM
C
     CHARACTER*1 LNAME(12),SEL
     INTEGER KEEP
C
     COMMON/LETT/ALPHA,ALPH2
     CHARACTER*1 ALPHA(26),ALPH2(26)
C
C          ISSUE INSTRUCTIONS
C
     IH=1
     IV=23
     CALL UPTOP(IH,IV)
     CALL BOLD
        WRITE(*,50)
  50    FORMAT('        (D)elete .... Please enter the first 3 ',
    A          'characters of last name        ')
     CALL OFF
C
C          READ LAST NAME, FIND A MATCH
C
     IV=9
     IH=22
     CALL UPTOP(IH,IV)
        READ(*,'(12A1)') (LNAME(K),K=1,12)
C
C          SEARCH THROUGH ALL RECORDS FOR ENTRY
C
     KEEP=0
 100 CONTINUE
     DO 300 I=KEEP+1,MNUM
     DO 200 K=1,3
     IC=0
     IM=0
        DO 150 J=1,26
        IF((LNAME(K).EQ.ALPHA(J)) .OR. (LNAME(K).EQ.ALPH2(J)))IC=J
        IF((LAST(K,I).EQ.ALPHA(J)) .OR. (LAST(K,I).EQ.ALPH2(J)))IM=J
 150    CONTINUE
     IF(IC.NE.IM) GOTO 300
 200 CONTINUE
     KEEP=I
     GOTO 400
 300 CONTINUE
     IH=1
     IV=23
     CALL UPTOP(IH,IV)
     CALL BOLD
     CALL BLINK
     CALL BELL
        WRITE(*,350)
 350    FORMAT('                                                  ',
    A          '  No Match ... Press <RET>  ',\)
        READ(*,'(A1)') IDUM
     RETURN
 400 CONTINUE
C
C          NOW, DISPLAY ALL DATA FOR MATCH
C
     IV=9
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(12A1)') (LAST(J,KEEP),J=1,12)
     IV=9
     IH=36
     CALL UPTOP(IH,IV)
        WRITE(*,'(A23)') FIRST(KEEP)
     IV=11
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(A30)') ADD1(KEEP)
     IV=13
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(A30)') ADD2(KEEP)
     IV=15
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(A23)') CITY(KEEP)
     IV=15
     IH=53
     CALL UPTOP(IH,IV)
        WRITE(*,'(A2)') STATE(KEEP)
     IV=15
     IH=61
     CALL UPTOP(IH,IV)
        WRITE(*,'(A5)')  ZIP(KEEP)
     IV=17
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(A14)')  PH1(KEEP)
     IV=17
     IH=46
     CALL UPTOP(IH,IV)
        WRITE(*,'(A14)')  PH2(KEEP)
C
C          ASK IF MATCH O.K.
C
     IH=1
     IV=23
     CALL UPTOP(IH,IV)
     CALL BOLD
     CALL BLINK
        WRITE(*,500)
 500    FORMAT('                                               ',
    A          'Delete entry ? (Y,N,Q)  [ ]    ',\)
     CALL OFF
        IV=6
        CALL CURLT(IV)
        READ(*,'(A1)') SEL
           IF((SEL.EQ.'N') .OR. (SEL.EQ.'n')) GOTO 100
           IF((SEL.EQ.'Y') .OR. (SEL.EQ.'y')) GOTO 600
           RETURN
 600 CONTINUE
C
C         DELETE THIS ENTRY
C
     DO 800 J=1,12
 800 LAST(J,KEEP)=LAST(J,MNUM)
     FIRST(KEEP)=FIRST(MNUM)
     ADD1(KEEP)=ADD1(MNUM)
     ADD2(KEEP)=ADD2(MNUM)
     CITY(KEEP)=CITY(MNUM)
     STATE(KEEP)=STATE(MNUM)
     ZIP(KEEP)=ZIP(MNUM)
     PH1(KEEP)=PH1(MNUM)
     PH2(KEEP)=PH2(MNUM)
     SORT(KEEP)=SORT(MNUM)
     STRID(KEEP)=STRID(MNUM)
     MNUM=MNUM-1
     RETURN
     END
C
C
C
     SUBROUTINE EDTIT
C
     COMMON/MAIN1/ LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
     CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
     CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
     CHARACTER PH1(200)*14,PH2(200)*14
C
     COMMON/MAIN2/ STRID,SORT,MNUM
     INTEGER*4 STRID(200),SORT(200),MNUM
C
     CHARACTER*1 LNAME(12),SEL
     INTEGER*4 MULT
     INTEGER KEEP,RESHOW
C
     COMMON/LETT/ALPHA,ALPH2
     CHARACTER*1 ALPHA(26),ALPH2(26)
C
C          ISSUE INSTRUCTIONS
C
     RESHOW=0
     IH=1
     IV=23
     CALL UPTOP(IH,IV)
     CALL BOLD
        WRITE(*,50)
  50    FORMAT('        (E)dit ...... Please enter the first 3 ',
    A          'characters of last name        ')
     CALL OFF
C
C          READ LAST NAME, FIND A MATCH
C
     IV=9
     IH=22
     CALL UPTOP(IH,IV)
        READ(*,'(12A1)') (LNAME(K),K=1,12)
C
C          SEARCH THROUGH ALL RECORDS FOR ENTRY
C
     KEEP=0
 100 CONTINUE
     DO 300 I=KEEP+1,MNUM
     DO 200 K=1,3
     IC=0
     IM=0
        DO 150 J=1,26
        IF((LNAME(K).EQ.ALPHA(J)) .OR. (LNAME(K).EQ.ALPH2(J)))IC=J
        IF((LAST(K,I).EQ.ALPHA(J)) .OR. (LAST(K,I).EQ.ALPH2(J)))IM=J
 150    CONTINUE
     IF(IC.NE.IM) GOTO 300
 200 CONTINUE
     KEEP=I
     GOTO 400
 300 CONTINUE
     IH=1
     IV=23
     CALL UPTOP(IH,IV)
     CALL BOLD
     CALL BLINK
     CALL BELL
        WRITE(*,350)
 350    FORMAT('                                                  ',
    A          '  No Match ... Press <RET>  ',\)
        READ(*,'(A1)') IDUM
        RETURN
 400 CONTINUE
C
C          NOW, DISPLAY ALL DATA FOR MATCH
C
     IV=9
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(12A1)') (LAST(J,KEEP),J=1,12)
     IV=9
     IH=36
     CALL UPTOP(IH,IV)
        WRITE(*,'(A23)') FIRST(KEEP)
     IV=11
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(A30)') ADD1(KEEP)
     IV=13
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(A30)') ADD2(KEEP)
     IV=15
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(A23)') CITY(KEEP)
     IV=15
     IH=53
     CALL UPTOP(IH,IV)
        WRITE(*,'(A2)') STATE(KEEP)
     IV=15
     IH=61
     CALL UPTOP(IH,IV)
        WRITE(*,'(A5)')  ZIP(KEEP)
     IV=17
     IH=22
     CALL UPTOP(IH,IV)
        WRITE(*,'(A14)')  PH1(KEEP)
     IV=17
     IH=46
     CALL UPTOP(IH,IV)
        WRITE(*,'(A14)')  PH2(KEEP)
C
C          ASK IF MATCH O.K. IF THIS IS THE 1ST TIME THROUGH
C
     IF(RESHOW.EQ.1) GOTO 600
     IH=1
     IV=23
     CALL UPTOP(IH,IV)
     CALL BOLD
     CALL BLINK
        WRITE(*,500)
 500    FORMAT('                                               ',
    A          '  Edit entry ? (Y,N,Q)  [ ]    ',\)
     CALL OFF
        IV=6
        CALL CURLT(IV)
        READ(*,'(A1)') SEL
           IF((SEL.EQ.'N') .OR. (SEL.EQ.'n')) GOTO 100
           IF((SEL.EQ.'Y') .OR. (SEL.EQ.'y')) GOTO 600
           RETURN
 600 CONTINUE
C
C         ISSUE INSTRUCTIONS
C
     RESHOW=0
     IH=48
     IV=23
     CALL UPTOP(IH,IV)
     CALL BOLD
        WRITE(*,'(A30)') '   <RET> = tab w/o change     '
     CALL OFF
C
C          NOW, STEP THROUGH DATA PROMPTS
C
     ICNT=MNUM+1
     IV=9
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(12A1)') (LAST(J,ICNT),J=1,12)
           IF(LAST(1,ICNT).NE.' ') THEN
              RESHOW=1
              DO 800 I=1,12
 800          LAST(I,KEEP)=LAST(I,ICNT)
C
C          CREATE SORT PARAMETERS BASED ON LAST NAME
C
              MULT=10000
              SORT(KEEP)=0
              DO 900 I=1,3
              DO 850 J=1,26
              IF((LAST(I,KEEP).EQ.ALPHA(J)) .OR.
    A            (LAST(I,KEEP).EQ.ALPH2(J))) THEN
                  SORT(KEEP)=SORT(KEEP) + J*MULT
                  MULT=MULT/100
                  GOTO 900
              ENDIF
 850          CONTINUE
              MULT=MULT/100
 900          CONTINUE
           ENDIF
C
C         NOW GET THE REST OF THE CHANGES
C
     IV=9
     IH=36
     CALL UPTOP(IH,IV)
           READ(*,'(A23)') FIRST(ICNT)
           IF(FIRST(ICNT).NE.' ') THEN
              RESHOW=1
              FIRST(KEEP)=FIRST(ICNT)
           ENDIF
     IV=11
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(A30)') ADD1(ICNT)
           IF(ADD1(ICNT).NE.' ') THEN
              RESHOW=1
              ADD1(KEEP)=ADD1(ICNT)
           ENDIF
     IV=13
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(A30)') ADD2(ICNT)
           IF(ADD2(ICNT).NE.' ') THEN
              RESHOW=1
              ADD2(KEEP)=ADD2(ICNT)
           ENDIF
     IV=15
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(A23)') CITY(ICNT)
           IF(CITY(ICNT).NE.' ') THEN
              RESHOW=1
              CITY(KEEP)=CITY(ICNT)
           ENDIF
     IV=15
     IH=53
     CALL UPTOP(IH,IV)
           READ(*,'(A2)') STATE(ICNT)
           IF(STATE(ICNT).NE.' ') THEN
              RESHOW=1
              STATE(KEEP)=STATE(ICNT)
           ENDIF
     IV=15
     IH=61
     CALL UPTOP(IH,IV)
           READ(*,'(A5)')  ZIP(ICNT)
           IF( ZIP(ICNT).NE.' ') THEN
              RESHOW=1
              ZIP(KEEP)= ZIP(ICNT)
           ENDIF
     IV=17
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(A14)')  PH1(ICNT)
           IF( PH1(ICNT).NE.' ')  THEN
              RESHOW=1
              PH1(KEEP)= PH1(ICNT)
           ENDIF
     IV=17
     IH=46
     CALL UPTOP(IH,IV)
           READ(*,'(A14)')  PH2(ICNT)
           IF( PH2(ICNT).NE.' ')  THEN
              RESHOW=1
              PH2(KEEP)= PH2(ICNT)
           ENDIF
     IF(RESHOW.EQ.1) GOTO 400
     RETURN
     END
C
C
C
     SUBROUTINE ADDIT
C
     COMMON/MAIN1/ LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
     CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
     CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
     CHARACTER PH1(200)*14,PH2(200)*14
C
     COMMON/MAIN2/ STRID,SORT,MNUM
     INTEGER*4 STRID(200),SORT(200),MNUM
C
     INTEGER*4 KEEP
C
     COMMON/LETT/ALPHA,ALPH2
     CHARACTER*1 ALPHA(26),ALPH2(26)
C
C          ISSUE INSTRUCTIONS
C
     IH=1
     IV=23
     CALL UPTOP(IH,IV)
     CALL BOLD
        WRITE(*,50)
  50    FORMAT('        (A)dd ....... Please hit <RET> to tab f',
    A          'rom item-to-item               ')
     CALL OFF
C
C          NOW, STEP THROUGH DATA PROMPTS
C
     MNUM=MNUM+1
     IF(MNUM.GT.200) THEN
        CALL CLS
        WRITE(*,'(2X,A30)') 'MASTER FILE RECORD OVERFLOW'
        STOP
     ENDIF
     IV=9
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(12A1)') (LAST(J,MNUM),J=1,12)
           IF(LAST(1,MNUM).EQ.' ') THEN
              MNUM=MNUM-1
              RETURN
           ENDIF
C
C          CREATE SORT PARAMETERS BASED ON LAST NAME
C
           KEEP=10000
           SORT(MNUM)=0
           DO 400 I=1,3
           DO 300 J=1,26
           IF((LAST(I,MNUM).EQ.ALPHA(J)) .OR.
    A         (LAST(I,MNUM).EQ.ALPH2(J))) THEN
               SORT(MNUM)=SORT(MNUM) + J*KEEP
               KEEP=KEEP/100
               GOTO 400
           ENDIF
 300       CONTINUE
           KEEP=KEEP/100
 400       CONTINUE
C
C          FIND NEXT HIGHEST STRUCTURE ID
C
     IBIG=0
     DO 500 J=1,MNUM-1
     IF(STRID(J).GT.IBIG) IBIG=STRID(J)
 500 CONTINUE
     STRID(MNUM)=IBIG+1
     IF(STRID(MNUM).GT.999) THEN
        CALL CLS
        WRITE(*,'(2X,A21)') 'STRUCTURE ID OVERFLOW'
        STOP
     ENDIF
C
C          NOW, GET THE REST OF THE DATA
C
     IV=9
     IH=36
     CALL UPTOP(IH,IV)
           READ(*,'(A23)') FIRST(MNUM)
     IV=11
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(A30)') ADD1(MNUM)
     IV=13
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(A30)') ADD2(MNUM)
     IV=15
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(A23)') CITY(MNUM)
     IV=15
     IH=53
     CALL UPTOP(IH,IV)
           READ(*,'(A2)') STATE(MNUM)
     IV=15
     IH=61
     CALL UPTOP(IH,IV)
           READ(*,'(A5)')  ZIP(MNUM)
     IV=17
     IH=22
     CALL UPTOP(IH,IV)
           READ(*,'(A14)')  PH1(MNUM)
     IV=17
     IH=46
     CALL UPTOP(IH,IV)
           READ(*,'(A14)')  PH2(MNUM)
     RETURN
     END
C
C
C
     SUBROUTINE MAP
C
C          PRINT MAP FOR FULL-SCREEN EDITING FEATURE
C
     IV=8
     IH=1
     CALL UPTOP(IH,IV)
C
     CALL OFF
     CALL BOLD
        WRITE(*,'(/,10X,A10,\)') 'Last Name '
     CALL OFF
     WRITE(*,'(A37)') '____________  _______________________'
     CALL BOLD
        WRITE(*,'(/,10X,A10,\)') '  Address '
     CALL OFF
     WRITE(*,'(A30)') '______________________________'
     WRITE(*,'(/,20X,A30)') '______________________________'
     CALL BOLD
        WRITE(*,'(/,10X,A10,\)') '     City '
     CALL OFF
     WRITE(*,'(A23,\)') '_______________________'
     CALL BOLD
        WRITE(*,'(A8,\)') '  State '
     CALL OFF
     WRITE(*,'(A2,\)') '__'
     CALL BOLD
        WRITE(*,'(A6,\)') '  Zip '
     CALL OFF
     WRITE(*,'(A5)') '_____'
     CALL BOLD
       WRITE(*,'(/,10X,A10,\)') '  Home PH '
     CALL OFF
     WRITE(*,'(A14,\)') '(___) ___-____'
     CALL BOLD
       WRITE(*,'(A10,\)') '  Work PH '
     CALL OFF
     WRITE(*,'(A14)') '(___) ___-____'
C
     RETURN
     END

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.