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