home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / viscobv6.zip / vac22os2 / ibmcobol / samples / putut / calcprg.cbl < prev    next >
Text File  |  1996-05-30  |  13KB  |  163 lines
  1.       PROCESS LIB                                                       CAL00010
  2.       *************************************************************     CAL00020
  3.       *                                                           *     CAL00030
  4.       *    Licensed Material - Property of IBM                    *     CAL00040
  5.       *                                                           *     CAL00050
  6.       *    83H9095 (C) Copyright IBM Corp., 1996                  *     CAL00060
  7.       *    All rights reserved                                    *     CAL00070
  8.       *                                                           *     CAL00080
  9.       *    US Government Users Restricted Rights - Use,           *     CAL00090
  10.       *    duplication or disclosure restricted by GSA ADP        *     CAL00100
  11.       *    Schedule Contract with IBM Corp.                       *     CAL00110
  12.       *                                                           *     CAL00120
  13.       *************************************************************     CAL00130
  14.       * File CALCPRG  COBOL                                             CAL00140
  15.        IDENTIFICATION DIVISION.                                         CAL00150
  16.          PROGRAM-ID.    CALCPRG.                                        CAL00160
  17.        ENVIRONMENT DIVISION.                                            CAL00170
  18.        CONFIGURATION SECTION.                                           CAL00180
  19.          SPECIAL-NAMES.                                                 CAL00190
  20.             C01 IS NEW-PAGE.                                            CAL00200
  21.        INPUT-OUTPUT SECTION.                                            CAL00210
  22.          FILE-CONTROL.                                                  CAL00220
  23.            SELECT INDATA-FILE                                           CAL00230
  24.              ASSIGN TO INDATA.                                          CAL00240
  25.            SELECT OUTDATA-FILE                                          CAL00250
  26.              ASSIGN TO OUTDATA.                                         CAL00260
  27.        DATA DIVISION.                                                   CAL00270
  28.        FILE SECTION.                                                    CAL00280
  29.        FD  INDATA-FILE                                                  CAL00290
  30.            RECORDING MODE IS F                                          CAL00300
  31.            BLOCK CONTAINS 0 RECORDS                                     CAL00310
  32.            RECORD CONTAINS 196 CHARACTERS                               CAL00320
  33.            LABEL RECORD IS STANDARD.                                    CAL00330
  34.        01  INDATA-REC                        PIC X(196).                CAL00340
  35.                                                                         CAL00350
  36.        FD  OUTDATA-FILE                                                 CAL00360
  37.            RECORDING MODE IS F                                          CAL00370
  38.            BLOCK CONTAINS 0 RECORDS                                     CAL00380
  39.            RECORD CONTAINS 196 CHARACTERS                               CAL00390
  40.            LABEL RECORD IS STANDARD.                                    CAL00400
  41.        01  OUTDATA-REC                        PIC X(196).               CAL00410
  42.                                                                         CAL00420
  43.        WORKING-STORAGE SECTION.                                         CAL00430
  44.          01  FLAGS.                                                     CAL00440
  45.              05 INDATA-EOF-FLAG               PIC X VALUE SPACES.       CAL00450
  46.                 88 INDATA-EOF VALUE 'Y'.                                CAL00460
  47.                                                                         CAL00470
  48.          COPY RECIN.                                                    CAL00480
  49.          COPY RECOUT.                                                   CAL00490
  50.                                                                         CAL00500
  51.        LINKAGE SECTION.                                                 CAL00510
  52.          COPY COMNDATA.                                                 CAL00520
  53.                                                                         CAL00530
  54.        PROCEDURE DIVISION USING COMNDATA.                               CAL00540
  55.                                                                         CAL00550
  56.                  DISPLAY 'CALCPRG MODULE BEGINS'.                       CAL00560
  57.                  ACCEPT RUNDATE FROM DATE.                              CAL00570
  58.                                                                         CAL00580
  59.                  PERFORM 1000-INIT-PARA                                 CAL00590
  60.                     THRU 1000-IP-EXIT.                                  CAL00600
  61.                                                                         CAL00610
  62.                  PERFORM 2000-PROCESS-PARA                              CAL00620
  63.                     THRU 2000-PP-EXIT                                   CAL00630
  64.                          WITH TEST BEFORE                               CAL00640
  65.                               UNTIL INDATA-EOF.                         CAL00650
  66.                                                                         CAL00660
  67.                  PERFORM 3000-END-PARA                                  CAL00670
  68.                     THRU 3000-EP-EXIT.                                  CAL00680
  69.                                                                         CAL00690
  70.                  DISPLAY 'CALCPRG MODULE ENDS. OLDONE = ' OLDONE.       CAL00700
  71.                                                                         CAL00710
  72.                  STOP RUN.                                              CAL00720
  73.                                                                         CAL00730
  74.        1000-INIT-PARA.                                                  CAL00740
  75.                                                                         CAL00750
  76.                  INITIALIZE FLAGS                                       CAL00760
  77.                             COMNDATA                                    CAL00770
  78.                             INBUFVARDS                                  CAL00780
  79.                             OUTBUFVARDS.                                CAL00790
  80.                                                                         CAL00800
  81.                  PERFORM 1100-OPEN-FILES                                CAL00810
  82.                     THRU 1100-OF-EXIT.                                  CAL00820
  83.                                                                         CAL00830
  84.                  PERFORM 7000-READ-INDATA                               CAL00840
  85.                     THRU 7000-RI-EXIT.                                  CAL00850
  86.                                                                         CAL00860
  87.                  IF INDATA-EOF                                          CAL00870
  88.                     CALL 'ERROUT'                                       CAL00880
  89.                     DISPLAY 'INDATA FILE IS EMPTY - PGM ENDING'         CAL00890
  90.                     GO TO 1000-IP-EXIT                                  CAL00900
  91.                  END-IF.                                                CAL00910
  92.                                                                         CAL00920
  93.                  IF DB-SELECTION = 1  THEN                              CAL00930
  94.                     CALL 'DB1DOPRG' USING BY REFERENCE INBUFVARDS       CAL00940
  95.                  ELSE                                                   CAL00950
  96.                     CALL 'DB2DOPRG' USING BY REFERENCE INBUFVARDS       CAL00960
  97.                  END-IF.                                                CAL00970
  98.                                                                         CAL00980
  99.        1000-IP-EXIT.                                                    CAL00990
  100.             EXIT.                                                       CAL01000
  101.                                                                         CAL01010
  102.        1100-OPEN-FILES.                                                 CAL01020
  103.                                                                         CAL01030
  104.             OPEN INPUT INDATA-FILE.                                     CAL01040
  105.                                                                         CAL01050
  106.             OPEN OUTPUT OUTDATA-FILE.                                   CAL01060
  107.                                                                         CAL01070
  108.        1100-OF-EXIT.                                                    CAL01080
  109.             EXIT.                                                       CAL01090
  110.                                                                         CAL01100
  111.        2000-PROCESS-PARA.                                               CAL01110
  112.                                                                         CAL01120
  113.             MOVE CORRESPONDING INBUFVARDS TO OUTBUFVARDS.               CAL01130
  114.                                                                         CAL01140
  115.             CALL 'INIT1PRG' USING BY REFERENCE OUTBUFVARDS, COMNDATA.   CAL01150
  116.                                                                         CAL01160
  117.             EVALUATE TRUE                                               CAL01170
  118.                 WHEN RATEVAR = 1                                        CAL01180
  119.                      CALL 'ADDPRG' USING BY REFERENCE OUTBUFVARDS       CAL01190
  120.                 WHEN RATEVAR = 2                                        CAL01200
  121.                      CALL 'SUBPRG' USING BY REFERENCE OUTBUFVARDS       CAL01210
  122.                 WHEN RATEVAR = 3                                        CAL01220
  123.                      CALL 'MULTPRG' USING BY REFERENCE OUTBUFVARDS      CAL01230
  124.                 WHEN RATEVAR > 3                                        CAL01240
  125.                      CALL 'DIVPRG' USING BY REFERENCE OUTBUFVARDS       CAL01250
  126.             END-EVALUATE                                                CAL01260
  127.                                                                         CAL01270
  128.             PERFORM 2100-WRITE-OUTDATA                                  CAL01280
  129.                THRU 2100-WO-EXIT.                                       CAL01290
  130.                                                                         CAL01300
  131.             PERFORM 7000-READ-INDATA                                    CAL01310
  132.                THRU 7000-RI-EXIT.                                       CAL01320
  133.                                                                         CAL01330
  134.        2000-PP-EXIT.                                                    CAL01340
  135.             EXIT.                                                       CAL01350
  136.                                                                         CAL01360
  137.        2100-WRITE-OUTDATA.                                              CAL01370
  138.             IF NOT ACCOUNT-UPDT-DDMMYY OF OUTBUFVARDS = RUNDATE         CAL01380
  139.                THEN IF ACCOUNT-OPEN-DDMMYY OF INBUFVARDS < OLDONE       CAL01390
  140.                      MOVE ACCOUNT-OPEN-DDMMYY OF INBUFVARDS TO OLDONE.  CAL01400
  141.                                                                         CAL01410
  142.             WRITE OUTDATA-REC FROM OUTBUFVARDS.                         CAL01420
  143.                                                                         CAL01430
  144.        2100-WO-EXIT.                                                    CAL01440
  145.             EXIT.                                                       CAL01450
  146.                                                                         CAL01460
  147.        3000-END-PARA.                                                   CAL01470
  148.                                                                         CAL01480
  149.             CLOSE INDATA-FILE                                           CAL01490
  150.                   OUTDATA-FILE.                                         CAL01500
  151.                                                                         CAL01510
  152.        3000-EP-EXIT.                                                    CAL01520
  153.             EXIT.                                                       CAL01530
  154.                                                                         CAL01540
  155.        7000-READ-INDATA.                                                CAL01550
  156.                                                                         CAL01560
  157.             READ INDATA-FILE INTO INBUFVARDS                            CAL01570
  158.                  AT END                                                 CAL01580
  159.                     MOVE 'Y' TO INDATA-EOF-FLAG.                        CAL01590
  160.                                                                         CAL01600
  161.        7000-RI-EXIT.                                                    CAL01610
  162.             EXIT.                                                       CAL01620
  163.