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 / RB117 / vehic3.for < prev    next >
Text File  |  1995-05-28  |  10KB  |  408 lines
  1. C
  2. C         VEHICLE MAINTENANCE PRGM        by Bruce W. Roeckel
  3. C       *--------------------------*                         
  4. C           OPTION #3 - MILEAGE   
  5. C
  6. C
  7. $STORAGE:2
  8. C
  9. C
  10.       SUBROUTINE MILES
  11. C
  12. C          THIS ROUTINE HANDLES ALL THE MILEAGE UPDATING
  13. C
  14.       IMPLICIT INTEGER (A-Z)
  15.       CHARACTER OPTION*25,ICODE*1
  16. C
  17. C           LIST ALL CARS, SELECT ONE TO WORK WITH
  18. C
  19.       SEL=0
  20.       TYPE=1
  21.       OPTION='Update Mileage Data'
  22.       CALL HEADER(OPTION)
  23.       CALL LISTEM(TYPE,SEL)
  24.       IF(SEL.EQ.0) RETURN
  25.       CALL RDMILE(SEL)
  26. C
  27. C           PRINT NAME AT TOP OF SCREEN
  28. C
  29.    50 CONTINUE
  30.       CALL HEADER(OPTION)
  31.       CALL DNAME(SEL)
  32. C
  33. C         DRAW SOLID LINE
  34. C
  35.       CALL MOVEIT(1,21)
  36.       CALL BOLD
  37.       CALL ULINE
  38.          WRITE(*,'(80X)')
  39.       CALL OFF
  40. C
  41. C          DRAW THE PROMPT LINE
  42. C
  43.    75 CONTINUE
  44.       CALL MAP2
  45.       CALL MOVEIT(1,23)
  46.          WRITE(*,'(7X,A35,A35,\)') 
  47.      A       '( )dd   ( )elete   ( )dit   ( )elp ',
  48.      B       '  ( )uit       Option ==> [ ]      '
  49.       CALL BOLD
  50.       CALL UPTOP(11,23)
  51.          WRITE(*,'(A1)') 'A'
  52.       CALL UPTOP(19,23)
  53.          WRITE(*,'(A1)') 'D'
  54.       CALL UPTOP(30,23)
  55.          WRITE(*,'(A1)') 'E'
  56.       CALL UPTOP(39,23)
  57.          WRITE(*,'(A1)') 'H'
  58.       CALL UPTOP(48,23)
  59.          WRITE(*,'(A1)') 'Q'
  60.   100 CONTINUE
  61.       CALL UPTOP(75,23)
  62.       CALL OFF
  63.       CALL CURLT(4)
  64.       READ(*,'(A1)',ERR=100) ICODE
  65. C
  66. C            BRANCH ON REQUESTED OPTION
  67. C
  68.       IF(ICODE.EQ.'Q' .OR. ICODE.EQ.'q') THEN
  69.          CALL MOVEIT(1,23)
  70.          CALL WRMILE(SEL)
  71.          RETURN
  72.       ELSEIF(ICODE.EQ.'H' .OR. ICODE.EQ.'h') THEN
  73.          ICODE='3'
  74.          IUNIT=15
  75.          CALL HELP(ICODE,IUNIT)
  76.          GOTO 50 
  77.       ELSEIF(ICODE.EQ.'A' .OR. ICODE.EQ.'a') THEN
  78.          CALL ADDIT(SEL)
  79.          GOTO 75 
  80.       ELSEIF(ICODE.EQ.'D' .OR. ICODE.EQ.'d') THEN
  81.          CALL DELETE(SEL)
  82.          GOTO 75
  83.       ELSEIF(ICODE.EQ.'E' .OR. ICODE.EQ.'e') THEN
  84.          CALL EDITML(SEL)
  85.          GOTO 75 
  86.       ELSE
  87.          CALL BELL
  88.          GOTO 100
  89.       ENDIF
  90.       END
  91. C
  92. C
  93. C
  94.       SUBROUTINE MAP2
  95. C
  96. C             DISPLAY FULL-SCREEN-EDIT MAP
  97. C
  98.       CALL UPTOP(1,12)
  99.       CALL BOLD
  100.       WRITE(*,100)
  101.   100 FORMAT(
  102.      A  /,10X,'     Date Purchased:                           ',
  103.      B  /,10X,'  Gallons Purchased:                           ',
  104.      C  /,10X,'   Odometer Reading:                           ',
  105.      D //,10X,'      Activity Code: Trip     City             ',
  106.      E  /,10X,'Description of Trip:                           ')
  107.       CALL OFF
  108. C
  109.       CALL UPTOP(33,13)
  110.          WRITE(*,'(A8)') '__/__/__'
  111.       CALL UPTOP(33,14)
  112.          WRITE(*,'(A9)') '_________'
  113.       CALL UPTOP(33,15)
  114.          WRITE(*,'(A9)') '_________'
  115.       CALL UPTOP(38,17)
  116.          WRITE(*,'(A1)') '_'
  117.       CALL UPTOP(47,17)
  118.          WRITE(*,'(A1)') '_'
  119.       CALL UPTOP(33,18)
  120.          WRITE(*,'(A25)') '_________________________'
  121. C
  122.       RETURN 
  123.       END
  124. C
  125. C
  126. C
  127.       SUBROUTINE ADDIT(SEL)
  128. C
  129. C        THIS ROUTINE ADDS A NEW ENTRY TO THE DATABASE
  130. C
  131.       IMPLICIT INTEGER (A-Z)
  132.       CHARACTER TEST*8,RAMDSK*80
  133.       REAL GALS
  134. C
  135.       COMMON/MAIN1/ NAME,IDNUM,DATE,RFILE,MFILE
  136.       CHARACTER NAME(25)*20,IDNUM(25)*20,DATE(2,25)*8
  137.       CHARACTER RFILE(25)*11,MFILE(25)*11
  138. C
  139.       COMMON/MAIN2/ COST,ODOM,VNUM
  140.       INTEGER VNUM
  141.       REAL COST(2,25),ODOM(2,25)
  142. C
  143.       COMMON/MILE1/ MDESC,MDATE
  144.       CHARACTER MDESC(500)*25,MDATE(500)*8
  145. C
  146.       COMMON/MILE2/ MCODE,MCOST,MODOM,MNUM
  147.       INTEGER MCODE(500),MNUM
  148.       REAL MCOST(500),MODOM(500)
  149. C
  150. C        CALL FOR MAP, DRAW PROMPT LINE
  151. C
  152.       CALL MOVEIT(1,23)
  153.       WRITE(*,'(7X,2A33)') 'Please Enter Requested Data .... ',
  154.      A                     'Press <RET> to tab to next field ' 
  155. C
  156. C        REQUEST ALL DATA
  157. C
  158.       LM=MNUM+1
  159.    50 CONTINUE
  160.       MDATE(LM)=' '
  161.       CALL EDATE(33,13,MDATE(LM))
  162.       IF(MDATE(LM).EQ.' ') THEN
  163.          CALL BELL
  164.          GOTO 50
  165.       ENDIF
  166. C
  167.    75 CONTINUE
  168.       MCOST(LM)=0.0
  169.       CALL EDREL(33,14,MCOST(LM),9)
  170.       IF(MCOST(LM).LE.0.0) THEN
  171.          CALL BELL
  172.          GOTO 75
  173.       ENDIF
  174. C
  175.   100 CONTINUE
  176.       GALS=0.0
  177.       CALL EDREL(33,15,GALS,9)
  178.       IF(DATE(2,SEL).EQ.' ') THEN
  179.          GALS = GALS + ODOM(2,SEL)
  180.       ENDIF
  181.       IF((GALS.LE.0.0).OR.(LM.GT.1.AND.GALS.LT.MODOM(LM-1))) THEN
  182.          CALL BELL
  183.          GOTO 100
  184.       ELSE
  185.          MODOM(LM)=GALS 
  186.       ENDIF
  187. C
  188. C             NOW ASK WHAT CATAGORY (TRIP/CITY) THIS IS FOR
  189. C
  190.   400 CONTINUE
  191.       TEST=' '
  192.       CALL EDCHR(38,17,TEST,1)
  193.       IF(TEST.NE.' ') THEN
  194.          MCODE(LM)=1
  195.   500    CONTINUE
  196.          RAMDSK=' '
  197.          CALL EDCHR(33,18,RAMDSK,25)
  198.          MDESC(LM)=RAMDSK
  199.          IF(MDESC(LM).EQ.' ') THEN
  200.             CALL BELL
  201.             GOTO 500
  202.          ENDIF
  203.       ELSE
  204.          CALL EDCHR(47,17,TEST,1)
  205.          IF(TEST.NE.' ') THEN
  206.             MCODE(LM)=2
  207.          ELSE
  208.             CALL BELL
  209.             GOTO 400
  210.          ENDIF
  211.       ENDIF
  212. C
  213. C              INCREMENT COUNTER, CREATE FILE NAME IF NECESSARY
  214. C
  215.       MNUM=LM
  216.       IF(MNUM.EQ.1) THEN
  217.          WRITE(RAMDSK,'(A5,I2.2,A4)') 'VEHIC',SEL,'.MIL'
  218.          READ(RAMDSK,'(A11)') MFILE(SEL)
  219.       ENDIF
  220.       RETURN
  221.       END
  222. C
  223. C
  224. C
  225.       SUBROUTINE EDITML(SEL)
  226. C
  227.       IMPLICIT INTEGER (A-Z)
  228.       CHARACTER TEST*8,RAMDSK*80
  229.       REAL GALS
  230. C
  231.       COMMON/MAIN1/ NAME,IDNUM,DATE,RFILE,MFILE
  232.       CHARACTER NAME(25)*20,IDNUM(25)*20,DATE(2,25)*8
  233.       CHARACTER RFILE(25)*11,MFILE(25)*11
  234. C
  235.       COMMON/MAIN2/ COST,ODOM,VNUM
  236.       INTEGER VNUM
  237.       REAL COST(2,25),ODOM(2,25)
  238. C
  239.       COMMON/MILE1/ MDESC,MDATE
  240.       CHARACTER MDESC(500)*25,MDATE(500)*8
  241. C
  242.       COMMON/MILE2/ MCODE,MCOST,MODOM,MNUM
  243.       INTEGER MCODE(500),MNUM
  244.       REAL MCOST(500),MODOM(500)
  245. C
  246. C        CALL FOR MAP, DRAW PROMPT LINE
  247. C
  248.    50 CONTINUE
  249.       CALL MOVEIT(1,23)
  250.       WRITE(*,'(7X,2A33,\)') 'Please Enter Date of Record to be',
  251.      A                       ' EDITed or <Return> for Menu     ' 
  252. C
  253. C        GET DATE, FIND MATCH
  254. C
  255.       TEST=' '
  256.       CALL EDATE(33,13,TEST)
  257.       IF(TEST.EQ.' ') THEN
  258.          CALL BELL
  259.          GOTO 900
  260.       ENDIF
  261. C
  262.       DO 75 I=1,MNUM
  263.       IF(TEST.EQ.MDATE(I)) GOTO 100
  264.    75 CONTINUE
  265.       CALL BELL
  266.       CALL MOVEIT(1,23)
  267.       WRITE(*,'(7X,2A33,\)') 'ERROR .... Record could not be lo',
  268.      A                       'cated, press <Return> for Menu   ' 
  269.       READ(*,'(A1)') TEST
  270.       GOTO 900
  271. C
  272. C         MATCH FOUND, DISPLAY ALL 
  273. C
  274.   100 CONTINUE
  275.       LM=I
  276.       CALL UPTOP(33,14)
  277.       WRITE(*,'(F9.2)') MCOST(LM)
  278.       CALL UPTOP(33,15)
  279.       WRITE(*,'(F9.2)') MODOM(LM)
  280.       IF(MCODE(LM).EQ.1) THEN
  281.          CALL UPTOP(38,17)
  282.          WRITE(*,'(A1)') 'X'
  283.          CALL UPTOP(33,18)
  284.          WRITE(*,'(A25)') MDESC(LM)
  285.       ELSE
  286.          CALL UPTOP(47,17)
  287.          WRITE(*,'(A1)') 'X'
  288.       ENDIF
  289. C
  290. C         NOW EDIT ENTRIES
  291. C
  292.       CALL EDREL(33,14,MCOST(LM),9)
  293.       CALL EDREL(33,15,MODOM(LM),9)
  294.   400 CONTINUE
  295.       IF(MCODE(LM).EQ.1) THEN
  296.          RAMDSK='X'
  297.       ELSE
  298.          RAMDSK=' '
  299.       ENDIF
  300.       CALL EDCHR(38,17,RAMDSK,1)
  301.       IF(RAMDSK.NE.' ') THEN
  302.          MCODE(LM)=1
  303.          RAMDSK=MDESC(LM)
  304.          CALL EDCHR(33,18,RAMDSK,25)
  305.          MDESC(LM)=RAMDSK
  306.       ELSE
  307.          RAMDSK='X'
  308.          CALL EDCHR(47,17,RAMDSK,1)
  309.          IF(RAMDSK.NE.' ') THEN
  310.             MCODE(LM)=2
  311.             MDESC(LM)=' '
  312.          ELSE
  313.             CALL BELL
  314.             GOTO 400
  315.          ENDIF
  316.       ENDIF
  317.   900 CONTINUE
  318.       RETURN
  319.       END
  320. C
  321. C
  322. C
  323.       SUBROUTINE DELETE(SEL)
  324. C
  325.       IMPLICIT INTEGER (A-Z)
  326.       CHARACTER TEST*8,RAMDSK*80
  327.       REAL GALS
  328. C
  329.       COMMON/MAIN1/ NAME,IDNUM,DATE,RFILE,MFILE
  330.       CHARACTER NAME(25)*20,IDNUM(25)*20,DATE(2,25)*8
  331.       CHARACTER RFILE(25)*11,MFILE(25)*11
  332. C
  333.       COMMON/MAIN2/ COST,ODOM,VNUM
  334.       INTEGER VNUM
  335.       REAL COST(2,25),ODOM(2,25)
  336. C
  337.       COMMON/MILE1/ MDESC,MDATE
  338.       CHARACTER MDESC(500)*25,MDATE(500)*8
  339. C
  340.       COMMON/MILE2/ MCODE,MCOST,MODOM,MNUM
  341.       INTEGER MCODE(500),MNUM
  342.       REAL MCOST(500),MODOM(500)
  343. C
  344. C        CALL FOR MAP, DRAW PROMPT LINE
  345. C
  346.    50 CONTINUE
  347.       CALL MOVEIT(1,23)
  348.       WRITE(*,'(7X,2A33,\)') 'Please Enter Date of Record to be',
  349.      A                       ' DELETED or <Return> for Menu    ' 
  350. C
  351. C        GET DATE, FIND MATCH
  352. C
  353.       TEST=' '
  354.       CALL EDATE(33,13,TEST)
  355.       IF(TEST.EQ.' ') THEN
  356.          CALL BELL
  357.          GOTO 900
  358.       ENDIF
  359. C
  360.       DO 75 I=1,MNUM
  361.       IF(TEST.EQ.MDATE(I)) GOTO 100
  362.    75 CONTINUE
  363.       CALL BELL
  364.       CALL MOVEIT(1,23)
  365.       WRITE(*,'(7X,2A33,\)') 'ERROR .... Record could not be lo',
  366.      A                       'cated, press <Return> for Menu   ' 
  367.       READ(*,'(A1)') TEST
  368.       GOTO 900
  369. C
  370. C         MATCH FOUND, DISPLAY ALL 
  371. C
  372.   100 CONTINUE
  373.       LM=I
  374.       CALL UPTOP(33,14)
  375.       WRITE(*,'(F9.2)') MCOST(LM)
  376.       CALL UPTOP(33,15)
  377.       WRITE(*,'(F9.2)') MODOM(LM)
  378.       IF(MCODE(LM).EQ.1) THEN
  379.          CALL UPTOP(38,17)
  380.          WRITE(*,'(A1)') 'X'
  381.          CALL UPTOP(33,18)
  382.          WRITE(*,'(A25)') MDESC(LM)
  383.       ELSE
  384.          CALL UPTOP(47,17)
  385.          WRITE(*,'(A1)') 'X'
  386.       ENDIF
  387. C
  388. C          FIND OUT IF THIS SHOULD BE DELETE
  389. C
  390.       CALL BELL
  391.       CALL MOVEIT(1,23)
  392.       WRITE(*,'(7X,2A28,\)') ' Is this the correct record ',
  393.      A                       'you wish to DELETE (Y/N) ?? ' 
  394.       READ(*,'(A1)') TEST
  395.       IF(TEST.NE.'Y' .AND. TEST.NE.'y') GOTO 900
  396. C
  397. C          MOVE LAST ENTRY HERE, DECREMENT COUNTER
  398. C
  399.       MDATE(LM)=MDATE(MNUM)
  400.       MCOST(LM)=MCOST(MNUM)
  401.       MODOM(LM)=MODOM(MNUM)
  402.       MCODE(LM)=MCODE(MNUM)
  403.       MDESC(LM)=MDESC(MNUM)
  404.       MNUM=MNUM-1
  405.   900 CONTINUE
  406.       RETURN
  407.       END
  408.