diff --git a/CICS/DTSCU351.cob b/CICS/DTSCU351.cob deleted file mode 100644 index c2bb73e..0000000 --- a/CICS/DTSCU351.cob +++ /dev/null @@ -1,1059 +0,0 @@ -00001 IDENTIFICATION DIVISION. 07/30/98 -00002 PROGRAM-ID. MACCU351. DTSCU351 -00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV001 -00004 DATE-WRITTEN. DECEMBER 1991. DTSCU351 -00005 DATE-COMPILED. DTSCU351 -00006 DTSCU351 -00007 ***** DTSCU351 -00008 * DTSCU351 -00009 * FUNCTION: FIELD ASSIGNMENT MEMORANDUM PRINT. DTSCU351 -00010 * DTSCU351 -00011 * DTSCU351 -00012 * MODIFICATION LOG: DTSCU351 -00013 * DTSCU351 -00014 * 12/08/91 INITIAL DEVELOPMENT. DTSCU351 -00015 * WORK ORDER: PROGRAMMER: TCL DTSCU351 -00016 * DTSCU351 -00017 * 11/07/97 MODIFICATIONS TO REFLECT TRANSFER OF UI TAX DTSCU351 -00018 * FUNCTIONS FROM DLI TO DOR. DTSCU351 -00019 * WORK ORDER: TCL 208 PROGRAMMER: EHH DTSCU351 -00020 * DTSCU351 -00021 * 03/24/92 DTSCU351 -00022 * WORK ORDER: PROGRAMMER: JME DTSCU351 -00023 * DTSCU351 -00024 * DTSCU351 -00025 * DESCRIPTION: DTSCU351 -00026 * DTSCU351 -00027 * MACCU351 IS PASSED L351-EMP-NO, L351-ASSGN-NO, DTSCU351 -00028 * L351-PRINTER-ID, L351-COPY-CNT, L351-TASK-START-DISP-DATE, DTSCU351 -00029 * AND L351-TASK-START-DISP-TIME. DTSCU351 -00030 * DTSCU351 -00031 * SEE \RAP\RPT\601R1 FOR FIELD ASSIGNMENT MEMORANDUM DESCRIPTIODTSCU351 -00032 * DESCRIPTION AND FORMAT. DTSCU351 -00033 * DTSCU351 -00034 * USE TS Q 'P' TO COMMUNICATE PRINT LINES TO MACIL357. DTSCU351 -00035 * DTSCU351 -00036 * DTSCU351 -00037 * RECORDS READ: DTSCU351 -00038 * DTSCU351 -00039 * MASTER: DTSCU351 -00040 * DTSCU351 -00041 * MPRF DTSCU351 -00042 * MFAS DTSCU351 -00043 * MTAD DTSCU351 -00044 * MOPO DTSCU351 -00045 * DTSCU351 -00046 * DTSCU351 -00047 * MODULES LINKED TO: DTSCU351 -00048 * DTSCU351 -00049 * MACCU036 FIELD SUPPORT CODES EDIT/DESCRIPTION. DTSCU351 -00050 * MACCU062 FIELD REP ID EDIT/DESCRIPTION. DTSCU351 -00051 * MACCU063 FIELD ASSIGNMENT TYPE EDIT/DESCRIPTION. DTSCU351 -00052 * MACCU071 NAME EDIT/CONVERSION. DTSCU351 -00053 * MACCU112 FORMAT ADDRESS FOR MAILING. DTSCU351 -00054 * MACCU119 AGENCY FACTS. DTSCU351 -00055 * MACCU357 ON-LINE PRINTING. DTSCU351 -00056 * MACCU810 MASTER FILE INPUT/OUTPUT. DTSCU351 -00057 * MACCU829 TEMPORARY STORAGE INPUT/OUTPUT. DTSCU351 -00058 * DTSCU351 -00059 * DTSCU351 -00060 * VERMONT REFERENCE: DTSCU351 -00061 * DTSCU351 -00062 * TXCU351. DTSCU351 -00063 * DTSCU351 -00064 * DTSCU351 -00065 * NOTES TO JEFF: DTSCU351 -00066 * DTSCU351 -00067 * . SEE RPT601R1.* IN RPT.ZIP FOR DEFINITIONS AND LAYOUT OF DTSCU351 -00068 * THE REPORT. DTSCU351 -00069 * DTSCU351 -00070 * . DON'T GET TOO CUTE FLOATING PRINT LINES UP AND DOWN THE DTSCU351 -00071 * PAGE. JUST SO THE PRINT LOOKS REASONABLE. DTSCU351 -00072 * DTSCU351 -00073 * . YOU WON'T BE ABLE TO TEST THE MOPO RELATED LOGIC UNTIL DTSCU351 -00074 * WE GET MACCS15 WRITTEN. I WILL SEND YOU MACCS15 IN A DTSCU351 -00075 * WEEK OR TWO. DTSCU351 -00076 * DTSCU351 -00077 * DTSCU351 -00078 ***** DTSCU351 -00079 DTSCU351 -00080 ENVIRONMENT DIVISION. DTSCU351 -00081 DTSCU351 -00082 DATA DIVISION. DTSCU351 -00083 DTSCU351 -00084 WORKING-STORAGE SECTION. DTSCU351 -000845 77 PAN-VALET PICTURE X(24) VALUE '001DTSCU351 07/30/98'. DTSCU351 -00085 DTSCU351 -00086 01 WRK-AREA. DTSCU351 -00087 05 WRK-ABEND-CODE PIC X(04) VALUE 'U351'. DTSCU351 -00088 DTSCU351 -00089 05 LINE-CNT PIC S9(04) COMP. DTSCU351 -00090 DTSCU351 -00091 05 WRK-OCC PIC S9(04) COMP. DTSCU351 -00092 DTSCU351 -00093 05 WRK-OCC1 PIC S9(04) COMP. DTSCU351 -00094 DTSCU351 -00095 05 WRK-OCC2 PIC S9(04) COMP. DTSCU351 -00096 DTSCU351 -00097 05 WRK-COPY-CNT PIC S9(01) COMP-3. DTSCU351 -00098 DTSCU351 -00099 05 WRK-BLANK-LINE-IND PIC X(01). DTSCU351 -00100 88 WRK-BLANK-LINE-YES-88 VALUE 'Y'. DTSCU351 -00101 88 WRK-BLANK-LINE-NO-88 VALUE 'N'. DTSCU351 -00102 DTSCU351 -00103 05 WRK-CC PIC X(01). DTSCU351 -00104 88 WRK-CC-NONE VALUE ' '. DTSCU351 -00105 88 WRK-CC-SKIP-LINE VALUE '0'. DTSCU351 -00106 DTSCU351 -00107 01 WRK-ASSIGN-DESC. DTSCU351 -00108 05 WRK-ASSIGN-DESC1 PIC X(20). DTSCU351 -00109 05 WRK-ASSIGN-DESC2 PIC X(20). DTSCU351 -00110 DTSCU351 -00111 01 TS-AREA. DTSCU351 -00112 05 TS-LINE-CNT PIC S9(04) COMP. DTSCU351 -00113 05 TS-LINE OCCURS 66 TIMES DTSCU351 -00114 INDEXED BY TS-LINE-IDX. DTSCU351 -00115 10 TS-CC PIC X(01). DTSCU351 -00116 88 TS-CC-NEW-PAGE VALUE '1'. DTSCU351 -00117 88 TS-CC-SKIP-LINE VALUE '0'. DTSCU351 -00118 88 TS-CC-NONE VALUE ' '. DTSCU351 -00119 10 TS-TEXT PIC X(78). DTSCU351 -00120 DTSCU351 -00121 01 WRK-ADDRESSES. DTSCU351 -00122 05 WRK-ADDRESS OCCURS 6 TIMES. DTSCU351 -00123 10 WRK-MAILING-LINE OCCURS 6 TIMES PIC X(40). DTSCU351 -00124 DTSCU351 -00125 01 WRK-TELEPHONES. DTSCU351 -00126 * 05 WRK-PHONES OCCURS 6 TIMES. DTSCU351 -00127 10 WRK-TELEPHONE. DTSCU351 -00128 15 WRK-TELEPHONE-LEFT PIC X(01). DTSCU351 -00129 15 WRK-TELEPHONE-AREA-CD PIC X(03). DTSCU351 -00130 15 WRK-TELEPHONE-RIGHT PIC X(02). DTSCU351 -00131 15 WRK-TELEPHONE-PREFIX PIC X(03). DTSCU351 -00132 15 WRK-TELPHONE-DASH PIC X(01). DTSCU351 -00133 15 WRK-TELEPHONE-SUFFIX PIC X(04). DTSCU351 -00134 15 WRK-TELEPHONE-EXT-LBL PIC X(06). DTSCU351 -00135 15 WRK-TELEPHONE-EXT PIC X(04). DTSCU351 -00136 DTSCU351 -00137 01 WRK-HEADING-1. DTSCU351 -00138 05 WRK-PROGRAM PIC X(05) VALUE '601R1'. DTSCU351 -00139 05 FILLER PIC X(19) VALUE SPACES. DTSCU351 -00140 05 WRK-AGY-NAMEA-CNTR PIC X(40). DTSCU351 -00141 05 FILLER PIC X(06) VALUE SPACES. DTSCU351 -00142 05 WRK-SYS-DATE PIC X(08). DTSCU351 -00143 DTSCU351 -00144 01 WRK-HEADING-2. DTSCU351 -00145 05 FILLER PIC X(25) VALUE SPACES. DTSCU351 -00146 05 FILLER PIC X(27) VALUE DTSCU351 -00147 'FIELD ASSIGNMENT MEMORANDUM'. DTSCU351 -00148 05 FILLER PIC X(18) VALUE SPACES. DTSCU351 -00149 05 WRK-SYS-TIME PIC X(08). DTSCU351 -00150 DTSCU351 -00151 01 WRK-LINE-TO. DTSCU351 -00152 05 FILLER PIC X(13) VALUE ' TO: '. DTSCU351 -00153 05 WRK-FIELD-REP-NAME PIC X(32). DTSCU351 -00154 05 FILLER PIC X(13) VALUE ' ASSIGN NO: '. DTSCU351 -00155 05 WRK-ASSIGN-NO PIC 99B99999. DTSCU351 -00156 DTSCU351 -00157 01 WRK-LINE-FROM. DTSCU351 -00158 05 FILLER PIC X(13) DTSCU351 -00159 VALUE ' FROM: '. DTSCU351 -00160 05 WRK-ORIGINATOR PIC X(32). DTSCU351 -00161 05 FILLER PIC X(13) VALUE ' DUE DATE: '. DTSCU351 -00162 05 WRK-DUE-DATE PIC X(08). DTSCU351 -00163 DTSCU351 -00164 01 WRK-LINE-EMP-NO. DTSCU351 -00165 05 FILLER PIC X(13) VALUE ' EMP NO: '. DTSCU351 -00166 05 WRK-EMP-NO PIC 999B999. DTSCU351 -00167 05 FILLER PIC X(25) VALUE SPACES. DTSCU351 -00168 05 FILLER PIC X(13) VALUE 'ASSIGN TYPE: '. DTSCU351 -00169 05 WRK-ASSIGN-TYPE PIC X(02). DTSCU351 -00170 DTSCU351 -00171 01 WRK-LINE-ASSIGN-1. DTSCU351 -00172 05 FILLER PIC X(58) VALUE SPACES. DTSCU351 -00173 05 WRK-ASSIGN-TYPE-DESC1 PIC X(20). DTSCU351 -00174 DTSCU351 -00175 01 WRK-LINE-ASSIGN-2. DTSCU351 -00176 05 FILLER PIC X(13) VALUE ' SIC: '. DTSCU351 -00177 05 WRK-SIC-CD PIC X(07). DTSCU351 -00178 05 FILLER PIC X(01) VALUE SPACES. DTSCU351 -00179 05 WRK-OWN-CD PIC X(02). DTSCU351 -00180 05 FILLER PIC X(35) VALUE SPACES. DTSCU351 -00181 05 WRK-ASSIGN-TYPE-DESC2 PIC X(20). DTSCU351 -00182 DTSCU351 -00183 01 WRK-LINE-FEIN. DTSCU351 -00184 05 FILLER PIC X(13) VALUE ' FEIN: '. DTSCU351 -00185 05 WRK-FEIN-X PIC X(11). DTSCU351 -00186 05 WRK-FEIN REDEFINES WRK-FEIN-X DTSCU351 -00187 PIC 99B9999999B. DTSCU351 -00188 05 FILLER PIC X(20) VALUE SPACES. DTSCU351 -00189 05 FILLER PIC X(14) VALUE 'AUDIT PERIOD: '. DTSCU351 -00190 05 WRK-AUDIT-YRQ-START PIC X(04). DTSCU351 -00191 05 FILLER PIC X(03) VALUE ' - '. DTSCU351 -00192 05 WRK-AUDIT-YRQ-END PIC X(04). DTSCU351 -00193 DTSCU351 -00194 01 WRK-EMP-SIZE-LINE. DTSCU351 -00195 05 FILLER PIC X(43) VALUE SPACES. DTSCU351 -00196 05 FILLER PIC X(15) VALUE 'EMPLOYER SIZE: '.DTSCU351 -00197 05 WRK-EMP-SIZE PIC X(05). DTSCU351 -00198 DTSCU351 -00199 01 WRK-LINE-ADDRESS. DTSCU351 -00200 05 WRK-TAD-ADDRESS PIC X(40). DTSCU351 -00201 05 FILLER PIC X(01) VALUE SPACES. DTSCU351 -00202 05 WRK-OPO-ADDRESS PIC X(37). DTSCU351 -00203 DTSCU351 -00204 01 WRK-LINE-RE. DTSCU351 -00205 05 FILLER PIC X(13) VALUE 'RE CLAIMANT: '. DTSCU351 -00206 05 WRK-CLAIMANT-SSN PIC 999B99B9999. DTSCU351 -00207 05 FILLER PIC X(04) VALUE SPACES. DTSCU351 -00208 05 WRK-CLAIMANT-NAME PIC X(32). DTSCU351 -00209 DTSCU351 -00210 01 WRK-LINE-RELATED-EMP. DTSCU351 -00211 05 FILLER PIC X(13) VALUE 'RELATED EMP: '. DTSCU351 -00212 05 WRK-RELATED-EMP-NO PIC 999B999. DTSCU351 -00213 05 FILLER PIC X(04) VALUE SPACES. DTSCU351 -00214 05 WRK-RELATED-EMP-NAME PIC X(40). DTSCU351 -00215 DTSCU351 -00216 01 WRK-LINE-TEXT. DTSCU351 -00217 05 WRK-TEXT PIC X(72) VALUE SPACES. DTSCU351 -00218 DTSCU351 -00219 01 WRK-LINE-COPY. DTSCU351 -00220 05 FILLER PIC X(25) VALUE SPACES. DTSCU351 -00221 05 WRK-COPY-LIT PIC X(20). DTSCU351 -00222 EJECT DTSCU351 -00223 01 L001-COMM-AREA. DTSCU351 -00224 COPY MACIL001. DTSCU351 -00225 EJECT DTSCU351 -00226 01 L004-COMM-AREA. DTSCU351 -00227 COPY MACIL004. DTSCU351 -00228 EJECT DTSCU351 -00229 01 L056-COMM-AREA. DTSCU351 -00230 COPY MACIL056. DTSCU351 -00231 EJECT DTSCU351 -00232 01 L062-COMM-AREA. DTSCU351 -00233 COPY MACIL062. DTSCU351 -00234 EJECT DTSCU351 -00235 01 L063-COMM-AREA. DTSCU351 -00236 COPY MACIL063. DTSCU351 -00237 EJECT DTSCU351 -00238 01 L071-COMM-AREA. DTSCU351 -00239 COPY MACIL071. DTSCU351 -00240 EJECT DTSCU351 -00241 01 L082-COMM-AREA. DTSCU351 -00242 COPY MACIL082. DTSCU351 -00243 EJECT DTSCU351 -00244 01 L112-COMM-AREA. DTSCU351 -00245 COPY MACIL112. DTSCU351 -00246 EJECT DTSCU351 -00247 01 L119-COMM-AREA. DTSCU351 -00248 COPY MACIL119. DTSCU351 -00249 EJECT DTSCU351 -00250 01 L357-COMM-AREA. DTSCU351 -00251 COPY MACIL357. DTSCU351 -00252 EJECT DTSCU351 -00253 01 L829-COMM-AREA. DTSCU351 -00254 05 L829-CONTROL-BLOCK. DTSCU351 -00255 COPY MACIL829. DTSCU351 -00256 DTSCU351 -00257 05 L829-REC. DTSCU351 -00258 COPY MACIXPTS. DTSCU351 -00259 EJECT DTSCU351 -00260 01 L810-COMM-AREA. DTSCU351 -00261 05 L810-CONTROL-BLOCK. DTSCU351 -00262 COPY MACIL810. DTSCU351 -00263 DTSCU351 -00264 05 MSKL-REC. DTSCU351 -00265 COPY MACIMSKL. DTSCU351 -00266 EJECT DTSCU351 -00267 01 MPRF-REC. DTSCU351 -00268 COPY MACIMPRF. DTSCU351 -00269 EJECT DTSCU351 -00270 01 MTAD-REC. DTSCU351 -00271 COPY MACIMTAD. DTSCU351 -00272 EJECT DTSCU351 -00273 01 MFAS-REC. DTSCU351 -00274 COPY MACIMFAS. DTSCU351 -00275 EJECT DTSCU351 -00276 01 MOPO-REC. DTSCU351 -00277 COPY MACIMOPO. DTSCU351 -00278 EJECT DTSCU351 -00279 LINKAGE SECTION. DTSCU351 -00280 DTSCU351 -00281 01 DFHCOMMAREA. DTSCU351 -00282 COPY MACIL351. DTSCU351 -00283 DTSCU351 -00284 /*****************************************************************DTSCU351 -00285 * DTSCU351 -00286 ******************************************************************DTSCU351 -00287 PROCEDURE DIVISION. DTSCU351 -00288 *-----------------------------------------------------------------DTSCU351 -00289 * CLEAN UP AND INITIALIZE TS QUEUE AREA. DTSCU351 -00290 *-----------------------------------------------------------------DTSCU351 -00291 MOVE 0 TO L829-ITEM-NO. DTSCU351 -00292 DTSCU351 -00293 MOVE XPTS-LENGTH TO L829-REC-LENGTH. DTSCU351 -00294 DTSCU351 -00295 SET L829-DEFAULT-STORAGE-88 TO TRUE. DTSCU351 -00296 DTSCU351 -00297 MOVE L351-TS-NAME-PREFIX TO L829-QUEUE-NAME-PREFIX. DTSCU351 -00298 DTSCU351 -00299 MOVE 'P' TO L829-QUEUE-NAME-SUFFIX. DTSCU351 -00300 DTSCU351 -00301 COMPUTE L829-COMM-AREA-LENGTH DTSCU351 -00302 = L829-CONTROL-BLOCK-LENGTH + L829-REC-LENGTH. DTSCU351 -00303 DTSCU351 -00304 PERFORM S829-DELETE-QUEUE THRU S829-EXIT. DTSCU351 -00305 DTSCU351 -00306 MOVE L351-PRINTER-ID TO L357-PRINTER-ID. DTSCU351 -00307 DTSCU351 -00308 MOVE L829-QUEUE-NAME TO L357-QUEUE-NAME DTSCU351 -00309 DTSCU351 -00310 DTSCU351 -00311 *-----------------------------------------------------------------DTSCU351 -00312 * SET RESULT TO OK AND AND START PROCESS DTSCU351 -00313 *-----------------------------------------------------------------DTSCU351 -00314 SET L351-PRINT-OK TO TRUE. DTSCU351 -00315 DTSCU351 -00316 IF L351-COPY-CNT = 0 DTSCU351 -00317 SET L351-PRINT-FAILED TO TRUE DTSCU351 -00318 ELSE DTSCU351 -00319 PERFORM P1000-PROCESS THRU P1000-EXIT DTSCU351 -00320 IF L351-PRINT-FAILED DTSCU351 -00321 PERFORM S829-DELETE-QUEUE THRU S829-EXIT DTSCU351 -00322 ELSE DTSCU351 -00323 PERFORM S357-LINK-PRINT THRU S357-EXIT DTSCU351 -00324 IF L357-FAILED-88 DTSCU351 -00325 SET L351-PRINT-FAILED TO TRUE DTSCU351 -00326 END-IF. DTSCU351 -00327 DTSCU351 -00328 EXEC CICS DTSCU351 -00329 RETURN DTSCU351 -00330 END-EXEC. DTSCU351 -00331 DTSCU351 -00332 GOBACK. DTSCU351 -00333 /*****************************************************************DTSCU351 -00334 * DTSCU351 -00335 ******************************************************************DTSCU351 -00336 P1000-PROCESS. DTSCU351 -00337 PERFORM P1010-READ-PRF THRU P1010-EXIT DTSCU351 -00338 IF L351-PRINT-FAILED DTSCU351 -00339 GO TO P1000-EXIT DTSCU351 -00340 END-IF. DTSCU351 -00341 DTSCU351 -00342 PERFORM P1020-READ-FAS THRU P1020-EXIT. DTSCU351 -00343 IF L351-PRINT-FAILED DTSCU351 -00344 GO TO P1000-EXIT DTSCU351 -00345 END-IF. DTSCU351 -00346 DTSCU351 -00347 PERFORM P1100-HEADING THRU P1100-EXIT. DTSCU351 -00348 DTSCU351 -00349 PERFORM P1200-FAS-AREA THRU P1200-EXIT. DTSCU351 -00350 DTSCU351 -00351 PERFORM P1300-ADDRESSES THRU P1300-EXIT. DTSCU351 -00352 DTSCU351 -00353 PERFORM P1400-CLAIMANT THRU P1400-EXIT. DTSCU351 -00354 DTSCU351 -00355 PERFORM P1500-REL-EMP THRU P1500-EXIT. DTSCU351 -00356 DTSCU351 -00357 ADD +1 TO TS-LINE-CNT DTSCU351 -00358 MOVE ' ' TO TS-CC(TS-LINE-CNT) DTSCU351 -00359 MOVE SPACES TO TS-TEXT(TS-LINE-CNT). DTSCU351 -00360 ADD +1 TO LINE-CNT. DTSCU351 -00361 DTSCU351 -00362 IF MFAS-TEXT-CNT NOT EQUAL 0 DTSCU351 -00363 PERFORM P1600-FAS-TEXT THRU P1600-EXIT DTSCU351 -00364 VARYING MFAS-TEXT-IDX DTSCU351 -00365 FROM 1 BY 1 DTSCU351 -00366 UNTIL MFAS-TEXT-IDX > MFAS-TEXT-CNT. DTSCU351 -00367 DTSCU351 -00368 PERFORM P7000-COPY-LINE THRU P7000-EXIT. DTSCU351 -00369 DTSCU351 -00370 MOVE '(FIELD REP COPY)' TO WRK-COPY-LIT. DTSCU351 -00371 PERFORM P8000-TS-WRITE THRU P8000-EXIT. DTSCU351 -00372 DTSCU351 -00373 IF L351-PRINT-FAILED DTSCU351 -00374 GO TO P1000-EXIT DTSCU351 -00375 END-IF. DTSCU351 -00376 DTSCU351 -00377 MOVE +0 TO WRK-COPY-CNT. DTSCU351 -00378 PERFORM P2000-COPY-IND THRU P2000-EXIT. DTSCU351 -00379 DTSCU351 -00380 IF L351-COPY-CNT > 1 DTSCU351 -00381 MOVE '(EMPLOYER FILE COPY)' TO WRK-COPY-LIT DTSCU351 -00382 PERFORM P8000-TS-WRITE THRU P8000-EXIT DTSCU351 -00383 PERFORM P2000-COPY-IND THRU P2000-EXIT DTSCU351 -00384 END-IF. DTSCU351 -00385 DTSCU351 -00386 IF L351-PRINT-FAILED DTSCU351 -00387 GO TO P1000-EXIT DTSCU351 -00388 END-IF. DTSCU351 -00389 DTSCU351 -00390 IF L351-COPY-CNT > 2 DTSCU351 -00391 MOVE SPACES TO WRK-COPY-LIT DTSCU351 -00392 PERFORM P8000-TS-WRITE THRU P8000-EXIT DTSCU351 -00393 PERFORM P2000-COPY-IND THRU P2000-EXIT DTSCU351 -00394 END-IF. DTSCU351 -00395 DTSCU351 -00396 IF L351-PRINT-FAILED DTSCU351 -00397 GO TO P1000-EXIT DTSCU351 -00398 END-IF. DTSCU351 -00399 DTSCU351 -00400 IF L351-COPY-CNT > 3 DTSCU351 -00401 IF MFAS-RELATED-EMP-NO NOT = 0 DTSCU351 -00402 MOVE SPACES TO WRK-COPY-LIT DTSCU351 -00403 ELSE DTSCU351 -00404 MOVE SPACES TO WRK-COPY-LIT DTSCU351 -00405 END-IF DTSCU351 -00406 PERFORM P8000-TS-WRITE THRU P8000-EXIT DTSCU351 -00407 PERFORM P2000-COPY-IND THRU P2000-EXIT DTSCU351 -00408 END-IF DTSCU351 -00409 DTSCU351 -00410 IF L351-PRINT-FAILED DTSCU351 -00411 GO TO P1000-EXIT. DTSCU351 -00412 DTSCU351 -00413 PERFORM P1001-ADDL-COPIES THRU P1001-EXIT DTSCU351 -00414 UNTIL (WRK-COPY-CNT NOT < L351-COPY-CNT) DTSCU351 -00415 OR DTSCU351 -00416 (L351-PRINT-FAILED). DTSCU351 -00417 DTSCU351 -00418 P1000-EXIT. DTSCU351 -00419 EXIT. DTSCU351 -00420 DTSCU351 -00421 P1001-ADDL-COPIES. DTSCU351 -00422 MOVE SPACES TO WRK-COPY-LIT. DTSCU351 -00423 PERFORM P8000-TS-WRITE THRU P8000-EXIT. DTSCU351 -00424 PERFORM P2000-COPY-IND THRU P2000-EXIT. DTSCU351 -00425 P1001-EXIT. DTSCU351 -00426 EXIT. DTSCU351 -00427 /*****************************************************************DTSCU351 -00428 * READ EMPLOYER PROFILE DTSCU351 -00429 ******************************************************************DTSCU351 -00430 P1010-READ-PRF. DTSCU351 -00431 MOVE LOW-VALUES TO MPRF-KEY-AREA. DTSCU351 -00432 MOVE L351-EMP-NO TO MPRF-EMP-NO. DTSCU351 -00433 SET MPRF-PRF-88 TO TRUE. DTSCU351 -00434 MOVE MPRF-KEY-AREA TO MSKL-KEY-AREA. DTSCU351 -00435 PERFORM S810-READ THRU S810-EXIT. DTSCU351 -00436 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00437 SET L351-PRINT-FAILED TO TRUE DTSCU351 -00438 ELSE DTSCU351 -00439 MOVE MSKL-REC TO MPRF-REC DTSCU351 -00440 END-IF. DTSCU351 -00441 P1010-EXIT. DTSCU351 -00442 EXIT. DTSCU351 -00443 DTSCU351 -00444 /*****************************************************************DTSCU351 -00445 * READ FIELD ASSIGNMENT DTSCU351 -00446 ******************************************************************DTSCU351 -00447 P1020-READ-FAS. DTSCU351 -00448 MOVE LOW-VALUES TO MFAS-KEY-AREA. DTSCU351 -00449 MOVE L351-EMP-NO TO MFAS-EMP-NO. DTSCU351 -00450 MOVE L351-ASSIGN-NO TO MFAS-ASSIGN-NO. DTSCU351 -00451 SET MFAS-FAS-88 TO TRUE. DTSCU351 -00452 MOVE MFAS-KEY-AREA TO MSKL-KEY-AREA. DTSCU351 -00453 PERFORM S810-READ THRU S810-EXIT. DTSCU351 -00454 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00455 SET L351-PRINT-FAILED TO TRUE DTSCU351 -00456 ELSE DTSCU351 -00457 MOVE MSKL-REC TO MFAS-REC DTSCU351 -00458 END-IF. DTSCU351 -00459 P1020-EXIT. DTSCU351 -00460 EXIT. DTSCU351 -00461 DTSCU351 -00462 /*****************************************************************DTSCU351 -00463 * BUILD FIELD ASSIGNMENT MEMO HEADING (FIRST 3 LINES) DTSCU351 -00464 ******************************************************************DTSCU351 -00465 P1100-HEADING. DTSCU351 -00466 MOVE L351-TASK-START-DISP-DATE TO WRK-SYS-DATE. DTSCU351 -00467 MOVE L351-TASK-START-DISP-TIME TO WRK-SYS-TIME. DTSCU351 -00468 DTSCU351 -00469 PERFORM S119-AGENCY-FACTS THRU S119-EXIT. DTSCU351 -00470 DTSCU351 -00471 MOVE L119-AGY-NAMEA TO WRK-AGY-NAMEA-CNTR. DTSCU351 -00472 SET TS-CC-NEW-PAGE(1) TO TRUE. DTSCU351 -00473 MOVE WRK-HEADING-1 TO TS-TEXT(1). DTSCU351 -00474 SET TS-CC-NONE(2) TO TRUE. DTSCU351 -00475 MOVE WRK-HEADING-2 TO TS-TEXT(2). DTSCU351 -00476 MOVE +02 TO TS-LINE-CNT. DTSCU351 -00477 MOVE +02 TO LINE-CNT. DTSCU351 -00478 P1100-EXIT. EXIT. DTSCU351 -00479 DTSCU351 -00480 /*****************************************************************DTSCU351 -00481 * BUILD FIELD ASSIGNMENT SPECIFIC INFORMATION DTSCU351 -00482 ******************************************************************DTSCU351 -00483 P1200-FAS-AREA. DTSCU351 -00484 SET TS-CC-SKIP-LINE(3) TO TRUE. DTSCU351 -00485 MOVE MFAS-FLD-REP-ID TO L062-FLD-REP-ID. DTSCU351 -00486 PERFORM S062-AUDIT-EDIT THRU S062-EXIT. DTSCU351 -00487 MOVE L062-NAME TO WRK-FIELD-REP-NAME. DTSCU351 -00488 MOVE MFAS-ASSIGN-NO TO WRK-ASSIGN-NO. DTSCU351 -00489 MOVE WRK-LINE-TO TO TS-TEXT(3). DTSCU351 -00490 DTSCU351 -00491 SET TS-CC-SKIP-LINE(4) TO TRUE. DTSCU351 -00492 MOVE MFAS-SOURCE-OP-ID TO L082-OP-ID. DTSCU351 -00493 PERFORM S082-OP-ID THRU S082-EXIT. DTSCU351 -00494 MOVE L082-NAME TO WRK-ORIGINATOR. DTSCU351 -00495 MOVE MFAS-DUE-DATE TO L001-FED-8-DATE-9. DTSCU351 -00496 PERFORM S001-FROM-FED-8 THRU S001-EXIT. DTSCU351 -00497 MOVE L001-SLASH-DATE TO WRK-DUE-DATE. DTSCU351 -00498 MOVE WRK-LINE-FROM TO TS-TEXT(4). DTSCU351 -00499 DTSCU351 -00500 SET TS-CC-SKIP-LINE(5) TO TRUE. DTSCU351 -00501 MOVE MFAS-ASSIGN-TYPE TO L063-TYPE. DTSCU351 -00502 PERFORM S063-ASSIGN-TYPE THRU S063-EXIT. DTSCU351 -00503 MOVE L063-TYPE TO WRK-ASSIGN-TYPE. DTSCU351 -00504 MOVE MFAS-EMP-NO TO WRK-EMP-NO. DTSCU351 -00505 MOVE WRK-LINE-EMP-NO TO TS-TEXT(5). DTSCU351 -00506 DTSCU351 -00507 SET TS-CC-NONE(6) TO TRUE. DTSCU351 -00508 MOVE L063-DESCRIPTION TO WRK-ASSIGN-DESC. DTSCU351 -00509 MOVE WRK-ASSIGN-DESC1 TO WRK-ASSIGN-TYPE-DESC1. DTSCU351 -00510 MOVE WRK-LINE-ASSIGN-1 TO TS-TEXT(6). DTSCU351 -00511 DTSCU351 -00512 SET TS-CC-NONE(7) TO TRUE. DTSCU351 -00513 MOVE MFAS-SIC-CD TO WRK-SIC-CD. DTSCU351 -00514 MOVE MFAS-OWN-CD TO WRK-OWN-CD. DTSCU351 -00515 DTSCU351 -00516 MOVE WRK-ASSIGN-DESC2 TO WRK-ASSIGN-TYPE-DESC2. DTSCU351 -00517 MOVE WRK-LINE-ASSIGN-2 TO TS-TEXT(7). DTSCU351 -00518 DTSCU351 -00519 SET TS-CC-NONE(8) TO TRUE. DTSCU351 -00520 IF MPRF-FEIN > 0 DTSCU351 -00521 MOVE MPRF-FEIN TO WRK-FEIN DTSCU351 -00522 ELSE DTSCU351 -00523 MOVE SPACES TO WRK-FEIN-X DTSCU351 -00524 END-IF. DTSCU351 -00525 DTSCU351 -00526 MOVE MFAS-AUDIT-START-YRQ TO L004-QTR-5-9. DTSCU351 -00527 PERFORM S004-FROM-5 THRU S004-EXIT. DTSCU351 -00528 MOVE L004-SLASH-QTR TO WRK-AUDIT-YRQ-START. DTSCU351 -00529 MOVE MFAS-AUDIT-END-YRQ TO L004-QTR-5-9. DTSCU351 -00530 PERFORM S004-FROM-5 THRU S004-EXIT. DTSCU351 -00531 MOVE L004-SLASH-QTR TO WRK-AUDIT-YRQ-END. DTSCU351 -00532 MOVE WRK-LINE-FEIN TO TS-TEXT(8). DTSCU351 -00533 DTSCU351 -00534 SET TS-CC-NONE(9) TO TRUE. DTSCU351 -00535 IF MFAS-AUDIT-88 DTSCU351 -00536 IF MFAS-EMP-LARGE-88 DTSCU351 -00537 MOVE 'LARGE' TO WRK-EMP-SIZE DTSCU351 -00538 ELSE DTSCU351 -00539 MOVE 'SMALL' TO WRK-EMP-SIZE DTSCU351 -00540 END-IF DTSCU351 -00541 ELSE DTSCU351 -00542 MOVE SPACES TO WRK-EMP-SIZE DTSCU351 -00543 END-IF. DTSCU351 -00544 MOVE WRK-EMP-SIZE-LINE TO TS-TEXT(9). DTSCU351 -00545 DTSCU351 -00546 MOVE +09 TO TS-LINE-CNT. DTSCU351 -00547 MOVE +12 TO LINE-CNT. DTSCU351 -00548 P1200-EXIT. DTSCU351 -00549 EXIT. DTSCU351 -00550 /*****************************************************************DTSCU351 -00551 * OBTAIN ADDRESS INFORMATION FROM FILE AND STORE IN TABLE DTSCU351 -00552 ******************************************************************DTSCU351 -00553 P1300-ADDRESSES. DTSCU351 -00554 MOVE SPACES TO WRK-ADDRESSES. DTSCU351 -00555 DTSCU351 -00556 PERFORM P1310-FORMAT-TAX-ADDR THRU P1310-EXIT. DTSCU351 -00557 DTSCU351 -00558 PERFORM P1320-FORMAT-OPO-ADDR THRU P1320-EXIT. DTSCU351 -00559 DTSCU351 -00560 MOVE SPACE TO WRK-TAD-ADDRESS. DTSCU351 -00561 DTSCU351 -00562 MOVE SPACE TO WRK-OPO-ADDRESS. DTSCU351 -00563 DTSCU351 -00564 PERFORM VARYING WRK-OCC FROM 1 BY 1 DTSCU351 -00565 UNTIL WRK-OCC > 3 DTSCU351 -00566 DTSCU351 -00567 SET WRK-CC-SKIP-LINE TO TRUE DTSCU351 -00568 DTSCU351 -00569 ADD 3 TO WRK-OCC GIVING WRK-OCC2 DTSCU351 -00570 PERFORM VARYING WRK-OCC1 FROM 1 BY 1 DTSCU351 -00571 UNTIL WRK-OCC1 > 6 DTSCU351 -00572 IF WRK-MAILING-LINE (WRK-OCC, WRK-OCC1) = SPACES DTSCU351 -00573 AND WRK-MAILING-LINE (WRK-OCC2, WRK-OCC1) = SPACES DTSCU351 -00574 CONTINUE DTSCU351 -00575 ELSE DTSCU351 -00576 MOVE WRK-MAILING-LINE (WRK-OCC, WRK-OCC1) DTSCU351 -00577 TO WRK-TAD-ADDRESS DTSCU351 -00578 MOVE WRK-MAILING-LINE (WRK-OCC2, WRK-OCC1) DTSCU351 -00579 TO WRK-OPO-ADDRESS DTSCU351 -00580 ADD 1 TO TS-LINE-CNT DTSCU351 -00581 MOVE WRK-CC TO TS-CC (TS-LINE-CNT) DTSCU351 -00582 SET WRK-CC-NONE TO TRUE DTSCU351 -00583 MOVE WRK-LINE-ADDRESS TO TS-TEXT (TS-LINE-CNT) DTSCU351 -00584 PERFORM P1301-LINE-CNT THRU P1301-EXIT DTSCU351 -00585 END-IF DTSCU351 -00586 END-PERFORM DTSCU351 -00587 END-PERFORM. DTSCU351 -00588 P1300-EXIT. EXIT. DTSCU351 -00589 DTSCU351 -00590 P1301-LINE-CNT. DTSCU351 -00591 IF TS-CC-SKIP-LINE (TS-LINE-CNT) DTSCU351 -00592 ADD +2 TO LINE-CNT DTSCU351 -00593 ELSE DTSCU351 -00594 ADD +1 TO LINE-CNT. DTSCU351 -00595 P1301-EXIT. DTSCU351 -00596 EXIT. DTSCU351 -00597 /*****************************************************************DTSCU351 -00598 * READ AND FORMAT FROM TAD (REPETITIVE CODE USED FOR READABLILITY)DTSCU351 -00599 ******************************************************************DTSCU351 -00600 P1310-FORMAT-TAX-ADDR. DTSCU351 -00601 MOVE LOW-VALUES TO MTAD-KEY-AREA. DTSCU351 -00602 MOVE MPRF-EMP-NO TO MTAD-EMP-NO. DTSCU351 -00603 SET MTAD-TAD-88 TO TRUE. DTSCU351 -00604 MOVE MTAD-KEY-AREA TO MSKL-KEY-AREA. DTSCU351 -00605 PERFORM S810-START-BROWSE THRU S810-EXIT. DTSCU351 -00606 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00607 GO TO P1310-EXIT DTSCU351 -00608 END-IF. DTSCU351 -00609 MOVE +0 TO WRK-OCC. DTSCU351 -00610 PERFORM P1315-FORMAT THRU P1315-EXIT. DTSCU351 -00611 DTSCU351 -00612 PERFORM S810-READ-NEXT THRU S810-EXIT. DTSCU351 -00613 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00614 GO TO P1310-EXIT DTSCU351 -00615 END-IF. DTSCU351 -00616 PERFORM P1315-FORMAT THRU P1315-EXIT. DTSCU351 -00617 DTSCU351 -00618 PERFORM S810-READ-NEXT THRU S810-EXIT. DTSCU351 -00619 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00620 GO TO P1310-EXIT DTSCU351 -00621 END-IF. DTSCU351 -00622 PERFORM P1315-FORMAT THRU P1315-EXIT. DTSCU351 -00623 DTSCU351 -00624 PERFORM S810-END-BROWSE THRU S810-EXIT. DTSCU351 -00625 DTSCU351 -00626 P1310-EXIT. DTSCU351 -00627 EXIT. DTSCU351 -00628 EJECT DTSCU351 -00629 DTSCU351 -00630 /*****************************************************************DTSCU351 -00631 * DTSCU351 -00632 ******************************************************************DTSCU351 -00633 P1315-FORMAT. DTSCU351 -00634 ADD +1 TO WRK-OCC. DTSCU351 -00635 MOVE MSKL-REC TO MTAD-REC. DTSCU351 -00636 PERFORM S112-FORMAT-TAD THRU S112-EXIT. DTSCU351 -00637 DTSCU351 -00638 IF MTAD-VOICE = SPACES DTSCU351 -00639 MOVE SPACES TO WRK-TELEPHONE DTSCU351 -00640 ELSE DTSCU351 -00641 MOVE '(' TO WRK-TELEPHONE-LEFT DTSCU351 -00642 MOVE MTAD-VOICE-AREA-CD TO WRK-TELEPHONE-AREA-CD DTSCU351 -00643 MOVE ') ' TO WRK-TELEPHONE-RIGHT DTSCU351 -00644 MOVE MTAD-VOICE-PREFIX TO WRK-TELEPHONE-PREFIX DTSCU351 -00645 MOVE '-' TO WRK-TELPHONE-DASH DTSCU351 -00646 MOVE MTAD-VOICE-SUFFIX TO WRK-TELEPHONE-SUFFIX DTSCU351 -00647 IF MTAD-VOICE-EXT NOT = SPACES DTSCU351 -00648 MOVE ' EXT. ' TO WRK-TELEPHONE-EXT-LBL DTSCU351 -00649 MOVE MTAD-VOICE-EXT TO WRK-TELEPHONE-EXT DTSCU351 -00650 ELSE DTSCU351 -00651 MOVE SPACES TO WRK-TELEPHONE-EXT-LBL DTSCU351 -00652 MOVE SPACES TO WRK-TELEPHONE-EXT DTSCU351 -00653 END-IF. DTSCU351 -00654 MOVE L112-MAILING-ADDRESS TO WRK-ADDRESS(WRK-OCC). DTSCU351 -00655 MOVE WRK-TELEPHONE TO WRK-MAILING-LINE(WRK-OCC, 6).DTSCU351 -00656 PERFORM P1330-SCRUNCH THRU P1330-EXIT. DTSCU351 -00657 P1315-EXIT. DTSCU351 -00658 EXIT. DTSCU351 -00659 DTSCU351 -00660 /*****************************************************************DTSCU351 -00661 * READ AND FORMAT FROM OPO (REPETITIVE CODE USED FOR READABLILITY)DTSCU351 -00662 ******************************************************************DTSCU351 -00663 P1320-FORMAT-OPO-ADDR. DTSCU351 -00664 MOVE LOW-VALUES TO MOPO-KEY-AREA. DTSCU351 -00665 MOVE MPRF-EMP-NO TO MOPO-EMP-NO. DTSCU351 -00666 SET MOPO-OPO-88 TO TRUE. DTSCU351 -00667 MOVE MOPO-KEY-AREA TO MSKL-KEY-AREA. DTSCU351 -00668 PERFORM S810-START-BROWSE THRU S810-EXIT. DTSCU351 -00669 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00670 GO TO P1320-EXIT DTSCU351 -00671 END-IF. DTSCU351 -00672 DTSCU351 -00673 MOVE +3 TO WRK-OCC. DTSCU351 -00674 PERFORM P1325-FORMAT THRU P1325-EXIT. DTSCU351 -00675 DTSCU351 -00676 PERFORM S810-READ-NEXT THRU S810-EXIT. DTSCU351 -00677 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00678 GO TO P1320-EXIT DTSCU351 -00679 END-IF. DTSCU351 -00680 PERFORM P1325-FORMAT THRU P1325-EXIT. DTSCU351 -00681 DTSCU351 -00682 PERFORM S810-READ-NEXT THRU S810-EXIT. DTSCU351 -00683 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00684 GO TO P1320-EXIT DTSCU351 -00685 END-IF. DTSCU351 -00686 PERFORM P1325-FORMAT THRU P1325-EXIT. DTSCU351 -00687 DTSCU351 -00688 PERFORM S810-END-BROWSE THRU S810-EXIT. DTSCU351 -00689 DTSCU351 -00690 P1320-EXIT. DTSCU351 -00691 EXIT. DTSCU351 -00692 EJECT DTSCU351 -00693 /*****************************************************************DTSCU351 -00694 * DTSCU351 -00695 ******************************************************************DTSCU351 -00696 P1325-FORMAT. DTSCU351 -00697 ADD +1 TO WRK-OCC. DTSCU351 -00698 MOVE MSKL-REC TO MOPO-REC. DTSCU351 -00699 IF MOPO-VOICE = SPACES DTSCU351 -00700 MOVE SPACES TO WRK-TELEPHONE DTSCU351 -00701 ELSE DTSCU351 -00702 MOVE '(' TO WRK-TELEPHONE-LEFT DTSCU351 -00703 MOVE MOPO-VOICE-AREA-CD TO WRK-TELEPHONE-AREA-CD DTSCU351 -00704 MOVE ') ' TO WRK-TELEPHONE-RIGHT DTSCU351 -00705 MOVE MOPO-VOICE-PREFIX TO WRK-TELEPHONE-PREFIX DTSCU351 -00706 MOVE '-' TO WRK-TELPHONE-DASH DTSCU351 -00707 MOVE MOPO-VOICE-SUFFIX TO WRK-TELEPHONE-SUFFIX DTSCU351 -00708 IF MOPO-VOICE-EXT NOT = SPACES DTSCU351 -00709 MOVE ' EXT. ' TO WRK-TELEPHONE-EXT-LBL DTSCU351 -00710 MOVE MOPO-VOICE-EXT TO WRK-TELEPHONE-EXT DTSCU351 -00711 ELSE DTSCU351 -00712 MOVE SPACES TO WRK-TELEPHONE-EXT-LBL DTSCU351 -00713 MOVE SPACES TO WRK-TELEPHONE-EXT DTSCU351 -00714 END-IF. DTSCU351 -00715 DTSCU351 -00716 IF MOPO-ADDRESS = SPACES DTSCU351 -00717 MOVE MOPO-NAME TO L071-NAM DTSCU351 -00718 PERFORM S071-FROM-LAST-NAME-FIRST THRU S071-EXIT DTSCU351 -00719 MOVE SPACE TO WRK-ADDRESS (WRK-OCC) DTSCU351 -00720 IF MOPO-TITLE = SPACES DTSCU351 -00721 MOVE L071-NAM TO WRK-MAILING-LINE (WRK-OCC 1) DTSCU351 -00722 ELSE DTSCU351 -00723 STRING L071-NAM DELIMITED BY ' ' DTSCU351 -00724 ', ' DELIMITED BY SIZE DTSCU351 -00725 MOPO-TITLE DELIMITED BY ' ' DTSCU351 -00726 INTO DTSCU351 -00727 WRK-MAILING-LINE (WRK-OCC 1) DTSCU351 -00728 ELSE DTSCU351 -00729 PERFORM S112-FORMAT-OPO THRU S112-EXIT DTSCU351 -00730 MOVE L112-MAILING-ADDRESS TO WRK-ADDRESS (WRK-OCC). DTSCU351 -00731 DTSCU351 -00732 MOVE WRK-TELEPHONE TO WRK-MAILING-LINE(WRK-OCC, 6).DTSCU351 -00733 PERFORM P1330-SCRUNCH THRU P1330-EXIT. DTSCU351 -00734 P1325-EXIT. DTSCU351 -00735 EXIT. DTSCU351 -00736 DTSCU351 -00737 /*****************************************************************DTSCU351 -00738 * BUBBLE SORT THE BLANK LINES TO THE BOTTOM OF EACH GROUP DTSCU351 -00739 ******************************************************************DTSCU351 -00740 P1330-SCRUNCH. DTSCU351 -00741 SET WRK-BLANK-LINE-YES-88 TO TRUE. DTSCU351 -00742 DTSCU351 -00743 PERFORM DTSCU351 -00744 UNTIL WRK-BLANK-LINE-NO-88 DTSCU351 -00745 SET WRK-BLANK-LINE-NO-88 TO TRUE DTSCU351 -00746 DTSCU351 -00747 PERFORM VARYING WRK-OCC1 FROM 1 BY 1 DTSCU351 -00748 UNTIL WRK-OCC1 > 5 DTSCU351 -00749 DTSCU351 -00750 COMPUTE WRK-OCC2 = WRK-OCC1 + 1 DTSCU351 -00751 DTSCU351 -00752 IF WRK-MAILING-LINE(WRK-OCC, WRK-OCC1) = SPACES DTSCU351 -00753 AND WRK-MAILING-LINE(WRK-OCC, WRK-OCC2) NOT = SPACES DTSCU351 -00754 SET WRK-BLANK-LINE-YES-88 TO TRUE DTSCU351 -00755 MOVE WRK-MAILING-LINE(WRK-OCC, WRK-OCC2) DTSCU351 -00756 TO WRK-MAILING-LINE(WRK-OCC, WRK-OCC1) DTSCU351 -00757 MOVE SPACES TO WRK-MAILING-LINE(WRK-OCC, WRK-OCC2) DTSCU351 -00758 END-IF DTSCU351 -00759 DTSCU351 -00760 END-PERFORM DTSCU351 -00761 DTSCU351 -00762 END-PERFORM. DTSCU351 -00763 P1330-EXIT. DTSCU351 -00764 EXIT. DTSCU351 -00765 /*****************************************************************DTSCU351 -00766 * DTSCU351 -00767 ******************************************************************DTSCU351 -00768 P1400-CLAIMANT. DTSCU351 -00769 IF MFAS-CLAIMANT-SSN IS NOT EQUAL TO ZERO DTSCU351 -00770 ADD +1 TO TS-LINE-CNT DTSCU351 -00771 SET TS-CC-SKIP-LINE(TS-LINE-CNT) TO TRUE DTSCU351 -00772 MOVE MFAS-CLAIMANT-SSN TO WRK-CLAIMANT-SSN DTSCU351 -00773 MOVE MFAS-CLAIMANT-NAME TO WRK-CLAIMANT-NAME DTSCU351 -00774 MOVE WRK-LINE-RE TO TS-TEXT(TS-LINE-CNT) DTSCU351 -00775 ADD +2 TO LINE-CNT. DTSCU351 -00776 P1400-EXIT. DTSCU351 -00777 EXIT. DTSCU351 -00778 /*****************************************************************DTSCU351 -00779 * DTSCU351 -00780 ******************************************************************DTSCU351 -00781 P1500-REL-EMP. DTSCU351 -00782 IF MFAS-RELATED-EMP-NO NOT EQUAL TO ZERO DTSCU351 -00783 MOVE LOW-VALUES TO MPRF-KEY-AREA DTSCU351 -00784 MOVE MFAS-RELATED-EMP-NO TO MPRF-EMP-NO DTSCU351 -00785 SET MPRF-PRF-88 TO TRUE DTSCU351 -00786 MOVE MPRF-KEY-AREA TO MSKL-KEY-AREA DTSCU351 -00787 PERFORM S810-READ THRU S810-EXIT DTSCU351 -00788 ADD +1 TO TS-LINE-CNT DTSCU351 -00789 SET TS-CC-SKIP-LINE(TS-LINE-CNT) TO TRUE DTSCU351 -00790 MOVE MFAS-RELATED-EMP-NO TO WRK-RELATED-EMP-NO DTSCU351 -00791 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351 -00792 MOVE '--NAME NO LONGER ON FILE--' DTSCU351 -00793 TO WRK-RELATED-EMP-NAME DTSCU351 -00794 ELSE DTSCU351 -00795 MOVE MSKL-REC TO MPRF-REC DTSCU351 -00796 MOVE MPRF-BUSINESS-NAME TO WRK-RELATED-EMP-NAME DTSCU351 -00797 END-IF DTSCU351 -00798 MOVE WRK-LINE-RELATED-EMP TO TS-TEXT(TS-LINE-CNT) DTSCU351 -00799 ADD +2 TO LINE-CNT. DTSCU351 -00800 P1500-EXIT. DTSCU351 -00801 EXIT. DTSCU351 -00802 /*****************************************************************DTSCU351 -00803 * DTSCU351 -00804 ******************************************************************DTSCU351 -00805 P1600-FAS-TEXT. DTSCU351 -00806 DTSCU351 -00807 ADD +1 TO TS-LINE-CNT. DTSCU351 -00808 MOVE ' ' TO TS-CC(TS-LINE-CNT). DTSCU351 -00809 MOVE MFAS-TEXT(MFAS-TEXT-IDX) TO WRK-TEXT. DTSCU351 -00810 MOVE WRK-LINE-TEXT TO TS-TEXT(TS-LINE-CNT). DTSCU351 -00811 ADD +1 TO LINE-CNT. DTSCU351 -00812 DTSCU351 -00813 P1600-EXIT. DTSCU351 -00814 EXIT. DTSCU351 -00815 DTSCU351 -00816 /*****************************************************************DTSCU351 -00817 * DTSCU351 -00818 ******************************************************************DTSCU351 -00819 P2000-COPY-IND. DTSCU351 -00820 DTSCU351 -00821 ADD +1 TO WRK-COPY-CNT. DTSCU351 -00822 DTSCU351 -00823 P2000-EXIT. DTSCU351 -00824 EXIT. DTSCU351 -00825 DTSCU351 -00826 /*****************************************************************DTSCU351 -00827 * GETS THE POINTER TO THE END OF THE PAGE DTSCU351 -00828 ******************************************************************DTSCU351 -00829 P7000-COPY-LINE. DTSCU351 -00830 PERFORM P7100-LOOP THRU P7100-EXIT DTSCU351 -00831 UNTIL LINE-CNT >= 60. DTSCU351 -00832 P7000-EXIT. DTSCU351 -00833 EXIT. DTSCU351 -00834 DTSCU351 -00835 P7100-LOOP. DTSCU351 -00836 ADD +1 TO LINE-CNT. DTSCU351 -00837 ADD +1 TO TS-LINE-CNT. DTSCU351 -00838 MOVE SPACE TO TS-CC(TS-LINE-CNT) DTSCU351 -00839 TS-TEXT(TS-LINE-CNT). DTSCU351 -00840 P7100-EXIT. DTSCU351 -00841 EXIT. DTSCU351 -00842 DTSCU351 -00843 P8000-TS-WRITE. DTSCU351 -00844 MOVE WRK-LINE-COPY TO TS-TEXT(TS-LINE-CNT). DTSCU351 -00845 PERFORM P8100-TS-LOOP THRU P8100-EXIT DTSCU351 -00846 VARYING WRK-OCC FROM 1 BY 1 DTSCU351 -00847 UNTIL WRK-OCC > TS-LINE-CNT DTSCU351 -00848 OR L351-PRINT-FAILED. DTSCU351 -00849 P8000-EXIT. DTSCU351 -00850 EXIT. DTSCU351 -00851 EJECT DTSCU351 -00852 /*****************************************************************DTSCU351 -00853 * DTSCU351 -00854 ******************************************************************DTSCU351 -00855 P8100-TS-LOOP. DTSCU351 -00856 MOVE TS-CC(WRK-OCC) TO XPTS-CC. DTSCU351 -00857 MOVE TS-TEXT(WRK-OCC) TO XPTS-DATA. DTSCU351 -00858 MOVE WRK-OCC TO L829-ITEM-NO. DTSCU351 -00859 PERFORM S829-WRITE-ITEM THRU S829-EXIT. DTSCU351 -00860 IF NOT L829-OK-88 DTSCU351 -00861 SET L351-PRINT-FAILED TO TRUE. DTSCU351 -00862 DTSCU351 -00863 P8100-EXIT. DTSCU351 -00864 EXIT. DTSCU351 -00865 /*****************************************************************DTSCU351 -00866 * SERVICE UTILITIES DTSCU351 -00867 ******************************************************************DTSCU351 -00868 S001-FROM-FED-8. DTSCU351 -00869 SET L001-FROM-FED-8 TO TRUE. DTSCU351 -00870 GO TO S001-DATE-EDIT. DTSCU351 -00871 DTSCU351 -00872 S001-DATE-EDIT. DTSCU351 -00873 EXEC CICS DTSCU351 -00874 LINK DTSCU351 -00875 PROGRAM ('MACCU001') DTSCU351 -00876 COMMAREA (L001-COMM-AREA) DTSCU351 -00877 LENGTH (L001-LENGTH) DTSCU351 -00878 END-EXEC. DTSCU351 -00879 S001-EXIT. DTSCU351 -00880 EXIT. DTSCU351 -00881 DTSCU351 -00882 S004-FROM-5. DTSCU351 -00883 SET L004-FROM-5 TO TRUE. DTSCU351 -00884 GO TO S004-QTR-EDIT. DTSCU351 -00885 DTSCU351 -00886 S004-QTR-EDIT. DTSCU351 -00887 EXEC CICS DTSCU351 -00888 LINK DTSCU351 -00889 PROGRAM ('MACCU004') DTSCU351 -00890 COMMAREA (L004-COMM-AREA) DTSCU351 -00891 LENGTH (L004-LENGTH) DTSCU351 -00892 END-EXEC. DTSCU351 -00893 S004-EXIT. DTSCU351 -00894 EXIT. DTSCU351 -00895 DTSCU351 -00896 S056-RATE. DTSCU351 -00897 EXEC CICS DTSCU351 -00898 LINK DTSCU351 -00899 PROGRAM ('MACCU056') DTSCU351 -00900 COMMAREA (L056-COMM-AREA) DTSCU351 -00901 LENGTH (L056-LENGTH) DTSCU351 -00902 END-EXEC. DTSCU351 -00903 S056-EXIT. DTSCU351 -00904 EXIT. DTSCU351 -00905 DTSCU351 -00906 S062-AUDIT-EDIT. DTSCU351 -00907 EXEC CICS DTSCU351 -00908 LINK DTSCU351 -00909 PROGRAM ('MACCU062') DTSCU351 -00910 COMMAREA (L062-COMM-AREA) DTSCU351 -00911 LENGTH (L062-LENGTH) DTSCU351 -00912 END-EXEC. DTSCU351 -00913 S062-EXIT. DTSCU351 -00914 EXIT. DTSCU351 -00915 DTSCU351 -00916 S063-ASSIGN-TYPE. DTSCU351 -00917 EXEC CICS DTSCU351 -00918 LINK DTSCU351 -00919 PROGRAM ('MACCU063') DTSCU351 -00920 COMMAREA (L063-COMM-AREA) DTSCU351 -00921 LENGTH (L063-LENGTH) DTSCU351 -00922 END-EXEC. DTSCU351 -00923 S063-EXIT. DTSCU351 -00924 EXIT. DTSCU351 -00925 DTSCU351 -00926 S071-FROM-LAST-NAME-FIRST. DTSCU351 -00927 SET L071-FROM-LAST-NAME-FIRST TO TRUE. DTSCU351 -00928 GO TO S071-FORMAT-NAME. DTSCU351 -00929 DTSCU351 -00930 S071-FORMAT-NAME. DTSCU351 -00931 EXEC CICS DTSCU351 -00932 LINK DTSCU351 -00933 PROGRAM ('MACCU071') DTSCU351 -00934 COMMAREA (L071-COMM-AREA) DTSCU351 -00935 LENGTH (L071-LENGTH) DTSCU351 -00936 END-EXEC. DTSCU351 -00937 S071-EXIT. DTSCU351 -00938 EXIT. DTSCU351 -00939 DTSCU351 -00940 S082-OP-ID. DTSCU351 -00941 EXEC CICS DTSCU351 -00942 LINK DTSCU351 -00943 PROGRAM ('MACCU082') DTSCU351 -00944 COMMAREA (L082-COMM-AREA) DTSCU351 -00945 LENGTH (L082-LENGTH) DTSCU351 -00946 END-EXEC. DTSCU351 -00947 S082-EXIT. DTSCU351 -00948 EXIT. DTSCU351 -00949 DTSCU351 -00950 S112-FORMAT-TAD. DTSCU351 -00951 SET L112-TAD-ADDR-88 TO TRUE. DTSCU351 -00952 SET L112-ANCHOR-FIRST-88 TO TRUE. DTSCU351 -00953 IF MTAD-ID-NO = +1 DTSCU351 -00954 MOVE MPRF-BUSINESS-NAME TO L112-BUSINESS-NAME DTSCU351 -00955 ELSE DTSCU351 -00956 MOVE SPACES TO L112-BUSINESS-NAME. DTSCU351 -00957 MOVE MTAD-MAIL-DELIV-IND TO L112-MAIL-DELIV-IND. DTSCU351 -00958 MOVE SPACES TO L112-NAME DTSCU351 -00959 L112-TITLE. DTSCU351 -00960 MOVE MTAD-ADDRESS TO L112-ADDRESS. DTSCU351 -00961 GO TO S112-FORMAT-ADDRESS. DTSCU351 -00962 DTSCU351 -00963 S112-FORMAT-OPO. DTSCU351 -00964 SET L112-OPO-ADDR-88 TO TRUE. DTSCU351 -00965 SET L112-ANCHOR-FIRST-88 TO TRUE. DTSCU351 -00966 MOVE SPACES TO L112-BUSINESS-NAME. DTSCU351 -00967 MOVE MOPO-MAIL-DELIV-IND TO L112-MAIL-DELIV-IND. DTSCU351 -00968 MOVE MOPO-NAME TO L112-NAME. DTSCU351 -00969 MOVE MOPO-TITLE TO L112-TITLE. DTSCU351 -00970 MOVE MOPO-ADDRESS TO L112-ADDRESS. DTSCU351 -00971 GO TO S112-FORMAT-ADDRESS. DTSCU351 -00972 DTSCU351 -00973 S112-FORMAT-ADDRESS. DTSCU351 -00974 EXEC CICS DTSCU351 -00975 LINK DTSCU351 -00976 PROGRAM ('MACCU112') DTSCU351 -00977 COMMAREA (L112-COMM-AREA) DTSCU351 -00978 LENGTH (L112-LENGTH) DTSCU351 -00979 END-EXEC. DTSCU351 -00980 S112-EXIT. DTSCU351 -00981 EXIT. DTSCU351 -00982 DTSCU351 -00983 S119-AGENCY-FACTS. DTSCU351 -00984 SET L119-REQ-CAPS-88 TO TRUE. DTSCU351 -00985 SET L119-REQ-NO-UNIT-88 TO TRUE. DTSCU351 -00986 EXEC CICS DTSCU351 -00987 LINK DTSCU351 -00988 PROGRAM ('MACCU119') DTSCU351 -00989 COMMAREA (L119-COMM-AREA) DTSCU351 -00990 LENGTH (L119-LENGTH) DTSCU351 -00991 END-EXEC. DTSCU351 -00992 S119-EXIT. DTSCU351 -00993 EXIT. DTSCU351 -00994 DTSCU351 -00995 S357-LINK-PRINT. DTSCU351 -00996 SET L357-EJECT-PAGE-88 TO TRUE. DTSCU351 -00997 DTSCU351 -00998 EXEC CICS DTSCU351 -00999 LINK DTSCU351 -01000 PROGRAM ('MACCU357') DTSCU351 -01001 COMMAREA (L357-COMM-AREA) DTSCU351 -01002 LENGTH (L357-LENGTH) DTSCU351 -01003 END-EXEC. DTSCU351 -01004 S357-EXIT. DTSCU351 -01005 EXIT. DTSCU351 -01006 DTSCU351 -01007 S810-START-BROWSE. DTSCU351 -01008 SET L810-START-BROWSE-88 TO TRUE DTSCU351 -01009 GO TO S810-MSTR-IO. DTSCU351 -01010 DTSCU351 -01011 S810-END-BROWSE. DTSCU351 -01012 SET L810-END-BROWSE-88 TO TRUE DTSCU351 -01013 GO TO S810-MSTR-IO. DTSCU351 -01014 DTSCU351 -01015 S810-READ-NEXT. DTSCU351 -01016 SET L810-READ-NEXT-88 TO TRUE DTSCU351 -01017 GO TO S810-MSTR-IO. DTSCU351 -01018 DTSCU351 -01019 S810-READ. DTSCU351 -01020 SET L810-READ-88 TO TRUE DTSCU351 -01021 GO TO S810-MSTR-IO. DTSCU351 -01022 DTSCU351 -01023 S810-MSTR-IO. DTSCU351 -01024 EXEC CICS DTSCU351 -01025 LINK DTSCU351 -01026 PROGRAM ('MACCU810') DTSCU351 -01027 COMMAREA (L810-COMM-AREA) DTSCU351 -01028 LENGTH (L810-LENGTH) DTSCU351 -01029 END-EXEC. DTSCU351 -01030 S810-EXIT. DTSCU351 -01031 EXIT. DTSCU351 -01032 DTSCU351 -01033 S829-DELETE-QUEUE. DTSCU351 -01034 DTSCU351 -01035 SET L829-DELETE-QUEUE-88 TO TRUE. DTSCU351 -01036 GO TO S829-TS-IO. DTSCU351 -01037 DTSCU351 -01038 S829-WRITE-ITEM. DTSCU351 -01039 SET L829-WRITE-88 TO TRUE. DTSCU351 -01040 GO TO S829-TS-IO. DTSCU351 -01041 DTSCU351 -01042 S829-TS-IO. DTSCU351 -01043 EXEC CICS DTSCU351 -01044 LINK DTSCU351 -01045 PROGRAM ('MACCU829') DTSCU351 -01046 COMMAREA (L829-COMM-AREA) DTSCU351 -01047 LENGTH (L829-COMM-AREA-LENGTH) DTSCU351 -01048 END-EXEC. DTSCU351 -01049 S829-EXIT. DTSCU351 -01050 EXIT. DTSCU351 -01051 DTSCU351 -01052 S899-ABEND. DTSCU351 -01053 EXEC CICS DTSCU351 -01054 ABEND DTSCU351 -01055 ABCODE (WRK-ABEND-CODE) DTSCU351 -01056 END-EXEC. DTSCU351 -01057 S899-EXIT. DTSCU351 -01058 EXIT. DTSCU351 diff --git a/CICSFiles.txt b/CICSFiles.txt index a3fe8a9..89e1054 100644 --- a/CICSFiles.txt +++ b/CICSFiles.txt @@ -1,4 +1,4 @@ -E:\Faizan_Folder\DUTAS_DEV_UPDATE\DUTAS\CICS\DTSCSL1.cob +E:\Faizan_Folder\DUTAS_DEV_UPDATE\DUTAS\CICS\RCSIGNON.cob diff --git a/CompileOptions_withoutDefinit.txt b/CompileOptions_withoutDefinit.txt new file mode 100644 index 0000000..1051910 --- /dev/null +++ b/CompileOptions_withoutDefinit.txt @@ -0,0 +1,8 @@ +-IgnoreParseError=TRUE +-OutputDir=E:\Faizan_Folder\DUTAS_DEV_UPDATE\bin\CICS\dll +-RemoveFileVerifyFailed=FALSE +-MaxMem=1000 +-IncludeSearchPath=E:\Faizan_Folder\DUTAS_DEV_UPDATE/DUTAS/Copybook +-IncludeExtension=.txt +-StringRuntimeEncoding=037 +