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
