000100*CBL PMAP
000200*CBL ADV
000300*CBL APOST
000400*CBL DYN
000500*CBL OPTIMIZE
000600*CBL RES
000700 IDENTIFICATION DIVISION.
000800 PROGRAM-ID. DDOS.
000900 AUTHOR. AUTHOR.
001000 INSTALLATION. SITE.
001100 DATE-WRITTEN. ON OR BEFORE JUL 29, 1997.
001200 DATE-COMPILED.
001300 REMARKS.
001400******************************************************************
001500** *
001600** RECOVERED BY RESOURCE (TM) 001700** *
001800** ORIGINALLY COMPILED BY: IBM OS/VS COBOL VERSION 2.4 *
001900** *
002000** NOTES: *
002100** *
002200******************************************************************
002300
002400 ENVIRONMENT DIVISION.
002500
002600 CONFIGURATION SECTION.
002700 SOURCE-COMPUTER. IBM-370.
002800 OBJECT-COMPUTER. IBM-370.
002900 SPECIAL-NAMES.
003000 C01 IS TO-TOP-OF-PAGE.
003100
003200 INPUT-OUTPUT SECTION.
003300 FILE-CONTROL.
003400 SELECT FILE-01
003500 ASSIGN TO UT-S-WAGEFILE
003600 ORGANIZATION IS SEQUENTIAL
003700 ACCESS MODE IS SEQUENTIAL.
003800 SELECT FILE-02
003900 ASSIGN TO UT-S-PAYROLL
004000 ORGANIZATION IS SEQUENTIAL
004100 ACCESS MODE IS SEQUENTIAL.
004200
004300******************************************************************
004400** *
004500******************************************************************
004600 DATA DIVISION.
004700
004800******************************************************************
004900** *
005000******************************************************************
005100 FILE SECTION.
005200
005300 FD FILE-01
005400 RECORDING MODE IS F
005500 LABEL RECORDS ARE STANDARD
005600 BLOCK CONTAINS 0 RECORDS
005700 RECORD CONTAINS 80 CHARACTERS.
005800 01 FD010.
005900 05 FD010000 PIC X(80).
006000
006100 FD FILE-02
006200 RECORDING MODE IS F
006300 LABEL RECORDS ARE STANDARD
006400 BLOCK CONTAINS 0 RECORDS
006500 RECORD CONTAINS 133 CHARACTERS.
006600 01 FD020.
006700 05 FD020000 PIC X(133).
006800
006900******************************************************************
007000** *
007100******************************************************************
007200* THE SIZE OF WORKING-STORAGE IS 23592 BYTES (DECIMAL).
007300* THE SIZE OF WORKING-STORAGE IS 5C28 BYTES (HEXADECIMAL).
007400 WORKING-STORAGE SECTION.
007500
007600 01 WS000.
007700 05 FILLER PIC X(30)
007800 VALUE 'WORKING STORAGE STARTS HERE'.
007900
008000 01 WS000020 PIC X(08) VALUE 'USERPGM'.
008100
008300 01 WS000028 PIC X(19) JUST VALUE SPACES.
008500
008600 01 WS000040 PIC X(40) VALUE SPACES.
008700
008900 01 WS000068 PIC 9(04) COMP VALUE ZEROS.
009100
009200 01 WS000070-G80.
009300 05 WS000070 PIC X(15).
009400 05 WS00007F PIC X(20).
009500 05 WS000093 PIC X(10).
009600 05 WS00009D PIC X(02).
009700 05 WS00009F PIC X(05).
009800 05 WS0000A4 PIC X(09).
009900 05 WS0000AD PIC 9(01).
010000 05 WS0000AE PIC 9(02).
010100 05 WS0000B0 PIC X(01).
010200 05 WS0000B1 PIC 9(03)V99.
010300 05 WS0000B6 PIC 9(03)V99.
010400 05 WS0000BB PIC 9(03)V99.
010500
010700 01 WS0000C0 PIC 9(05)V99 VALUE ZEROS.
010900
011100 01 WS0000C8 PIC 9(07)V99 VALUE ZEROS.
011300
011500 01 WS0000D8 PIC 9(07)V99 VALUE ZEROS.
011700
011900 01 WS0000E8 PIC 9(07)V99 VALUE ZEROS.
012100
012300 01 WS0000F8-G6.
012400 10 WS0000F8 PIC 9(02).
012500 10 WS0000FA PIC 9(02).
012600 10 WS0000FC PIC 9(02).
012800
012900 01 ALIGN-0100.
013000 05 WS000100 PIC X(01) VALUE 'C'.
013100 05 WS000101 PIC X(01) VALUE 'C'.
013200 05 WS000102 PIC X(01) VALUE 'N'.
013300 05 WS000103 PIC X(01) VALUE 'N'.
013400 05 FILLER PIC X(04).
013500
013600 01 ALIGN-0108.
013700 05 WS000108 PIC 9(04) COMP VALUE ZEROS.
013800 05 WS00010A PIC 9(05) COMP-3 VALUE ZEROS.
013900 05 WS00010D PIC 9(05) VALUE ZEROS.
014000 05 WS000112 PIC 9(05) VALUE 1.
014100 05 WS000117 PIC 9(02) VALUE 99.
014200 05 WS000119 PIC 9(01) VALUE 3.
014300 05 FILLER PIC X(06).
014400
014500 01 WS000120 PIC X(08).
014600
014700 01 ALIGN-0128.
014800 05 FILLER PIC X(33).
014900 05 FILLER PIC X(14) VALUE SPACES.
015000
015100 01 ALIGN-0158.
015200 05 FILLER PIC X(09).
015300 05 FILLER PIC X(20) VALUE SPACES.
015400
015500 01 ALIGN-0178.
015600 05 FILLER PIC X(37).
015700 05 FILLER PIC X(39) VALUE 'FRED BRANDES'.
015800 05 FILLER PIC X(39) VALUE SPACES.
015900 05 FILLER PIC X(02) VALUE SPACES.
016000
016100 01 ALIGN-01F0.
016200 05 FILLER PIC S9(03) COMP-3 VALUE ZEROS.
016300 05 FILLER PIC S9(05) COMP-3 VALUE ZEROS.
016400 05 FILLER PIC S9(05) COMP-3 VALUE ZEROS.
016500
016600 01 ALIGN-01F8.
016700 05 FILLER PIC X(21).
016800 05 FILLER PIC S9(01) COMP-3 VALUE ZEROS.
016900
017000 01 ALIGN-0210.
017100 05 FILLER PIC S9(05) COMP-3 VALUE ZEROS.
017200
017300 01 ALIGN-0218.
017400 05 FILLER PIC 9(03) COMP-3 VALUE ZEROS.
017500 05 FILLER PIC 9(05) COMP-3 VALUE ZEROS.
017600 05 FILLER PIC 9(05) COMP-3 VALUE ZEROS.
017700
017800 01 ALIGN-0220.
017900 05 FILLER PIC X(21).
018000 05 FILLER PIC 9(01) COMP-3 VALUE ZEROS.
018100
018200 01 ALIGN-0238.
018300 05 FILLER PIC 9(05) COMP-3 VALUE ZEROS.
018400
018500 01 ALIGN-0240.
018600 05 FILLER PIC S9(03) VALUE ZEROS.
018700 05 FILLER PIC S9(04) VALUE +12.
018800 05 FILLER PIC S9(05) VALUE ZEROS.
018900
019000 01 ALIGN-0250.
019100 05 FILLER PIC X(26).
019200 05 FILLER PIC S9(07) VALUE ZEROS.
019300 05 FILLER PIC S9(08) VALUE ZEROS.
019400
019500 01 ALIGN-0280.
019600 05 FILLER PIC 9(07) VALUE ZEROS.
019700
019800 01 ALIGN-0288.
019900 05 FILLER PIC X(34).
020000 05 FILLER PIC 9(15) VALUE ZEROS.
020100
020200 01 ALIGN-02C0.
020300 05 FILLER PIC S9(07) COMP-3 VALUE ZEROS.
020400
020500 01 ALIGN-02C8.
020600 05 FILLER PIC X(15).
020700 05 FILLER PIC 9(01) COMP-3 VALUE ZEROS.
020800
020900 01 ALIGN-02D8.
021000 05 FILLER PIC S9(07) COMP-3 VALUE ZEROS.
021100
021200 01 ALIGN-02E0.
021300 05 FILLER PIC X(15).
021400 05 FILLER PIC S9(01) COMP-3 VALUE ZEROS.
021500
021600 01 FILLER PIC X(64).
021700
021800 01 ALIGN-0330.
021900 05 WS000330-G133.
022000 10 FILLER PIC X(11) VALUE SPACES.
022100 10 FILLER PIC X(33)
022200 VALUE 'THE SOURCE RECOVERY COMPANY, LLC.'.
022300 10 FILLER PIC X(17) VALUE SPACES.
022400 10 FILLER PIC X(23) VALUE 'WAGE REPORT'.
022500 10 FILLER PIC X(12) VALUE 'REPORT DATE'.
022600 10 WS000390 PIC X(09) VALUE 'MONTH'.
022700 10 FILLER PIC X(01) VALUE SPACES.
022800 10 WS00039A PIC X(02) VALUE 'DD'.
022900 10 FILLER PIC X(01) VALUE ','.
023000 10 WS00039D PIC 9(02) VALUE 19.
023100 10 WS00039F PIC X(02) VALUE 'YY'.
023200 10 FILLER PIC X(10) VALUE SPACES.
023300 10 FILLER PIC X(05) VALUE 'PAGE'.
023400 10 WS0003B0 PIC ZZZZ9.
023500 05 FILLER PIC X(03).
023600
023700 01 ALIGN-03B8.
023800 05 WS0003B8-G133.
023900 10 FILLER PIC X(10) VALUE SPACES.
024000 10 FILLER PIC X(17) VALUE 'NAME'.
024100 10 FILLER PIC X(22) VALUE 'ADDRESS'.
024200 10 FILLER PIC X(12) VALUE 'CITY'.
024300 10 FILLER PIC X(04) VALUE 'ST'.
024400 10 FILLER PIC X(07) VALUE 'ZIP'.
024500 10 FILLER PIC X(11) VALUE 'SSN'.
024600 10 FILLER PIC X(12) VALUE 'PAYCODE'.
024700 10 FILLER PIC X(08) VALUE 'RATE'.
024800 10 FILLER PIC X(08) VALUE 'REG HR'.
024900 10 FILLER PIC X(08) VALUE 'OT HR'.
025000 10 FILLER PIC X(14) VALUE 'GROSS'.
025100
025200 01 ALIGN-0440.
025300 05 FILLER PIC X(10) VALUE SPACES.
025400 05 FILLER PIC X(19)
025500 VALUE 'YEAR TO DATE TOTALS'.
025600 05 FILLER PIC X(39) VALUE ':'.
025700 05 FILLER PIC X(29) VALUE SPACES.
025800 05 FILLER PIC X(10) VALUE 'REG HR'.
025900 05 FILLER PIC X(10) VALUE 'OT HR'.
026000 05 FILLER PIC X(16) VALUE 'YTD GROSS'.
026100
026200 01 ALIGN-04C8.
026300 05 WS0004C8-G133.
026400 10 FILLER PIC X(10).
026500 10 WS0004D2 PIC X(15).
026600 10 FILLER PIC X(02).
026700 10 WS0004E3 PIC X(20).
026800 10 FILLER PIC X(02).
026900 10 WS0004F9 PIC X(10).
027000 10 FILLER PIC X(02).
027100 10 WS000505 PIC X(02).
027200 10 FILLER PIC X(02).
027300 10 WS000509 PIC X(05).
027400 10 FILLER PIC X(02).
027500 10 WS000510 PIC X(09).
027600 10 FILLER PIC X(02).
027700 10 WS00051B PIC 9(01).
027800 10 WS00051C PIC 9(02).
027900 10 WS00051E PIC X(01).
028000 10 WS00051F PIC X(06).
028100 10 FILLER PIC X(02).
028200 10 WS000527 PIC ZZ9.99.
028300 10 FILLER PIC X(02).
028400 10 WS00052F PIC ZZ9.99.
028500 10 FILLER PIC X(02).
028600 10 WS000537 PIC ZZ9.99.
028610 10 FILLER PIC X(02).
028700 10 WS00053F PIC Z,ZZZ.99.
028900 10 FILLER PIC X(06).
028902 05 WS0004C8-R01 REDEFINES WS0004C8-G133.
028903 10 FILLER PIC X(97).
028904 10 WS000529 PIC Z,ZZ9.99.
028905 10 FILLER PIC X(02).
028906 10 WS000533 PIC Z,ZZ9.99.
028907 10 FILLER PIC X(02).
028908 10 WS00053D PIC ZZZ,ZZ9.99.
028909 10 FILLER PIC X(06).
028910
029000 05 FILLER PIC X(03).
029100
029200 01 ALIGN-0550.
029300 05 WS000550 PIC S9(04) COMP VALUE ZEROS.
029400 05 FILLER PIC X(06).
029500
029600 01 ALIGN-0558.
029700 05 WS000558-VALUES.
029800 10 FILLER PIC 9(02) VALUE 1.
029900 10 FILLER PIC X(09) VALUE 'JANUARY'.
030000 10 FILLER PIC 9(02) VALUE 2.
030100 10 FILLER PIC X(09) VALUE 'FEBRUARY'.
030200 10 FILLER PIC 9(02) VALUE 3.
030300 10 FILLER PIC X(09) VALUE 'MARCH'.
030400 10 FILLER PIC 9(02) VALUE 4.
030500 10 FILLER PIC X(09) VALUE 'APRIL'.
030600 10 FILLER PIC 9(02) VALUE 5.
030700 10 FILLER PIC X(09) VALUE 'MAY'.
030800 10 FILLER PIC 9(02) VALUE 6.
030900 10 FILLER PIC X(09) VALUE 'JUNE'.
031000 10 FILLER PIC 9(02) VALUE 7.
031100 10 FILLER PIC X(09) VALUE 'JULY'.
031200 10 FILLER PIC 9(02) VALUE 8.
031300 10 FILLER PIC X(09) VALUE 'AUGUST'.
031400 10 FILLER PIC 9(02) VALUE 9.
031500 10 FILLER PIC X(09) VALUE 'SEPTEMBER'.
031600 10 FILLER PIC 9(02) VALUE 10.
031700 10 FILLER PIC X(09) VALUE 'OCTOBER'.
031800 10 FILLER PIC 9(02) VALUE 11.
031900 10 FILLER PIC X(09) VALUE 'NOVEMBER'.
032000 10 FILLER PIC 9(02) VALUE 12.
032100 10 FILLER PIC X(09) VALUE 'DECEMBER'.
032200 05 WS000558-TABLE REDEFINES WS000558-VALUES
032300 OCCURS 12 TIMES.
032400 10 WS000558 PIC 9(02).
032500 10 WS00055A PIC X(09).
032600 05 FILLER PIC X(04).
032700
032800 01 ALIGN-05E0.
032900 05 WS0005E0-VALUES.
033000 10 FILLER PIC X(02) VALUE '01'.
033100 10 FILLER PIC 9(05) VALUE 415.
033200 10 FILLER PIC X(02) VALUE '02'.
033300 10 FILLER PIC 9(05) VALUE 525.
033400 10 FILLER PIC X(02) VALUE '03'.
033500 10 FILLER PIC 9(05) VALUE 650.
033600 10 FILLER PIC X(02) VALUE '04'.
033700 10 FILLER PIC 9(05) VALUE 775.
033800 10 FILLER PIC X(02) VALUE '05'.
033900 10 FILLER PIC 9(05) VALUE 900.
034000 10 FILLER PIC X(02) VALUE '06'.
034100 10 FILLER PIC 9(05) VALUE 1075.
034200 10 FILLER PIC X(02) VALUE '07'.
034300 10 FILLER PIC 9(05) VALUE 1250.
034400 10 FILLER PIC X(02) VALUE '08'.
034500 10 FILLER PIC 9(05) VALUE 1500.
034600 10 FILLER PIC X(02) VALUE '09'.
034700 10 FILLER PIC 9(05) VALUE 1800.
034800 10 FILLER PIC X(02) VALUE '10'.
034900 10 FILLER PIC 9(05) VALUE 2200.
035000 10 FILLER PIC X(02) VALUE '11'.
035100 10 FILLER PIC 9(05) VALUE 2700.
035200 10 FILLER PIC X(02) VALUE '12'.
035300 10 FILLER PIC 9(05) VALUE 3200.
035400 05 WS0005E0-TABLE REDEFINES WS0005E0-VALUES
035500 OCCURS 12 TIMES
035600 INDEXED BY INDEX-01.
035700 10 WS0005E0 PIC X(02).
035800 10 WS0005E2 PIC 9(03)V99.
035900 05 FILLER PIC X(20004).
036000
036100 01 WS005458 PIC X(2000).
036200
036300******************************************************************
036400** *
036500******************************************************************
036600 LINKAGE SECTION.
036700
036800 01 LS010.
036900 05 LS010000 PIC X(2000).
037000******************************************************************
037100** *
037200******************************************************************
037300 PROCEDURE DIVISION USING LS010.
037400
037500 MOVE '0000-MAINLINE' TO WS000028.
037600
037700 MOVE LS010000 TO WS005458.
037800
037900 PERFORM PGM067BA THRU TGT00294-EXIT.
038000
038100 PERFORM PGM06B24 THRU TGT0029C-EXIT.
038200
038300 IF WS000102 = 'Y'
038700 MOVE 'WAGE FILE IS EMPTY' TO WS000040
038900 MOVE 1002 TO WS000068
039100 GO TO PGM07092.
039300
039400 PERFORM PGM06BF8 THRU TGT002A4-EXIT
039500 UNTIL WS000102 = 'Y'.
040500
040600 MOVE WS0000D8 TO WS000529.
040700
040800 MOVE WS0000E8 TO WS000533.
040900
041000 MOVE WS0000C8 TO WS00053D.
041100
041200 MOVE WS0004C8-G133 TO FD020000.
041300
041400 WRITE FD020
041500 AFTER ADVANCING WS000119 LINES.
041600
041700 CLOSE FILE-02.
041800
041900 DISPLAY 'COUNT OF RECORDS READ '
042000 WS000108.
042100
042200 DISPLAY 'COUNT OF RECORDS REJECTED '
042300 WS00010D.
042400
042500 DISPLAY 'COUNT OF RECORDS WRITTEN '
042600 WS00010A.
042700
042800 PGM06790.
042900
043000 GOBACK.
043100
043200 PGM067BA.
043300
043400 MOVE '0100-INIT' TO WS000028.
043500
043600 MOVE CURRENT-DATE TO WS000120.
043700
043800 DISPLAY 'RUN DATE: '
043900 WS000120.
044000
044100 OPEN INPUT FILE-01
044200 OUTPUT FILE-02.
044300
044400 MOVE 'O' TO WS000100.
044500
044600 MOVE 'O' TO WS000101.
044700
044800 ACCEPT WS0000F8-G6 FROM CONSOLE.
044900
045000 IF WS0000F8 IS NOT NUMERIC
045500 MOVE 'MONTH NOT NUMERIC' TO WS000040
045700 MOVE 1010 TO WS000068
045900 GO TO PGM07092.
046100 PGM068DC.
046200
046300 IF WS0000FA IS NOT NUMERIC
046800 MOVE 'DAY NOT NUMERIC' TO WS000040
047000 MOVE 1010 TO WS000068
047200 GO TO PGM07092.
047400 PGM06904.
047500
047600 IF WS0000FC IS NOT NUMERIC
048100 MOVE 'YEAR NOT NUMERIC' TO WS000040
048300 MOVE 1010 TO WS000068
048500 GO TO PGM07092.
048600
048700 PGM0692C.
048800
048900 PERFORM PGM0694A THRU TGT002AC-EXIT.
049000
049100 TGT00294-EXIT.
049200 EXIT.
049300
049400******************************************************************
049500** *
049600******************************************************************
049800 PGM0694A.
049900
050000 MOVE '0200-INIT-HEADINGS' TO WS000028.
050100
050200 PERFORM PGM069FC THRU TGT002B4-EXIT
050300 VARYING WS000550 FROM 1 BY 1
050310 UNTIL WS000550 > 12 OR
050400 WS000103 = 'Y'.
052500
052600 IF WS000103 = 'N'
053000 MOVE 'INVALID MONTH SPECIFIED' TO WS000040
053200 MOVE 1001 TO WS000068
053400 GO TO PGM07092.
053600
054700 MOVE WS00055A ( WS000550 ) TO WS000390.
054900
055000 MOVE WS0000FA TO WS00039A.
055100
055200 MOVE 19 TO WS00039D.
055300
055400 MOVE WS0000FC TO WS00039F.
055500
055600 TGT002AC-EXIT.
055700 EXIT.
055800
055900******************************************************************
056000** *
056100******************************************************************
056300 PGM069FC.
056400
056500 MOVE '0300-GET-MONTH' TO WS000028.
056600
057500 IF WS0000F8 = WS000558 ( WS000550 )
058300 MOVE 'Y' TO WS000103.
058600
058700 TGT002B4-EXIT.
058800 EXIT.
058900
059000******************************************************************
059100** *
059200******************************************************************
059400 PGM06A42.
059500
059600 MOVE '0900-HEADINGS' TO WS000028.
059700
059800 MOVE WS000112 TO WS0003B0.
059900
060000 MOVE WS000330-G133 TO FD020000.
060100
060200 WRITE FD020
060300 AFTER ADVANCING TO-TOP-OF-PAGE.
060400
060500 MOVE WS0003B8-G133 TO FD020000.
060600
060700 WRITE FD020
060800 AFTER ADVANCING 2 LINES.
060900
061000 MOVE SPACES TO FD020000.
061100
061200 WRITE FD020
061300 AFTER ADVANCING 1 LINES.
061400
061500 ADD 1 TO WS000112.
061600
061700 MOVE 4 TO WS000117.
061800
061900 TGT002BC-EXIT.
062000 EXIT.
062100
062200******************************************************************
062300** *
062400******************************************************************
062600 PGM06B24.
062700
062800 MOVE '1000-READ' TO WS000028.
062900
063000 READ FILE-01
063100 AT END
063300 MOVE 'Y' TO WS000102
063500 CLOSE FILE-01
063700 MOVE 'C' TO WS000100.
064000
064100 ADD 1 TO WS000108.
064200
064300 TGT0029C-EXIT.
064400 EXIT.
064500
064600******************************************************************
064700** *
064800******************************************************************
065000 PGM06BF8.
065100
065200 MOVE '2000-PROCESS-WAGES' TO WS000028.
065300
065400 MOVE FD010000 TO WS000070-G80.
065500
065600 IF WS0000B0 = 'X'
066000 ADD 1 TO WS00010D
066200 GO TO TGT002A4-EXIT.
066400
066600 IF WS0000AD = 1 OR
067100 WS0000AD = 2 OR
067600 WS0000AD = 3 OR
068100 WS0000AD = 4 OR
068600 WS0000AD = 5
069200 PERFORM PGM06EA0 THRU TGT002C4-EXIT
069400 GO TO PGM06CE2.
069600
069800 IF WS0000AE > 12
070200 PERFORM PGM06EFC THRU TGT002CC-EXIT
070400 GO TO PGM06CE2.
070600
070700 PERFORM PGM06F6C THRU TGT002D4-EXIT.
070800
070900 PGM06CE2.
071000
071100 MOVE WS000070 TO WS0004D2.
071200
071300 MOVE WS00007F TO WS0004E3.
071400
071500 MOVE WS000093 TO WS0004F9.
071600
071700 MOVE WS00009D TO WS000505.
071800
071900 MOVE WS00009F TO WS000509.
072000
072100 MOVE WS0000A4 TO WS000510.
072200
072300 MOVE WS0000AD TO WS00051B.
072400
072500 MOVE WS0000AE TO WS00051C.
072600
072700 MOVE WS0000B0 TO WS00051E.
072800
073000 IF WS0000AD = 1 OR
073500 WS0000AD = 4
074100 MOVE 'REG1/4' TO WS00051F
074200 ELSE
074700 IF WS0000AD = 2 OR
075200 WS0000AD = 5
075800 MOVE 'REG2/5' TO WS00051F
075900 ELSE
076400 IF WS0000AD = 3
076800 MOVE 'REG 3' TO WS00051F
076900 ELSE
077400 IF WS0000AE = ZERO
077800 MOVE 'PC2-Z' TO WS00051F
077900 ELSE
078300 IF WS0000B0 = 'F'
078700 MOVE 'FULL' TO WS00051F
078800 ELSE
079200 IF WS0000B0 = 'P'
079600 MOVE 'PART' TO WS00051F
079700 ELSE
080100 MOVE 'N/A' TO WS00051F.
080200
080500 MOVE WS0000B1 TO WS000527.
080600
080700 MOVE WS0000B6 TO WS00052F.
080800
080900 MOVE WS0000BB TO WS000537.
081000
081100 MOVE WS0000C0 TO WS00053F.
081200
081300 PERFORM PGM07002 THRU TGT002DC-EXIT.
081400
081500 PERFORM PGM06B24 THRU TGT0029C-EXIT.
081600
081900 TGT002A4-EXIT.
082000 EXIT.
082100
082200******************************************************************
082300** *
082400******************************************************************
082600 PGM06EA0.
082700
082800 MOVE '2100-CALC' TO WS000028
082900
082910 COMPUTE WS0000C0 =
082930 ( WS0000B1 * WS0000B6 ) +
082940 ( WS0000B1 * WS0000BB * 1.5 ).
084000
084500 TGT002C4-EXIT.
084600 EXIT.
084700
084800******************************************************************
084900** *
085000******************************************************************
085200 PGM06EFC.
085300
085400 MOVE '2200-CALC' TO WS000028.
085500
085600 CALL WS000020
085700 USING WS0000AD
085800 WS0000B1
085900 WS0000B6
086000 WS0000BB
086100 WS0000C0.
086200
086300 TGT002CC-EXIT.
086400 EXIT.
086500
086600******************************************************************
086700** *
086800******************************************************************
087000 PGM06F6C.
087100
087200 MOVE '2300-CALC' TO WS000028.
087300
087500 IF WS0000AE < 12
087900 SET INDEX-01 TO WS0000AE
088000 ELSE
088900 SET INDEX-01 TO 1.
089000
089600 COMPUTE WS0000C0 =
089620 ( WS0000B6 * WS0005E2 ( INDEX-01 )) +
089630 ( WS0000BB * WS0005E2 ( INDEX-01 ) * 1.5 ).
091200 TGT002D4-EXIT.
091300 EXIT.
091400
091500******************************************************************
091600** *
091700******************************************************************
091900 PGM07002.
092000
092100 MOVE '3000-WRITE' TO WS000028.
092200
092400 IF WS000117 > 56
092800 PERFORM PGM06A42 THRU TGT002BC-EXIT.
093100
093200 ADD 1 TO WS00010A.
093300
093400 MOVE WS0004C8-G133 TO FD020000.
093500
093600 WRITE FD020
093700 AFTER ADVANCING 1 LINES.
093800
093900 ADD 1 TO WS000117.
094000
094100 TGT002DC-EXIT.
094200 EXIT.
094300
094400******************************************************************
094500** *
094600******************************************************************
094800 PGM07092.
094900
095000 MOVE '9999-TERMINATE' TO WS000028.
095100
095200 IF WS000100 = 'O'
095600 CLOSE FILE-01.
095700
096000 IF WS000101 = 'O'
096400 CLOSE FILE-02.
096500
096800 IF WS000068 > 0
097300 DISPLAY 'ERROR CODE: '
097400 WS000068
097600 DISPLAY 'ERROR MSG: '
097700 WS000040.
098100 GOBACK.
098200
Since the compiler does not store any of the original data
or paragraph names in the object module, ReSource™
builds generic names based on where the item is located in
the program (e.g., "WS" for an item in Working Storage,
followed by a hexadecimal number representing the item's
displacement from the beginning of the record). Generic
names can be enhanced or replaced by ESTC's Source Code
Recovery Services.Back To Top