000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. QUE_SEARCH. 000300 ENVIRONMENT DIVISION. 001000 DATA DIVISION. 001100 WORKING-STORAGE SECTION. 01 MSD-STATUS PIC X(02). 01 DISPLAY_QUEUE PIC S9(09) COMP VALUE 6. 01 IOSB. 02 FILLER OCCURS 2 TIMES. 03 IOSB-LONGWORD PIC 9(09) COMP. 01 JBC$_NOMOREQUE PIC S9(09) COMP VALUE 295338. 000120 01 QUE_ITMLST. 000130 02 FILLER PIC S9(04) COMP VALUE 31. 000140 02 FILLER PIC S9(04) COMP VALUE 77. 000160 02 FILLER POINTER VALUE REFERENCE 000170 SEARCH_NAME. 000180 02 FILLER POINTER VALUE REFERENCE 000190 SEARCH_NAME_LENGTH. 000130 02 FILLER PIC S9(04) COMP VALUE 4. 000140 02 FILLER PIC S9(04) COMP VALUE 76. 000160 02 FILLER POINTER VALUE REFERENCE 000170 SEARCH_FLAGS. 000180 02 FILLER POINTER VALUE REFERENCE 000190 SEARCH_FLAGS_LENGTH. 000130 02 FILLER PIC S9(04) COMP VALUE 31. 000140 02 FILLER PIC S9(04) COMP VALUE 31. 000160 02 FILLER POINTER VALUE REFERENCE 000170 FORM_NAME. 000180 02 FILLER POINTER VALUE REFERENCE 000190 FORM_NAME_LENGTH. 000130 02 FILLER PIC S9(04) COMP VALUE 31. 000140 02 FILLER PIC S9(04) COMP VALUE 70. 000160 02 FILLER POINTER VALUE REFERENCE 000170 QUEUE_NAME. 000180 02 FILLER POINTER VALUE REFERENCE 000190 QUEUE_NAME_LENGTH. 000130 02 FILLER PIC S9(04) COMP VALUE 4. 000140 02 FILLER PIC S9(04) COMP VALUE 71. 000160 02 FILLER POINTER VALUE REFERENCE 000170 QUEUE_STATUS. 000180 02 FILLER POINTER VALUE REFERENCE 000190 QUEUE_STATUS_LENGTH. 000200 02 FILLER PIC S9(09) COMP VALUE 0. 01 SEARCH_NAME PIC X(31). 01 SEARCH_NAME_LENGTH PIC S9(09) COMP VALUE 0. 01 SEARCH_FLAGS PIC 9(09) COMP VALUE 0. 01 SEARCH_FLAGS_LENGTH PIC S9(09) COMP VALUE 0. 01 FORM_NAME PIC X(31). 01 FORM_NAME_LENGTH PIC S9(09) COMP. 01 QUEUE_NAME PIC X(31). 01 QUEUE_NAME_LENGTH PIC S9(09) COMP. 01 QUEUE_STATUS PIC 9(09) COMP. 01 QUEUE_STATUS_LENGTH PIC S9(09) COMP. 01 POS PIC 9(09) COMP. 01 STATUS_FLAG_VALUE PIC 9(09) COMP. 01 NUMBER-OF-BITS PIC 9(04) COMP VALUE 1. 01 TBL-IND PIC S9(09) COMP VALUE EXTERNAL LIB$K_CLI_GLOBAL_SYM. 01 STAT PIC S9(09) COMP. 01 QTYPE PIC X(05) VALUE " ". 01 WHAT_QUE PIC X(31) VALUE " ". 01 QUEUE_OK PIC X(03) VALUE " ". PROCEDURE DIVISION. MAIN-PARA. CALL "LIB$GET_SYMBOL" USING BY DESCRIPTOR "QTYPE" BY DESCRIPTOR QTYPE BY VALUE 0 BY REFERENCE TBL-IND GIVING STAT. CALL "LIB$GET_SYMBOL" USING BY DESCRIPTOR "WHAT_QUE" BY DESCRIPTOR WHAT_QUE BY VALUE 0 BY REFERENCE TBL-IND GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. IF QTYPE = "BATCH" MOVE 4 TO SEARCH_FLAGS. IF QTYPE = "PRINT" MOVE 8 TO SEARCH_FLAGS. MOVE "NO" TO QUEUE_OK. MOVE "*" TO SEARCH_NAME. START-SEARCHING. CALL "SYS$GETQUIW" USING BY VALUE 0 BY VALUE DISPLAY_QUEUE BY VALUE 0 BY REFERENCE QUE_ITMLST BY REFERENCE IOSB BY VALUE 0 0 GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. IF IOSB-LONGWORD (1) = JBC$_NOMOREQUE GO TO E-O-J. * PERFORM VARYING POS FROM 0 BY 1 UNTIL POS > 15 * CALL "LIB$EXTZV" USING BY REFERENCE POS * NUMBER-OF-BITS * QUEUE_STATUS * GIVING STATUS_FLAG_VALUE * IF POS = 0 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE ALIGNING ****" * END-IF * END-IF * IF POS = 1 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE IDLE ****" * END-IF * END-IF * IF POS = 2 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE LOWERCASE ****" * END-IF * END-IF * IF POS = 3 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** UNDEFINED QUEUE STATUS ****" * END-IF * END-IF * IF POS = 4 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE PAUSED ****" * END-IF * END-IF * IF POS = 5 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE PAUSING ****" * END-IF * END-IF * IF POS = 6 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE REMOTE ****" * END-IF * END-IF * IF POS = 7 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE RESETTING ****" * END-IF * END-IF * IF POS = 8 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE RESUMING ****" * END-IF * END-IF * IF POS = 9 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE SERVER ****" * END-IF * END-IF * IF POS = 10 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE STALLED ****" * END-IF * END-IF * IF POS = 11 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE STARTING ****" * END-IF * END-IF * IF POS = 12 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE STOPPED ****" * END-IF * END-IF * IF POS = 13 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE STOPPING ****" * END-IF * END-IF * IF POS = 14 * IF STATUS_FLAG_VALUE = 1 * DISPLAY "**** QUEUE UNAVAILABLE ****" * END-IF * END-IF * END-PERFORM. * DISPLAY " ". * DISPLAY "FORM NAME = " FORM_NAME. * DISPLAY "QUEUE NAME = " QUEUE_NAME "*". IF QUEUE_NAME (1:QUEUE_NAME_LENGTH) NOT = WHAT_QUE GO TO START-SEARCHING. MOVE "YES" TO QUEUE_OK. GO TO START-SEARCHING. E-O-J. CALL "LIB$SET_SYMBOL" USING BY DESCRIPTOR "QUEUE_OK" BY DESCRIPTOR QUEUE_OK BY REFERENCE TBL-IND GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. STOP RUN.