00001 IDENTIFICATION DIVISION. 10/06/98 00002 PROGRAM-ID. DTSCU075. DTSCU075 00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV003 00004 DATE-WRITTEN. OCTOBER 1998. CL**2 00005 DATE-COMPILED. DTSCU075 00006 SKIP3 DTSCU075 00007 ***** DTSCU075 00008 * DTSCU075 00009 * FUNCTION: COOPERATING AGENCY ADDRESS LOOKUP. DTSCU075 00010 * DTSCU075 00011 * DTSCU075 00012 * MODIFICATION LOG: DTSCU075 00013 * DTSCU075 00014 * 10/06/1998 INITIAL DEVELOPMENT. MODIFIED FROM MACCU075. CL**2 00015 * WORK ORDER: PROGRAMMER: GD CL**2 00016 * DTSCU075 00017 * XX/XX/XXXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CL**2 00018 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CL**2 00019 * WORK ORDER: PROGRAMMER: XXX CL**2 00020 * DTSCU075 00021 * DTSCU075 00022 * DESCRIPTION: DTSCU075 00023 * DTSCU075 00024 * DTSCU075 LOOKS UP A COOPERATING AGENCY ADDRES. CL**2 00025 * DTSCU075 00026 * USE THE INFOMATION IN DTSIC075 TO CONVERT L075-LOOKUP-STATE CL**3 00027 * FROM POSTAL CODE ALPHA TO FIPS. DTSCU075 00028 * DTSCU075 00029 * READ THE MTAA RECORD FOR EMPLOYER NUMBER 11**00, WHERE ** IS CL**3 00030 * THE STATE FIPS CODE AND MTAA-ID-NO IS EQUAL TO ONE. CL**3 00031 * DTSCU075 00032 * RETURN L075-NAME AND L075-ADDRESS FROM THE MTAA RECORD. CL**3 00033 * DTSCU075 00034 * IF L075-LOOKUP-STATE IS NOT FOUND IN DTSIC075, THEN CL**3 00035 * RETURN L075-ADDR-NOT-FOUND-88. DTSCU075 00036 * DTSCU075 00037 * IF A MASTER FILE RECORD IS NOT FOUND, THEN RETURN DTSCU075 00038 * L075-ADDR-NOT-FOUND-88. DTSCU075 00039 * DTSCU075 00040 * IF THE MASTER FILE IS NOT AVAILABLE, THEN RETURN DTSCU075 00041 * L075-FILE-CLOSED-88. DTSCU075 00042 * DTSCU075 00043 ***** DTSCU075 00044 SKIP2 DTSCU075 00045 ENVIRONMENT DIVISION. DTSCU075 00046 SKIP1 DTSCU075 00047 DATA DIVISION. DTSCU075 00048 SKIP1 DTSCU075 00049 WORKING-STORAGE SECTION. DTSCU075 000495 77 PAN-VALET PICTURE X(24) VALUE '003DTSCU075 10/06/98'. DTSCU075 00050 SKIP1 DTSCU075 00051 01 WRK-AREA. DTSCU075 00052 05 WRK-ABEND-CODE PIC X(04) VALUE 'U075'. DTSCU075 00053 05 WRK-RESP-CODE PIC S9(08) COMP. DTSCU075 00054 05 WRK-EMPNO-X. DTSCU075 00055 10 FILLER PIC X(02) VALUE '11'. CL**3 00056 10 WRK-FIPS PIC X(02). DTSCU075 00057 10 FILLER PIC X(02) VALUE '00'. CL**3 00058 05 WRK-EMPNO-9 REDEFINES WRK-EMPNO-X DTSCU075 00059 PIC 9(06). DTSCU075 00060 EJECT DTSCU075 00061 01 C075-LITERALS. DTSCU075 00062 ++INCLUDE DTSIC075 CL**3 00063 EJECT DTSCU075 00064 01 L810-COMM-AREA. DTSCU075 00065 05 L810-CONTROL-AREA. DTSCU075 00066 ++INCLUDE DTSIL810 CL**3 00067 SKIP3 DTSCU075 00068 05 MSKL-REC. DTSCU075 00069 ++INCLUDE DTSIMSKL CL**3 00070 SKIP3 DTSCU075 00071 01 MTAA-REC. DTSCU075 00072 ++INCLUDE DTSIMTAA CL**3 00073 EJECT DTSCU075 00074 LINKAGE SECTION. DTSCU075 00075 SKIP3 DTSCU075 00076 01 DFHCOMMAREA. DTSCU075 00077 ++INCLUDE DTSIL075 CL**3 00078 EJECT DTSCU075 00079 PROCEDURE DIVISION. DTSCU075 00080 SKIP2 DTSCU075 00081 DTSCU075-MAIN. CL**3 00082 SET L075-ADDR-NOT-FOUND-88 TO TRUE DTSCU075 00083 MOVE SPACE TO L075-NAME DTSCU075 00084 L075-ADDRESS DTSCU075 00085 L075-MSG-AREA. DTSCU075 00086 SKIP1 DTSCU075 00087 IF NOT L075-LOOKUP-ADDR-88 DTSCU075 00088 PERFORM S899-ABEND THRU S899-EXIT. DTSCU075 00089 SKIP1 DTSCU075 00090 SET C075-IDX TO 1. DTSCU075 00091 SEARCH C075-LITERAL-GROUP DTSCU075 00092 VARYING C075-IDX DTSCU075 00093 AT END DTSCU075 00094 GO TO DTSCU075-EXIT CL**3 00095 WHEN C075-POSTAL-ST (C075-IDX) = L075-LOOKUP-STATE DTSCU075 00096 MOVE C075-FIPS-ST (C075-IDX) TO WRK-FIPS. CL**3 00097 DTSCU075 00098 MOVE LOW-VALUES TO MTAA-KEY-AREA CL**3 00099 MOVE WRK-EMPNO-9 TO MTAA-EMP-NO CL**3 00100 SET MTAA-TAA-88 TO TRUE CL**3 00101 MOVE +1 TO MTAA-ID-NO CL**3 00102 MOVE MTAA-KEY-AREA TO MSKL-KEY-AREA CL**3 00103 PERFORM S810-READ THRU S810-EXIT CL**3 00104 IF L810-OK-88 CL**3 00105 MOVE MSKL-REC TO MTAA-REC CL**3 00106 DTSCU075 00107 SET L075-ADDR-FOUND-88 TO TRUE CL**3 00108 MOVE MTAA-NAME TO L075-NAME CL**3 00109 MOVE MTAA-ADDRESS TO L075-ADDRESS CL**3 00110 END-IF. CL**3 00111 SKIP2 DTSCU075 00112 DTSCU075-EXIT. CL**3 00113 SKIP1 DTSCU075 00114 EXEC CICS DTSCU075 00115 RETURN DTSCU075 00116 END-EXEC. DTSCU075 00117 SKIP2 DTSCU075 00118 GOBACK. DTSCU075 00119 EJECT DTSCU075 00120 EJECT DTSCU075 00121 S810-READ. DTSCU075 00122 SET L810-READ-88 TO TRUE. DTSCU075 00123 GO TO S810-MSTR-IO. DTSCU075 00124 SKIP1 DTSCU075 00125 S810-MSTR-IO. DTSCU075 00126 SKIP1 DTSCU075 00127 EXEC CICS DTSCU075 00128 LINK DTSCU075 00129 PROGRAM('DTSCU810') CL**3 00130 COMMAREA(L810-COMM-AREA) DTSCU075 00131 END-EXEC. DTSCU075 00132 SKIP1 DTSCU075 00133 IF L810-FILE-CLOSED-88 DTSCU075 00134 SET L075-FILE-CLOSED-88 TO TRUE DTSCU075 00135 MOVE L810-MSG-AREA TO L075-MSG-AREA. DTSCU075 00136 S810-EXIT. DTSCU075 00137 EXIT. DTSCU075 00138 SKIP3 DTSCU075 00139 S899-ABEND. DTSCU075 00140 SKIP1 DTSCU075 00141 EXEC CICS DTSCU075 00142 ABEND DTSCU075 00143 ABCODE (WRK-ABEND-CODE) DTSCU075 00144 END-EXEC. DTSCU075 00145 SKIP1 DTSCU075 00146 S899-EXIT. DTSCU075 00147 EXIT. DTSCU075