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