00001  IDENTIFICATION DIVISION.                                         08/11/98
00002  PROGRAM-ID.             DTSCU898                                 DTSCU898
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV004
00004  DATE-WRITTEN.           NOVEMBER 1991.                           DTSCU898
00005  DATE-COMPILED.                                                   DTSCU898
00006      SKIP3                                                        DTSCU898
00007 *****                                                             DTSCU898
00008 *                                                                 DTSCU898
00009 *    FUNCTION:  DELETE ALL TEMPORARY STORAGE QUEUES ASSOCIATED    DTSCU898
00010 *               WITH THE PSEUDO CONVERSATION.                     DTSCU898
00011 *                                                                 DTSCU898
00012 *                                                                 DTSCU898
00013 *    MODIFICATION LOG:                                            DTSCU898
00014 *                                                                 DTSCU898
00015 *    11/05/91  INITIAL DEVELOPMENT.                               DTSCU898
00016 *              WORK ORDER:                      PROGRAMMER: TCL   DTSCU898
00017 *                                                                 DTSCU898
00018 *    08/11/1998  REVIEWED AND MODIFIED FOR DC.                       CL**2
00019 *                REFERENCE: DC DEVELOPMENT      PROGRAMMER: EHH      CL**2
00020 *                                                                    CL**2
00021 *    MM/DD/YYYY  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX      CL**2
00022 *                XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX      CL**2
00023 *                REFERENCE: XXXXXXXXXXXXXX      PROGRAMMER: XXX      CL**2
00024 *                                                                 DTSCU898
00025 *                                                                 DTSCU898
00026 *    DESCRIPTION:                                                 DTSCU898
00027 *                                                                 DTSCU898
00028 *    WHEN A PSEUDO CONVERSATION IS INITIATED, A PSEUDO            DTSCU898
00029 *    CONVERSATION IS TERMINATED OR DURING ABEND PROCESSING        DTSCU898
00030 *    ALL TEMPORARY STORAGE AREAS ASSOCIATED WITH THE PSEUDO       DTSCU898
00031 *    CONVERSATION MUST BE DELETED.                                DTSCU898
00032 *                                                                 DTSCU898
00033 *    DTSCU898 DELETES ALL POSSIBLE TEMPORARY STORAGE AREAS.          CL**2
00034 *    IF CERTAIN AREAS DO NOT EXIST IN A PARTICULAR PSEUDO         DTSCU898
00035 *    CONVERSATION, THEN THE DELETE YIELDS A QIDERR.  THE QIDERR   DTSCU898
00036 *    IS SIMPLY TOLERATED.                                         DTSCU898
00037 *                                                                 DTSCU898
00038 *    IF TEMPORARY STORAGE AREA NAMES ARE ADDED ANYWHERE IN THE    DTSCU898
00039 *    COMPLEX OF MODULES CONSTITUTING CICS TRANSACTION 'DTS', THEN    CL**2
00040 *    THE NEW TEMPORARY STORAGE AREA NAMES SHOULD BE ADDED TO THIS DTSCU898
00041 *    MODULE.                                                      DTSCU898
00042 *                                                                 DTSCU898
00043 *    IN PARTICULAR, THIS MODULE ASSUMES THAT CHARACTER ONE THRU   DTSCU898
00044 *    CHARACTER THREE OF A TS QUEUE NAME IS EQUAL TO 'DTS' AND THAT   CL**2
00045 *    CHARACTER FOUR THRU CHARACTER SEVEN OF A TS QUEUE NAME IS EQUDTSCU898
00046 *    TO EIBTRMID.  IF THESE ASSUMPTIONS BECOME INVALID, THEN THIS DTSCU898
00047 *    MODULE MUST BE MOFIFIED.                                     DTSCU898
00048 *                                                                 DTSCU898
00049 *****                                                             DTSCU898
00050      SKIP3                                                        DTSCU898
00051  ENVIRONMENT DIVISION.                                            DTSCU898
00052      SKIP3                                                        DTSCU898
00053  DATA DIVISION.                                                   DTSCU898
00054      SKIP3                                                        DTSCU898
00055  WORKING-STORAGE SECTION.                                         DTSCU898
000555 77  PAN-VALET PICTURE X(24) VALUE '004DTSCU898  08/11/98'.       DTSCU898
00056      SKIP3                                                        DTSCU898
00057  01  WRK-AREA.                                                    DTSCU898
00058      05  WRK-RESP-CD                 PIC S9(08)  COMP.            DTSCU898
00059      SKIP3                                                        DTSCU898
00060      05  WRK-CNT                     PIC S9(04)  COMP  VALUE +6.  DTSCU898
00061                                                                      CL**2
00062      05  WRK-QUEUE-NAME-SUFFIX-LITERALS.                          DTSCU898
00063          10  FILLER                  PIC  X(06)                   DTSCU898
00064                VALUE 'SPE123'.                                    DTSCU898
00065      05  FILLER REDEFINES WRK-QUEUE-NAME-SUFFIX-LITERALS.         DTSCU898
00066          10  WRK-QUEUE-NAME-SUFFIX-LITERAL OCCURS 6 TIMES         DTSCU898
00067                                            INDEXED BY WRK-IDX     DTSCU898
00068                                      PIC  X(01).                  DTSCU898
00069  01  L829-AREA.                                                   DTSCU898
00070  ++INCLUDE DTSIL829                                                  CL**2
00071      EJECT                                                        DTSCU898
00072  PROCEDURE DIVISION.                                              DTSCU898
00073      SKIP2                                                        DTSCU898
00074 *****MOVE L829-CONTROL-BLOCK-LENGTH TO L829-COMM-AREA-LENGTH.        CL**2
00075                                                                      CL**2
00076      SET L829-DELETE-QUEUE-88 TO TRUE.                               CL**4
00077                                                                      CL**2
00078      MOVE +0 TO L829-ITEM-NO                                      DTSCU898
00079                 L829-REC-LENGTH.                                  DTSCU898
00080                                                                      CL**2
00081      SET L829-DEFAULT-STORAGE-88 TO TRUE.                         DTSCU898
00082                                                                      CL**2
00083      MOVE 'DTS'    TO L829-QUEUE-NAME-PREFIX (1:3).                  CL**2
00084                                                                      CL**2
00085      MOVE EIBTRMID TO L829-QUEUE-NAME-PREFIX (4:4).               DTSCU898
00086                                                                      CL**2
00087      PERFORM P1000-DELETE-QUEUE THRU P1000-EXIT                   DTSCU898
00088          VARYING WRK-IDX FROM 1 BY 1                              DTSCU898
00089          UNTIL WRK-IDX > WRK-CNT.                                 DTSCU898
00090                                                                      CL**2
00091      EXEC CICS                                                    DTSCU898
00092          RETURN                                                   DTSCU898
00093      END-EXEC.                                                    DTSCU898
00094      SKIP2                                                        DTSCU898
00095      GOBACK.                                                      DTSCU898
00096      EJECT                                                        DTSCU898
00097  P1000-DELETE-QUEUE.                                              DTSCU898
00098      MOVE WRK-QUEUE-NAME-SUFFIX-LITERAL (WRK-IDX)                 DTSCU898
00099        TO L829-QUEUE-NAME-SUFFIX.                                 DTSCU898
00100                                                                      CL**2
00101      EXEC CICS                                                    DTSCU898
00102          LINK                                                     DTSCU898
00103              PROGRAM ('DTSCU829')                                    CL**2
00104              COMMAREA (L829-AREA)                                 DTSCU898
00105      END-EXEC.                                                    DTSCU898
00106  P1000-EXIT.                                                      DTSCU898
00107      EXIT.                                                        DTSCU898
