00001  IDENTIFICATION DIVISION.                                         02/26/24
00002  PROGRAM-ID.             CHGBD200.                                CHGBD200
00003 *AUTHOR.                 TCL.                                        LV048
00004 *DATE-WRITTEN.           FEBRUARY 1999.                           CHGBD200
00005  DATE-COMPILED.                                                   CHGBD200
00006      SKIP3                                                        CHGBD200
00007 *****                                                             CHGBD200
00008 *                                                                 CHGBD200
00009 *    FUNCTION:                                                    CHGBD200
00010 *                                                                 CHGBD200
00011 *        DAILY BENEFIT CHARGE REPORTING PROCESS STEP 2            CHGBD200
00012 *          (1) READ CHGIM001 RECORDS CREATED BY CHGBD100          CHGBD200
00013 *          (2) ACCUMULATE CHARGES BY EMPLOYER/SSN/BYE             CHGBD200
00014 *          (3) WRITE CHGIM002 RECORDS TO VSAM CHARGE FILE         CHGBD200
00015 *          (4) WRITE CHGIM002 RECORDS TO FLAT FILE FOR INPUT      CHGBD200
00016 *              TO CHGBD207 (BUILD TOTAL CHARGE RECORDS)           CHGBD200
00017 *                                                                 CHGBD200
00018 *        INPUT:                                                   CHGBD200
00019 *                                                                 CHGBD200
00020 *            BD100CHG - CHARGE RECORDS GENERATED BY               CHGBD200
00021 *                       CHGBD100.                                 CHGBD200
00022 *             CHGPARM - PARAMETER DATA INPUT FROM CHGBD100        CHGBD200
00023 *                                                                 CHGBD200
00024 *       OUTPUT:                                                   CHGBD200
00025 *                                                                 CHGBD200
00026 *            BD200CHG - CHARGE REPORT RECORDS                     CHGBD200
00027 *            BD200TOT - CHARGE REPORT RECORDS PASSED TO CHGBD207  CHGBD200
00028 *                                                                 CHGBD200
00029 *****                                                             CHGBD200
00030                                                                   CHGBD200
00031 ******************************************************************CHGBD200
00032 * MODIFICATION HISTORY:                                          *CHGBD200
00033 *                                                                *CHGBD200
00034 * 02-02-1999 INITIAL DEVELOPMENT                                 *CHGBD200
00035 *            REFERENCE RFP #              AUTHOR OF CHANGE - GD  *CHGBD200
00036 *                                                                *CHGBD200
00037 * 04-09-2001 ELIMINATED THE CHG-PARM-FILE AND CHANGED CHGIM002   *CHGBD200
00038 *            TO PRODUCE A NEW VERSION OF OUTPUT PERMANENT VSAM   *CHGBD200
00039 *            FILE WITHOUT THE EMPLOYEE NAME.                     *CHGBD200
00040 *            REFERENCE RFP #              AUTHOR OF CHANGE - RW1 *CHGBD200
00041 *                                                                *CHGBD200
00042 * 03-22-2002 ADDED A NEW VALUE TEUC (THE NEW FEDERAL EXTENDED    *CHGBD200
00043 *            BENEFITS PROGRAM) TO THE PROGRAM CODE DATA ELEMENT  *CHGBD200
00044 *            IN THE CHARGE SYSTEM DISTINGUISHED BENEFIT PROGRAM. *CHGBD200
00045 *            NOW IT CONTAINS VALUES ONLY FOR UI AND EB.          *CHGBD200
00046 *            REFERENCE RFP #              AUTHOR OF CHANGE - RW1 *CHGBD200
00047 *                                                                *CHGBD200
00048 * 07-03-2002 COMMENTED OUT SPECIAL DEBUG DISPLAY OF               CHGBD200
00049 *            WK-DISP-AREA1                                        CHGBD200
00050 *            REFERENCE RFP #              AUTHOR OF CHANGE - JHP *CHGBD200
00051 *                                                                *CHGBD200
00052 * 08-06-2002 MODIFIED TO ADD THE DAILY CHARGE RECORDS TO A DISK  *CHGBD200
00053 *            FILE. THIS FILE IS INPUT TO CHGBD207 AND USED TO    *CHGBD200
00054 *            BUILD THE CHGM030 TOTAL CHARGE FILE.                *CHGBD200
00055 *            REFERENCE RFP #              AUTHOR OF CHANGE - RW1 *CHGBD200
00056 *                                                                *CHGBD200
00057 * 06-29-2004 ADDED EMP TYPE 17 - DOMESTIC VIOLENCE.              *CHGBD200
00058 *            REFERENCE RFP #              AUTHOR OF CHANGE - GD  *CHGBD200
00059 *                                                                *CHGBD200
00060 * 03-06-2009 MODIFIED FOR NEW FORMAT OF PROGRAM CODE - CHANGED   *CHGBD200
00061 *            FROM NUMERIC TO CHARACTER.                          *CHGBD200
00062 *            UPDATED EMPLOYER TYPES.                             *CHGBD200
00063 *            REFERENCE RFP #              AUTHOR OF CHANGE - GD  *CHGBD200
00064 *                                                                *CHGBD200
00065 * 08-05-2009 ADDED NEW PROGRAM CODES FOR AB,TRAINING AND         *CHGBD200
00066 *            DEPENDENTS.                                         *CHGBD200
00067 *            REFERENCE RFP #              AUTHOR OF CHANGE - ZL1 *CHGBD200
00068 *                                                                *CHGBD200
00069 * 03-31-2010 ADDED NEW PROGRAM CODES FOR SPECIAL PAYMENTS.       *CHGBD200
00070 *            REFERENCE RFP #              AUTHOR OF CHANGE - ZGD *CHGBD200
00071 *                                                                *CHGBD200
00072 * 03-19-2013 MODIFIED P1222-ADJ-CHARGE: REMOVED TEST OF          *CHGBD200
00073 *            CHG1-CHARGE-PAY-OP-RECOUP.  THIS INDICATOR, BASED   *CHGBD200
00074 *            ON CHARGE-PAY-TYPE IN THE BENEFITS FILE, DOES NOT   *CHGBD200
00075 *            CONTAIN INFORMATION ABOUT OVERPAYMENTS.  THE FIELD  *CHGBD200
00076 *            IS BLANK IN RECORDS THAT HAVE OP RECOVERY AMOUNTS.  *CHGBD200
00077 *            THE PROGRAM NOW SAVES OP RECOVERIES BASED ONLY ON   *CHGBD200
00078 *            THE CHARGE-CODE - A VALUE OF CHARGE-OP-RECOUP       *CHGBD200
00079 *            INDICATES THAT THE RECORD CONTAINS CHARGE           *CHGBD200
00080 *            ADJUSTMENTS FROM OP RECOVERIES.                     *CHGBD200
00081 *            REFERENCE                    AUTHOR OF CHANGE - GD  *CHGBD200
00082 *                                                                *CHGBD200
00083 * 09-26-2014 ADDED NEW PROGRAM CODES FOR UCPIA                   *CHGBD200
00084 *            REFERENCE RFP #              AUTHOR OF CHANGE - ZL1 *CHGBD200
00085 *                                                                *CHGBD200
00086 *                                                                *   CL**2
00087 * 04-14-2020 ADDED NEW PROGRAM CODES FOR PUA, FPUC AND FRUR      *   CL**2
00088 *            REFERENCE RFP #              AUTHOR OF CHANGE - ZL1 *   CL**2
00089 *                                                                *   CL**2
00090 *                                                                *   CL*11
00091 * 04-24-2020 ADDED NEW PROGRAM CODES FOR PEUC                    *   CL*11
00092 *            REFERENCE RFP #              AUTHOR OF CHANGE - ZL1 *   CL*11
00093 *                                                                *   CL*11
00094 *                                                                *   CL*18
00095 * 06-24-2020 ADDED NEW PROGRAM CODES FOR REUR                    *   CL*18
00096 *            CHARGES FOR RATED EMPLOYER IS MOVING TO 5032 DUE    *   CL*18
00097 *            TO COVID                                            *   CL*18
00098 *                                                                *   CL*18
00099 *                                                                *   CL*20
00100 * 09-18-2020 ADDED NEW PROGRAM CODES FOR LWA -005033             *   CL*20
00101 *            LWA CHARGES WILL COME TO DUTAS FAC                  *   CL*20
00102 *                                                                *   CL*20
00103 * 12-08-2020 ADDED NEW PROGRAM CODES FOR PUA STIMULUS 5034       *   CL*23
00104 *            PUA CHARGES WILL COME TO DUTAS AS U2                *   CL*23
00105 *                                                                *   CL*23
00106 *            REFERENCE RFP #              AUTHOR OF CHANGE - ZL1 *   CL*18
00107 *                                                                *   CL*18
00108 *                                                                *CHGBD200
00109 * MM-DD-YYYY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *CHGBD200
00110 *            XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *CHGBD200
00111 *            REFERENCE RFP #****          AUTHOR OF CHANGE - *** *CHGBD200
00112 ******************************************************************CHGBD200
00113                                                                   CHGBD200
00114      SKIP3                                                        CHGBD200
00115  ENVIRONMENT DIVISION.                                            CHGBD200
00116      SKIP3                                                        CHGBD200
00117  INPUT-OUTPUT SECTION.                                            CHGBD200
00118      SKIP3                                                        CHGBD200
00119  FILE-CONTROL.                                                    CHGBD200
00120                                                                   CHGBD200
00121      SELECT BD100-CHG-FILE  ASSIGN TO BD100CHG                    CHGBD200
00122             FILE STATUS IS BD100-CHG-STATUS.                      CHGBD200
00123                                                                   CHGBD200
00124      SELECT BD200-CHG-FILE  ASSIGN TO BD200CHG                    CHGBD200
00125             ORGANIZATION IS INDEXED                               CHGBD200
00126             ACCESS IS DYNAMIC                                     CHGBD200
00127             RECORD KEY IS BD200-CHG-REC-KEY                       CHGBD200
00128             FILE STATUS IS BD200-CHG-STATUS.                      CHGBD200
00129                                                                   CHGBD200
00130      SELECT BD200-TOTAL-CHG   ASSIGN TO BD200TOT                  CHGBD200
00131             FILE STATUS IS BD200-TOTAL-STATUS.                    CHGBD200
00132                                                                   CHGBD200
00133      SELECT BD200-SRVR-CHG   ASSIGN TO BD200SVR                   CHGBD200
00134             FILE STATUS IS BD200-TOTAL-STATUS.                    CHGBD200
00135                                                                   CHGBD200
00136      EJECT                                                        CHGBD200
00137  DATA DIVISION.                                                   CHGBD200
00138      SKIP3                                                        CHGBD200
00139  FILE SECTION.                                                    CHGBD200
00140      SKIP3                                                        CHGBD200
00141 ************************************************************      CHGBD200
00142 *    PARAMETER RECORD PASSED FROM CHGBD100.                       CHGBD200
00143 ************************************************************      CHGBD200
00144                                                                   CHGBD200
00145  FD  BD100-CHG-FILE                                               CHGBD200
00146      LABEL RECORDS ARE STANDARD                                   CHGBD200
00147      RECORDING MODE IS F                                          CHGBD200
00148      BLOCK CONTAINS 0 CHARACTERS.                                 CHGBD200
00149      SKIP1                                                        CHGBD200
00150  01  BD100-CHG-REC.                                               CHGBD200
00151  ++INCLUDE CHGIM001                                               CHGBD200
00152                                                                   CHGBD200
00153  FD  BD200-CHG-FILE                                               CHGBD200
00154      RECORD CONTAINS 64 CHARACTERS                                CHGBD200
00155      DATA RECORD IS BD200-CHG-REC.                                CHGBD200
00156      SKIP1                                                        CHGBD200
00157  01  BD200-CHG-REC.                                               CHGBD200
00158      05  BD200-CHG-REC-KEY           PIC  X(21).                  CHGBD200
00159      05  BD200-CHG-REC-DATA          PIC  X(43).                  CHGBD200
00160                                                                   CHGBD200
00161  FD  BD200-TOTAL-CHG                                              CHGBD200
00162      LABEL RECORDS ARE STANDARD                                   CHGBD200
00163      RECORDING MODE IS F                                          CHGBD200
00164      BLOCK CONTAINS 0 CHARACTERS.                                 CHGBD200
00165      SKIP1                                                        CHGBD200
00166  01  BD200-TOTAL-REC                 PIC  X(64).                  CHGBD200
00167                                                                   CHGBD200
00168  FD  BD200-SRVR-CHG                                               CHGBD200
00169      LABEL RECORDS ARE STANDARD                                   CHGBD200
00170      RECORDING MODE IS F                                          CHGBD200
00171      BLOCK CONTAINS 0 CHARACTERS.                                 CHGBD200
00172      SKIP1                                                        CHGBD200
00173  01  BD200-SRVR-REC                 PIC  X(73).                      CL*38
00174                                                                   CHGBD200
00175  WORKING-STORAGE SECTION.                                         CHGBD200
001755 77  PAN-VALET PICTURE X(24) VALUE '048CHGBD200  02/26/24'.       CHGBD200
00176  77  PAN-VALET PICTURE X(24) VALUE '146CHGBD200  10/08/14'.       CHGBD200
00177  77  PAN-VALET PICTURE X(24) VALUE '002CHGBD200  10/02/14'.       CHGBD200
00178  77  PAN-VALET PICTURE X(24) VALUE '144CHGBD200  10/01/14'.       CHGBD200
00179  77  PAN-VALET PICTURE X(24) VALUE '002CHGBD200  09/26/14'.       CHGBD200
00180  77  PAN-VALET PICTURE X(24) VALUE '142CHGBD200  03/31/14'.       CHGBD200
00181  77  PAN-VALET PICTURE X(24) VALUE '037CHGBD200  03/27/14'.       CHGBD200
00182  77  PAN-VALET PICTURE X(24) VALUE '140CHGBD200  01/02/14'.       CHGBD200
00183  77  PAN-VALET PICTURE X(24) VALUE '002CHGBD200  12/30/13'.       CHGBD200
00184  77  PAN-VALET PICTURE X(24) VALUE '138CHGBD200  10/17/13'.       CHGBD200
00185  77  PAN-VALET PICTURE X(24) VALUE '006CHGBD200  10/09/13'.       CHGBD200
00186  77  PAN-VALET PICTURE X(24) VALUE '136CHGBD200  04/01/10'.       CHGBD200
00187                                                                   CHGBD200
00188  01  WRK-AREA.                                                    CHGBD200
00189      05  ABEND-CODE                  PIC S9(04)  COMP             CHGBD200
00190                                     VALUE +200.                   CHGBD200
00191      05  ABEND-MSG                   PIC  X(60).                  CHGBD200
00192      05  FILLER REDEFINES ABEND-MSG.                              CHGBD200
00193          10  ABEND-MSG-TEXT          PIC X(59).                   CHGBD200
00194          10  ABEND-MSG-PROG-CODE     PIC X(01).                   CHGBD200
00195                                                                   CHGBD200
00196      05  ABEND-MOD                   PIC  X(08)                   CHGBD200
00197                                     VALUE 'DTSBU999'.             CHGBD200
00198                                                                   CHGBD200
00199      05  BD100-CHG-STATUS            PIC  X(02) VALUE SPACES.     CHGBD200
00200          88  BD100-FILE-OK-88       VALUE ZERO.                   CHGBD200
00201          88  BD100-FILE-EOF-88      VALUE '10'.                   CHGBD200
00202      05  BD200-CHG-STATUS            PIC  X(02) VALUE SPACES.     CHGBD200
00203          88  BD200-FILE-OK-88       VALUE ZERO.                   CHGBD200
00204          88  BD200-FILE-DUP-88      VALUE '22'.                   CHGBD200
00205      05  BD200-TOTAL-STATUS          PIC  X(02) VALUE SPACES.     CHGBD200
00206          88  BD200-TOTAL-FILE-OK-88 VALUE ZERO.                   CHGBD200
00207 *        88  BD200-TOTAL-FILE-EOF-88 VALUE '10'.                  CHGBD200
00208                                                                   CHGBD200
00209      05  WRK-ERROR-IND               PIC  X(01).                  CHGBD200
00210          88  WRK-ERROR-YES-88       VALUE 'Y'.                    CHGBD200
00211          88  WRK-ERROR-NO-88        VALUE 'N'.                    CHGBD200
00212                                                                   CHGBD200
00213      05  WRK-CHG-REC-IND             PIC  X(01).                  CHGBD200
00214          88  WRK-CHG-REC-OK-88      VALUE 'Y'.                    CHGBD200
00215          88  WRK-CHG-REC-INVALID-88 VALUE 'N'.                    CHGBD200
00216                                                                   CHGBD200
00217      05  WRK-CHG-NEXT-REC            PIC  X(01).                  CHGBD200
00218          88  WRK-CHG-NEXT-OK-88     VALUE 'Y'.                    CHGBD200
00219                                                                   CHGBD200
00220 *********************************************************         CHGBD200
00221 *  THE FOLLOWING INDICATOR IS USED DURING RERUNS.                 CHGBD200
00222 *  WHEN IT IS SET TO YES, THE PROGRAM WILL WRITE                  CHGBD200
00223 *  CHARGE RECORDS TO PASS TO CHGBD207, BUT WILL NOT               CHGBD200
00224 *  WRITE EMPLOYER CHARGE RECORDS.                                 CHGBD200
00225 *********************************************************         CHGBD200
00226      05  WRK-ACCEPT-DUPS-IND   PIC  X(01).                        CHGBD200
00227          88  WRK-ACCEPT-DUPS-YES-88  VALUE 'Y'.                   CHGBD200
00228          88  WRK-ACCEPT-DUPS-NO-88   VALUE 'N'.                   CHGBD200
00229                                                                   CHGBD200
00230      05  WRK-REPORT-TYPE             PIC  X(01).                  CHGBD200
00231          88  WRK-RPT-TYPE-RATED-88    VALUE '1'.                  CHGBD200
00232          88  WRK-RPT-TYPE-SELF-INS-88 VALUE '2'.                  CHGBD200
00233          88  WRK-RPT-TYPE-CWC-88      VALUE '3'.                  CHGBD200
00234          88  WRK-RPT-TYPE-FED-88      VALUE '4'.                  CHGBD200
00235          88  WRK-RPT-TYPE-UNKNOWN-88  VALUE '5'.                  CHGBD200
00236          88  WRK-RPT-TYPE-NOT-LIAB-88 VALUE '6'.                  CHGBD200
00237          88  WRK-NO-RPT-88            VALUE '0'.                  CHGBD200
00238                                                                   CHGBD200
00239      05  WRK-EMP-TYPE                PIC  9(02).                  CHGBD200
00240          88  WRK-EMP-TYPE-CONTRIB-88   VALUE 00.                  CHGBD200
00241          88  WRK-EMP-TYPE-UCX-88       VALUE 01.                  CHGBD200
00242          88  WRK-EMP-TYPE-UCFE-88      VALUE 02.                  CHGBD200
00243          88  WRK-EMP-TYPE-FED-88       VALUE 01, 02.              CHGBD200
00244          88  WRK-EMP-TYPE-CWC-88       VALUE 04.                  CHGBD200
00245          88  WRK-EMP-TYPE-SELF-INS-88  VALUE 08.                  CHGBD200
00246          88  WRK-EMP-TYPE-DC-GOV-88    VALUE 10.                  CHGBD200
00247          88  WRK-EMP-TYPE-NOT-LIAB-88  VALUE 13.                  CHGBD200
00248          88  WRK-EMP-TYPE-TEUC-88      VALUE 16.                  CHGBD200
00249          88  WRK-EMP-TYPE-DOM-VIOLENC-88  VALUE 17.               CHGBD200
00250          88  WRK-EMP-TYPE-POOL-88                                 CHGBD200
00251                  VALUE 03, 05, 06, 07, 09, 11                     CHGBD200
00252                        12, 15, 16, 17, 18, 19, 20.                   CL*19
00253                                                                   CHGBD200
00254          88  WRK-EMP-TYPE-VALID-88                                CHGBD200
00255                  VALUE 00, 01, 02, 03, 04, 05, 06, 07,            CHGBD200
00256                        07, 08, 09, 10, 11, 12,                    CHGBD200
00257                        13, 15, 16, 17, 18, 19, 20,                CHGBD200
00258                        21, 22, 23, 24, 25, 26, 27, 28                CL**2
00259                        29, 31, 32, 33, 34, 35, 36, 37.               CL*23
00260                                                                   CHGBD200
00261      05  WRK-BD100-READ              PIC  9(07) COMP-3.           CHGBD200
00262      05  WRK-SRVR-WRITE-CNT          PIC  9(07) COMP-3.           CHGBD200
00263      05  WRK-BD200-CHG-WRITTEN       PIC  9(07) COMP-3.           CHGBD200
00264      05  WRK-BD200-TOTAL-WRITTEN     PIC  9(07) COMP-3.           CHGBD200
00265      05  WRK-BD200-CHG-DUP           PIC  9(07) COMP-3.           CHGBD200
00266      05  WRK-BD200-CHG-DEL           PIC  9(07) VALUE 0.             CL*30
00267      05  TOT-BEN-ADJ-AMT           PIC S9(09)V99 VALUE +0.        CHGBD200
00268      05  TOT-BEN-ADJ-AMT-DISP      PIC  ZZZ,ZZZ,ZZ9.99.           CHGBD200
00269      05  WRK-TOT-CHG                 PIC S9(11)V99 COMP-3         CHGBD200
00270                                           VALUE +0.               CHGBD200
00271      05  WRK-CHRG-READ-CNT           PIC  9(07) COMP-3 VALUE 0.   CHGBD200
00272      05  WRK-CHRG-WRITE-CNT          PIC  9(07) COMP-3 VALUE 0.   CHGBD200
00273      05  WRK-SSN                     PIC  9(10).                  CHGBD200
00274      05  WRK-SSN-X REDEFINES WRK-SSN.                             CHGBD200
00275          10  WRK-OUT-SSN             PIC  9(09).                  CHGBD200
00276          10  WRK-OUT-SSN-ZERO        PIC  9(01).                  CHGBD200
00277      05  WRK-CURR-AMT                PIC S9(11)V99 COMP-3.        CHGBD200
00278                                                                   CHGBD200
00279                                                                   CHGBD200
00280 ***************************************************************   CHGBD200
00281 *  WORKING STORAGE AND ACCUMULATOR FIELDS FOR CURRENT SSN/BYE.    CHGBD200
00282 *  CHARGES FOR INDIVIDUAL EMPLOYERS ARE IN THE TABLE BELOW.       CHGBD200
00283 ***************************************************************   CHGBD200
00284      05  WRK-CURR-SSN                PIC S9(10) COMP-3.           CHGBD200
00285      05  WRK-CLMNT-NAME              PIC  X(32).                  CHGBD200
00286      05  WRK-CURR-BYE                PIC S9(09) COMP-3.           CHGBD200
00287      05  WRK-CURR-CHG-DATE           PIC S9(09) COMP-3.              CL*28
00288      05  WRK-CURR-EMP                PIC S9(07) COMP-3.           CHGBD200
00289                                                                   CHGBD200
00290      05  WRK-PROGRAM-TOTALS OCCURS 27 TIMES.                         CL*24
00291          10  WRK-TOT-BEN             PIC S9(07)V99 COMP-3.        CHGBD200
00292          10  WRK-TOT-ADJ             PIC S9(07)V99 COMP-3.        CHGBD200
00293                                                                   CHGBD200
00294 ***************************************************************   CHGBD200
00295 *  THE TABLE BELOW RECORDS CHARGE DATA FOR EACH EMPLOYER WITHIN   CHGBD200
00296 *  A GIVEN SSN/BYE.  WITHIN EACH TABLE ENTRY, A SEPARATE TABLE    CHGBD200
00297 *  DISTINGUISHES CHARGE AMOUNTS BY BENEFIT PROGRAM.               CHGBD200
00298 *  PROG-SUB-MAX INDICATES THE MAXIMUM NUMBER OF PROGRAMS THE      CHGBD200
00299 *  CHARGE AMOUNT TABLE MAY CONTAIN.                               CHGBD200
00300 *  EMP-ENTRY-MAX INDICATES THE MAXIMUM NUMBER OF EMPLOYERS THE    CHGBD200
00301 *  EMPLOYER TABLE MAY CONTAIN.                                    CHGBD200
00302 ***************************************************************   CHGBD200
00303      05  EMP-SUB                     PIC S9(04)    COMP.          CHGBD200
00304      05  PROG-SUB                    PIC S9(04)    COMP.          CHGBD200
00305          88  PROG-SUB-UI          VALUE +1.                       CHGBD200
00306          88  PROG-SUB-EB          VALUE +2.                       CHGBD200
00307          88  PROG-SUB-TEUC        VALUE +3.                       CHGBD200
00308          88  PROG-SUB-TEUCA       VALUE +4.                       CHGBD200
00309          88  PROG-SUB-FAC         VALUE +5.                       CHGBD200
00310          88  PROG-SUB-FSB         VALUE +6.                       CHGBD200
00311          88  PROG-SUB-FSC         VALUE +7.                       CHGBD200
00312          88  PROG-SUB-DUA         VALUE +8.                       CHGBD200
00313          88  PROG-SUB-TR2         VALUE +9.                       CHGBD200
00314          88  PROG-SUB-TRA         VALUE +10.                      CHGBD200
00315          88  PROG-SUB-STEPLDR     VALUE +11.                      CHGBD200
00316          88  PROG-SUB-AB          VALUE +12.                      CHGBD200
00317          88  PROG-SUB-TRAINING    VALUE +13.                      CHGBD200
00318          88  PROG-SUB-DEPENDENTS  VALUE +14.                      CHGBD200
00319          88  PROG-SUB-EUC08-2PLUS VALUE +15.                      CHGBD200
00320          88  PROG-SUB-EUC08TR3    VALUE +16.                      CHGBD200
00321          88  PROG-SUB-EUC08TR4    VALUE +17.                      CHGBD200
00322          88  PROG-SUB-SPEC-PAY    VALUE +18.                      CHGBD200
00323          88  PROG-SUB-UCPIA       VALUE +19.                      CHGBD200
00324          88  PROG-SUB-GPA         VALUE +20.                         CL**2
00325          88  PROG-SUB-PUA         VALUE +21.                         CL**2
00326          88  PROG-SUB-FPUC        VALUE +22.                         CL**2
00327          88  PROG-SUB-FRUR        VALUE +23.                         CL**2
00328          88  PROG-SUB-PEUC        VALUE +24.                         CL*11
00329          88  PROG-SUB-REUR        VALUE +25.                         CL*18
00330          88  PROG-SUB-LWA         VALUE +26.                         CL*21
00331          88  PROG-SUB-PUA-STIM    VALUE +27.                         CL*24
00332          88  PROG-SUB-VALID       VALUE +1 THRU +27.                 CL*24
00333      05  PROG-SUB-MAX                PIC S9(04)    COMP           CHGBD200
00334                                   VALUE +27.                         CL*24
00335      05  EMP-ENTRY-MAX               PIC S9(04)    COMP           CHGBD200
00336                                   VALUE +100.                     CHGBD200
00337      05  EMP-CNT                     PIC S9(04)    COMP.          CHGBD200
00338                                                                   CHGBD200
00339      05  EMP-TABLE.                                               CHGBD200
00340          10  EMP-TABLE-ENTRY OCCURS 100 TIMES.                    CHGBD200
00341              15  TAB-EMP-ACCT            PIC  9(06).              CHGBD200
00342                  88  TAB-POOL-ACCT-YES-88                         CHGBD200
00343                                      VALUE 028411,                CHGBD200
00344                                            999000 THRU 999992.    CHGBD200
00345              15  TAB-EMP-TYPE            PIC  9(02).              CHGBD200
00346 ***************************************************************   CHGBD200
00347 *  THE TABLE BELOW RECORDS AMOUNTS CHARGED FOR EACH BENEFIT       CHGBD200
00348 *  PROGRAM.  THE FIRST OCCURRENCE IS FOR REGULAR UI AND THE       CHGBD200
00349 *  SECOND FOR EB.  ADD ADDITIONAL OCCURRENCES AS REQUIRED.        CHGBD200
00350 ***************************************************************   CHGBD200
00351              15  TAB-EMP-CHARGE-AMTS                              CHGBD200
00352                                 OCCURS 27 TIMES.                     CL*26
00353                 20  TAB-BEN-CHG          PIC S9(07)V99 COMP-3.    CHGBD200
00354                 20  TAB-ADJ-CHG          PIC S9(07)V99 COMP-3.    CHGBD200
00355                 20  TAB-OP-RECOVER       PIC S9(07)V99 COMP-3.    CHGBD200
00356                                                                   CHGBD200
00357 ****                                                              CHGBD200
00358  01  BD200-CHG-READ          PIC X(64).                              CL*35
00359  01  WRK-TEST-TOT            PIC S9(07)V99 COMP-3 VALUE ZERO.     CHGBD200
00360  01  WRK-AMT-DISP            PIC S9(07)V99 COMP-3 VALUE ZERO.     CHGBD200
00361  01  WRK-TEST-AMT-OUT        PIC S9(07)V99 COMP-3 VALUE ZERO.     CHGBD200
00362  01  WRK-TEST-TOT-OUT        PIC S9(07)V99 COMP-3 VALUE ZERO.     CHGBD200
00363  01  WRK-AMT-DISP-OUT        PIC S9(07)V99.                       CHGBD200
00364 ****                                                              CHGBD200
00365  01  WK-DISP-AREA1.                                               CHGBD200
00366      05 FILLER      PIC X(12) VALUE '  CHG-DATE: '.               CHGBD200
00367      05 WK-DISP-CGD PIC 9(09).                                    CHGBD200
00368      05 FILLER      PIC X(12) VALUE '  CHG2-EMP: '.               CHGBD200
00369      05 WK-DISP-EMP PIC 9(07).                                    CHGBD200
00370      05 FILLER      PIC X(12) VALUE '  CHG2-SSN: '.               CHGBD200
00371      05 WK-DISP-SSN PIC 9(10).                                    CHGBD200
00372      05 FILLER      PIC X(12) VALUE '  CHG2-BYE: '.               CHGBD200
00373      05 WK-DISP-BYE PIC 9(09).                                    CHGBD200
00374      05 FILLER      PIC X(11) VALUE '  EMP-PGM: '.                CHGBD200
00375      05 WK-DISP-PGM PIC X(01).                                    CHGBD200
00376 ****                                                              CHGBD200
00377  01  WRK-OUT-REC.                                                 CHGBD200
00378      05  OUT-CHARGE-DATE             PIC  X(10).                  CHGBD200
00379      05  FILLER                      PIC  X(01) VALUE ';'.        CHGBD200
00380      05  OUT-EMP-NO                  PIC  9(06).                  CHGBD200
00381      05  FILLER                      PIC  X(01) VALUE ';'.        CHGBD200
00382      05  OUT-SSN                     PIC  9(10).                     CL*38
00383      05  FILLER                      PIC  X(01) VALUE ';'.        CHGBD200
00384      05  OUT-BYE                     PIC  X(10).                  CHGBD200
00385      05  FILLER                      PIC  X(01) VALUE ';'.        CHGBD200
00386      05  OUT-PROGRAM                 PIC  X(01).                  CHGBD200
00387      05  FILLER                      PIC  X(01) VALUE ';'.        CHGBD200
00388      05  OUT-EMP-TYPE                PIC  9(02).                  CHGBD200
00389      05  FILLER                      PIC  X(01) VALUE ';'.        CHGBD200
00390      05  OUT-CURR-AMT                PIC  ---------9.99.             CL*45
00391      05  FILLER                      PIC  X(01) VALUE ';'.        CHGBD200
00392      05  OUT-RECOVERIES              PIC  ---------9.99.             CL*45
00393      05  OUT-DEL                     PIC  X(01) VALUE SPACES.        CL*44
00394       EJECT                                                       CHGBD200
00395  01  WRK-BD200-CHG-REC.                                           CHGBD200
00396  ++INCLUDE CHGIM002                                               CHGBD200
00397                                                                   CHGBD200
00398  01  L001-LINK-AREA.                                              CHGBD200
00399  ++INCLUDE DTSIL001                                               CHGBD200
00400                                                                   CHGBD200
00401  01  L004-LINK-AREA.                                              CHGBD200
00402  ++INCLUDE DTSIL004                                               CHGBD200
00403                                                                   CHGBD200
00404  01  L100-LINK-AREA.                                              CHGBD200
00405  ++INCLUDE CHGIL100                                               CHGBD200
00406                                                                   CHGBD200
00407  01  L910-LINK-AREA.                                              CHGBD200
00408  ++INCLUDE DTSIL910                                               CHGBD200
00409                                                                   CHGBD200
00410  01  MSKL-REC.                                                    CHGBD200
00411  ++INCLUDE DTSIMSKL                                               CHGBD200
00412                                                                   CHGBD200
00413  01  MPRF-REC.                                                    CHGBD200
00414  ++INCLUDE DTSIMPRF                                               CHGBD200
00415                                                                   CHGBD200
00416  01  L921-LINK-AREA.                                              CHGBD200
00417  ++INCLUDE DTSIL921                                               CHGBD200
00418                                                                   CHGBD200
00419  01  ISKL-REC.                                                    CHGBD200
00420  ++INCLUDE DTSIISKL                                               CHGBD200
00421                                                                   CHGBD200
00422  LINKAGE SECTION.                                                 CHGBD200
00423                                                                   CHGBD200
00424  01  PARM-AREA.                                                   CHGBD200
00425      05  PARM-LENGTH                PIC S9(04)  COMP.             CHGBD200
00426      05  PARM-DATA.                                               CHGBD200
00427          10  PARM-ACCEPT-DUPS-IND   PIC  X(01).                   CHGBD200
00428              88  PARM-ACCEPT-DUPS-YES-88  VALUE 'Y'.              CHGBD200
00429              88  PARM-ACCEPT-DUPS-NO-88   VALUE 'N'.              CHGBD200
00430                                                                   CHGBD200
00431  PROCEDURE DIVISION USING PARM-AREA.                              CHGBD200
00432      SKIP2                                                        CHGBD200
00433  CHGBD200-MAIN.                                                   CHGBD200
00434      PERFORM I0000-INITIATE THRU I0000-EXIT.                      CHGBD200
00435      IF WRK-ERROR-YES-88                                          CHGBD200
00436         GO TO CHGBD200-EXIT.                                      CHGBD200
00437                                                                   CHGBD200
00438      PERFORM P0000-PROCESS THRU P0000-EXIT.                       CHGBD200
00439                                                                   CHGBD200
00440      PERFORM T0000-TERMINATE THRU T0000-EXIT.                     CHGBD200
00441                                                                   CHGBD200
00442  CHGBD200-EXIT.                                                   CHGBD200
00443      STOP RUN.                                                    CHGBD200
00444      EJECT                                                        CHGBD200
00445  I0000-INITIATE.                                                  CHGBD200
00446                                                                   CHGBD200
00447      PERFORM I1000-INIT-WRK-DATA THRU I1000-EXIT.                 CHGBD200
00448                                                                   CHGBD200
00449      PERFORM I2000-OPEN-FILES THRU I2000-EXIT.                    CHGBD200
00450                                                                   CHGBD200
00451      PERFORM I3000-PARM       THRU I3000-EXIT.                    CHGBD200
00452                                                                   CHGBD200
00453  I0000-EXIT.                                                      CHGBD200
00454      EXIT.                                                        CHGBD200
00455                                                                   CHGBD200
00456  I1000-INIT-WRK-DATA.                                             CHGBD200
00457      MOVE ZERO TO  WRK-BD100-READ,                                CHGBD200
00458                    WRK-BD200-CHG-WRITTEN,                         CHGBD200
00459                    WRK-BD200-TOTAL-WRITTEN,                       CHGBD200
00460                    WRK-BD200-CHG-DUP,                             CHGBD200
00461                    WRK-AMT-DISP,                                  CHGBD200
00462                    EMP-CNT.                                       CHGBD200
00463                                                                   CHGBD200
00464      SET WRK-ERROR-NO-88 TO TRUE.                                 CHGBD200
00465                                                                   CHGBD200
00466  I1000-EXIT.                                                      CHGBD200
00467      EXIT.                                                        CHGBD200
00468                                                                   CHGBD200
00469  I2000-OPEN-FILES.                                                CHGBD200
00470      DISPLAY 'SORT FILE OPEN : ' BD100-CHG-STATUS                    CL**9
00471      OPEN INPUT BD100-CHG-FILE.                                   CHGBD200
00472      IF NOT BD100-FILE-OK-88                                      CHGBD200
00473         DISPLAY 'SORT FILE OPEN ERROR: ' BD100-CHG-STATUS         CHGBD200
00474         SET WRK-ERROR-YES-88 TO TRUE                              CHGBD200
00475         GO TO I2000-EXIT.                                         CHGBD200
00476                                                                   CHGBD200
00477      DISPLAY 'BD200 VSAM OPEN : ' BD200-CHG-STATUS                   CL**9
00478      OPEN I-O    BD200-CHG-FILE.                                  CHGBD200
00479      IF NOT BD200-FILE-OK-88                                      CHGBD200
00480         DISPLAY 'BD200 VSAM OPEN ERROR: ' BD200-CHG-STATUS           CL**7
00481         SET WRK-ERROR-YES-88 TO TRUE                              CHGBD200
00482         GO TO I2000-EXIT.                                         CHGBD200
00483                                                                   CHGBD200
00484      DISPLAY 'TOTAL CHG FILE OPEN : '                                CL**9
00485      OPEN OUTPUT BD200-TOTAL-CHG.                                 CHGBD200
00486      IF NOT BD200-TOTAL-FILE-OK-88                                CHGBD200
00487         DISPLAY 'TOTAL CHG FILE OPEN ERROR: '                     CHGBD200
00488                  BD200-TOTAL-STATUS                               CHGBD200
00489         SET WRK-ERROR-YES-88 TO TRUE                              CHGBD200
00490         GO TO I2000-EXIT.                                         CHGBD200
00491                                                                   CHGBD200
00492                                                                   CHGBD200
00493      DISPLAY 'SRVR CHG FILE OPEN : '                                 CL**9
00494      OPEN OUTPUT BD200-SRVR-CHG.                                  CHGBD200
00495      IF NOT BD200-TOTAL-FILE-OK-88                                CHGBD200
00496         DISPLAY 'SRVR CHG FILE OPEN ERROR: '                      CHGBD200
00497                  BD200-TOTAL-STATUS                               CHGBD200
00498         SET WRK-ERROR-YES-88 TO TRUE                              CHGBD200
00499         GO TO I2000-EXIT.                                         CHGBD200
00500                                                                   CHGBD200
00501      PERFORM S910-OPEN-READ THRU S910-EXIT.                       CHGBD200
00502      PERFORM S921-OPEN-READ THRU S921-EXIT.                       CHGBD200
00503                                                                   CHGBD200
00504  I2000-EXIT.                                                      CHGBD200
00505      EXIT.                                                        CHGBD200
00506                                                                   CHGBD200
00507  I3000-PARM.                                                      CHGBD200
00508      SET WRK-ACCEPT-DUPS-NO-88  TO TRUE.                          CHGBD200
00509                                                                   CHGBD200
00510      IF PARM-LENGTH = +1                                          CHGBD200
00511          NEXT SENTENCE                                            CHGBD200
00512      ELSE                                                         CHGBD200
00513          DISPLAY 'PARM IGNORED: PARM-LENGTH NOT EQUAL TO 1'       CHGBD200
00514          GO TO I3000-EXIT.                                        CHGBD200
00515                                                                   CHGBD200
00516      IF PARM-ACCEPT-DUPS-YES-88                                   CHGBD200
00517         SET WRK-ACCEPT-DUPS-YES-88  TO TRUE.                      CHGBD200
00518                                                                   CHGBD200
00519  I3000-EXIT.                                                      CHGBD200
00520      EXIT.                                                        CHGBD200
00521                                                                   CHGBD200
00522  P0000-PROCESS.                                                   CHGBD200
00523      READ BD100-CHG-FILE.                                         CHGBD200
00524      IF NOT BD100-FILE-OK-88                                      CHGBD200
00525         DISPLAY 'SORT FILE EMPTY: ' BD100-CHG-STATUS              CHGBD200
00526         SET WRK-ERROR-YES-88 TO TRUE                              CHGBD200
00527         GO TO P0000-EXIT                                          CHGBD200
00528      ELSE                                                         CHGBD200
00529         ADD 1 TO WRK-BD100-READ.                                  CHGBD200
00530                                                                   CHGBD200
00531 *    DISPLAY 'P2000 INIT EMP: '                                      CL*16
00532      PERFORM P2000-INIT-EMP-DATA THRU P2000-EXIT.                 CHGBD200
00533                                                                   CHGBD200
00534 *    DISPLAY 'P1000 READ EMP: '                                      CL*16
00535      PERFORM P1000-READ-CHARGES THRU P1000-EXIT                   CHGBD200
00536        UNTIL BD100-FILE-EOF-88                                    CHGBD200
00537           OR WRK-ERROR-YES-88.                                    CHGBD200
00538                                                                   CHGBD200
00539  P0000-EXIT.                                                      CHGBD200
00540      EXIT.                                                        CHGBD200
00541                                                                   CHGBD200
00542  P1000-READ-CHARGES.                                              CHGBD200
00543      DISPLAY 'CHG ' CHG1-EMP-NO ' ' CHG1-SSN ' ' CHG1-BYE.           CL*47
00544      DISPLAY 'WRK ' WRK-CURR-EMP ' ' WRK-CURR-SSN ' ' WRK-CURR-BYE   CL*48
00545      IF CHG1-SSN = WRK-CURR-SSN                                      CL*46
00546      AND CHG1-BYE = WRK-CURR-BYE                                     CL*46
00547         PERFORM P1200-ACCUM-CHARGES  THRU P1200-EXIT                 CL*46
00548      ELSE                                                            CL*46
00549         PERFORM P1400-WRITE-CHG-RECS THRU P1400-EXIT              CHGBD200
00550            VARYING EMP-SUB FROM +1 BY +1                             CL*46
00551            UNTIL EMP-SUB > EMP-CNT                                   CL*46
00552         PERFORM P2000-INIT-EMP-DATA THRU P2000-EXIT                  CL*46
00553         PERFORM P1200-ACCUM-CHARGES  THRU P1200-EXIT.                CL*46
00554                                                                   CHGBD200
00555      PERFORM P1010-READ-NEXT-REC THRU P1010-EXIT.                 CHGBD200
00556                                                                   CHGBD200
00557  P1000-EXIT.                                                      CHGBD200
00558      EXIT.                                                        CHGBD200
00559                                                                   CHGBD200
00560  P1010-READ-NEXT-REC.                                             CHGBD200
00561 *    DISPLAY 'P1010-READ-NEXT-REC..'.                                CL**8
00562      READ BD100-CHG-FILE.                                         CHGBD200
00563                                                                   CHGBD200
00564      IF BD100-FILE-EOF-88                                         CHGBD200
00565         PERFORM P1400-WRITE-CHG-RECS THRU P1400-EXIT              CHGBD200
00566         PERFORM S200-WRITE-CHG2 THRU S200-EXIT                       CL*41
00567            VARYING EMP-SUB FROM +1 BY +1                             CL*46
00568              UNTIL EMP-SUB > EMP-CNT                                 CL*46
00569      ELSE                                                         CHGBD200
00570         IF BD100-FILE-OK-88                                       CHGBD200
00571            ADD 1 TO WRK-BD100-READ                                CHGBD200
00572         ELSE                                                      CHGBD200
00573           DISPLAY 'SORT FILE READ ERROR: ' BD100-CHG-STATUS       CHGBD200
00574           SET WRK-ERROR-YES-88 TO TRUE                            CHGBD200
00575         END-IF                                                    CHGBD200
00576      END-IF.                                                      CHGBD200
00577                                                                   CHGBD200
00578  P1010-EXIT.                                                      CHGBD200
00579      EXIT.                                                        CHGBD200
00580                                                                   CHGBD200
00581  P1200-ACCUM-CHARGES.                                             CHGBD200
00582 *    DISPLAY 'P1200-ACCUM-CHARGES...'.                               CL**8
00583      IF CHG1-EMP-NO NOT = WRK-CURR-EMP                            CHGBD200
00584         PERFORM P1210-NEW-EMP THRU P1210-EXIT.                    CHGBD200
00585                                                                   CHGBD200
00586      PERFORM P1220-UPDATE-EMP-TABLE THRU P1220-EXIT.              CHGBD200
00587                                                                   CHGBD200
00588  P1200-EXIT.                                                      CHGBD200
00589      EXIT.                                                        CHGBD200
00590                                                                   CHGBD200
00591 ****************************************************************  CHGBD200
00592 *  CHARGE RECORDS ARRIVE IN EMPLOYER NUMBER ORDER (WITHIN         CHGBD200
00593 *  SSN/BYE).  ALL CHARGE RECORDS FOR A GIVEN EMPLOYER WILL BE     CHGBD200
00594 *  GROUPED TOGETHER BY THE SORT.                                  CHGBD200
00595 ****************************************************************  CHGBD200
00596  P1210-NEW-EMP.                                                   CHGBD200
00597 *    DISPLAY 'P1210-NEW-EMP...'.                                     CL**8
00598      ADD +1 TO EMP-SUB                                            CHGBD200
00599                EMP-CNT.                                           CHGBD200
00600      IF EMP-SUB > EMP-ENTRY-MAX                                   CHGBD200
00601         MOVE    'EMPLOYER TABLE LENGTH EXCEEDED'                  CHGBD200
00602                               TO ABEND-MSG                        CHGBD200
00603         PERFORM S999-ABEND THRU S999-EXIT                         CHGBD200
00604         GO TO P1210-EXIT                                          CHGBD200
00605      ELSE                                                         CHGBD200
00606         MOVE CHG1-EMP-NO      TO WRK-CURR-EMP                     CHGBD200
00607                                  TAB-EMP-ACCT (EMP-SUB)           CHGBD200
00608         MOVE CHG1-CHARGE-EMP-TYPE                                 CHGBD200
00609                               TO TAB-EMP-TYPE (EMP-SUB).          CHGBD200
00610  P1210-EXIT.                                                      CHGBD200
00611      EXIT.                                                        CHGBD200
00612                                                                   CHGBD200
00613 ****************************************************************  CHGBD200
00614 *  TOTAL REGULAR CHARGES AND ADJUSTMENTS SEPARATELY.              CHGBD200
00615 *  CHG1-CHARGE-PAY-OP-RECOUP IS SET FOR OVERPAYMENT RECOVERIES    CHGBD200
00616 *  DIRECTED TO A CWC ACCOUNT AND ARE TOTALLED SEPARATELY.         CHGBD200
00617 ****************************************************************  CHGBD200
00618  P1220-UPDATE-EMP-TABLE.                                          CHGBD200
00619 *    DISPLAY 'P1220-UPDATE-EMP-TABLE...'.                            CL**8
00620      PERFORM P1229-EDIT-PROG-CODE THRU P1229-EXIT.                CHGBD200
00621                                                                   CHGBD200
00622      IF CHG1-CHARGE-BEN                                           CHGBD200
00623         PERFORM P1221-BEN-CHARGE THRU P1221-EXIT                  CHGBD200
00624      ELSE                                                         CHGBD200
00625      IF CHG1-CHARGE-ALL-ADJ                                       CHGBD200
00626         PERFORM P1222-ADJ-CHARGE THRU P1222-EXIT.                 CHGBD200
00627                                                                   CHGBD200
00628  P1220-EXIT.                                                      CHGBD200
00629      EXIT.                                                        CHGBD200
00630                                                                   CHGBD200
00631  P1221-BEN-CHARGE.                                                CHGBD200
00632      ADD CHG1-CHARGE-CURR-AMT TO                                  CHGBD200
00633                           TAB-BEN-CHG (EMP-SUB, PROG-SUB),        CHGBD200
00634                           WRK-TOT-BEN (PROG-SUB).                 CHGBD200
00635                                                                   CHGBD200
00636  P1221-EXIT.                                                      CHGBD200
00637      EXIT.                                                        CHGBD200
00638                                                                   CHGBD200
00639  P1222-ADJ-CHARGE.                                                CHGBD200
00640      ADD CHG1-CHARGE-CURR-AMT TO                                  CHGBD200
00641                           TAB-ADJ-CHG (EMP-SUB, PROG-SUB),        CHGBD200
00642                           WRK-TOT-ADJ (PROG-SUB).                 CHGBD200
00643                                                                   CHGBD200
00644 ***  IF CHG1-CHARGE-PAY-OP-RECOUP                                 CHGBD200
00645      IF CHG1-CHARGE-OP-RECOUP                                     CHGBD200
00646         ADD CHG1-CHARGE-CURR-AMT TO                               CHGBD200
00647                           TAB-OP-RECOVER (EMP-SUB, PROG-SUB).     CHGBD200
00648                                                                   CHGBD200
00649  P1222-EXIT.                                                      CHGBD200
00650      EXIT.                                                        CHGBD200
00651                                                                   CHGBD200
00652  P1229-EDIT-PROG-CODE.                                            CHGBD200
00653 *    DISPLAY 'P1229-EDIT-PROG-CODE...'.                              CL**8
00654 *    DISPLAY'PROG CODE: ' CHG1-CHARGE-PROGRAM ' ' CHG1-EMP-NO        CL*16
00655      EVALUATE CHG1-CHARGE-PROGRAM                                 CHGBD200
00656         WHEN '1'                                                  CHGBD200
00657           SET PROG-SUB-UI           TO TRUE                       CHGBD200
00658         WHEN '2'                                                  CHGBD200
00659           SET PROG-SUB-EB           TO TRUE                       CHGBD200
00660         WHEN '3'                                                  CHGBD200
00661           SET PROG-SUB-TEUC         TO TRUE                       CHGBD200
00662         WHEN '4'                                                  CHGBD200
00663           SET PROG-SUB-TEUCA        TO TRUE                       CHGBD200
00664         WHEN '5'                                                  CHGBD200
00665           SET PROG-SUB-FAC          TO TRUE                       CHGBD200
00666         WHEN '6'                                                  CHGBD200
00667           SET PROG-SUB-FSB          TO TRUE                       CHGBD200
00668         WHEN '7'                                                  CHGBD200
00669           SET PROG-SUB-FSC          TO TRUE                       CHGBD200
00670         WHEN '8'                                                  CHGBD200
00671           SET PROG-SUB-DUA          TO TRUE                       CHGBD200
00672         WHEN '9'                                                  CHGBD200
00673           SET PROG-SUB-TR2          TO TRUE                       CHGBD200
00674         WHEN '0'                                                  CHGBD200
00675           SET PROG-SUB-TRA          TO TRUE                       CHGBD200
00676         WHEN 'A'                                                  CHGBD200
00677           SET PROG-SUB-STEPLDR      TO TRUE                       CHGBD200
00678         WHEN 'B'                                                  CHGBD200
00679           SET PROG-SUB-AB           TO TRUE                       CHGBD200
00680         WHEN 'C'                                                     CL*19
00681           SET PROG-SUB-TRAINING     TO TRUE                       CHGBD200
00682         WHEN 'D'                                                  CHGBD200
00683           SET PROG-SUB-DEPENDENTS   TO TRUE                       CHGBD200
00684         WHEN 'E'                                                  CHGBD200
00685           SET  PROG-SUB-EUC08-2PLUS TO TRUE                       CHGBD200
00686         WHEN 'F'                                                  CHGBD200
00687           SET  PROG-SUB-EUC08TR3    TO TRUE                       CHGBD200
00688         WHEN 'G'                                                  CHGBD200
00689           SET  PROG-SUB-EUC08TR4    TO TRUE                       CHGBD200
00690         WHEN 'H'                                                  CHGBD200
00691           SET  PROG-SUB-SPEC-PAY    TO TRUE                       CHGBD200
00692         WHEN 'I'                                                  CHGBD200
00693           SET  PROG-SUB-UCPIA       TO TRUE                       CHGBD200
00694         WHEN 'J'                                                     CL**2
00695           SET  PROG-SUB-GPA         TO TRUE                          CL**2
00696         WHEN 'U'                                                     CL*13
00697           SET  PROG-SUB-PUA         TO TRUE                          CL**2
00698         WHEN 'L'                                                     CL**2
00699           SET  PROG-SUB-FPUC        TO TRUE                          CL**2
00700         WHEN 'M'                                                     CL**2
00701           SET  PROG-SUB-FRUR        TO TRUE                          CL**2
00702         WHEN 'N'                                                     CL*19
00703           SET  PROG-SUB-PEUC        TO TRUE                          CL*11
00704         WHEN 'Y'                                                     CL*18
00705           SET  PROG-SUB-REUR        TO TRUE                          CL*18
00706         WHEN 'X'                                                     CL*21
00707           SET  PROG-SUB-LWA         TO TRUE                          CL*21
00708         WHEN 'R'                                                     CL*25
00709           SET  PROG-SUB-PUA-STIM    TO TRUE                          CL*25
00710         WHEN OTHER                                                CHGBD200
00711          DISPLAY 'INVALID PROGRAM CODE '                          CHGBD200
00712             CHG1-CHARGE-PROGRAM ' ' CHG1-EMP-NO                   CHGBD200
00713             '  ' CHG1-SSN                                         CHGBD200
00714 *         SET  PROG-SUB-PUA         TO TRUE                          CL*46
00715           SET  PROG-SUB-EUC08TR4    TO TRUE                          CL*46
00716 *                                                                    CL*29
00717 *** ZL1 CHANGED TO PUA                                               CL*29
00718 *         SET  PROG-SUB-EUC08TR4    TO TRUE                          CL*29
00719 *         MOVE    'INVALID PROGRAM CODE'                          CHGBD200
00720 *                             TO ABEND-MSG-TEXT                   CHGBD200
00721 *         MOVE CHG1-CHARGE-PROGRAM                                CHGBD200
00722 *                             TO ABEND-MSG-PROG-CODE              CHGBD200
00723 *         PERFORM S999-ABEND THRU S999-EXIT                       CHGBD200
00724                                                                   CHGBD200
00725      END-EVALUATE.                                                CHGBD200
00726                                                                   CHGBD200
00727 ***  MOVE CHG1-CHARGE-PROGRAM TO PROG-SUB.                        CHGBD200
00728 *    IF NOT PROG-SUB-VALID                                        CHGBD200
00729 *       MOVE    'INVALID PROGRAM CODE'                            CHGBD200
00730 *                             TO ABEND-MSG-TEXT                   CHGBD200
00731 *       MOVE CHG1-CHARGE-PROGRAM                                  CHGBD200
00732 *                             TO ABEND-MSG-PROG-CODE              CHGBD200
00733 ***     PERFORM S999-ABEND THRU S999-EXIT.                        CHGBD200
00734                                                                   CHGBD200
00735  P1229-EXIT.                                                      CHGBD200
00736      EXIT.                                                        CHGBD200
00737                                                                   CHGBD200
00738  P1400-WRITE-CHG-RECS.                                            CHGBD200
00739 *    DISPLAY 'P1400-WRITE-CHG-RECS...'.                              CL**8
00740      MOVE CHG1-CHARGE-DATE       TO CHG2-CHARGE-DATE.                CL*41
00741      MOVE CHG1-EMP-NO            TO CHG2-EMP-NO.                     CL*41
00742      MOVE CHG1-SSN               TO CHG2-SSN.                        CL*41
00743      MOVE CHG1-BYE               TO CHG2-BYE.                        CL*41
00744      MOVE CHG1-CHARGE-PROGRAM    TO CHG2-PROGRAM.                    CL*41
00745      MOVE CHG1-CHARGE-EMP-TYPE   TO CHG2-EMP-TYPE.                   CL*41
00746      MOVE ZEROS                  TO CHG2-CURR-BEN-AMT                CL*41
00747                                     CHG2-CURR-ADJ-AMT                CL*41
00748                                     CHG2-TOT-BEN-AMT                 CL*41
00749                                     CHG2-TOT-ADJ-AMT                 CL*41
00750                                     CHG2-OP-RECOVER-AMT.             CL*41
00751                                                                      CL*41
00752      DISPLAY 'P1400 WRITE ' CHG2-CHARGE-DATE                         CL*43
00753                         ' ' CHG2-EMP-NO                              CL*43
00754                         ' ' CHG2-SSN                                 CL*43
00755                         ' ' CHG2-BYE                                 CL*43
00756                         ' ' CHG2-PROGRAM.                            CL*43
00757                                                                      CL*27
00758      PERFORM P1410-EMP-TYPE      THRU P1410-EXIT.                    CL*46
00759                                                                   CHGBD200
00760      MOVE WRK-EMP-TYPE           TO CHG2-EMP-TYPE.                   CL*46
00761                                                                   CHGBD200
00762      PERFORM P1420-CHARGE-AMOUNTS THRU P1420-EXIT                    CL*46
00763         VARYING PROG-SUB FROM +1 BY +1                               CL*46
00764         UNTIL PROG-SUB > PROG-SUB-MAX.                               CL*46
00765                                                                   CHGBD200
00766  P1400-EXIT.                                                      CHGBD200
00767      EXIT.                                                        CHGBD200
00768                                                                   CHGBD200
00769 ***************************************************************   CHGBD200
00770 *  IF THE EMPLOYER TYPE FROM THE ORIGINAL CHARGE RECORD IS        CHGBD200
00771 *  INVALID, READ THE EMPLOYER PROFILE RECORD TO FIND THE          CHGBD200
00772 *  CORRECT EMPLOYER TYPE.  THE EMPLOYER TYPE IS NEEDED TO         CHGBD200
00773 *  DETERMINE IN WHICH REPORT TO INCLUDE THE EMPLOYER'S CHARGES.   CHGBD200
00774 ***************************************************************   CHGBD200
00775  P1410-EMP-TYPE.                                                  CHGBD200
00776 *    DISPLAY 'P1410-EMP-TYPE.. '.                                    CL**8
00777      MOVE CHG2-EMP-NO                TO L100-EMP-NO.              CHGBD200
00778      PERFORM S100-CALL-CHGBU100      THRU S100-EXIT.              CHGBD200
00779      IF L100-OK-88                                                CHGBD200
00780         MOVE L100-EMP-TYPE           TO WRK-EMP-TYPE              CHGBD200
00781      ELSE                                                         CHGBD200
00782         MOVE TAB-EMP-TYPE (EMP-SUB)  TO WRK-EMP-TYPE.             CHGBD200
00783                                                                   CHGBD200
00784  P1410-EXIT.                                                      CHGBD200
00785      EXIT.                                                        CHGBD200
00786                                                                   CHGBD200
00787  P1420-CHARGE-AMOUNTS.                                            CHGBD200
00788 *     DISPLAY 'P1420-CHARGE-AMOUNTS...'.                             CL**8
00789 *     DISPLAY 'PROG SUB: ' PROG-SUB                                  CL*16
00790      EVALUATE TRUE                                                CHGBD200
00791         WHEN PROG-SUB-UI                                          CHGBD200
00792           SET CHG2-PROG-UI          TO TRUE                       CHGBD200
00793         WHEN PROG-SUB-EB                                          CHGBD200
00794           SET CHG2-PROG-EB          TO TRUE                       CHGBD200
00795         WHEN PROG-SUB-TEUC                                        CHGBD200
00796           SET CHG2-PROG-TEUC        TO TRUE                       CHGBD200
00797         WHEN PROG-SUB-TEUCA                                       CHGBD200
00798           SET CHG2-PROG-TEUCA       TO TRUE                       CHGBD200
00799         WHEN PROG-SUB-FAC                                         CHGBD200
00800           SET CHG2-PROG-FAC         TO TRUE                       CHGBD200
00801         WHEN PROG-SUB-FSB                                         CHGBD200
00802           SET CHG2-PROG-FSB         TO TRUE                       CHGBD200
00803         WHEN PROG-SUB-FSC                                         CHGBD200
00804           SET CHG2-PROG-FSC         TO TRUE                       CHGBD200
00805         WHEN PROG-SUB-DUA                                         CHGBD200
00806           SET CHG2-PROG-DUA         TO TRUE                       CHGBD200
00807         WHEN PROG-SUB-TR2                                         CHGBD200
00808           SET CHG2-PROG-TR2         TO TRUE                       CHGBD200
00809         WHEN PROG-SUB-TRA                                         CHGBD200
00810           SET CHG2-PROG-TRA         TO TRUE                       CHGBD200
00811         WHEN PROG-SUB-STEPLDR                                     CHGBD200
00812           SET CHG2-PROG-STEPLDR     TO TRUE                       CHGBD200
00813         WHEN PROG-SUB-AB                                          CHGBD200
00814           SET CHG2-PROG-AB          TO TRUE                       CHGBD200
00815         WHEN PROG-SUB-TRAINING                                    CHGBD200
00816           SET CHG2-PROG-TRAINING    TO TRUE                       CHGBD200
00817         WHEN PROG-SUB-DEPENDENTS                                  CHGBD200
00818           SET CHG2-PROG-DEPENDENTS  TO TRUE                       CHGBD200
00819         WHEN PROG-SUB-EUC08-2PLUS                                 CHGBD200
00820           SET CHG2-PROG-EUC08-2PLUS TO TRUE                       CHGBD200
00821         WHEN PROG-SUB-EUC08TR3                                    CHGBD200
00822           SET CHG2-PROG-EUC08TR3    TO TRUE                       CHGBD200
00823         WHEN PROG-SUB-EUC08TR4                                    CHGBD200
00824           SET CHG2-PROG-EUC08TR4    TO TRUE                       CHGBD200
00825        WHEN PROG-SUB-SPEC-PAY                                     CHGBD200
00826           SET CHG2-PROG-SPECIAL-PAY TO TRUE                       CHGBD200
00827        WHEN PROG-SUB-UCPIA                                        CHGBD200
00828           SET CHG2-PROG-UCPIA       TO TRUE                       CHGBD200
00829        WHEN PROG-SUB-GPA                                             CL**2
00830           SET CHG2-PROG-GPA         TO TRUE                          CL**2
00831        WHEN PROG-SUB-PUA                                             CL**2
00832           SET CHG2-PROG-PUA         TO TRUE                          CL**2
00833        WHEN PROG-SUB-FPUC                                            CL**2
00834           SET CHG2-PROG-FRUR        TO TRUE                          CL**2
00835        WHEN PROG-SUB-PEUC                                            CL*11
00836           SET CHG2-PROG-PEUC        TO TRUE                          CL*11
00837        WHEN PROG-SUB-REUR                                            CL*18
00838           SET CHG2-PROG-REUR        TO TRUE                          CL*18
00839        WHEN PROG-SUB-LWA                                             CL*21
00840           SET CHG2-PROG-LWA         TO TRUE                          CL*21
00841        WHEN PROG-SUB-PUA-STIM                                        CL*25
00842           SET CHG2-PROG-PUA-STIM    TO TRUE                          CL*25
00843                                                                   CHGBD200
00844      END-EVALUATE.                                                CHGBD200
00845                                                                   CHGBD200
00846                                                                   CHGBD200
00847 ***  MOVE PROG-SUB TO CHG2-PROGRAM.                               CHGBD200
00848                                                                   CHGBD200
00849      IF (TAB-BEN-CHG (EMP-SUB, PROG-SUB) +                        CHGBD200
00850          TAB-ADJ-CHG (EMP-SUB, PROG-SUB)) NOT = ZERO              CHGBD200
00851         MOVE TAB-BEN-CHG (EMP-SUB, PROG-SUB)                      CHGBD200
00852                                     TO CHG2-CURR-BEN-AMT          CHGBD200
00853         MOVE TAB-ADJ-CHG (EMP-SUB, PROG-SUB)                      CHGBD200
00854                                     TO CHG2-CURR-ADJ-AMT          CHGBD200
00855         MOVE WRK-TOT-BEN (PROG-SUB) TO CHG2-TOT-BEN-AMT           CHGBD200
00856         MOVE WRK-TOT-ADJ (PROG-SUB) TO CHG2-TOT-ADJ-AMT           CHGBD200
00857         MOVE TAB-OP-RECOVER (EMP-SUB, PROG-SUB)                   CHGBD200
00858                                     TO CHG2-OP-RECOVER-AMT        CHGBD200
00859 *&                                                                CHGBD200
00860         IF CHG2-OP-RECOVER-AMT NOT = ZERO                         CHGBD200
00861            MOVE CHG2-OP-RECOVER-AMT  TO WRK-AMT-DISP              CHGBD200
00862            DISPLAY 'OP RECOVER ' CHG2-EMP-NO '  '                 CHGBD200
00863               CHG2-SSN '  ' WRK-AMT-DISP                          CHGBD200
00864         END-IF                                                    CHGBD200
00865 *&                                                                CHGBD200
00866         PERFORM S200-WRITE-CHG2 THRU S200-EXIT                    CHGBD200
00867         PERFORM P1450-WRITE-SRVR THRU P1450-EXIT                     CL*46
00868      COMPUTE TOT-BEN-ADJ-AMT = TOT-BEN-ADJ-AMT +                  CHGBD200
00869         (CHG2-CURR-BEN-AMT + CHG2-CURR-ADJ-AMT).                  CHGBD200
00870                                                                   CHGBD200
00871  P1420-EXIT.                                                      CHGBD200
00872      EXIT.                                                        CHGBD200
00873      EJECT                                                        CHGBD200
00874  P1450-WRITE-SRVR.                                                CHGBD200
00875 *       DISPLAY 'P1450-WRITE-SRVR...'.                               CL**8
00876         MOVE CHG2-EMP-NO          TO OUT-EMP-NO.                  CHGBD200
00877         MOVE CHG2-CHARGE-DATE     TO L001-FED-8-DATE-9.           CHGBD200
00878         PERFORM S001-FROM-FED-8   THRU S001-EXIT.                 CHGBD200
00879         MOVE L001-SLASH-8-DATE    TO OUT-CHARGE-DATE.             CHGBD200
00880         MOVE CHG2-SSN             TO WRK-SSN.                     CHGBD200
00881 *       MOVE WRK-OUT-SSN          TO OUT-SSN.                        CL*38
00882         MOVE WRK-SSN          TO OUT-SSN.                            CL*38
00883         MOVE CHG2-BYE             TO L001-FED-8-DATE-9.           CHGBD200
00884         PERFORM S001-FROM-FED-8   THRU S001-EXIT.                 CHGBD200
00885         IF L001-INVALID-DATE                                      CHGBD200
00886            MOVE '01/01/1930'      TO OUT-BYE                      CHGBD200
00887         ELSE                                                      CHGBD200
00888            MOVE L001-SLASH-8-DATE    TO OUT-BYE.                  CHGBD200
00889         MOVE CHG2-PROGRAM         TO OUT-PROGRAM.                 CHGBD200
00890         MOVE CHG2-EMP-TYPE        TO OUT-EMP-TYPE.                CHGBD200
00891       COMPUTE WRK-CURR-AMT = CHG2-CURR-BEN-AMT + CHG2-CURR-ADJ-AMTCHGBD200
00892         MOVE WRK-CURR-AMT         TO OUT-CURR-AMT.                CHGBD200
00893         ADD WRK-CURR-AMT          TO WRK-TOT-CHG.                 CHGBD200
00894                                                                      CL*27
00895 *    DISPLAY 'P1450 WRITE ' CHG2-CHARGE-DATE                         CL*36
00896 *                       ' ' CHG2-EMP-NO                              CL*36
00897 *                       ' ' CHG2-SSN                                 CL*36
00898 *                       ' ' CHG2-BYE                                 CL*36
00899 *                       ' ' OUT-CURR-AMT.                            CL*36
00900 **NH MOD FOR RECOVERIES                                           CHGBD200
00901         MOVE WRK-AMT-DISP         TO OUT-RECOVERIES.              CHGBD200
00902 **NH MOD FOR RECOVERIES                                           CHGBD200
00903         WRITE BD200-SRVR-REC     FROM WRK-OUT-REC.                CHGBD200
00904         ADD 1  TO  WRK-SRVR-WRITE-CNT.                            CHGBD200
00905         MOVE ZERO TO OUT-RECOVERIES.                              CHGBD200
00906         MOVE ZERO TO WRK-AMT-DISP.                                CHGBD200
00907                                                                   CHGBD200
00908  P1450-EXIT.                                                      CHGBD200
00909      EXIT.                                                        CHGBD200
00910      EJECT                                                        CHGBD200
00911  P2000-INIT-EMP-DATA.                                             CHGBD200
00912 *    DISPLAY 'P2000-INIT-EMP-DATA...'.                               CL*11
00913      MOVE CHG1-SSN     TO WRK-CURR-SSN.                           CHGBD200
00914      MOVE CHG1-BYE     TO WRK-CURR-BYE.                           CHGBD200
00915      MOVE CHG1-CHARGE-DATE TO WRK-CURR-CHG-DATE                      CL*28
00916      MOVE CHG1-CHARGE-NAME                                           CL*28
00917                        TO WRK-CLMNT-NAME.                         CHGBD200
00918                                                                   CHGBD200
00919      MOVE ZERO         TO WRK-CURR-EMP.                           CHGBD200
00920                                                                   CHGBD200
00921      PERFORM                                                      CHGBD200
00922         VARYING PROG-SUB FROM +1 BY +1                            CHGBD200
00923         UNTIL PROG-SUB > PROG-SUB-MAX                             CHGBD200
00924            MOVE ZERO TO WRK-TOT-BEN (PROG-SUB),                   CHGBD200
00925                         WRK-TOT-ADJ (PROG-SUB)                    CHGBD200
00926 *    DISPLAY 'P2000-INIT-EMP-.VARY..' PROG-SUB ' ' PROG-SUB-MAX      CL*11
00927      END-PERFORM.                                                 CHGBD200
00928                                                                   CHGBD200
00929      PERFORM P2100-INIT-EMP-TABLE THRU P2100-EXIT                 CHGBD200
00930         VARYING EMP-SUB FROM +1 BY +1                             CHGBD200
00931         UNTIL EMP-SUB > EMP-ENTRY-MAX.                            CHGBD200
00932                                                                   CHGBD200
00933      MOVE +0    TO EMP-SUB,                                       CHGBD200
00934                    EMP-CNT.                                       CHGBD200
00935                                                                   CHGBD200
00936  P2000-EXIT.                                                      CHGBD200
00937      EXIT.                                                        CHGBD200
00938                                                                   CHGBD200
00939  P2100-INIT-EMP-TABLE.                                            CHGBD200
00940 *     DISPLAY 'P2100-INIT-EMP-TABLE...'.                             CL*11
00941      MOVE ZERO TO TAB-EMP-ACCT (EMP-SUB),                         CHGBD200
00942                   TAB-EMP-TYPE (EMP-SUB).                         CHGBD200
00943                                                                   CHGBD200
00944      PERFORM P2110-INIT-AMT-TABLE THRU P2110-EXIT                 CHGBD200
00945         VARYING PROG-SUB FROM +1 BY +1                            CHGBD200
00946         UNTIL PROG-SUB > PROG-SUB-MAX.                            CHGBD200
00947  P2100-EXIT.                                                      CHGBD200
00948      EXIT.                                                        CHGBD200
00949                                                                   CHGBD200
00950  P2110-INIT-AMT-TABLE.                                            CHGBD200
00951 *    DISPLAY 'P2110-INIT-AMT-TABLE....'.                             CL*11
00952      MOVE ZERO TO TAB-BEN-CHG    (EMP-SUB, PROG-SUB),             CHGBD200
00953                   TAB-ADJ-CHG    (EMP-SUB, PROG-SUB),             CHGBD200
00954                   TAB-OP-RECOVER (EMP-SUB, PROG-SUB).             CHGBD200
00955  P2110-EXIT.                                                      CHGBD200
00956      EXIT.                                                        CHGBD200
00957                                                                   CHGBD200
00958  T0000-TERMINATE.                                                 CHGBD200
00959      CLOSE BD100-CHG-FILE                                         CHGBD200
00960            BD200-CHG-FILE                                         CHGBD200
00961            BD200-TOTAL-CHG.                                       CHGBD200
00962                                                                   CHGBD200
00963      PERFORM S910-CLOSE     THRU S910-EXIT.                       CHGBD200
00964      PERFORM S921-CLOSE     THRU S921-EXIT.                       CHGBD200
00965                                                                   CHGBD200
00966      DISPLAY '    CHGBD200 CHARGE RECORDS READ: '                 CHGBD200
00967         WRK-BD100-READ.                                           CHGBD200
00968      DISPLAY ' EMPLOYER CHARGE RECORDS WRITTEN: '                 CHGBD200
00969         WRK-BD200-CHG-WRITTEN.                                    CHGBD200
00970      DISPLAY '      SSN CHARGE RECORDS WRITTEN: '                 CHGBD200
00971         WRK-BD200-TOTAL-WRITTEN.                                  CHGBD200
00972      DISPLAY '       CHARGE RECORDS DUPLICATED: '                 CHGBD200
00973         WRK-BD200-CHG-DUP.                                        CHGBD200
00974      DISPLAY '       CHARGE RECORDS DELETED...: '                    CL*30
00975         WRK-BD200-CHG-DEL.                                           CL*30
00976      MOVE TOT-BEN-ADJ-AMT TO TOT-BEN-ADJ-AMT-DISP.                CHGBD200
00977      DISPLAY '  '.                                                CHGBD200
00978      DISPLAY ' TOTAL BENEFIT AND ADJ AMT = '                      CHGBD200
00979         TOT-BEN-ADJ-AMT-DISP.                                     CHGBD200
00980                                                                   CHGBD200
00981  T0000-EXIT.                                                      CHGBD200
00982      EXIT.                                                        CHGBD200
00983      EJECT                                                        CHGBD200
00984                                                                   CHGBD200
00985  S001-FROM-FED-8.                                                 CHGBD200
00986      SET L001-FROM-FED-8 TO TRUE.                                 CHGBD200
00987      GO TO S001-DATE.                                             CHGBD200
00988                                                                   CHGBD200
00989  S001-FROM-ABS-DAY.                                               CHGBD200
00990      SET L001-FROM-ABS-DAY TO TRUE.                               CHGBD200
00991      GO TO S001-DATE.                                             CHGBD200
00992                                                                   CHGBD200
00993  S001-DATE.                                                       CHGBD200
00994      CALL 'DTSBU001' USING L001-LINK-AREA.                        CHGBD200
00995                                                                   CHGBD200
00996  S001-EXIT.                                                       CHGBD200
00997      EXIT.                                                        CHGBD200
00998      SKIP3                                                        CHGBD200
00999                                                                   CHGBD200
01000  S100-CALL-CHGBU100.                                              CHGBD200
01001       CALL 'CHGBU100' USING L100-LINK-AREA.                       CHGBD200
01002                                                                   CHGBD200
01003  S100-EXIT.                                                       CHGBD200
01004      EXIT.                                                        CHGBD200
01005                                                                   CHGBD200
01006  S200-WRITE-CHG2.                                                 CHGBD200
01007                                                                   CHGBD200
01008 *       PERFORM S300-DELETE-CHG2 THRU S300-EXIT                      CL*46
01009 *       PERFORM P1450-WRITE-SRVR THRU P1450-EXIT                     CL*44
01010 *       GO TO S200-EXIT                                              CL*46
01011                                                                      CL*40
01012      WRITE BD200-CHG-REC FROM WRK-BD200-CHG-REC.                  CHGBD200
01013                                                                   CHGBD200
01014      IF BD200-FILE-DUP-88                                         CHGBD200
01015         ADD +1 TO WRK-BD200-CHG-DUP                               CHGBD200
01016         IF WRK-ACCEPT-DUPS-YES-88                                 CHGBD200
01017            WRITE BD200-TOTAL-REC FROM WRK-BD200-CHG-REC           CHGBD200
01018            ADD +1 TO WRK-BD200-TOTAL-WRITTEN                      CHGBD200
01019         END-IF                                                    CHGBD200
01020      ELSE                                                         CHGBD200
01021         WRITE BD200-TOTAL-REC FROM WRK-BD200-CHG-REC              CHGBD200
01022         ADD +1 TO WRK-BD200-CHG-WRITTEN                           CHGBD200
01023         ADD +1 TO WRK-BD200-TOTAL-WRITTEN.                        CHGBD200
01024                                                                   CHGBD200
01025  S200-EXIT.                                                       CHGBD200
01026      EXIT.                                                        CHGBD200
01027                                                                   CHGBD200
01028  S300-DELETE-CHG2.                                                   CL*30
01029                                                                      CL*30
01030      MOVE WRK-BD200-CHG-REC TO BD200-CHG-REC-KEY.                    CL*30
01031      READ BD200-CHG-FILE INTO BD200-CHG-READ.                        CL*34
01032                                                                      CL*30
01033      IF NOT BD200-FILE-OK-88                                         CL*30
01034         DISPLAY 'BD200 VSAM READ ERROR: ' BD200-CHG-STATUS           CL*30
01035 *       DISPLAY 'REC NOT FND ' WRK-BD200-CHG-REC                     CL*40
01036         MOVE 'N' TO OUT-DEL                                          CL*44
01037         PERFORM P1450-WRITE-SRVR THRU P1450-EXIT                     CL*44
01038      DISPLAY  'REC NOT FND ' CHG2-CHARGE-DATE                        CL*40
01039            ',' CHG2-EMP-NO                                           CL*40
01040            ',' CHG2-SSN                                              CL*40
01041            ',' CHG2-BYE                                              CL*40
01042            ',' CHG2-PROGRAM                                          CL*43
01043         GO TO S300-EXIT.                                             CL*30
01044                                                                      CL*30
01045      DELETE BD200-CHG-FILE RECORD.                                   CL*30
01046                                                                      CL*30
01047      IF NOT BD200-FILE-OK-88                                         CL*30
01048         DISPLAY 'BD200 VSAM DELETE ERROR: ' BD200-CHG-STATUS         CL*30
01049         DISPLAY 'NOT DELETED ' BD200-CHG-READ                        CL*34
01050         GO TO S300-EXIT.                                             CL*30
01051                                                                      CL*30
01052         MOVE 'Y' TO OUT-DEL                                          CL*44
01053         PERFORM P1450-WRITE-SRVR THRU P1450-EXIT                     CL*44
01054       DISPLAY 'REC DELETED ' BD200-CHG-REC-KEY                       CL*32
01055       ADD 1 TO WRK-BD200-CHG-DEL.                                    CL*31
01056  S300-EXIT.                                                          CL*30
01057      EXIT.                                                           CL*30
01058  S910-OPEN-READ.                                                  CHGBD200
01059      SET L910-OPEN-READ-88 TO TRUE.                               CHGBD200
01060      GO TO S910-MSTR-IO.                                          CHGBD200
01061                                                                   CHGBD200
01062 *S910-READ.                                                       CHGBD200
01063 **   SET L910-READ-88 TO TRUE.                                    CHGBD200
01064 **   GO TO S910-MSTR-IO.                                          CHGBD200
01065                                                                   CHGBD200
01066  S910-CLOSE.                                                      CHGBD200
01067       SET L910-CLOSE-88 TO TRUE.                                  CHGBD200
01068       GO TO S910-MSTR-IO.                                         CHGBD200
01069                                                                   CHGBD200
01070  S910-MSTR-IO.                                                    CHGBD200
01071       CALL 'DTSBU910' USING L910-LINK-AREA                        CHGBD200
01072                             MSKL-REC.                             CHGBD200
01073                                                                   CHGBD200
01074  S910-EXIT.                                                       CHGBD200
01075      EXIT.                                                        CHGBD200
01076                                                                   CHGBD200
01077  S921-OPEN-READ.                                                  CHGBD200
01078      SET L921-OPEN-READ-88 TO TRUE.                               CHGBD200
01079      GO TO S921-AIX-IO.                                           CHGBD200
01080                                                                   CHGBD200
01081  S921-CLOSE.                                                      CHGBD200
01082       SET L921-CLOSE-88 TO TRUE.                                  CHGBD200
01083       GO TO S921-AIX-IO.                                          CHGBD200
01084                                                                   CHGBD200
01085  S921-AIX-IO.                                                     CHGBD200
01086       CALL 'DTSBU921' USING L921-LINK-AREA                        CHGBD200
01087                             ISKL-REC.                             CHGBD200
01088                                                                   CHGBD200
01089  S921-EXIT.                                                       CHGBD200
01090      EXIT.                                                        CHGBD200
01091                                                                   CHGBD200
01092  S999-ABEND.                                                      CHGBD200
01093      DISPLAY '****  CHGBD200 ABENDING '                           CHGBD200
01094         ABEND-MSG.                                                CHGBD200
01095      CALL ABEND-MOD USING ABEND-CODE.                             CHGBD200
01096  S999-EXIT.                                                       CHGBD200
01097      EXIT.                                                        CHGBD200
