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