00001  IDENTIFICATION DIVISION.                                         12/08/21
00002  PROGRAM-ID.             DTSCS1D.                                 DTSCS1D
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV060
00004  DATE-WRITTEN.           JUNE 1994.                               DTSCS1D
00005  DATE-COMPILED.                                                   DTSCS1D
00006      SKIP3                                                        DTSCS1D
00007 *****                                                             DTSCS1D
00008 *                                                                 DTSCS1D
00009 *    FUNCTION:  MISCELLANEOUS REGISTRATION INQUIRY/UPDATE         DTSCS1D
00010 *               SCREEN PROCESSOR.                                 DTSCS1D
00011 *                                                                 DTSCS1D
00012 *                                                                 DTSCS1D
00013 *    MODIFICATION LOG:                                            DTSCS1D
00014 *                                                                 DTSCS1D
00015 *    11/02/98  INITIAL DEVELOPMENT.  COPIED FROM MACCS1D.         DTSCS1D
00016 *              WORK ORDER:                      PROGRAMMER: ZL1   DTSCS1D
00017 *                                                                 DTSCS1D
00018 *    05/08/00  MODIFIED TO DISPLAY FISCAL AGENT DATA.             DTSCS1D
00019 *              WORK ORDER:                      PROGRAMMER: ZL1   DTSCS1D
00020 *                                                                 DTSCS1D
00021 *    10/24/05  MODIFIED TO DISPLAY RETURN MAIL INDICATOR          DTSCS1D
00022 *              WORK ORDER:                      PROGRAMMER: ZL1   DTSCS1D
00023 *                                                                 DTSCS1D
00024 *    02/01/06  ADDED EVENT LOG RECORD WHEN RETURN MAIL            DTSCS1D
00025 *              INDICATOR IS CHANGED.                              DTSCS1D
00026 *              WORK ORDER:                      PROGRAMMER: GD    DTSCS1D
00027 *                                                                 DTSCS1D
00028 *    07/14/2009  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00029 *                ELIGIBILITY CODES 21 (AB) AND 22 (DEPENDENCY     DTSCS1D
00030 *                ALLOWANCE) ADDED.                                DTSCS1D
00031 *                REFERENCE:                     PROGRAMMER: GD    DTSCS1D
00032 *                                                                 DTSCS1D
00033 *    07/15/2009  ADDED POWER OF ATTORNEY RECEIVED DATE.           DTSCS1D
00034 *                THIS REPLACES THE OTR ACCT NBR (BTN) THAT WAS    DTSCS1D
00035 *                ORIGINALLY IN THE SAME PLACE ON THE SCREEN.      DTSCS1D
00036 *                REFERENCE:                     PROGRAMMER: GD    DTSCS1D
00037 *                                                                 DTSCS1D
00038 *    07/30/2009  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00039 *                ELIGIBILITY CODE 23 (TRAINING EXTENSION) ADDED   DTSCS1D
00040 *                REFERENCE:                     PROGRAMMER: GD    DTSCS1D
00041 *                                                                 DTSCS1D
00042 *    11/17/2009  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00043 *                ELIGIBILITY CODES 24 AND 25 (EUC 2008 TIERS      DTSCS1D
00044 *                3 AND 4)                                         DTSCS1D
00045 *                REFERENCE:                     PROGRAMMER: GD    DTSCS1D
00046 *                                                                 DTSCS1D
00047 *    07/13/2011  MODIFIED TO SHOW YY IN POWER OF ATTORNEY         DTSCS1D
00048 *                FIELD.                                           DTSCS1D
00049 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00050 *                                                                 DTSCS1D
00051 *    09/26/2014  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00052 *                ELIGIBILITY CODE 28 (UCPIA)                      DTSCS1D
00053 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00054 *                                                                 DTSCS1D
00055 *    03/26/2015  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00056 *                ELIGIBILITY CODE 29 (DUA) AND 30 GPA             DTSCS1D
00057 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00058 *                                                                 DTSCS1D
00059 *    09/15/2015  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00060 *                ORGANIZATION CODES UNA FIT AND OTH               DTSCS1D
00061 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00062 *                                                                 DTSCS1D
00063 *    04/07/2020  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00064 *                ELIGIBILITY CODE 32 (FPUC) AND 33 FRUR           DTSCS1D
00065 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00066 *                                                                 DTSCS1D
00067 *    04/24/2020  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00068 *                ELIGIBILITY CODE 34 (PEUC)                       DTSCS1D
00069 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00070 *                                                                 DTSCS1D
00071 *    05/08/2020  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00072 *                ELIGIBILITY CODE 35 (REUR)                       DTSCS1D
00073 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00074 *                                                                 DTSCS1D
00075 *    09/02/2020  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00076 *                ELIGIBILITY CODE 36 (LWA)                        DTSCS1D
00077 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00078 *                                                                 DTSCS1D
00079 *    12/05/2020  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00080 *                ELIGIBILITY CODE 37 PUA SITMULUS                 DTSCS1D
00081 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00082 *                                                                 DTSCS1D
00083 *    02/16/2021  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00084 *                ELIGIBILITY CODE 38 MEUC                         DTSCS1D
00085 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00086 *                                                                 DTSCS1D
00087 *    12/06/2021  RECOMPILED FOR NEW VERSION OF MPRF -             DTSCS1D
00088 *                ELIGIBILITY CODE 39 DUC                          DTSCS1D
00089 *                REFERENCE:                     PROGRAMMER: ZL1   DTSCS1D
00090 *    XX/XX/XX  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   DTSCS1D
00091 *              XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   DTSCS1D
00092 *              WORK ORDER:                      PROGRAMMER: XXX   DTSCS1D
00093 *                                                                 DTSCS1D
00094 *                                                                 DTSCS1D
00095 *  DESCRIPTION:                                                   DTSCS1D
00096 *                                                                 DTSCS1D
00097 *                                                                 DTSCS1D
00098 *    CLEAR:                                                       DTSCS1D
00099 *                                                                 DTSCS1D
00100 *      FIELD(S) DISPLAYED: MAP-EMP-NO (FROM LCCM-EMP-NO).         DTSCS1D
00101 *                                                                 DTSCS1D
00102 *                                                                 DTSCS1D
00103 *    JUMP:                                                        DTSCS1D
00104 *                                                                 DTSCS1D
00105 *      F17  REGISTRATION INQUIRY (11).                            DTSCS1D
00106 *                                                                 DTSCS1D
00107 *                                                                 DTSCS1D
00108 *    INQUIRY:                                                     DTSCS1D
00109 *                                                                 DTSCS1D
00110 *      CONTROL FIELD(S): MAP-EMP-NO.                              DTSCS1D
00111 *                                                                 DTSCS1D
00112 *      JUMP IN: DISPLAY DATA ASSOCIATED WITH LCCM-EMP-NO.         DTSCS1D
00113 *                                                                 DTSCS1D
00114 *      ENTER:   DISPLAY DATA ASSOCIATED WITH MAP-EMP-NO.          DTSCS1D
00115 *                                                                 DTSCS1D
00116 *      STANDARD LCCM-EMP-NO MAINTENANCE.                          DTSCS1D
00117 *                                                                 DTSCS1D
00118 *                                                                 DTSCS1D
00119 *    UPDATE:                                                      DTSCS1D
00120 *                                                                 DTSCS1D
00121 *      MOD.                                                       DTSCS1D
00122 *                                                                 DTSCS1D
00123 *                                                                 DTSCS1D
00124 *    RECORDS READ:                                                DTSCS1D
00125 *                                                                 DTSCS1D
00126 *      MASTER:                                                    DTSCS1D
00127 *                                                                 DTSCS1D
00128 *        MPRF.                                                    DTSCS1D
00129 *                                                                 DTSCS1D
00130 *                                                                 DTSCS1D
00131 *      ALTERNATE INDEX:                                           DTSCS1D
00132 *                                                                 DTSCS1D
00133 *        N/A.                                                     DTSCS1D
00134 *                                                                 DTSCS1D
00135 *                                                                 DTSCS1D
00136 *      REFERENCE:                                                 DTSCS1D
00137 *                                                                 DTSCS1D
00138 *        N/A.                                                     DTSCS1D
00139 *                                                                 DTSCS1D
00140 *                                                                 DTSCS1D
00141 *      ACCOUNTING TRANSACTION COLLECTION:                         DTSCS1D
00142 *                                                                 DTSCS1D
00143 *        N/A.                                                     DTSCS1D
00144 *                                                                 DTSCS1D
00145 *                                                                 DTSCS1D
00146 *    RECORDS UPDATED:                                             DTSCS1D
00147 *                                                                 DTSCS1D
00148 *      MASTER:                                                    DTSCS1D
00149 *                                                                 DTSCS1D
00150 *        MPRF (REWRITE).                                          DTSCS1D
00151 *                                                                 DTSCS1D
00152 *                                                                 DTSCS1D
00153 *      REFERENCE:                                                 DTSCS1D
00154 *                                                                 DTSCS1D
00155 *        N/A.                                                     DTSCS1D
00156 *                                                                 DTSCS1D
00157 *                                                                 DTSCS1D
00158 *      ACCOUNTING TRANSACTION COLLECTION:                         DTSCS1D
00159 *                                                                 DTSCS1D
00160 *        N/A.                                                     DTSCS1D
00161 *                                                                 DTSCS1D
00162 *                                                                 DTSCS1D
00163 *    ON-LINE ACTIVITY FILE RECORDS WRITTEN:                       DTSCS1D
00164 *                                                                 DTSCS1D
00165 *      N/A.                                                       DTSCS1D
00166 *                                                                 DTSCS1D
00167 *                                                                 DTSCS1D
00168 *    TEMPORARY STORAGE USAGE:                                     DTSCS1D
00169 *                                                                 DTSCS1D
00170 *      N/A.                                                       DTSCS1D
00171 *                                                                 DTSCS1D
00172 *                                                                 DTSCS1D
00173 *    MODULES LINKED TO:                                           DTSCS1D
00174 *                                                                 DTSCS1D
00175 *      DTSCU004  QUARTER EDIT/CONVERSION.                         DTSCS1D
00176 *      DTSCU016  YEAR/QUARTER FROM SCREEN FORMAT/EDIT.            DTSCS1D
00177 *      DTSCU017  FEIN FROM SCREEN FORMAT/EDIT.                    DTSCS1D
00178 *      DTSCU018  EMP NO FROM SCREEN FORMAT/EDIT.                  DTSCS1D
00179 *      DTSCU031  EMPLOYER REGISTRATION CODES EDIT/DESCRIPTION.    DTSCS1D
00180 *      DTSCU039  SIC CODE EDIT/DESCRIPTION.                       DTSCS1D
00181 *      DTSCU074  DUPLICATE FEIN EDIT.                             DTSCS1D
00182 *      DTSCU204  DETERMINE SIC DIVISION.                          DTSCS1D
00183 *      DTSCU221  MPRF-UPDATE DATA ELEMENT MAINTENANCE.            DTSCS1D
00184 *      DTSCU331  WRITE MAINTENANCE LIST REPORT RECORDS.           DTSCS1D
00185 *      DTSCU810  MASTER FILE INPUT/OUTPUT.                        DTSCS1D
00186 *                                                                 DTSCS1D
00187 *                                                                 DTSCS1D
00188 *    MAINTENANCE NOTES:                                           DTSCS1D
00189 *                                                                 DTSCS1D
00190 *      A NON-KEY FIELD ADDED TO OR REMOVED FROM THE SCREEN        DTSCS1D
00191 *      REQUIRES ATTENTION IN THE FOLLOWING AREAS:                 DTSCS1D
00192 *        ALTER PARAGRAPHS P6900, P8900, S5900,                    DTSCS1D
00193 *        ALTER AS APPROPRIATE PARAGRAPHS LISTED IN S1002,         DTSCS1D
00194 *        ALTER THE SEND/RECEIVE AREA DEFINITION (DTSIS1D),        DTSCS1D
00195 *        ALTER THE MAP (DTSM1D) AND ASSEMBLE THE MAPSET (DTSMSET).DTSCS1D
00196 *                                                                 DTSCS1D
00197 *                                                                 DTSCS1D
00198 *    VERMONT REFERENCE:                                           DTSCS1D
00199 *                                                                 DTSCS1D
00200 *      N/A.                                                       DTSCS1D
00201 *                                                                 DTSCS1D
00202 *****                                                             DTSCS1D
00203      SKIP3                                                        DTSCS1D
00204  ENVIRONMENT DIVISION.                                            DTSCS1D
00205      SKIP3                                                        DTSCS1D
00206  DATA DIVISION.                                                   DTSCS1D
00207      SKIP3                                                        DTSCS1D
00208  WORKING-STORAGE SECTION.                                         DTSCS1D
002085 77  PAN-VALET PICTURE X(24) VALUE '060DTSCS1D   12/08/21'.       DTSCS1D
00209  77  PAN-VALET PICTURE X(24) VALUE '002DTSCS1D   12/07/21'.       DTSCS1D
00210  77  PAN-VALET PICTURE X(24) VALUE '058DTSCS1D   02/16/21'.       DTSCS1D
00211  77  PAN-VALET PICTURE X(24) VALUE '002DTSCS1D   02/16/21'.       DTSCS1D
00212  77  PAN-VALET PICTURE X(24) VALUE '056DTSCS1D   12/07/20'.       DTSCS1D
00213  77  PAN-VALET PICTURE X(24) VALUE '003DTSCS1D   12/07/20'.       DTSCS1D
00214  77  PAN-VALET PICTURE X(24) VALUE '054DTSCS1D   05/08/20'.       DTSCS1D
00215  77  PAN-VALET PICTURE X(24) VALUE '002DTSCS1D   05/08/20'.       DTSCS1D
00216  77  PAN-VALET PICTURE X(24) VALUE '052DTSCS1D   04/27/20'.       DTSCS1D
00217  77  PAN-VALET PICTURE X(24) VALUE '004DTSCS1D   04/25/20'.       DTSCS1D
00218  77  PAN-VALET PICTURE X(24) VALUE '050DTSCS1D   03/25/15'.       DTSCS1D
00219  77  PAN-VALET PICTURE X(24) VALUE '002DTSCS1D   03/25/15'.       DTSCS1D
00220  77  PAN-VALET PICTURE X(24) VALUE '048DTSCS1D   10/01/14'.       DTSCS1D
00221  77  PAN-VALET PICTURE X(24) VALUE '002DTSCS1D   09/26/14'.       DTSCS1D
00222  77  PAN-VALET PICTURE X(24) VALUE '046DTSCS1D   07/13/11'.       DTSCS1D
00223      SKIP3                                                        DTSCS1D
00224  01  WRK-AREA.                                                    DTSCS1D
00225      05  WRK-ABEND-CD                PIC  X(04)  VALUE 'S1D '.    DTSCS1D
00226      SKIP1                                                        DTSCS1D
00227      05  WRK-SCR-ID                  PIC  X(02)  VALUE '1D'.      DTSCS1D
00228      05  WRK-F03-SCR-ID              PIC  X(02)  VALUE '10'.      DTSCS1D
00229      SKIP1                                                        DTSCS1D
00230      05  WRK-EMP-NO                  PIC S9(07)  COMP-3.          DTSCS1D
00231      SKIP1                                                        DTSCS1D
00232      05  WRK-MSG-AREA                PIC  X(62).                  DTSCS1D
00233      SKIP1                                                        DTSCS1D
00234      05  WRK-MPRF-IND                PIC  X(01).                  DTSCS1D
00235          88  WRK-MPRF-YES-88                VALUE 'Y'.            DTSCS1D
00236          88  WRK-MPRF-NO-88                 VALUE 'N'.            DTSCS1D
00237      SKIP1                                                        DTSCS1D
00238      05  WRK-FISCAL-AGENT-NAME       PIC X(40) VALUE SPACES.      DTSCS1D
00239      05  WRK-DISPLAY                 PIC 9(09).                   DTSCS1D
00240      05  FILLER REDEFINES WRK-DISPLAY.                            DTSCS1D
00241          10  WRK-DISPLAY-FEIN-1      PIC X(02).                   DTSCS1D
00242          10  WRK-DISPLAY-FEIN-2      PIC X(07).                   DTSCS1D
00243                                                                   DTSCS1D
00244      05  WRK-MSOL-CNT                PIC S9(04) COMP.             DTSCS1D
00245      05  WRK-START-YRQ               PIC S9(05) COMP-3.           DTSCS1D
00246      05  WRK-UPD-MSOL-IND            PIC  X(01).                  DTSCS1D
00247          88  WRK-UPD-MSOL-YES-88  VALUE 'Y'.                      DTSCS1D
00248          88  WRK-UPD-MSOL-NO-88   VALUE 'N'.                      DTSCS1D
00249      05  WRK-LIAB-CD-DOMESTIC-IND    PIC  X(01).                  DTSCS1D
00250          88  WRK-LIAB-CD-DOMESTIC-YES-88  VALUE 'Y'.              DTSCS1D
00251          88  WRK-LIAB-CD-DOMESTIC-NO-88   VALUE 'N'.              DTSCS1D
00252                                                                   DTSCS1D
00253      05  WRK-PWR-ATTORNEY-YR.                                     DTSCS1D
00254          15  WRK-PWR-ATTORNEY-CC     PIC 99.                      DTSCS1D
00255          15  WRK-PWR-ATTORNEY-YY     PIC 99.                      DTSCS1D
00256      EJECT                                                        DTSCS1D
00257  01  SCREEN-CONTROL.                                              DTSCS1D
00258      05  SCR-ACCESS-IND              PIC X(01).                   DTSCS1D
00259          88  SCR-ACCESS-INQ                  VALUE '1'.           DTSCS1D
00260          88  SCR-ACCESS-UPDATE               VALUE '2'.           DTSCS1D
00261      SKIP1                                                        DTSCS1D
00262      05  CURSOR-SET-IND              PIC X(01).                   DTSCS1D
00263          88  CURSOR-SET-YES                  VALUE 'Y'.           DTSCS1D
00264          88  CURSOR-SET-NO                   VALUE 'N'.           DTSCS1D
00265          88  CURSOR-SET-GOTO                 VALUE 'G'.           DTSCS1D
00266      SKIP1                                                        DTSCS1D
00267      05  REQ-IND                     PIC X(01).                   DTSCS1D
00268          88  REQ-ERROR                       VALUE 'O'.           DTSCS1D
00269          88  REQ-JUMP                        VALUE 'J'.           DTSCS1D
00270          88  REQ-INQUIRE                     VALUE 'I'.           DTSCS1D
00271          88  REQ-CLEAR                       VALUE 'C'.           DTSCS1D
00272          88  REQ-EDIT                        VALUE 'E'.           DTSCS1D
00273          88  REQ-UPDATE                      VALUE 'U'.           DTSCS1D
00274          88  REQ-CURSOR-TO-GOTO              VALUE 'G'.           DTSCS1D
00275      SKIP1                                                        DTSCS1D
00276      05  RESP-IND                    PIC X(01).                   DTSCS1D
00277          88  RESP-SEND-MSGONLY               VALUE 'O'.           DTSCS1D
00278          88  RESP-SEND-MAP                   VALUE 'M'.           DTSCS1D
00279          88  RESP-JUMP                       VALUE 'J'.           DTSCS1D
00280          88  RESP-CURSOR-TO-GOTO             VALUE 'G'.           DTSCS1D
00281      SKIP1                                                        DTSCS1D
00282      05  SCR-ATB-AN                  PIC  X(01).                  DTSCS1D
00283      05  SCR-ATB-NUM                 PIC  X(01).                  DTSCS1D
00284                                                                   DTSCS1D
00285      05  WRK-RET-MAIL-IND            PIC  X(01).                  DTSCS1D
00286          88  WRK-RET-MAIL-ON-88       VALUE '1'.                  DTSCS1D
00287          88  WRK-RET-MAIL-OFF-88      VALUE '2'.                  DTSCS1D
00288          88  WRK-RET-MAIL-NULL-88     VALUE '0'.                  DTSCS1D
00289                                                                   DTSCS1D
00290  01  MSG-LITERALS.                                                DTSCS1D
00291      05  MSG-E1D1-AREA.                                           DTSCS1D
00292          10  FILLER                  PIC  X(04)  VALUE 'E1D1'.    DTSCS1D
00293          10  FILLER                  PIC  X(30)                   DTSCS1D
00294                VALUE 'CHANGE NOT ALLOWED - LIABILITY'.            DTSCS1D
00295          10  FILLER                  PIC  X(30)                   DTSCS1D
00296                VALUE ' CODE NOT HOUSEHOLD           '.            DTSCS1D
00297      05  MSG-E1D2-AREA.                                           DTSCS1D
00298          10  FILLER                  PIC  X(04)  VALUE 'E1D2'.    DTSCS1D
00299          10  FILLER                  PIC  X(30)                   DTSCS1D
00300                VALUE 'NOT ALLOWED: EMPLOYER NOT LIAB'.            DTSCS1D
00301          10  FILLER                  PIC  X(30)                   DTSCS1D
00302                VALUE 'LE                            '.            DTSCS1D
00303      05  MSG-E1D3-AREA.                                           DTSCS1D
00304          10  FILLER                  PIC  X(04)  VALUE 'E1D3'.    DTSCS1D
00305          10  FILLER                  PIC  X(30)                   DTSCS1D
00306                VALUE 'CHANGE FROM HOUSEHOLD NOT ALLO'.            DTSCS1D
00307          10  FILLER                  PIC  X(30)                   DTSCS1D
00308                VALUE 'WED. ESATBLISH NEW ACCOUNT    '.            DTSCS1D
00309                                                                   DTSCS1D
00310                                                                   DTSCS1D
00311  01  L001-COMM-AREA.                                              DTSCS1D
00312  ++INCLUDE DTSIL001                                               DTSCS1D
00313      EJECT                                                        DTSCS1D
00314  01  L004-COMM-AREA.                                              DTSCS1D
00315  ++INCLUDE DTSIL004                                               DTSCS1D
00316      EJECT                                                        DTSCS1D
00317  01  L015-COMM-AREA.                                              DTSCS1D
00318  ++INCLUDE DTSIL015                                               DTSCS1D
00319      EJECT                                                        DTSCS1D
00320  01  L016-COMM-AREA.                                              DTSCS1D
00321  ++INCLUDE DTSIL016                                               DTSCS1D
00322      EJECT                                                        DTSCS1D
00323  01  L017-COMM-AREA.                                              DTSCS1D
00324  ++INCLUDE DTSIL017                                               DTSCS1D
00325      EJECT                                                        DTSCS1D
00326  01  L018-COMM-AREA.                                              DTSCS1D
00327  ++INCLUDE DTSIL018                                               DTSCS1D
00328      EJECT                                                        DTSCS1D
00329  01  L027-COMM-AREA.                                              DTSCS1D
00330  ++INCLUDE DTSIL027                                               DTSCS1D
00331      EJECT                                                        DTSCS1D
00332  01  L031-COMM-AREA.                                              DTSCS1D
00333  ++INCLUDE DTSIL031                                               DTSCS1D
00334      EJECT                                                        DTSCS1D
00335 *01  L039-COMM-AREA.                                              DTSCS1D
00336 ***INCLUDE DTSIL039                                               DTSCS1D
00337      EJECT                                                        DTSCS1D
00338  01  L074-COMM-AREA.                                              DTSCS1D
00339  ++INCLUDE DTSIL074                                               DTSCS1D
00340      EJECT                                                        DTSCS1D
00341  01  L221-COMM-AREA.                                              DTSCS1D
00342  ++INCLUDE DTSIL221                                               DTSCS1D
00343      EJECT                                                        DTSCS1D
00344  01  L331-COMM-AREA.                                              DTSCS1D
00345  ++INCLUDE DTSIL331                                               DTSCS1D
00346      EJECT                                                        DTSCS1D
00347  01  L400-COMM-AREA.                                              DTSCS1D
00348  ++INCLUDE DTSIL400                                               DTSCS1D
00349      EJECT                                                        DTSCS1D
00350  01  L805-COMM-AREA.                                              DTSCS1D
00351  ++INCLUDE DTSIL805                                               DTSCS1D
00352      EJECT                                                        DTSCS1D
00353  01  L810-COMM-AREA.                                              DTSCS1D
00354      05  L810-CONTROL-BLOCK.                                      DTSCS1D
00355  ++INCLUDE DTSIL810                                               DTSCS1D
00356      EJECT                                                        DTSCS1D
00357      05  MSKL-REC.                                                DTSCS1D
00358  ++INCLUDE DTSIMSKL                                               DTSCS1D
00359      SKIP1                                                        DTSCS1D
00360      EJECT                                                        DTSCS1D
00361  01  L831-COMM-AREA.                                              DTSCS1D
00362      05  L831-CONTROL-BLOCK.                                      DTSCS1D
00363  ++INCLUDE DTSIL831                                               DTSCS1D
00364      EJECT                                                        DTSCS1D
00365      05  FSKL-REC.                                                DTSCS1D
00366  ++INCLUDE DTSIFSKL                                               DTSCS1D
00367      SKIP1                                                        DTSCS1D
00368      05  MFAE-REC.                                                DTSCS1D
00369  ++INCLUDE DTSIMFAE                                               DTSCS1D
00370      SKIP1                                                        DTSCS1D
00371      05  FFIS-REC.                                                DTSCS1D
00372  ++INCLUDE DTSIFFIS                                               DTSCS1D
00373      SKIP1                                                        DTSCS1D
00374  01  MPRF-REC.                                                    DTSCS1D
00375  ++INCLUDE DTSIMPRF                                               DTSCS1D
00376  01  MSOL-REC.                                                    DTSCS1D
00377      SKIP1                                                        DTSCS1D
00378  ++INCLUDE DTSIMSOL                                               DTSCS1D
00379  01  MEVL-REC.                                                    DTSCS1D
00380      SKIP1                                                        DTSCS1D
00381  ++INCLUDE DTSIMEVL                                               DTSCS1D
00382                                                                   DTSCS1D
00383  01  L851-COMM-AREA.                                              DTSCS1D
00384      SKIP1                                                        DTSCS1D
00385  ++INCLUDE DTSIL851                                               DTSCS1D
00386      SKIP3                                                        DTSCS1D
00387      05  MAP-AREA REDEFINES L851-MAP-AREA.                        DTSCS1D
00388  ++INCLUDE DTSIS1D                                                DTSCS1D
00389      EJECT                                                        DTSCS1D
00390  01  CATB-LITERALS.                                               DTSCS1D
00391  ++INCLUDE DTSICATB                                               DTSCS1D
00392      SKIP3                                                        DTSCS1D
00393  01  CFKD-LITERALS.                                               DTSCS1D
00394  ++INCLUDE DTSICFKD                                               DTSCS1D
00395      EJECT                                                        DTSCS1D
00396  01  CECD-LITERALS.                                               DTSCS1D
00397  ++INCLUDE DTSICECD                                               DTSCS1D
00398      SKIP3                                                        DTSCS1D
00399  01  CPCD-LITERALS.                                               DTSCS1D
00400  ++INCLUDE DTSICPCD                                               DTSCS1D
00401      EJECT                                                        DTSCS1D
00402  LINKAGE SECTION.                                                 DTSCS1D
00403      SKIP3                                                        DTSCS1D
00404  01  DFHCOMMAREA.                                                 DTSCS1D
00405  ++INCLUDE DTSILCCM                                               DTSCS1D
00406      EJECT                                                        DTSCS1D
00407 ******************************************************************DTSCS1D
00408 *                                                                *DTSCS1D
00409 ******************************************************************DTSCS1D
00410      SKIP1                                                        DTSCS1D
00411  PROCEDURE DIVISION.                                              DTSCS1D
00412      SKIP2                                                        DTSCS1D
00413      MOVE +0 TO WRK-EMP-NO.                                       DTSCS1D
00414      MOVE LOW-VALUES TO MAP-AREA.                                 DTSCS1D
00415      SET CURSOR-SET-NO TO TRUE.                                   DTSCS1D
00416      SET WRK-MPRF-NO-88 TO TRUE.                                  DTSCS1D
00417      SKIP1                                                        DTSCS1D
00418      SET SCR-ACCESS-INQ TO TRUE.                                  DTSCS1D
00419      PERFORM P0100-ACCESS-SEARCH THRU P0100-EXIT                  DTSCS1D
00420          VARYING LCCM-NONUM-IDX FROM 1 BY 1                       DTSCS1D
00421          UNTIL LCCM-NONUM-IDX > LCCM-SCR-NONUM-CNT.               DTSCS1D
00422      SKIP3                                                        DTSCS1D
00423      MOVE SPACE TO REQ-IND.                                       DTSCS1D
00424      PERFORM P1000-ANALYZE-REQUEST THRU P1000-EXIT.               DTSCS1D
00425      SKIP1                                                        DTSCS1D
00426 *-----------------------------------------------------            DTSCS1D
00427 *    P1000-ANALYZE-REQUEST HAS DETERMINED, BASED ON THE           DTSCS1D
00428 *    "AID" KEY PRESSED AND THE CONTEXT OF THE CURRENT             DTSCS1D
00429 *    REQUEST WITHIN THE PSEUDO CONVERSATION, THE TYPE             DTSCS1D
00430 *    OF ACTIVITY THE WORK STATION OPERATOR HAS REQUESTED.         DTSCS1D
00431 *                                                                 DTSCS1D
00432 *    THE REQUEST, REFLECTED IN REQ-IND WILL NOW BE                DTSCS1D
00433 *    PROCESSED.                                                   DTSCS1D
00434 *                                                                 DTSCS1D
00435 *    THE REQUEST PROCESSING PARAGRAPHS WILL SET RESP-IND,         DTSCS1D
00436 *    INDICATING THE TYPE OF RESPONSE TO BE SENT TO THE            DTSCS1D
00437 *    WORK STATION OPERATOR.                                       DTSCS1D
00438 *-----------------------------------------------------            DTSCS1D
00439      SKIP1                                                        DTSCS1D
00440      MOVE SPACE TO RESP-IND.                                      DTSCS1D
00441      SKIP1                                                        DTSCS1D
00442      IF REQ-ERROR                                                 DTSCS1D
00443         PERFORM P2000-REQUEST-ERROR THRU P2000-EXIT               DTSCS1D
00444      ELSE                                                         DTSCS1D
00445      IF REQ-JUMP                                                  DTSCS1D
00446         PERFORM P3000-REQUEST-JUMP THRU P3000-EXIT                DTSCS1D
00447      ELSE                                                         DTSCS1D
00448      IF REQ-CLEAR                                                 DTSCS1D
00449         PERFORM P4000-REQUEST-CLEAR THRU P4000-EXIT               DTSCS1D
00450      ELSE                                                         DTSCS1D
00451      IF REQ-CURSOR-TO-GOTO                                        DTSCS1D
00452         PERFORM P5000-CURSOR-TO-GOTO THRU P5000-EXIT              DTSCS1D
00453      ELSE                                                         DTSCS1D
00454      IF REQ-INQUIRE                                               DTSCS1D
00455         PERFORM P6000-REQUEST-INQUIRE THRU P6000-EXIT             DTSCS1D
00456      ELSE                                                         DTSCS1D
00457      IF REQ-EDIT                                                  DTSCS1D
00458         PERFORM P7000-REQUEST-EDIT THRU P7000-EXIT                DTSCS1D
00459      ELSE                                                         DTSCS1D
00460      IF REQ-UPDATE                                                DTSCS1D
00461         PERFORM P8000-REQUEST-UPDATE THRU P8000-EXIT              DTSCS1D
00462      ELSE                                                         DTSCS1D
00463         GO TO S899-ABEND.                                         DTSCS1D
00464      SKIP3                                                        DTSCS1D
00465 *-----------------------------------------------------            DTSCS1D
00466 *    THE REQUEST PROCESSING PARAGRAPHS HAVE INDICATED             DTSCS1D
00467 *    IN RESP-IND THE TYPE OF RESPONSE TO BE MADE.                 DTSCS1D
00468 *-----------------------------------------------------            DTSCS1D
00469      SKIP1                                                        DTSCS1D
00470      IF RESP-SEND-MAP                                             DTSCS1D
00471          PERFORM S9300-SEND-MAP THRU S9300-EXIT                   DTSCS1D
00472          SET LCCM-END-TASK-88 TO TRUE                             DTSCS1D
00473      ELSE                                                         DTSCS1D
00474      IF RESP-SEND-MSGONLY                                         DTSCS1D
00475      OR RESP-CURSOR-TO-GOTO                                       DTSCS1D
00476          PERFORM S9200-SEND-DATAONLY THRU S9200-EXIT              DTSCS1D
00477          SET LCCM-END-TASK-88 TO TRUE                             DTSCS1D
00478      ELSE                                                         DTSCS1D
00479      IF RESP-JUMP                                                 DTSCS1D
00480          SET LCCM-LINK-SCREEN-88 TO TRUE                          DTSCS1D
00481      ELSE                                                         DTSCS1D
00482          GO TO S899-ABEND.                                        DTSCS1D
00483      SKIP3                                                        DTSCS1D
00484  MAINLINE-EXIT.                                                   DTSCS1D
00485      SKIP1                                                        DTSCS1D
00486      EXEC CICS                                                    DTSCS1D
00487          RETURN                                                   DTSCS1D
00488      END-EXEC.                                                    DTSCS1D
00489      SKIP2                                                        DTSCS1D
00490 *    GOBACK.                                                      DTSCS1D
00491      EJECT                                                        DTSCS1D
00492  P0100-ACCESS-SEARCH.                                             DTSCS1D
00493      IF LCCM-SCR-NONUM-ID (LCCM-NONUM-IDX) = WRK-SCR-ID           DTSCS1D
00494          MOVE LCCM-SCR-NONUM-ACCESS-IND (LCCM-NONUM-IDX)          DTSCS1D
00495            TO SCR-ACCESS-IND.                                     DTSCS1D
00496  P0100-EXIT.                                                      DTSCS1D
00497      EXIT.                                                        DTSCS1D
00498 /*****************************************************************DTSCS1D
00499 * DETERMINE CURRENT SCREEN STATE AND REQUEST COMBINATION         *DTSCS1D
00500 ******************************************************************DTSCS1D
00501  P1000-ANALYZE-REQUEST.                                           DTSCS1D
00502      SKIP1                                                        DTSCS1D
00503 *-----------------------------------------------------            DTSCS1D
00504 *     IF SCREEN IS NOT CURRENTLY DISPLAYED (JUMP TO HERE)         DTSCS1D
00505 *     THEN ANY KEY PRESSED WILL BE IGNORED (WILL BE               DTSCS1D
00506 *     REPLACED WITH ENTER)                                        DTSCS1D
00507 *-----------------------------------------------------            DTSCS1D
00508      IF LCCM-SCR-ID NOT = WRK-SCR-ID                              DTSCS1D
00509         SET LCCM-ENTER-88 TO TRUE                                 DTSCS1D
00510         SET REQ-INQUIRE TO TRUE                                   DTSCS1D
00511         IF LCCM-EMP-NO > ZERO                                     DTSCS1D
00512             MOVE LCCM-EMP-NO-1 TO MAP-EMP-NO-1                    DTSCS1D
00513             MOVE LCCM-EMP-NO-2 TO MAP-EMP-NO-2                    DTSCS1D
00514         END-IF                                                    DTSCS1D
00515         GO TO P1000-EXIT.                                         DTSCS1D
00516      SKIP3                                                        DTSCS1D
00517 *-----------------------------------------------------            DTSCS1D
00518 *      MAP IS RECEIVED                                            DTSCS1D
00519 *-----------------------------------------------------            DTSCS1D
00520      PERFORM S9100-RECEIVE THRU S9100-EXIT.                       DTSCS1D
00521      SKIP3                                                        DTSCS1D
00522 *-----------------------------------------------------            DTSCS1D
00523 *    CHECK FOR AID KEYS THAT DO NOT SEND DATA FROM THE            DTSCS1D
00524 *    WORK STATION                                                 DTSCS1D
00525 *-----------------------------------------------------            DTSCS1D
00526      IF LCCM-CLEAR-88                                             DTSCS1D
00527         SET REQ-CLEAR TO TRUE                                     DTSCS1D
00528         GO TO P1000-EXIT.                                         DTSCS1D
00529      SKIP3                                                        DTSCS1D
00530 *-----------------------------------------------------            DTSCS1D
00531 *    IF IN UPDATE MODE, SPECIFIC KEYS MUST BE CHECKED             DTSCS1D
00532 *-----------------------------------------------------            DTSCS1D
00533      IF LCCM-SCR-UPDATE-LOCKED                                    DTSCS1D
00534         PERFORM P1100-UPDATE-LOCKED THRU P1100-EXIT               DTSCS1D
00535         GO TO P1000-EXIT.                                         DTSCS1D
00536      SKIP3                                                        DTSCS1D
00537 *-----------------------------------------------------            DTSCS1D
00538 *    PA2 IS A REQUEST TO POSITION CURSOR AT GO TO:                DTSCS1D
00539 *-----------------------------------------------------            DTSCS1D
00540      IF LCCM-PA2-88                                               DTSCS1D
00541          SET REQ-CURSOR-TO-GOTO TO TRUE                           DTSCS1D
00542          GO TO P1000-EXIT.                                        DTSCS1D
00543      SKIP3                                                        DTSCS1D
00544 *-----------------------------------------------------            DTSCS1D
00545 *    ALL OTHER PA KEYS ARE NOT ACTIVE                             DTSCS1D
00546 *-----------------------------------------------------            DTSCS1D
00547      IF LCCM-PA-88                                                DTSCS1D
00548        PERFORM S804-INVALID-KEY THRU S804-EXIT                    DTSCS1D
00549        SET REQ-ERROR TO TRUE                                      DTSCS1D
00550        GO TO P1000-EXIT.                                          DTSCS1D
00551      SKIP3                                                        DTSCS1D
00552 *-----------------------------------------------------            DTSCS1D
00553 *    IF PF12 IS PRESSED AND UPDATE NOT IN PROGRESS THEN           DTSCS1D
00554 *    CLEAR SCREEN                                                 DTSCS1D
00555 *-----------------------------------------------------            DTSCS1D
00556      IF LCCM-F12-88                                               DTSCS1D
00557         MOVE LOW-VALUES TO MAP-AREA                               DTSCS1D
00558         SET REQ-CLEAR TO TRUE                                     DTSCS1D
00559         GO TO P1000-EXIT.                                         DTSCS1D
00560      SKIP3                                                        DTSCS1D
00561 *-----------------------------------------------------            DTSCS1D
00562 *    IF EXIT KEY PRESSED, JUMP TO NEXT HIGHER FUNCTION            DTSCS1D
00563 *-----------------------------------------------------            DTSCS1D
00564      IF LCCM-F03-88                                               DTSCS1D
00565         MOVE WRK-F03-SCR-ID TO LCCM-REQ-SCR-ID                    DTSCS1D
00566         SET REQ-JUMP TO TRUE                                      DTSCS1D
00567         GO TO P1000-EXIT.                                         DTSCS1D
00568      SKIP3                                                        DTSCS1D
00569 *-----------------------------------------------------            DTSCS1D
00570 *    IF PRIOR SCREEN KEY PRESSED, JUMP TO PREVIOUS SCREEN         DTSCS1D
00571 *-----------------------------------------------------            DTSCS1D
00572      IF LCCM-F04-88                                               DTSCS1D
00573         MOVE LCCM-PRIOR-SCR-ID TO LCCM-REQ-SCR-ID                 DTSCS1D
00574         SET REQ-JUMP TO TRUE                                      DTSCS1D
00575         GO TO P1000-EXIT.                                         DTSCS1D
00576      SKIP3                                                        DTSCS1D
00577 *-----------------------------------------------------            DTSCS1D
00578 *    IF CORRESPONDENCE SCREEN KEY PRESSED, JUMP TO                DTSCS1D
00579 *    CORRESPONDENCE SCREEN                                        DTSCS1D
00580 *-----------------------------------------------------            DTSCS1D
00581      IF LCCM-F14-88                                               DTSCS1D
00582         MOVE LCCM-CORR-SCR-ID TO LCCM-REQ-SCR-ID                  DTSCS1D
00583         SET REQ-JUMP TO TRUE                                      DTSCS1D
00584         GO TO P1000-EXIT.                                         DTSCS1D
00585      SKIP3                                                        DTSCS1D
00586 *-----------------------------------------------------            DTSCS1D
00587 *    IF REGISTRATION INQUIRY SCREEN KEY PRESSED,                  DTSCS1D
00588 *    THEN JUMP TO REGISTRATION INQUIRY SCREEN.                    DTSCS1D
00589 *-----------------------------------------------------            DTSCS1D
00590 *    IF LCCM-F17-88                                               DTSCS1D
00591 *       MOVE '11' TO LCCM-REQ-SCR-ID                              DTSCS1D
00592 *       SET REQ-JUMP TO TRUE                                      DTSCS1D
00593 *       GO TO P1000-EXIT.                                         DTSCS1D
00594 *    SKIP3                                                        DTSCS1D
00595 *-----------------------------------------------------            DTSCS1D
00596 *    IF DIFFERENT SCREEN TYPE IS REQUESTED, JUMP TO               DTSCS1D
00597 *    REQUESTED SCREEN TYPE                                        DTSCS1D
00598 *-----------------------------------------------------            DTSCS1D
00599      IF MAP-GOTO = SPACES OR LOW-VALUES OR WRK-SCR-ID             DTSCS1D
00600         NEXT SENTENCE                                             DTSCS1D
00601      ELSE                                                         DTSCS1D
00602        MOVE MAP-GOTO TO LCCM-REQ-SCR-ID                           DTSCS1D
00603        SET REQ-JUMP TO TRUE                                       DTSCS1D
00604        GO TO P1000-EXIT.                                          DTSCS1D
00605      SKIP3                                                        DTSCS1D
00606 *-----------------------------------------------------            DTSCS1D
00607 *    IF REQUEST TO UPDATE THE DATA (ADD, MOD, DEL)                DTSCS1D
00608 *          VERIFY USER ACCESS TO PERFORM UPDATE                   DTSCS1D
00609 *-----------------------------------------------------            DTSCS1D
00610      IF LCCM-F10-88                                               DTSCS1D
00611         IF SCR-ACCESS-UPDATE                                      DTSCS1D
00612            SET REQ-EDIT TO TRUE                                   DTSCS1D
00613            GO TO P1000-EXIT                                       DTSCS1D
00614         ELSE                                                      DTSCS1D
00615            PERFORM S804-INVALID-KEY THRU S804-EXIT                DTSCS1D
00616            SET REQ-ERROR TO TRUE                                  DTSCS1D
00617            GO TO P1000-EXIT.                                      DTSCS1D
00618      SKIP3                                                        DTSCS1D
00619 *-----------------------------------------------------            DTSCS1D
00620 *    IF INQUIRY TYPE KEY PRESSED (ENTER, PAGE DOWN,               DTSCS1D
00621 *          PAGE UP), INDICATE INQUIRY REQUEST                     DTSCS1D
00622 *-----------------------------------------------------            DTSCS1D
00623      IF LCCM-ENTER-88                                             DTSCS1D
00624          SET REQ-INQUIRE TO TRUE                                  DTSCS1D
00625          GO TO P1000-EXIT.                                        DTSCS1D
00626      SKIP3                                                        DTSCS1D
00627 *-----------------------------------------------------            DTSCS1D
00628 *     ANY OTHER KEY IS INVALID                                    DTSCS1D
00629 *-----------------------------------------------------            DTSCS1D
00630      PERFORM S804-INVALID-KEY THRU S804-EXIT.                     DTSCS1D
00631      SET REQ-ERROR TO TRUE.                                       DTSCS1D
00632  P1000-EXIT. EXIT.                                                DTSCS1D
00633      SKIP3                                                        DTSCS1D
00634 ******************************************************************DTSCS1D
00635 * THE SCREEN IS LOCKED FOR UPDATE AND THE USER CONFIRMS HIS WISH *DTSCS1D
00636 ******************************************************************DTSCS1D
00637      SKIP1                                                        DTSCS1D
00638  P1100-UPDATE-LOCKED.                                             DTSCS1D
00639 *-----------------------------------------------------            DTSCS1D
00640 *    IF THE SCREEN IS "LOCKED FOR UPDATE", THEN                   DTSCS1D
00641 *    THE ONLY VALID OPERATOR REQUESTS ARE ENTER                   DTSCS1D
00642 *    (CONFIRMING UPDATE) OR F12 (CANCELLING UPDATE).              DTSCS1D
00643 *-----------------------------------------------------            DTSCS1D
00644      IF LCCM-ENTER-88 OR LCCM-F12-88                              DTSCS1D
00645         SET REQ-UPDATE TO TRUE                                    DTSCS1D
00646      ELSE                                                         DTSCS1D
00647         SET REQ-ERROR TO TRUE                                     DTSCS1D
00648         IF LCCM-SCR-MOD-LOCKED                                    DTSCS1D
00649            MOVE PMSG-MOD-CONFIRM TO LCCM-MSG-AREA                 DTSCS1D
00650         ELSE                                                      DTSCS1D
00651            GO TO S899-ABEND.                                      DTSCS1D
00652  P1100-EXIT. EXIT.                                                DTSCS1D
00653 /*****************************************************************DTSCS1D
00654 * ANALYZE REQUEST HAS DETERMINED AN ERROR THAT MUST BE REPORTED. *DTSCS1D
00655 * VERIFY THAT A MESSAGE HAS BEEN FILLED IN.                      *DTSCS1D
00656 ******************************************************************DTSCS1D
00657      SKIP1                                                        DTSCS1D
00658  P2000-REQUEST-ERROR.                                             DTSCS1D
00659      IF LCCM-MSG                                                  DTSCS1D
00660         SET RESP-SEND-MSGONLY TO TRUE                             DTSCS1D
00661      ELSE                                                         DTSCS1D
00662         GO TO S899-ABEND.                                         DTSCS1D
00663  P2000-EXIT. EXIT.                                                DTSCS1D
00664 /*****************************************************************DTSCS1D
00665 * JUMP TO A DIFFERENT SCREEN TYPE WAS REQUESTED                  *DTSCS1D
00666 ******************************************************************DTSCS1D
00667      SKIP1                                                        DTSCS1D
00668  P3000-REQUEST-JUMP.                                              DTSCS1D
00669 *-----------------------------------------------------            DTSCS1D
00670 *    VERIFY THAT THE REQUESTED SCREEN EXISTS AND IS ACCESSIBLE    DTSCS1D
00671 *    BY USER                                                      DTSCS1D
00672 *-----------------------------------------------------            DTSCS1D
00673      PERFORM S803-REQ-SCR-ID-EDIT THRU S803-EXIT.                 DTSCS1D
00674      SKIP3                                                        DTSCS1D
00675 *-----------------------------------------------------            DTSCS1D
00676 *    VERIFICATION RETURN LCCM-MSG IF ERROR DETECTED               DTSCS1D
00677 *-----------------------------------------------------            DTSCS1D
00678      IF LCCM-MSG                                                  DTSCS1D
00679         SET RESP-SEND-MSGONLY TO TRUE                             DTSCS1D
00680         SET CURSOR-SET-GOTO TO TRUE                               DTSCS1D
00681         GO TO P3000-EXIT.                                         DTSCS1D
00682      SKIP3                                                        DTSCS1D
00683      MOVE MAP-EMP-NO-AREA TO L018-S-EMP-NO-AREA.                  DTSCS1D
00684      PERFORM S018-EMP-NO-FROM-SCREEN THRU S018-EXIT.              DTSCS1D
00685      IF L018-VALID                                                DTSCS1D
00686          MOVE L018-EMP-NO TO LCCM-EMP-NO.                         DTSCS1D
00687      SKIP3                                                        DTSCS1D
00688 *-----------------------------------------------------            DTSCS1D
00689 *    CLEAN UP INDICATORS AND PAGING STORAGE PRIOR TO LEAVING      DTSCS1D
00690 *-----------------------------------------------------            DTSCS1D
00691      MOVE LOW-VALUES TO LCCM-SCR-STATUS                           DTSCS1D
00692                         LCCM-SCR-HOLD-AREA.                       DTSCS1D
00693      MOVE +0 TO LCCM-SCR-ABSTIME.                                 DTSCS1D
00694      SET RESP-JUMP TO TRUE.                                       DTSCS1D
00695  P3000-EXIT. EXIT.                                                DTSCS1D
00696 /*****************************************************************DTSCS1D
00697 * CLEAR KEY WAS PRESSED                                          *DTSCS1D
00698 ******************************************************************DTSCS1D
00699      SKIP1                                                        DTSCS1D
00700  P4000-REQUEST-CLEAR.                                             DTSCS1D
00701      PERFORM S5300-SET-INQ-ATTRB THRU S5300-EXIT.                 DTSCS1D
00702      SKIP3                                                        DTSCS1D
00703 *-----------------------------------------------------            DTSCS1D
00704 *   CLEAN UP INDICATORS AND PAGING STORAGE.  RESET KEY            DTSCS1D
00705 *   FIELDS FROM EARLIER REQUESTS                                  DTSCS1D
00706 *-----------------------------------------------------            DTSCS1D
00707      IF LCCM-EMP-NO > ZERO                                        DTSCS1D
00708          MOVE LCCM-EMP-NO-1 TO MAP-EMP-NO-1                       DTSCS1D
00709          MOVE LCCM-EMP-NO-2 TO MAP-EMP-NO-2.                      DTSCS1D
00710      MOVE ZERO TO LCCM-EMP-NO.                                    DTSCS1D
00711      SKIP1                                                        DTSCS1D
00712      MOVE LOW-VALUES TO LCCM-SCR-HOLD-AREA.                       DTSCS1D
00713      MOVE LCCM-TASK-START-ABSTIME TO LCCM-SCR-ABSTIME.            DTSCS1D
00714      SET LCCM-SCR-CLEAR TO TRUE.                                  DTSCS1D
00715      SET RESP-SEND-MAP TO TRUE.                                   DTSCS1D
00716  P4000-EXIT. EXIT.                                                DTSCS1D
00717 /*****************************************************************DTSCS1D
00718 * POSITION CURSOR ON GO TO FIELD WAS REQUESTED                   *DTSCS1D
00719 ******************************************************************DTSCS1D
00720      SKIP1                                                        DTSCS1D
00721  P5000-CURSOR-TO-GOTO.                                            DTSCS1D
00722      SET CURSOR-SET-GOTO TO TRUE.                                 DTSCS1D
00723      SET RESP-CURSOR-TO-GOTO TO TRUE.                             DTSCS1D
00724  P5000-EXIT. EXIT.                                                DTSCS1D
00725 /*****************************************************************DTSCS1D
00726 * INQUIRY WAS REQUESTED                                          *DTSCS1D
00727 ******************************************************************DTSCS1D
00728      SKIP1                                                        DTSCS1D
00729  P6000-REQUEST-INQUIRE.                                           DTSCS1D
00730      MOVE MAP-EMP-NO-AREA TO L018-S-EMP-NO-AREA.                  DTSCS1D
00731      MOVE LOW-VALUES TO MAP-AREA.                                 DTSCS1D
00732      MOVE L018-S-EMP-NO-AREA TO MAP-EMP-NO-AREA.                  DTSCS1D
00733      SKIP1                                                        DTSCS1D
00734      PERFORM S5300-SET-INQ-ATTRB THRU S5300-EXIT.                 DTSCS1D
00735      SKIP1                                                        DTSCS1D
00736      SET LCCM-SCR-CLEAR TO TRUE.                                  DTSCS1D
00737      MOVE LCCM-TASK-START-ABSTIME TO LCCM-SCR-ABSTIME.            DTSCS1D
00738      SKIP1                                                        DTSCS1D
00739      PERFORM S1001-SCREEN-KEY-EDITS THRU S1001-EXIT.              DTSCS1D
00740      SKIP1                                                        DTSCS1D
00741      IF LCCM-NO-MSG                                               DTSCS1D
00742          IF LCCM-ENTER-88                                         DTSCS1D
00743              PERFORM P6100-NO-PAGE THRU P6100-EXIT                DTSCS1D
00744          ELSE                                                     DTSCS1D
00745              GO TO S899-ABEND.                                    DTSCS1D
00746      SKIP1                                                        DTSCS1D
00747      SET RESP-SEND-MAP TO TRUE.                                   DTSCS1D
00748  P6000-EXIT. EXIT.                                                DTSCS1D
00749      EJECT                                                        DTSCS1D
00750  P6100-NO-PAGE.                                                   DTSCS1D
00751      PERFORM S8100-READ-MPRF THRU S8100-EXIT.                     DTSCS1D
00752      IF L810-NO-REC-88                                            DTSCS1D
00753          MOVE EMSG-NO-EMPLOYER TO WRK-MSG-AREA                    DTSCS1D
00754          PERFORM S1101-ERROR THRU S1101-EXIT                      DTSCS1D
00755      ELSE                                                         DTSCS1D
00756          MOVE MSKL-REC       TO MPRF-REC                          DTSCS1D
00757          PERFORM P6900-CONSTRUCT-SCREEN THRU P6900-EXIT.          DTSCS1D
00758  P6100-EXIT. EXIT.                                                DTSCS1D
00759 /*****************************************************************DTSCS1D
00760 * THE RECORD WAS FOUND SO FORMAT AND PLACE ALL FIELDS            *DTSCS1D
00761 ******************************************************************DTSCS1D
00762      SKIP1                                                        DTSCS1D
00763  P6900-CONSTRUCT-SCREEN.                                          DTSCS1D
00764      IF SCR-ACCESS-UPDATE                                         DTSCS1D
00765          PERFORM S5200-SET-UPDATE-ATTRB THRU S5200-EXIT.          DTSCS1D
00766      SKIP1                                                        DTSCS1D
00767      PERFORM P6910-FROM-MPRF THRU P6910-EXIT.                     DTSCS1D
00768      PERFORM P6920-FROM-MFAE THRU P6920-EXIT.                     DTSCS1D
00769      SKIP1                                                        DTSCS1D
00770      SET LCCM-SCR-INQUIRE TO TRUE.                                DTSCS1D
00771      MOVE WRK-EMP-NO TO LCCM-EMP-NO.                              DTSCS1D
00772  P6900-EXIT. EXIT.                                                DTSCS1D
00773      SKIP3                                                        DTSCS1D
00774 /*****************************************************************DTSCS1D
00775 * MOVE FIELDS FROM THE MPRF RECORD AND FORMAT ON SCREEN          *DTSCS1D
00776 ******************************************************************DTSCS1D
00777  P6910-FROM-MPRF.                                                 DTSCS1D
00778      MOVE MPRF-UC30-MASS-MAIL-IND TO MAP-UC30-MASS-MAIL-IND.      DTSCS1D
00779      MOVE MPRF-UC30-CREDIT-IND   TO MAP-UC30-CREDIT-IND.          DTSCS1D
00780      MOVE MPRF-RETURN-MAIL-IND   TO MAP-RETURN-MAIL-IND.          DTSCS1D
00781      MOVE MPRF-FEIN-HARASS-IND   TO MAP-FEIN-HARASS-IND.          DTSCS1D
00782      MOVE MPRF-CHRG-STMT-PRINT-IND                                DTSCS1D
00783                                  TO MAP-CHRG-STMT-PRINT-IND.      DTSCS1D
00784      SKIP1                                                        DTSCS1D
00785      MOVE MPRF-ORG-TYPE TO MAP-ORG-TYPE.                          DTSCS1D
00786      SKIP1                                                        DTSCS1D
00787      IF MPRF-FEIN  NOT =  +0                                      DTSCS1D
00788          MOVE MPRF-FEIN TO WRK-DISPLAY                            DTSCS1D
00789          MOVE WRK-DISPLAY-FEIN-1 TO MAP-FEIN-1                    DTSCS1D
00790          MOVE WRK-DISPLAY-FEIN-2 TO MAP-FEIN-2.                   DTSCS1D
00791      SKIP1                                                        DTSCS1D
00792      MOVE MPRF-DC-CONTRACTOR-IND                                  DTSCS1D
00793                                  TO MAP-DC-CONTRACTOR-IND.        DTSCS1D
00794      SKIP1                                                        DTSCS1D
00795      IF MPRF-PWR-OF-ATTORNEY-DT NUMERIC                           DTSCS1D
00796         IF MPRF-PWR-OF-ATTORNEY-DT NOT = ZERO                     DTSCS1D
00797            MOVE MPRF-PWR-OF-ATTORNEY-DT  TO L001-FED-8-DATE-9     DTSCS1D
00798            PERFORM S001-FROM-FED-8       THRU S001-EXIT           DTSCS1D
00799            IF L001-VALID-DATE                                     DTSCS1D
00800               MOVE L001-FED-8-MO         TO MAP-PWR-ATTORNEY-MO   DTSCS1D
00801               MOVE L001-FED-8-DA         TO MAP-PWR-ATTORNEY-DA   DTSCS1D
00802               MOVE L001-FED-8-YR         TO WRK-PWR-ATTORNEY-YR   DTSCS1D
00803               MOVE WRK-PWR-ATTORNEY-YY   TO MAP-PWR-ATTORNEY-YR   DTSCS1D
00804            END-IF                                                 DTSCS1D
00805         END-IF                                                    DTSCS1D
00806      END-IF.                                                      DTSCS1D
00807      SKIP1                                                        DTSCS1D
00808      MOVE MPRF-EFT-ENROLLED-IND                                   DTSCS1D
00809                                  TO MAP-EFT-ENROLLED-IND.         DTSCS1D
00810      SKIP1                                                        DTSCS1D
00811      IF MPRF-ARCHIVED-AUDIT-YRQ NOT = +0                          DTSCS1D
00812          MOVE MPRF-ARCHIVED-AUDIT-YRQ TO L004-QTR-5-9             DTSCS1D
00813          SET L004-FROM-5 TO TRUE                                  DTSCS1D
00814          PERFORM S004-QUARTER THRU S004-EXIT                      DTSCS1D
00815          IF L004-VALID-QTR                                        DTSCS1D
00816              MOVE L004-QTR-3-YR-X TO MAP-ARCHIVED-AUDIT-YR        DTSCS1D
00817              MOVE L004-QTR-3-Q-X  TO MAP-ARCHIVED-AUDIT-Q         DTSCS1D
00818          ELSE                                                     DTSCS1D
00819              GO TO S899-ABEND.                                    DTSCS1D
00820  P6910-EXIT. EXIT.                                                DTSCS1D
00821      SKIP3                                                        DTSCS1D
00822 /*****************************************************************DTSCS1D
00823 * MOVE FIELDS FROM THE MFAE RECORD AND FORMAT ON SCREEN          *DTSCS1D
00824 ******************************************************************DTSCS1D
00825  P6920-FROM-MFAE.                                                 DTSCS1D
00826      MOVE LOW-VALUES    TO MFAE-KEY-AREA.                         DTSCS1D
00827      MOVE MPRF-EMP-NO   TO MFAE-EMP-NO.                           DTSCS1D
00828      SET MFAE-FAE-88    TO TRUE.                                  DTSCS1D
00829      MOVE MFAE-KEY-AREA TO MSKL-KEY-AREA.                         DTSCS1D
00830      PERFORM S810-START-BROWSE THRU S810-EXIT.                    DTSCS1D
00831      IF L810-NO-REC-88                                            DTSCS1D
00832         GO TO P6920-EXIT                                          DTSCS1D
00833      ELSE                                                         DTSCS1D
00834         PERFORM P6921-SCAN-MFAE THRU P6921-EXIT                   DTSCS1D
00835         UNTIL L810-NO-REC-88.                                     DTSCS1D
00836  P6920-EXIT. EXIT.                                                DTSCS1D
00837      SKIP3                                                        DTSCS1D
00838  P6921-SCAN-MFAE.                                                 DTSCS1D
00839      MOVE MSKL-REC             TO MFAE-REC.                       DTSCS1D
00840      MOVE LOW-VALUES           TO FFIS-KEY-AREA.                  DTSCS1D
00841      MOVE MFAE-FISCAL-AGENT-CD TO FFIS-FISCAL-AGENT-CD.           DTSCS1D
00842      MOVE MFAE-SERVICE-TYPE    TO FFIS-SERVICE-TYPE.              DTSCS1D
00843      SET FFIS-FIS-88           TO TRUE.                           DTSCS1D
00844      MOVE FFIS-KEY-AREA        TO FSKL-KEY-AREA.                  DTSCS1D
00845                                                                   DTSCS1D
00846      PERFORM S831-READ         THRU S831-EXIT.                    DTSCS1D
00847                                                                   DTSCS1D
00848      IF NOT L831-OK-88                                            DTSCS1D
00849         MOVE SPACES TO WRK-FISCAL-AGENT-NAME                      DTSCS1D
00850      ELSE                                                         DTSCS1D
00851         MOVE FSKL-REC          TO FFIS-REC                        DTSCS1D
00852         MOVE FFIS-NAME         TO WRK-FISCAL-AGENT-NAME           DTSCS1D
00853      END-IF.                                                      DTSCS1D
00854                                                                   DTSCS1D
00855      IF FFIS-SERVICE-UC30-88                                      DTSCS1D
00856         MOVE FFIS-FISCAL-AGENT-CD  TO MAP-FA-QTLY-RPT-CD          DTSCS1D
00857         MOVE WRK-FISCAL-AGENT-NAME TO MAP-FA-QTLY-RPT-NAME        DTSCS1D
00858      ELSE                                                         DTSCS1D
00859        IF FFIS-SERVICE-BEN-CHG-88                                 DTSCS1D
00860           MOVE FFIS-FISCAL-AGENT-CD  TO MAP-FA-BENF-CHG-CD        DTSCS1D
00861           MOVE WRK-FISCAL-AGENT-NAME TO MAP-FA-BENF-CHG-NAME      DTSCS1D
00862        ELSE                                                       DTSCS1D
00863          IF FFIS-SERVICE-CORRESPOND-88                            DTSCS1D
00864             MOVE FFIS-FISCAL-AGENT-CD  TO MAP-FA-ADDR-REC-CD      DTSCS1D
00865             MOVE WRK-FISCAL-AGENT-NAME TO MAP-FA-ADDR-REC-NAME    DTSCS1D
00866          END-IF                                                   DTSCS1D
00867        END-IF                                                     DTSCS1D
00868       END-IF.                                                     DTSCS1D
00869                                                                   DTSCS1D
00870       PERFORM S810-READ-NEXT THRU S810-EXIT.                      DTSCS1D
00871                                                                   DTSCS1D
00872  P6921-EXIT. EXIT.                                                DTSCS1D
00873      SKIP3                                                        DTSCS1D
00874 /*****************************************************************DTSCS1D
00875 * FUNCTION KEY TO ADD, MOD OR DEL THE RECORD WAS PRESSED.        *DTSCS1D
00876 ******************************************************************DTSCS1D
00877      SKIP1                                                        DTSCS1D
00878  P7000-REQUEST-EDIT.                                              DTSCS1D
00879      PERFORM S5200-SET-UPDATE-ATTRB THRU S5200-EXIT.              DTSCS1D
00880      SKIP1                                                        DTSCS1D
00881      IF LCCM-F10-88                                               DTSCS1D
00882         PERFORM P7200-EDIT-MOD THRU P7200-EXIT                    DTSCS1D
00883      ELSE                                                         DTSCS1D
00884         GO TO S899-ABEND.                                         DTSCS1D
00885      SKIP3                                                        DTSCS1D
00886 *------------------------------------------------------           DTSCS1D
00887 *  SCREEN STATUS IS NOT CHANGED IF AN ERROR IS DETECTED.          DTSCS1D
00888 *  IN ORDER TO CONTINUE TO ATTEMPT AN ADD THE SCREEN MUST REMAIN  DTSCS1D
00889 *  IN A 'CLEAR' STATE.  THE SCREEN MUST BE IN 'INQUIRE' STATUS    DTSCS1D
00890 *  IF MOD OR DEL FUNCTIONS ARE BEING REQUESTED.                   DTSCS1D
00891 *------------------------------------------------------           DTSCS1D
00892      SKIP1                                                        DTSCS1D
00893      IF LCCM-MSG                                                  DTSCS1D
00894         NEXT SENTENCE                                             DTSCS1D
00895      ELSE                                                         DTSCS1D
00896         PERFORM S5100-SET-LOCK-ATTRB THRU S5100-EXIT              DTSCS1D
00897         IF LCCM-F10-88                                            DTSCS1D
00898            SET LCCM-SCR-MOD-LOCKED TO TRUE                        DTSCS1D
00899            MOVE PMSG-MOD-CONFIRM TO LCCM-MSG-AREA.                DTSCS1D
00900      SKIP1                                                        DTSCS1D
00901      SET RESP-SEND-MAP TO TRUE.                                   DTSCS1D
00902  P7000-EXIT. EXIT.                                                DTSCS1D
00903 /*****************************************************************DTSCS1D
00904 * MODIFICATION FUNCTION WAS REQUESTED                            *DTSCS1D
00905 ******************************************************************DTSCS1D
00906      SKIP1                                                        DTSCS1D
00907  P7200-EDIT-MOD.                                                  DTSCS1D
00908 *-----------------------------------------------------            DTSCS1D
00909 *    MODIFICATION REQUIRES THAT A RECORD WAS SUCCESSFULLY         DTSCS1D
00910 *    INQUIRED                                                     DTSCS1D
00911 *-----------------------------------------------------            DTSCS1D
00912      IF NOT LCCM-SCR-INQUIRE                                      DTSCS1D
00913         MOVE EMSG-MOD-PRECEDED TO LCCM-MSG-AREA                   DTSCS1D
00914         GO TO P7200-EXIT.                                         DTSCS1D
00915      SKIP3                                                        DTSCS1D
00916 *-----------------------------------------------------            DTSCS1D
00917 *    MAP-EMP-NO MAY NOT BE CHANGED DURING THE MOD                 DTSCS1D
00918 *-----------------------------------------------------            DTSCS1D
00919      PERFORM S1001-SCREEN-KEY-EDITS THRU S1001-EXIT.              DTSCS1D
00920      IF LCCM-MSG                                                  DTSCS1D
00921          GO TO P7200-EXIT.                                        DTSCS1D
00922      SKIP1                                                        DTSCS1D
00923      IF LCCM-EMP-NO  NOT =  WRK-EMP-NO                            DTSCS1D
00924          MOVE EMSG-NO-FIELD-CHANGE-UPDATE TO WRK-MSG-AREA         DTSCS1D
00925          PERFORM S1101-ERROR THRU S1101-EXIT                      DTSCS1D
00926          GO TO P7200-EXIT.                                        DTSCS1D
00927      SKIP1                                                        DTSCS1D
00928      PERFORM S8100-READ-MPRF THRU S8100-EXIT.                     DTSCS1D
00929      IF L810-NO-REC-88                                            DTSCS1D
00930          MOVE EMSG-NO-EMPLOYER TO WRK-MSG-AREA                    DTSCS1D
00931          PERFORM S1101-ERROR THRU S1101-EXIT                      DTSCS1D
00932      ELSE                                                         DTSCS1D
00933          MOVE MSKL-REC       TO MPRF-REC                          DTSCS1D
00934          PERFORM S1002-SCREEN-DATA-EDITS THRU S1002-EXIT.         DTSCS1D
00935  P7200-EXIT. EXIT.                                                DTSCS1D
00936 /*****************************************************************DTSCS1D
00937 * THE UPDATE/ADD/DELETE FUNCTION WAS CONFIRMED OR CANCELED       *DTSCS1D
00938 ******************************************************************DTSCS1D
00939      SKIP1                                                        DTSCS1D
00940  P8000-REQUEST-UPDATE.                                            DTSCS1D
00941      PERFORM S5200-SET-UPDATE-ATTRB THRU S5200-EXIT.              DTSCS1D
00942      SKIP1                                                        DTSCS1D
00943      IF LCCM-SCR-MOD-LOCKED                                       DTSCS1D
00944         PERFORM P8200-MOD THRU P8200-EXIT                         DTSCS1D
00945      ELSE                                                         DTSCS1D
00946         GO TO S899-ABEND.                                         DTSCS1D
00947      SKIP1                                                        DTSCS1D
00948      SET RESP-SEND-MAP TO TRUE.                                   DTSCS1D
00949  P8000-EXIT. EXIT.                                                DTSCS1D
00950 /*****************************************************************DTSCS1D
00951 * IF ENTER OR CANCEL, MODULE IS SET TO INQUIRY REGARDLESS        *DTSCS1D
00952 ******************************************************************DTSCS1D
00953      SKIP1                                                        DTSCS1D
00954  P8200-MOD.                                                       DTSCS1D
00955      SET LCCM-SCR-INQUIRE TO TRUE.                                DTSCS1D
00956      SKIP1                                                        DTSCS1D
00957      IF LCCM-F12-88                                               DTSCS1D
00958         MOVE PMSG-MOD-CANCELED        TO LCCM-MSG-AREA            DTSCS1D
00959         GO TO P8200-EXIT.                                         DTSCS1D
00960      SKIP1                                                        DTSCS1D
00961      PERFORM S1001-SCREEN-KEY-EDITS THRU S1001-EXIT.              DTSCS1D
00962      IF LCCM-MSG                                                  DTSCS1D
00963          GO TO P8200-EXIT.                                        DTSCS1D
00964      SKIP1                                                        DTSCS1D
00965      MOVE 'M' TO L221-UPDATE-FUNCTION.                            DTSCS1D
00966      PERFORM P8800-LOCK-EMPLOYER THRU P8800-EXIT.                 DTSCS1D
00967      IF LCCM-MSG                                                  DTSCS1D
00968          GO TO P8200-EXIT.                                        DTSCS1D
00969                                                                   DTSCS1D
00970      PERFORM P8900-INITILIZE-L331 THRU P8900-EXIT.                DTSCS1D
00971      SET  WRK-UPD-MSOL-NO-88      TO TRUE.                        DTSCS1D
00972      SET  WRK-RET-MAIL-NULL-88    TO TRUE.                        DTSCS1D
00973      PERFORM P8910-MPRF-UPDATE THRU P8910-EXIT.                   DTSCS1D
00974      IF WRK-UPD-MSOL-YES-88                                       DTSCS1D
00975         PERFORM P8920-UPD-MSOL THRU P8920-EXIT.                   DTSCS1D
00976      IF WRK-RET-MAIL-ON-88                                        DTSCS1D
00977      OR WRK-RET-MAIL-OFF-88                                       DTSCS1D
00978         PERFORM P8930-ADD-MEVL  THRU P8930-EXIT.                  DTSCS1D
00979      PERFORM S221-EMP-UNLOCK THRU S221-EXIT.                      DTSCS1D
00980      SKIP1                                                        DTSCS1D
00981      MOVE PMSG-MOD-SUCCESSFUL TO LCCM-MSG-AREA.                   DTSCS1D
00982      MOVE L221-UPDATE-END-ABSTIME TO LCCM-SCR-ABSTIME.            DTSCS1D
00983  P8200-EXIT. EXIT.                                                DTSCS1D
00984      SKIP3                                                        DTSCS1D
00985                                                                   DTSCS1D
00986 ******************************************************************DTSCS1D
00987 *                                                                *DTSCS1D
00988 ******************************************************************DTSCS1D
00989  P8800-LOCK-EMPLOYER.                                             DTSCS1D
00990      MOVE WRK-EMP-NO TO L221-EMP-NO.                              DTSCS1D
00991      MOVE LCCM-SCR-ABSTIME TO L221-SCR-ABSTIME.                   DTSCS1D
00992      MOVE LCCM-TASK-ID TO L221-UPDATE-TASK-ID.                    DTSCS1D
00993      MOVE LCCM-OP-ID TO L221-UPDATE-OP-ID.                        DTSCS1D
00994      MOVE LCCM-CICS-TERM-ID TO L221-UPDATE-TERMID.                DTSCS1D
00995      MOVE LCCM-TASK-NETNAME TO L221-UPDATE-NETNAME.               DTSCS1D
00996      MOVE LCCM-TASK-START-DATE TO L221-UPDATE-START-DATE.         DTSCS1D
00997      MOVE LCCM-TASK-START-TIME TO L221-UPDATE-START-TIME.         DTSCS1D
00998      MOVE WRK-SCR-ID TO L221-UPDATE-SCR-ID.                       DTSCS1D
00999      SKIP1                                                        DTSCS1D
01000      PERFORM S221-EMP-LOCK THRU S221-EXIT.                        DTSCS1D
01001  P8800-EXIT. EXIT.                                                DTSCS1D
01002 /*****************************************************************DTSCS1D
01003 * INITILIZE MODIFICATION LOG DATA AREA                           *DTSCS1D
01004 ******************************************************************DTSCS1D
01005  P8900-INITILIZE-L331.                                            DTSCS1D
01006        MOVE WRK-EMP-NO TO L331-EMP-NO.                            DTSCS1D
01007                                                                   DTSCS1D
01008        MOVE LCCM-CURR-RUN-DATE TO L331-CURR-RUN-DATE.             DTSCS1D
01009                                                                   DTSCS1D
01010        MOVE LCCM-TASK-START-ABSTIME TO L331-UPDATE-ABSTIME.       DTSCS1D
01011                                                                   DTSCS1D
01012        MOVE LCCM-OP-ID   TO L331-OP-ID.                           DTSCS1D
01013                                                                   DTSCS1D
01014  P8900-EXIT.                                                      DTSCS1D
01015        EXIT.                                                      DTSCS1D
01016 /*****************************************************************DTSCS1D
01017 * MOVE ALL NON-KEY SCREEN FIELDS TO MPRF RECORD LAYOUT           *DTSCS1D
01018 ******************************************************************DTSCS1D
01019  P8910-MPRF-UPDATE.                                               DTSCS1D
01020      PERFORM S8100-READ-MPRF THRU S8100-EXIT.                     DTSCS1D
01021      IF L810-NO-REC-88                                            DTSCS1D
01022          GO TO S899-ABEND.                                        DTSCS1D
01023      SKIP1                                                        DTSCS1D
01024      MOVE MSKL-REC       TO MPRF-REC.                             DTSCS1D
01025      MOVE SPACES TO L331-REC-OCC-ID.                              DTSCS1D
01026      SKIP1                                                        DTSCS1D
01027      IF MAP-UC30-MASS-MAIL-IND NOT =  MPRF-UC30-MASS-MAIL-IND     DTSCS1D
01028          MOVE 'MPRF-UC30-MASS-MAIL-IND' TO L331-FIELD-NAME        DTSCS1D
01029          MOVE MPRF-UC30-MASS-MAIL-IND TO L331-FROM-VALUE          DTSCS1D
01030          MOVE MAP-UC30-MASS-MAIL-IND TO L331-TO-VALUE             DTSCS1D
01031          PERFORM S331-EMP-WRITE-MLOG THRU S331-EXIT               DTSCS1D
01032          MOVE MAP-UC30-MASS-MAIL-IND TO MPRF-UC30-MASS-MAIL-IND   DTSCS1D
01033          MOVE LCCM-CURR-RUN-DATE TO MPRF-CHNG-DATE.               DTSCS1D
01034      SKIP1                                                        DTSCS1D
01035      IF MAP-RETURN-MAIL-IND NOT =     MPRF-RETURN-MAIL-IND        DTSCS1D
01036          IF MPRF-RETURN-MAIL-NO-88                                DTSCS1D
01037             SET WRK-RET-MAIL-ON-88      TO TRUE                   DTSCS1D
01038          ELSE                                                     DTSCS1D
01039             SET WRK-RET-MAIL-OFF-88     TO TRUE                   DTSCS1D
01040          END-IF                                                   DTSCS1D
01041          MOVE 'MPRF-RETURN-MAIL-IND' TO L331-FIELD-NAME           DTSCS1D
01042          MOVE MPRF-RETURN-MAIL-IND TO L331-FROM-VALUE             DTSCS1D
01043          MOVE MAP-RETURN-MAIL-IND TO L331-TO-VALUE                DTSCS1D
01044          PERFORM S331-EMP-WRITE-MLOG THRU S331-EXIT               DTSCS1D
01045          MOVE MAP-RETURN-MAIL-IND TO MPRF-RETURN-MAIL-IND         DTSCS1D
01046          MOVE LCCM-CURR-RUN-DATE TO MPRF-CHNG-DATE.               DTSCS1D
01047      SKIP1                                                        DTSCS1D
01048      IF MAP-UC30-CREDIT-IND NOT =  MPRF-UC30-CREDIT-IND           DTSCS1D
01049          MOVE 'MPRF-UC30-CREDIT-IND' TO L331-FIELD-NAME           DTSCS1D
01050          MOVE MPRF-UC30-CREDIT-IND TO L331-FROM-VALUE             DTSCS1D
01051          MOVE MAP-UC30-CREDIT-IND TO L331-TO-VALUE                DTSCS1D
01052          PERFORM S331-EMP-WRITE-MLOG THRU S331-EXIT               DTSCS1D
01053          MOVE MAP-UC30-CREDIT-IND TO MPRF-UC30-CREDIT-IND         DTSCS1D
01054          MOVE LCCM-CURR-RUN-DATE TO MPRF-CHNG-DATE.               DTSCS1D
01055      SKIP1                                                        DTSCS1D
01056      IF MAP-FEIN-HARASS-IND NOT = MPRF-FEIN-HARASS-IND            DTSCS1D
01057          MOVE MAP-FEIN-HARASS-IND TO MPRF-FEIN-HARASS-IND         DTSCS1D
01058          MOVE LCCM-CURR-RUN-DATE TO MPRF-CHNG-DATE.               DTSCS1D
01059      SKIP1                                                        DTSCS1D
01060      IF MAP-CHRG-STMT-PRINT-IND NOT = MPRF-CHRG-STMT-PRINT-IND    DTSCS1D
01061          MOVE MAP-CHRG-STMT-PRINT-IND                             DTSCS1D
01062            TO MPRF-CHRG-STMT-PRINT-IND                            DTSCS1D
01063          MOVE LCCM-CURR-RUN-DATE TO MPRF-CHNG-DATE.               DTSCS1D
01064      SKIP1                                                        DTSCS1D
01065      IF MAP-ORG-TYPE  NOT =  MPRF-ORG-TYPE                        DTSCS1D
01066          PERFORM P8911-HOUSEHOLD  THRU P8911-EXIT                 DTSCS1D
01067          MOVE 'MPRF-ORG-TYPE' TO L331-FIELD-NAME                  DTSCS1D
01068          MOVE MPRF-ORG-TYPE TO L331-FROM-VALUE                    DTSCS1D
01069          MOVE MAP-ORG-TYPE TO L331-TO-VALUE                       DTSCS1D
01070          PERFORM S331-EMP-WRITE-MLOG THRU S331-EXIT               DTSCS1D
01071          MOVE MAP-ORG-TYPE TO MPRF-ORG-TYPE                       DTSCS1D
01072          MOVE LCCM-CURR-RUN-DATE TO MPRF-CHNG-DATE.               DTSCS1D
01073      SKIP1                                                        DTSCS1D
01074      MOVE MAP-FEIN-AREA TO L017-S-FEIN-AREA.                      DTSCS1D
01075      PERFORM S017-FEIN-FROM-SCREEN THRU S017-EXIT.                DTSCS1D
01076      IF L017-FEIN = MPRF-FEIN                                     DTSCS1D
01077          NEXT SENTENCE                                            DTSCS1D
01078      ELSE                                                         DTSCS1D
01079          MOVE 'MPRF-FEIN' TO L331-FIELD-NAME                      DTSCS1D
01080          MOVE SPACES TO L331-TO-VALUE                             DTSCS1D
01081                         L331-FROM-VALUE                           DTSCS1D
01082          IF MPRF-FEIN NOT = +0                                    DTSCS1D
01083              MOVE MPRF-FEIN TO WRK-DISPLAY                        DTSCS1D
01084              STRING WRK-DISPLAY-FEIN-1 DELIMITED BY SIZE          DTSCS1D
01085                     ' '                DELIMITED BY SIZE          DTSCS1D
01086                     WRK-DISPLAY-FEIN-2 DELIMITED BY SIZE          DTSCS1D
01087                  INTO L331-FROM-VALUE                             DTSCS1D
01088          END-IF                                                   DTSCS1D
01089          IF L017-FEIN NOT = +0                                    DTSCS1D
01090              MOVE L017-FEIN TO WRK-DISPLAY                        DTSCS1D
01091              STRING WRK-DISPLAY-FEIN-1 DELIMITED BY SIZE          DTSCS1D
01092                     ' '                DELIMITED BY SIZE          DTSCS1D
01093                     WRK-DISPLAY-FEIN-2 DELIMITED BY SIZE          DTSCS1D
01094                  INTO L331-TO-VALUE                               DTSCS1D
01095          END-IF                                                   DTSCS1D
01096          PERFORM S331-EMP-WRITE-MLOG THRU S331-EXIT               DTSCS1D
01097          MOVE L017-FEIN TO MPRF-FEIN                              DTSCS1D
01098          MOVE LCCM-CURR-RUN-DATE TO MPRF-CHNG-DATE.               DTSCS1D
01099      SKIP1                                                        DTSCS1D
01100      IF MPRF-PWR-OF-ATTORNEY-DT NOT NUMERIC                       DTSCS1D
01101         MOVE ZERO TO MPRF-PWR-OF-ATTORNEY-DT                      DTSCS1D
01102      END-IF.                                                      DTSCS1D
01103      MOVE MAP-PWR-OF-ATTORNEY-AREA         TO L015-S-DATE-AREA    DTSCS1D
01104      IF L015-S-MO = '99'                                          DTSCS1D
01105         PERFORM P8912-CLEAR-PWR-OF-ATTRNY  THRU P8912-EXIT        DTSCS1D
01106      ELSE                                                         DTSCS1D
01107        PERFORM S015-DATE-FROM-SCREEN         THRU S015-EXIT       DTSCS1D
01108        IF L015-VALID                                              DTSCS1D
01109          IF L015-DATE NOT = MPRF-PWR-OF-ATTORNEY-DT               DTSCS1D
01110             MOVE 'MPRF-PWR-OF-ATTORNEY-DT' TO L331-FIELD-NAME     DTSCS1D
01111             MOVE MPRF-PWR-OF-ATTORNEY-DT   TO L001-FED-8-DATE-9   DTSCS1D
01112             PERFORM S001-FROM-FED-8        THRU S001-EXIT         DTSCS1D
01113             MOVE L001-SLASH-DATE           TO L331-FROM-VALUE     DTSCS1D
01114             MOVE L015-DATE                 TO L001-FED-8-DATE-9   DTSCS1D
01115             PERFORM S001-FROM-FED-8        THRU S001-EXIT         DTSCS1D
01116             MOVE L001-SLASH-DATE           TO L331-TO-VALUE       DTSCS1D
01117             PERFORM S331-EMP-WRITE-MLOG    THRU S331-EXIT         DTSCS1D
01118             MOVE L015-DATE             TO MPRF-PWR-OF-ATTORNEY-DT DTSCS1D
01119             MOVE LCCM-CURR-RUN-DATE        TO MPRF-CHNG-DATE      DTSCS1D
01120          END-IF                                                   DTSCS1D
01121        END-IF                                                     DTSCS1D
01122      END-IF.                                                      DTSCS1D
01123      SKIP1                                                        DTSCS1D
01124      IF MAP-DC-CONTRACTOR-IND NOT = MPRF-DC-CONTRACTOR-IND        DTSCS1D
01125          MOVE 'MPRF-DC-CONTRACTOR-IND' TO L331-FIELD-NAME         DTSCS1D
01126          MOVE MPRF-DC-CONTRACTOR-IND TO L331-FROM-VALUE           DTSCS1D
01127          MOVE MAP-DC-CONTRACTOR-IND TO L331-TO-VALUE              DTSCS1D
01128          PERFORM S331-EMP-WRITE-MLOG THRU S331-EXIT               DTSCS1D
01129          MOVE MAP-DC-CONTRACTOR-IND TO MPRF-DC-CONTRACTOR-IND     DTSCS1D
01130          MOVE LCCM-CURR-RUN-DATE TO MPRF-CHNG-DATE.               DTSCS1D
01131      SKIP1                                                        DTSCS1D
01132      MOVE MAP-ARCHIVED-AUDIT-YRQ-AREA TO L016-S-YRQ-AREA.         DTSCS1D
01133      PERFORM S016-YRQ-FROM-SCREEN THRU S016-EXIT.                 DTSCS1D
01134      IF L016-YRQ NOT = MPRF-ARCHIVED-AUDIT-YRQ                    DTSCS1D
01135          MOVE L016-YRQ TO MPRF-ARCHIVED-AUDIT-YRQ                 DTSCS1D
01136          MOVE L016-YRQ TO MPRF-ARCHIVED-AUDIT-YRQ.                DTSCS1D
01137      SKIP1                                                        DTSCS1D
01138      MOVE MPRF-KEY-AREA TO MSKL-KEY-AREA.                         DTSCS1D
01139      MOVE MPRF-REC  TO MSKL-REC.                                  DTSCS1D
01140      PERFORM S810-REWRITE THRU S810-EXIT.                         DTSCS1D
01141  P8910-EXIT. EXIT.                                                DTSCS1D
01142                                                                   DTSCS1D
01143  P8911-HOUSEHOLD.                                                 DTSCS1D
01144      IF MAP-ORG-TYPE  = 'H  '                                     DTSCS1D
01145         NEXT SENTENCE                                             DTSCS1D
01146      ELSE                                                         DTSCS1D
01147         GO TO P8911-EXIT.                                         DTSCS1D
01148                                                                   DTSCS1D
01149      PERFORM S1120-CHECK-MSOL  THRU S1120-EXIT.                   DTSCS1D
01150                                                                   DTSCS1D
01151      IF WRK-MSOL-CNT = ZERO                                       DTSCS1D
01152      OR WRK-START-YRQ = ZERO                                      DTSCS1D
01153 **** OR WRK-LIAB-CD-DOMESTIC-NO-88                                DTSCS1D
01154         MOVE MPRF-ORG-TYPE TO MAP-ORG-TYPE                        DTSCS1D
01155         GO TO P8911-EXIT.                                         DTSCS1D
01156                                                                   DTSCS1D
01157      SET WRK-UPD-MSOL-YES-88     TO TRUE.                         DTSCS1D
01158                                                                   DTSCS1D
01159      SET L400-ORG-TYPE-CHANGE-88 TO TRUE.                         DTSCS1D
01160      MOVE WRK-EMP-NO             TO L400-EMP-NO.                  DTSCS1D
01161      MOVE MSOL-FIRST-LIAB-YRQ    TO L400-FIRST-LIAB-YRQ.          DTSCS1D
01162      MOVE LCCM-CURR-RUN-DATE     TO L400-CURR-RUN-DATE.           DTSCS1D
01163      MOVE LCCM-OP-ID             TO L400-OP-ID.                   DTSCS1D
01164      PERFORM S400-HOUSEHOLD      THRU S400-EXIT.                  DTSCS1D
01165                                                                   DTSCS1D
01166  P8911-EXIT. EXIT.                                                DTSCS1D
01167                                                                   DTSCS1D
01168  P8912-CLEAR-PWR-OF-ATTRNY.                                       DTSCS1D
01169      MOVE 'MPRF-PWR-OF-ATTORNEY-DT'  TO L331-FIELD-NAME.          DTSCS1D
01170      MOVE MPRF-PWR-OF-ATTORNEY-DT    TO L001-FED-8-DATE-9.        DTSCS1D
01171      PERFORM S001-FROM-FED-8         THRU S001-EXIT.              DTSCS1D
01172      MOVE L001-SLASH-DATE            TO L331-FROM-VALUE.          DTSCS1D
01173      MOVE SPACES                     TO L331-TO-VALUE.            DTSCS1D
01174      PERFORM S331-EMP-WRITE-MLOG     THRU S331-EXIT.              DTSCS1D
01175      MOVE ZERO                       TO MPRF-PWR-OF-ATTORNEY-DT.  DTSCS1D
01176      MOVE LCCM-CURR-RUN-DATE         TO MPRF-CHNG-DATE.           DTSCS1D
01177                                                                   DTSCS1D
01178      MOVE SPACES                     TO MAP-PWR-ATTORNEY-MO       DTSCS1D
01179                                         MAP-PWR-ATTORNEY-DA       DTSCS1D
01180                                         MAP-PWR-ATTORNEY-YR.      DTSCS1D
01181                                                                   DTSCS1D
01182  P8912-EXIT. EXIT.                                                DTSCS1D
01183                                                                   DTSCS1D
01184  P8920-UPD-MSOL.                                                  DTSCS1D
01185      MOVE LOW-VALUES      TO MSOL-KEY-AREA.                       DTSCS1D
01186      MOVE WRK-EMP-NO TO MSOL-EMP-NO.                              DTSCS1D
01187      SET MSOL-SOL-88 TO TRUE.                                     DTSCS1D
01188      MOVE ZEROS TO MSOL-LIAB-DATE.                                DTSCS1D
01189      MOVE MSOL-KEY-AREA TO MSKL-KEY-AREA.                         DTSCS1D
01190      PERFORM S810-START-BROWSE THRU S810-EXIT.                    DTSCS1D
01191                                                                   DTSCS1D
01192      PERFORM P8921-SCAN-MSOL  THRU P8921-EXIT                     DTSCS1D
01193         UNTIL L810-NO-REC-88.                                     DTSCS1D
01194                                                                   DTSCS1D
01195  P8920-EXIT. EXIT.                                                DTSCS1D
01196                                                                   DTSCS1D
01197  P8921-SCAN-MSOL.                                                 DTSCS1D
01198      PERFORM S810-END-BROWSE         THRU S810-EXIT.              DTSCS1D
01199      PERFORM S810-READ               THRU S810-EXIT.              DTSCS1D
01200                                                                   DTSCS1D
01201      MOVE MSKL-REC                   TO MSOL-REC                  DTSCS1D
01202      SET MSOL-LIAB-RATED-DOMESTIC-88 TO TRUE                      DTSCS1D
01203      MOVE MSOL-REC                   TO MSKL-REC                  DTSCS1D
01204      PERFORM S810-REWRITE            THRU S810-EXIT.              DTSCS1D
01205                                                                   DTSCS1D
01206      PERFORM S810-START-BROWSE THRU S810-EXIT.                    DTSCS1D
01207      PERFORM S810-READ-NEXT         THRU S810-EXIT.               DTSCS1D
01208                                                                   DTSCS1D
01209  P8921-EXIT. EXIT.                                                DTSCS1D
01210                                                                   DTSCS1D
01211  P8930-ADD-MEVL.                                                  DTSCS1D
01212      MOVE LOW-VALUES TO MEVL-REC.                                 DTSCS1D
01213                                                                   DTSCS1D
01214      MOVE WRK-EMP-NO TO MEVL-EMP-NO.                              DTSCS1D
01215                                                                   DTSCS1D
01216      SET MEVL-EVL-88 TO TRUE.                                     DTSCS1D
01217                                                                   DTSCS1D
01218      MOVE LCCM-TASK-START-DATE TO MEVL-DATE.                      DTSCS1D
01219                                                                   DTSCS1D
01220      MOVE LCCM-TASK-START-TIME TO MEVL-TIME.                      DTSCS1D
01221                                                                   DTSCS1D
01222      MOVE +0 TO MEVL-PURGE-DATE.                                  DTSCS1D
01223                                                                   DTSCS1D
01224      IF WRK-RET-MAIL-ON-88                                        DTSCS1D
01225         MOVE 'RETURN MAIL SET TO YES ' TO MEVL-TEXT               DTSCS1D
01226      ELSE                                                         DTSCS1D
01227         MOVE 'RETURN MAIL SET TO NO  ' TO MEVL-TEXT               DTSCS1D
01228      END-IF.                                                      DTSCS1D
01229                                                                   DTSCS1D
01230      MOVE LCCM-OP-ID TO MEVL-SOURCE.                              DTSCS1D
01231                                                                   DTSCS1D
01232      SET MEVL-NOT-CONVERTED-88 TO TRUE.                           DTSCS1D
01233                                                                   DTSCS1D
01234      MOVE LCCM-CURR-RUN-DATE TO MEVL-ESTB-DATE                    DTSCS1D
01235                                 MEVL-CHNG-DATE.                   DTSCS1D
01236                                                                   DTSCS1D
01237      MOVE MEVL-REC TO MSKL-REC.                                   DTSCS1D
01238                                                                   DTSCS1D
01239      PERFORM S810-WRITE THRU S810-EXIT.                           DTSCS1D
01240                                                                   DTSCS1D
01241  P8930-EXIT. EXIT.                                                DTSCS1D
01242                                                                   DTSCS1D
01243 /*****************************************************************DTSCS1D
01244 * LINKS TO UTILITY MODULES                                        DTSCS1D
01245 ******************************************************************DTSCS1D
01246      SKIP1                                                        DTSCS1D
01247  S001-FROM-FED-8.                                                 DTSCS1D
01248      SET L001-FROM-FED-8 TO TRUE.                                 DTSCS1D
01249      GO TO S001-DATE.                                             DTSCS1D
01250                                                                   DTSCS1D
01251  S001-DATE.                                                       DTSCS1D
01252      EXEC CICS LINK                                               DTSCS1D
01253          PROGRAM('DTSCU001')                                      DTSCS1D
01254          COMMAREA(L001-COMM-AREA)                                 DTSCS1D
01255      END-EXEC.                                                    DTSCS1D
01256  S001-EXIT.                                                       DTSCS1D
01257      EXIT.                                                        DTSCS1D
01258                                                                   DTSCS1D
01259  S004-QUARTER.                                                    DTSCS1D
01260      EXEC CICS LINK                                               DTSCS1D
01261          PROGRAM  ('DTSCU004')                                    DTSCS1D
01262          COMMAREA (L004-COMM-AREA)                                DTSCS1D
01263      END-EXEC.                                                    DTSCS1D
01264  S004-EXIT.                                                       DTSCS1D
01265      EXIT.                                                        DTSCS1D
01266      SKIP3                                                        DTSCS1D
01267  S015-DATE-FROM-SCREEN.                                           DTSCS1D
01268      EXEC CICS LINK                                               DTSCS1D
01269          PROGRAM('DTSCU015')                                      DTSCS1D
01270          COMMAREA(L015-COMM-AREA)                                 DTSCS1D
01271      END-EXEC.                                                    DTSCS1D
01272  S015-EXIT.                                                       DTSCS1D
01273      EXIT.                                                        DTSCS1D
01274                                                                   DTSCS1D
01275  S016-YRQ-FROM-SCREEN.                                            DTSCS1D
01276      EXEC CICS LINK                                               DTSCS1D
01277          PROGRAM  ('DTSCU016')                                    DTSCS1D
01278          COMMAREA (L016-COMM-AREA)                                DTSCS1D
01279      END-EXEC.                                                    DTSCS1D
01280  S016-EXIT.                                                       DTSCS1D
01281      EXIT.                                                        DTSCS1D
01282      SKIP3                                                        DTSCS1D
01283  S017-FEIN-FROM-SCREEN.                                           DTSCS1D
01284      EXEC CICS LINK                                               DTSCS1D
01285          PROGRAM  ('DTSCU017')                                    DTSCS1D
01286          COMMAREA (L017-COMM-AREA)                                DTSCS1D
01287      END-EXEC.                                                    DTSCS1D
01288  S017-EXIT.                                                       DTSCS1D
01289      EXIT.                                                        DTSCS1D
01290      SKIP3                                                        DTSCS1D
01291  S018-EMP-NO-FROM-SCREEN.                                         DTSCS1D
01292      EXEC CICS LINK                                               DTSCS1D
01293          PROGRAM  ('DTSCU018')                                    DTSCS1D
01294          COMMAREA (L018-COMM-AREA)                                DTSCS1D
01295      END-EXEC.                                                    DTSCS1D
01296  S018-EXIT.                                                       DTSCS1D
01297      EXIT.                                                        DTSCS1D
01298      SKIP3                                                        DTSCS1D
01299 *S027-BTN-FROM-SCREEN.                                            DTSCS1D
01300 *    EXEC CICS LINK                                               DTSCS1D
01301 *        PROGRAM  ('DTSCU027')                                    DTSCS1D
01302 *        COMMAREA (L027-COMM-AREA)                                DTSCS1D
01303 *    END-EXEC.                                                    DTSCS1D
01304 *S027-EXIT.                                                       DTSCS1D
01305 *    EXIT.                                                        DTSCS1D
01306      SKIP3                                                        DTSCS1D
01307  S031-REG-CODES.                                                  DTSCS1D
01308      EXEC CICS LINK                                               DTSCS1D
01309          PROGRAM  ('DTSCU031')                                    DTSCS1D
01310          COMMAREA (L031-COMM-AREA)                                DTSCS1D
01311      END-EXEC.                                                    DTSCS1D
01312  S031-EXIT.                                                       DTSCS1D
01313      EXIT.                                                        DTSCS1D
01314      SKIP3                                                        DTSCS1D
01315 *S039-SIC-OWN-CD.                                                 DTSCS1D
01316 *****EXEC CICS LINK                                               DTSCS1D
01317 *********PROGRAM  ('DTSCU039')                                    DTSCS1D
01318 *********COMMAREA (L039-COMM-AREA)                                DTSCS1D
01319 *****END-EXEC.                                                    DTSCS1D
01320                                                                   DTSCS1D
01321 *****IF L039-SIC-FILE-CLOSED                                      DTSCS1D
01322 *********MOVE L039-MSG-AREA TO LCCM-MSG-AREA                      DTSCS1D
01323 *********SET LCCM-REQ-SCR-SF-88 TO TRUE                           DTSCS1D
01324 *********SET LCCM-LINK-SCREEN-88 TO TRUE                          DTSCS1D
01325 *********GO TO MAINLINE-EXIT.                                     DTSCS1D
01326 *S039-EXIT.                                                       DTSCS1D
01327 *****EXIT.                                                        DTSCS1D
01328      SKIP3                                                        DTSCS1D
01329  S074-DUP-FEIN-EDIT.                                              DTSCS1D
01330      EXEC CICS LINK                                               DTSCS1D
01331          PROGRAM  ('DTSCU074')                                    DTSCS1D
01332          COMMAREA (L074-COMM-AREA)                                DTSCS1D
01333      END-EXEC.                                                    DTSCS1D
01334      SKIP1                                                        DTSCS1D
01335      IF L074-FILE-CLOSED-88                                       DTSCS1D
01336          MOVE L074-MSG-AREA TO LCCM-MSG-AREA                      DTSCS1D
01337          SET LCCM-REQ-SCR-SF-88 TO TRUE                           DTSCS1D
01338          SET LCCM-LINK-SCREEN-88 TO TRUE                          DTSCS1D
01339          GO TO MAINLINE-EXIT.                                     DTSCS1D
01340  S074-EXIT.                                                       DTSCS1D
01341      EXIT.                                                        DTSCS1D
01342      SKIP3                                                        DTSCS1D
01343  S221-EMP-LOCK.                                                   DTSCS1D
01344      SET L221-START-UPDATE TO TRUE.                               DTSCS1D
01345      GO TO S221-EMP-LOCK-UNLOCK.                                  DTSCS1D
01346      SKIP1                                                        DTSCS1D
01347  S221-EMP-UNLOCK.                                                 DTSCS1D
01348      SET L221-END-UPDATE TO TRUE.                                 DTSCS1D
01349      GO TO S221-EMP-LOCK-UNLOCK.                                  DTSCS1D
01350      SKIP1                                                        DTSCS1D
01351  S221-EMP-LOCK-UNLOCK.                                            DTSCS1D
01352      EXEC CICS LINK                                               DTSCS1D
01353          PROGRAM  ('DTSCU221')                                    DTSCS1D
01354          COMMAREA (L221-COMM-AREA)                                DTSCS1D
01355      END-EXEC.                                                    DTSCS1D
01356      SKIP1                                                        DTSCS1D
01357      IF L221-FILE-CLOSED                                          DTSCS1D
01358          MOVE L221-MSG-AREA TO LCCM-MSG-AREA                      DTSCS1D
01359          SET LCCM-REQ-SCR-SF-88 TO TRUE                           DTSCS1D
01360          SET LCCM-LINK-SCREEN-88 TO TRUE                          DTSCS1D
01361          GO TO MAINLINE-EXIT.                                     DTSCS1D
01362      SKIP1                                                        DTSCS1D
01363      IF L221-NOT-OK                                               DTSCS1D
01364          MOVE L221-MSG-AREA TO LCCM-MSG-AREA.                     DTSCS1D
01365  S221-EXIT.                                                       DTSCS1D
01366      EXIT.                                                        DTSCS1D
01367      SKIP3                                                        DTSCS1D
01368  S331-EMP-WRITE-MLOG.                                             DTSCS1D
01369      EXEC CICS LINK                                               DTSCS1D
01370          PROGRAM  ('DTSCU331')                                    DTSCS1D
01371          COMMAREA (L331-COMM-AREA)                                DTSCS1D
01372      END-EXEC.                                                    DTSCS1D
01373      SKIP1                                                        DTSCS1D
01374      IF L331-FILE-CLOSED                                          DTSCS1D
01375          MOVE L331-MSG-AREA TO LCCM-MSG-AREA                      DTSCS1D
01376          SET LCCM-REQ-SCR-SF-88 TO TRUE                           DTSCS1D
01377          SET LCCM-LINK-SCREEN-88 TO TRUE                          DTSCS1D
01378          GO TO MAINLINE-EXIT.                                     DTSCS1D
01379  S331-EXIT.                                                       DTSCS1D
01380      EXIT.                                                        DTSCS1D
01381      SKIP3                                                        DTSCS1D
01382  S400-HOUSEHOLD.                                                  DTSCS1D
01383      EXEC CICS LINK                                               DTSCS1D
01384          PROGRAM  ('DTSCU400')                                    DTSCS1D
01385          COMMAREA (L400-COMM-AREA)                                DTSCS1D
01386      END-EXEC.                                                    DTSCS1D
01387      SKIP1                                                        DTSCS1D
01388  S400-EXIT.                                                       DTSCS1D
01389      EXIT.                                                        DTSCS1D
01390      SKIP3                                                        DTSCS1D
01391  S803-REQ-SCR-ID-EDIT.                                            DTSCS1D
01392      EXEC CICS LINK                                               DTSCS1D
01393          PROGRAM  ('DTSCU803')                                    DTSCS1D
01394          COMMAREA (DFHCOMMAREA)                                   DTSCS1D
01395      END-EXEC.                                                    DTSCS1D
01396  S803-EXIT.                                                       DTSCS1D
01397      EXIT.                                                        DTSCS1D
01398      SKIP3                                                        DTSCS1D
01399  S804-INVALID-KEY.                                                DTSCS1D
01400      EXEC CICS LINK                                               DTSCS1D
01401          PROGRAM  ('DTSCU804')                                    DTSCS1D
01402          COMMAREA (DFHCOMMAREA)                                   DTSCS1D
01403      END-EXEC.                                                    DTSCS1D
01404  S804-EXIT.                                                       DTSCS1D
01405      EXIT.                                                        DTSCS1D
01406      SKIP3                                                        DTSCS1D
01407  S805-MSG-AREA.                                                   DTSCS1D
01408      MOVE LCCM-MSG-AREA TO L805-MSG-AREA                          DTSCS1D
01409      SKIP1                                                        DTSCS1D
01410      EXEC CICS LINK                                               DTSCS1D
01411          PROGRAM  ('DTSCU805')                                    DTSCS1D
01412          COMMAREA (L805-COMM-AREA)                                DTSCS1D
01413      END-EXEC.                                                    DTSCS1D
01414      SKIP1                                                        DTSCS1D
01415      MOVE L805-S-MSG-AREA TO MAP-MSG-AREA.                        DTSCS1D
01416  S805-EXIT.                                                       DTSCS1D
01417      EXIT.                                                        DTSCS1D
01418      EJECT                                                        DTSCS1D
01419  S810-READ.                                                       DTSCS1D
01420      SET L810-READ-88 TO TRUE.                                    DTSCS1D
01421      GO TO S810-IO.                                               DTSCS1D
01422      SKIP1                                                        DTSCS1D
01423  S810-START-BROWSE.                                               DTSCS1D
01424      SET L810-START-BROWSE-88 TO TRUE.                            DTSCS1D
01425      GO TO S810-IO.                                               DTSCS1D
01426      SKIP1                                                        DTSCS1D
01427  S810-READ-NEXT.                                                  DTSCS1D
01428      SET L810-READ-NEXT-88 TO TRUE.                               DTSCS1D
01429      GO TO S810-IO.                                               DTSCS1D
01430      SKIP1                                                        DTSCS1D
01431  S810-END-BROWSE.                                                 DTSCS1D
01432      SET L810-END-BROWSE-88 TO TRUE.                              DTSCS1D
01433      GO TO S810-IO.                                               DTSCS1D
01434      SKIP1                                                        DTSCS1D
01435  S810-REWRITE.                                                    DTSCS1D
01436      SET L810-REWRITE-88 TO TRUE.                                 DTSCS1D
01437      GO TO S810-IO.                                               DTSCS1D
01438      SKIP1                                                        DTSCS1D
01439  S810-WRITE.                                                      DTSCS1D
01440      SET L810-WRITE-88 TO TRUE.                                   DTSCS1D
01441      GO TO S810-IO.                                               DTSCS1D
01442      SKIP1                                                        DTSCS1D
01443  S810-IO.                                                         DTSCS1D
01444      SKIP1                                                        DTSCS1D
01445      EXEC CICS LINK                                               DTSCS1D
01446          PROGRAM  ('DTSCU810')                                    DTSCS1D
01447          COMMAREA (L810-COMM-AREA)                                DTSCS1D
01448      END-EXEC.                                                    DTSCS1D
01449      SKIP1                                                        DTSCS1D
01450      IF L810-FILE-CLOSED-88                                       DTSCS1D
01451          MOVE L810-MSG-AREA TO LCCM-MSG-AREA                      DTSCS1D
01452          SET LCCM-REQ-SCR-SF-88 TO TRUE                           DTSCS1D
01453          SET LCCM-LINK-SCREEN-88 TO TRUE                          DTSCS1D
01454          GO TO MAINLINE-EXIT.                                     DTSCS1D
01455  S810-EXIT.                                                       DTSCS1D
01456      EXIT.                                                        DTSCS1D
01457      EJECT                                                        DTSCS1D
01458  S831-READ.                                                       DTSCS1D
01459      SET L831-READ-88 TO TRUE.                                    DTSCS1D
01460      SKIP1                                                        DTSCS1D
01461      EXEC CICS LINK                                               DTSCS1D
01462          PROGRAM  ('DTSCU831')                                    DTSCS1D
01463          COMMAREA (L831-COMM-AREA)                                DTSCS1D
01464      END-EXEC.                                                    DTSCS1D
01465      SKIP1                                                        DTSCS1D
01466      IF L831-FILE-CLOSED-88                                       DTSCS1D
01467          MOVE L831-MSG-AREA TO LCCM-MSG-AREA                      DTSCS1D
01468          SET LCCM-REQ-SCR-SF-88 TO TRUE                           DTSCS1D
01469          SET LCCM-LINK-SCREEN-88 TO TRUE                          DTSCS1D
01470          GO TO MAINLINE-EXIT.                                     DTSCS1D
01471  S831-EXIT.                                                       DTSCS1D
01472      EXIT.                                                        DTSCS1D
01473      EJECT                                                        DTSCS1D
01474  S851-SCREEN-PROCESSING.                                          DTSCS1D
01475      EXEC CICS LINK                                               DTSCS1D
01476          PROGRAM  ('DTSCU851')                                    DTSCS1D
01477          COMMAREA (L851-COMM-AREA)                                DTSCS1D
01478      END-EXEC.                                                    DTSCS1D
01479  S851-EXIT.                                                       DTSCS1D
01480      EXIT.                                                        DTSCS1D
01481      SKIP3                                                        DTSCS1D
01482  S899-ABEND.                                                      DTSCS1D
01483      EXEC CICS ABEND                                              DTSCS1D
01484          ABCODE(WRK-ABEND-CD)                                     DTSCS1D
01485      END-EXEC.                                                    DTSCS1D
01486 *S899-EXIT.                                                       DTSCS1D
01487 *    EXIT.                                                        DTSCS1D
01488 /*****************************************************************DTSCS1D
01489 *    EDIT THE INFORMATION ON THE SCREEN.                         *DTSCS1D
01490 ******************************************************************DTSCS1D
01491      SKIP1                                                        DTSCS1D
01492  S1001-SCREEN-KEY-EDITS.                                          DTSCS1D
01493      SKIP1                                                        DTSCS1D
01494      PERFORM S1100-EMP-NO                THRU S1100-EXIT.         DTSCS1D
01495      SKIP1                                                        DTSCS1D
01496  S1001-EXIT. EXIT.                                                DTSCS1D
01497      SKIP3                                                        DTSCS1D
01498  S1002-SCREEN-DATA-EDITS.                                         DTSCS1D
01499      SKIP1                                                        DTSCS1D
01500      PERFORM S1200-INDICATORS            THRU S1200-EXIT.         DTSCS1D
01501      PERFORM S1300-ORG-TYPE              THRU S1300-EXIT.         DTSCS1D
01502      PERFORM S1400-EDIT-PWR-OF-ATTORNEY  THRU S1400-EXIT.         DTSCS1D
01503 ***  PERFORM S1400-EDIT-BTN              THRU S1400-EXIT.         DTSCS1D
01504      PERFORM S1500-FEIN                  THRU S1500-EXIT.         DTSCS1D
01505      PERFORM S1600-AUDITED               THRU S1600-EXIT.         DTSCS1D
01506                                                                   DTSCS1D
01507  S1002-EXIT. EXIT.                                                DTSCS1D
01508 /*****************************************************************DTSCS1D
01509 *  EMP-NO IS THE ONLY KEY FIELD FOR MPRF                         *DTSCS1D
01510 ******************************************************************DTSCS1D
01511  S1100-EMP-NO.                                                    DTSCS1D
01512      MOVE MAP-EMP-NO-AREA TO L018-S-EMP-NO-AREA.                  DTSCS1D
01513      PERFORM S018-EMP-NO-FROM-SCREEN THRU S018-EXIT.              DTSCS1D
01514      SKIP1                                                        DTSCS1D
01515      IF L018-NO-ENTRY                                             DTSCS1D
01516          MOVE EMSG-FIELD-REQUIRED TO WRK-MSG-AREA                 DTSCS1D
01517          PERFORM S1101-ERROR THRU S1101-EXIT                      DTSCS1D
01518      ELSE                                                         DTSCS1D
01519      IF L018-NOT-VALID                                            DTSCS1D
01520          MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA                DTSCS1D
01521          PERFORM S1101-ERROR THRU S1101-EXIT                      DTSCS1D
01522      ELSE                                                         DTSCS1D
01523          MOVE L018-EMP-NO TO WRK-EMP-NO.                          DTSCS1D
01524  S1100-EXIT. EXIT.                                                DTSCS1D
01525      SKIP3                                                        DTSCS1D
01526  S1101-ERROR.                                                     DTSCS1D
01527      MOVE CATB-UNPROT-NORM-NUM-MDTON TO MAP-EMP-NO-1-A            DTSCS1D
01528                                         MAP-EMP-NO-2-A.           DTSCS1D
01529      IF LCCM-NO-MSG                                               DTSCS1D
01530          MOVE WRK-MSG-AREA TO LCCM-MSG-AREA                       DTSCS1D
01531          MOVE CATB-CURSOR TO MAP-EMP-NO-1-L                       DTSCS1D
01532          SET CURSOR-SET-YES TO TRUE.                              DTSCS1D
01533  S1101-EXIT. EXIT.                                                DTSCS1D
01534 /*****************************************************************DTSCS1D
01535 *  SCAN MSOL RECORD IF ORG TYPE CHANGE FOR HOUSEHOLD EMPLOYER    *DTSCS1D
01536 ******************************************************************DTSCS1D
01537  S1120-CHECK-MSOL.                                                DTSCS1D
01538      MOVE ZERO            TO WRK-MSOL-CNT                         DTSCS1D
01539                              WRK-START-YRQ.                       DTSCS1D
01540      SET WRK-LIAB-CD-DOMESTIC-YES-88 TO TRUE.                     DTSCS1D
01541                                                                   DTSCS1D
01542      MOVE LOW-VALUES      TO MSOL-KEY-AREA.                       DTSCS1D
01543      MOVE WRK-EMP-NO TO MSOL-EMP-NO.                              DTSCS1D
01544      SET MSOL-SOL-88 TO TRUE.                                     DTSCS1D
01545      MOVE ZEROS TO MSOL-LIAB-DATE.                                DTSCS1D
01546      MOVE MSOL-KEY-AREA TO MSKL-KEY-AREA.                         DTSCS1D
01547      PERFORM S810-START-BROWSE THRU S810-EXIT.                    DTSCS1D
01548                                                                   DTSCS1D
01549      PERFORM S1121-SCAN-MSOL  THRU S1121-EXIT                     DTSCS1D
01550         UNTIL L810-NO-REC-88.                                     DTSCS1D
01551                                                                   DTSCS1D
01552      PERFORM S810-END-BROWSE   THRU S810-EXIT.                    DTSCS1D
01553                                                                   DTSCS1D
01554  S1120-EXIT. EXIT.                                                DTSCS1D
01555                                                                   DTSCS1D
01556  S1121-SCAN-MSOL.                                                 DTSCS1D
01557      MOVE MSKL-REC                  TO MSOL-REC.                  DTSCS1D
01558                                                                   DTSCS1D
01559      IF MSOL-INACT-WITHDRAWN-88                                   DTSCS1D
01560         NEXT SENTENCE                                             DTSCS1D
01561      ELSE                                                         DTSCS1D
01562         ADD +1                      TO WRK-MSOL-CNT               DTSCS1D
01563         IF MSOL-INACT-ACTIVE-88                                   DTSCS1D
01564            MOVE MSOL-FIRST-LIAB-YRQ TO WRK-START-YRQ              DTSCS1D
01565            IF NOT MSOL-LIAB-RATED-DOMESTIC-88                     DTSCS1D
01566               SET WRK-LIAB-CD-DOMESTIC-NO-88 TO TRUE.             DTSCS1D
01567                                                                   DTSCS1D
01568      PERFORM S810-READ-NEXT         THRU S810-EXIT.               DTSCS1D
01569                                                                   DTSCS1D
01570  S1121-EXIT. EXIT.                                                DTSCS1D
01571 /*****************************************************************DTSCS1D
01572 *                                                                *DTSCS1D
01573 ******************************************************************DTSCS1D
01574  S1200-INDICATORS.                                                DTSCS1D
01575      IF MAP-UC30-MASS-MAIL-IND = SPACE OR LOW-VALUE               DTSCS1D
01576          SET MAP-UC30-MASS-MAIL-YES-88 TO TRUE                    DTSCS1D
01577      ELSE                                                         DTSCS1D
01578          IF NOT MAP-UC30-MASS-MAIL-VALID-88                       DTSCS1D
01579              MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA            DTSCS1D
01580              PERFORM S1201-ERROR THRU S1201-EXIT.                 DTSCS1D
01581      SKIP1                                                        DTSCS1D
01582      IF MAP-UC30-CREDIT-IND = SPACE OR LOW-VALUE                  DTSCS1D
01583          SET MAP-UC30-CREDIT-YES-88 TO TRUE                       DTSCS1D
01584      ELSE                                                         DTSCS1D
01585          IF NOT MAP-UC30-CREDIT-VALID-88                          DTSCS1D
01586              MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA            DTSCS1D
01587              PERFORM S1202-ERROR THRU S1202-EXIT.                 DTSCS1D
01588      SKIP1                                                        DTSCS1D
01589      IF MAP-RETURN-MAIL-IND = SPACE OR LOW-VALUE                  DTSCS1D
01590          SET MAP-RETURN-MAIL-NO-88 TO TRUE                        DTSCS1D
01591      ELSE                                                         DTSCS1D
01592          IF NOT MAP-RETURN-MAIL-VALID-88                          DTSCS1D
01593              MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA            DTSCS1D
01594              PERFORM S1209-ERROR THRU S1209-EXIT.                 DTSCS1D
01595      SKIP1                                                        DTSCS1D
01596      IF MAP-FEIN-HARASS-IND = SPACE OR LOW-VALUE                  DTSCS1D
01597          SET MAP-FEIN-HARASS-YES-88 TO TRUE                       DTSCS1D
01598      ELSE                                                         DTSCS1D
01599          IF NOT MAP-FEIN-HARASS-VALID-88                          DTSCS1D
01600              MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA            DTSCS1D
01601              PERFORM S1206-ERROR THRU S1206-EXIT.                 DTSCS1D
01602      SKIP1                                                        DTSCS1D
01603      IF MAP-CHRG-STMT-PRINT-IND = SPACE OR LOW-VALUE              DTSCS1D
01604          SET MAP-CHRG-STMT-PRINT-YES-88 TO TRUE                   DTSCS1D
01605      ELSE                                                         DTSCS1D
01606          IF MAP-CHRG-STMT-PRINT-YES-88                            DTSCS1D
01607              NEXT SENTENCE                                        DTSCS1D
01608          ELSE                                                     DTSCS1D
01609          IF MAP-CHRG-STMT-PRINT-NO-88                             DTSCS1D
01610              IF  MPRF-CLASS-RATED-88                              DTSCS1D
01611              AND MPRF-STATUS-INACT-88                             DTSCS1D
01612                  NEXT SENTENCE                                    DTSCS1D
01613              ELSE                                                 DTSCS1D
01614                  MOVE EMSG-CROSS-EDIT TO WRK-MSG-AREA             DTSCS1D
01615                  PERFORM S1207-ERROR THRU S1207-EXIT              DTSCS1D
01616          ELSE                                                     DTSCS1D
01617              MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA            DTSCS1D
01618              PERFORM S1207-ERROR THRU S1207-EXIT.                 DTSCS1D
01619      SKIP1                                                        DTSCS1D
01620      IF MAP-DC-CONTRACTOR-IND = SPACES OR LOW-VALUES              DTSCS1D
01621          SET MAP-DC-CONTRACTOR-NO-88 TO TRUE                      DTSCS1D
01622      ELSE                                                         DTSCS1D
01623          IF NOT MAP-DC-CONTRACTOR-VALID-88                        DTSCS1D
01624              MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA            DTSCS1D
01625              PERFORM S1208-ERROR THRU S1208-EXIT.                 DTSCS1D
01626      SKIP1                                                        DTSCS1D
01627  S1200-EXIT. EXIT.                                                DTSCS1D
01628      SKIP3                                                        DTSCS1D
01629  S1201-ERROR.                                                     DTSCS1D
01630      MOVE CATB-UNPROT-NORM-AN-MDTON TO MAP-UC30-MASS-MAIL-IND-A.  DTSCS1D
01631      IF LCCM-NO-MSG                                               DTSCS1D
01632         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01633         MOVE CATB-CURSOR   TO MAP-UC30-MASS-MAIL-IND-L            DTSCS1D
01634         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01635  S1201-EXIT. EXIT.                                                DTSCS1D
01636      SKIP3                                                        DTSCS1D
01637  S1202-ERROR.                                                     DTSCS1D
01638      MOVE CATB-UNPROT-NORM-AN-MDTON TO MAP-UC30-CREDIT-IND-A.     DTSCS1D
01639      IF LCCM-NO-MSG                                               DTSCS1D
01640         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01641         MOVE CATB-CURSOR   TO MAP-UC30-CREDIT-IND-L               DTSCS1D
01642         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01643  S1202-EXIT. EXIT.                                                DTSCS1D
01644      SKIP3                                                        DTSCS1D
01645  S1206-ERROR.                                                     DTSCS1D
01646      MOVE CATB-UNPROT-NORM-AN-MDTON TO MAP-FEIN-HARASS-IND-A.     DTSCS1D
01647      IF LCCM-NO-MSG                                               DTSCS1D
01648         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01649         MOVE CATB-CURSOR   TO MAP-FEIN-HARASS-IND-L               DTSCS1D
01650         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01651  S1206-EXIT. EXIT.                                                DTSCS1D
01652      SKIP3                                                        DTSCS1D
01653  S1207-ERROR.                                                     DTSCS1D
01654      MOVE CATB-UNPROT-NORM-AN-MDTON TO MAP-CHRG-STMT-PRINT-IND-A. DTSCS1D
01655      IF LCCM-NO-MSG                                               DTSCS1D
01656         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01657         MOVE CATB-CURSOR   TO MAP-CHRG-STMT-PRINT-IND-L           DTSCS1D
01658         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01659  S1207-EXIT. EXIT.                                                DTSCS1D
01660  S1208-ERROR.                                                     DTSCS1D
01661      MOVE CATB-UNPROT-NORM-AN-MDTON TO MAP-DC-CONTRACTOR-IND-A.   DTSCS1D
01662      IF LCCM-NO-MSG                                               DTSCS1D
01663         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01664         MOVE CATB-CURSOR   TO MAP-DC-CONTRACTOR-IND-L             DTSCS1D
01665         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01666  S1208-EXIT. EXIT.                                                DTSCS1D
01667  S1209-ERROR.                                                     DTSCS1D
01668      MOVE CATB-UNPROT-NORM-AN-MDTON TO MAP-RETURN-MAIL-IND-A.     DTSCS1D
01669      IF LCCM-NO-MSG                                               DTSCS1D
01670         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01671         MOVE CATB-CURSOR   TO MAP-RETURN-MAIL-IND-L               DTSCS1D
01672         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01673  S1209-EXIT. EXIT.                                                DTSCS1D
01674      SKIP3                                                        DTSCS1D
01675 /*****************************************************************DTSCS1D
01676 *                                                                *DTSCS1D
01677 ******************************************************************DTSCS1D
01678  S1300-ORG-TYPE.                                                  DTSCS1D
01679      IF MAP-ORG-TYPE = SPACE OR LOW-VALUE                         DTSCS1D
01680          SET MAP-ORG-UNK-88 TO TRUE.                              DTSCS1D
01681      SKIP1                                                        DTSCS1D
01682      IF MAP-ORG-UNK-88                                            DTSCS1D
01683          GO TO S1300-EXIT.                                        DTSCS1D
01684      SKIP1                                                        DTSCS1D
01685      IF MAP-ORG-WAS-UNK-88                                        DTSCS1D
01686          MOVE SPACES TO MAP-ORG-TYPE-EXT.                         DTSCS1D
01687      SKIP1                                                        DTSCS1D
01688      MOVE MAP-ORG-TYPE TO L031-CD.                                DTSCS1D
01689      SET L031-MPRF-ORG-TYPE TO TRUE.                              DTSCS1D
01690      PERFORM S031-REG-CODES THRU S031-EXIT.                       DTSCS1D
01691      IF L031-NOT-VALID                                            DTSCS1D
01692          MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA                DTSCS1D
01693          PERFORM S1301-ERROR THRU S1301-EXIT                      DTSCS1D
01694      ELSE                                                         DTSCS1D
01695          IF MAP-ORG-TYPE NOT = MPRF-ORG-TYPE                      DTSCS1D
01696              PERFORM S1310-HOUSEHOLD-EDITS  THRU S1310-EXIT.      DTSCS1D
01697                                                                   DTSCS1D
01698  S1300-EXIT. EXIT.                                                DTSCS1D
01699      SKIP3                                                        DTSCS1D
01700  S1301-ERROR.                                                     DTSCS1D
01701      MOVE CATB-UNPROT-NORM-AN-MDTON TO MAP-ORG-TYPE-A.            DTSCS1D
01702      IF LCCM-NO-MSG                                               DTSCS1D
01703         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01704         MOVE CATB-CURSOR   TO MAP-ORG-TYPE-L                      DTSCS1D
01705         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01706  S1301-EXIT. EXIT.                                                DTSCS1D
01707                                                                   DTSCS1D
01708  S1310-HOUSEHOLD-EDITS.                                           DTSCS1D
01709      IF MPRF-ORG-HSEHLD-DMSTIC-88                                 DTSCS1D
01710      AND MAP-ORG-TYPE NOT = MPRF-ORG-TYPE                         DTSCS1D
01711         MOVE MSG-E1D3-AREA      TO WRK-MSG-AREA                   DTSCS1D
01712         PERFORM S1301-ERROR     THRU S1301-EXIT                   DTSCS1D
01713         GO TO S1310-EXIT.                                         DTSCS1D
01714                                                                   DTSCS1D
01715      IF MAP-ORG-TYPE = 'H  '                                      DTSCS1D
01716         NEXT SENTENCE                                             DTSCS1D
01717      ELSE                                                         DTSCS1D
01718         GO TO S1310-EXIT.                                         DTSCS1D
01719                                                                   DTSCS1D
01720      PERFORM S1120-CHECK-MSOL   THRU S1120-EXIT.                  DTSCS1D
01721                                                                   DTSCS1D
01722      IF WRK-MSOL-CNT = ZERO                                       DTSCS1D
01723      OR WRK-START-YRQ = ZERO                                      DTSCS1D
01724         MOVE MSG-E1D2-AREA      TO WRK-MSG-AREA                   DTSCS1D
01725         PERFORM S1301-ERROR     THRU S1301-EXIT.                  DTSCS1D
01726 **   ELSE                                                         DTSCS1D
01727 **   IF WRK-LIAB-CD-DOMESTIC-NO-88                                DTSCS1D
01728 **      MOVE MSG-E1D1-AREA      TO WRK-MSG-AREA                   DTSCS1D
01729 **      PERFORM S1301-ERROR     THRU S1301-EXIT.                  DTSCS1D
01730                                                                   DTSCS1D
01731  S1310-EXIT. EXIT.                                                DTSCS1D
01732                                                                   DTSCS1D
01733 /*****************************************************************DTSCS1D
01734 *                                                                *DTSCS1D
01735 ******************************************************************DTSCS1D
01736  S1400-EDIT-PWR-OF-ATTORNEY.                                      DTSCS1D
01737      MOVE MAP-PWR-OF-ATTORNEY-AREA  TO L015-S-DATE-AREA.          DTSCS1D
01738 ** IF USER ENTERS NINES, RESET MPRF-PWR-OF-ATTORNEY-DT            DTSCS1D
01739 ** IN MPRF RECORD TO ZERO.                                        DTSCS1D
01740      IF L015-S-MO = '99'                                          DTSCS1D
01741         MOVE '99'                    TO L015-S-DA                 DTSCS1D
01742                                         L015-S-YR                 DTSCS1D
01743         GO TO S1400-EXIT                                          DTSCS1D
01744      END-IF.                                                      DTSCS1D
01745                                                                   DTSCS1D
01746      PERFORM S015-DATE-FROM-SCREEN   THRU S015-EXIT.              DTSCS1D
01747      IF L015-NO-ENTRY                                             DTSCS1D
01748          NEXT SENTENCE                                            DTSCS1D
01749      ELSE                                                         DTSCS1D
01750        IF L015-NOT-VALID                                          DTSCS1D
01751          MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA                DTSCS1D
01752          PERFORM S1401-ERROR THRU S1401-EXIT.                     DTSCS1D
01753  S1400-EXIT. EXIT.                                                DTSCS1D
01754      SKIP3                                                        DTSCS1D
01755  S1401-ERROR.                                                     DTSCS1D
01756      MOVE CATB-UNPROT-NORM-NUM-MDTON TO MAP-PWR-ATTORNEY-MO-A.    DTSCS1D
01757      IF LCCM-NO-MSG                                               DTSCS1D
01758         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01759         MOVE CATB-CURSOR   TO MAP-PWR-ATTORNEY-MO-L               DTSCS1D
01760         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01761  S1401-EXIT. EXIT.                                                DTSCS1D
01762      SKIP3                                                        DTSCS1D
01763 /*****************************************************************DTSCS1D
01764 *                                                                *DTSCS1D
01765 ******************************************************************DTSCS1D
01766  S1500-FEIN.                                                      DTSCS1D
01767      MOVE MAP-FEIN-AREA  TO L017-S-FEIN-AREA.                     DTSCS1D
01768      PERFORM S017-FEIN-FROM-SCREEN THRU S017-EXIT.                DTSCS1D
01769                                                                   DTSCS1D
01770      IF L017-NO-ENTRY                                             DTSCS1D
01771          GO TO S1500-EXIT.                                        DTSCS1D
01772      SKIP1                                                        DTSCS1D
01773      IF L017-NOT-VALID                                            DTSCS1D
01774          MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA                DTSCS1D
01775          PERFORM S1501-ERROR THRU S1501-EXIT                      DTSCS1D
01776          GO TO S1500-EXIT.                                        DTSCS1D
01777      SKIP1                                                        DTSCS1D
01778                                                                   DTSCS1D
01779                                                                   DTSCS1D
01780      IF  L017-FEIN NOT = MPRF-FEIN                                DTSCS1D
01781      AND MPRF-STATUS-ACT-88                                       DTSCS1D
01782          SET L074-ACTIVE-DUP-88 TO TRUE                           DTSCS1D
01783          MOVE WRK-EMP-NO TO L074-EMP-NO                           DTSCS1D
01784          MOVE L017-FEIN TO L074-FEIN                              DTSCS1D
01785          MOVE +0 TO L074-INACTIVE-EMP-NO                          DTSCS1D
01786          PERFORM S074-DUP-FEIN-EDIT THRU S074-EXIT                DTSCS1D
01787          IF L074-DUP-NOT-OK-88                                    DTSCS1D
01788              MOVE EMSG-DUPLICATE-FEIN TO WRK-MSG-AREA             DTSCS1D
01789              PERFORM S1501-ERROR THRU S1501-EXIT.                 DTSCS1D
01790  S1500-EXIT. EXIT.                                                DTSCS1D
01791      SKIP3                                                        DTSCS1D
01792  S1501-ERROR.                                                     DTSCS1D
01793      MOVE CATB-UNPROT-NORM-NUM-MDTON TO MAP-FEIN-1-A              DTSCS1D
01794                                         MAP-FEIN-2-A.             DTSCS1D
01795      IF LCCM-NO-MSG                                               DTSCS1D
01796         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01797         MOVE CATB-CURSOR   TO MAP-FEIN-1-L                        DTSCS1D
01798         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01799  S1501-EXIT. EXIT.                                                DTSCS1D
01800 /*****************************************************************DTSCS1D
01801 *                                                                *DTSCS1D
01802 ******************************************************************DTSCS1D
01803  S1600-AUDITED.                                                   DTSCS1D
01804      MOVE MAP-ARCHIVED-AUDIT-YRQ-AREA TO L016-S-YRQ-AREA.         DTSCS1D
01805      PERFORM S016-YRQ-FROM-SCREEN THRU S016-EXIT.                 DTSCS1D
01806      IF L016-NOT-VALID                                            DTSCS1D
01807          MOVE EMSG-FIELD-NOT-VALID TO WRK-MSG-AREA                DTSCS1D
01808          PERFORM S1601-ERROR THRU S1601-EXIT.                     DTSCS1D
01809  S1600-EXIT. EXIT.                                                DTSCS1D
01810      SKIP3                                                        DTSCS1D
01811  S1601-ERROR.                                                     DTSCS1D
01812      MOVE CATB-UNPROT-NORM-NUM-MDTON TO MAP-ARCHIVED-AUDIT-YR-A   DTSCS1D
01813                                         MAP-ARCHIVED-AUDIT-Q-A    DTSCS1D
01814      IF LCCM-NO-MSG                                               DTSCS1D
01815         MOVE WRK-MSG-AREA  TO LCCM-MSG-AREA                       DTSCS1D
01816         MOVE CATB-CURSOR   TO MAP-ARCHIVED-AUDIT-YR-L             DTSCS1D
01817         SET CURSOR-SET-YES TO TRUE.                               DTSCS1D
01818  S1601-EXIT. EXIT.                                                DTSCS1D
01819 /*****************************************************************DTSCS1D
01820 * LOCK SCREEN FOR UPDATE CONFIRMATION                            *DTSCS1D
01821 ******************************************************************DTSCS1D
01822  S5100-SET-LOCK-ATTRB.                                            DTSCS1D
01823      MOVE CATB-ASKIP-BRT-MDTON TO SCR-ATB-AN                      DTSCS1D
01824                                   SCR-ATB-NUM.                    DTSCS1D
01825      SKIP1                                                        DTSCS1D
01826      PERFORM S5900-SET-ATTRB THRU S5900-EXIT.                     DTSCS1D
01827      SKIP1                                                        DTSCS1D
01828      MOVE CATB-ASKIP-BRT-MDTON TO MAP-EMP-NO-1-A                  DTSCS1D
01829                                   MAP-EMP-NO-2-A                  DTSCS1D
01830                                   MAP-GOTO-A.                     DTSCS1D
01831  S5100-EXIT. EXIT.                                                DTSCS1D
01832      SKIP3                                                        DTSCS1D
01833 ******************************************************************DTSCS1D
01834 * SET ATTIBUTE BYTES FOR UPDATE ACCESS                           *DTSCS1D
01835 ******************************************************************DTSCS1D
01836  S5200-SET-UPDATE-ATTRB.                                          DTSCS1D
01837      MOVE CATB-UNPROT-BRT-AN-MDTON  TO SCR-ATB-AN.                DTSCS1D
01838      MOVE CATB-UNPROT-BRT-NUM-MDTON TO SCR-ATB-NUM.               DTSCS1D
01839      SKIP1                                                        DTSCS1D
01840      PERFORM S5900-SET-ATTRB THRU S5900-EXIT.                     DTSCS1D
01841  S5200-EXIT. EXIT.                                                DTSCS1D
01842      SKIP3                                                        DTSCS1D
01843 ******************************************************************DTSCS1D
01844 *  SET ATTRIBUTE BYTES FOR INQUIRY STATUS                        *DTSCS1D
01845 ******************************************************************DTSCS1D
01846  S5300-SET-INQ-ATTRB.                                             DTSCS1D
01847      MOVE CATB-ASKIP-BRT-MDTOFF TO SCR-ATB-AN                     DTSCS1D
01848                                    SCR-ATB-NUM.                   DTSCS1D
01849      SKIP1                                                        DTSCS1D
01850      PERFORM S5900-SET-ATTRB THRU S5900-EXIT.                     DTSCS1D
01851  S5300-EXIT. EXIT.                                                DTSCS1D
01852 /*****************************************************************DTSCS1D
01853 *  DO IT                                                         *DTSCS1D
01854 ******************************************************************DTSCS1D
01855  S5900-SET-ATTRB.                                                 DTSCS1D
01856      SKIP1                                                        DTSCS1D
01857      MOVE CATB-UNPROT-BRT-NUM-MDTON TO MAP-EMP-NO-1-A             DTSCS1D
01858                                        MAP-EMP-NO-2-A.            DTSCS1D
01859      SKIP3                                                        DTSCS1D
01860      MOVE SCR-ATB-AN  TO MAP-UC30-MASS-MAIL-IND-A                 DTSCS1D
01861                          MAP-UC30-CREDIT-IND-A                    DTSCS1D
01862                          MAP-RETURN-MAIL-IND-A                    DTSCS1D
01863                          MAP-FEIN-HARASS-IND-A                    DTSCS1D
01864                          MAP-CHRG-STMT-PRINT-IND-A                DTSCS1D
01865                          MAP-ORG-TYPE-A                           DTSCS1D
01866                          MAP-DC-CONTRACTOR-IND-A.                 DTSCS1D
01867      SKIP1                                                        DTSCS1D
01868      MOVE SCR-ATB-NUM TO MAP-FEIN-1-A                             DTSCS1D
01869                          MAP-FEIN-2-A                             DTSCS1D
01870                          MAP-PWR-ATTORNEY-DA-A                    DTSCS1D
01871                          MAP-PWR-ATTORNEY-MO-A                    DTSCS1D
01872                          MAP-PWR-ATTORNEY-YR-A                    DTSCS1D
01873                          MAP-ARCHIVED-AUDIT-YR-A                  DTSCS1D
01874                          MAP-ARCHIVED-AUDIT-Q-A.                  DTSCS1D
01875      SKIP1                                                        DTSCS1D
01876      MOVE CATB-ASKIP-BRT-MDTON TO MAP-LAST-ARCHIVED-YRQ-A         DTSCS1D
01877                                   MAP-ELIGIBLE-CD-A.              DTSCS1D
01878      SKIP1                                                        DTSCS1D
01879      MOVE CATB-ASKIP-BRT-MDTON TO MAP-PRIMARY-NAME-A.             DTSCS1D
01880      SKIP1                                                        DTSCS1D
01881      MOVE CATB-ASKIP-NORM-MDTON TO MAP-FA-ADDR-REC-A              DTSCS1D
01882                                    MAP-FA-ADDR-REC-NAME-A         DTSCS1D
01883                                    MAP-FA-QTLY-RPT-A              DTSCS1D
01884                                    MAP-FA-QTLY-RPT-NAME-A         DTSCS1D
01885                                    MAP-FA-BENF-CHG-A              DTSCS1D
01886                                    MAP-FA-BENF-CHG-NAME-A         DTSCS1D
01887                                    MAP-ORG-DESC-A                 DTSCS1D
01888                                    MAP-ELIGIBLE-DESC-A            DTSCS1D
01889                                    MAP-EFT-ENROLLED-A.            DTSCS1D
01890      SKIP3                                                        DTSCS1D
01891      MOVE CATB-UNPROT-BRT-AN-MDTON TO MAP-GOTO-A.                 DTSCS1D
01892      SKIP1                                                        DTSCS1D
01893  S5900-EXIT. EXIT.                                                DTSCS1D
01894 /*****************************************************************DTSCS1D
01895 *  FILE READ COMMON PREPARATION ROUTINES                         *DTSCS1D
01896 ******************************************************************DTSCS1D
01897  S8100-READ-MPRF.                                                 DTSCS1D
01898      MOVE LOW-VALUES TO MPRF-KEY-AREA.                            DTSCS1D
01899      MOVE WRK-EMP-NO TO MPRF-EMP-NO.                              DTSCS1D
01900      SET MPRF-PRF-88 TO TRUE.                                     DTSCS1D
01901      MOVE MPRF-KEY-AREA TO MSKL-KEY-AREA.                         DTSCS1D
01902      PERFORM S810-READ THRU S810-EXIT.                            DTSCS1D
01903      IF L810-OK-88                                                DTSCS1D
01904          SET WRK-MPRF-YES-88 TO TRUE                              DTSCS1D
01905      ELSE                                                         DTSCS1D
01906          SET WRK-MPRF-NO-88 TO TRUE.                              DTSCS1D
01907  S8100-EXIT. EXIT.                                                DTSCS1D
01908 /*****************************************************************DTSCS1D
01909 * MAP ROUTINES                                                   *DTSCS1D
01910 ******************************************************************DTSCS1D
01911  S9100-RECEIVE.                                                   DTSCS1D
01912      MOVE WRK-SCR-ID TO L851-SCR-ID.                              DTSCS1D
01913      SET L851-RECEIVE-88 TO TRUE.                                 DTSCS1D
01914      PERFORM S851-SCREEN-PROCESSING THRU S851-EXIT.               DTSCS1D
01915      SKIP1                                                        DTSCS1D
01916      MOVE L851-AID TO LCCM-AID.                                   DTSCS1D
01917      MOVE L851-CURSOR TO LCCM-CURSOR.                             DTSCS1D
01918  S9100-EXIT. EXIT.                                                DTSCS1D
01919      SKIP3                                                        DTSCS1D
01920 ******************************************************************DTSCS1D
01921 *                                                                *DTSCS1D
01922 ******************************************************************DTSCS1D
01923  S9200-SEND-DATAONLY.                                             DTSCS1D
01924      MOVE LOW-VALUES TO MAP-AREA.                                 DTSCS1D
01925      SKIP1                                                        DTSCS1D
01926      IF LCCM-NO-MSG                                               DTSCS1D
01927          NEXT SENTENCE                                            DTSCS1D
01928      ELSE                                                         DTSCS1D
01929          PERFORM S805-MSG-AREA THRU S805-EXIT.                    DTSCS1D
01930      SKIP1                                                        DTSCS1D
01931      IF CURSOR-SET-GOTO                                           DTSCS1D
01932          MOVE CATB-CURSOR TO MAP-GOTO-L                           DTSCS1D
01933      ELSE                                                         DTSCS1D
01934          MOVE CATB-CURSOR TO MAP-EMP-NO-1-L.                      DTSCS1D
01935      SKIP1                                                        DTSCS1D
01936      PERFORM S9900-PREPARE-SEND THRU S9900-EXIT.                  DTSCS1D
01937      SKIP1                                                        DTSCS1D
01938      SET L851-SEND-DATAONLY-88 TO TRUE.                           DTSCS1D
01939      PERFORM S851-SCREEN-PROCESSING THRU S851-EXIT.               DTSCS1D
01940  S9200-EXIT. EXIT.                                                DTSCS1D
01941      SKIP3                                                        DTSCS1D
01942 ******************************************************************DTSCS1D
01943 *                                                                *DTSCS1D
01944 ******************************************************************DTSCS1D
01945  S9300-SEND-MAP.                                                  DTSCS1D
01946      MOVE  LCCM-TASK-START-DISP-DATE TO MAP-SYS-DATE.             DTSCS1D
01947      MOVE  LCCM-TASK-START-DISP-TIME TO MAP-SYS-TIME.             DTSCS1D
01948      MOVE  LCCM-CICS-REGION-NAME TO MAP-CICS-REGION-NAME.         DTSCS1D
01949      SKIP1                                                        DTSCS1D
01950      IF SCR-ACCESS-UPDATE                                         DTSCS1D
01951          PERFORM S9310-UPDATE-FKEYS THRU S9310-EXIT               DTSCS1D
01952      ELSE                                                         DTSCS1D
01953          PERFORM S9320-INQUIRY-FKEYS THRU S9320-EXIT.             DTSCS1D
01954      SKIP1                                                        DTSCS1D
01955      PERFORM S805-MSG-AREA THRU S805-EXIT.                        DTSCS1D
01956      SKIP1                                                        DTSCS1D
01957      IF CURSOR-SET-NO                                             DTSCS1D
01958          MOVE CATB-CURSOR TO MAP-EMP-NO-1-L.                      DTSCS1D
01959      SKIP1                                                        DTSCS1D
01960      PERFORM S9330-DISPLAY-FIELDS THRU S9330-EXIT.                DTSCS1D
01961      PERFORM S9900-PREPARE-SEND   THRU S9900-EXIT.                DTSCS1D
01962      SKIP1                                                        DTSCS1D
01963      SET L851-SEND-88 TO TRUE.                                    DTSCS1D
01964      PERFORM S851-SCREEN-PROCESSING THRU S851-EXIT.               DTSCS1D
01965  S9300-EXIT. EXIT.                                                DTSCS1D
01966      SKIP3                                                        DTSCS1D
01967  S9310-UPDATE-FKEYS.                                              DTSCS1D
01968      MOVE CFKD-MOD TO MAP-KEY-MOD.                                DTSCS1D
01969 *    PERFORM S9390-JUMP-KEYS THRU S9390-EXIT.                     DTSCS1D
01970      SKIP1                                                        DTSCS1D
01971      IF LCCM-SCR-CLEAR                                            DTSCS1D
01972          MOVE LOW-VALUES TO MAP-KEY-MOD                           DTSCS1D
01973      ELSE                                                         DTSCS1D
01974      IF LCCM-SCR-UPDATE-LOCKED                                    DTSCS1D
01975          MOVE LOW-VALUES TO MAP-KEY-MOD.                          DTSCS1D
01976  S9310-EXIT. EXIT.                                                DTSCS1D
01977      SKIP3                                                        DTSCS1D
01978  S9320-INQUIRY-FKEYS.                                             DTSCS1D
01979      MOVE LOW-VALUES TO MAP-KEY-MOD.                              DTSCS1D
01980 *    PERFORM S9390-JUMP-KEYS THRU S9390-EXIT.                     DTSCS1D
01981  S9320-EXIT. EXIT.                                                DTSCS1D
01982      EJECT                                                        DTSCS1D
01983  S9330-DISPLAY-FIELDS.                                            DTSCS1D
01984      IF MAP-ORG-TYPE = SPACE OR LOW-VALUE                         DTSCS1D
01985          MOVE LOW-VALUE TO MAP-ORG-DESC                           DTSCS1D
01986      ELSE                                                         DTSCS1D
01987          MOVE MAP-ORG-TYPE TO L031-CD                             DTSCS1D
01988          SET L031-MPRF-ORG-TYPE TO TRUE                           DTSCS1D
01989          PERFORM S031-REG-CODES THRU S031-EXIT                    DTSCS1D
01990          MOVE L031-SHORT-DSCR TO MAP-ORG-DESC.                    DTSCS1D
01991      SKIP1                                                        DTSCS1D
01992      IF WRK-MPRF-YES-88                                           DTSCS1D
01993          PERFORM S9331-DISPLAY-FROM-MPRF THRU S9331-EXIT.         DTSCS1D
01994  S9330-EXIT. EXIT.                                                DTSCS1D
01995      SKIP3                                                        DTSCS1D
01996  S9331-DISPLAY-FROM-MPRF.                                         DTSCS1D
01997      MOVE MPRF-PRIMARY-NAME TO MAP-PRIMARY-NAME.                  DTSCS1D
01998      SKIP1                                                        DTSCS1D
01999      IF MPRF-LAST-ARCHIVED-YRQ = +0                               DTSCS1D
02000          MOVE SPACE TO MAP-LAST-ARCHIVED-YRQ                      DTSCS1D
02001      ELSE                                                         DTSCS1D
02002          MOVE MPRF-LAST-ARCHIVED-YRQ TO L004-QTR-5-9              DTSCS1D
02003          SET L004-FROM-5 TO TRUE                                  DTSCS1D
02004          PERFORM S004-QUARTER THRU S004-EXIT                      DTSCS1D
02005          IF L004-VALID-QTR                                        DTSCS1D
02006              MOVE L004-SLASH-QTR TO MAP-LAST-ARCHIVED-YRQ         DTSCS1D
02007          ELSE                                                     DTSCS1D
02008              GO TO S899-ABEND.                                    DTSCS1D
02009      SKIP1                                                        DTSCS1D
02010      MOVE MPRF-ELIGIBLE-CD TO MAP-ELIGIBLE-CD-N.                  DTSCS1D
02011      MOVE MAP-ELIGIBLE-CD  TO L031-CD.                            DTSCS1D
02012      SET L031-MPRF-ELIGIBLE-CD TO TRUE.                           DTSCS1D
02013      PERFORM S031-REG-CODES THRU S031-EXIT.                       DTSCS1D
02014      MOVE L031-SHORT-DSCR TO MAP-ELIGIBLE-DESC.                   DTSCS1D
02015  S9331-EXIT. EXIT.                                                DTSCS1D
02016      EJECT                                                        DTSCS1D
02017 *S9390-JUMP-KEYS.                                                 DTSCS1D
02018 *    MOVE CFKD-REG-INQ    TO MAP-KEY-REG-INQ.                     DTSCS1D
02019 *S9390-EXIT. EXIT.                                                DTSCS1D
02020      SKIP3                                                        DTSCS1D
02021 ******************************************************************DTSCS1D
02022 *                                                                *DTSCS1D
02023 ******************************************************************DTSCS1D
02024  S9900-PREPARE-SEND.                                              DTSCS1D
02025      MOVE WRK-SCR-ID        TO LCCM-SCR-ID                        DTSCS1D
02026                                L851-SCR-ID.                       DTSCS1D
02027      MOVE LCCM-OP-ALARM-IND TO L851-ALARM-IND.                    DTSCS1D
02028      MOVE LCCM-MSG-TYPE     TO L851-MSG-TYPE.                     DTSCS1D
02029  S9900-EXIT. EXIT.                                                DTSCS1D
