109 lines
8.5 KiB
COBOL
109 lines
8.5 KiB
COBOL
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
|