00001  IDENTIFICATION DIVISION.                                         12/14/09
00002  PROGRAM-ID.             DTSCU801.                                DTSCU801
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV008
00004  DATE-WRITTEN.           NOVEMBER 1991.                           DTSCU801
00005  DATE-COMPILED.                                                   DTSCU801
00006      SKIP3                                                        DTSCU801
00007 *****                                                             DTSCU801
00008 *                                                                 DTSCU801
00009 *    FUNCTION:  SECURITY EXTRACT.                                 DTSCU801
00010 *                                                                 DTSCU801
00011 *                                                                 DTSCU801
00012 *    MODIFICATION LOG:                                            DTSCU801
00013 *                                                                 DTSCU801
00014 *    11/05/91  INITIAL DEVELOPMENT.                               DTSCU801
00015 *              WORK ORDER:                      PROGRAMMER: TCL   DTSCU801
00016 *                                                                 DTSCU801
00017 *    04/01/94  MODIFIED FOR MONTANA.                              DTSCU801
00018 *              WORK ORDER:                      PROGRAMMER: TCL   DTSCU801
00019 *                                                                 DTSCU801
00020 *    08/12/1998  REVIEWED AND MODIFIED FOR DC.                    DTSCU801
00021 *                REFERENCE: DC DEVELOPMENT      PROGRAMMER: EHH   DTSCU801
00022 *                                                                 DTSCU801
00023 *    08/12/1998  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   DTSCU801
00024 *                XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   DTSCU801
00025 *                REFERENCE: XXXXXXXXXXXXXXX     PROGRAMMER: XXX   DTSCU801
00026 *                                                                 DTSCU801
00027 *                                                                 DTSCU801
00028 *    DESCRIPTION:                                                 DTSCU801
00029 *                                                                 DTSCU801
00030 *    DTSCU801 EXTRACTS SECURITY INFORMATION FROM A REFERENCE      DTSCU801
00031 *    FILE OPERATOR ID (FOPR) RECORD.                              DTSCU801
00032 *                                                                 DTSCU801
00033 *    THIS INFORMATION, IS PLACED IN LCCM-OP-AREA.                 DTSCU801
00034 *    IF THE REFERENCE FILE IS NOT AVAILABLE, NO                   DTSCU801
00035 *    OPERATOR RECORD EXISTS FOR THE CICS OPERATOR ID, OR THE      DTSCU801
00036 *    OPERATOR RECORD INDICATES THE OPERATOR DOES NOT HAVE         DTSCU801
00037 *    ACCESS TO THE TAX SYSTEM, THEN AN ERROR MESSAGE IS PLACED    DTSCU801
00038 *    IN LCCM-MSG-AREA.                                            DTSCU801
00039 *                                                                 DTSCU801
00040 *                                                                 DTSCU801
00041 *        OBTAIN THE CICS OPERATOR ID VIA A ASSIGN USERID          DTSCU801
00042 *        COMMAND.                                                 DTSCU801
00043 *                                                                 DTSCU801
00044 *        MOVE THE CICS OPERATOR ID TO LCCM-OP-ID.                 DTSCU801
00045 *                                                                 DTSCU801
00046 *        OBTAIN THE REFERENCE FILE OP ID RECORD FOR               DTSCU801
00047 *        LCCM-OP-ID.                                              DTSCU801
00048 *                                                                 DTSCU801
00049 *        IF REFERENCE FILE IS NOT AVAILABLE                       DTSCU801
00050 *            MOVE L831-MSG-AREA TO LCCM-MSG-AREA                  DTSCU801
00051 *        ELSE                                                     DTSCU801
00052 *        IF NO RECORD IS FOUND                                    DTSCU801
00053 *            MOVE EMSG-NO-TAX-ACCESS TO LCCM-MSG-AREA             DTSCU801
00054 *        ELSE                                                     DTSCU801
00055 *        IF OPERATOR DOES NOT HAVE ACCESS TO TAX SYSTEM           DTSCU801
00056 *            MOVE EMSG-NO-TAX-ACCESS TO LCCM-MSG-AREA             DTSCU801
00057 *        ELSE                                                     DTSCU801
00058 *            USE THE INFORMATION IN THE REFERENCE FILE            DTSCU801
00059 *            OPERATOR RECORD TO CONSTRUCT LCCM-OP-AREA.           DTSCU801
00060 *                                                                 DTSCU801
00061 *                                                                 DTSCU801
00062 *        NOTE:  AS OF 04/01/94, IF NO RECORD IS FOUND, THE        DTSCU801
00063 *               OPERATOR IS GIVEN ACCESS TO EVERYTHING.           DTSCU801
00064 *                                                                 DTSCU801
00065 *               THIS IS DONE TO FACILITATE INITIAL TESTING.       DTSCU801
00066 *                                                                 DTSCU801
00067 *****                                                             DTSCU801
00068      SKIP3                                                        DTSCU801
00069  ENVIRONMENT DIVISION.                                            DTSCU801
00070      SKIP3                                                        DTSCU801
00071  DATA DIVISION.                                                   DTSCU801
00072      SKIP3                                                        DTSCU801
00073  WORKING-STORAGE SECTION.                                         DTSCU801
000735 77  PAN-VALET PICTURE X(24) VALUE '008DTSCU801  12/14/09'.       DTSCU801
00074      SKIP3                                                        DTSCU801
00075  01  WRK-AREA.                                                    DTSCU801
00076      05  WRK-ABEND-CODE              PIC  X(04)  VALUE 'U801'.    DTSCU801
00077      05  WRK-RESP-CODE               PIC S9(08)  COMP.            DTSCU801
00078                                                                   DTSCU801
00079      05  WRK-CICS-OP-ID              PIC  X(08).                  DTSCU801
00080                                                                   DTSCU801
00081      05  TAX-SYSTEM-ACCESS-IND       PIC  X(01).                  DTSCU801
00082      SKIP3                                                        DTSCU801
00083  01  MSG-LITERALS.                                                DTSCU801
00084      05  EMSG-NO-TAX-ACCESS.                                      DTSCU801
00085          10  FILLER                  PIC  X(04)  VALUE 'E092'.    DTSCU801
00086          10  FILLER                  PIC  X(44)                   DTSCU801
00087            VALUE 'TAX SYSTEM ACCESS NOT ALLOWED FOR CICS USER '.  DTSCU801
00088          10  EMSG-OP-ID              PIC  X(08).                  DTSCU801
00089      EJECT                                                        DTSCU801
00090  01  L831-COMM-AREA.                                              DTSCU801
00091      05  L831-CONTROL-BLOCK.                                      DTSCU801
00092  ++INCLUDE  DTSIL831                                              DTSCU801
00093      SKIP3                                                        DTSCU801
00094      05  FSKL-REC.                                                DTSCU801
00095  ++INCLUDE  DTSIFSKL                                              DTSCU801
00096      SKIP3                                                        DTSCU801
00097      05  FOPR-REC REDEFINES FSKL-REC.                             DTSCU801
00098  ++INCLUDE  DTSIFOPR                                              DTSCU801
00099      EJECT                                                        DTSCU801
00100  LINKAGE SECTION.                                                 DTSCU801
00101      SKIP3                                                        DTSCU801
00102  01  DFHCOMMAREA.                                                 DTSCU801
00103  ++INCLUDE  DTSILCCM                                              DTSCU801
00104      EJECT                                                        DTSCU801
00105  PROCEDURE DIVISION.                                              DTSCU801
00106      SKIP2                                                        DTSCU801
00107      EXEC CICS                                                    DTSCU801
00108          ASSIGN                                                   DTSCU801
00109             USERID (WRK-CICS-OP-ID)                               DTSCU801
00110      END-EXEC.                                                    DTSCU801
00111      SKIP2                                                        DTSCU801
00112      MOVE WRK-CICS-OP-ID TO LCCM-OP-ID.                           DTSCU801
00113                                                                   DTSCU801
00114      PERFORM P1000-CONSTRUCT-OP-AREA THRU P1000-EXIT.             DTSCU801
00115                                                                   DTSCU801
00116      IF EIBTRNID = 'DTSC'                                         DTSCU801
00117          PERFORM P2000-DISABLE-UPDATE THRU P2000-EXIT.            DTSCU801
00118      SKIP2                                                        DTSCU801
00119      EXEC CICS                                                    DTSCU801
00120          RETURN                                                   DTSCU801
00121      END-EXEC.                                                    DTSCU801
00122      SKIP2                                                        DTSCU801
00123      GOBACK.                                                      DTSCU801
00124      EJECT                                                        DTSCU801
00125  P1000-CONSTRUCT-OP-AREA.                                         DTSCU801
00126      MOVE LOW-VALUES TO FOPR-KEY-AREA.                            DTSCU801
00127      SET FOPR-OPR-88 TO TRUE.                                     DTSCU801
00128      MOVE LCCM-OP-ID TO FOPR-OP-ID.                               DTSCU801
00129      PERFORM S831-REF-READ THRU S831-EXIT.                        DTSCU801
00130                                                                   DTSCU801
00131 *****                                                             DTSCU801
00132 *                                                                 DTSCU801
00133 *    EXECUTION OF P1800-NO-REC IS A TEMPORARY MEASURE.  ONCE      DTSCU801
00134 *    SCREEN 92 IS COMPLETE AND FOPR RECORDS ARE CONSRUCTED        DTSCU801
00135 *    FOR THE DEVELOPMENT TEAM, COMMENT OUT EXECUTIONS OF          DTSCU801
00136 *    P1800-NO-REC AND REMOVE THE COMMENT BLOCKING THE             DTSCU801
00137 *    EXECUTION OF P1900-NO-ACCESS.                                DTSCU801
00138 *                                                                 DTSCU801
00139 *    05/21/1999: CALL TO P1800-NO-REC COMMENTED OUT.  GD.         DTSCU801
00140 *****                                                             DTSCU801
00141                                                                   DTSCU801
00142      IF L831-NO-REC-88                                            DTSCU801
00143 *********PERFORM P1800-NO-REC THRU P1800-EXIT                     DTSCU801
00144          PERFORM P1900-NO-ACCESS THRU P1900-EXIT                  DTSCU801
00145          GO TO P1000-EXIT.                                        DTSCU801
00146                                                                   DTSCU801
00147      IF L831-FILE-CLOSED-88                                       DTSCU801
00148          MOVE L831-MSG-AREA TO LCCM-MSG-AREA                      DTSCU801
00149          GO TO P1000-EXIT.                                        DTSCU801
00150                                                                   DTSCU801
00151      IF FOPR-EXTERNAL-88                                          DTSCU801
00152          NEXT SENTENCE                                            DTSCU801
00153      ELSE                                                         DTSCU801
00154          PERFORM P1900-NO-ACCESS THRU P1900-EXIT                  DTSCU801
00155          GO TO P1000-EXIT.                                        DTSCU801
00156                                                                   DTSCU801
00157      MOVE FOPR-NAME TO LCCM-OP-NAME.                              DTSCU801
00158                                                                   DTSCU801
00159      MOVE FOPR-PHONE-NUMBERS TO LCCM-OP-PHONE-NUMBERS.            DTSCU801
00160                                                                   DTSCU801
00161      MOVE FOPR-FLD-REP-ID TO LCCM-OP-FLD-REP-ID.                  DTSCU801
00162                                                                   DTSCU801
00163      MOVE FOPR-FLD-DESK-IND TO LCCM-OP-FLD-DESK-IND.              DTSCU801
00164                                                                   DTSCU801
00165      MOVE FOPR-ACCOUNTING-DESK-IND                                DTSCU801
00166        TO LCCM-OP-ACCOUNTING-DESK-IND.                            DTSCU801
00167                                                                   DTSCU801
00168      MOVE FOPR-PRINTER-ID TO LCCM-OP-PRINTER-ID.                  DTSCU801
00169                                                                   DTSCU801
00170      MOVE FOPR-ALARM-IND TO LCCM-OP-ALARM-IND.                    DTSCU801
00171                                                                   DTSCU801
00172      MOVE FOPR-ARPT-EDIT-MODE TO LCCM-OP-ARPT-EDIT-MODE.          DTSCU801
00173                                                                   DTSCU801
00174 *****MOVE FOPR-UNIT-ID TO LCCM-OP-UNIT-ID.                        DTSCU801
00175                                                                   DTSCU801
00176 *****MOVE FOPR-TITLE TO LCCM-OP-TITLE.                            DTSCU801
00177                                                                   DTSCU801
00178 *****MOVE FOPR-UNIT-NAME TO LCCM-OP-UNIT-NAME.                    DTSCU801
00179                                                                   DTSCU801
00180 *****MOVE FOPR-BUREAU-NAME TO LCCM-OP-BUREAU-NAME.                DTSCU801
00181                                                                   DTSCU801
00182      MOVE FOPR-SCR-ACCESS-AREA TO LCCM-SCR-ACCESS-AREA.           DTSCU801
00183                                                                   DTSCU801
00184      MOVE 'N' TO TAX-SYSTEM-ACCESS-IND.                           DTSCU801
00185                                                                   DTSCU801
00186      PERFORM P1100-SCR-NUM-LOOP THRU P1100-EXIT                   DTSCU801
00187          VARYING LCCM-NUM-IDX FROM 1 BY 1                         DTSCU801
00188          UNTIL (LCCM-NUM-IDX > +99)                               DTSCU801
00189                    OR                                             DTSCU801
00190                (TAX-SYSTEM-ACCESS-IND = 'Y').                     DTSCU801
00191                                                                   DTSCU801
00192      PERFORM P1200-SCR-NONUM-LOOP THRU P1200-EXIT                 DTSCU801
00193          VARYING LCCM-NONUM-IDX FROM 1 BY 1                       DTSCU801
00194          UNTIL (LCCM-NONUM-IDX > LCCM-SCR-NONUM-CNT)              DTSCU801
00195                      OR                                           DTSCU801
00196                (TAX-SYSTEM-ACCESS-IND = 'Y').                     DTSCU801
00197                                                                   DTSCU801
00198      IF TAX-SYSTEM-ACCESS-IND = 'N'                               DTSCU801
00199          PERFORM P1900-NO-ACCESS THRU P1900-EXIT.                 DTSCU801
00200                                                                   DTSCU801
00201      IF (FOPR-BATCH-NO NUMERIC)                                   DTSCU801
00202            AND                                                    DTSCU801
00203         (FOPR-BATCH-NO > +0)                                      DTSCU801
00204          MOVE FOPR-BATCH-NO TO LCCM-BATCH-NO                      DTSCU801
00205          MOVE +0 TO FOPR-BATCH-NO                                 DTSCU801
00206          PERFORM S831-REF-REWRITE THRU S831-EXIT.                 DTSCU801
00207  P1000-EXIT.                                                      DTSCU801
00208      EXIT.                                                        DTSCU801
00209      SKIP3                                                        DTSCU801
00210  P1100-SCR-NUM-LOOP.                                              DTSCU801
00211      IF LCCM-SCR-NUM-I-U-ACCESS-88 (LCCM-NUM-IDX) OR              DTSCU801
00212         LCCM-SCR-NUM-IUS-ACCESS-88 (LCCM-NUM-IDX)                 DTSCU801
00213          MOVE 'Y' TO TAX-SYSTEM-ACCESS-IND.                       DTSCU801
00214  P1100-EXIT.                                                      DTSCU801
00215      EXIT.                                                        DTSCU801
00216      SKIP3                                                        DTSCU801
00217  P1200-SCR-NONUM-LOOP.                                            DTSCU801
00218      IF LCCM-SCR-NONUM-I-U-ACCESS-88 (LCCM-NONUM-IDX) OR          DTSCU801
00219         LCCM-SCR-NONUM-IUS-ACCESS-88 (LCCM-NONUM-IDX)             DTSCU801
00220          MOVE 'Y' TO TAX-SYSTEM-ACCESS-IND.                       DTSCU801
00221  P1200-EXIT.                                                      DTSCU801
00222      EXIT.                                                        DTSCU801
00223      SKIP3                                                        DTSCU801
00224 *P1800-NO-REC.                                                    DTSCU801
00225 *    MOVE 'DUCK/DONALD' TO LCCM-OP-NAME.                          DTSCU801
00226 *    MOVE '123456789054321' TO LCCM-OP-PHONE-NUMBERS.             DTSCU801
00227 *    MOVE SPACES TO LCCM-OP-FLD-REP-ID.                           DTSCU801
00228 *    MOVE 'N' TO LCCM-OP-FLD-DESK-IND                             DTSCU801
00229 *                LCCM-OP-ACCOUNTING-DESK-IND.                     DTSCU801
00230 *    MOVE SPACES TO LCCM-OP-PRINTER-ID.                           DTSCU801
00231 *    MOVE 'N' TO LCCM-OP-ALARM-IND.                               DTSCU801
00232 *    SET LCCM-OP-ARPT-EDIT-FULL-88 TO TRUE.                       DTSCU801
00233 *****MOVE 'QUAK' TO LCCM-OP-UNIT-ID.                              DTSCU801
00234 *****MOVE 'HEAD QUACKER' TO LCCM-OP-TITLE.                        DTSCU801
00235 *****MOVE 'SOUTH WING' TO LCCM-OP-UNIT-NAME.                      DTSCU801
00236 *****MOVE 'MONTANA FLOCK' TO LCCM-OP-BUREAU-NAME.                 DTSCU801
00237 *    PERFORM P1810-SCR-NUM-LOOP THRU P1810-EXIT                   DTSCU801
00238 *        VARYING LCCM-NUM-IDX FROM 1 BY 1                         DTSCU801
00239 *        UNTIL LCCM-NUM-IDX > +99.                                DTSCU801
00240 *    MOVE +7 TO LCCM-SCR-NONUM-CNT.                               DTSCU801
00241 *    MOVE '1A2' TO LCCM-SCR-NONUM-GROUP (1).                      DTSCU801
00242 *    MOVE '1C2' TO LCCM-SCR-NONUM-GROUP (2).                      DTSCU801
00243 *    MOVE '1D2' TO LCCM-SCR-NONUM-GROUP (3).                      DTSCU801
00244 *    MOVE '7A2' TO LCCM-SCR-NONUM-GROUP (4).                      DTSCU801
00245 *    MOVE '7B2' TO LCCM-SCR-NONUM-GROUP (5).                      DTSCU801
00246 *    MOVE 'L12' TO LCCM-SCR-NONUM-GROUP (6).                      DTSCU801
00247 *    MOVE 'L22' TO LCCM-SCR-NONUM-GROUP (7).                      DTSCU801
00248 *P1800-EXIT.                                                      DTSCU801
00249 *    EXIT.                                                        DTSCU801
00250 *    SKIP3                                                        DTSCU801
00251 *P1810-SCR-NUM-LOOP.                                              DTSCU801
00252 *    MOVE '2' TO LCCM-SCR-NUM-ACCESS-IND (LCCM-NUM-IDX).          DTSCU801
00253 *P1810-EXIT.                                                      DTSCU801
00254 *    EXIT.                                                        DTSCU801
00255      SKIP3                                                        DTSCU801
00256  P1900-NO-ACCESS.                                                 DTSCU801
00257      MOVE LCCM-OP-ID TO EMSG-OP-ID.                               DTSCU801
00258      MOVE EMSG-NO-TAX-ACCESS TO LCCM-MSG-AREA.                    DTSCU801
00259  P1900-EXIT.                                                      DTSCU801
00260      EXIT.                                                        DTSCU801
00261      EJECT                                                        DTSCU801
00262  P2000-DISABLE-UPDATE.                                            DTSCU801
00263      PERFORM P2100-SCR-NUM-LOOP THRU P2100-EXIT                   DTSCU801
00264          VARYING LCCM-NUM-IDX FROM 1 BY 1                         DTSCU801
00265          UNTIL LCCM-NUM-IDX > +99.                                DTSCU801
00266                                                                   DTSCU801
00267      PERFORM P2200-SCR-NONUM-LOOP THRU P2200-EXIT                 DTSCU801
00268          VARYING LCCM-NONUM-IDX FROM 1 BY 1                       DTSCU801
00269          UNTIL LCCM-NONUM-IDX > LCCM-SCR-NONUM-CNT.               DTSCU801
00270  P2000-EXIT.                                                      DTSCU801
00271      EXIT.                                                        DTSCU801
00272      SKIP3                                                        DTSCU801
00273  P2100-SCR-NUM-LOOP.                                              DTSCU801
00274      IF LCCM-SCR-NUM-UPD-ACCESS-88 (LCCM-NUM-IDX) OR              DTSCU801
00275         LCCM-SCR-NUM-SUP-ACCESS-88 (LCCM-NUM-IDX)                 DTSCU801
00276          SET LCCM-SCR-NUM-INQ-ACCESS-88 (LCCM-NUM-IDX) TO TRUE.   DTSCU801
00277  P2100-EXIT.                                                      DTSCU801
00278      EXIT.                                                        DTSCU801
00279      SKIP3                                                        DTSCU801
00280  P2200-SCR-NONUM-LOOP.                                            DTSCU801
00281      IF LCCM-SCR-NONUM-UPD-ACCESS-88 (LCCM-NONUM-IDX) OR          DTSCU801
00282         LCCM-SCR-NONUM-SUP-ACCESS-88 (LCCM-NONUM-IDX)             DTSCU801
00283          SET LCCM-SCR-NONUM-INQ-ACCESS-88                         DTSCU801
00284                (LCCM-NONUM-IDX) TO TRUE.                          DTSCU801
00285  P2200-EXIT.                                                      DTSCU801
00286      EXIT.                                                        DTSCU801
00287      EJECT                                                        DTSCU801
00288  S831-REF-READ.                                                   DTSCU801
00289      SET L831-READ-88 TO TRUE.                                    DTSCU801
00290      GO TO S831-REF-IO.                                           DTSCU801
00291                                                                   DTSCU801
00292  S831-REF-REWRITE.                                                DTSCU801
00293      SET L831-REWRITE-88 TO TRUE.                                 DTSCU801
00294      GO TO S831-REF-IO.                                           DTSCU801
00295                                                                   DTSCU801
00296  S831-REF-IO.                                                     DTSCU801
00297      EXEC CICS                                                    DTSCU801
00298          LINK                                                     DTSCU801
00299              PROGRAM ('DTSCU831')                                 DTSCU801
00300              COMMAREA (L831-COMM-AREA)                            DTSCU801
00301      END-EXEC.                                                    DTSCU801
00302  S831-EXIT.                                                       DTSCU801
00303      EXIT.                                                        DTSCU801
