home *** CD-ROM | disk | FTP | other *** search
/ ftp.update.uu.se / ftp.update.uu.se.2014.03.zip / ftp.update.uu.se / pub / rainbow / msdos / decus / RB113 / name2.for < prev    next >
Text File  |  1995-05-28  |  10KB  |  406 lines
  1. C
  2. C         IMPORTANT NAMES & DATES         by Bruce W. Roeckel
  3. C       *--------------------------*                         
  4. C          OPTION #2 - UPDATE                                
  5. C
  6. C
  7. $STORAGE:2
  8. C
  9. C
  10.       SUBROUTINE UPDATE
  11. C
  12. C          CONTROLS UPDATING OF MASTER RECORDS
  13. C
  14.       CHARACTER*1 SEL
  15.       CHARACTER*25 OPTION
  16. C
  17. C          CALL HEADER WITH OPTION PARAMETER
  18. C
  19.    50 CONTINUE
  20.       OPTION='Update Names & Dates'
  21.       CALL HEADER(OPTION)
  22. C
  23. C          PRINT OPTIONS MENU          
  24. C
  25.       IH=1
  26.       IV=20
  27.       CALL UPTOP(IH,IV)
  28.          WRITE(*,'(X)')
  29.       CALL ULINE
  30.          WRITE(*,'(80X)')
  31.       CALL OFF
  32. C
  33. C          PRINT MAP , THEN PROCESS DATA
  34. C
  35.       CALL MAP
  36.   100 CONTINUE
  37.       IH=1
  38.       IV=23
  39.       CALL UPTOP(IH,IV)
  40.          WRITE(*,150)
  41.   150    FORMAT('    ( )dit    ( )elp    ( )uit                    ',
  42.      A          '       Option ==> [ ]       ',\)
  43.       CALL BOLD
  44.       CALL UPTOP(IH+7 ,IV)
  45.          WRITE(*,'(A1)') 'E'
  46.       CALL UPTOP(IH+17,IV)
  47.          WRITE(*,'(A1)') 'H'
  48.       CALL UPTOP(IH+27,IV)
  49.          WRITE(*,'(A1)') 'Q'
  50.       CALL OFF
  51.       CALL UPTOP(IH+71,IV)
  52.          READ(*,'(A1)') SEL
  53.             IF((SEL.EQ.'E') .OR. (SEL.EQ.'e')) THEN
  54.                CALL FINDIT
  55.                CALL MAP
  56.             ELSEIF((SEL.EQ.'Q') .OR. (SEL.EQ.'q')) THEN
  57.                CALL FILLUP
  58.                CALL WRDATE
  59.                RETURN
  60.             ELSEIF((SEL.EQ.'H') .OR. (SEL.EQ.'h')) THEN
  61.                SEL='2'
  62.                LU=15
  63.                CALL HELP(SEL,LU)
  64.                GOTO 50
  65.             ENDIF
  66.       GOTO 100
  67.       END
  68. C
  69. C
  70. C
  71.       SUBROUTINE FINDIT
  72. C
  73. C            THIS ROUTINE FINDS SELECTION TO EDIT
  74. C
  75.       COMMON/MAIN1/ LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
  76.       CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
  77.       CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
  78.       CHARACTER PH1(200)*14,PH2(200)*14
  79. C
  80.       COMMON/MAIN2/ STRID,JULIAN,MNUM
  81.       INTEGER STRID(200),JULIAN(366,5),MNUM
  82. C
  83.       CHARACTER LNAME(12)*1,SEL*1
  84.       INTEGER KEEP
  85. C
  86.       COMMON/LETT/ALPHA,ALPH2
  87.       CHARACTER*1 ALPHA(26),ALPH2(26)
  88. C
  89. C          ISSUE INSTRUCTIONS           
  90. C
  91.       IH=1
  92.       IV=23
  93.       CALL UPTOP(IH,IV)
  94.       CALL BOLD
  95.          WRITE(*,50)
  96.    50    FORMAT('        (E)dit ...... Please enter the first 3 ',
  97.      A          'characters of last name        ')
  98.       CALL OFF
  99. C
  100. C          READ LAST NAME, FIND A MATCH
  101. C
  102.       IV=7 
  103.       IH=22 
  104.       CALL UPTOP(IH,IV)
  105.          READ(*,'(12A1)') (LNAME(K),K=1,12)
  106. C
  107. C          SEARCH THROUGH ALL RECORDS FOR ENTRY
  108. C
  109.       KEEP=0
  110.   100 CONTINUE
  111.       DO 300 I=KEEP+1,MNUM
  112.       DO 200 K=1,3
  113.       IC=0
  114.       IM=0
  115.          DO 150 J=1,26
  116.          IF((LNAME(K).EQ.ALPHA(J)) .OR. (LNAME(K).EQ.ALPH2(J)))IC=J
  117.          IF((LAST(K,I).EQ.ALPHA(J)) .OR. (LAST(K,I).EQ.ALPH2(J)))IM=J
  118.   150    CONTINUE
  119.       IF(IC.NE.IM) GOTO 300
  120.   200 CONTINUE
  121. C
  122. C          ASK IF MATCH O.K.            
  123. C
  124.       KEEP=I
  125.       CALL SHOWIT(KEEP)
  126.       IH=1
  127.       IV=23
  128.       CALL UPTOP(IH,IV)
  129.       CALL BOLD
  130.       CALL BLINK
  131.          WRITE(*,500)
  132.   500    FORMAT('                                               ',
  133.      A          '  Edit entry ? (Y,N,Q)  [ ]    ',\)
  134.       CALL OFF
  135.          IV=6
  136.          CALL CURLT(IV)
  137.          READ(*,'(A1)') SEL
  138.             IF((SEL.EQ.'N') .OR. (SEL.EQ.'n')) GOTO 100
  139.             IF((SEL.EQ.'Y') .OR. (SEL.EQ.'y')) GOTO 400
  140.             RETURN
  141.   300 CONTINUE
  142.       IH=1
  143.       IV=23
  144.       CALL UPTOP(IH,IV)
  145.       CALL BOLD
  146.       CALL BLINK
  147.       CALL BELL
  148.          WRITE(*,350)
  149.   350    FORMAT('                                                  ',
  150.      A          '  No Match ... Press <RET>  ',\)
  151.          READ(*,'(A1)') IDUM
  152.          RETURN  
  153.   400 CONTINUE
  154.       CALL EDITIT(KEEP)
  155.       RETURN
  156.       END
  157. C
  158. C
  159. C
  160.       SUBROUTINE SHOWIT(KEEP)
  161. C
  162. C          THIS ROUTINE WILL DISPLAY SELECTION ON SCREEN
  163. C
  164.       COMMON/MAIN1/ LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
  165.       CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
  166.       CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
  167.       CHARACTER PH1(200)*14,PH2(200)*14
  168. C
  169.       COMMON/MAIN2/ STRID,JULIAN,MNUM
  170.       INTEGER STRID(200),JULIAN(366,5),MNUM
  171. C
  172.       COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
  173.       CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
  174. C
  175. C             DISPLAY SELECTED RECORD OF INFORMATION
  176. C
  177.       IV=7 
  178.       IH=22
  179.       CALL UPTOP(IH,IV)
  180.          WRITE(*,'(12A1)') (LAST(J,KEEP),J=1,12)
  181.       IV=7 
  182.       IH=36
  183.       CALL UPTOP(IH,IV)
  184.          WRITE(*,'(A23)') FIRST(KEEP)
  185.       IKEY = STRID(KEEP)
  186.       IV=9 
  187.       IH=32
  188.       CALL UPTOP(IH,IV)
  189.          IF(ANIV(IKEY).NE.' ') THEN
  190.             WRITE(*,'(A8)') ANIV(IKEY)
  191.          ELSE
  192.             WRITE(*,'(A8)') '__/__/__'
  193.          ENDIF
  194.       IV=11
  195.       IH=32
  196.       CALL UPTOP(IH,IV)
  197.          IF(NAME(1,IKEY).NE.' ' .OR. BDAY(1,IKEY).NE.' ') THEN
  198.             WRITE(*,'(A12,2X,A8)') NAME(1,IKEY),BDAY(1,IKEY)
  199.          ELSE
  200.             WRITE(*,'(A23)') '____________  __/__/__ '
  201.          ENDIF
  202.       IV=12
  203.       IH=32
  204.       CALL UPTOP(IH,IV)
  205.          IF(NAME(2,IKEY).NE.' ' .OR. BDAY(2,IKEY).NE.' ') THEN
  206.             WRITE(*,'(A12,2X,A8)') NAME(2,IKEY),BDAY(2,IKEY)
  207.          ELSE
  208.             WRITE(*,'(A23)') '____________  __/__/__ '
  209.          ENDIF
  210.       IV=13
  211.       IH=32
  212.       CALL UPTOP(IH,IV)
  213.          IF(NAME(3,IKEY).NE.' ' .OR. BDAY(3,IKEY).NE.' ') THEN
  214.             WRITE(*,'(A12,2X,A8)') NAME(3,IKEY),BDAY(3,IKEY)
  215.          ELSE
  216.             WRITE(*,'(A23)') '____________  __/__/__ '
  217.          ENDIF
  218.       IV=14
  219.       IH=32
  220.       CALL UPTOP(IH,IV)
  221.          IF(NAME(4,IKEY).NE.' ' .OR. BDAY(4,IKEY).NE.' ') THEN
  222.             WRITE(*,'(A12,2X,A8)') NAME(4,IKEY),BDAY(4,IKEY)
  223.          ELSE
  224.             WRITE(*,'(A23)') '____________  __/__/__ '
  225.          ENDIF
  226.       IV=15
  227.       IH=32
  228.       CALL UPTOP(IH,IV)
  229.          IF(NAME(5,IKEY).NE.' ' .OR. BDAY(5,IKEY).NE.' ') THEN
  230.             WRITE(*,'(A12,2X,A8)') NAME(5,IKEY),BDAY(5,IKEY)
  231.          ELSE
  232.             WRITE(*,'(A23)') '____________  __/__/__ '
  233.          ENDIF
  234.       IV=16 
  235.       IH=32
  236.       CALL UPTOP(IH,IV)
  237.          IF(NAME(6,IKEY).NE.' ' .OR. BDAY(6,IKEY).NE.' ') THEN
  238.             WRITE(*,'(A12,2X,A8)') NAME(6,IKEY),BDAY(6,IKEY)
  239.          ELSE
  240.             WRITE(*,'(A23)') '____________  __/__/__ '
  241.          ENDIF
  242.       IV=18
  243.       IH=40
  244.       CALL UPTOP(IH,IV)
  245.          IF(XMAS(1,IKEY).NE.' ' ) THEN
  246.             WRITE(*,'(6(A2,1X))') (XMAS(K,IKEY),K=1,6)
  247.          ELSE
  248.             WRITE(*,'(A17)') '__ __ __ __ __ __'
  249.          ENDIF
  250.       IV=19 
  251.       IH=40
  252.       CALL UPTOP(IH,IV)
  253.          IF(XMAS(7,IKEY).NE.' ' ) THEN
  254.             WRITE(*,'(6(A2,1X))') (XMAS(K,IKEY),K=7,12)
  255.          ELSE
  256.             WRITE(*,'(A17)') '__ __ __ __ __ __'
  257.          ENDIF
  258.       RETURN
  259.       END
  260. C
  261. C
  262. C
  263.       SUBROUTINE EDITIT(KEEP)
  264. C
  265. C         THIS ROUTINE EXECUTES THE FULL SCREEN EDITOR
  266. C
  267.       COMMON/MAIN1/ LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
  268.       CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
  269.       CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
  270.       CHARACTER PH1(200)*14,PH2(200)*14
  271. C
  272.       COMMON/MAIN2/ STRID,JULIAN,MNUM
  273.       INTEGER STRID(200),JULIAN(366,5),MNUM
  274. C
  275.       COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
  276.       CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
  277. C
  278.       CHARACTER TDATE*8,TNAME*12
  279.       INTEGER KEEP,RESHOW
  280. C
  281. C         ISSUE INSTRUCTIONS 
  282. C
  283.       IKEY=STRID(KEEP)
  284.   100 CONTINUE
  285.       RESHOW=0
  286.       IH=48
  287.       IV=23
  288.       CALL UPTOP(IH,IV)
  289.       CALL BOLD
  290.          WRITE(*,'(A30)') '   <RET> = tab w/o change     '
  291.       CALL OFF
  292. C
  293. C          NOW, EDIT ANNIVERSARY DATE
  294. C
  295.       IV=9 
  296.       IH=32
  297.       CALL UPTOP(IH,IV)
  298.             READ(*,'(A8)') TDATE
  299.             IF(TDATE.EQ.'*') THEN
  300.                RESHOW=1
  301.                ANIV(IKEY) = ' '
  302.             ELSEIF(TDATE.NE.' ') THEN
  303.                RESHOW=1
  304.                ANIV(IKEY) = TDATE
  305.             ENDIF
  306. C
  307. C          DO ALL BIRTHDAYS NEXT
  308. C
  309.       IV=10
  310.       DO 200 K=1,6
  311.       IV=IV+1
  312.       IH=32
  313.       CALL UPTOP(IH,IV)
  314.             READ(*,'(A12)') TNAME
  315.             IF(TNAME.EQ.'*') THEN
  316.                RESHOW=1
  317.                NAME(K,IKEY) = ' '
  318.             ELSEIF(TNAME.NE.' ') THEN
  319.                RESHOW=1
  320.                NAME(K,IKEY) = TNAME 
  321.             ENDIF
  322.       IH=46
  323.       CALL UPTOP(IH,IV)
  324.             READ(*,'(A8)') TDATE
  325.             IF(TDATE.EQ.'*') THEN
  326.                RESHOW=1
  327.                BDAY(K,IKEY) = ' '
  328.             ELSEIF(TDATE.NE.' ') THEN
  329.                RESHOW=1
  330.                BDAY(K,IKEY) = TDATE
  331.             ENDIF
  332.   200 CONTINUE
  333. C
  334. C             BLAST THROUGH THE XMAS CARD STUFF
  335. C
  336.       IH=37
  337.       IV=18
  338.       DO 700 K=1,12
  339.       IF(K.EQ.7) THEN 
  340.          IV=19
  341.          IH=37
  342.       ENDIF
  343.       IH=IH+3
  344.       CALL UPTOP(IH,IV)
  345.          READ(*,'(A2)') TNAME
  346.          IF(TNAME.EQ.'*') THEN
  347.             RESHOW=1
  348.             XMAS(K,IKEY) = ' '
  349.          ELSEIF(TNAME.NE.' ') THEN
  350.             RESHOW=1
  351.             XMAS(K,IKEY) = TNAME
  352.          ENDIF
  353.   700 CONTINUE
  354. C
  355. C            SEE IF WE SHOULD REDISPLAY IF CHANGES MADE
  356. C
  357.       IF(RESHOW.EQ.1) THEN
  358.          CALL SHOWIT(KEEP)
  359.          GOTO 100
  360.       ENDIF
  361.       RETURN
  362.       END
  363. C
  364. C
  365. C
  366.       SUBROUTINE MAP
  367. C
  368. C          PRINT MAP FOR FULL-SCREEN EDITING FEATURE   
  369. C
  370.       IV=7
  371.       IH=1
  372.       CALL UPTOP(IH,IV)
  373. C
  374.       CALL OFF
  375.       CALL BOLD
  376.          WRITE(*,'(   9X,A10,\)') 'Last Name '
  377.       CALL OFF
  378.       WRITE(*,'(A37)') '____________  _______________________'
  379.       CALL BOLD
  380.          WRITE(*,'(/,18X,A12,\)') 'Anniversary '
  381.       CALL OFF
  382.       WRITE(*,'(A8)') '__/__/__'
  383.       CALL BOLD
  384.          WRITE(*,'(/,20X,A10,\)') 'Names and '
  385.       CALL OFF
  386.       WRITE(*,'(A23)') '____________  __/__/__ '
  387.       CALL BOLD
  388.          WRITE(*,'(  19X,A10,\)') 'Birthdays '
  389.       CALL OFF
  390.       WRITE(*,'(A23)') '____________  __/__/__ '
  391.       WRITE(*,'(30X,A23)') '____________  __/__/__ '
  392.       WRITE(*,'(30X,A23)') '____________  __/__/__ '
  393.       WRITE(*,'(30X,A23)') '____________  __/__/__ '
  394.       WRITE(*,'(30X,A23)') '____________  __/__/__ '
  395.       CALL BOLD
  396.          WRITE(*,'(/,10X,A28,\)') 'Xmas Cards Sent      Years: '
  397.       CALL OFF
  398.       WRITE(*,'(A17)') '__ __ __ __ __ __'
  399.       CALL BOLD
  400.          WRITE(*,'(   9X,A28,\)') 'Xmas Cards Received  Years: '
  401.       CALL OFF
  402.       WRITE(*,'(A17)') '__ __ __ __ __ __'
  403. C
  404.       RETURN
  405.       END
  406.