COBOL Examples

Before ReSource/Recovery™ {Examples Page}	Click For Assembler Example

Click For Assembler Example	After ReSource/Recovery™

000100 IDENTIFICATION DIVISION.
  000200 PROGRAM-ID. DDOS.
  000300******************************************************************
  000400** *
  000500* © 1996 RECOVERED BY THE SOURCE RECOVERY COMPANY OF GA *
  000800** *
  000900******************************************************************
  001000
  001100 ENVIRONMENT DIVISION.
  001200
  001300 CONFIGURATION SECTION.
  001400 SPECIAL-NAMES.
  001500 C01 IS TO-TOP-OF-PAGE.
  001600
  001700 INPUT-OUTPUT SECTION.
  001800 FILE-CONTROL.
  001900 SELECT WAGE-FILE ASSIGN TO UT-S-WAGEFILE.
  002000 SELECT PAYROLL-REPORT ASSIGN TO UT-S-PAYROLL.
  002100
  002200 DATA DIVISION.
  002300
  002400 FILE SECTION.
  002500
  002600 FD WAGE-FILE
  002700 RECORDING MODE IS F
  002800 LABEL RECORDS ARE STANDARD
  002900 RECORD CONTAINS 80 CHARACTERS
  003000 BLOCK CONTAINS 0 RECORDS.
  003100 01 WAGE-RECORD.
  003200 05 IN-NAME PIC X(15).
  003300 05 IN-ADDRESS PIC X(20).
  003400 05 IN-CITY PIC X(10).
  003500 05 IN-STATE PIC X(02).
  003600 05 IN-ZIP PIC X(05).
  003700 05 IN-SSN PIC X(09).
  003800 05 IN-CODE-01 PIC 9(02).
  003900 05 IN-CODE-02 PIC 9(02).
  004000 05 IN-RATE PIC 9(03)V99.
  004100 05 IN-REG-HOURS PIC 9(03)V99.
  004200 05 IN-OT-HOURS PIC 9(03)V99.
  004300
  004400 FD PAYROLL-REPORT
  004500 RECORDING MODE IS F
  004600 LABEL RECORDS ARE STANDARD
  004700 RECORD CONTAINS 133 CHARACTERS
  004800 BLOCK CONTAINS 0 RECORDS.
  004900 01 PAY-RECORD PIC X(133).
  005000
  005100 WORKING-STORAGE SECTION.
  005200
  005300 01 WS-START.
  005400 05 FILLER PIC X(30)
  005500 VALUE 'WORKING STORAGE STARTS HERE'.
  005600
  005700 01 WS-CALC-PGM PIC X(08) VALUE 'USERPGM'.
  005800
  005900 01 WS-PARA PIC X(19) VALUE SPACES JUSTIFIED.
  006000
  006100 01 WS-ERROR-MSG PIC X(40) VALUE SPACES.
  006200
  006300 01 WS-ERROR-CODE PIC 9(04) COMP VALUE 0.
  006400
  006500 01 WS-INPUT-RECORD.
  006600 05 WS-NAME PIC X(15).
  006700 05 WS-ADDRESS PIC X(20).
  006800 05 WS-CITY PIC X(10).
  006900 05 WS-STATE PIC X(02).
  007000 05 WS-ZIP PIC X(05).
  007100 05 WS-SSN PIC X(09).
  007200 05 WS-CODE-01 PIC 9(01).
  007300 05 WS-CODE-02 PIC 9(02).
  007400 05 WS-CODE-03 PIC X(01).
  007500 05 WS-RATE PIC 9(03)V99.
  007600 05 WS-REG-HOURS PIC 9(03)V99.
  007700 05 WS-OT-HOURS PIC 9(03)V99.
  007800
  007900 01 WS-GROSS PIC 9(05)V99 VALUE ZERO.
  008000
  008100 01 WS-GROSS-TOTAL PIC 9(07)V99 VALUE ZERO.
  008200 01 WS-GROSS-REG PIC 9(07)V99 VALUE ZERO.
  008300 01 WS-GROSS-OT PIC 9(07)V99 VALUE ZERO.
  008400
  008500 01 WS-PARM.
  008600 05 WS-MM PIC 9(02).
  008700 05 WS-DD PIC 9(02).
  008800 05 WS-YY PIC 9(02).
  008900
  009000 01 WS-SWITCHES.
  009100 05 INPUT-FILE-SW PIC X(01) VALUE 'C'.
  009200 88 INPUT-OPEN VALUE 'O'.
  009300 05 OUTPUT-FILE-SW PIC X(01) VALUE 'C'.
  009400 88 OUTPUT-OPEN VALUE 'O'.
  009500 05 INPUT-EOF-SW PIC X(01) VALUE 'N'.
  009600 88 INPUT-EOF VALUE 'Y'.
  009700 05 MONTH-SW PIC X(01) VALUE 'N'.
  009800 88 MONTH-NOT-FOUND VALUE 'N'.
  009900 88 MONTH-FOUND VALUE 'Y'.
  010000 05 WS-CALL-SW PIC X(01).
  010100 88 REGULAR VALUE 'R'.
  010200 88 OVERTIME VALUE 'O'.
  010300
  010400 01 WS-COUNTS.
  010500 05 RECORDS-READ PIC 9(04) COMP VALUE ZERO.
  010600 05 RECORDS-WRITTEN PIC 9(05) COMP-3 VALUE ZERO.
  010700 05 RECORDS-REJECTED PIC 9(05) VALUE ZERO.
  010800 05 PAGE-COUNT PIC 9(05) VALUE 1.
  010900 05 LINE-COUNT PIC 9(02) VALUE 99.
  011000 05 WS-LINES PIC 9(01) VALUE 3.
  011100
  011200 01 WS-DATE-DAY-TIME-FIELDS.
  011300 05 WS-CURRENT-DATE PIC X(08).
  011400 05 WS-TIME-OF-DAY PIC 9(06).
  011500 05 WS-SIGNED-TIME-OF-DAY PIC S9(06).
  011600 05 WS-DATE PIC 9(06).
  011700 05 WS-DAY PIC 9(05).
  011800 05 WS-TIME PIC 9(08).
  011900
  012000 01 X-FIELDS.
  012100 05 X-01 PIC X(01).
  012200 05 X-02 PIC X(02) VALUE SPACES.
  012300 05 X-04 PIC X(04) VALUE SPACES.
  012400 05 X-08 PIC X(08) VALUE SPACES.
  012500 05 X-10 PIC X(10).
  012600 05 X-20 PIC X(20) VALUE SPACES.
  012700 05 X-40 PIC X(40).
  012800 05 X-80 PIC X(80) VALUE 'FRED BRANDES'.
  012900
  013000 01 S9-COMP-3-FIELDS.
  013100 05 S9-3-C3 PIC S9(03) COMP-3 VALUE ZERO.
  013200 05 S9-4-C3 PIC S9(04) COMP-3 VALUE +0.
  013300 05 S9-5-C3 PIC S9(05) COMP-3 VALUE ZERO.
  013400 05 S9-6-C3 PIC S9(06) COMP-3.
  013500 05 S9-7-C3 PIC S9(07) COMP-3.
  013600 05 S9-8-C3 PIC S9(08) COMP-3.
  013700 05 S9-9-C3 PIC S9(09) COMP-3.
  013800 05 S9-5-V2-C3 PIC S9(05)V99 COMP-3 VALUE ZERO.
  013900 05 S9-5-V3-C3 PIC S9(05)V999 COMP-3 VALUE ZEROS.
  014000
  014100 01 U9-COMP-3-FIELDS.
  014200 05 U9-3-C3 PIC 9(03) COMP-3 VALUE ZERO.
  014300 05 U9-4-C3 PIC 9(04) COMP-3 VALUE ZERO.
  014400 05 U9-5-C3 PIC 9(05) COMP-3 VALUE ZERO.
  014500 05 U9-6-C3 PIC 9(06) COMP-3.
  014600 05 U9-7-C3 PIC 9(07) COMP-3.
  014700 05 U9-8-C3 PIC 9(08) COMP-3.
  014800 05 U9-9-C3 PIC 9(09) COMP-3.
  014900 05 U9-5-V2-C3 PIC 9(05)V99 COMP-3 VALUE 0.
  015000 05 U9-5-V3-C3 PIC 9(05)V999 COMP-3 VALUE ZEROS.
  015100
  015200 01 S9-FIELDS.
  015300 05 S9-3 PIC S9(03) VALUE ZERO.
  015400 05 S9-4 PIC S9(04) VALUE +12.
  015500 05 S9-5 PIC S9(05) VALUE ZERO.
  015600 05 S9-6 PIC S9(06).
  015700 05 S9-7 PIC S9(07).
  015800 05 S9-8 PIC S9(08).
  015900 05 S9-9 PIC S9(09).
  016000 05 S9-5-V2 PIC S9(05)V99 VALUE ZERO.
  016100 05 S9-5-V3 PIC S9(05)V999 VALUE ZEROS.
  016200
  016300 01 U9-FIELDS.
  016400 05 U9-3 PIC 9(03) VALUE 0.
  016500 05 U9-4 PIC 9(04) VALUE ZERO.
  016600 05 U9-5 PIC 9(05).
  016700 05 U9-6 PIC 9(06).
  016800 05 U9-7 PIC 9(07).
  016900 05 U9-8 PIC 9(08).
  017000 05 U9-9 PIC 9(09).
  017100 05 U9-5-V2 PIC 9(05)V99 VALUE 0.
  017200 05 U9-5-V3 PIC 9(05)V999 VALUE ZEROS.
  017300
  017400 01 S9-COMP-FIELDS.
  017500 05 S9-3-C PIC S9(03) COMP VALUE ZERO.
  017600 05 S9-4-C PIC S9(04) COMP VALUE +12.
  017700 05 S9-5-C PIC S9(05) COMP VALUE ZERO.
  017800 05 S9-6-C PIC S9(06) COMP.
  017900 05 S9-7-C PIC S9(07) COMP.
  018000 05 S9-8-C PIC S9(08) COMP.
  018100 05 S9-9-C PIC S9(09) COMP VALUE +15.
  018200
  018300 01 U9-COMP-FIELDS.
  018400 05 U9-3-C PIC 9(03) COMP VALUE ZERO.
  018500 05 U9-4-C PIC 9(04) COMP VALUE 12.
  018600 05 U9-5-C PIC 9(05) COMP VALUE ZERO.
  018700 05 U9-6-C PIC 9(06) COMP.
  018800 05 U9-7-C PIC 9(07) COMP.
  018900 05 U9-8-C PIC 9(08) COMP.
  019000 05 U9-9-C PIC 9(09) COMP VALUE 12.
  019100
  019200 01 EDIT-FIELDS.
  019300 05 ZZZCZZZP99 PIC ZZZ,ZZZ.99.
  019400 05 ZZZCZZ9P99 PIC ZZZ,ZZ9.99.
  019500 05 ZZZCZZ9 PIC ZZZ,ZZ9.
  019600 05 ZZZZZ9 PIC ZZZZZ9.
  019700 05 ZZZZ9 PIC ZZZZ9.
  019800 05 ZZZ9 PIC ZZZ9.
  019900 05 ZZZ PIC ZZZ.
  020000 05 ZZ9P99MINUS PIC ZZ9.99-.
  020100 05 ZZ9P99CR PIC ZZ9.99CR.
  020200
  020300 01 HEADING-01.
  020400 05 FILLER PIC X(01) VALUE SPACES.
  020500 05 FILLER PIC X(10) VALUE SPACES.
  020600 05 FILLER PIC X(40)
  020700 VALUE 'THE SOURCE RECOVERY COMPANY, LLC.'.
  020800 05 FILLER PIC X(10) VALUE SPACES.
  020900 05 FILLER PIC X(23) VALUE 'WAGE REPORT'.
  021000 05 FILLER PIC X(12) VALUE 'REPORT DATE '.
  021100 05 RPT-MONTH PIC X(09) VALUE 'MONTH'.
  021200 05 FILLER PIC X(01) VALUE SPACES.
  021300 05 RPT-DD PIC X(02) VALUE 'DD'.
  021400 05 FILLER PIC X(01) VALUE ','.
  021500 05 RPT-CC PIC X(02) VALUE '19'.
  021600 05 RPT-YY PIC X(02) VALUE 'YY'.
  021700 05 FILLER PIC X(10) VALUE SPACES.
  021800 05 FILLER PIC X(05) VALUE 'PAGE '.
  021900 05 PAGE-01 PIC ZZZZ9.
  022000
  022100 01 HEADING-02.
  022200 05 FILLER PIC X(01) VALUE SPACE.
  022300 05 FILLER PIC X(09) VALUE SPACE.
  022400 05 FILLER PIC X(15) VALUE 'NAME'.
  022500 05 FILLER PIC X(02) VALUE SPACES.
  022600 05 FILLER PIC X(20) VALUE 'ADDRESS'.
  022700 05 FILLER PIC X(02) VALUE SPACES.
  022800 05 FILLER PIC X(10) VALUE 'CITY'.
  022900 05 FILLER PIC X(02) VALUE SPACES.
  023000 05 FILLER PIC X(02) VALUE 'ST'.
  023100 05 FILLER PIC X(02) VALUE SPACES.
  023200 05 FILLER PIC X(05) VALUE 'ZIP'.
  023300 05 FILLER PIC X(02) VALUE SPACES.
  023400 05 FILLER PIC X(09) VALUE 'SSN'.
  023500 05 FILLER PIC X(02) VALUE SPACES.
  023600 05 FILLER PIC X(10) VALUE 'PAYCODE'.
  023700 05 FILLER PIC X(02) VALUE SPACES.
  023800 05 FILLER PIC X(06) VALUE 'RATE'.
  023900 05 FILLER PIC X(02) VALUE SPACES.
  024000 05 FILLER PIC X(06) VALUE 'REG HR'.
  024100 05 FILLER PIC X(02) VALUE SPACES.
  024200 05 FILLER PIC X(06) VALUE 'OT HR'.
  024300 05 FILLER PIC X(02) VALUE SPACES.
  024400 05 FILLER PIC X(08) VALUE 'GROSS'.
  024500 05 FILLER PIC X(06) VALUE SPACES.
  024600
  024700 01 HEADING-03.
  024800 05 FILLER PIC X(01) VALUE SPACE.
  024900 05 FILLER PIC X(09) VALUE SPACE.
  025000 05 FILLER PIC X(20) VALUE 'YEAR TO DATE TOTALS:'.
  025100 05 FILLER PIC X(67) VALUE SPACES.
  025200 05 FILLER PIC X(08) VALUE 'REG HR'.
  025300 05 FILLER PIC X(02) VALUE SPACES.
  025400 05 FILLER PIC X(08) VALUE 'OT HR'.
  025500 05 FILLER PIC X(02) VALUE SPACES.
  025600 05 FILLER PIC X(10) VALUE 'YTD GROSS'.
  025700 05 FILLER PIC X(06) VALUE SPACES.
  025800
  025900 01 DETAIL-01.
  026000 05 FILLER PIC X(01).
  026100 05 FILLER PIC X(09).
  026200 05 DTL-NAME PIC X(15).
  026300 05 FILLER PIC X(02).
  026400 05 DTL-ADDRESS PIC X(20).
  026500 05 FILLER PIC X(02).
  026600 05 DTL-CITY PIC X(10).
  026700 05 FILLER PIC X(02).
  026800 05 DTL-STATE PIC X(02).
  026900 05 FILLER PIC X(02).
  027000 05 DTL-ZIP PIC X(05).
  027100 05 FILLER PIC X(02).
  027200 05 DTL-SSN PIC X(09).
  027300 05 FILLER PIC X(02).
  027400 05 DTL-PAYCODE.
  027500 10 DTL-CODE-01 PIC 9(01).
  027600 10 DTL-CODE-02 PIC 9(02).
  027700 10 DTL-CODE-03 PIC X(01).
  027800 10 DTL-DESC PIC X(06).
  027900 05 FILLER PIC X(02).
  028000 05 DTL-RATE PIC ZZ9.99.
  028100 05 FILLER PIC X(02).
  028200 05 DTL-REG PIC ZZ9.99.
  028300 05 FILLER PIC X(02).
  028400 05 DTL-OT PIC ZZ9.99.
  028500 05 FILLER PIC X(02).
  028600 05 DTL-GROSS PIC Z,ZZZ.99.
  028700 05 FILLER PIC X(06).
  028800 01 DETAIL-02 REDEFINES DETAIL-01.
  028900 05 FILLER PIC X(01).
  029000 05 FILLER PIC X(96).
  029100 05 TOT-REG PIC Z,ZZ9.99.
  029200 05 FILLER PIC X(02).
  029300 05 TOT-OT PIC Z,ZZ9.99.
  029400 05 FILLER PIC X(02).
  029500 05 TOT-GROSS PIC ZZZ,ZZ9.99.
  029600 05 FILLER PIC X(06).
  029700
  029800 01 SUB-SCRIPTS.
  029900 05 SUB-1 PIC S9(04) COMP.
  030000 05 SUB-1-C3 PIC S9(03) COMP-3.
  030100 05 SUB-1-9 PIC 9(03).
  030200
  030300 01 MONTH-VALUES.
  030400 05 FILLER PIC 9(02) VALUE 1.
  030500 05 FILLER PIC X(09) VALUE 'JANUARY'.
  030600 05 FILLER PIC 9(02) VALUE 2.
  030700 05 FILLER PIC X(09) VALUE 'FEBRUARY'.
  030800 05 FILLER PIC 9(02) VALUE 3.
  030900 05 FILLER PIC X(09) VALUE 'MARCH'.
  031000 05 FILLER PIC 9(02) VALUE 4.
  031100 05 FILLER PIC X(09) VALUE 'APRIL'.
  031200 05 FILLER PIC 9(02) VALUE 5.
  031300 05 FILLER PIC X(09) VALUE 'MAY'.
  031400 05 FILLER PIC 9(02) VALUE 6.
  031500 05 FILLER PIC X(09) VALUE 'JUNE'.
  031600 05 FILLER PIC 9(02) VALUE 7.
  031700 05 FILLER PIC X(09) VALUE 'JULY'.
  031800 05 FILLER PIC 9(02) VALUE 8.
  031900 05 FILLER PIC X(09) VALUE 'AUGUST'.
  032000 05 FILLER PIC 9(02) VALUE 9.
  032100 05 FILLER PIC X(09) VALUE 'SEPTEMBER'.
  032200 05 FILLER PIC 9(02) VALUE 10.
  032300 05 FILLER PIC X(09) VALUE 'OCTOBER'.
  032400 05 FILLER PIC 9(02) VALUE 11.
  032500 05 FILLER PIC X(09) VALUE 'NOVEMBER'.
  032600 05 FILLER PIC 9(02) VALUE 12.
  032700 05 FILLER PIC X(09) VALUE 'DECEMBER'.
  032800
  032900 01 MONTHS REDEFINES MONTH-VALUES.
  033000 05 MONTH-TABLE OCCURS 12 TIMES.
  033100 10 MM PIC 9(02).
  033200 10 MONTH-NAME PIC X(09).
  033300
  033400 01 RATE-VALUES.
  033500 05 FILLER PIC 9(02) VALUE 1.
  033600 05 FILLER PIC 9(03)V99 VALUE 4.15.
  033700 05 FILLER PIC 9(02) VALUE 2.
  033800 05 FILLER PIC 9(03)V99 VALUE 5.25.
  033900 05 FILLER PIC 9(02) VALUE 3.
  034000 05 FILLER PIC 9(03)V99 VALUE 6.50.
  034100 05 FILLER PIC 9(02) VALUE 4.
  034200 05 FILLER PIC 9(03)V99 VALUE 7.75.
  034300 05 FILLER PIC 9(02) VALUE 5.
  034400 05 FILLER PIC 9(03)V99 VALUE 9.00.
  034500 05 FILLER PIC 9(02) VALUE 6.
  034600 05 FILLER PIC 9(03)V99 VALUE 10.75.
  034700 05 FILLER PIC 9(02) VALUE 7.
  034800 05 FILLER PIC 9(03)V99 VALUE 12.50.
  034900 05 FILLER PIC 9(02) VALUE 8.
  035000 05 FILLER PIC 9(03)V99 VALUE 15.00.
  035100 05 FILLER PIC 9(02) VALUE 9.
  035200 05 FILLER PIC 9(03)V99 VALUE 18.00.
  035300 05 FILLER PIC 9(02) VALUE 10.
  035400 05 FILLER PIC 9(03)V99 VALUE 22.00.
  035500 05 FILLER PIC 9(02) VALUE 11.
  035600 05 FILLER PIC 9(03)V99 VALUE 27.00.
  035700 05 FILLER PIC 9(02) VALUE 12.
  035800 05 FILLER PIC 9(03)V99 VALUE 32.00.
  035900 01 RATE-TABLE REDEFINES RATE-VALUES.
  036000 05 RATES OCCURS 12 TIMES
  036100 INDEXED BY RATE-INDEX.
  036200 10 RATE-CODE PIC 9(02).
  036300 10 RATE PIC 9(03)V99.
  036400
  036500 01 WS-WORK-TABLE.
  036600 05 WS-WORK-ROW OCCURS 100 TIMES.
  036700 10 WS-WORK-COL OCCURS 100 TIMES.
  036800 15 WS-WORK-ELEMENT PIC 9(04) COMP.
  036900
  037000 01 WS-MOVE-LONG.
  037100 05 WS-MOVE-LONG-01 PIC X(2000).
  037200
  037300******************************************************************
  037400* *
  037500******************************************************************
  037600 LINKAGE SECTION.
  037700
  037800 01 LNK-MOVE-LONG.
  037900 05 LNK-MOVE-LONG-01 PIC X(2000).
  038000
  038100******************************************************************
  038200* *
  038300******************************************************************
  038400 PROCEDURE DIVISION USING LNK-MOVE-LONG.
  038500
  038600 0000-MAINLINE.
  038700
  038800 MOVE '0000-MAINLINE' TO WS-PARA.
  038900
  039000 MOVE LNK-MOVE-LONG TO WS-MOVE-LONG.
  039100
  039200 PERFORM 0100-INIT THRU 0100-EXIT.
  039300
  039400 PERFORM 1000-READ THRU 1000-EXIT.
  039500
  039600 IF INPUT-EOF
  039700 MOVE 'WAGE FILE IS EMPTY' TO WS-ERROR-MSG
  039800 MOVE 1002 TO WS-ERROR-CODE
  039900 GO TO 9999-TERMINATE.
  040000
  040100 PERFORM 2000-PROCESS-WAGES THRU 2000-EXIT
  040200 UNTIL INPUT-EOF.
  040300
  040400 MOVE WS-GROSS-REG TO TOT-REG.
  040500
  040600 MOVE WS-GROSS-OT TO TOT-OT.
  040700
  040800 MOVE WS-GROSS-TOTAL TO TOT-GROSS.
  040900
  041000 WRITE PAY-RECORD FROM DETAIL-02
  041100 AFTER ADVANCING WS-LINES LINES.
  041200
  041300 CLOSE PAYROLL-REPORT.
  041400
  041500 DISPLAY 'COUNT OF RECORDS READ '
  041600 RECORDS-READ.
  041700
  041800 DISPLAY 'COUNT OF RECORDS REJECTED '
  041900 RECORDS-REJECTED.
  042000
  042100 DISPLAY 'COUNT OF RECORDS WRITTEN '
  042200 RECORDS-WRITTEN.
  042300
  042400 GOBACK.
  042500
  042600******************************************************************
  042700* *
  042800******************************************************************
  042900 0100-INIT.
  043000
  043100 MOVE '0100-INIT' TO WS-PARA.
  043200
  043300 MOVE CURRENT-DATE TO WS-CURRENT-DATE.
  043400
  043500 DISPLAY 'RUN DATE: '
  043600 WS-CURRENT-DATE.
  043700
  043800 OPEN INPUT WAGE-FILE
  043900 OUTPUT PAYROLL-REPORT.
  044000
  044100 MOVE 'O' TO INPUT-FILE-SW.
  044200
  044300 MOVE 'O' TO OUTPUT-FILE-SW.
  044400
  044500 ACCEPT WS-PARM FROM CONSOLE.
  044600
  044700 IF WS-MM NOT NUMERIC
  044800 MOVE 'MONTH NOT NUMERIC' TO WS-ERROR-MSG
  044900 MOVE 1010 TO WS-ERROR-CODE
  045000 GO TO 9999-TERMINATE.
  045100
  045200 IF WS-DD NOT NUMERIC
  045300 MOVE 'DAY NOT NUMERIC' TO WS-ERROR-MSG
  045400 MOVE 1010 TO WS-ERROR-CODE
  045500 GO TO 9999-TERMINATE.
  045600
  045700 IF WS-YY NOT NUMERIC
  045800 MOVE 'YEAR NOT NUMERIC' TO WS-ERROR-MSG
  045900 MOVE 1010 TO WS-ERROR-CODE
  046000 GO TO 9999-TERMINATE.
  046100
  046200 PERFORM 0200-INIT-HEADINGS THRU 0200-EXIT.
  046300
  046400 0100-EXIT.
  046500 EXIT.
  046600
  046700******************************************************************
  046800* *
  046900******************************************************************
  047000 0200-INIT-HEADINGS.
  047100
  047200 MOVE '0200-INIT-HEADINGS' TO WS-PARA.
  047300
  047400 PERFORM 0300-GET-MONTH
  047500 VARYING SUB-1 FROM 1 BY 1
  047600 UNTIL SUB-1 > 12 OR
  047700 MONTH-FOUND.
  047800
  047900 IF MONTH-NOT-FOUND
  048000 MOVE 'INVALID MONTH SPECIFIED' TO WS-ERROR-MSG
  048100 MOVE 1001 TO WS-ERROR-CODE
  048200 GO TO 9999-TERMINATE.
  048300
  048400 MOVE MONTH-NAME (SUB-1) TO RPT-MONTH.
  048500
  048600 MOVE WS-DD TO RPT-DD.
  048700
  048800 MOVE '19' TO RPT-CC.
  048900
  049000 MOVE WS-YY TO RPT-YY.
  049100
  049200 0200-EXIT.
  049300 EXIT.
  049400
  049500******************************************************************
  049600* *
  049700******************************************************************
  049800 0300-GET-MONTH.
  049900
  050000 MOVE '0300-GET-MONTH' TO WS-PARA.
  050100
  050200 IF WS-MM = MM (SUB-1)
  050300 MOVE 'Y' TO MONTH-SW.
  050400
  050500 0300-EXIT.
  050600 EXIT.
  050700
  050800******************************************************************
  050900* *
  051000******************************************************************
  051100 0900-HEADINGS.
  051200
  051300 MOVE '0900-HEADINGS' TO WS-PARA.
  051400
  051500 MOVE PAGE-COUNT TO PAGE-01.
  051600
  051700 WRITE PAY-RECORD FROM HEADING-01
  051800 AFTER ADVANCING TO-TOP-OF-PAGE.
  051900
  052000 WRITE PAY-RECORD FROM HEADING-02
  052100 AFTER ADVANCING 2 LINES.
  052200
  052300 MOVE SPACES TO PAY-RECORD.
  052400
  052500 WRITE PAY-RECORD
  052600 AFTER ADVANCING 1 LINES.
  052700
  052800 ADD 1 TO PAGE-COUNT.
  052900
  053000 MOVE 4 TO LINE-COUNT.
  053100
  053200 0900-EXIT.
  053300 EXIT.
  053400
  053500******************************************************************
  053600* *
  053700******************************************************************
  053800 1000-READ.
  053900
  054000 MOVE '1000-READ' TO WS-PARA.
  054100
  054200 READ WAGE-FILE
  054300 AT END
  054400 MOVE 'Y' TO INPUT-EOF-SW
  054500 CLOSE WAGE-FILE
  054600 MOVE 'C' TO INPUT-FILE-SW.
  054700
  054800 ADD 1 TO RECORDS-READ.
  054900
  055000 1000-EXIT.
  055100 EXIT.
  055200
  055300******************************************************************
  055400* *
  055500******************************************************************
  055600 2000-PROCESS-WAGES.
  055700
  055800 MOVE '2000-PROCESS-WAGES' TO WS-PARA.
  055900
  056000 MOVE WAGE-RECORD TO WS-INPUT-RECORD.
  056100
  056200 IF WS-CODE-03 = 'X'
  056300 ADD 1 TO RECORDS-REJECTED
  056400 GO TO 2000-EXIT.
  056500
  056600 IF WS-CODE-01 = 1 OR 2 OR 3 OR 4 OR 5
  056700 PERFORM 2100-CALC THRU 2100-EXIT
  056800 ELSE IF WS-CODE-02 > 12
  056900 PERFORM 2200-CALC THRU 2200-EXIT
  057000 ELSE
  057100 PERFORM 2300-CALC THRU 2300-EXIT.
  057200
  057300 MOVE WS-NAME TO DTL-NAME.
  057400
  057500 MOVE WS-ADDRESS TO DTL-ADDRESS.
  057600
  057700 MOVE WS-CITY TO DTL-CITY.
  057800
  057900 MOVE WS-STATE TO DTL-STATE.
  058000
  058100 MOVE WS-ZIP TO DTL-ZIP.
  058200
  058300 MOVE WS-SSN TO DTL-SSN.
  058400
  058500 MOVE WS-CODE-01 TO DTL-CODE-01.
  058600
  058700 MOVE WS-CODE-02 TO DTL-CODE-02.
  058800
  058900 MOVE WS-CODE-03 TO DTL-CODE-03.
  059000
  059100 IF WS-CODE-01 = 1 OR 4
  059200 MOVE 'REG1/4' TO DTL-DESC
  059300 ELSE IF WS-CODE-01 = 2 OR 5
  059400 MOVE 'REG2/5' TO DTL-DESC
  059500 ELSE IF WS-CODE-01 = 3
  059600 MOVE 'REG 3' TO DTL-DESC
  059700 ELSE IF WS-CODE-02 = ZERO
  059800 MOVE 'PC2-Z' TO DTL-DESC
  059900 ELSE IF WS-CODE-03 = 'F'
  060000 MOVE 'FULL' TO DTL-DESC
  060100 ELSE IF WS-CODE-03 = 'P'
  060200 MOVE 'PART' TO DTL-DESC
  060300 ELSE
  060400 MOVE 'N/A' TO DTL-DESC.
  060500
  060600 MOVE WS-RATE TO DTL-RATE.
  060700
  060800 MOVE WS-REG-HOURS TO DTL-REG.
  060900
  061000 MOVE WS-OT-HOURS TO DTL-OT.
  061100
  061200 MOVE WS-GROSS TO DTL-GROSS.
  061300
  061400 PERFORM 3000-WRITE THRU 3000-EXIT.
  061500
  061600 PERFORM 1000-READ THRU 1000-EXIT.
  061700
  061800 2000-EXIT.
  061900 EXIT.
  062000
  062100******************************************************************
  062200* *
  062300******************************************************************
  062400 2100-CALC.
  062500
  062600 MOVE '2100-CALC' TO WS-PARA.
  062700
  062800 COMPUTE WS-GROSS = (WS-RATE * WS-REG-HOURS) +
  062900 (WS-RATE * WS-OT-HOURS * 1.5).
  063000
  063100 2100-EXIT.
  063200 EXIT.
  063300
  063400******************************************************************
  063500* *
  063600******************************************************************
  063700 2200-CALC.
  063800
  063900 MOVE '2200-CALC' TO WS-PARA.
  064000
  064100 CALL WS-CALC-PGM USING WS-CODE-01
  064200 WS-RATE
  064300 WS-REG-HOURS
  064400 WS-OT-HOURS
  064500 WS-GROSS.
  064600
  064700 2200-EXIT.
  064800 EXIT.
  064900
  065000******************************************************************
  065100* *
  065200******************************************************************
  065300 2300-CALC.
  065400
  065500 MOVE '2300-CALC' TO WS-PARA.
  065600
  065700 IF WS-CODE-02 < 12
  065800 SET RATE-INDEX TO WS-CODE-02
  065900 ELSE
  066000 SET RATE-INDEX TO 1.
  066100
  066200 COMPUTE WS-GROSS = (WS-REG-HOURS *
  066300 RATE (RATE-INDEX)) +
  066400 (WS-OT-HOURS *
  066500 RATE (RATE-INDEX) * 1.5).
  066600
  066700 2300-EXIT.
  066800 EXIT.
  066900
  067000******************************************************************
  067100* *
  067200******************************************************************
  067300 3000-WRITE.
  067400
  067500 MOVE '3000-WRITE' TO WS-PARA.
  067600
  067700 IF LINE-COUNT > 56
  067800 PERFORM 0900-HEADINGS THRU 0900-EXIT.
  067900
  068000 ADD 1 TO RECORDS-WRITTEN.
  068100
  068200 WRITE PAY-RECORD FROM DETAIL-01
  068300 AFTER ADVANCING 1 LINES.
  068400
  068500 ADD 1 TO LINE-COUNT.
  068600
  068700 3000-EXIT.
  068800 EXIT.
  068900******************************************************************
  069000* *
  069100******************************************************************
  069200 9999-TERMINATE.
  069300
  069400 MOVE '9999-TERMINATE' TO WS-PARA.
  069500
  069600 IF INPUT-OPEN
  069700 CLOSE WAGE-FILE.
  069800
  069900 IF OUTPUT-OPEN
  070000 CLOSE PAYROLL-REPORT.
  070100
  070200 IF WS-ERROR-CODE > 0
  070300 DISPLAY 'ERROR CODE: '
  070400 WS-ERROR-CODE
  070500 DISPLAY 'ERROR MSG: '
  070600 WS-ERROR-MSG.
  070700
  070800 GOBACK.

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 THE RESOURCE PRODUCT FROM ESTC<br>
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-PAYROLL004000 ORGANIZATION IS SEQUENTIAL004100 ACCESS MODE IS SEQUENTIAL.
004200004300******************************************************************
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.
0201000
20200 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).
023600023700 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'.
026100026200 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).
27300 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.