//QUE0010  JOB (QUEUE),
//             'Create Q files',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1)
//*********************************************************************
//*
//*                       MVS 3.8 SYSGEN
//*                       ==============
//*
//*
//* DESC: Create the QUEUE command - Build files
//*
//*********************************************************************
//*
//CLEANUP EXEC PGM=IDCAMS
//SYSPRINT DD  SYSOUT=*
//SYSIN    DD *
 DELETE JES2.QUEUE.ASM NONVSAM
 DELETE JES2.QUEUE.OBJ NONVSAM
 SET LASTCC = 0
 SET MAXCC = 0
//ALLOC   EXEC PGM=IEBUPDTE,PARM=NEW
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DISP=(NEW,CATLG),DSN=JES2.QUEUE.ASM,DCB=SYS1.MACLIB,
//             SPACE=(CYL,(5,5,20)),UNIT=3350,VOL=SER=MVSDLB
//SYSUT3   DD  DISP=(NEW,CATLG),DSN=JES2.QUEUE.OBJ,
//             DCB=(LRECL=80,BLKSIZE=3120,RECFM=FB),
//             SPACE=(CYL,(1,1,20)),UNIT=3350,VOL=SER=MVSDLB
//SYSIN    DD  DATA,DLM=##
./ ADD NAME=$JQT
         MACRO -- JQT -- PHONY DSECT TO DESCRIBE FIRST CKPT REC
         $JQT
JQTDSECT DSECT
         GBLB  &QSP                                               UF020
         AIF   (&QSP).QSP1                                        UF020
JQTOUT   DS    H              HEADER FOR OUTPUT JQES
         DS    7H
JQTSTC   DS    H
JQTTSU   DS    H              HEADER FOR TSO USER JQES
JQTCLSA  DS    H              HEADER FOR CLASS A JQES
JQTQMAX  EQU   46             MAXIMUM NUMBER OF QUEUES
         MEXIT                                                    UF020
.QSP1    ANOP                                                     UF020
JQTOUT   DS    F              HEADER FOR PRINT/PUNCH JQES         RNB19
JQTAWOUT DS    F              HEADER FOR OUTPUT JQES (AWAITING)   RNB19
JQTDUMP  DS    F              HEADER FOR DUMP JQE'S               RNB19
         DS    4F                                                 RNB19
JQTXEQ   DS    F              HEADER FOR XEQ (CONVERSION) JQE'S   RNB19
JQTSTC   DS    F                                                  UF020
JQTTSU   DS    F              HEADER FOR TSO USER JQES            UF020
JQTCLSA  DS    F              HEADER FOR CLASS A JQES             UF020
JQTQMAX  EQU   48             MAXIMUM NUMBER OF QUEUES            UF020
         MEND
./ ADD NAME=$SP
THE SP VERSION OF THE QUEUE COMMAND IS OBTAINED BY SPECIFYING
"SYSPARM=((SP))" FOR THE ASSEMBLIES (SEE MEMBER $NERJCL2).
MEMBER QSTART CAN ALSO BE UPDATED TO CHANGE THE DEFAULT FLAG SETTING
TO ELIMINATE THE NEED TO SPECIFY ANY SYSPARM AT ALL.

SEE MEMBER $UFDOC FOR A DESCRIPTION OF THE OTHER MODIFICATIONS.

THIS VERSION OF QUEUE WAS DEVELOPED AS IN INTERNAL AID FOR THE DEBUGGING
OF THE NEW JES2 SYSTEM, WHICH NORMALLY RUNS AS A SECONDARY SUBSYSTEM.
IT IS BELIEVED THAT MOST OF THE DISPLAY COMMANDS WORK PROPERLY, WITH THE
EXCEPTION OF STATUS AND DO.  BOTH OF THERE COMMANDS ARE IN MODULE Q20
(SEARCH).  THE PROBLEM WITH THE DISPLAY OUTPUT COMMANDS IS THAT THERE
ARE NOW TWO QUEUES FOR OUTPUT JOES, ONE FOR LOCAL ROUTING, AND THE OTHER
FOR REMOTE ROUTING.  AT THIS TIME ONLY THE LOCAL ROUTING QUEUE IS
PROCESSED.  THE PROBLEM WITH THE STATUS COMMAND SEEMS TO BE THAT THE
COMMAND SKIPS SOME OF THE QUEUES ENTIRELY, BUT THAT SEEMED TO BE A
PROBLEM WITH THE OLD VERSION OF THE COMMAND AS WELL.
IN PARTICULAR, JOBS IN THE OUTPUT QUEUE (NOT HARDCOPY) SEEM TO
BE IGNORED IN ALL ENVIRONMENTS.

THIS VERSION WILL NOT WORK IF ANY OF THE DEFINED SPOOL VOLUMES
ARE NOT AVAILABLE, INCLUDING A SPOOL VOLUME THAT WAS ADDED AND
THEN PURGED AT A LATER TIME.

THERE WAS ONE PROBLEM WITH THE SYSLOG COMMAND CAUSED BY A CHANGE IN
THE WAS THAT SPUN OUTPUT PDDB'S ARE GENERATED.  IT APPEARS THAT A
SPUN SYSOUT WILL NOW HAVE TWO SEPARATE PDDB'S; A NULL ONE IN THE
NORMAL IOT, AND THE TRUE ONE IN A SPIN IOT.  BECAUSE BOTH OF THE
PDDB'S HAVE THE SAME NUMBER, NORMAL QUEUE PROCESSING WOULD LOCATE
THE FIRST ONE, SEE THAT IT WAS NULL, AND INDICATE THAT THE FILE WAS
EMPTY.  CODE HAS BEEN CHANGED IN LISTDS TO CHECK IF THE MTTR FIELD
IS ZERO BEFORE TESTING FOR THE PROPER DATASET ID NUMBER.  ANY PDDB
WITH A ZERO MTTR FIELD WILL BE IGNORED.  THE ONLY POSSIBLE CHANGE
THAT THE USER WILL NOTICE IS THAT THERE WILL BE TIMES WHEN THE OLD
VERSION WOULD INDICATE "DATASET IS EMPTY" WHILE THE NEW VERSION
WILL INDICATE "DATASET ID NOT FOUND".

AT THIS TIME THE FINDPDDB ROUTINE HAS NOT BEEN CHANGED, SO THE
DD COMMAND WILL PROBABLY GIVE SOME INCORRECT INDICATIONS ABOUT
THE STATUS OF SOME SYSOUTS.

A PDDB COMMAND HAS BEEN ADDED THAT WILL DUMP OUT SOME OF THE MORE
RELEVANT INFORMATION ABOUT THE PDDB'S IN GENERAL, OR DUMP OUT
SELECTED ONES IN HEX, TO ASSIST IN FIGURING OUT WHAT IS REALLY
GOING ON.

I WOULD APPRECIATE HEARING FROM ANYONE WHO COMES UP WITH EITHER
ADDITIONAL BUGS OR FIXES TO THE KNOWN ONES.  ALSO, I WILL TRY TO
PASS ON ANY FIXES TO THOSE USERS THAT I AM AWARE OF, SO PLEASE DROP
ME A NOTE IF YOU GET THIS OFF OF ONE OF THE MODS TAPES.

JACK SCHUDEL
NORTHEAST REGIONAL DATA CENTER
233 SSRB, UNIVERSITY OF FLORIDA
GAINESVILLE, FLORIDA  32611
(904) 392-4601
SHARE CODE - UF

./ ADD NAME=$WARN
//*                                                                 *   00013
//*            *******************************************          *   00014
//*            *                                          *         *   00015
//*            * SOME INSTALLATIONS HAVE HAD THE          *         *   00016
//*            * FOLLOWING PROBLEM WITH QUE. IT ASSEMBLES *         *   00017
//*            * FINE BUT IT NEVER PUTS ANYTHING OUT TO   *         *   00018
//*            * THE SCREEN. THE CIRCUMVENTION IS TO GET  *         *   00019
//*            * THE TPUT AND TGET MACROS FROM PUT TAPE   *         *   00020
//*            * 8007. I DO NOT KNOW WHAT THE PTF NUMBERS *         *   00021
//*            * ARE, WHEN I FIND OUT I WILL ADD THEM     *         *   00022
//*            * HERE.                                    *         *   00023
//*            *                                          *         *   00024
//*            ********************************************         *   00025
./ ADD NAME=COMPILE
//ASMLQUE JOB (QUEUE),VB,CLASS=A,MSGCLASS=A,REGION=2048K
//ASMLQUE PROC M=MISSING,SP='NOSP,NODEBUG'
//ASM     EXEC PGM=IFOX00,
//             PARM='NOLIST,DECK,NOLOAD,TERM,TEST,SYSPARM((&SP))'
//SYSLIB   DD  DISP=SHR,DSN=JES2.QUEUE.ASM
//         DD  DISP=SHR,DSN=SYS1.HASPSRC
//         DD  DISP=SHR,DSN=SYS1.MACLIB
//         DD  DISP=SHR,DSN=SYS1.AMODGEN
//SYSUT1   DD  SPACE=(CYL,(25,5)),UNIT=SYSDA
//SYSUT2   DD  SPACE=(CYL,(25,5)),UNIT=SYSDA
//SYSUT3   DD  SPACE=(CYL,(25,5)),UNIT=SYSDA
//SYSTERM  DD  SYSOUT=*
//SYSPRINT DD  SYSOUT=*
//SYSIN    DD  DISP=SHR,DSN=JES2.QUEUE.ASM(&M)
//SYSPUNCH DD  DISP=SHR,DSN=JES2.QUEUE.OBJ(&M)
//        PEND
//Q00     EXEC ASMLQUE,M=Q0                     QCOMMON
//Q01     EXEC ASMLQUE,M=Q1                     QUEUE
//Q02     EXEC ASMLQUE,M=Q2                     ALLOCATE
//Q03     EXEC ASMLQUE,M=Q3                     CKPT
//Q04     EXEC ASMLQUE,M=Q4                     DDNAME
//Q05     EXEC ASMLQUE,M=Q5                     DISPLAY
//Q06     EXEC ASMLQUE,M=Q6                     FINDJOB
//Q07     EXEC ASMLQUE,M=Q7                     FORMAT
//Q08     EXEC ASMLQUE,M=Q8                     HELP
//Q09     EXEC ASMLQUE,M=Q9                     HEXBLK
//Q10     EXEC ASMLQUE,M=Q10                    INIT
//Q11     EXEC ASMLQUE,M=Q11                    JCL
//Q12     EXEC ASMLQUE,M=Q12                    JLOG
//Q13     EXEC ASMLQUE,M=Q13                    JMSG
//Q14     EXEC ASMLQUE,M=Q14                    LIST
//Q15     EXEC ASMLQUE,M=Q15                    LISTDS
//Q16     EXEC ASMLQUE,M=Q16                    PARSE
//Q17     EXEC ASMLQUE,M=Q17                    READSPC
//Q18     EXEC ASMLQUE,M=Q18                    REPOS
//Q19     EXEC ASMLQUE,M=Q19                    SAVE
//Q20     EXEC ASMLQUE,M=Q20                    SEARCH
//Q21     EXEC ASMLQUE,M=Q21                    SYSLOG
//Q22     EXEC ASMLQUE,M=Q22                    XDS
//Q23     EXEC ASMLQUE,M=Q23                    INITS
//Q24     EXEC ASMLQUE,M=Q24                    ACTIVE
//Q25     EXEC ASMLQUE,M=Q25                    FINDPDDB
//Q26     EXEC ASMLQUE,M=Q26                    SYSOUT
//Q27     EXEC ASMLQUE,M=Q27                    PRINT
//Q28     EXEC ASMLQUE,M=Q28                    HEXDUMP
//Q29     EXEC ASMLQUE,M=Q29                    CJQE
//Q30     EXEC ASMLQUE,M=Q30                    CJCT
//Q31     EXEC ASMLQUE,M=Q31                    CTSO
//Q32     EXEC ASMLQUE,M=Q32                    CHCT
//Q33     EXEC ASMLQUE,M=Q33                    CPDDB
//Q34     EXEC ASMLQUE,M=Q34                    CJOE
//LKED    EXEC PGM=IEWL,PARM='XREF,LIST,LET,TEST,AC=1',REGION=1024K
//SYSLMOD  DD  DSN=SYS2.CMDLIB,DISP=SHR
//SYSUT1   DD  UNIT=SYSDA,SPACE=(CYL,(8,1))
//SYSPRINT DD  SYSOUT=*
//SYSLIB   DD  DISP=SHR,DSN=JES2.QUEUE.OBJ
//SYSLIN   DD  *
 INCLUDE SYSLIB(Q0,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9)
 INCLUDE SYSLIB(Q10,Q11,Q12,Q13,Q14,Q15,Q16,Q17,Q18,Q19)
 INCLUDE SYSLIB(Q20,Q21,Q22,Q23,Q24,Q25,Q26,Q27,Q28,Q29)
 INCLUDE SYSLIB(Q30,Q31,Q32,Q33,Q34)
 ENTRY QUEUE
 ALIAS QUEUE
 ALIAS QUE
 NAME Q(R)
/*
//
./ ADD NAME=FILE53
************************************************************************
*
*         F I L E   5 3   U P D A T E D   Q U E U E
*
************************************************************************

THIS FILE IS IN IEBCOPY UNLOAD FORMAT (80 X 32720).
     THIS VERSION OF THE COMMAND HAS A NUMBER OF ENHANCEMENTS AND
CLEANUP FIXES INSTALLED. THE SUPPORT FOR JES2 PRIOR TO 79/09 WAS REMOVED
AND THE CODE STANDARDIZED ON THE DUPLEX CHECKPOINT LEVEL. A SCREEN PRINT
FACILITY WAS ADDED. THE COMMAND RUNS AUTHORIZED AND NOW HAS SUPPORT FOR
CANCEL, REQUEUE, AND PURGE. THE PDDB SYSOUT COUNTS ARE LISTED ON THE DD
SUBCOMMAND. SUPPORT WAS ADDED TO FIND AND LIST TSO DYNAMICALLY SPUN
SYSOUT.
     THE COMMAND ONLY NEEDS TO RUN AUTHORIZED FOR THE FOLLOWING COMMANDS
CANCEL, REQUEUE, AND PURGE. IF YOU DO NOT MARK THE CODE AC=1, THE
PREVIOUS THREE COMMANDS WILL NOT FUNCTION.

 --- QUEUE COMMAND -----------------------------------------------------

  QUEUE SUBCOMMAND OPERAND        DEFAULT Q STATUS *
  Q                               CAN USE Q CKPT(DEVTYPE,VOLSER) TO GET
                                  NONSTANDARD CHECKPOINT.

 --- SYSTEM DISPLAYS ---------------------------------------------------

DA                  JOBS IN EXECUTION
DT                  DISPLAY TSO USERS
DS                  DISPLAY STARTED TASKS
DC (B/S/T)          DISPLAY CPU BATCH/STC/TSO
STATUS (LEVEL)      JOB STATUS. DEFAULT FOR STATUS IS * (TSO ID).

 --- INPUT QUEUE DISPLAYS ----------------------------------------------

DQ                  DISPLAY INPUT QUEUES
DI (CLASS)          DISPLAY ALL INPUT JOBS
AI (CLASS)          DISPLAY AVAILABLE JOBS
HI (CLASS)          DISPLAY HELD JOBS

 --- OUTPUT QUEUE DISPLAYS----------------------------------------------

DF                  DISPLAY OUTPUT QUEUES
DO (CLASS)          DISPLAY ALL OUTPUT JOBS
AO (CLASS)          DISPLAY AVAILABLE OUTPUT
HO (CLASS)          DISPLAY HELD OUTPUT

 --- JOB MODIFICATION SUBCOMMANDS --------------------------------------

CAN JOBNAME (PURGE) CANCEL FROM INPUT OR EXECUTION. DELETE OUTPUT IF
                     PURGE IS SPECIFIED.
REQ JOBNAME CLASS   CHANGE SYSOUT CLASS
DEL JOBNAME         DELETE HELD OUTPUT

 --- MISC SUBCOMMANDS --------------------------------------------------

SLOG STC# SEQ       LIST SYSTEM LOG.  ST SYSLOG WILL GET STC#. IF SEQ
                     IS NOT SPECIFED ZERO IS ASSUMED (CURRENT).
FTIME HH.MM.SS      POSITION SYSLOG TO TIME
H/HELP              HELP
E/END               EXIT

 --- JOB RELATED SUBCOMMANDS -------------------------------------------

DJ JOBNAME          DISPLAY JOB
JCL JOBNAME         LIST JOB JCL
JLOG JOBNAME        LIST JOB LOG
JMSG JOBNAME        LIST JOB MESSAGES
DD JOBNAME          JES2 DD SUMMARY
LIST JOBNAME DSID   LIST JES2 DATASET. OBTAIN DSID VALUES BY USING THE
                     DD SUBCOMMAND.

 --- LIST RELATED SUBCOMMANDS ---------

FIND 'STRING' COL(SS,EE)  FIND NEXT OCCURANCE OF 'STRING' IN THE DATA.
FALL 'STRING' COL(SS,EE)  FIND ALL OCCURANCES OF 'STRING' IN THE DATA.
                          STRING MUST BE IN QUOTES. COL DEFAULT IS ALL.

COL  #              POSITION TO COLUMN #
@    #              POSITION TO RECORD #
D/+  #              MOVE FORWARD # LINES
UP/- #              MOVE BACKWARD # LINES
TOP                 TOP OF CURRENT DATASET
BOTTOM              BOTTOM OF CURRENT DATASET
HF/HB #             FORWARD/BACKWARD # HALF PAGES
PF/PB #             FORWARD/BACKWARD # PAGES

                    DEFAULT VALUE FOR # IS 1.
                    SYNONYMS L-LIST F-FIND C-COLUMN T-TOP B-BOTTOM

 --------- LOGGING SUBCOMMANDS---------------

SAVE DSNAME TYPE    COPY DATASET
PRINT ON CLASS DEST OPEN SCREEN LOG
                    DEFAULT PRINT CLASS IS SYSOUT=A.
PRINT               PRINT SCREEN
PRINT OFF           CLOSE SCREEN LOG

 -------------------------------
 | PF1     | PF2     | PF3     |
 |   HELP  |   DA    |   END   |   PROGRAM FUNCTION KEY DEFINITIONS
 -------------------------------
 | PF4     | PF5     | PF6     |   TO SPECIFY OPERANDS FOR PF 5 OR
 |   PRINT |   FIND  |   DI    |   OPTIONALLY FOR PF 6,9,12 OR
 -------------------------------   TO OVERRIDE DEFAULTS FOR PF 4,7,8,10,
 | PF7     | PF8     | PF9     |   KEY IN THE VALUE AND PRESS THE KEY
 |   - 21  |   + 21  |   DO    |
 -------------------------------
 | PF10    | PF11    | PF12    |
 |  COL 1  |  COL 41 |   ST    |
 -------------------------------

 -------------------------- RESTRICTED SUBCOMMANDS ---------------------

XB MTTR             DISPLAY DISK RECORD
XD JOBNAME DSID     LIST ANY DATASET
XI                  DISPLAY ACTIVE INITIATORS
XJ JOBNAME          DISPLAY JQE AND JOES
XP PASSWORD         REQUEST FOR PASSWORD PROMPT. PROMPT IS A BLANK SCREE
                     THE PASSWARD AND IF SUCCESSFUL A MESSAGE WILL BE IS

INSTALLATION PROCEDURE FOR QUEUE:

     1. THERE ARE 36 MEMBERS IN THE DATASET.
        Q0 IS THE COMMON AREA.
        Q1 - Q27 ARE REENTRANT CODE.
        QCOMMON, QSTART, QSTOP, QTILT, AND $JQT ARE MACROS.
        HELP IS A TSO HELP MEMBER.
        ASSEMBLE IS THE JCL TO ASSEMBLE AND LINK QUEUE.
        TABLE IS A SAMPLE SMP JOB TO AUTHORIZE THE QUEUE COMMAND.

     2. EDIT MEMBER QCOMMON CHANGING THE FOLLOWING PARAMETERS:

        UNIT=XXXX THE DEVICE TYPE FOR SYS1.HASPCKPT.
        VOLSER=YYYYYY THE VOLUME SERIAL FOR SYS1.HASPCKPT.
        SID1-SID7=ZZZZ THE SMF IDS FOR EACH CPU IN THE COMPLEX. THE
        IDS MUST BE IN THE SAME ORDER AS IN THE INITIALIZATION DECK.

        AT PRESENT THERE IS SUPPORT IN THE INITIALIZATION MODULE TO
        DYNAMICALLY ALLOCATE THE CHECKPOINT ON EITHER 3330, 3330-1,
        OR 3350. IF YOU ARE FORTUNATE ENOUGH TO HAVE A DRUM YOU
        WILL HAVE TO MODIFY Q10 TO ADD SUPPORT.

        EDIT THE MACRO QSTART TO INDICATE THE OPTIONS DESIRED.

        QPFK SETB 0      NO PFK SUPPORT.
        QPFK SETB 1      PFK SUPPORT (DEFAULT).

        THE PFK SUPPORT IS FROM VILKO MACEK - INSURANCE CORPORATION
        OF BRITISH COLUMBIA. PFK SUPPORT CAN BE IDENTIFIED BY SOURCE
        MARKED WITH ICBC IN MODULES Q5, Q8, AND THE MACRO QCOMMON. TO
        CHANGE THE DEFINITIONS OF THE PFKS SEE THE END OF MODULE Q5.

        QACF2 SETB 0     NO ACF2 SUPPORT (DEFAULT).
        QACF2 SETB 1     ACF2 SUPPORT.

        THE ACF2 SUPPORT IS FROM KEN TRUE - FAIRCHILD CAMERA. KEN ALSO
        SUPPLIED THE ORIGINAL PRINT SUPPORT.

     3. EDIT MEMBER ASSEMBLE TO CHANGE THE JCL TO FIT YOUR STANDARDS.
        DO NOT ALTER THE ORDER OF THE ASSEMBLY SYSLIBS AS THERE IS A
        CONFLICT ON THE MACRO QSTART. THE ASSEMBLIES AND LINKS CREATE
        2 LOAD MODULES.

        QUEUE (ALIAS Q) - IS THE REENTRANT CODE OF THE COMMAND. IT MAY
        BE PLACED IN SYS1.LPALIB OR ANY OTHER AUTHORIZED LIBRARY WITH
        AN AUTHORIZATION CODE OF 1.

        QUEUECMN - THE MODIFIABLE COMMON AREA. CAN BE PLACED IN SYS1.
        LINKLIB OR SYS1.CMDLIB. IF YOU WANT TO CHANGE THE NAME OF
        QUEUECMN LOOK IN MEMBER Q10 WHERE THE LINK IS ISSUED.

     4. ADD QUEUE ALIAS Q TO THE IKJEFTE2 MODULE WHICH IS THE TSO LIST
        OF AUTHORIZED COMMANDS. A SAMPLE SMP JOB IS PROVIDED IN THE
        MEMBER TABLE. QUEUE CAN BE RUN UNDER SPF BUT THE SUBCOMMANDS
        USING THE SUBSYSTEM INTERFACE (CANCEL, REQUEUE, AND DELETE)
        WILL BE INOPERABLE, ALL OTHER COMMANDS WILL FUNCTION NORMALLY.
        IF YOU DON'T MIND THE INTEGRITY PROBLEM YOU CAN ADD CODE TO
        QUEUE TO USE A SPECIAL SVC TO GET INTO SUPERVISOR STATE AND
        HAVE FULL FACILITY UNDER SPF.

NOTE:  THE QUEUE COMMAND WAS WRITTEN FOR JES2 4.1 AT PUT TAPE 79/09
LEVEL WITH THE DUPLEX CHECKPOINT FACILITY (AZ27300). THERE IS NO REASON
THAT THE CONCEPT OF ACCESSING THE CHECKPOINT AND SPOOL WOULD NOT WORK
WITH EARLIER VERSIONS OF JES2 OR WITH NJE. THE LOCATION OF CHECKPOINT
VARIABLES AND CHECKPOINT AND SPOOL STRUCTURE MAY BE DIFFERENT AND THE
USER WILL HAVE TO MAKE APPROPRIATE CHANGES TO SUPPORT OTHER VERSIONS
OF JES2.

./ ADD NAME=HELP
)F FUNCTION -
  THE QUEUE COMMAND IS USED TO INTERROGATE THE SYSTEM QUEUES IN ORDER
  TO DETERMINE THE STATUS OF A JOB OR GROUP OF JOBS. IT ALSO PROVIDES
  ACCESS TO ALL PARTS OF A JOB WHILE IT IS ON THE QUEUE.

  FOR MORE INFORMATION, TYPE IN - QUEUE HELP.
)X SYNTAX -
         QUEUE  OPERAND    DEFAULT OPERAND IS STATUS. AN OPERAND OF
         Q                 CKPT(UNIT,VOLSER) CAN BE USED TO SPECIFY
                           A JES2 CHECKPOINT DATASET OTHER THAN THE
                           STANDARD DATASET.

./ ADD NAME=Q0
QCOMMON  TITLE 'QUEUE COMMAND - COMMON AREA'                      UF004
QCOMMON  QSTART TYPE=GLOBAL
         QCOMMON CSECT=YES
         END
./ ADD NAME=Q1
QUEUE    QSTART 'QUEUE COMMAND - MAINLINE MODULE',MAIN=YES
***********************************************************************
* RNB CHANGES:                                                        *
*      (1) RNB01 - FIX FINAL TPUT MESSAGE TO WORK WITH SPF TCAM       *
*                                                                     *
***********************************************************************
***********************************************************************
*                                                                     *
*   CALL - INITIALIZATION                                             *
*                                                                     *
***********************************************************************
         L     R15,=V(INIT)   ADDR OF INIT
         BALR  R14,R15        GO TO IT
         LA    R10,LOOP       INTERRUPTED RETURN ADDRESS
         USING QDISPLAY,R9    BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL      LOAD BASE REG
******************************************************************UF003
*                                                                 UF003
*   INITIALIZE 3270 SCREEN VARIABLES                              UF003
*                                                                 UF003
******************************************************************UF003
         GTSIZE ,             READ 3270 SCREEN SIZE               UF003
         STM   R0,R1,QDOSZR0  SAVE FOR LATER RESTORE              UF003
         LTR   R0,R0          DISPLAY DEVICE?                     UF003
         BZ    NOTDISP        NO, ABORT                           UF003
         SPACE 1                                                  UF003
         STFSMODE ON,INITIAL=YES  TELL VTAM ABOUT FULLSCREEN MODE UF003
         SPACE 1                                                  UF003
         LM    R0,R1,QDOSZR0  RESTORE DESTROYED REGS              UF003
         CH    R1,=H'80'      POSSIBLE MODEL 2 OR 4 TERMINAL?     UF003
         BNE   TRYM5          NO, TRY FOR MODEL 5                 UF003
         CH    R0,=H'43'      MODEL 4 TERMINAL?                   UF003
         BE    MODEL4         YES, SET IT                         UF003
         CH    R0,=H'32'      MODEL 3 TERMINAL?                   UF003
         BNE   SETM2          NO, SET MODEL 2 DEFAULT             UF003
         SPACE 1                                                  UF003
MODEL3   MVC   QDLNELEN,=H'80'     LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'29'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(29*80)  SCR LENGTH                   UF003
         MVC   QDSCRPLN,=AL2(29*80+QDLINE1-QDSCREEN) TPUT LEN     UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C150'    (2,1)                          UF003
         MVC   QDSCRO3,=X'E6F0'    (32,1)                         UF003
         MVC   QDSCRO4,=X'E7F7'    (32,72)                        UF003
         MVC   QDSCRO5,=X'C260'    (3,1)                          UF003
         B     LOOP                JOIN COMMON CODE               UF003
         SPACE 1                                                  UF003
MODEL4   MVC   QDLNELEN,=H'80'     LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'40'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(40*80)  SCR LENGTH                   UF003
         MVC   QDSCRPLN,=AL2(40*80+QDLINE1-QDSCREEN) TPUT LEN     UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C150'    (2,1)                          UF003
         MVC   QDSCRO3,=X'F460'    (43,1)                         UF003
         MVC   QDSCRO4,=X'F5E7'    (43,72)                        UF003
         MVC   QDSCRO5,=X'C260'    (3,1)                          UF003
         B     LOOP                JOIN COMMON CODE               UF003
         SPACE 1                                                  UF003
TRYM5    CH    R1,=H'132'     POSSIBLE MODEL 5 TERMINAL?          UF003
         BNE   SETM2          NO, FORCE MODEL 2 DEFAULT           UF003
         CH    R0,=H'27'      ACTUAL MODEL 5?                     UF003
         BNE   SETM2          NO, FORCE MODEL 2 DEFAULT           UF003
         SPACE 1                                                  UF003
MODEL5   MVC   QDLNELEN,=H'132'    LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'24'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(24*132)  SCR LENGTH                  UF003
         MVC   QDSCRPLN,=AL2(24*132+QDLINE1-QDSCREEN) TPUT LEN    UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C2C4'    (2,1)                          UF003
         MVC   QDSCRO3,=X'F5E8'    (27,1)                         UF003
         MVC   QDSCRO4,=X'F66F'    (27,72)                        UF003
         MVC   QDSCRO5,=X'C4C8'    (3,1)                          UF003
         B     LOOP                JOIN COMMON CODE               UF003
         SPACE 1                                                  UF003
SETM2    STSIZE SIZE=80,LINE=24  FORCE MODEL 2 DEFAULT            UF003
         SPACE 1                                                  UF003
         B     LOOP           GO TO PROCESS LOOP                  UF003
         SPACE 1                                                  UF003
NOTDISP  TPUT  NOTDSPL,L'NOTDSPL SEND MESSAGE TO USER             UF003
         B     EXIT2          AND RETURN TO CALLER                UF003
         SPACE 1                                                  UF003
NOTDSPL  DC    C'QUEUE COMMAND REQUIRES DISPLAY TERMINAL'         UF003
         EJECT ,                                                  UF003
***********************************************************************
*                                                                     *
*   CALL - COMMAND LINE PARSE                                         *
*                                                                     *
***********************************************************************
LOOP     DS    0H                                                 UF006
         L     R15,=V(PARSE)  ADDR OF PARSE
         BALR  R14,R15        GO TO IT
         CLC   =C'E ',QSUBNAME STOP?
         BE    EXIT           YES.
         CLC   =C'EXIT ',QSUBNAME STOP?
         BE    EXIT           YES.
         CLC   =C'END ',QSUBNAME STOP?
         BE    EXIT           YES.
         CLC   =C'STOP ',QSUBNAME STOP?
         BE    EXIT           YES.
***********************************************************************
*                                                                     *
*   CALL - SUB-COMMAND MODULE SELECTED BY PARSE                       *
*                                                                     *
***********************************************************************
         MVC   QDHLINE,DUMMY  NO OUTPUT MESSAGE
         L     R15,QSUBCMD    ADDR OF SUBCMD FROM QCOMMON
         BALR  R14,R15        GO TO IT
         MVC   QDMLNG,=H'0'   ZERO OUT MESSAGE LENGTH
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE
         BALR  R14,R15        WRITE LAST SCREEN, GET NEXT INPUT
         B     LOOP           DO IT AGAIN
***********************************************************************
*                                                                     *
*   CLEAN UP AND GO HOME                                              *
*                                                                     *
***********************************************************************
EXIT     STSIZE SIZELOC=QDOSZR1,LINELOC=QDOSZR0  RESTORE SCRSIZE  UF003
         TPUT  CLEAR,L'CLEAR,FULLSCR,MF=(E,QTPUT) CLEAR SCREEN    UF003
         STLINENO LINE=1,MODE=OFF                 OFF FULLSCR     UF003
         USING QCKPT,R8 BASE REG FOR CKPT WORK AREA
EXIT2    DS    0H                                                 UF003
         L     R8,QVCKPT      LOAD BASE REG
         CLOSE MF=(E,HOCKPT)
         CLOSE MF=(E,QCSPOOLS)
         TM    QPFLAG,HARDCPY         IS HARDCOPY INVOKED?         FCI*
         BNO   FREEUP                   NO..SPLIT THIS STUFF       FCI*
         L     R15,=V(PRINT)               INVOKE PRINT            FCI*
         MVC   QDREPLY,QBLANK                  TO                  FCI*
         MVC   QDREPLY(09),=C'PRINT OFF'          FREE UP          FCI*
         MVC   QDRLNG,=X'0009'                        HARDCOPY     FCI*
         BALR  R14,R15                                     OUTPUT  FCI*
         EJECT
***********************************************************************
*                                                                  FCI*
*   FREE HASPCKPT AND HASPACEN DDNAMES BEFORE LEAVING TO BE NEAT.. FCI*
*                                                                  FCI*
***********************************************************************
FREEUP   MVI   DAIRFLAG,X'18'    INDICATE FREE DDNAME(XXXXXXXX)    FCI*
         MVC   DA18DDN,HASPCKPT+40  GET DDNAME USED...             FCI*
         L     R15,=V(ALLOCATE)  GET ROUTINE NAME                  FCI*
         BALR  R14,R15           GO FREE IT..                      FCI*
*
         LA    R2,QCSPOOLS       GET ADDR OF LIST OF HASPACE DCBS  FCI*
         LA    R4,35             MAX OF 35 PASSES THROUGH HERE..   FCI*
FREEUP1  L     R3,0(R2)          GET ADDRESS OF DCB TO WORK ON     FCI*
         LTR   R3,R3             ANYONE THERE?                     FCI*
         BZ    EXITQCK                                             FCI*
         MVC   DA18DDN,40(R3)    MOVE IN DDNAME FROM DCB           FCI*
         L     R15,=V(ALLOCATE)  GET ROUTINE NAME                  FCI*
         BALR  R14,R15           AND GO INVOKE DAIR TO FREE IT..   FCI*
         LA    R2,4(R2)          BUMP                              FCI*
         BCT   R4,FREEUP1                                          FCI*
***********************************************************************
*                                                                     *
*   FREE THE AREAS ACQUIRED IN INIT (Q3)                              *
*                                                                     *
***********************************************************************
EXITQCK  OI    QGETL3,X'80'   PREPARE FOR FREEMAIN             PWF FCI*
         FREEMAIN MF=(E,QFREE)
         TM    QFLAG1,QFLG1DBC    NEED TO TERMINATE ESTAE?        UF024
         BZ    NOESTAE            NO, SKIP THIS                   UF024
         ESTAE 0                  DELETE CURRENT ESTAE            UF024
         NI    QFLAG1,255-QFLG1DBC  CLEAR FLAG                    UF024
NOESTAE  DS    0H                                                 UF024
         QSTOP
***********************************************************************
*                                                                     *
*   CONSTANTS AND OTHER ODDITIES                                      *
*                                                                     *
***********************************************************************
         LTORG
CLEAR1   EQU   *                   START OF CLEAR DATA            UF003
*        DC    X'27F5C1'           ESC; ERASE/WRITE; RESET MDT    UF003
         DC    X'C1'               FIX FOR SPF/TCAM               RNB01
         DC    X'115D7E'           SBA  24,80                     UF003
         DC    X'114040'           SBA  1,1                       UF003
         DC    X'3C404000'         RTA  1,1 WITH NULLS            UF003
         DC    X'1DC8'             SF, INTENSIFIED                UF003
         DC    X'13'               INSERT CURSOR                  UF003
CLEAR    EQU   CLEAR1,*-CLEAR1                                    UF003
DUMMY    DC    CL80'    NO DATA IS AVAILABLE FOR YOUR REQUEST'
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q10
INIT     QSTART 'QUEUE COMMAND - INITIALIZATION ROUTINES'
***********************************************************************
* RNB CHANGES:                                                        *
*            (3) RNB03 - IF RACF OPTION IS SET, AND IF AUTHORIZED,    *
*                        AND IF QNEWUSR IS NON-NULL, CHANGE ACEEUSER  *
*                        SO USER WILL BE AUTHORIZED TO OPEN CKPT/SPOOL*
***********************************************************************
         GBLB  &QSP           MVS/SP OPTION                       UF020
         GBLB  &QDBC          DBC    OPTION                       UF024
         GBLB  &QRACF         RACF OPTION                         RNB03
         GBLB  &QRNB          RNB OPTION FLAG                     RNB05
***********************************************************************
*                                                                     *
*   LOAD QCOMMON                                                      *
*                                                                     *
***********************************************************************
*
****
*******  IF YOU WANT TO CHANGE THE NAME FOR THE COMMON AREA,
****               THIS IS THE ONLY REFERENCE TO IT.
*
         L     R11,=V(QCOMMON) ADDR OF QCOMMON                    UF002
         LTR   R11,R11        SEE IF LINKED IN                    UF002
         BNZ   LOADED         YES, CONTINUE                       UF002
         SPACE 1                                                  UF002
         LOAD  EP=QUEUECMN    QUEUE COMMON AREA
         LR    R11,R0         ADDR OF QCOMMON
         SPACE 1                                                  UF002
LOADED   DS    0H                                                 UF002
         L     R1,4(R13)      PREVIOUS SAVE AREA
         ST    R11,64(R1)     UPDATE R11 IN PREVIOUS SAVE AREA
         ST    R1,QFRSTSA     STORE ADDR OF FIRST SAVEAREA IN QCOMMON
         USING QDAIR,R10      BASE REG FOR DAIR WORK
         L     R10,QVDAIR     LOAD BASE REG
         USING QCKPT,R9       BASE REG FOR CKPT WORK
         L     R9,QVCKPT      LOAD BASE REG
         USING QDISPLAY,R8    BASE REG FOR DISPLAY WORK
         L     R8,QVDSPL      LOAD BASE REG
***********************************************************************
*                                                                     *
*   MOVE PARMS FROM CPPL TO DAPL                                      *
*                                                                     *
***********************************************************************
         USING CPPL,R2        ADDR OF CPPL IS IN R2
         MVC   DAPLUPT,CPPLUPT USER PROFILE TABLE
         MVC   DAPLPSCB,CPPLPSCB PROTECTED STORAGE CNTL BLK
         MVC   DAPLECT,CPPLECT ENVIRONMENT CNTL TABLE
         AIF   (&QRNB).RNB02      SKIP IF AT RNB                  RNB02
******************************************************************UF010
*                                                                 UF010
*   CHECK PSCB FOR OPERATOR AUTHORITY                             UF010
*                                                                 UF010
******************************************************************UF010
         L     R1,CPPLPSCB    ADDRESS OF PSCB                     UF010
         USING PSCB,R1        ADDRESSING FOR PSCB                 UF010
         TM    PSCBATR1,PSCBCTRL  TEST FOR OPERATOR AUTHORITY     UF010
         BZ    NOTOPER        NO, SKIP THIS                       UF010
         OI    QFLAG1,QFLG1OPR    SET OPER AUTH                   UF010
         OI    QXAUTH,1           SET PRIV AUTH                   UF010
         AIF   (NOT &QDBC).NODBC1 SKIP IF DBC NOT INSTALLED       UF024
******************************************************************UF024
*                                                                 UF024
*   IF USER HAS OPER AUTHORITY, ESTABLISH ESTAE ENVIRONMENT       UF024
*                                                                 UF024
******************************************************************UF024
         LOAD  EP=DBC,ERRET=NOTOPER  LOAD ESTAE ROUTINE           UF024
         LR    R3,R0          ADDR OF ROUTINE                     UF024
         ESTAE (R3)           CREATE THE ESTAE                    UF024
         OI    QFLAG1,QFLG1DBC  INDICATE NEED TO DELETE AT TERM   UF024
.NODBC1  ANOP                                                     UF024
.RNB02   ANOP                                                     RNB02
NOTOPER  DS    0H                                                 UF010
***********************************************************************
*                                                                     *
*   MOVE COMMAND BUFFER TO REPLY BUFFER                               *
*                                                                     *
***********************************************************************
         L     R1,CPPLCBUF    ADDR OF COMMAND BUFFER
         LH    R3,0(R1)       LENGTH OF COMMAND BUFFER
         LH    R4,2(R1)       OFFSET TO FIRST DATA BYTE
         LA    R1,4(R1,R4)    FIRST DATA BYTE
         SR    R3,R4          SUBTRACT OFFSET FROM LENGTH
         SH    R3,=H'4'       SUBTRACT OVERHEAD
         SH    R3,=H'1'       IS LENGTH ZERO?
         BM    SKIP           YES. SKIP IT.
         EX    R3,OCBUF       TRANSLATE TO UPPER CASE
         CLC   =C'CKPT(',0(1) IS REQUEST FOR CKPT?
         BE    CKPT           YES. DO IT.
         MVC   QDREPLY,QBLANK BLANK THE REPLY LINE
         CH    R3,=H'62'      IS LENGTH OVER 63?
         BNH   OK             NO. USE IT.
         LA    R3,62          USE MAXIMUM LENGTH
OK       EX    R3,MVCBUF      MOVE THE DATA
         LA    R3,1(R3)       INCREMENT TO TRUE LENGTH
         STH   R3,QDRLNG      STORE REPLY LENGTH
***********************************************************************
*                                                                     *
*   LOCATE LOGON ID, MOVE TO QLOGON                                   *
*                                                                     *
***********************************************************************
SKIP     L     R1,16          ADDR OF CVT
         L     R1,0(R1)       ADDR OF DISPATCH QUEUE
         L     R1,12(R1)      ADDR OF CURRENT ASCB
         L     R1,176(R1)     ADDR OF JOBNAME
         MVC   QLOGON,0(R1)   MOVE JOBNAME TO QLOGON
***********************************************************************
*                                                                     *
*   OBTAIN BLOCK ADDR TABLE FOR LISTDS                                *
*                                                                     *
***********************************************************************
         GETMAIN R,LV=65536
         ST    R1,QGETA1      SAVE START ADDR OF GETMAIN
         ST    R1,QCSTART     STORE STARTING ADDR OF TABLE
         A     R1,=F'65536'   END OF TABLE
         ST    R1,QCEND
***********************************************************************
*                                                                     *
*   ALLOCATE HASPCKPT                                                 *
*                                                                     *
***********************************************************************
         MVC   DA08DDN,=CL8'HASPCKPT' DDNAME FOR ALLOCATE
         MVC   DA08PDSN,=A(DSNCKPT) DSNAME FOR ALLOCATE
         MVI   DAIRFLAG,X'08' REQUEST ALLOCATE FUNCTION
         L     R15,=V(ALLOCATE) ADDR OF ALLOCATE MODULE
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   OPEN HASPCKPT, READ FIRST BLOCK OF CHECKPOINT                     *
*                                                                     *
***********************************************************************
         AIF   (NOT &QRACF).RNB03B                                RNB03
         TESTAUTH FCTN=1             APF-AUTHORIZED?              RNB03
         LTR   R15,R15                                            RNB03
         BNZ   RNB03A                /NO  - CAN'T CHG ACEEUSER    RNB03
*                                    /YES -                       RNB03
         RACSTAT ,                   IS RACF UP?                  RNB03
         LTR   R15,R15                                            RNB03
         BNZ   RNB03A                /NO  - CAN'T CHG ACEEUSER    RNB03
*                                    /YES -                       RNB03
         CLI   QNEWUSR,0             IS THERE A NEW USERID TO USE?RNB03
         BE    RNB03A                /NO  - CAN'T CHG ACEEUSER    RNB03
*                                    /YES - CHANGE ACEEUSER TO    RNB03
*                                           ALLOW ACCESS TO THE   RNB03
*                                           SPOOL/CKPT DATA SETS  RNB03
         L     R2,CVTPTR             CVT                          RNB03
         USING CVT,R2                #####                        RNB03
         L     R2,CVTTCBP            TCB WORDS                    RNB03
         L     R2,12(,R2)            CURRENT ASCB                 RNB03
         USING ASCB,R2               #####                        RNB03
         L     R2,ASCBASXB           ASXB                         RNB03
         USING ASXB,R2               #####                        RNB03
         ICM   R2,15,ASXBSENV        ACEE                         RNB03
         BZ    RNB03A                FORGET IT IF NO ACEE         RNB03
         USING ACEE,R2               #####                        RNB03
         CLC   =C'ACEE',ACEEACEE     REALLY AN ACEE?              RNB03
         BNE   RNB03A                /NO  - FORGET IT             RNB03
         MVC   QUSRSAV,ACEEUSER      /YES - SAVE CURRENT USERID   RNB03
         STAX  DEFER=YES             DON'T ALLOW ATTENTION'S      RNB03
         MODESET KEY=ZERO            GET KEY ZERO TO UPDATE ACEE  RNB03
         MVC   ACEEUSER,QNEWUSR      SET NEW USERID               RNB03
         MODESET KEY=NZERO           BACK TO USER KEY             RNB03
RNB03A   EQU   *                                                  RNB03
.RNB03B  ANOP                                                     RNB03
         OPEN  MF=(E,HOCKPT)  OPEN HASPCKPT
         L     R2,QCSTART     USE TABLE AREA FOR IOAREA
         POINT HASPCKPT,TIR3  POINT PAST SYNC RECORDS
         READ  HDECB1,SF,,(R2),MF=E READ FIRST RECORD
         CHECK HDECB1
***********************************************************************
*                                                                     *
*   COMPUTE OFFSET TO FIRST PDDB IN IOT                               *
*                                                                     *
***********************************************************************
         USING $SAVEBEG,R2    BASE REG FOR CHECKPOINT
         AIF   (&QSP).QSP1                                        UF020
         LH    R5,$NUMTGV     NUMBER OF TRACK GROUPS PER VOLUME
         LA    R5,7(R5)       ROUND UP TO MULTIPLE OF 8
         SRL   R5,3           DIVIDE BY 8
         SR    R0,R0          ZERO OUT R0
         IC    R0,$NUMDA      NUMBER OF SPOOL VOLUMES
         MR    R4,R0          LENGTH OF TRACK GROUP MAP IN R5
         AGO   .QSP2                                              UF020
.QSP1    ANOP                                                     UF020
         LH    R5,$NUMTG      NUMBER OF TRACK GROUPS PER VOLUME   UF020
         LA    R5,7(R5)       ROUND UP TO MULTIPLE OF 8           UF020
         SRL   R5,3           DIVIDE BY 8                         UF020
.QSP2    ANOP                                                     UF020
         LR    R1,R5          SAVE LENGTH OF TRACK GROUP MAP
         LA    R5,IOTTGMAP-IOTSTART+TGMAP-TGMDSECT+3(R5) OFFSET
         N     R5,=F'-4'      ROUND TO FULL WORD BOUNDARY
         ST    R5,QCPDDB1     SAVE OFFSET TO FIRST PDDB IN IOT
         AIF   (NOT &QSP).QSP3                                    UF020
***********************************************************************
*                                                                     *
*   COMPUTE NUMBER OF JIX BLOCKS ON CKPT                              *
*                                                                     *
***********************************************************************
         LH    R5,$NUMJBNO    NUMBER OF JOB NUMBERS               UF020
         LA    R5,1(,R5)       PLUS 1 FOR HEADER                  UF020
         SLL   R5,1           TIMES LENGTH OF 2                   UF020
         LA    R5,4095(R5)    PREPARE TO ROUND                    UF020
         SRL   R5,12          DIVIDE BY 4096                      UF020
         STH   R5,QCJIXL      NUMBER OF BLOCKS FOR JIX            UF020
.QSP3    ANOP                                                     UF020
***********************************************************************
*                                                                     *
*   COMPUTE NUMBER OF JQE BLOCKS ON CKPT                              *
*                                                                     *
***********************************************************************
         LH    R6,$MAXJOBS    NUMBER OF JQES
         LA    R6,1(,R6)       PLUS 1 FOR EYE-CATCHER
         MH    R6,=AL2(JQELNGTH) MULTIPLY BY LENGTH OF JQE
         LA    R6,4095(R6)    PREPARE TO ROUND
         SRL   R6,12          DIVIDE BY 4096
         STH   R6,QCJQTL      NUMBER OF BLOCKS FOR JQES
***********************************************************************
*                                                                     *
*   COMPUTE NUMBER OF JOT BLOCKS IN CKPT                              *
*                                                                     *
***********************************************************************
         LH    R3,$NUMJOES    NUMBER OF JOES
         LA    R3,NJOTPRFX(,R3) ADJUSTED LENGTH OF JOT PREFIX
         MH    R3,=AL2(JOESIZE) MULTIPLY BY LENGTH OF JOE
         LA    R3,4095(R3) PREPARE TO ROUND
         SRL   R3,12          DIVIDE BY 4096
         STH   R3,QCJOTL      NUMBER OF BLOCKS FOR JOT
***********************************************************************
*                                                                     *
*   COMPUTE TOTAL LENGTH OF QSES                                      *
*                                                                     *
***********************************************************************
         LA    R4,QSELEN      QSE LENGTH
         MH    R4,$QSENO      MULTIPLY LENGTH TIMES NUMBER OF QSES
         AIF   (NOT &QSP).QSP5                                    UF020
         ALR   R4,R5          ADD ONE BYTE FOR EACH JIX BLOCK     UF020
******************************************************************UF020
*                                                                 UF020
*   COMPUTE NUMBER OF MSQ BLOCKS ON CKPT                          UF020
*                                                                 UF020
******************************************************************UF020
         LH    R1,$NUMRJE     NUMBER OF REMOTES                   UF020
         MH    R1,=Y(3)       TIMES LENGTH OF 3                   UF020
         LA    R1,3(,R1)       PLUS HEADER LENGTH                 UF020
         LA    R1,4095(R1)    PREPARE TO ROUND                    UF020
         SRL   R1,12          DIVIDE BY 4096                      UF020
         ALR   R4,R1          ADD 1 BYTE FOR EACH BLOCK           UF020
******************************************************************UF020
*                                                                 UF020
*   COMPUTE NUMBER OF RSO BLOCKS ON CKPT                          UF020
*                                                                 UF020
******************************************************************UF020
         LH    R1,$NUMRJE     NUMBER OF REMOTES                   UF020
         LA    R1,4095(R1)    PREPARE TO ROUND                    UF020
         SRL   R1,12          DIVIDE BY 4096                      UF020
         ALR   R4,R1          ADD 1 BYTE FOR EACH BLOCK           UF020
******************************************************************UF020
*                                                                 UF020
*   COMPUTE NUMBER OF LCK BLOCKS ON CKPT                          UF020
*                                                                 UF020
******************************************************************UF020
*        LH    R1,$NUMLCK     NUMBER OF LOAD CKPT ELEMENTS        UF020
         LA    R1,9*7         NUMBER OF LOAD CKPT ELEMENTS        UF020
         MH    R1,=Y(LCKSIZE) TIMES LENGTH OF EACH                UF020
         LA    R1,4095(R1)    PREPARE TO ROUND                    UF020
         SRL   R1,12          DIVIDE BY 4096                      UF020
         ALR   R4,R1          ADD 1 BYTE FOR EACH BLOCK           UF020
.QSP5    ANOP                                                     UF020
         ALR   R4,R6          ADD ONE BYTE FOR EACH JQE BLOCK
         ALR   R4,R3          ADD ONE BYTE FOR EACH JOT BLOCK
***********************************************************************
*                                                                     *
*   COMPUTE HASPACE BUFFER SIZE                                       *
*                                                                     *
***********************************************************************
         LH    R5,$BUFSIZE    BLKSIZE FOR HASPACE
         STH   R5,HASPACE+62  STORE IN DCB
         STH   R5,HDECB2+6    STORE IN DECB
         LA    R5,63(R5)      PREPARE TO ROUND
         N     R5,=F'-64'     ROUND TO 64 BYTE BOUNDARY
***********************************************************************
*                                                                     *
*   OBTAIN BUFFERS FOR HASPCKPT AND HASPACE                           *
*                                                                     *
***********************************************************************
         LR    R14,R5         HASPACE BUFFER SIZE
         MH    R14,=H'3'      3 BUFFERS
         LA    R1,1(R6,R3)    NUMBER OF BLOCKS IN CKPT DS
         AIF   (NOT &QSP).QSP6                                    UF020
         AH    R1,QCJIXL      ADD NUMBER OF JIX BLOCKS            UF020
.QSP6    ANOP                                                     UF020
         ST    R1,QCJOTL      STORE RECORD COUNT
         SLL   R1,12          MULTIPLY BY 4096
         LA    R0,256(R1,R14) ADD CKPT BUFFERS, HASPACE BUFFERS, SLOP
         ST    R0,QGETL2      SAVE LENGTH OF GETMAIN AREA
         GETMAIN R,LV=(0)     OBTAIN BUFFERS
         ST    R1,QGETA2      SAVE ADDRESS OF GETMAIN AREA
         ST    R1,QCJQTL      BUFFER FOR FIRST CKPT REC
         AH    R1,=H'4096'    INCREMENT
         AIF   (NOT &QSP).QSP7                                    UF020
         ST    R1,QCJIXA      BUFFER FOR JIX BLOCKS               UF020
         LH    R15,QCJIXL     NUMBER OF JIX BLOCKS                UF020
         SLL   R15,12         TIMES 4096                          UF020
         AR    R1,R15         INCREMENT                           UF020
.QSP7    ANOP                                                     UF020
         ST    R1,QCJQTA      BUFFER FOR JQE BLOCKS
         SLL   R6,12          MULTIPLY BY 4096
         AR    R1,R6          INCREMENT
         ST    R1,QCJOTA      BUFFER FOR JOE BLOCKS
         SLL   R3,12          MULTIPLY BY 4096
         AR    R1,R3          INCREMENT
         ST    R1,QCJCTA      BUFFER FOR JCT
         AR    R1,R5          INCREMENT
         ST    R1,QCIOTA      BUFFER FOR IOT
         AR    R1,R5          INCREMENT
         ST    R1,QCBLKA      BUFFER FOR DATA BLOCKS
         AIF   (NOT &QSP).QSP8                                    UF020
         LA    R1,$JQHEADS+$JQHEADL-$SAVEBEG OFFSET 1ST JQE HEAD  UF020
         AGO   .QSP9                                              UF020
.QSP8    ANOP                                                     UF020
         LA    R1,$JQHEADS+2-$SAVEBEG OFFSET TO FIRST JQE HEADER
.QSP9    ANOP                                                     UF020
         A     R1,QCJQTL      BASE OF FIRST CKPT REC
         ST    R1,QCJQHEAD    ADDR OF FIRST JQE HEADER
***********************************************************************
*                                                                     *
*   ALLOCATE AND OPEN HASPACE                                         *
*                                                                     *
***********************************************************************
         LA    R3,$SAVEEND(R4) ADDR OF DA CKPT INFO
.EXIT    ANOP
         MVC   DA08DDN,=CL8'HASPACE' DDNAME FOR ALLOCATE
         MVC   DA08PDSN,=A(DSNSPACE) DSNAME FOR ALLOCATE
         LA    R4,9           MAX POSSIBLE SPOOLS FOR QUEUE       UF020
         AIF   (&QSP).QSP10                                       UF020
         IC    R4,$NUMDA      MAXIMUM NUMBER OF SPOOL VOLUMES
.QSP10   ANOP                                                     UF020
         LA    R7,QCDCBL      LENGTH OF HASPACE DCB
         MR    R6,R4          COMPUTE LENGTH OF DCB POOL
         GETMAIN R,LV=(R7)    OBTAIN DCB POOL
         ST    R7,QGETL3      SAVE LENGTH OF GETMAIN
         ST    R1,QGETA3      SAVE ADDRESS OF GETMAIN
         LR    R7,R1          SAVE ADDR OF DCB POOL
         LA    R8,QCSPOOLS-4  ADDR OF OPEN LIST
         SR    R6,R6          ACTUAL NUMBER OF SPOOL VOLUMES
         MVC   DA08SER(5),$SPOOL PATTERN FOR VOLSER
SPOOL1   LA    R5,DEVTAB      ADDR OF DEVICE CHARACTERISTICS TBL
         CLI   0(R3),0        IS THIS VOLUME UNUSED?
         BE    SPOOL4         YES. TRY NEXT.
SPOOL2   CLI   0(R5),X'FF'    IS THIS THE END OF TABLE?
         BE    ABORT          YES. UNSUPPORTED DEVICE TYPE.
         CLC   0(1,R5),0(R3)  IS THIS A MATCH?
         BE    SPOOL3         YES. GO WITH IT.
         LA    R5,12(R5)      NEXT TABLE ENTRY
         B     SPOOL2         TRY NEXT ENTRY
SPOOL3   MVC   150(2,R8),2(R5) MOVE TRK/CYL TO TRK/CYL LIST
         MVC   DA08UNIT,4(R5) MOVE UNIT NAME
         MVC   DA08SER+5(1),1(R3) LAST DIGIT OF VOLSER
         LA    R6,1(R6)       INCREASE COUNT BY ONE
         STC   R6,DA08DDN+7   UPDATE DDNAME
         OI    DA08DDN+7,X'F0' MAKE IT A VALID NUMBER
         L     R15,=V(ALLOCATE) ADDR OF ALLOCATE MODULE
         BALR  R14,R15        GO TO IT
         MVC   0(QCDCBL,R7),HASPACE MOVE PATTERN DCB TO POOL
         MVC   47(1,R7),DA08DDN+7 UPDATE THE DDNAME
         ST    R7,4(R8)       STORE DCB ADDR IN OPEN LIST
         LA    R7,QCDCBL(R7)  INCREMENT TO NEXT DCB
         LA    R8,4(R8)       NEXT ENTRY IN OPEN LIST
SPOOL4   LA    R3,6(R3)       NEXT VOLUME
         BCT   R4,SPOOL1      BRANCH IF MORE VOLUMES.
         OI    0(R8),X'80'    INDICATE END OF OPEN LIST
         OPEN  MF=(E,QCSPOOLS) OPEN HASPACE
         AIF   (NOT &QRACF).RNB03D                                RNB03
         CLI   QUSRSAV,0           DID WE CHANGE ACEEUSER?        RNB03
         BE    RNB03C              /NO  - SKIP THIS CODE          RNB03
*                                  /YES - PUT USERID BACK         RNB03
         L     R2,CVTPTR             CVT                          RNB03
         USING CVT,R2                #####                        RNB03
         L     R2,CVTTCBP            TCB WORDS                    RNB03
         L     R2,12(,R2)            CURRENT ASCB                 RNB03
         USING ASCB,R2               #####                        RNB03
         L     R2,ASCBASXB           ASXB                         RNB03
         USING ASXB,R2               #####                        RNB03
         ICM   R2,15,ASXBSENV        ACEE                         RNB03
         USING ACEE,R2               #####                        RNB03
         MODESET KEY=ZERO            GET KEY ZERO TO UPDATE ACEE  RNB03
         MVC   ACEEUSER,QUSRSAV      SET OLD USERID               RNB03
         MODESET KEY=NZERO           BACK TO USER KEY             RNB03
         STAX  DEFER=NO              ALLOW ATTENTION INTERRUPTS   RNB03
RNB03C   EQU   *                                                  RNB03
.RNB03D  ANOP                                                     RNB03
***********************************************************************
*                                                                     *
*   GO HOME                                                           *
*                                                                     *
***********************************************************************
         QSTOP
***********************************************************************
*                                                                     *
*   PROCESS REQUEST FOR DIFFERENT UNIT AND VOL ON SYS1.HASPCKPT       *
*                                                                     *
***********************************************************************
*
*** FORMAT - QUEUE CKPT(UNIT,VOLSER)
*
CKPT     MVC   DA08UNIT(16),QBLANK BLANK THE UNIT AND VOLSER FIELDS
         LA    R5,DA08UNIT    START OF UNIT FIELD
         LA    R6,DA08SER     START OF VOLSER FIELD
         SH    R3,=H'4'       SUBTRACT OVERHEAD FROM LENGTH
CKPT1    CLI   5(R1),C','     IS THIS THE END OF UNIT FIELD?
         BE    CKPT2          YES. PROCESS VOLSER NEXT.
         MVC   0(1,R5),5(R1)  MOVE ONE BYTE OF UNIT NAME
         LA    R5,1(R5)       ADD 1 TO RECEIVING ADDR
         LA    R1,1(R1)       ADD 1 TO SENDING ADDR
         BCT   R3,CKPT1       BRANCH IF NOT EXHAUSTED.
         B     ABORT2         INVALID PARAMETERS.
CKPT2    CLI   6(R1),C')'     IS THIS THE END OF VOLSER FIELD?
         BE    CKPT3          YES. CONTINUE PROCESSING.
         MVC   0(1,R6),6(R1)  MOVE ONE BYTE TO VOLSER
         LA    R6,1(R6)       ADD ONE TO RECEIVING ADDR
         LA    R1,1(R1)       ADD ONE TO SENDING ADDR
         BCT   R3,CKPT2       BRANCH IF NOT EXHAUSTED.
         B     ABORT2         INVALID PARAMETER.
CKPT3    CLI   DA08UNIT,C' '  IS THERE A UNIT?
         BE    ABORT2         NO. INVALID.
         CLI   DA08SER,C' '   IS THERE A VOLSER?
         BE    ABORT2         NO. INVALID.
         CLI   DA08BLK,0      DID WE GO TOO FAR?
         BE    SKIP           NO. EVERTHING LOOKS GOOD.
ABORT2   TPUT  MESSAGE2,L'MESSAGE2,EDIT,MF=(E,QTPUT) TELL THE USER
         ABEND 97,DUMP        QUIT
***********************************************************************
*                                                                     *
*   UNSUPPORTED DEVICE TYPE. ABORT.                                   *
*                                                                     *
***********************************************************************
ABORT    TPUT  MESSAGE,L'MESSAGE,EDIT,MF=(E,QTPUT)   TELL THE USER
         ABEND 98,DUMP        QUIT.
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
OCBUF    OC    0(1,R1),QBLANK TRANSLATE COMMAND TO UPPER CASE
MVCBUF   MVC   QDREPLY(1),0(R1) MOVE DATA TO REPLY
DEVTAB   DC    X'0900',H'19',CL8'3330' DEVTYPE,TRK/CYL,DEVNAME
         DC    X'0B00',H'30',CL8'3350'
         DC    X'0D00',H'19',CL8'3330-1'
         DC    X'0E00',H'15',CL8'3380  '
         DC    X'FFFF'
         DS    0F
TIR3     DC    X'00000300'    POINT PAST SYNC RECORDS
DSNCKPT  DC    H'13',CL44'SYS1.HASPCKPT'
DSNSPACE DC    H'12',CL44'SYS1.HASPACE'
MESSAGE  DC    C'UNSUPPORTED DEVICE TYPE SPECIFIED FOR SPOOL'
MESSAGE2 DC    C'INVALID PARAMETER SPECIFIED - CKPT(UNIT,VOLSER)'
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
INIT     CSECT ,                                                  UF023
         GBLC  &VERSION
&VERSION SETC  '0'
         AIF   (NOT &QSP).QSP99A                                  UF020
$MAXNODE EQU   1000           FOR SP2 $JOT DSECT                  UF020
         AGO   .QSP99B                                            UF020
.QSP99A  ANOP                                                     UF020
$MAXNODE EQU   99             FOR NJE $JOT DSECT                  UF001
.QSP99B  ANOP                                                     UF020
SAVE     EQU   13             NEEDED FOR NJE $PCE                 UF001
         $PCE  ,              NEEDED FOR NJE $HCT                 UF001
         $JOE
         $JOT
NJOTPRFX EQU   (JOTJOES-JOTDSECT)/JOESIZE
BASE1    EQU   0
$RPS     EQU   0
$MSGID   EQU   0
$DUPVOLT EQU   0
$PRIOOPT EQU   0
$PRTBOPT EQU   0
$PRTRANS EQU   0
$QSONDA  EQU   0
         AIF   (NOT &QSP).QSP99                                   UF020
*        EQUATES REQUIRED FOR $HCT EXPANSION                      UF020
FF       EQU   X'FF'                                              UF020
$CMBDEF  EQU   15                                                 UF020
$JQEDEF  EQU   100                                                UF020
$MAXDA   EQU   32                                                 UF020
$MAXJBNO EQU   9999                                               UF020
$SMFDEF  EQU   5                                                  UF020
$TGDEF   EQU   3072                                               UF020
*JCT      EQU   10                                         VBA01  UF020
         $LCK  ,                                                  UF020
.QSP99   ANOP                                                     UF020
JCT      EQU    10                                         VBA01
         $BUFFER                                                  UF020
         $JCT  ,                                                  UF020
         $CAT  ,                                                  UF020
         $TAB
         $QSE
         $PDDB                                                    UF021
         $IOT
         $TGM
         $JQE
         $HCT
         IKJCPPL
         IKJPSCB                                                  UF010
         AIF   (NOT &QRACF).RNB03E                                RNB03
         PUSH  PRINT                                              RNB03
         PRINT NOGEN                                              RNB03
         CVT   DSECT=YES                                          RNB03
         IHAASCB ,                                                RNB03
         IHAASXB ,                                                RNB03
         IHAACEE ,                                                RNB03
         POP   PRINT                                              RNB03
.RNB03E  ANOP                                                     RNB03
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q11
JCL      QSTART 'QUEUE COMMAND - LIST THE JCL FOR A JOB'
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   CALL LISTDS TO LIST THE DATASET                                   *
*                                                                     *
***********************************************************************
         MVC   QPOFFSET,=H'10' PRINT OFFSET FOR EACH RECORD
         MVC   QPDSID,=H'3'   DSID OF DATASET TO BE PRINTED
         L     R15,=V(LISTDS) ADDR OF LISTDS MODULE
         BALR  R14,R15        GO TO IT
         QSTOP
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q12
JLOG     QSTART 'QUEUE COMMAND - LIST THE JOBLOG MESSAGES FOR A JOB'
         GBLB  &QRNB                                              RNB04
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   DETERMINE IF JOB LOG IS AVAILABLE                                 *
*                                                                     *
***********************************************************************
         USING PDBDSECT,R2    BASE REG FOR PDDB
         USING IOTSTART,R3    BASE REG FOR IOT
         L     R3,QCIOTA      LOAD BASE REG
NEXTIOT  LR    R4,R3          BASE OF IOT
         A     R4,IOTPDDBP    OFFSET BEYOND LAST PDDB
         LR    R2,R3          BASE OF IOT
         A     R2,QCPDDB1     OFFSET TO FIRST PDDB IN JOT
FINDDS   CLC   PDBDSKEY,=H'2' IS THIS THE JOB LOG
         BE    FOUNDDS        YES. CONTINUE.
         LA    R2,PDBLENG(R2) NO. LOOK AT NEXT PDDB
         CR    R2,R4          HAVE WE GONE PAST THE LAST PDDB
         B
//MVS0040  JOB (SYSGEN),VB,CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1)
//CLEANUP EXEC PGM=IDCAMS
//SYSPRINT DD  SYSOUT=*
//SYSIN    DD *
 DELETE JES2.QUEUE.ASM NONVSAM
 DELETE JES2.QUEUE.OBJ NONVSAM
 SET LASTCC = 0
 SET MAXCC = 0
//ALLOC   EXEC PGM=IEBUPDTE,PARM=NEW
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DISP=(NEW,CATLG),DSN=JES2.QUEUE.ASM,DCB=SYS1.MACLIB,
//             SPACE=(CYL,(5,5,20)),UNIT=3350,VOL=SER=MVSDLB
//SYSUT3   DD  DISP=(NEW,CATLG),DSN=JES2.QUEUE.OBJ,
//             DCB=(LRECL=80,BLKSIZE=3120,RECFM=FB),
//             SPACE=(CYL,(1,1,20)),UNIT=3350,VOL=SER=MVSDLB
//SYSIN    DD  DATA,DLM=##
./ ADD NAME=$JQT
         MACRO -- JQT -- PHONY DSECT TO DESCRIBE FIRST CKPT REC
         $JQT
JQTDSECT DSECT
         GBLB  &QSP                                               UF020
         AIF   (&QSP).QSP1                                        UF020
JQTOUT   DS    H              HEADER FOR OUTPUT JQES
         DS    7H
JQTSTC   DS    H
JQTTSU   DS    H              HEADER FOR TSO USER JQES
JQTCLSA  DS    H              HEADER FOR CLASS A JQES
JQTQMAX  EQU   46             MAXIMUM NUMBER OF QUEUES
         MEXIT                                                    UF020
.QSP1    ANOP                                                     UF020
JQTOUT   DS    F              HEADER FOR PRINT/PUNCH JQES         RNB19
JQTAWOUT DS    F              HEADER FOR OUTPUT JQES (AWAITING)   RNB19
JQTDUMP  DS    F              HEADER FOR DUMP JQE'S               RNB19
         DS    4F                                                 RNB19
JQTXEQ   DS    F              HEADER FOR XEQ (CONVERSION) JQE'S   RNB19
JQTSTC   DS    F                                                  UF020
JQTTSU   DS    F              HEADER FOR TSO USER JQES            UF020
JQTCLSA  DS    F              HEADER FOR CLASS A JQES             UF020
JQTQMAX  EQU   48             MAXIMUM NUMBER OF QUEUES            UF020
         MEND
./ ADD NAME=$SP
THE SP VERSION OF THE QUEUE COMMAND IS OBTAINED BY SPECIFYING
"SYSPARM=((SP))" FOR THE ASSEMBLIES (SEE MEMBER $NERJCL2).
MEMBER QSTART CAN ALSO BE UPDATED TO CHANGE THE DEFAULT FLAG SETTING
TO ELIMINATE THE NEED TO SPECIFY ANY SYSPARM AT ALL.

SEE MEMBER $UFDOC FOR A DESCRIPTION OF THE OTHER MODIFICATIONS.

THIS VERSION OF QUEUE WAS DEVELOPED AS IN INTERNAL AID FOR THE DEBUGGING
OF THE NEW JES2 SYSTEM, WHICH NORMALLY RUNS AS A SECONDARY SUBSYSTEM.
IT IS BELIEVED THAT MOST OF THE DISPLAY COMMANDS WORK PROPERLY, WITH THE
EXCEPTION OF STATUS AND DO.  BOTH OF THERE COMMANDS ARE IN MODULE Q20
(SEARCH).  THE PROBLEM WITH THE DISPLAY OUTPUT COMMANDS IS THAT THERE
ARE NOW TWO QUEUES FOR OUTPUT JOES, ONE FOR LOCAL ROUTING, AND THE OTHER
FOR REMOTE ROUTING.  AT THIS TIME ONLY THE LOCAL ROUTING QUEUE IS
PROCESSED.  THE PROBLEM WITH THE STATUS COMMAND SEEMS TO BE THAT THE
COMMAND SKIPS SOME OF THE QUEUES ENTIRELY, BUT THAT SEEMED TO BE A
PROBLEM WITH THE OLD VERSION OF THE COMMAND AS WELL.
IN PARTICULAR, JOBS IN THE OUTPUT QUEUE (NOT HARDCOPY) SEEM TO
BE IGNORED IN ALL ENVIRONMENTS.

THIS VERSION WILL NOT WORK IF ANY OF THE DEFINED SPOOL VOLUMES
ARE NOT AVAILABLE, INCLUDING A SPOOL VOLUME THAT WAS ADDED AND
THEN PURGED AT A LATER TIME.

THERE WAS ONE PROBLEM WITH THE SYSLOG COMMAND CAUSED BY A CHANGE IN
THE WAS THAT SPUN OUTPUT PDDB'S ARE GENERATED.  IT APPEARS THAT A
SPUN SYSOUT WILL NOW HAVE TWO SEPARATE PDDB'S; A NULL ONE IN THE
NORMAL IOT, AND THE TRUE ONE IN A SPIN IOT.  BECAUSE BOTH OF THE
PDDB'S HAVE THE SAME NUMBER, NORMAL QUEUE PROCESSING WOULD LOCATE
THE FIRST ONE, SEE THAT IT WAS NULL, AND INDICATE THAT THE FILE WAS
EMPTY.  CODE HAS BEEN CHANGED IN LISTDS TO CHECK IF THE MTTR FIELD
IS ZERO BEFORE TESTING FOR THE PROPER DATASET ID NUMBER.  ANY PDDB
WITH A ZERO MTTR FIELD WILL BE IGNORED.  THE ONLY POSSIBLE CHANGE
THAT THE USER WILL NOTICE IS THAT THERE WILL BE TIMES WHEN THE OLD
VERSION WOULD INDICATE "DATASET IS EMPTY" WHILE THE NEW VERSION
WILL INDICATE "DATASET ID NOT FOUND".

AT THIS TIME THE FINDPDDB ROUTINE HAS NOT BEEN CHANGED, SO THE
DD COMMAND WILL PROBABLY GIVE SOME INCORRECT INDICATIONS ABOUT
THE STATUS OF SOME SYSOUTS.

A PDDB COMMAND HAS BEEN ADDED THAT WILL DUMP OUT SOME OF THE MORE
RELEVANT INFORMATION ABOUT THE PDDB'S IN GENERAL, OR DUMP OUT
SELECTED ONES IN HEX, TO ASSIST IN FIGURING OUT WHAT IS REALLY
GOING ON.

I WOULD APPRECIATE HEARING FROM ANYONE WHO COMES UP WITH EITHER
ADDITIONAL BUGS OR FIXES TO THE KNOWN ONES.  ALSO, I WILL TRY TO
PASS ON ANY FIXES TO THOSE USERS THAT I AM AWARE OF, SO PLEASE DROP
ME A NOTE IF YOU GET THIS OFF OF ONE OF THE MODS TAPES.

JACK SCHUDEL
NORTHEAST REGIONAL DATA CENTER
233 SSRB, UNIVERSITY OF FLORIDA
GAINESVILLE, FLORIDA  32611
(904) 392-4601
SHARE CODE - UF

./ ADD NAME=$WARN
//*                                                                 *   00013
//*            *******************************************          *   00014
//*            *                                          *         *   00015
//*            * SOME INSTALLATIONS HAVE HAD THE          *         *   00016
//*            * FOLLOWING PROBLEM WITH QUE. IT ASSEMBLES *         *   00017
//*            * FINE BUT IT NEVER PUTS ANYTHING OUT TO   *         *   00018
//*            * THE SCREEN. THE CIRCUMVENTION IS TO GET  *         *   00019
//*            * THE TPUT AND TGET MACROS FROM PUT TAPE   *         *   00020
//*            * 8007. I DO NOT KNOW WHAT THE PTF NUMBERS *         *   00021
//*            * ARE, WHEN I FIND OUT I WILL ADD THEM     *         *   00022
//*            * HERE.                                    *         *   00023
//*            *                                          *         *   00024
//*            ********************************************         *   00025
./ ADD NAME=C
//ASMLQUE JOB (QUEUE),VB,CLASS=A,MSGCLASS=A,REGION=2048K
//ASMLQUE PROC M=MISSING,SP='NOSP,NODEBUG'
//ASM     EXEC PGM=IFOX00,
//             PARM='DECK,NOLOAD,TERM,TEST,SYSPARM((&SP))'
//SYSLIB   DD  DISP=SHR,DSN=JES2.QUEUE.ASM
//         DD  DISP=SHR,DSN=SYS1.HASPSRC
//         DD  DISP=SHR,DSN=SYS1.MACLIB
//         DD  DISP=SHR,DSN=SYS1.AMODGEN
//SYSUT1   DD  SPACE=(CYL,(25,5)),UNIT=VIO
//SYSUT2   DD  SPACE=(CYL,(25,5)),UNIT=VIO
//SYSUT3   DD  SPACE=(CYL,(25,5)),UNIT=VIO
//SYSTERM  DD  SYSOUT=*
//SYSPRINT DD  SYSOUT=*
//SYSIN    DD  DISP=SHR,DSN=JES2.QUEUE.ASM(&M)
//SYSPUNCH DD  DISP=SHR,DSN=JES2.QUEUE.OBJ(&M)
//        PEND
//Q00     EXEC ASMLQUE,M=Q0                     QCOMMON
//Q01     EXEC ASMLQUE,M=Q1                     QUEUE
//Q02     EXEC ASMLQUE,M=Q2                     ALLOCATE
//Q03     EXEC ASMLQUE,M=Q3                     CKPT
//Q04     EXEC ASMLQUE,M=Q4                     DDNAME
//Q05     EXEC ASMLQUE,M=Q5                     DISPLAY
//Q06     EXEC ASMLQUE,M=Q6                     FINDJOB
//Q07     EXEC ASMLQUE,M=Q7                     FORMAT
//Q08     EXEC ASMLQUE,M=Q8                     HELP
//Q09     EXEC ASMLQUE,M=Q9                     HEXBLK
//Q10     EXEC ASMLQUE,M=Q10                    INIT
//Q11     EXEC ASMLQUE,M=Q11                    JCL
//Q12     EXEC ASMLQUE,M=Q12                    JLOG
//Q13     EXEC ASMLQUE,M=Q13                    JMSG
//Q14     EXEC ASMLQUE,M=Q14                    LIST
//Q15     EXEC ASMLQUE,M=Q15                    LISTDS
//Q16     EXEC ASMLQUE,M=Q16                    PARSE
//Q17     EXEC ASMLQUE,M=Q17                    READSPC
//Q18     EXEC ASMLQUE,M=Q18                    REPOS
//Q19     EXEC ASMLQUE,M=Q19                    SAVE
//Q20     EXEC ASMLQUE,M=Q20                    SEARCH
//Q21     EXEC ASMLQUE,M=Q21                    SYSLOG
//Q22     EXEC ASMLQUE,M=Q22                    XDS
//Q23     EXEC ASMLQUE,M=Q23                    INITS
//Q24     EXEC ASMLQUE,M=Q24                    ACTIVE
//Q25     EXEC ASMLQUE,M=Q25                    FINDPDDB
//Q26     EXEC ASMLQUE,M=Q26                    SYSOUT
//Q27     EXEC ASMLQUE,M=Q27                    PRINT
//Q28     EXEC ASMLQUE,M=Q28                    HEXDUMP
//Q29     EXEC ASMLQUE,M=Q29                    CJQE
//Q30     EXEC ASMLQUE,M=Q30                    CJCT
//Q31     EXEC ASMLQUE,M=Q31                    CTSO
//Q32     EXEC ASMLQUE,M=Q32                    CHCT
//Q33     EXEC ASMLQUE,M=Q33                    CPDDB
//Q34     EXEC ASMLQUE,M=Q34                    CJOE
//LKED    EXEC PGM=IEWL,PARM='XREF,LIST,LET,TEST,AC=1',REGION=1024K
//SYSLMOD  DD  DSN=SYS2.CMDLIB,DISP=SHR
//SYSUT1   DD  UNIT=SYSDA,SPACE=(CYL,(8,1))
//SYSPRINT DD  SYSOUT=*
//SYSLIB   DD  DISP=SHR,DSN=JES2.QUEUE.OBJ
//SYSLIN   DD  *
 INCLUDE SYSLIB(Q0,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9)
 INCLUDE SYSLIB(Q10,Q11,Q12,Q13,Q14,Q15,Q16,Q17,Q18,Q19)
 INCLUDE SYSLIB(Q20,Q21,Q22,Q23,Q24,Q25,Q26,Q27,Q28,Q29)
 INCLUDE SYSLIB(Q30,Q31,Q32,Q33,Q34)
 ENTRY QUEUE
 ALIAS QUEUE
 ALIAS QUE
 NAME Q(R)
/*
//
./ ADD NAME=FILE53
************************************************************************
*
*         F I L E   5 3   U P D A T E D   Q U E U E
*
************************************************************************

THIS FILE IS IN IEBCOPY UNLOAD FORMAT (80 X 32720).
     THIS VERSION OF THE COMMAND HAS A NUMBER OF ENHANCEMENTS AND
CLEANUP FIXES INSTALLED. THE SUPPORT FOR JES2 PRIOR TO 79/09 WAS REMOVED
AND THE CODE STANDARDIZED ON THE DUPLEX CHECKPOINT LEVEL. A SCREEN PRINT
FACILITY WAS ADDED. THE COMMAND RUNS AUTHORIZED AND NOW HAS SUPPORT FOR
CANCEL, REQUEUE, AND PURGE. THE PDDB SYSOUT COUNTS ARE LISTED ON THE DD
SUBCOMMAND. SUPPORT WAS ADDED TO FIND AND LIST TSO DYNAMICALLY SPUN
SYSOUT.
     THE COMMAND ONLY NEEDS TO RUN AUTHORIZED FOR THE FOLLOWING COMMANDS
CANCEL, REQUEUE, AND PURGE. IF YOU DO NOT MARK THE CODE AC=1, THE
PREVIOUS THREE COMMANDS WILL NOT FUNCTION.

 --- QUEUE COMMAND -----------------------------------------------------

  QUEUE SUBCOMMAND OPERAND        DEFAULT Q STATUS *
  Q                               CAN USE Q CKPT(DEVTYPE,VOLSER) TO GET
                                  NONSTANDARD CHECKPOINT.

 --- SYSTEM DISPLAYS ---------------------------------------------------

DA                  JOBS IN EXECUTION
DT                  DISPLAY TSO USERS
DS                  DISPLAY STARTED TASKS
DC (B/S/T)          DISPLAY CPU BATCH/STC/TSO
STATUS (LEVEL)      JOB STATUS. DEFAULT FOR STATUS IS * (TSO ID).

 --- INPUT QUEUE DISPLAYS ----------------------------------------------

DQ                  DISPLAY INPUT QUEUES
DI (CLASS)          DISPLAY ALL INPUT JOBS
AI (CLASS)          DISPLAY AVAILABLE JOBS
HI (CLASS)          DISPLAY HELD JOBS

 --- OUTPUT QUEUE DISPLAYS----------------------------------------------

DF                  DISPLAY OUTPUT QUEUES
DO (CLASS)          DISPLAY ALL OUTPUT JOBS
AO (CLASS)          DISPLAY AVAILABLE OUTPUT
HO (CLASS)          DISPLAY HELD OUTPUT

 --- JOB MODIFICATION SUBCOMMANDS --------------------------------------

CAN JOBNAME (PURGE) CANCEL FROM INPUT OR EXECUTION. DELETE OUTPUT IF
                     PURGE IS SPECIFIED.
REQ JOBNAME CLASS   CHANGE SYSOUT CLASS
DEL JOBNAME         DELETE HELD OUTPUT

 --- MISC SUBCOMMANDS --------------------------------------------------

SLOG STC# SEQ       LIST SYSTEM LOG.  ST SYSLOG WILL GET STC#. IF SEQ
                     IS NOT SPECIFED ZERO IS ASSUMED (CURRENT).
FTIME HH.MM.SS      POSITION SYSLOG TO TIME
H/HELP              HELP
E/END               EXIT

 --- JOB RELATED SUBCOMMANDS -------------------------------------------

DJ JOBNAME          DISPLAY JOB
JCL JOBNAME         LIST JOB JCL
JLOG JOBNAME        LIST JOB LOG
JMSG JOBNAME        LIST JOB MESSAGES
DD JOBNAME          JES2 DD SUMMARY
LIST JOBNAME DSID   LIST JES2 DATASET. OBTAIN DSID VALUES BY USING THE
                     DD SUBCOMMAND.

 --- LIST RELATED SUBCOMMANDS ---------

FIND 'STRING' COL(SS,EE)  FIND NEXT OCCURANCE OF 'STRING' IN THE DATA.
FALL 'STRING' COL(SS,EE)  FIND ALL OCCURANCES OF 'STRING' IN THE DATA.
                          STRING MUST BE IN QUOTES. COL DEFAULT IS ALL.

COL  #              POSITION TO COLUMN #
@    #              POSITION TO RECORD #
D/+  #              MOVE FORWARD # LINES
UP/- #              MOVE BACKWARD # LINES
TOP                 TOP OF CURRENT DATASET
BOTTOM              BOTTOM OF CURRENT DATASET
HF/HB #             FORWARD/BACKWARD # HALF PAGES
PF/PB #             FORWARD/BACKWARD # PAGES

                    DEFAULT VALUE FOR # IS 1.
                    SYNONYMS L-LIST F-FIND C-COLUMN T-TOP B-BOTTOM

 --------- LOGGING SUBCOMMANDS---------------

SAVE DSNAME TYPE    COPY DATASET
PRINT ON CLASS DEST OPEN SCREEN LOG
                    DEFAULT PRINT CLASS IS SYSOUT=A.
PRINT               PRINT SCREEN
PRINT OFF           CLOSE SCREEN LOG

 -------------------------------
 | PF1     | PF2     | PF3     |
 |   HELP  |   DA    |   END   |   PROGRAM FUNCTION KEY DEFINITIONS
 -------------------------------
 | PF4     | PF5     | PF6     |   TO SPECIFY OPERANDS FOR PF 5 OR
 |   PRINT |   FIND  |   DI    |   OPTIONALLY FOR PF 6,9,12 OR
 -------------------------------   TO OVERRIDE DEFAULTS FOR PF 4,7,8,10,
 | PF7     | PF8     | PF9     |   KEY IN THE VALUE AND PRESS THE KEY
 |   - 21  |   + 21  |   DO    |
 -------------------------------
 | PF10    | PF11    | PF12    |
 |  COL 1  |  COL 41 |   ST    |
 -------------------------------

 -------------------------- RESTRICTED SUBCOMMANDS ---------------------

XB MTTR             DISPLAY DISK RECORD
XD JOBNAME DSID     LIST ANY DATASET
XI                  DISPLAY ACTIVE INITIATORS
XJ JOBNAME          DISPLAY JQE AND JOES
XP PASSWORD         REQUEST FOR PASSWORD PROMPT. PROMPT IS A BLANK SCREE
                     THE PASSWARD AND IF SUCCESSFUL A MESSAGE WILL BE IS

INSTALLATION PROCEDURE FOR QUEUE:

     1. THERE ARE 36 MEMBERS IN THE DATASET.
        Q0 IS THE COMMON AREA.
        Q1 - Q27 ARE REENTRANT CODE.
        QCOMMON, QSTART, QSTOP, QTILT, AND $JQT ARE MACROS.
        HELP IS A TSO HELP MEMBER.
        ASSEMBLE IS THE JCL TO ASSEMBLE AND LINK QUEUE.
        TABLE IS A SAMPLE SMP JOB TO AUTHORIZE THE QUEUE COMMAND.

     2. EDIT MEMBER QCOMMON CHANGING THE FOLLOWING PARAMETERS:

        UNIT=XXXX THE DEVICE TYPE FOR SYS1.HASPCKPT.
        VOLSER=YYYYYY THE VOLUME SERIAL FOR SYS1.HASPCKPT.
        SID1-SID7=ZZZZ THE SMF IDS FOR EACH CPU IN THE COMPLEX. THE
        IDS MUST BE IN THE SAME ORDER AS IN THE INITIALIZATION DECK.

        AT PRESENT THERE IS SUPPORT IN THE INITIALIZATION MODULE TO
        DYNAMICALLY ALLOCATE THE CHECKPOINT ON EITHER 3330, 3330-1,
        OR 3350. IF YOU ARE FORTUNATE ENOUGH TO HAVE A DRUM YOU
        WILL HAVE TO MODIFY Q10 TO ADD SUPPORT.

        EDIT THE MACRO QSTART TO INDICATE THE OPTIONS DESIRED.

        QPFK SETB 0      NO PFK SUPPORT.
        QPFK SETB 1      PFK SUPPORT (DEFAULT).

        THE PFK SUPPORT IS FROM VILKO MACEK - INSURANCE CORPORATION
        OF BRITISH COLUMBIA. PFK SUPPORT CAN BE IDENTIFIED BY SOURCE
        MARKED WITH ICBC IN MODULES Q5, Q8, AND THE MACRO QCOMMON. TO
        CHANGE THE DEFINITIONS OF THE PFKS SEE THE END OF MODULE Q5.

        QACF2 SETB 0     NO ACF2 SUPPORT (DEFAULT).
        QACF2 SETB 1     ACF2 SUPPORT.

        THE ACF2 SUPPORT IS FROM KEN TRUE - FAIRCHILD CAMERA. KEN ALSO
        SUPPLIED THE ORIGINAL PRINT SUPPORT.

     3. EDIT MEMBER ASSEMBLE TO CHANGE THE JCL TO FIT YOUR STANDARDS.
        DO NOT ALTER THE ORDER OF THE ASSEMBLY SYSLIBS AS THERE IS A
        CONFLICT ON THE MACRO QSTART. THE ASSEMBLIES AND LINKS CREATE
        2 LOAD MODULES.

        QUEUE (ALIAS Q) - IS THE REENTRANT CODE OF THE COMMAND. IT MAY
        BE PLACED IN SYS1.LPALIB OR ANY OTHER AUTHORIZED LIBRARY WITH
        AN AUTHORIZATION CODE OF 1.

        QUEUECMN - THE MODIFIABLE COMMON AREA. CAN BE PLACED IN SYS1.
        LINKLIB OR SYS1.CMDLIB. IF YOU WANT TO CHANGE THE NAME OF
        QUEUECMN LOOK IN MEMBER Q10 WHERE THE LINK IS ISSUED.

     4. ADD QUEUE ALIAS Q TO THE IKJEFTE2 MODULE WHICH IS THE TSO LIST
        OF AUTHORIZED COMMANDS. A SAMPLE SMP JOB IS PROVIDED IN THE
        MEMBER TABLE. QUEUE CAN BE RUN UNDER SPF BUT THE SUBCOMMANDS
        USING THE SUBSYSTEM INTERFACE (CANCEL, REQUEUE, AND DELETE)
        WILL BE INOPERABLE, ALL OTHER COMMANDS WILL FUNCTION NORMALLY.
        IF YOU DON'T MIND THE INTEGRITY PROBLEM YOU CAN ADD CODE TO
        QUEUE TO USE A SPECIAL SVC TO GET INTO SUPERVISOR STATE AND
        HAVE FULL FACILITY UNDER SPF.

NOTE:  THE QUEUE COMMAND WAS WRITTEN FOR JES2 4.1 AT PUT TAPE 79/09
LEVEL WITH THE DUPLEX CHECKPOINT FACILITY (AZ27300). THERE IS NO REASON
THAT THE CONCEPT OF ACCESSING THE CHECKPOINT AND SPOOL WOULD NOT WORK
WITH EARLIER VERSIONS OF JES2 OR WITH NJE. THE LOCATION OF CHECKPOINT
VARIABLES AND CHECKPOINT AND SPOOL STRUCTURE MAY BE DIFFERENT AND THE
USER WILL HAVE TO MAKE APPROPRIATE CHANGES TO SUPPORT OTHER VERSIONS
OF JES2.

./ ADD NAME=HELP
)F FUNCTION -
  THE QUEUE COMMAND IS USED TO INTERROGATE THE SYSTEM QUEUES IN ORDER
  TO DETERMINE THE STATUS OF A JOB OR GROUP OF JOBS. IT ALSO PROVIDES
  ACCESS TO ALL PARTS OF A JOB WHILE IT IS ON THE QUEUE.

  FOR MORE INFORMATION, TYPE IN - QUEUE HELP.
)X SYNTAX -
         QUEUE  OPERAND    DEFAULT OPERAND IS STATUS. AN OPERAND OF
         Q                 CKPT(UNIT,VOLSER) CAN BE USED TO SPECIFY
                           A JES2 CHECKPOINT DATASET OTHER THAN THE
                           STANDARD DATASET.

./ ADD NAME=Q0
QCOMMON  TITLE 'QUEUE COMMAND - COMMON AREA'                      UF004
QCOMMON  QSTART TYPE=GLOBAL
         QCOMMON CSECT=YES
         END
./ ADD NAME=Q1
QUEUE    QSTART 'QUEUE COMMAND - MAINLINE MODULE',MAIN=YES
***********************************************************************
* RNB CHANGES:                                                        *
*      (1) RNB01 - FIX FINAL TPUT MESSAGE TO WORK WITH SPF TCAM       *
*                                                                     *
***********************************************************************
***********************************************************************
*                                                                     *
*   CALL - INITIALIZATION                                             *
*                                                                     *
***********************************************************************
         L     R15,=V(INIT)   ADDR OF INIT
         BALR  R14,R15        GO TO IT
         LA    R10,LOOP       INTERRUPTED RETURN ADDRESS
         USING QDISPLAY,R9    BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL      LOAD BASE REG
******************************************************************UF003
*                                                                 UF003
*   INITIALIZE 3270 SCREEN VARIABLES                              UF003
*                                                                 UF003
******************************************************************UF003
         GTSIZE ,             READ 3270 SCREEN SIZE               UF003
         STM   R0,R1,QDOSZR0  SAVE FOR LATER RESTORE              UF003
         LTR   R0,R0          DISPLAY DEVICE?                     UF003
         BZ    NOTDISP        NO, ABORT                           UF003
         SPACE 1                                                  UF003
         STFSMODE ON,INITIAL=YES  TELL VTAM ABOUT FULLSCREEN MODE UF003
         SPACE 1                                                  UF003
         LM    R0,R1,QDOSZR0  RESTORE DESTROYED REGS              UF003
         CH    R1,=H'80'      POSSIBLE MODEL 2 OR 4 TERMINAL?     UF003
         BNE   TRYM5          NO, TRY FOR MODEL 5                 UF003
         CH    R0,=H'43'      MODEL 4 TERMINAL?                   UF003
         BE    MODEL4         YES, SET IT                         UF003
         CH    R0,=H'32'      MODEL 3 TERMINAL?                   UF003
         BNE   SETM2          NO, SET MODEL 2 DEFAULT             UF003
         SPACE 1                                                  UF003
MODEL3   MVC   QDLNELEN,=H'80'     LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'29'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(29*80)  SCR LENGTH                   UF003
         MVC   QDSCRPLN,=AL2(29*80+QDLINE1-QDSCREEN) TPUT LEN     UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C150'    (2,1)                          UF003
         MVC   QDSCRO3,=X'E6F0'    (32,1)                         UF003
         MVC   QDSCRO4,=X'E7F7'    (32,72)                        UF003
         MVC   QDSCRO5,=X'C260'    (3,1)                          UF003
         B     LOOP                JOIN COMMON CODE               UF003
         SPACE 1                                                  UF003
MODEL4   MVC   QDLNELEN,=H'80'     LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'40'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(40*80)  SCR LENGTH                   UF003
         MVC   QDSCRPLN,=AL2(40*80+QDLINE1-QDSCREEN) TPUT LEN     UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C150'    (2,1)                          UF003
         MVC   QDSCRO3,=X'F460'    (43,1)                         UF003
         MVC   QDSCRO4,=X'F5E7'    (43,72)                        UF003
         MVC   QDSCRO5,=X'C260'    (3,1)                          UF003
         B     LOOP                JOIN COMMON CODE               UF003
         SPACE 1                                                  UF003
TRYM5    CH    R1,=H'132'     POSSIBLE MODEL 5 TERMINAL?          UF003
         BNE   SETM2          NO, FORCE MODEL 2 DEFAULT           UF003
         CH    R0,=H'27'      ACTUAL MODEL 5?                     UF003
         BNE   SETM2          NO, FORCE MODEL 2 DEFAULT           UF003
         SPACE 1                                                  UF003
MODEL5   MVC   QDLNELEN,=H'132'    LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'24'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(24*132)  SCR LENGTH                  UF003
         MVC   QDSCRPLN,=AL2(24*132+QDLINE1-QDSCREEN) TPUT LEN    UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C2C4'    (2,1)                          UF003
         MVC   QDSCRO3,=X'F5E8'    (27,1)                         UF003
         MVC   QDSCRO4,=X'F66F'    (27,72)                        UF003
         MVC   QDSCRO5,=X'C4C8'    (3,1)                          UF003
         B     LOOP                JOIN COMMON CODE               UF003
         SPACE 1                                                  UF003
SETM2    STSIZE SIZE=80,LINE=24  FORCE MODEL 2 DEFAULT            UF003
         SPACE 1                                                  UF003
         B     LOOP           GO TO PROCESS LOOP                  UF003
         SPACE 1                                                  UF003
NOTDISP  TPUT  NOTDSPL,L'NOTDSPL SEND MESSAGE TO USER             UF003
         B     EXIT2          AND RETURN TO CALLER                UF003
         SPACE 1                                                  UF003
NOTDSPL  DC    C'QUEUE COMMAND REQUIRES DISPLAY TERMINAL'         UF003
         EJECT ,                                                  UF003
***********************************************************************
*                                                                     *
*   CALL - COMMAND LINE PARSE                                         *
*                                                                     *
***********************************************************************
LOOP     DS    0H                                                 UF006
         L     R15,=V(PARSE)  ADDR OF PARSE
         BALR  R14,R15        GO TO IT
         CLC   =C'E ',QSUBNAME STOP?
         BE    EXIT           YES.
         CLC   =C'EXIT ',QSUBNAME STOP?
         BE    EXIT           YES.
         CLC   =C'END ',QSUBNAME STOP?
         BE    EXIT           YES.
         CLC   =C'STOP ',QSUBNAME STOP?
         BE    EXIT           YES.
***********************************************************************
*                                                                     *
*   CALL - SUB-COMMAND MODULE SELECTED BY PARSE                       *
*                                                                     *
***********************************************************************
         MVC   QDHLINE,DUMMY  NO OUTPUT MESSAGE
         L     R15,QSUBCMD    ADDR OF SUBCMD FROM QCOMMON
         BALR  R14,R15        GO TO IT
         MVC   QDMLNG,=H'0'   ZERO OUT MESSAGE LENGTH
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE
         BALR  R14,R15        WRITE LAST SCREEN, GET NEXT INPUT
         B     LOOP           DO IT AGAIN
***********************************************************************
*                                                                     *
*   CLEAN UP AND GO HOME                                              *
*                                                                     *
***********************************************************************
EXIT     STSIZE SIZELOC=QDOSZR1,LINELOC=QDOSZR0  RESTORE SCRSIZE  UF003
         TPUT  CLEAR,L'CLEAR,FULLSCR,MF=(E,QTPUT) CLEAR SCREEN    UF003
         STLINENO LINE=1,MODE=OFF                 OFF FULLSCR     UF003
         USING QCKPT,R8 BASE REG FOR CKPT WORK AREA
EXIT2    DS    0H                                                 UF003
         L     R8,QVCKPT      LOAD BASE REG
         CLOSE MF=(E,HOCKPT)
         CLOSE MF=(E,QCSPOOLS)
         TM    QPFLAG,HARDCPY         IS HARDCOPY INVOKED?         FCI*
         BNO   FREEUP                   NO..SPLIT THIS STUFF       FCI*
         L     R15,=V(PRINT)               INVOKE PRINT            FCI*
         MVC   QDREPLY,QBLANK                  TO                  FCI*
         MVC   QDREPLY(09),=C'PRINT OFF'          FREE UP          FCI*
         MVC   QDRLNG,=X'0009'                        HARDCOPY     FCI*
         BALR  R14,R15                                     OUTPUT  FCI*
         EJECT
***********************************************************************
*                                                                  FCI*
*   FREE HASPCKPT AND HASPACEN DDNAMES BEFORE LEAVING TO BE NEAT.. FCI*
*                                                                  FCI*
***********************************************************************
FREEUP   MVI   DAIRFLAG,X'18'    INDICATE FREE DDNAME(XXXXXXXX)    FCI*
         MVC   DA18DDN,HASPCKPT+40  GET DDNAME USED...             FCI*
         L     R15,=V(ALLOCATE)  GET ROUTINE NAME                  FCI*
         BALR  R14,R15           GO FREE IT..                      FCI*
*
         LA    R2,QCSPOOLS       GET ADDR OF LIST OF HASPACE DCBS  FCI*
         LA    R4,35             MAX OF 35 PASSES THROUGH HERE..   FCI*
FREEUP1  L     R3,0(R2)          GET ADDRESS OF DCB TO WORK ON     FCI*
         LTR   R3,R3             ANYONE THERE?                     FCI*
         BZ    EXITQCK                                             FCI*
         MVC   DA18DDN,40(R3)    MOVE IN DDNAME FROM DCB           FCI*
         L     R15,=V(ALLOCATE)  GET ROUTINE NAME                  FCI*
         BALR  R14,R15           AND GO INVOKE DAIR TO FREE IT..   FCI*
         LA    R2,4(R2)          BUMP                              FCI*
         BCT   R4,FREEUP1                                          FCI*
***********************************************************************
*                                                                     *
*   FREE THE AREAS ACQUIRED IN INIT (Q3)                              *
*                                                                     *
***********************************************************************
EXITQCK  OI    QGETL3,X'80'   PREPARE FOR FREEMAIN             PWF FCI*
         FREEMAIN MF=(E,QFREE)
         TM    QFLAG1,QFLG1DBC    NEED TO TERMINATE ESTAE?        UF024
         BZ    NOESTAE            NO, SKIP THIS                   UF024
         ESTAE 0                  DELETE CURRENT ESTAE            UF024
         NI    QFLAG1,255-QFLG1DBC  CLEAR FLAG                    UF024
NOESTAE  DS    0H                                                 UF024
         QSTOP
***********************************************************************
*                                                                     *
*   CONSTANTS AND OTHER ODDITIES                                      *
*                                                                     *
***********************************************************************
         LTORG
CLEAR1   EQU   *                   START OF CLEAR DATA            UF003
*        DC    X'27F5C1'           ESC; ERASE/WRITE; RESET MDT    UF003
         DC    X'C1'               FIX FOR SPF/TCAM               RNB01
         DC    X'115D7E'           SBA  24,80                     UF003
         DC    X'114040'           SBA  1,1                       UF003
         DC    X'3C404000'         RTA  1,1 WITH NULLS            UF003
         DC    X'1DC8'             SF, INTENSIFIED                UF003
         DC    X'13'               INSERT CURSOR                  UF003
CLEAR    EQU   CLEAR1,*-CLEAR1                                    UF003
DUMMY    DC    CL80'    NO DATA IS AVAILABLE FOR YOUR REQUEST'
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q10
INIT     QSTART 'QUEUE COMMAND - INITIALIZATION ROUTINES'
***********************************************************************
* RNB CHANGES:                                                        *
*            (3) RNB03 - IF RACF OPTION IS SET, AND IF AUTHORIZED,    *
*                        AND IF QNEWUSR IS NON-NULL, CHANGE ACEEUSER  *
*                        SO USER WILL BE AUTHORIZED TO OPEN CKPT/SPOOL*
***********************************************************************
         GBLB  &QSP           MVS/SP OPTION                       UF020
         GBLB  &QDBC          DBC    OPTION                       UF024
         GBLB  &QRACF         RACF OPTION                         RNB03
         GBLB  &QRNB          RNB OPTION FLAG                     RNB05
***********************************************************************
*                                                                     *
*   LOAD QCOMMON                                                      *
*                                                                     *
***********************************************************************
*
****
*******  IF YOU WANT TO CHANGE THE NAME FOR THE COMMON AREA,
****               THIS IS THE ONLY REFERENCE TO IT.
*
         L     R11,=V(QCOMMON) ADDR OF QCOMMON                    UF002
         LTR   R11,R11        SEE IF LINKED IN                    UF002
         BNZ   LOADED         YES, CONTINUE                       UF002
         SPACE 1                                                  UF002
         LOAD  EP=QUEUECMN    QUEUE COMMON AREA
         LR    R11,R0         ADDR OF QCOMMON
         SPACE 1                                                  UF002
LOADED   DS    0H                                                 UF002
         L     R1,4(R13)      PREVIOUS SAVE AREA
         ST    R11,64(R1)     UPDATE R11 IN PREVIOUS SAVE AREA
         ST    R1,QFRSTSA     STORE ADDR OF FIRST SAVEAREA IN QCOMMON
         USING QDAIR,R10      BASE REG FOR DAIR WORK
         L     R10,QVDAIR     LOAD BASE REG
         USING QCKPT,R9       BASE REG FOR CKPT WORK
         L     R9,QVCKPT      LOAD BASE REG
         USING QDISPLAY,R8    BASE REG FOR DISPLAY WORK
         L     R8,QVDSPL      LOAD BASE REG
***********************************************************************
*                                                                     *
*   MOVE PARMS FROM CPPL TO DAPL                                      *
*                                                                     *
***********************************************************************
         USING CPPL,R2        ADDR OF CPPL IS IN R2
         MVC   DAPLUPT,CPPLUPT USER PROFILE TABLE
         MVC   DAPLPSCB,CPPLPSCB PROTECTED STORAGE CNTL BLK
         MVC   DAPLECT,CPPLECT ENVIRONMENT CNTL TABLE
         AIF   (&QRNB).RNB02      SKIP IF AT RNB                  RNB02
******************************************************************UF010
*                                                                 UF010
*   CHECK PSCB FOR OPERATOR AUTHORITY                             UF010
*                                                                 UF010
******************************************************************UF010
         L     R1,CPPLPSCB    ADDRESS OF PSCB                     UF010
         USING PSCB,R1        ADDRESSING FOR PSCB                 UF010
         TM    PSCBATR1,PSCBCTRL  TEST FOR OPERATOR AUTHORITY     UF010
         BZ    NOTOPER        NO, SKIP THIS                       UF010
         OI    QFLAG1,QFLG1OPR    SET OPER AUTH                   UF010
         OI    QXAUTH,1           SET PRIV AUTH                   UF010
         AIF   (NOT &QDBC).NODBC1 SKIP IF DBC NOT INSTALLED       UF024
******************************************************************UF024
*                                                                 UF024
*   IF USER HAS OPER AUTHORITY, ESTABLISH ESTAE ENVIRONMENT       UF024
*                                                                 UF024
******************************************************************UF024
         LOAD  EP=DBC,ERRET=NOTOPER  LOAD ESTAE ROUTINE           UF024
         LR    R3,R0          ADDR OF ROUTINE                     UF024
         ESTAE (R3)           CREATE THE ESTAE                    UF024
         OI    QFLAG1,QFLG1DBC  INDICATE NEED TO DELETE AT TERM   UF024
.NODBC1  ANOP                                                     UF024
.RNB02   ANOP                                                     RNB02
NOTOPER  DS    0H                                                 UF010
***********************************************************************
*                                                                     *
*   MOVE COMMAND BUFFER TO REPLY BUFFER                               *
*                                                                     *
***********************************************************************
         L     R1,CPPLCBUF    ADDR OF COMMAND BUFFER
         LH    R3,0(R1)       LENGTH OF COMMAND BUFFER
         LH    R4,2(R1)       OFFSET TO FIRST DATA BYTE
         LA    R1,4(R1,R4)    FIRST DATA BYTE
         SR    R3,R4          SUBTRACT OFFSET FROM LENGTH
         SH    R3,=H'4'       SUBTRACT OVERHEAD
         SH    R3,=H'1'       IS LENGTH ZERO?
         BM    SKIP           YES. SKIP IT.
         EX    R3,OCBUF       TRANSLATE TO UPPER CASE
         CLC   =C'CKPT(',0(1) IS REQUEST FOR CKPT?
         BE    CKPT           YES. DO IT.
         MVC   QDREPLY,QBLANK BLANK THE REPLY LINE
         CH    R3,=H'62'      IS LENGTH OVER 63?
         BNH   OK             NO. USE IT.
         LA    R3,62          USE MAXIMUM LENGTH
OK       EX    R3,MVCBUF      MOVE THE DATA
         LA    R3,1(R3)       INCREMENT TO TRUE LENGTH
         STH   R3,QDRLNG      STORE REPLY LENGTH
***********************************************************************
*                                                                     *
*   LOCATE LOGON ID, MOVE TO QLOGON                                   *
*                                                                     *
***********************************************************************
SKIP     L     R1,16          ADDR OF CVT
         L     R1,0(R1)       ADDR OF DISPATCH QUEUE
         L     R1,12(R1)      ADDR OF CURRENT ASCB
         L     R1,176(R1)     ADDR OF JOBNAME
         MVC   QLOGON,0(R1)   MOVE JOBNAME TO QLOGON
***********************************************************************
*                                                                     *
*   OBTAIN BLOCK ADDR TABLE FOR LISTDS                                *
*                                                                     *
***********************************************************************
         GETMAIN R,LV=65536
         ST    R1,QGETA1      SAVE START ADDR OF GETMAIN
         ST    R1,QCSTART     STORE STARTING ADDR OF TABLE
         A     R1,=F'65536'   END OF TABLE
         ST    R1,QCEND
***********************************************************************
*                                                                     *
*   ALLOCATE HASPCKPT                                                 *
*                                                                     *
***********************************************************************
         MVC   DA08DDN,=CL8'HASPCKPT' DDNAME FOR ALLOCATE
         MVC   DA08PDSN,=A(DSNCKPT) DSNAME FOR ALLOCATE
         MVI   DAIRFLAG,X'08' REQUEST ALLOCATE FUNCTION
         L     R15,=V(ALLOCATE) ADDR OF ALLOCATE MODULE
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   OPEN HASPCKPT, READ FIRST BLOCK OF CHECKPOINT                     *
*                                                                     *
***********************************************************************
         AIF   (NOT &QRACF).RNB03B                                RNB03
         TESTAUTH FCTN=1             APF-AUTHORIZED?              RNB03
         LTR   R15,R15                                            RNB03
         BNZ   RNB03A                /NO  - CAN'T CHG ACEEUSER    RNB03
*                                    /YES -                       RNB03
         RACSTAT ,                   IS RACF UP?                  RNB03
         LTR   R15,R15                                            RNB03
         BNZ   RNB03A                /NO  - CAN'T CHG ACEEUSER    RNB03
*                                    /YES -                       RNB03
         CLI   QNEWUSR,0             IS THERE A NEW USERID TO USE?RNB03
         BE    RNB03A                /NO  - CAN'T CHG ACEEUSER    RNB03
*                                    /YES - CHANGE ACEEUSER TO    RNB03
*                                           ALLOW ACCESS TO THE   RNB03
*                                           SPOOL/CKPT DATA SETS  RNB03
         L     R2,CVTPTR             CVT                          RNB03
         USING CVT,R2                #####                        RNB03
         L     R2,CVTTCBP            TCB WORDS                    RNB03
         L     R2,12(,R2)            CURRENT ASCB                 RNB03
         USING ASCB,R2               #####                        RNB03
         L     R2,ASCBASXB           ASXB                         RNB03
         USING ASXB,R2               #####                        RNB03
         ICM   R2,15,ASXBSENV        ACEE                         RNB03
         BZ    RNB03A                FORGET IT IF NO ACEE         RNB03
         USING ACEE,R2               #####                        RNB03
         CLC   =C'ACEE',ACEEACEE     REALLY AN ACEE?              RNB03
         BNE   RNB03A                /NO  - FORGET IT             RNB03
         MVC   QUSRSAV,ACEEUSER      /YES - SAVE CURRENT USERID   RNB03
         STAX  DEFER=YES             DON'T ALLOW ATTENTION'S      RNB03
         MODESET KEY=ZERO            GET KEY ZERO TO UPDATE ACEE  RNB03
         MVC   ACEEUSER,QNEWUSR      SET NEW USERID               RNB03
         MODESET KEY=NZERO           BACK TO USER KEY             RNB03
RNB03A   EQU   *                                                  RNB03
.RNB03B  ANOP                                                     RNB03
         OPEN  MF=(E,HOCKPT)  OPEN HASPCKPT
         L     R2,QCSTART     USE TABLE AREA FOR IOAREA
         POINT HASPCKPT,TIR3  POINT PAST SYNC RECORDS
         READ  HDECB1,SF,,(R2),MF=E READ FIRST RECORD
         CHECK HDECB1
***********************************************************************
*                                                                     *
*   COMPUTE OFFSET TO FIRST PDDB IN IOT                               *
*                                                                     *
***********************************************************************
         USING $SAVEBEG,R2    BASE REG FOR CHECKPOINT
         AIF   (&QSP).QSP1                                        UF020
         LH    R5,$NUMTGV     NUMBER OF TRACK GROUPS PER VOLUME
         LA    R5,7(R5)       ROUND UP TO MULTIPLE OF 8
         SRL   R5,3           DIVIDE BY 8
         SR    R0,R0          ZERO OUT R0
         IC    R0,$NUMDA      NUMBER OF SPOOL VOLUMES
         MR    R4,R0          LENGTH OF TRACK GROUP MAP IN R5
         AGO   .QSP2                                              UF020
.QSP1    ANOP                                                     UF020
         LH    R5,$NUMTG      NUMBER OF TRACK GROUPS PER VOLUME   UF020
         LA    R5,7(R5)       ROUND UP TO MULTIPLE OF 8           UF020
         SRL   R5,3           DIVIDE BY 8                         UF020
.QSP2    ANOP                                                     UF020
         LR    R1,R5          SAVE LENGTH OF TRACK GROUP MAP
         LA    R5,IOTTGMAP-IOTSTART+TGMAP-TGMDSECT+3(R5) OFFSET
         N     R5,=F'-4'      ROUND TO FULL WORD BOUNDARY
         ST    R5,QCPDDB1     SAVE OFFSET TO FIRST PDDB IN IOT
         AIF   (NOT &QSP).QSP3                                    UF020
***********************************************************************
*                                                                     *
*   COMPUTE NUMBER OF JIX BLOCKS ON CKPT                              *
*                                                                     *
***********************************************************************
         LH    R5,$NUMJBNO    NUMBER OF JOB NUMBERS               UF020
         LA    R5,1(,R5)       PLUS 1 FOR HEADER                  UF020
         SLL   R5,1           TIMES LENGTH OF 2                   UF020
         LA    R5,4095(R5)    PREPARE TO ROUND                    UF020
         SRL   R5,12          DIVIDE BY 4096                      UF020
         STH   R5,QCJIXL      NUMBER OF BLOCKS FOR JIX            UF020
.QSP3    ANOP                                                     UF020
***********************************************************************
*                                                                     *
*   COMPUTE NUMBER OF JQE BLOCKS ON CKPT                              *
*                                                                     *
***********************************************************************
         LH    R6,$MAXJOBS    NUMBER OF JQES
         LA    R6,1(,R6)       PLUS 1 FOR EYE-CATCHER
         MH    R6,=AL2(JQELNGTH) MULTIPLY BY LENGTH OF JQE
         LA    R6,4095(R6)    PREPARE TO ROUND
         SRL   R6,12          DIVIDE BY 4096
         STH   R6,QCJQTL      NUMBER OF BLOCKS FOR JQES
***********************************************************************
*                                                                     *
*   COMPUTE NUMBER OF JOT BLOCKS IN CKPT                              *
*                                                                     *
***********************************************************************
         LH    R3,$NUMJOES    NUMBER OF JOES
         LA    R3,NJOTPRFX(,R3) ADJUSTED LENGTH OF JOT PREFIX
         MH    R3,=AL2(JOESIZE) MULTIPLY BY LENGTH OF JOE
         LA    R3,4095(R3) PREPARE TO ROUND
         SRL   R3,12          DIVIDE BY 4096
         STH   R3,QCJOTL      NUMBER OF BLOCKS FOR JOT
***********************************************************************
*                                                                     *
*   COMPUTE TOTAL LENGTH OF QSES                                      *
*                                                                     *
***********************************************************************
         LA    R4,QSELEN      QSE LENGTH
         MH    R4,$QSENO      MULTIPLY LENGTH TIMES NUMBER OF QSES
         AIF   (NOT &QSP).QSP5                                    UF020
         ALR   R4,R5          ADD ONE BYTE FOR EACH JIX BLOCK     UF020
******************************************************************UF020
*                                                                 UF020
*   COMPUTE NUMBER OF MSQ BLOCKS ON CKPT                          UF020
*                                                                 UF020
******************************************************************UF020
         LH    R1,$NUMRJE     NUMBER OF REMOTES                   UF020
         MH    R1,=Y(3)       TIMES LENGTH OF 3                   UF020
         LA    R1,3(,R1)       PLUS HEADER LENGTH                 UF020
         LA    R1,4095(R1)    PREPARE TO ROUND                    UF020
         SRL   R1,12          DIVIDE BY 4096                      UF020
         ALR   R4,R1          ADD 1 BYTE FOR EACH BLOCK           UF020
******************************************************************UF020
*                                                                 UF020
*   COMPUTE NUMBER OF RSO BLOCKS ON CKPT                          UF020
*                                                                 UF020
******************************************************************UF020
         LH    R1,$NUMRJE     NUMBER OF REMOTES                   UF020
         LA    R1,4095(R1)    PREPARE TO ROUND                    UF020
         SRL   R1,12          DIVIDE BY 4096                      UF020
         ALR   R4,R1          ADD 1 BYTE FOR EACH BLOCK           UF020
******************************************************************UF020
*                                                                 UF020
*   COMPUTE NUMBER OF LCK BLOCKS ON CKPT                          UF020
*                                                                 UF020
******************************************************************UF020
*        LH    R1,$NUMLCK     NUMBER OF LOAD CKPT ELEMENTS        UF020
         LA    R1,9*7         NUMBER OF LOAD CKPT ELEMENTS        UF020
         MH    R1,=Y(LCKSIZE) TIMES LENGTH OF EACH                UF020
         LA    R1,4095(R1)    PREPARE TO ROUND                    UF020
         SRL   R1,12          DIVIDE BY 4096                      UF020
         ALR   R4,R1          ADD 1 BYTE FOR EACH BLOCK           UF020
.QSP5    ANOP                                                     UF020
         ALR   R4,R6          ADD ONE BYTE FOR EACH JQE BLOCK
         ALR   R4,R3          ADD ONE BYTE FOR EACH JOT BLOCK
***********************************************************************
*                                                                     *
*   COMPUTE HASPACE BUFFER SIZE                                       *
*                                                                     *
***********************************************************************
         LH    R5,$BUFSIZE    BLKSIZE FOR HASPACE
         STH   R5,HASPACE+62  STORE IN DCB
         STH   R5,HDECB2+6    STORE IN DECB
         LA    R5,63(R5)      PREPARE TO ROUND
         N     R5,=F'-64'     ROUND TO 64 BYTE BOUNDARY
***********************************************************************
*                                                                     *
*   OBTAIN BUFFERS FOR HASPCKPT AND HASPACE                           *
*                                                                     *
***********************************************************************
         LR    R14,R5         HASPACE BUFFER SIZE
         MH    R14,=H'3'      3 BUFFERS
         LA    R1,1(R6,R3)    NUMBER OF BLOCKS IN CKPT DS
         AIF   (NOT &QSP).QSP6                                    UF020
         AH    R1,QCJIXL      ADD NUMBER OF JIX BLOCKS            UF020
.QSP6    ANOP                                                     UF020
         ST    R1,QCJOTL      STORE RECORD COUNT
         SLL   R1,12          MULTIPLY BY 4096
         LA    R0,256(R1,R14) ADD CKPT BUFFERS, HASPACE BUFFERS, SLOP
         ST    R0,QGETL2      SAVE LENGTH OF GETMAIN AREA
         GETMAIN R,LV=(0)     OBTAIN BUFFERS
         ST    R1,QGETA2      SAVE ADDRESS OF GETMAIN AREA
         ST    R1,QCJQTL      BUFFER FOR FIRST CKPT REC
         AH    R1,=H'4096'    INCREMENT
         AIF   (NOT &QSP).QSP7                                    UF020
         ST    R1,QCJIXA      BUFFER FOR JIX BLOCKS               UF020
         LH    R15,QCJIXL     NUMBER OF JIX BLOCKS                UF020
         SLL   R15,12         TIMES 4096                          UF020
         AR    R1,R15         INCREMENT                           UF020
.QSP7    ANOP                                                     UF020
         ST    R1,QCJQTA      BUFFER FOR JQE BLOCKS
         SLL   R6,12          MULTIPLY BY 4096
         AR    R1,R6          INCREMENT
         ST    R1,QCJOTA      BUFFER FOR JOE BLOCKS
         SLL   R3,12          MULTIPLY BY 4096
         AR    R1,R3          INCREMENT
         ST    R1,QCJCTA      BUFFER FOR JCT
         AR    R1,R5          INCREMENT
         ST    R1,QCIOTA      BUFFER FOR IOT
         AR    R1,R5          INCREMENT
         ST    R1,QCBLKA      BUFFER FOR DATA BLOCKS
         AIF   (NOT &QSP).QSP8                                    UF020
         LA    R1,$JQHEADS+$JQHEADL-$SAVEBEG OFFSET 1ST JQE HEAD  UF020
         AGO   .QSP9                                              UF020
.QSP8    ANOP                                                     UF020
         LA    R1,$JQHEADS+2-$SAVEBEG OFFSET TO FIRST JQE HEADER
.QSP9    ANOP                                                     UF020
         A     R1,QCJQTL      BASE OF FIRST CKPT REC
         ST    R1,QCJQHEAD    ADDR OF FIRST JQE HEADER
***********************************************************************
*                                                                     *
*   ALLOCATE AND OPEN HASPACE                                         *
*                                                                     *
***********************************************************************
         LA    R3,$SAVEEND(R4) ADDR OF DA CKPT INFO
.EXIT    ANOP
         MVC   DA08DDN,=CL8'HASPACE' DDNAME FOR ALLOCATE
         MVC   DA08PDSN,=A(DSNSPACE) DSNAME FOR ALLOCATE
         LA    R4,9           MAX POSSIBLE SPOOLS FOR QUEUE       UF020
         AIF   (&QSP).QSP10                                       UF020
         IC    R4,$NUMDA      MAXIMUM NUMBER OF SPOOL VOLUMES
.QSP10   ANOP                                                     UF020
         LA    R7,QCDCBL      LENGTH OF HASPACE DCB
         MR    R6,R4          COMPUTE LENGTH OF DCB POOL
         GETMAIN R,LV=(R7)    OBTAIN DCB POOL
         ST    R7,QGETL3      SAVE LENGTH OF GETMAIN
         ST    R1,QGETA3      SAVE ADDRESS OF GETMAIN
         LR    R7,R1          SAVE ADDR OF DCB POOL
         LA    R8,QCSPOOLS-4  ADDR OF OPEN LIST
         SR    R6,R6          ACTUAL NUMBER OF SPOOL VOLUMES
         MVC   DA08SER(5),$SPOOL PATTERN FOR VOLSER
SPOOL1   LA    R5,DEVTAB      ADDR OF DEVICE CHARACTERISTICS TBL
         CLI   0(R3),0        IS THIS VOLUME UNUSED?
         BE    SPOOL4         YES. TRY NEXT.
SPOOL2   CLI   0(R5),X'FF'    IS THIS THE END OF TABLE?
         BE    ABORT          YES. UNSUPPORTED DEVICE TYPE.
         CLC   0(1,R5),0(R3)  IS THIS A MATCH?
         BE    SPOOL3         YES. GO WITH IT.
         LA    R5,12(R5)      NEXT TABLE ENTRY
         B     SPOOL2         TRY NEXT ENTRY
SPOOL3   MVC   150(2,R8),2(R5) MOVE TRK/CYL TO TRK/CYL LIST
         MVC   DA08UNIT,4(R5) MOVE UNIT NAME
         MVC   DA08SER+5(1),1(R3) LAST DIGIT OF VOLSER
         LA    R6,1(R6)       INCREASE COUNT BY ONE
         STC   R6,DA08DDN+7   UPDATE DDNAME
         OI    DA08DDN+7,X'F0' MAKE IT A VALID NUMBER
         L     R15,=V(ALLOCATE) ADDR OF ALLOCATE MODULE
         BALR  R14,R15        GO TO IT
         MVC   0(QCDCBL,R7),HASPACE MOVE PATTERN DCB TO POOL
         MVC   47(1,R7),DA08DDN+7 UPDATE THE DDNAME
         ST    R7,4(R8)       STORE DCB ADDR IN OPEN LIST
         LA    R7,QCDCBL(R7)  INCREMENT TO NEXT DCB
         LA    R8,4(R8)       NEXT ENTRY IN OPEN LIST
SPOOL4   LA    R3,6(R3)       NEXT VOLUME
         BCT   R4,SPOOL1      BRANCH IF MORE VOLUMES.
         OI    0(R8),X'80'    INDICATE END OF OPEN LIST
         OPEN  MF=(E,QCSPOOLS) OPEN HASPACE
         AIF   (NOT &QRACF).RNB03D                                RNB03
         CLI   QUSRSAV,0           DID WE CHANGE ACEEUSER?        RNB03
         BE    RNB03C              /NO  - SKIP THIS CODE          RNB03
*                                  /YES - PUT USERID BACK         RNB03
         L     R2,CVTPTR             CVT                          RNB03
         USING CVT,R2                #####                        RNB03
         L     R2,CVTTCBP            TCB WORDS                    RNB03
         L     R2,12(,R2)            CURRENT ASCB                 RNB03
         USING ASCB,R2               #####                        RNB03
         L     R2,ASCBASXB           ASXB                         RNB03
         USING ASXB,R2               #####                        RNB03
         ICM   R2,15,ASXBSENV        ACEE                         RNB03
         USING ACEE,R2               #####                        RNB03
         MODESET KEY=ZERO            GET KEY ZERO TO UPDATE ACEE  RNB03
         MVC   ACEEUSER,QUSRSAV      SET OLD USERID               RNB03
         MODESET KEY=NZERO           BACK TO USER KEY             RNB03
         STAX  DEFER=NO              ALLOW ATTENTION INTERRUPTS   RNB03
RNB03C   EQU   *                                                  RNB03
.RNB03D  ANOP                                                     RNB03
***********************************************************************
*                                                                     *
*   GO HOME                                                           *
*                                                                     *
***********************************************************************
         QSTOP
***********************************************************************
*                                                                     *
*   PROCESS REQUEST FOR DIFFERENT UNIT AND VOL ON SYS1.HASPCKPT       *
*                                                                     *
***********************************************************************
*
*** FORMAT - QUEUE CKPT(UNIT,VOLSER)
*
CKPT     MVC   DA08UNIT(16),QBLANK BLANK THE UNIT AND VOLSER FIELDS
         LA    R5,DA08UNIT    START OF UNIT FIELD
         LA    R6,DA08SER     START OF VOLSER FIELD
         SH    R3,=H'4'       SUBTRACT OVERHEAD FROM LENGTH
CKPT1    CLI   5(R1),C','     IS THIS THE END OF UNIT FIELD?
         BE    CKPT2          YES. PROCESS VOLSER NEXT.
         MVC   0(1,R5),5(R1)  MOVE ONE BYTE OF UNIT NAME
         LA    R5,1(R5)       ADD 1 TO RECEIVING ADDR
         LA    R1,1(R1)       ADD 1 TO SENDING ADDR
         BCT   R3,CKPT1       BRANCH IF NOT EXHAUSTED.
         B     ABORT2         INVALID PARAMETERS.
CKPT2    CLI   6(R1),C')'     IS THIS THE END OF VOLSER FIELD?
         BE    CKPT3          YES. CONTINUE PROCESSING.
         MVC   0(1,R6),6(R1)  MOVE ONE BYTE TO VOLSER
         LA    R6,1(R6)       ADD ONE TO RECEIVING ADDR
         LA    R1,1(R1)       ADD ONE TO SENDING ADDR
         BCT   R3,CKPT2       BRANCH IF NOT EXHAUSTED.
         B     ABORT2         INVALID PARAMETER.
CKPT3    CLI   DA08UNIT,C' '  IS THERE A UNIT?
         BE    ABORT2         NO. INVALID.
         CLI   DA08SER,C' '   IS THERE A VOLSER?
         BE    ABORT2         NO. INVALID.
         CLI   DA08BLK,0      DID WE GO TOO FAR?
         BE    SKIP           NO. EVERTHING LOOKS GOOD.
ABORT2   TPUT  MESSAGE2,L'MESSAGE2,EDIT,MF=(E,QTPUT) TELL THE USER
         ABEND 97,DUMP        QUIT
***********************************************************************
*                                                                     *
*   UNSUPPORTED DEVICE TYPE. ABORT.                                   *
*                                                                     *
***********************************************************************
ABORT    TPUT  MESSAGE,L'MESSAGE,EDIT,MF=(E,QTPUT)   TELL THE USER
         ABEND 98,DUMP        QUIT.
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
OCBUF    OC    0(1,R1),QBLANK TRANSLATE COMMAND TO UPPER CASE
MVCBUF   MVC   QDREPLY(1),0(R1) MOVE DATA TO REPLY
DEVTAB   DC    X'0900',H'19',CL8'3330' DEVTYPE,TRK/CYL,DEVNAME
         DC    X'0B00',H'30',CL8'3350'
         DC    X'0D00',H'19',CL8'3330-1'
         DC    X'0E00',H'15',CL8'3380  '
         DC    X'FFFF'
         DS    0F
TIR3     DC    X'00000300'    POINT PAST SYNC RECORDS
DSNCKPT  DC    H'13',CL44'SYS1.HASPCKPT'
DSNSPACE DC    H'12',CL44'SYS1.HASPACE'
MESSAGE  DC    C'UNSUPPORTED DEVICE TYPE SPECIFIED FOR SPOOL'
MESSAGE2 DC    C'INVALID PARAMETER SPECIFIED - CKPT(UNIT,VOLSER)'
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
INIT     CSECT ,                                                  UF023
         GBLC  &VERSION
&VERSION SETC  '0'
         AIF   (NOT &QSP).QSP99A                                  UF020
$MAXNODE EQU   1000           FOR SP2 $JOT DSECT                  UF020
         AGO   .QSP99B                                            UF020
.QSP99A  ANOP                                                     UF020
$MAXNODE EQU   99             FOR NJE $JOT DSECT                  UF001
.QSP99B  ANOP                                                     UF020
SAVE     EQU   13             NEEDED FOR NJE $PCE                 UF001
         $PCE  ,              NEEDED FOR NJE $HCT                 UF001
         $JOE
         $JOT
NJOTPRFX EQU   (JOTJOES-JOTDSECT)/JOESIZE
BASE1    EQU   0
$RPS     EQU   0
$MSGID   EQU   0
$DUPVOLT EQU   0
$PRIOOPT EQU   0
$PRTBOPT EQU   0
$PRTRANS EQU   0
$QSONDA  EQU   0
         AIF   (NOT &QSP).QSP99                                   UF020
*        EQUATES REQUIRED FOR $HCT EXPANSION                      UF020
FF       EQU   X'FF'                                              UF020
$CMBDEF  EQU   15                                                 UF020
$JQEDEF  EQU   100                                                UF020
$MAXDA   EQU   32                                                 UF020
$MAXJBNO EQU   9999                                               UF020
$SMFDEF  EQU   5                                                  UF020
$TGDEF   EQU   3072                                               UF020
*JCT      EQU   10                                         VBA01  UF020
         $LCK  ,                                                  UF020
.QSP99   ANOP                                                     UF020
JCT      EQU    10                                         VBA01
         $BUFFER                                                  UF020
         $JCT  ,                                                  UF020
         $CAT  ,                                                  UF020
         $TAB
         $QSE
         $PDDB                                                    UF021
         $IOT
         $TGM
         $JQE
         $HCT
         IKJCPPL
         IKJPSCB                                                  UF010
         AIF   (NOT &QRACF).RNB03E                                RNB03
         PUSH  PRINT                                              RNB03
         PRINT NOGEN                                              RNB03
         CVT   DSECT=YES                                          RNB03
         IHAASCB ,                                                RNB03
         IHAASXB ,                                                RNB03
         IHAACEE ,                                                RNB03
         POP   PRINT                                              RNB03
.RNB03E  ANOP                                                     RNB03
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q11
JCL      QSTART 'QUEUE COMMAND - LIST THE JCL FOR A JOB'
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   CALL LISTDS TO LIST THE DATASET                                   *
*                                                                     *
***********************************************************************
         MVC   QPOFFSET,=H'10' PRINT OFFSET FOR EACH RECORD
         MVC   QPDSID,=H'3'   DSID OF DATASET TO BE PRINTED
         L     R15,=V(LISTDS) ADDR OF LISTDS MODULE
         BALR  R14,R15        GO TO IT
         QSTOP
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q12
JLOG     QSTART 'QUEUE COMMAND - LIST THE JOBLOG MESSAGES FOR A JOB'
         GBLB  &QRNB                                              RNB04
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   DETERMINE IF JOB LOG IS AVAILABLE                                 *
*                                                                     *
***********************************************************************
         USING PDBDSECT,R2    BASE REG FOR PDDB
         USING IOTSTART,R3    BASE REG FOR IOT
         L     R3,QCIOTA      LOAD BASE REG
NEXTIOT  LR    R4,R3          BASE OF IOT
         A     R4,IOTPDDBP    OFFSET BEYOND LAST PDDB
         LR    R2,R3          BASE OF IOT
         A     R2,QCPDDB1     OFFSET TO FIRST PDDB IN JOT
FINDDS   CLC   PDBDSKEY,=H'2' IS THIS THE JOB LOG
         BE    FOUNDDS        YES. CONTINUE.
         LA    R2,PDBLENG(R2) NO. LOOK AT NEXT PDDB
         CR    R2,R4          HAVE WE GONE PAST THE LAST PDDB
         BL    FINDDS         NO. TRY AGAIN
         B     TILT
         AIF   (&QRNB).RNB04A                                     RNB04
FOUNDDS  CLC   PDBRECCT,=F'1' IS JOB LOG EMPTY
         BE    TILT           YES, SAY SO
         AGO   .RNB04B                                            RNB04
.RNB04A  ANOP                                                     RNB04
***********************************************************************
* RNB CHANGES:                                                        *
*          (1) RNB04 - ALLOW JOBLOG FOR JOBS THAT HAVE BEGUN EXECUTING*
*                      BUT HAVEN'T FINISHED FIRST STEP YET. WILL ONLY *
*                      SHOW JOB-STARTED MESSAGE.                      *
***********************************************************************
FOUNDDS  L     R3,QCJCTA      GET THE JCT                         RNB04
         USING JCTSTART,R3    #####                               RNB04
         OC    JCTXEQON,JCTXEQON  JOB EXECUTING OR EXECUTED?      RNB04
         BZ    TILT2              /NO  - REALLY EMPTY             RNB04
*                                 /YES - OK TO LIST IT            RNB04
         DROP  R3                                                 RNB04
.RNB04B  ANOP                                                     RNB04
***********************************************************************
*                                                                     *
*   CALL LISTDS TO LIST THE DATASET                                   *
*                                                                     *
***********************************************************************
         MVC   QPOFFSET,=H'0' PRINT OFFSET FOR EACH RECORD
         MVC   QPDSID,=H'2'   DSID OF DATASET TO BE PRINTED
         L     R15,=V(LISTDS) ADDR OF LISTDS MODULE
         BALR  R14,R15        GO TO IT
         QSTOP
         AIF   (&QRNB).RNB04C                                     RNB04
TILT     QTILT '*** JOBLOG IS NOT AVAILABLE ***'
         AGO   .RNB04D                                            RNB04
.RNB04C  ANOP                                                     RNB04
TILT     QTILT '*** JOBLOG NOT FOUND ***'                         RNB04
TILT2    QTILT '*** JOBLOG NOT AVAILABLE - JOB HAS NOT EXECUTED ***' 04
.RNB04D  ANOP                                                     RNB04
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
JLOG     CSECT ,                                                  UF023
JCT      EQU   0
         $BUFFER                                                  UF020
         $JQE
         $TAB
         $JCT
         $PDDB
         $IOT
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q13
JMSG     QSTART 'QUEUE COMMAND - LIST THE SYSTEM MESSAGES FOR A JOB'
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   CALL LISTDS TO LIST THE DATASET                                   *
*                                                                     *
***********************************************************************
         MVC   QPOFFSET,=H'0' PRINT OFFSET FOR EACH RECORD
         MVC   QPDSID,=H'4'   DSID OF DATASET TO BE PRINTED
         L     R15,=V(LISTDS) ADDR OF LISTDS MODULE
         BALR  R14,R15        GO TO IT
         QSTOP
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q14
LIST     QSTART 'QUEUE COMMAND - PRINT A DATASET FROM SPOOL BY ID'
         GBLB  &QACF2         IS ACF2 AUTH CHECKING TO BE DONE     FCI*
         GBLB  &QRNB                                              RNB05
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING WORK,R13       BASE REG FOR TEMP WORK
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   ENSURE JOBNAME BEGINS WITH USER ID                                *
*                                                                     *
***********************************************************************
         AIF   (&QRNB).RNB05A                                     RNB05
         SPACE 1                                                  UF005
         TM    QXAUTH,1       IS USER AUTHORIZED?                 UF005
         BO    OKJOB          YES, ALLOW TO PROCEED               UF005
         SPACE 1                                                  UF005
.RNB05A  ANOP                                                     RNB05
         L     R9,QCJCTA      ADDR OF JCT
         USING JCTSTART,R9    BASE REG FOR JCT
         LA    R2,7           MAXIMUM LENGTH OF USER ID
         LA    R3,QLOGON+7    LAST BYTE OF USER ID
LOOP     CLI   0(R3),C' '     IS THIS BYTE BLANK?
         BNE   CHECK          NO. CONTINUE.
         BCTR  R3,0           TRY PREVIOUS BYTE
         BCT   R2,LOOP        TRY AGAIN
CHECK    EX    R2,CLC         IS THE JOBNAME VALID?
         AIF   (&QRNB).RNB05B                                     RNB05
         AIF   (&QACF2).ACF1                                       FCI*
         BNE   TILT2          NO. TILT.                            FCI*
         AGO   .ACF2                                               FCI*
.ACF1    ANOP  ,                                                   FCI*
         NOP   TILT2          ACF2 HAS ALREADY CHECKED AUTHORITY   FCI*
.ACF2    ANOP  ,                                                   FCI*
*        BNE   TILT2          NO. TILT.
         AGO   .RNB05C                                            RNB05
.RNB05B  ANOP                                                     RNB05
         BE    OKJOB          /YES - GO CHECK DSID                RNB05
         CLC   =C'PJS',QLOGON IS THIS A PJS USER?                 RNB05
         BE    TILT2          INVALID JOB IF SO                   RNB05
         CLC   QLOGON(*-*),JCTTSUID  DOES THE USERID              RNB05
         EX    R2,*-6                MATCH THE NOTIFY ID?         RNB05
         BE    OKJOB                 GOOD JOB IF SO               RNB05
         CLC   =C'TEC',QLOGON        IS THIS A TEC USERID?        RNB05
         BNE   TILT2                 INVALID JOB IF NOT           RNB05
         CLC   =C'TEC',JCTJNAME      FOR A TEC USER, ALLOW LIST   RNB05
         BE    OKJOB                 FOR ANY TEC JOB OR ANY JOB   RNB05
         CLC   =C'TEC',JCTTSUID      WITH A TEC NOTIFY            RNB05
         BE    OKJOB                                              RNB05
         TM    JCTJOBFL,JCTSTCJB     ALSO ALLOW IF AN STC         RNB05
         BZ    TILT2                                              RNB05
.RNB05C  ANOP                                                     RNB05
OKJOB    DS    0H                                                 UF005
***********************************************************************
*                                                                     *
*   CHECK AND CONVERT THE DATASET ID NUMBER                           *
*                                                                     *
***********************************************************************
         LH    R2,QLNG2       LENGTH OF DATASET ID FIELD
         SH    R2,=H'1'       IS THE DATASET ID FIELD ZERO LENGTH?
         BM    TILT           YES. QUIT.
         MVC   QFZONES,QFZONE INITIALIZE NUMERIC TEST
         EX    R2,MVZ         MOVE THE ZONES FOR VALIDITY CHECK
         CLC   QFZONES,QFZONE IS THE FIELD NUMERIC?
         BNE   TILT           NO. QUIT.
         EX    R2,PACK        PACK THE FIELD
         CVB   R2,CONVERT     CONVERT TO BINARY
         SPACE 1                                                  UF005
         TM    QXAUTH,1       IS USER AUTHORIZED?                 UF005
         BO    *+4+8          YES, ALLOW ANY DSID                 UF005
         SPACE 1                                                  UF005
         CH    R2,=H'101'     IS THE DATASET ID LESS THAN 101?
         BL    TILT           YES. TILT.
         STH   R2,QPDSID      STORE DATASET ID
***********************************************************************
*                                                                     *
*   CHECK AND CONVERT THE PRINT OFFSET                                *
*                                                                     *
***********************************************************************
         MVC   QPOFFSET,=H'0' DEFAULT TO ZERO
         LH    R2,QLNG3       LENGTH OF OFFSET FIELD
         SH    R2,=H'1'       IS THE OFFSET FIELD ZERO LENGTH?
         BM    CALLLIST       YES. USE ZERO OFFSET.
         MVC   QFZONES,QFZONE INITIALIZE NUMERIC TEST
         EX    R2,MVZ2        MOVE THE ZONES FOR VALIDITY CHECK
         CLC   QFZONES,QFZONE IS THE FIELD NUMERIC?
         BNE   TILT           NO. QUIT.
         EX    R2,PACK2       PACK THE FIELD
         CVB   R2,CONVERT     CONVERT TO BINARY
         STH   R2,QPOFFSET    STORE OFFSET
***********************************************************************
*                                                                     *
*   CALL LISTDS TO LIST THE DATASET                                   *
*                                                                     *
***********************************************************************
CALLLIST L     R15,=V(LISTDS) ADDR OF LISTDS MODULE
         BALR  R14,R15        GO TO IT
         QSTOP
TILT     QTILT '*** DATASET ID INVALID ***'
TILT2    QTILT '*** JOBNAME MUST BEGIN WITH USERID ***'
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
CLC      CLC   QLOGON(1),JCTJNAME IS THE JOBNAME EQUAL TO USERID
MVZ      MVZ   QFZONES(1),QPARM2 CHECK FOR NUMERIC
MVZ2     MVZ   QFZONES(1),QPARM3 CHECK FOR NUMERIC
PACK     PACK  CONVERT,QPARM2(1) CONVERT TO BINARY
PACK2    PACK  CONVERT,QPARM3(1) CONVERT TO BINARY
         LTORG
         DROP  ,                   DROP ALL ADDRESSINGS           NERDC
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
LIST     CSECT ,                                                  UF023
JCT      EQU   0
         $BUFFER                                                  UF020
         $JCT
WORK     DSECT
         DS    72C
CONVERT  DS    D
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q15
LISTDS   QSTART 'QUEUE COMMAND - LIST A DATASET FROM THE SPOOL PACK'
         USING QCKPT,R10      BASE REG FOR CHECKPOINT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING QDISPLAY,R9    BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL      LOAD BASE REG
         USING WORK,R13       BASE REG FOR LOCAL WORK
***********************************************************************
*                                                                     *
*   DETERMINE FUNCTION REQUESTED                                      *
*                                                                     *
***********************************************************************
         CLI   QCODE,0        IS THE REQUEST FOR REPOSITIONING?
         BNE   REPOS          YES. DO IT.
***********************************************************************
*                                                                     *
*   LOCATE PDDB FOR DATASET SPECIFIED IN QPDSID                       *
*                                                                     *
***********************************************************************
NORMAL   MVI   SWITCH,0       INITIALIZE SWITCH
         USING PDBDSECT,R2    BASE REG FOR PDDB
         USING IOTSTART,R3    BASE REG FOR IOT
         L     R3,QCIOTA      LOAD BASE REG
         LR    R5,R3          IOAREA FOR READ IOT BLOCK
NEXTIOT  LR    R4,R3          BASE OF IOT
         A     R4,IOTPDDBP    OFFSET BEYOND LAST PDDB
         LR    R2,R3          BASE OF IOT
         A     R2,QCPDDB1     OFFSET TO FIRST PDDB IN IOT
FINDDS   OC    PDBMTTR,PDBMTTR IS THERE ANY OUTPUT?               UF020
         BZ    FINDDS1        NO, SKIP THIS ONE                   UF020
         CLC   QPDSID,PDBDSKEY IS THIS THE DATASET?
         BE    FOUNDDS        YES. CONTINUE.
FINDDS1  LA    R2,PDBLENG(R2) NO. LOOK AT NEXT PDDB.              UF020
         CR    R2,R4          HAVE WE GONE PAST THE LAST PDDB?
         BL    FINDDS         NO. TRY AGAIN.
         L     R4,IOTIOTTR    DISK ADDR OF NEXT IOT
SPIN     LTR   R4,R4          IS THERE ANOTHER IOT?
         BZ    SPINIOT        NO. TRY THE SPIN IOT?
         BAL   R8,READ        READ THE IOT
         B     NEXTIOT        SEARCH THE NEXT IOT
         USING JCTSTART,R1    BASE REG FOR JCT
SPINIOT  TM    SWITCH,1       DID WE SEARCH THE SPINIOT ALREADY?
         BO    TILT           YES. TILT.
         OI    SWITCH,1       SET SWITCH
         L     R1,QCJCTA      LOAD BASE REG
         L     R4,JCTSPIOT    DISK ADDR OF SPIN IOT
         DROP  R1
         B     SPIN           SEARCH THE SPIN IOT CHAIN
TILT     MVC   QPDSID,=H'0'   INVALIDATE DSID
         QTILT '*** DATASET ID NOT FOUND ***'
TILT2    QTILT '*** DATASET TABLE LIMITS EXCEEDED ***'
FOUNDDS  DS    0H                                                 UF007
         CLI   QPARM1,C'*'    USE LAST JOB NAME?                  UF007
         BE    *+4+6          YES, SKIP OVERLAY OF JOBNAME        UF007
         MVC   QCJNAME,QPARM1 SAVE THE JOBNAME                    UF007
         MVC   QCDSNO,QPARM2  SAVE THE DATASET ID NUMBER
         MVC   QDHLINE,QCHLINE MOVE IN HEADING LINE
         MVC   QCRECFM,PDBRECFM RECORD FORMAT FOR SAVE
         MVC   QCLRECL,PDBLRECL RECORD LENGTH FOR SAVE
         L     R4,PDBMTTR     DISK ADDR OF FIRST BLOCK
         L     R5,QCBLKA      ADDR OF DATASET BLOCK IOAREA
         L     R2,QCSTART     BEGINNING OF DISK ADDR TABLE
         ZAP   QCCREC,=P'0'   ZERO CURRENT RECORD NO
         MVC   QCCPTR,QCSTART BEGIN OF TBL
         ZAP   QCHREC,=P'0'   ZERO HIGH REC NO
         MVC   QCHPTR,QCSTART BEGIN OF TBL
         ZAP   QPREC,=P'1'    REPOSITION TO TOP OF DATASET
         B     FIRST          PROCESS DATASET
         DROP  R2
         DROP  R3
***********************************************************************
*                                                                     *
*   PROCESS DATASET                                                   *
*                                                                     *
***********************************************************************
NEXTBLK  L     R4,0(R5)       DISK ADDR OF NEXT BLOCK
FIRST    LTR   R4,R4          IS THE DISK ADDR ZERO?
         BZ    END            YES. END OF DATASET.
         ST    R4,0(R2)       STORE DISK ADDR IN TABLE
         BAL   R8,READ        READ A BLOCK
         CLC   QPJOBID(6),4(R5) DOES THE JOBID MATCH?
         BNE   END            NO. END OF DATASET.
         MVC   4(4,R2),QCCREC STORE CURRENT REC NUM IN TABLE
         ST    R2,QCCPTR      STORE CURRENT TABLE ADDR
         CP    QCCREC,QCHREC  IS THE CURRENT REC NO > HIGHEST?
         BNH   NOTHI          NO. SKIP.
         MVC   QCHREC(8),QCCREC REPLACE HI REC CNT AND PTR
NOTHI    LA    R2,8(R2)       INCREMENT TO NEXT TBL ENTRY
         C     R2,QCEND       IS THIS THE END OF TABLE?
         BNL   TILT2          YES. TILT.
         LA    R4,10(R5)      ADDR OF FIRST RECORD IN BLOCK
***********************************************************************
*                                                                     *
*   PROCESS RECORDS                                                   *
*                                                                     *
***********************************************************************
NEXTREC  CLI   0(R4),X'FF'    IS LENGTH BYTE FF?
         BE    NEXTBLK        YES. END OF BLOCK.
         TM    1(R4),X'10'    IS THIS A SPANNED RECORD?
         BO    SPAN           YES. SKIP IT.
         SR    R6,R6          ZERO OUT REG
         IC    R6,0(R4)       INSERT LENGTH
         LR    R7,R6          SAVE RECORD LENGTH
         LR    R1,R4          SAVE RECORD LOCATION
         TM    1(R4),X'80'    IS CARRIAGE CONTROL SPECIFIED?
         BZ    NOCCTL         NO. CONTINUE.
         LA    R1,1(R1)       SKIP OVER CARRIAGE CONTROL
NOCCTL   TM    1(R4),X'08'    IS THIS RECORD TO BE IGNORED?
         LR    R4,R1          UPDATE RECORD POINTER
         BNZ   SKIPREC        YES. SKIP IT.
         AP    QCCREC,=P'1'   ADD ONE TO CUR REC NO
         CP    QCCREC,QPREC   HAVE WE REACHED THE RECORD WE WANT?
         BL    SKIPREC        NO. TRY NEXT RECORD.
         CLI   QCODE,4        IS THE REQUEST FOR A FIND?
         BE    FIND           YES. DO IT.
         CLI   QCODE,8        IS THE REQUEST FOR A FINDTIME?
         BE    FINDTIME       YES. DO IT.
FINDOFF  AH    R1,QPOFFSET    ADD OFFSET TO START OF RECORD
         SH    R7,QPOFFSET    SUBTRACT OFFSET FROM LENGTH
         BNP   ZEROPRT        NO DATA LEFT IN RECORD.
         CH    R7,QDLNELEN    IS THE RECORD BIGGER THAN LINE?     UF003
         BNH   LTMAX          NO. USE RECORD LENGTH.              UF003
         LH    R7,QDLNELEN    YES. USE A LENGTH OF LINE.          UF003
LTMAX    STH   R7,QDMLNG      STORE MESSAGE LENGTH                UF003
         LA    R1,3(R1)       OFFSET PAST REC HDR
         ST    R1,QDMSGA      STORE ADDR OF MESSAGE LINE
         L     R15,=V(DISPLAY) ADDRESS OF DISPLAY MODULE
         BALR  R14,R15        GO TO IT
         TM    QDOVER,1       WAS THERE A PAGE OVERFLOW?
         BNO   SKIPREC        NO. SKIP.
         ZAP   QPREC,QCCREC   UPDATE THE REPOSITION NUMBER
         MVC   HREC,EDIT      PATTERN FOR EDIT
         ED    HREC,QCCREC    EDIT RECORD NUMBER
SKIPREC  LA    R4,3(R6,R4)    INCREMENT TO NEXT RECORD
         B     NEXTREC        PROCESS NEXT RECORD
SPAN     LH    R6,2(R4)       LENGTH OF SEGMENT
         TM    1(R4),X'08'    IS THIS THE FIRST SEGMENT?
         BO    SPANFRST       YES. USE HEADER LENGTH OF 6.
         LA    R4,4(R6,R4)    UPDATE RECORD POSITION
         B     NEXTREC        PROCESS NEXT RECORD
SPANFRST LA    R4,6(R6,R4)    UPDATE RECORD POSITION
         B     NEXTREC        PROCESS NEXT RECORD
ZEROPRT  LA    R1,QBLANK      PRINT A BLANK
         LA    R7,1           LENGTH OF ONE
         B     LTMAX          PRINT THE RECORD                    UF003
END      CP    QCCREC,=P'0'   IS THE DATASET EMPTY
         BE    STOP           YES. QUIT.
         MVC   HEND,ENDLINE   TELL THEM THIS IS THE END
         MVC   HREND,EDIT     PATTERN FOR EDIT
         ED    HREND,QCCREC   LAST REC NO
         CLI   QCODE,32       WAS REQUEST FOR BOTTOM?
         BE    BOTTOM         YES. BACK UP 21 LINES.
         MVC   QDMLNG,=H'0'   ZERO OUT MESSAGE LENGTH
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE
         BALR  R14,R15        FLUSH THE SCREEN
         ZAP   QPREC,=P'1'    RECORD NUMBER 1
         MVC   QDHLINE,QCHLINE BLANK THE TITLE LINE
         B     TOP            START AT TOP OF DATASET
STOP     XC    QPDSID,QPDSID  MAKE USER SPECIFY A NEW DATA SET
         MVC   QDHLINE,=CL80'*** DATA SET IS EMPTY ***'
         QSTOP
***********************************************************************
*                                                                     *
*   BOTTOM OF DATASET                                                 *
*                                                                     *
***********************************************************************
BOTTOM   ZAP   QPREC,QCCREC   LAST RECORD NUMBER
         MVI   QCODE,0        AVOID A LOOP
         SP    QPREC,QDLNES   TOP OF PAGE -1                      UF003
         AP    QPREC,=P'1'    TOP OF PAGE                         UF003
         BP    REPOS          CONTINUE IF POSITIVE.
         ZAP   QPREC,=P'1'    TOP OF DATASET
***********************************************************************
*                                                                     *
*   REPOSITION TO REQUESTED RECORD NUMBER                             *
*                                                                     *
***********************************************************************
REPOS    MVC   QDHLINE,QCHLINE MOVE IN HEADING LINE
         MVC   HREC,EDIT      PREPARE FOR EDIT
         ED    HREC,QPREC     EDIT RECORD NUMBER
         CP    QPREC,QCHREC   IS THE REQ NO > HIGHEST READ?
         BNL   HI             YES. GO FROM HI.
         CP    QPREC,QCCREC   IS THE REQ NO > CURRENT REC?
         BH    UP             YES. GO FROM CURRENT.
         CP    QPREC,=P'1'    IS REQ FOR TOP OF DATASET?
         BH    DOWN           NO. GO DOWN FROM CURRENT.
TOP      L     R2,QCSTART     START AT TOP
RESUME   L     R4,0(R2)       LOAD DISK ADDR
         L     R5,QCBLKA      ADDR OF BLOCK IOAREA
         MVC   QCCREC,4(R2)   RESET CURRENT REC NO
         B     FIRST          RESUME PROCESSING
HI       L     R2,QCHPTR      START AT HIGHEST SO FAR
         B     DOWNLOOP       FIND CORRECT BLOCK
UP       L     R2,QCCPTR      CURRENT TABLE PTR
UPLOOP   CP    QPREC,12(4,R2) IS THE NEXT ENTRY > REQ NO?
         BNH   RESUME         YES. PROCESS IT.
         LA    R2,8(R2)       TRY NEXT ENTRY
         B     UPLOOP         AGAIN
DOWN     L     R2,QCCPTR      CURRENT TABLE PTR
DOWNLOOP CP    QPREC,4(4,R2)  IS THE ENTRY < REQ NO?
         BH    RESUME         YES. PROCESS IT.
         SH    R2,=H'8'       TRY PREVIOUS ENTRY
         B     DOWNLOOP       AGAIN
***********************************************************************
*                                                                     *
*   FIND MATCHING RECORD ROUTINE                                      *
*                                                                     *
***********************************************************************
FIND     LH    R3,QPLNG       LENGTH-1 OF COMPARE
         LR    R14,R6         LENGTH OF RECORD
         SR    R14,R3         NUMBER OF COMPARES
         BNP   SKIPREC        RECORD IS TOO SMALL. SKIP IT.
         LR    R15,R4         FIRST BYTE OF RECORD
         CLC   QOFFE,=H'0'    END RANGE FOR FIND SPECIFIED ?
         BE    FLOOP          NO. BYPASS RANGE FOR FIND
         AH    R15,QOFFS      YES. START ADDR FOR FIND
         LH    R14,QOFFE      END ADDR FOR FIND
         SH    R14,QOFFS      VALID RANGE ?
         BP    FLOOP          YES. CONTINUE PROCESSING
         QTILT ' *** ERROR IN COLUMN SPECIFICATION ***'
FLOOP    EX    R3,CLC         DOES THE FIND DATA MATCH THE RECORD?
         BE    MATCH          YES. DISCONTINUE SEARCH.
         LA    R15,1(R15)     INCREMENT TO NEXT BYTE
         BCT   R14,FLOOP      TRY NEXT BYTE
         B     SKIPREC        SKIP THE RECORD. NO MATCH.
MATCH    CLI   QSUBNAME+1,C'A' IS THE REQUEST FOR A FINDALL?
         BE    FALL           YES. DO NOT DISABLE SEARCH.
         MVI   QCODE,0        END THE SEARCH
         ZAP   QPREC,QCCREC   UPDATE THE REPOSITION NUMBER
FALL     MVC   HREC,EDIT      PREPARE FOR EDIT
         ED    HREC,QCCREC    EDIT RECORD NUMBER
         B     FINDOFF        CONTINUE
CLC      CLC   QPFIND(1),3(R15) COMPARE PARM TO RECORD
***********************************************************************
*                                                                     *
*   FIND THE RECORD WHICH IS GREATER THAN OR EQUAL TO TIME            *
*                                                                     *
***********************************************************************
FINDTIME CLI   10(R4),C'.'    DOES THIS RECORD HAVE TIME?
         BNE   SKIPREC        NO. SKIP IT.
         CLC   QPARM1,8(R4)   IS THIS THE TIME WE WANT?
         BH    SKIPREC        NO. SKIP IT.
         B     MATCH          END THE SEARCH
***********************************************************************
*                                                                     *
*   READ A BLOCK FROM HASPACE                                         *
*                                                                     *
***********************************************************************
READ     ST    R4,QCTRAK      STORE DISK ADDR
         LR    R1,R5          IOAREA ADDRESS
         L     R15,=V(READSPC) ADDR OF ROUTINE TO READ HASPACE
         BALR  R14,R15        GO TO IT
         BR    R8             RETURN TO CALLER
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
ENDLINE  DC    C', END OF DATA. LAST REC #'
EDIT     DC    X'4020202020202021'
         DC    CL45' '
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
LISTDS   CSECT ,                                                  UF023
JCT      EQU   0
BUFSTART EQU   0
BUFDSECT EQU   0
         $TAB
         $JCT
         $PDDB
         $IOT
         QCOMMON
         ORG   QDHLINE
         DS    C'JOB XXXXXXXX, DSID XXXXXXXX, REC #'
HREC     DS    CL8
HEND     DS    C', END OF DATA. LAST REC #'
HREND    DS    CL8
WORK     DSECT
         DS    CL72
SWITCH   DS    C
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q16
PARSE    QSTART 'QUEUE COMMAND - COMMAND LINE PARSE ROUTINES'
***********************************************************************
* RNB CHANGES:                                                        *
*    (1) ADDED COMMAND ABBREVIATIONS: RNB06                           *
*                JM FOR JMSG                                          *
*                JL FOR JLOG                                          *
*                JC FOR JCL                                           *
*                SL FOR SLOG                                          *
*                FT FOR FTIM                                          *
*                DE FOR DEL                                           *
*                RE FOR REQ                                           *
*    (2) DELETED COMMANDS:      RNB06  (ONLY IF QRNB=1)               *
*                TSO, EXEC, AND MODEL                                 *
*    (3) USE RACF TO CHECK FOR X AUTHORITY (XP COMMAND): RNB03        *
*                                                                     *
***********************************************************************
         GBLB  &QRNB                                              RNB06
         GBLB  &QRACF                                             RNB03
         USING QDISPLAY,R10   BASE REG FOR DISPLAY WORK AREA
         L     R10,QVDSPL     LOAD BASE REG
         USING WORK,R13       BASE REG FOR LOCAL WORK AREA
***********************************************************************
*                                                                     *
*   PARSE SUBCOMMAND NAME                                             *
*                                                                     *
***********************************************************************
         LH    R2,QDRLNG      LENGTH OF REPLY LINE
         OC    QDREPLY,QBLANK TRANSLATE TO UPPER CASE
         CLC   QDREPLY,QBLANK IS THE ENTIRE REPLY BLANK?
         BE    LOOKUP         YES. DO LOOKUP.
         MVC   QDTLINE,QDREPLY MOVE COMMAND LINE TO HEADING
         MVC   FIELD,QBLANK   BLANK THE WORK FIELD
         MVC   OFFSET(4),=F'0' ZERO THE OFFSET AND LENGTH
         MVC   QOFF0(12),OFFSET INITIALIZE FIRST FIELD
         MVC   QOFF1(48),QOFF0 INITIALIZE NEXT FOUR FIELDS
         LA    R6,QOFF4+12    ADDR PAST LAST FIELD
         LA    R5,QOFF0       ADDR OF FIRST SET OF FIELDS
         LA    R3,QDREPLY     FIRST BYTE OF REPLY LINE
ENCORE   LA    R4,FIELD       FIRST BYTE OF WORK FIELD
BLANK    CLI   0(R3),C' '     IS THIS BYTE BLANK?
         BNE   FIRST          NO. START OF FIELD.
         LA    R3,1(R3)       YES. SKIP IT.
         BCT   R2,BLANK       TRY NEXT BYTE
         B     EMPTY          END OF REPLY LINE.
FIRST    LH    R1,QDRLNG      REPLY LENGTH
         SR    R1,R2          COMPUTE OFFSET TO START OF FIELD
         STH   R1,OFFSET      STORE OFFSET
         LR    R1,R2          SAVE COUNT OF REMAINING BYTES
         B     CHAR           CONTINUE
LOOP     CLI   0(R3),C' '     IS THIS BYTE BLANK?
         BE    LAST           YES. END OF FIELD.
CHAR     MVC   0(1,R4),0(R3)  MOVE BYTE TO SUBNAME
         LA    R3,1(R3)       INCREMENT
         LA    R4,1(R4)       INCREMENT
         BCT   R2,LOOP        TRY NEXT BYTE
LAST     SR    R1,R2          COMPUTE FIELD LENGTH
         CH    R1,=H'8'       IS LENGTH GREATER THAN 8?
         BNH   STORE          NO. USE IT.
         LA    R1,8           YES. USE LENGTH OF EIGHT.
STORE    STH   R1,LENGTH      STORE FIELD LENGTH
EMPTY    MVC   0(12,R5),OFFSET MOVE FIELD TO QCOMMON
         LTR   R2,R2          IS THE REMAINING LENGTH ZERO?
         BZ    LOOKUP         YES. DO THE TABLE LOOKUP.
         MVC   FIELD,QBLANK   BLANK THE WORK FIELD
         MVC   OFFSET(4),=F'0' ZERO OUT OFFSET AND LENGTH
         LA    R5,12(R5)      INCREMENT TO NEXT FIELD
         CR    R5,R6          WAS THAT THE LAST FIELD?
         BL    ENCORE         NO. PROCESS NEXT FIELD.
***********************************************************************
*                                                                     *
*   LOOK UP THE MODULE ADDRESS FOR THE SUB COMMAND                    *
*                                                                     *
***********************************************************************
LOOKUP   CLC   =C'XP',QSUBNAME  IS THIS A PASSWORD REQUEST?       UF014
         BE    PASSWD         YES. CHECK FOR PASSWORD.            UF014
LOOKUP2  LA    R2,TABLE       START OF SUBCOMMAND TABLE
         TM    QXAUTH,1       IS THE USER PRIVILEGED?             UF014
         BNO   NEXT           NO, TABLE IS OK                     UF014
         LA    R2,TABLEX      START OF PRIV TABLE                 UF014
         CLC   =C'DIE',QSUBNAME IS THIS THE DIE REQUEST?          UF024
         BE    CDIE           YES, DO IT                          UF024
NEXT     CLC   0(4,R2),QSUBNAME COMPARE FIRST 4 CHARACTERS        UF014
         BE    FOUND          THIS IS THE ONE
         LA    R2,10(R2)      NEXT ENTRY                          UF014
         CLI   0(R2),X'FF'    IS THIS THE END OF TABLE?
         BNE   NEXT           NO. TRY NEXT ENTRY.
FOUND    MVC   QCODEH(6),4(R2) SUBCOMMAND CODE AND COMMAND ADDR   UF014
STOP     QSTOP
***********************************************************************
*                                                                     *
*   CHECK PASSWORD FOR AUTHORIZED COMMANDS                        UF014
*                                                                     *
***********************************************************************
         AIF   (&QRACF).RNB03A                                    RNB03
PASSWD   CLC   QPARM1,=C'PASSWORD' DID THE USER SAY PASSWORD?
         BNE   BOUNCE         NO. REJECT.
         TPUT  WPASS,L'WPASS,FULLSCR,MF=(E,QTPUT)
*        LA    R1,RPASS       REPLY ADDRESS
         TGET  RPASS,8,EDIT,MF=(E,QTGET)
         CLC   RPASS,=C'YES SIR!' IS THE PASSWORD CORRECT?
         BNE   BOUNCE         NO. REJECT.
         OI    QXAUTH,1       AUTHORIZE USER
         QTILT '*** PASSWORD ACCEPTED ***'
         AGO   .RNB03B                                            RNB03
.RNB03A  ANOP                                                     RNB03
PASSWD   RACHECK ENTITY=QRACNMXP,MF=(E,QRACHECK)                  RNB03
         LTR   R15,R15                                            RNB03
         BNZ   BOUNCE                                             RNB03
         OI    QXAUTH,1       AUTHORIZE USER                      RNB03
         QTILT '*** AUTHORIZED FUNCTIONS ENABLED'                 RNB03
.RNB03B  ANOP                                                     RNB03
BOUNCE   LA    R2,HELPCC      NO. PRETEND IT IS INVALID.
         B     FOUND          CONTINUE
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
         EJECT ,                                                  UF014
TABLEX   DS    0D             START OF PRIV COMMAND TABLE         UF014
         DC    C'XB  ',H'0',VL4(HEXBLK)    DISP SPOOL BLOCK
         DC    C'XJ  ',H'36',VL4(SEARCH)   DISP HEX JQE/JOE
         DC    C'XI  ',H'0',VL4(INITS)     DISP ACTIVE INITS
         DC    C'XD  ',H'0',VL4(XDS)       UNRESTRICTED DISP OF FILES
         DC    C'JQE ',H'0',VL4(CJQE)      HEX DUMP OF JQE        UF015
         DC    C'JCT ',H'0',VL4(CJCT)      HEX DUMP OF JCT        UF016
         DC    C'HCT ',H'0',VL4(CHCT)      HEX DUMP OF HCT SAVEAREUF022
         DC    C'PDDB',H'0',VL4(CPDDB)     LIST PDDB'S FOR JOB    UF025
         DC    C'JOE ',H'0',VL4(CJOE)      HEX DUMP OF JOE        UF026
         SPACE 1                                                  UF014
TABLE    EQU   *              START OF STANDARD COMMAND TABLE     UF014
         DC    C'STAT',H'0',VL4(SEARCH)    STATUS
         DC    C'ST  ',H'0',VL4(SEARCH)    STATUS
         DC    C'DD  ',H'0',VL4(DDNAME)    LIST SYSINS/SYSOUTS FOR JOB
         DC    C'LIST',H'0',VL4(LIST)      LIST A SYSIN/SYSOUT FILE
         DC    C'L   ',H'0',VL4(LIST)      LIST A SYSIN/SYSOUT FILE
         DC    C'FIND',H'4',VL4(REPOS)     FIND
         DC    C'FALL',H'4',VL4(REPOS)     FIND ALL
         DC    C'FA  ',H'4',VL4(REPOS)     FIND ALL
         DC    C'F   ',H'4',VL4(REPOS)     FIND
         DC    C'FTIM',H'8',VL4(REPOS)     FTIME (SYSLOG)
         DC    C'FT  ',H'8',VL4(REPOS)     FTIME (SYSLOG)         RNB06
         DC    C'COL ',H'12',VL4(REPOS)    COLUMN
         DC    C'CO  ',H'12',VL4(REPOS)    COLUMN
         DC    C'C   ',H'12',VL4(REPOS)    COLUMN
         DC    C'@   ',H'16',VL4(REPOS)    REPOS TO RECORD NUMBER
         DC    C'MD  ',H'16',VL4(REPOS)    REPOS TO RECORD NUMBER
         DC    C'+   ',H'20',VL4(REPOS)    DOWN
         DC    C'D   ',H'20',VL4(REPOS)    DOWN
         DC    C'PF  ',H'20',VL4(REPOS)    PAGE FORWARD
         DC    C'HF  ',H'20',VL4(REPOS)    HALF PAGE FORWARD
         DC    C'-   ',H'24',VL4(REPOS)    UP
         DC    C'UP  ',H'24',VL4(REPOS)    UP
         DC    C'PB  ',H'24',VL4(REPOS)    PAGE BACK
         DC    C'HB  ',H'24',VL4(REPOS)    HALF BACK
         DC    C'TOP ',H'28',VL4(REPOS)    TOP
         DC    C'T   ',H'28',VL4(REPOS)    TOP
         DC    C'BOTT',H'32',VL4(REPOS)    BOTTOM
         DC    C'BOT ',H'32',VL4(REPOS)    BOTTOM
         DC    C'B   ',H'32',VL4(REPOS)    BOTTOM
         AIF   (&QRNB).RNB06A                                     RNB06
         DC    C'MODE',H'36',VL4(REPOS)    MODEL                  UF003
         DC    C'M   ',H'36',VL4(REPOS)    MODEL                  UF003
.RNB06A  ANOP                                                     RNB06
         DC    C'SAVE',H'4',VL4(SAVE)      SAVE COPY OF CURRENT FILE
         DC    C'SLOG',H'0',VL4(SYSLOG)    LIST THE SYSTEM LOG DATASET
         DC    C'SL  ',H'0',VL4(SYSLOG)    LIST THE SYSTEM LOG   RNB06
         DC    C'DA  ',H'4',VL4(SEARCH)    DISP ALL IN EXEC
         DC    C'DI  ',H'8',VL4(SEARCH)    DISP ALL IN INPUT CLASS
         DC    C'DO  ',H'12',VL4(SEARCH)   DISP ALL IN OUTPUT CLASS
         DC    C'AI  ',H'16',VL4(SEARCH)   DISP ALL AVAIL FOR EXEC
         DC    C'AO  ',H'20',VL4(SEARCH)   DISP ALL AVAIL FOR OUTPUT
         DC    C'HI  ',H'24',VL4(SEARCH)   DISP ALL IN INPUT HOLD
         DC    C'HO  ',H'28',VL4(SEARCH)   DISP ALL IN OUTPUT HOLD
         DC    C'DT  ',H'32',VL4(SEARCH)   DISP TSO USERS
         DC    C'DJ  ',H'36',VL4(SEARCH)   DISPLAY JOB
         DC    C'DS  ',H'40',VL4(SEARCH)   DISPLAY STC
         DC    C'DQ  ',H'44',VL4(SEARCH)   DISP INPUT QUEUES
         DC    C'DF  ',H'48',VL4(SEARCH)   DISP OUTPUT QUEUES
         DC    C'JCL ',H'0',VL4(JCL)       LIST JCL
         DC    C'JC  ',H'0',VL4(JCL)       LIST JCL               RNB06
         DC    C'JLOG',H'0',VL4(JLOG)      LIST JOBLOG
         DC    C'JL  ',H'0',VL4(JLOG)      LIST JOBLOG            RNB06
         DC    C'JMSG',H'0',VL4(JMSG)      LIST SYSMSGS
         DC    C'JM  ',H'0',VL4(JMSG)      LIST SYSMSGS           RNB06
         DC    C'DC  ',H'0',VL4(ACTIVE)    DISP CPU BATCH/STC/TSO
         DC    C'DEL ',H'0',VL4(SYSOUT)    DELETE JOB
         DC    C'DE  ',H'0',VL4(SYSOUT)    DELETE JOB             RNB06
         DC    C'REQ ',H'4',VL4(SYSOUT)    REQUEUE JOB
         DC    C'RE  ',H'4',VL4(SYSOUT)    REQUEUE JOB            RNB06
         DC    C'CAN ',H'8',VL4(SYSOUT)    CANCEL JOB
         DC    C'CA  ',H'8',VL4(SYSOUT)    CANCEL JOB             RNB06
         AIF   (&QRNB).RNB06B                                     RNB06
         DC    C'TSO ',H'0',VL4(CTSO)      ISSUE ANY TSO COMMAND  UF017
         DC    C'EX  ',H'0',VL4(CTSO)      IMPLICIT CLIST INVOKE  UF017
         DC    C'EXEC',H'0',VL4(CTSO)      IMPLICIT CLIST INVOKE  UF017
         DC    C'PDDB',H'0',VL4(CPDDB)     LIST PDDB'S FOR JOB    UF025
.RNB06B  ANOP                                                     RNB06
HELPCC   DC    X'FF0000000000',VL4(HELP)
         SPACE 1                                                  UF014
WPASS    DC    X'C1115D7F1140403C4040001D4C13'  *** SPF TCAM
         SPACE 1                                                  UF024
CDIE     DC    X'00DEAD'                                          UF024
         DC    AL1(L'CDIEMSG)                                     UF024
CDIEMSG  DC    C'DIE COMMAND ENTERRED'                            UF024
         SPACE 1                                                  UF024
CDIEDONE LA    R2,HELPCC          SIMULATE HELP REQUEST WHEN RETURN 024
         MVI   QSUBNAME,0         CLEAR COMMAND NAME              UF024
         B     FOUND              AND RETURN TO CALLER            UF024
         SPACE 1                                                  UF024
         AIF   (NOT &QRACF).RNB03C                                RNB03
RACNAME  DC    CL8'QUEUEXP'                                       RNB03
.RNB03C  ANOP                                                     RNB03
WORK     DSECT
         DS    CL72
OFFSET   DS    H
LENGTH   DS    H
FIELD    DS    CL8
RPASS    DS    CL8
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q17
READSPC  QSTART 'QUEUE COMMAND - READ A BLOCK FROM HASPACE'
***********************************************************************
* RNB CHANGES:                                                        *
*      (1) RNB03 - WITH RACF SUPPORT, WHEN A JCT IS READ WIPE OUT THE *
*                  PASSWORD FIELDS (JCTPASS, JCTNUPAS)                *
***********************************************************************
         GBLB  &QRACF                                             RNB03
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
***********************************************************************
*                                                                     *
*   CONVERT MTTR TO MBBCCHHR                                          *
*                                                                     *
***********************************************************************
*
* NOTE - THE INPUT TO THIS ROUTINE IS AS FOLLOWS:
*            QCTRAK CONTAINS THE MTTR
*            R1 CONTAINS THE IOAREA ADDRESS
*
         LR    R2,R1          MOVE IOAREA ADDR TO R2
         SR    R3,R3          ZERO R3
         IC    R3,QCTRAKM     RELATIVE DCB NUMBER
         SLL   R3,2           MULTIPLY BY 4
         MVC   QCDADR,QCTRAKR MOVE RECORD NUMBER
         MVC   QCDADHH,QCTRAKTT MOVE TRACK TO A HALFWORD BOUNDARY
         LH    R5,QCDADHH     LOAD RELATIVE TRACK NUMBER
         SR    R4,R4          ZERO R4
         D     R4,QCTRKCYL(R3) DIVIDE TRACKS BY TRACKS PER CYLINDER
         STH   R4,QCDADHH     STORE HEAD NUMBER
         STH   R5,QCDADCC     STORE CYLINDER NUMBER
         L     R3,QCSPOOLS(R3) DCB ADDRESS
         USING IHADCB,R3      ADDRESSING FOR DCB DSECT            UF009
         MVC   DCBSYNAD+1(3),=AL3(SYNAD)  SET SYNAD ADDR IN DCB   UF009
         DROP  R3             DROP ADDRESSING FOR DCB             UF009
         READ  HDECB2,DI,(R3),(R2),MF=E
         CHECK HDECB2
         TM    QFLAG1,QFLG1IOE  I/O ERROR?                        UF009
         BZ    QSTOP          NO, RETURN TO CALLER                UF009
         NI    QFLAG1,255-QFLG1IOE  CLEAR ERROR FLAG              UF009
*        SIMULATE QTILT ACTION                                    UF009
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE             UF009
         LR    R14,R15        SET FOR LOOP                        UF009
         BR    R15            GO TO IT                            UF009
QSTOP    EQU   *                                                  RNB03
         AIF   (NOT &QRACF).RNB03A                                RNB03
         USING JCTDSECT,R2    SEE IF WE READ A JCT                RNB03
         CLC   JCTID,=CL4'JCT'  POSSIBLE JCT?                     RNB03
         BNE   RNB03C           /NO  - GO QSTOP                   RNB03
         CLC   JCTJNAME,JCTJMRJN  JOB NAME IN BOTH PLACES?        RNB03
         BNE   RNB03C             /NO  - GO QSTOP                 RNB03
         CLC   =C'JOB ',JCTJOBID  IS IT AN STC, A JOB, OR A TSU?  RNB03
         BE    RNB03B             IF SO, ASSUME THIS IS A JCT     RNB03
         CLC   =C'TSU ',JCTJOBID                                  RNB03
         BE    RNB03B                                             RNB03
         CLC   =C'STC ',JCTJOBID                                  RNB03
         BNE   RNB03C                                             RNB03
RNB03B   XC    JCTPASS,JCTPASS    WIPE OUT THE PASSWORDS          RNB03
         XC    JCTNUPAS,JCTNUPAS                                  RNB03
         DROP  R2                                                 RNB03
RNB03C   EQU   *                                                  RNB03
.RNB03A  ANOP                                                     RNB03
         QSTOP                                                    RNB03
SYNAD    SYNADAF ACSMETH=BDAM DECODE ERROR CAUSE                  UF009
         OI    QFLAG1,QFLG1IOE  SET I/O ERROR FLAG                UF009
         USING QDISPLAY,R15   BASE REG FOR DISPLAY WORK AREA      UF009
         L     R15,QVDSPL     LOAD BASE REG                       UF009
         MVC   QDHLINE,QBLANK BLANK MESSAGE AREA                  UF009
         MVC   QDHLINE(78),50(R1)  COPY SYNAD MESSAGE             UF009
         MVC   QDMLNG,=H'0'   ZERO MESSAGE LENGTH                 UF009
         DROP  R15                                                UF009
         SYNADRLS ,           RELEASE WORK AREA                   UF009
         BR    R14            RETURN TO OP SYS                    UF009
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         AIF   (NOT &QRACF).RNB03X                                RNB03
READSPC  CSECT                                                    RNB03
JCT      EQU   0                                                  RNB03
BUFSTART EQU   0                                                  RNB03
BUFDSECT EQU   0                                                  RNB03
         $JCT                                                     RNB03
.RNB03X  ANOP                                                     RNB03
         QCOMMON
         DCBD  DSORG=DA,DEVD=DA                                   UF009
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q18
REPOS    QSTART 'QUEUE COMMAND - DATASET REPOSITIONING ROUTINES'
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING QDISPLAY,R9    BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL      LOAD BASE REG
         USING WORK,R13       BASE REG FOR LOCAL WORK AREA
***********************************************************************
*                                                                     *
*   BRANCH TO PROPER ROUTINE                                          *
*                                                                     *
***********************************************************************
         CLC   QCODEH,=H'36'  MODEL 2/5 COMMAND?                  UF003
         BE    MODEL          OK IF NO DATASET                    UF003
         SPACE 1                                                  UF003
CHKID    CLC   QPDSID,=H'0'   IS THERE A VALID DATASET?
         BNE   GO             YES. GO AHEAD.
         QTILT '*** YOU ARE NOT PROCESSING A VALID DATASET ***'
GO       LH    R1,QCODEH      LOAD FUNCTION CODE
         CH    R1,=H'32'      IS THE FUNCTION SUPPORTED?
         BH    STOP           NO. RETURN.
         B     *+4(R1)        BRANCH TO ROUTINE
         B     TILT           0 OFFSET
         B     FIND           4
         B     FINDTIME       8
         B     COLUMN         12
         B     AT             16
         B     PLUS           20
         B     MINUS          24
         B     TOP            28
         B     BOTTOM         32
TILT     QTILT '*** PARAMETER IS INVALID OR OMITTED ***'
***********************************************************************
*                                                                     *
*   REPOSITION VERTICALLY                                             *
*                                                                     *
***********************************************************************
* SKIP FORWARD
PLUS     CLI   QPARM1,C' '    DEFAULT NEEDED
         BNE   PLUS010        NO
         MVI   QLNG1+1,X'01'  YES, SET LENGTH OF PARM
         MVI   QPARM1,X'F1'   SET DEFAULT TO 1
PLUS010  BAL   R4,NUMERIC     VALIDATE PARAMETER
         AP    QPREC,COUNT    ADD COUNT TO CURRENT RECORD
         B     RESUME         CALL LISTDS
* SKIP BACKWARD
MINUS    CLI   QPARM1,C' '    DEFAULT NEEDED
         BNE   MINUS010       NO
         MVI   QLNG1+1,X'01'  YES, SET LENGTH OF PARM
         MVI   QPARM1,X'F1'   SET DEFAULT TO 1
MINUS010 BAL   R4,NUMERIC     VALIDATE PARAMETER
         SP    QPREC,COUNT    SUBTRACT COUNT FROM CURRENT RECORD
         BP    RESUME         CALL LISTDS IF RESULT POSITIVE.
* TOP OF DATASET
TOP      ZAP   QPREC,=P'1'    SET CURRENT RECORD TO TOP OF DS
* RESUME AT CURRENT RECORD
RESUME   L     R15,=V(LISTDS) ADDR OF LISTDS MODULE
         BALR  R14,R15        GO TO IT
STOP     QSTOP
* BOTTOM OF DATASET
BOTTOM   ZAP   QPREC,=P'9999999' SET CURRENT RECORD TO LARGEST
         B     RESUME         CALL LISTDS
* POSITION TO THIS RECORD
AT       BAL   R4,NUMERIC     VALIDATE PARAMETER
         ZAP   QPREC,COUNT    INDICATE REPOSITION NO
         B     RESUME         CALL LISTDS
* CHECK THE PARMETER FOR VALID NUMERIC AND PACK IT
NUMERIC  LH    R2,QLNG1       LENGTH OF PARM
         SH    R2,=H'1'       IS THE COUNT FIELD ZERO?
         BM    RESUME         YES. RESUME FROM CURRENT POSITION.
         MVC   QFZONES,QFZONE INITIALIZE NUMERIC CHECK
         EX    R2,MVZ         MOVE THE ZONES FOR VALIDITY CHECK
         CLC   QFZONES,QFZONE IS THE FIELD NUMERIC?
         BNE   TILT           NO. TILT.
         EX    R2,PACK        PACK THE FIELD INTO COUNT
         CLI   QSUBNAME,C'P'  ?/PAGE FORWARD/BACKWARD SPECIFIED
         BE    FOUNDP         YES. GO PROCESS
         CLI   QSUBNAME,C'H'  ?/HALF PAGE FORWARD/BACKWARD SPECIFIED
         BNE   NEXIT          NO. GO TO EXIT
         MP    COUNT,QDLNES   YES. MULTIPLY BY PAGE SIZE          UF003
         DP    COUNT,=P'2'    AND CONVERT TO HALF PAGES           UF003
         ZAP   COUNT,COUNT(7) RE-ALIGN THE STUPID FIELD           UF003
         B     NEXIT
FOUNDP   MP    COUNT,QDLNES   YES. MULTIPLY BY PAGE SIZE          UF003
NEXIT    BR    R4             RETURN
* EXECUTED INSTRUCTIONS
MVZ      MVZ   QFZONES(1),QPARM1 CHECK FOR NUMERIC
PACK     PACK  COUNT,QPARM1(1) PACK COUNT
***********************************************************************
*                                                                     *
*   REPOSITION HORIZONTALLY                                           *
*                                                                     *
***********************************************************************
COLUMN   CLI   QPARM1,C' '    ?/DEFAULT NEEDED
         BE    COL010         YES, GO SET IT
         CLI   QPARM1,C'0'    ?/SET COLUMN TO 1
         BNE   COL020         NO, TEST IF NUMERIC
COL010   MVI   QLNG1+1,X'01'  SET LENGTH OF PARM
         MVI   QPARM1,X'F1'   SET COLUMN TO 1
COL020   BAL   R4,NUMERIC     VALIDATE PARAMETER
         CP    COUNT,=P'255'  IS THE COUNT FIELD TOO BIG?
         BH    TILT           YES. TILT.
         SP    COUNT,=P'1'    COLUMN RELATIVE TO ZERO
         BM    TILT           INVALID. TILT.
         CVB   R5,COUNT       CONVERT TO BINARY
         STH   R5,QPOFFSET    STORE IN QPOFFSET
         B     RESUME         CALL LISTDS
***********************************************************************
*                                                                     *
*   LOCATE SPECIFIC RECORD                                            *
*                                                                     *
***********************************************************************
FIND     CLI   QSUBNAME+1,C'A' IS THE REQUEST FOR FIND ALL?
         BE    FIND2          YES. DO NOT UPDATE RECORD POINTER.
         AP    QPREC,=P'1'    START SEARCH AT NEXT RECORD
FIND2    CLI   QPARM1,C' '    IS THERE A PARAMETER?
         BE    RESUME         NO. CONTINUE WITH PREVIOUS FIND.
         LA    R2,QDREPLY+62  END OF USER REPLY
         LA    R3,61          MAXIMUM LENGTH OF PARM
         SH    R3,QOFF1       OFFSET TO FIRST PARM
LOOP     CLC   0(1,R2),QPARM1 IS THIS THE DELIMITER?
         BE    FOUND          YES. CONTINUE.
         BCTR  R2,0           TRY THE PREVIOUS BYTE
         BCT   R3,LOOP        IS THE LENGTH FIELD EXHAUSTED?
         B     TILT           YES. TILT.
FOUND    BCTR  R3,0           DECREMENT LENGTH BY 1
         LA    R2,QDREPLY+1   ADDR OF REPLY + 1
         AH    R2,QOFF1       ADDR OF FIRST BYTE OF PARM
         EX    R3,MVC         MOVE PARM TO QPFIND
         STH   R3,QPLNG       SAVE LENGTH-1 OF PARM
         B     COLTEST        TEST IF COLUMN KEYWORD IS PRESENT
MVC      MVC   QPFIND(1),0(R2) MOVE PARM TO QPFIND
***********************************************************************
*                                                                     *
*    COLUMN RANGE FOR FIND                                            *
*                                                                     *
***********************************************************************
COLTEST  XC    QOFFS,QOFFS    RESET COLUMN OFFSETS
         XC    QOFFE,QOFFE
         LA    R2,3(R2,R3)    PREPARE FOR NEXT FIELD
         LA    R3,QDREPLY+55  END OF USER REPLY
LOOP1    CLC   0(3,R2),=CL3'COL'  ?/COLUMN PARAMETER
         BE    FOUNDA         YES. GO PROCESS
         LA    R2,1(R2)       NO. LOOK AT NEXT FIELD
         CR    R2,R3          ?/END OF REPLY
         BH    RESUME         YES. EXIT
         B     LOOP1          NO. CHECK AGAIN
FOUNDA   LA    R2,3(R2)       NEXT FIELD
         CLI   0(R2),C'('     ?/LP PRESENT
         BNE   PRESUME        NO. EXIT
         LA    R2,1(R2)       NEXT FIELD
         LA    R3,QDREPLY+62  END OF REPLY
         LR    R5,R2          SAVE START OF THIS FIELD
         MVI   QDELIMIT,C','  LOOKING FOR DELIMETER = ','
         BAL   R7,CHKDEL      GO CHECK THE DELIMETER
         CVB   R6,COUNT       CONVERT START COLUMN OFFSET TO BINARY
         LTR   R6,R6          ?/USER SPECIFY OFFSET OF ZERO
         BZ    PRESUME        YES. GO INDICATE AN ERROR
         BCTR  R6,0           DECREMENT OFFSET BY 1
         STH   R6,QOFFS       SAVE START COLUMN
         LA    R2,1(R2)       NEXT FIELD
         LR    R5,R2          SAVE START OF THIS FIELD
         MVI   QDELIMIT,C')'  LOOKING FOR DELIMETER = ')'
         BAL   R7,CHKDEL      GO CHECK THE DELIMETER
         CVB   R6,COUNT       CONVERT END COLUMN OFFSET TO BINARY
         LTR   R6,R6          ?/USER SPECIFY OFFSET OF ZERO
         BZ    PRESUME        YES. GO INDICATE AN ERROR
         BCTR  R6,0           DECREMENT OFFSET BY 1
         STH   R6,QOFFE       SAVE END COLUMN
         CLC   QOFFS,QOFFE    ?/ERROR IN COLUMN SPECIFICATION
         BNL   PRESUME        YES. DISREGARD COLUMN SEARCH
         B     RESUME         NO. CONTINUE WITH NORMAL PROCESSING
CHKDEL   CLC   0(1,R2),QDELIMIT ?/DELIMITER FOUND
         BE    CHK010         YES. GO PROCESS
         LA    R2,1(R2)       NO. LOOK AT NEXT FIELD
         CR    R2,R3          ?/END OF REPLY
         BH    PRESUME        YES. EXIT
         B     CHKDEL         NO. CHECK AGAIN
CHK010   LR    R4,R2          SAVE DELIMITER ADDRESS
         SR    R4,R5          LENGTH OF SUB-PARM
         CH    R4,=H'3'       ?/LENGTH TO LONG
         BNL   PRESUME        YES. DISREGARD COLUMN SEARCH
         BCTR  R4,0           LENGTH FOR EXEC INTRUCTION
         MVC   QFZONES,QFZONE  NUMERIC TEST
         EX    R4,MVZ1
         CLC   QFZONES,QFZONE ?/FIELD NUMERIC
         BNE   TILT           NO. EXIT WITH ERROR MESSAGE
         EX    R4,PACK1
         BR    R7
PRESUME  XC    QOFFS,QOFFS    DISREGARD FIND
         XC    QOFFE,QOFFE       BY COLUMN RANGE
         QTILT ' *** ERROR IN COLUMN SPECIFICATION ***'
MVZ1     MVZ   QFZONES(1),0(R5)
PACK1    PACK  COUNT,0(1,R5)
***********************************************************************
*                                                                     *
*   REPOSITION IN SYSLOG DATASET BY TIME OF DAY                       *
*                                                                     *
***********************************************************************
FINDTIME CLI   QPARM1,C' '    IS THE PARM OMITTED?
         BE    TILT           YES. TILT.
         B     RESUME         CALL LISTDS
         EJECT                                                    UF003
******************************************************************UF003
*                                                                 UF003
*   SWITCH MODEL TYPE FOR 3270 TERMINAL                           UF003
*                                                                 UF003
******************************************************************UF003
MODEL    DS    0H             ,                                   UF003
         BAL   R4,NUMERIC     VALIDATE PARAMETER                  UF003
         CP    COUNT,=P'2'    MODEL 2?                            UF003
         BE    MODEL2         YES, BRANCH                         UF003
         CP    COUNT,=P'3'    MODEL 3?                            UF003
         BE    MODEL3         YES, BRANCH                         UF003
         CP    COUNT,=P'4'    MODEL 4?                            UF003
         BE    MODEL4         YES, BRANCH                         UF003
         CP    COUNT,=P'5'    MODEL 5?                            UF003
         BE    MODEL5         YES, BRANCH                         UF003
         QTILT 'UNSUPPORTED MODEL TYPE'                           UF003
         SPACE 1                                                  UF003
MODEL2   MVC   QDLNELEN,=H'80'     LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'21'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(21*80) SCREEN LENGTH                 UF003
         MVC   QDSCRPLN,=AL2(21*80+QDLINE1-QDSCREEN) TPUT LEN     UF003
         MVI   QDSCRO1,X'F5'       ERASE/WRITE                    UF003
         MVC   QDSCRO2,=X'C150'    (2,1)                          UF003
         MVC   QDSCRO3,=X'5CF0'    (24,1)                         UF003
         MVC   QDSCRO4,=X'5DF7'    (24,72)                        UF003
         MVC   QDSCRO5,=X'C260'    (3,1)                          UF003
         STSIZE SIZE=80,LINE=24    SET SCREEN SIZE FOR VTAM       UF003
         SPACE 1                                                  UF003
MODELN   CLC   QPDSID,=H'0'        IS THERE A DATASET?            UF003
         BNE   RESUME              YES, CALL LISTDS               UF003
         MVC   QDHLINE,=CL80' '    BLANK HEADING LINE             UF003
         B     STOP                AND RETURN                     UF003
         SPACE 1                                                  UF003
MODEL3   MVC   QDLNELEN,=H'80'     LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'29'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(29*80)  SCR LENGTH                   UF003
         MVC   QDSCRPLN,=AL2(29*80+QDLINE1-QDSCREEN) TPUT LEN     UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C150'    (2,1)                          UF003
         MVC   QDSCRO3,=X'E6F0'    (32,1)                         UF003
         MVC   QDSCRO4,=X'E7F7'    (32,72)                        UF003
         MVC   QDSCRO5,=X'C260'    (3,1)                          UF003
         STSIZE SIZE=80,LINE=32    SET SCREEN SIZE FOR VTAM       UF003
         B     MODELN              JOIN COMMON CODE               UF003
         SPACE 1                                                  UF003
MODEL4   MVC   QDLNELEN,=H'80'     LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'40'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(40*80)  SCR LENGTH                   UF003
         MVC   QDSCRPLN,=AL2(40*80+QDLINE1-QDSCREEN) TPUT LEN     UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C150'    (2,1)                          UF003
         MVC   QDSCRO3,=X'F460'    (43,1)                         UF003
         MVC   QDSCRO4,=X'F5E7'    (43,72)                        UF003
         MVC   QDSCRO5,=X'C260'    (3,1)                          UF003
         STSIZE SIZE=80,LINE=43    SET SCREEN SIZE FOR VTAM       UF003
         B     MODELN              JOIN COMMON CODE               UF003
         SPACE 1                                                  UF003
MODEL5   MVC   QDLNELEN,=H'132'    LINE LENGTH                    UF003
         MVC   QDLNES,=PL2'24'     LINES PER SCREEN AREA          UF003
         MVC   QDSCRLEN,=AL2(24*132)  SCR LENGTH                  UF003
         MVC   QDSCRPLN,=AL2(24*132+QDLINE1-QDSCREEN) TPUT LEN    UF003
         MVI   QDSCRO1,X'7E'       ERASE/WRITE ALTERNATE          UF003
         MVC   QDSCRO2,=X'C2C4'    (2,1)                          UF003
         MVC   QDSCRO3,=X'F5E8'    (27,1)                         UF003
         MVC   QDSCRO4,=X'F66F'    (27,72)                        UF003
         MVC   QDSCRO5,=X'C4C8'    (3,1)                          UF003
         STSIZE SIZE=132,LINE=27   SET SCREEN SIZE FOR VTAM       UF003
         B     MODELN              JOIN COMMON CODE               UF003
         EJECT                                                    UF003
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
WORK     DSECT
         DS    CL72
COUNT    DS    D
         END
./ ADD NAME=Q19
SAVE     QSTART 'QUEUE COMMAND - CREATE A COPY OF CURRENT DATASET'
         USING QCKPT,R10      BASE REG FOR CHECKPOINT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING QDISPLAY,R9    BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL      LOAD BASE REG
         USING WORK,R13       LOCAL WORK AREA
***********************************************************************
*                                                                     *
*   ALLOCATE OUTPUT DATASET                                           *
*                                                                     *
***********************************************************************
         CLC   QPDSID,=H'0'   IS THERE A VALID DATASET?
         BE    TILT1          NO. TELL THE USER.
         MVC   DSNAME+2(44),QBLANK BLANK THE DSNAME
         MVC   DSNAME+2(8),QPARM1 FIRST PART OF DSNAME
         LA    R1,DSNAME      ADDR OF DSNAME
         ST    R1,DA08PDSN    STORE IN PARM LIST
         LH    R2,QLNG1       LENGTH OF QPARM1
         LA    R1,2(R2,R1)    OFFSET INTO DSNAME
         LH    R3,QLNG2       LENGTH OF QPARM2
         LTR   R3,R3          ?/LENGTH ZERO
         BZ    DATA           YES. USE DATA AS DEFAULT DS TYPE
         MVI   0(R1),C'.'     MOVE IN DELIMITER
         MVC   1(8,R1),QPARM2 NO. SAVE DS TYPE
         LA    R1,1(R3,R2)    LENGTH OF DSNAME
         B     DSLNGH         GO SAVE LENGTH
DATA     MVC   0(5,R1),=C'.DATA' LAST PART OF DSNAME
         LA    R1,5(R2)       LENGTH OF DSNAME
DSLNGH   STH   R1,DSNAME      STORE LENGTH OF DSNAME
         MVC   DA08DDN(72),ALCLIST REMAINDER OF PARM LIST
         LH    R3,QLNG3       LENGTH OF QPARM3 (VOLSER)           UF028
         LTR   R3,R3          WAS IT SPECIFIED?                   UF028
         BZ    DSALLOC        NO, SKIP THIS                       UF028
         MVC   DA08SER(8),QPARM3  SET VOLSER                      UF028
DSALLOC  MVI   DAIRFLAG,X'08' INDICATE ALLOC FUNCTION
         L     R15,=V(ALLOCATE) ADDR OF DAIR MODULE
         BALR  R14,R15        GO TO IT
         MVC   QCOUT+36(1),QCRECFM MOVE IN RECORD FORMAT
         NI    QCOUT+36,X'06' TURN OFF EVERTHING BUT CCTL
         OI    QCOUT+36,X'90' SPECIFY FIXED BLOCKED RECORDS
         LH    R1,QCLRECL     RECORD LENGTH
         LTR   R1,R1          IS THE LRECL ZERO?
         BNZ   RECOK          NO. SKIP.
         LA    R1,133         YES. USE LRECL 133.
RECOK    STH   R1,QCOUT+82    STORE LRECL
BIGGER   LR    R2,R1          UPDATE BLKSIZE
         AH    R1,QCOUT+82    ADD LRECL TO BLKSIZE
         CH    R1,=H'4096'    IS THE BLKSIZE GREATER THAN 4096?
         BL    BIGGER         NO. MAKE IT BIGGER.
         STH   R2,QCOUT+62    STORE BLKSIZE
         OPEN  MF=(E,QCOPEN)
***********************************************************************
*                                                                     *
*   REPOSITION DATASET TO TOP                                         *
*                                                                     *
***********************************************************************
         L     R4,QCSTART     TOP OF DATASET POINTER
         L     R4,0(R4)       DISK ADDR TOP OF DATASET
         L     R5,QCBLKA      IOAREA ADDRESS
         B     FIRST          GO DO IT
***********************************************************************
*                                                                     *
*   PROCESS DATASET                                                   *
*                                                                     *
***********************************************************************
NEXTBLK  L     R4,0(R5)       DISK ADDR OF NEXT BLOCK
FIRST    LTR   R4,R4          IS THE DISK ADDR ZERO?
         BZ    END            YES. END OF DATASET.
         BAL   R8,READ        READ A BLOCK
         CLC   QPJOBID(6),4(R5) DOES THE JOBID MATCH?
         BNE   END            NO. END OF DATASET.
         LA    R4,10(R5)      ADDR OF FIRST RECORD IN BLOCK
***********************************************************************
*                                                                     *
*   PROCESS RECORDS                                                   *
*                                                                     *
***********************************************************************
NEXTREC  CLI   0(R4),X'FF'    IS LENGTH BYTE FF?
         BE    NEXTBLK        YES. END OF BLOCK.
         TM    1(R4),X'10'    IS THIS A SPANNED RECORD?
         BO    SPAN           YES. SKIP IT.
         SR    R6,R6          ZERO OUT REG
         IC    R6,0(R4)       INSERT LENGTH
         TM    1(R4),X'80'    IS CCTL SPECIFIED?
         BZ    NOCCTL         NO. SKIP.
         LA    R6,1(R6)       INCREMENT LENGTH FOR CCTL
NOCCTL   TM    1(R4),X'08'    IS THIS RECORD TO BE IGNORED?
         BO    SKIPREC        YES. SKIP IT.
         MVI   BUFFER,C' '    BLANK FIRST BYTE OF BUFFER
         MVC   BUFFER+1(255),BUFFER BLANK THE BUFFER
         LR    R7,R6          DO NOT DESTROY R6
         SH    R7,=H'1'       IS LENGTH ZERO?
         BM    SKIPREC        YES. SKIP RECORD.
         EX    R7,MVCREC      MOVE RECORD TO BUFFER
         PUT   QCOUT,BUFFER
SKIPREC  LA    R4,3(R6,R4)    INCREMENT TO NEXT RECORD
         B     NEXTREC        PROCESS NEXT RECORD
SPAN     LH    R6,2(R4)       SEGMENT LENGTH
         TM    1(R4),X'08'    IS THIS THE FIRST SEGMENT?
         BO    SPANFRST       YES. USE LARGER HEADER SIZE.
         LA    R4,4(R6,R4)    INCREMENT TO NEXT RECORD
         B     NEXTREC        PROCESS NEXT RECORD
SPANFRST LA    R4,6(R6,R4)    INCREMENT TO NEXT RECORD
         B     NEXTREC        PROCESS NEXT RECORD
***********************************************************************
*                                                                     *
*   CLOSE UP SHOP AND GO HOME                                         *
*                                                                     *
***********************************************************************
END      CLOSE MF=(E,QCOPEN)
         MVI   DAIRFLAG,X'18' INDICATE FREE FUNCTION
         L     R15,=V(ALLOCATE) ADDR OF DAIR MODULE
         BALR  R14,R15        GO TO IT
         L     R15,=V(LISTDS) GO BACK TO LISTDS
         BALR  R14,R15        GO TO IT
         QSTOP
***********************************************************************
*                                                                     *
*   READ A BLOCK FROM HASPACE                                         *
*                                                                     *
***********************************************************************
READ     ST    R4,QCTRAK      STORE DISK ADDR
         LR    R1,R5          IOAREA ADDRESS
         L     R15,=V(READSPC) ADDR OF ROUTINE TO READ HASPACE
         BALR  R14,R15        GO TO IT
         BR    R8             RETURN TO CALLER
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
TILT1    QTILT '*** YOU ARE NOT PROCESSING A VALID DATASET ***'
         LTORG
MVCREC   MVC   BUFFER(1),3(R4)
         DS    0F
ALCLIST  DC    C'HASPSAVE',CL16' ',F'0',F'10',F'50',F'0'
         DC    CL16' ',X'040202B0',F'0',CL8' '
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
WORK     DSECT
         DS    CL80
BUFFER   DS    CL256
DSNAME   DS    H
         DS    CL44
         END
./ ADD NAME=Q2
ALLOCATE QSTART 'QUEUE COMMAND - DATASET ALLOCATION ROUTINES'
         USING QDAIR,R10      BASE REG FOR DAIR WORK
         L     R10,QVDAIR     LOAD ADDR OF DAIR WORK
         USING QCKPT,R9       BASE REG FOR CKPT WORK ARES
         L     R9,QVCKPT      LOAD ADDR
***********************************************************************
*                                                                     *
*   DETERMINE FUNCTION                                                *
*                                                                     *
***********************************************************************
         CLI   DAIRFLAG,X'08' IS THE FUNCTION ALLOCATE?
         BE    ALLOC          YES. DO IT.
         CLI   DAIRFLAG,X'18' IS THE FUNCTION FREE?
         BE    FREE           YES. DO IT.
         B     ABEND99        INVALID FUNCTION. ABANDON SHIP.
***********************************************************************
*                                                                     *
*   FREE DDNAME(XXXXXXXX)                                             *
*                                                                     *
***********************************************************************
FREE     LA    R1,DA18CD      LOAD ADDR OF FREE PARM LIST
         ST    R1,DAPLDAPB    STORE IN DAIR CALL LIST
         BAL   R2,CALLDAIR    CALL DAIR
         B     STOP           RETURN TO CALLER
***********************************************************************
*                                                                     *
*   ALLOC DDNAME(XXXXXXXX) DSNAME(YYYYYYYY) SHR                       *
*                                                                     *
***********************************************************************
ALLOC    MVC   DA18DDN,DA08DDN MOVE DDNAME TO FREE LIST
         LA    R1,DA18CD      LOAD ADDR OF FREE PARM LIST
         ST    R1,DAPLDAPB    STORE IN DAIR CALL LIST
         BAL   R2,CALLDAIR    CALL DAIR - FREE THE DDNAME
         LA    R1,DA08CD      LOAD ADDR OF ALLOC PARM LIST
         ST    R1,DAPLDAPB    STORE IN DAIR CALL LIST
         BAL   R2,CALLDAIR    CALL DAIR - ALLOCATE THE DATASET
         B     STOP           RETURN TO CALLER
***********************************************************************
*                                                                     *
*   RETURN TO CALLING ROUTINE                                         *
*                                                                     *
***********************************************************************
STOP     QSTOP
***********************************************************************
*                                                                     *
*   CALL DYNAMIC ALLOCATION INTERFACE ROUTINE (DAIR)                  *
*                                                                     *
***********************************************************************
CALLDAIR XC    DAIRECB,DAIRECB CLEAR ECB
         LA    R1,DAPLUPT     LOAD ADDR OF DAIR CALL LIST
         LINK  EP=IKJEFD00    CALL DAIR
         LTR   R15,R15        IS RETURN CODE ZERO?
         BZR   R2             YES. RETURN.
         CH    R15,=H'28'     IS DATASET ALREADY FREE?
         BER   R2             YES. RETURN.
         CLC   DA08DDN,=C'HASPSAVE' IS THIS A SAVE?
         BNE   ABEND99        NO. ABEND.
         QTILT '*** UNABLE TO ALLOCATE DATASET ***'
***********************************************************************
*                                                                     *
*   DAIR HAS FAILED. TAKE A PICTURE AND GO HOME.                      *
*                                                                     *
***********************************************************************
ABEND99  TPUT  MESSAGE,L'MESSAGE,EDIT,MF=(E,QTPUT) TELL SAD STORY  PWF*
         ABEND 99,DUMP        ABEND THE JOB. USER CODE 0099.
***********************************************************************
*                                                                     *
*   CONSTANTS AND ASSORTED GARBAGE                                    *
*                                                                     *
***********************************************************************
         LTORG
MESSAGE  DC    C'A MAJOR DISASTER HAS OCCURRED IN DAIR PROCESSING.'
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q20
SEARCH QSTART 'QUEUE COMMAND - JQE AND JOE SEARCH AND FORMAT'
*******************************************************************
* RNB CHANGES:                                                    *
*      (1) RNB16 - PROCESS BOTH LOCAL AND REMOTE JOE QUEUE.       *
*                  ALSO, FIX BUG IN UF020 THAT WAS CLEARING       *
*                  FIELD JOEFLAG IN THE WORK JOE.                 *
*      (2) RNB19 - FOR SP, SEARCH DUMP Q AND CONVERSION (XEQ) Q IF*
*                  STATUS COMMAND OR DJ. ALSO OUTPUT QUEUE        *
*******************************************************************
         GBLB  &QSP           MVS/SP OPTION                       UF020
         L     R10,QVCKPT     LOAD BASE REG
         USING JQEDSECT,R9    BASE REG FOR JQE DSECT
         USING JOEDSECT,R8    BASE REG FOR JOE DSECT
         USING WORK,R13       BASE REG FOR LOCAL WORK AREA
******************************************************************UF006
*                                                                 UF006
*   CALL - READ JES2 CHECKPOINT FILE                              UF006
*                                                                 UF006
******************************************************************UF006
         L     R15,=V(CKPT)   ADDR OF CKPT ROUTINE                UF006
         BALR  R14,R15        GO TO IT                            UF006
***********************************************************************
*                                                                     *
*   BRANCH TO PROPER ROUTINE                                          *
*                                                                     *
***********************************************************************
         LH    R1,QCODEH      LOAD FUNCTION CODE INTO R1
         CH    R1,=H'48'      IS THE FUNCTION SUPPORTED?
         BH    STOP           NO. RETURN.
         B     *+4(R1)        BRANCH TO ROUTINE
         B     ST             0 OFFSET
         B     DA             4
         B     DI             8
         B     AO   DO        12
         B     AI             16
         B     AO             20
         B     HI             24
         B     HO             28
         B     DT             32
         B     DJ             36
         B     DS             40
         B     DQ             44
         B     DF             48
***********************************************************************
*                                                                     *
*   STATUS - FIND ALL JOBS THAT MATCH LEVEL                           *
*                                                                     *
***********************************************************************
ST       CLI   QPARM1,C' '    DID USER SPECIFY LEVEL?
         BNE   ST2            NO. USE QLOGON.
         MVC   QPARM1,QLOGON  MOVE USER PARM1 TO LEVEL
ST2      BAL   R2,PARMLEN     DETERMINE PARM LENGTH
* SEARCH THE TSO QUEUE
         USING JQTDSECT,R1    BASE REG FOR JQT
DJ2      LH    R6,QLNG1       LENGTH OF COMPARE FOR LEVEL
         L     R1,QCJQHEAD    LOAD ADDR OF JQT
         LA    R4,JQTTSU      ADDR OF TSO QUEUE
         MVI   QCLASS,0       INDICATE THIS IS THE TSO QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     DJ3            END OF QUEUE
         EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?
         BNE   SKIPJQE        NO. SKIP THIS RECORD.
         B     PRTJQE         PRINT THE RECORD
* SEARCH THE SYSTEM QUEUE
DJ3      L     R1,QCJQHEAD    LOAD ADDR OF JQT
         LA    R4,JQTSTC      ADDR OF STC QUEUE
         MVI   QCLASS,4       INDICATE THIS IS THE STC QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     DJ4            END OF QUEUE
         EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?
         BNE   SKIPJQE        NO. SKIP THIS RECORD.
         B     PRTJQE         PRINT THE RECORD
* SEARCH FOR HELD OUTPUT
DJ4      L     R1,QCJQHEAD    LOAD ADDR OF JQT
         LA    R4,JQTOUT      ADDR OF $OUTPUT QUEUE
         DROP  R1
         MVI   QCLASS,8       INDICATE THIS IS THE HELD OUT QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         AIF   (&QSP).RNB19A                                      RNB19
         B     ST3            END OF QUEUE
         AGO   .RNB19B                                            RNB19
.RNB19A  ANOP                                                     RNB19
         B     DJ5            END OF QUEUE                        RNB19
.RNB19B  ANOP                                                     RNB19
         EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?
         BNE   SKIPJQE        NO. SKIP THIS RECORD.
         CLI   JQEHLDCT,0     ARE THERE ANY HELD DATASETS? (PART 1)
         BNE   PRTJQE         YES. PRINT THE RECORD.
         TM    JQEHQLOK,X'F0' ARE THERE ANY HELD DATASETS? (PART 2)
         BNZ   PRTJQE         YES. PRINT THE RECORD.
         B     REJJQE         REJECT THE RECORD
         AIF   (NOT &QSP).RNB19C                                  RNB19
* SEARCH DUMP QUEUE                                               RNB19
DJ5      L     R1,QCJQHEAD    LOAD ADDR OF JQT                    RNB19
         USING JQTDSECT,R1    BASE REG FOR JQT                    RNB19
         LA    R4,JQTDUMP     ADDR OF DUMP QUEUE                  RNB19
         DROP  R1                                                 RNB19
         MVI   QCLASS,12      INDICATE THIS IS THE DUMP QUEUE     RNB19
         BAL   R2,SRCHJQE     SEARCH THE QUEUE                    RNB19
         B     DJ6            END OF QUEUE                        RNB19
         EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?      RNB19
         BNE   SKIPJQE        NO. SKIP THIS RECORD.               RNB19
         B     PRTJQE         PRINT THE RECORD                    RNB19
* SEARCH CONVERSION (XEQ) QUEUE                                   RNB19
DJ6      L     R1,QCJQHEAD    LOAD ADDR OF JQT                    RNB19
         USING JQTDSECT,R1    BASE REG FOR JQT                    RNB19
         LA    R4,JQTXEQ      ADDR OF CONVERSION QUEUE            RNB19
         DROP  R1                                                 RNB19
         MVI   QCLASS,16      INDICATE THIS IS THE CNV QUEUE      RNB19
         BAL   R2,SRCHJQE     SEARCH THE QUEUE                    RNB19
         B     DJ7            END OF QUEUE                        RNB19
         EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?      RNB19
         BNE   SKIPJQE        NO. SKIP THIS RECORD.               RNB19
         B     PRTJQE         PRINT THE RECORD                    RNB19
* SEARCH OUTPUT (AWAITING OUTPUT) QUEUE                           RNB19
DJ7      L     R1,QCJQHEAD    LOAD ADDR OF JQT                    RNB19
         USING JQTDSECT,R1    BASE REG FOR JQT                    RNB19
         LA    R4,JQTAWOUT    ADDR OF OUTPUT QUEUE                RNB19
         DROP  R1                                                 RNB19
         MVI   QCLASS,20      INDICATE THIS IS THE CNV QUEUE      RNB19
         BAL   R2,SRCHJQE     SEARCH THE QUEUE                    RNB19
         B     ST3            END OF QUEUE                        RNB19
         EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?      RNB19
         BNE   SKIPJQE        NO. SKIP THIS RECORD.               RNB19
         B     PRTJQE         PRINT THE RECORD                    RNB19
.RNB19C  ANOP                                                     RNB19
* SEARCH INPUT QUEUES
ST3      MVI   QCLASS,192     START WITH CLASS A
ST4      BAL   R2,NEXTJQT     FIND NEXT QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     ST4            END OF QUEUE
         CLI   JQEFLAGS,0     IS THE JOB EXECUTING OR HELD?
         BNE   ST7            YES. SPECIAL HANDLING.
         EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?
         BNE   SKIPJQE        NO. SKIP THIS RECORD.
         B     PRTJQE         PRINT THE JQE
ST7      EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?
         BNE   REJJQE         NO. SKIP THIS RECORD.
         B     PRT2JQE        PRINT THE RECORD WITHOUT INCR COUNT
* SEARCH OUTPUT QUEUES
ST5      MVI   QCLASS,192     START WITH CLASS A
ST6      BAL   R2,NEXTJOT     DETERMINE NEXT QUEUE
         BAL   R2,SRCHJOE     SEARCH A JQE QUEUE
         B     ST6            END OF QUEUE
         EX    R6,STCLC       IS THE JOBNAME EQUAL TO LEVEL?
         BNE   SKIPJOE        NO. SKIP THIS RECORD.
         B     PRTJOE         PRINT THE RECORD
* COMPARE USED TO CHECK LEVEL
STCLC    CLC   QPARM1(1),JQEJNAME IS THE JOBNAME EQUAL TO LEVEL?
***********************************************************************
*                                                                     *
*   DQ - PRINT SUMMARY OF ALL JOBS IN THE INPUT QUEUES                *
*                                                                     *
***********************************************************************
*  SEARCH ALL QUEUES
DQ       MVI   QCLASS,192           START WITH CLASS A
         MVC   QDHLINE,DQHEADER     MOVE IN THE HEADING
DQ1      BAL   R2,NEXTJQT           FIND NEXT QUEUE
         ZAP   QCOUNTE,=P'0'        ZERO COUNT FOR EXECUTING JOBS
         ZAP   QCOUNTA,=P'0'        ZERO COUNT FOR AWAITING JOBS
         ZAP   QCOUNTH,=P'0'        ZERO COUNT FOR HELD JOBS
         BAL   R2,SRCHJQE           SEARCH THE QUEUE
         B     DQ4                  END OF QUEUE
         TM    JQEFLAGS,QUEBUSY     IS THIS JOB EXECUTING
         BZ    DQ2                  NO, NEXT TEST
         AP    QCOUNTE,=P'1'        YES, BUMP COUNTER
         B     SKIPJQE              PROCESS NEXT JQE
DQ2      TM    JQEFLAGS,X'E0'       IS THIS A HELD JOB
         BZ    DQ3                  NO, NEXT TEST
         AP    QCOUNTH,=P'1'        YES, BUMP COUNTER
         B     SKIPJQE              PROCESS NEXT JQE
DQ3      CLI   JQEFLAGS,0           IS THIS JOB AWAITING EXECUTION
         BNE   SKIPJQE              NO, PROCESS NEXT JQE
         AP    QCOUNTA,=P'1'        YES, BUMP COUNTER
         B     SKIPJQE              PROCESS NEXT JQE
DQ4      CLC   QCOUNT,=PL3'0'       IS THIS QUEUE EMPTY
         BE    DQ1                  YES, TRY THE NEXT QUEUE
         MVC   QDMSG,DQLINE         MOVE IN DETAIL LINE
         MVC   FCOUNT,ED5           MOVE IN
         ED    FCOUNT,QCOUNTE            NUMBER OF JOBS
         MVC   QECOUNT,FCOUNT+3                    IN EXECUTION
         MVC   FCOUNT,ED5           MOVE IN
         ED    FCOUNT,QCOUNTA            NUMBER OF JOBS
         MVC   QACOUNT,FCOUNT+3                    AWAITING EXECUTION
         MVC   FCOUNT,ED5           MOVE IN
         ED    FCOUNT,QCOUNTH            NUMBER OF JOBS
         MVC   QHCOUNT,FCOUNT+3                    IN HELD STATUS
         MVC   FCOUNT,ED5           MOVE IN THE TOTAL NUMBER OF JOBS
         ED    FCOUNT,QCOUNT             IN THIS QUEUE
         MVC   CLASS,QCLASS         MOVE IN QUEUE CLASS
         BAL   R2,DISPLAY           GO DISPLAY THIS LINE
         B     DQ1                  PROCESS THE NEXT QUEUE
***********************************************************************
*                                                                     *
*   DF - PRINT SUMMARY OF ALL JOBS IN THE OUTPUT QUEUES               *
*                                                                     *
***********************************************************************
DF       MVI   QCLASS,192           START WITH CLASS A
         MVC   QDHLINE,DFHEADER     MOVE IN THE HEADING
DF1      BAL   R2,NEXTJOT           FIND NEXT QUEUE
         ZAP   QCOUNTE,=P'0'        ZERO COUNT FOR JOBS PRINTING
         BAL   R2,SRCHJOE           SEARCH THE QUEUE
         B     DF2                  END OF QUEUE
         TM    JOEFLAG,X'20'        IS JOB PRINTING
         BNO   SKIPJOE              NO, PROCESS NEXT JOE
         AP    QCOUNTE,=P'1'        YES, BUMP COUNTER
         B     SKIPJOE              PROCESS NEXT JOE
DF2      CLC   QCOUNT,=PL3'0'       QUEUE EMPTY
         BE    DF1                  YES, TRY THE NEXT QUEUE
         MVC   QDMSG,DFLINE         MOVE IN DETAIL LINE
         MVC   FCOUNT,ED5           MOVE IN
         ED    FCOUNT,QCOUNTE            NUMBER OF JOBS
         MVC   QECOUNT,FCOUNT+3                    PRINTING
         MVC   FCOUNT,ED5           MOVE IN TOTAL NUMBER OF JOBS
         ED    FCOUNT,QCOUNT             IN THIS QUEUE
         MVC   CLASS,QCLASS         MOVE IN QUEUE CLASS
         BAL   R2,DISPLAY           GO DISPLAY THIS LINE
         B     DF1                  PROCESS NEXT QUEUE
***********************************************************************
*                                                                     *
*   DJ - FIND A SPECIFIC JOB                                          *
*                                                                     *
***********************************************************************
DJ       CLI   QPARM1,C' '    DID USER SPECIFY JOBNAME?
         BE    DJ9            NO. TILT.
         MVC   QLNG1,=H'7'    COMPARE FOR 8 CHARACTERS
         B     DJ2            USE THE STATUS ROUTINES
DJ9      QTILT '*** YOU MUST SPECIFY JOBNAME ***'
***********************************************************************
*                                                                     *
*   DI - PRINT ALL JOBS IN INPUT QUEUES                               *
*                                                                     *
***********************************************************************
DI       CLI   QPARM1,C' '    DID USER SPECIFY CLASS?
         BNE   DI5            YES. LIMIT TO ONE QUEUE.
* SEARCH ALL QUEUES
         MVI   QCLASS,192     START WITH CLASS A
DI2      BAL   R2,NEXTJQT     DETERMINE NEXT QUEUE
         BAL   R2,SRCHJQE     SEARCH A JQE QUEUE
         B     DI2            END OF QUEUE
         B     PRTJQE         PRINT THE RECORD
* SEARCH ONLY ONE QUEUE
DI5      MVC   QCLASS,QPARM1  USER SPECIFIED CLASS
         BAL   R2,FINDJQT     FIND QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     STOP           END OF QUEUE
         B     PRTJQE         PRINT THE RECORD
***********************************************************************
*                                                                     *
*   AI - PRINT JOBS IN INPUT QUEUES THAT ARE AVAILABLE FOR SELECTION  *
*                                                                     *
***********************************************************************
AI       CLI   QPARM1,C' '    DID USER SPECIFY CLASS?
         BNE   AI5            YES. LIMIT TO ONE QUEUE.
* SEARCH ALL QUEUES
         MVI   QCLASS,192     START WITH CLASS A
AI2      BAL   R2,NEXTJQT     DETERMINE NEXT QUEUE
         BAL   R2,SRCHJQE     SEARCH A JQE QUEUE
         B     AI2            END OF QUEUE
         CLI   JQEFLAGS,0     IS THE JOB BUSY OR HELD?
         BNE   REJJQE         YES. SKIP IT.
         B     PRTJQE         PRINT THE RECORD
* SEARCH ONLY ONE QUEUE
AI5      MVC   QCLASS,QPARM1  USER SPECIFIED CLASS
         BAL   R2,FINDJQT     FIND QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     STOP           END OF QUEUE
         CLI   JQEFLAGS,0     IS THE JOB BUSY OR HELD?
         BNE   REJJQE         YES. SKIP IT.
         B     PRTJQE         PRINT THE RECORD
***********************************************************************
*                                                                     *
*   AO - PRINT AVAILABLE JOBS IN THE OUTPUT QUEUE                     *
*                                                                     *
***********************************************************************
AO       CLI   QPARM1,C' '    DID USER SPECIFY CLASS?
         BNE   AO5            YES. LIMIT TO ONE QUEUE.
* SEARCH ALL QUEUES
         MVI   QCLASS,192     START WITH CLASS A
AO2      BAL   R2,NEXTJOT     DETERMINE NEXT QUEUE
         BAL   R2,SRCHJOE     SEARCH A JQE QUEUE
         B     AO2            END OF QUEUE
         B     PRTJOE         PRINT THE RECORD
* SEARCH ONLY ONE QUEUE
AO5      MVC   QCLASS,QPARM1  USER SPECIFIED CLASS
         BAL   R2,FINDJOT     FIND QUEUE
         BAL   R2,SRCHJOE     SEARCH THE QUEUE
         B     STOP           END OF QUEUE
         B     PRTJOE         PRINT THE RECORD
***********************************************************************
*                                                                     *
*   HI - PRINT JOBS IN INPUT QUEUES THAT ARE HELD                     *
*                                                                     *
***********************************************************************
HI       CLI   QPARM1,C' '    DID USER SPECIFY CLASS?
         BNE   HI5            YES. LIMIT TO ONE QUEUE.
* SEARCH ALL QUEUES
         MVI   QCLASS,192     START WITH CLASS A
HI2      BAL   R2,NEXTJQT     DETERMINE NEXT QUEUE
         BAL   R2,SRCHJQE     SEARCH A JQE QUEUE
         B     HI2            END OF QUEUE
         TM    JQEFLAGS,X'E0' IS THE JOB HELD?
         BZ    REJJQE         NO. SKIP IT.
         B     PRTJQE         PRINT THE RECORD
* SEARCH ONLY ONE QUEUE
HI5      MVC   QCLASS,QPARM1  USER SPECIFIED CLASS
         BAL   R2,FINDJQT     FIND QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     STOP           END OF QUEUE
         TM    JQEFLAGS,X'E0' IS THE JOB HELD?
         BZ    REJJQE         NO. SKIP IT.
         B     PRTJQE         PRINT THE RECORD
***********************************************************************
*                                                                     *
*   HO - LIST ALL JOBS WITH HELD OUTPUT                               *
*                                                                     *
***********************************************************************
         USING JQTDSECT,R1    BASE REG FOR JQT
HO       L     R1,QCJQHEAD    LOAD ADDR OF JQT
         LA    R4,JQTOUT      ADDR OF $OUTPUT QUEUE
         DROP  R1
         MVI   QCLASS,8       INDICATE THIS IS THE HELD OUT QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     STOP           END OF QUEUE
         CLI   JQEHLDCT,0     ARE THERE ANY HELD DATASETS? (PART 1)
         BNE   PRTJQE         YES. PRINT THE RECORD.
         TM    JQEHQLOK,X'F0' ARE THERE ANY HELD DATASETS? (PART 2)
         BNZ   PRTJQE         YES. PRINT THE RECORD.
         B     REJJQE         REJECT THE RECORD
***********************************************************************
*                                                                     *
*   DA - FIND ALL EXECUTING JOBS                                      *
*                                                                     *
***********************************************************************
DA       MVI   QCLASS,192     START WITH CLASS A
DA2      BAL   R2,NEXTJQT     DETERMINE NEXT QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     DA2            END OF QUEUE
         TM    JQEFLAGS,QUEBUSY IS THE JOB EXECUTING?
         BZ    REJJQE         NO. REJECT IT.
         B     PRTJQE         PRINT THE RECORD
***********************************************************************
*                                                                     *
*   DT - LIST ALL TSO USERS                                           *
*                                                                     *
***********************************************************************
         USING JQTDSECT,R1    BASE REG FOR JQT
DT       L     R1,QCJQHEAD    LOAD ADDR OF JQT
         LA    R4,JQTTSU      ADDR OF TSO QUEUE
         DROP  R1
         MVI   QCLASS,0       INDICATE THIS IS THE TSO QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     STOP           END OF QUEUE
         B     PRTJQE         PRINT THE RECORD
***********************************************************************
*                                                                     *
*   DS - LIST ALL SYSTEM STARTED TASKS                                *
*                                                                     *
***********************************************************************
         USING JQTDSECT,R1    BASE REG FOR JQT
DS       L     R1,QCJQHEAD    LOAD ADDR OF JQT
         LA    R4,JQTSTC      ADDR OF STC QUEUE
         DROP  R1
         MVI   QCLASS,4       INDICATE THIS IS THE STC QUEUE
         BAL   R2,SRCHJQE     SEARCH THE QUEUE
         B     STOP           END OF QUEUE
         B     PRTJQE         PRINT THE RECORD
***********************************************************************
*                                                                     *
*   DETERMINE LENGTH OF LEVEL                                         *
*                                                                     *
***********************************************************************
PARMLEN  LA    R3,7           MAXIMUM LENGTH OF 8
         LA    R4,QPARM1+7    END OF FIELD
PARMLEN2 CLI   0(R4),C' '     IS THIS BYTE BLANK?
         BNE   PARMLEN3       NO. THIS IS THE LENGTH
         BCTR  R4,0           TRY PREVIOUS BYTE
         BCT   R3,PARMLEN2    LOOP
PARMLEN3 STH   R3,QLNG1       STORE THE LENGTH OF LEVEL
         BR    R2             RETURN TO CALLER
***********************************************************************
*                                                                     *
*   SEARCH A JQE QUEUE                                                *
*                                                                     *
***********************************************************************
SRCHJQE  ZAP   QCOUNT,=P'0'   ZERO THE QUEUE COUNT
         AIF   (&QSP).QSP3                                        UF020
         LH    R9,0(R4)       LOAD FIRST JQE OFFSET
         N     R9,=X'0000FFFF' KILL EXTRANEOUS BITS
NEXTJQE  SLA   R9,2           MULTIPLY BY 4
         AGO   .QSP4                                              UF020
.QSP3    ANOP                                                     UF020
         L     R9,0(R4)       LOAD FIRST JQE OFFSET               UF020
NEXTJQE  LA    R9,0(,R9)      KILL EXTRANEOUS BITS                UF020
         LTR   R9,R9          TEST FOR END OF QUEUE               UF020
.QSP4    ANOP                                                     UF020
         BZR   R2             END OF QUEUE. RETURN.
         A     R9,QCJQTA      ADD BASE TO OFFSET
         B     4(R2)          DETERMINE ELIGIBILITY
PRTJQE   AP    QCOUNT,=P'1'   INCREMENT COUNT
PRT2JQE  SR    R1,R1          INDICATE THIS IS A JQE
         L     R15,=V(FORMAT) ADDR OF PRINT MODULE
         BALR  R14,R15        PRINT THE JQE IN R9
         AIF   (&QSP).QSP5                                        UF020
REJJQE   LH    R9,JQECHAIN    LOAD OFFSET TO NEXT JQE
         AGO   .QSP6                                              UF020
.QSP5    ANOP                                                     UF020
REJJQE   L     R9,JQENEXT     LOAD OFFSET TO NEXT JQE             UF020
.QSP6    ANOP                                                     UF020
         B     NEXTJQE        GET THE NEXT JQE
SKIPJQE  AP    QCOUNT,=P'1'   INCREMENT COUNT
         B     REJJQE         CONTINUE
***********************************************************************
*                                                                     *
*   SEARCH A JOE QUEUE                                                *
*                                                                     *
***********************************************************************
         AIF   (&QSP).QSP7                                        RNB16
SRCHJOE  ZAP   QCOUNT,=P'0'   ZERO THE QUEUE COUNT
FIRSTJOE LH    R8,0(R4)       LOAD FIRST JOE OFFSET
         N     R8,=X'0000FFFF' KILL EXTRANEOUS BITS.
         AGO   .QSP8                                              UF020
.QSP7    ANOP                                                     UF020
SRCHJOE  ZAP   QCOUNT,=P'0'    ZERO THE QUEUE COUNT               RNB16
         OI    QFLAG1,QFLG1LCL SHOW SEARCHING LOCAL QUEUE         RNB16
         B     FIRSTJOE        AND GO DO IT                       RNB16
*                                                                 RNB16
SRCHJOE1 NI    QFLAG1,X'FF'-QFLG1LCL TURN OFF LOCAL QUEUE FLAG    RNB16
         LA    R4,4(,R4)             POINT TO REMOTE QUEUE        RNB16
*                                                                 RNB16
FIRSTJOE L     R8,0(R4)       LOAD FIRST JOE OFFSET               UF020
         LA    R8,0(,R8)       KILL EXTRANEOUS BITS.              UF020
.QSP8    ANOP                                                     UF020
         LTR   R8,R8          IS THE QUEUE EMPTY?
         AIF   (&QSP).QSP8A                                       RNB16
         BZR   R2             YES. RETURN TO CALLER.
         AGO   .QSP8B                                             RNB16
.QSP8A   BNZ   $1             /NO  - CONTINUE                     RNB16
*                             /YES -                              RNB16
         TM    QFLAG1,QFLG1LCL WAS THIS THE LOCAL QUEUE?          RNB16
         BO    SRCHJOE1       /YES - GO DO REMOTE QUEUE           RNB16
         BR    R2             /NO  - RETURN TO CALLER             RNB16
$1       EQU   *                                                  RNB16
.QSP8B   ANOP                                                     RNB16
         XC    PRIORITY(12),PRIORITY ZERO OUT HIGHEST POINTERS
         AIF   (&QSP).QSP9                                        UF020
NEXTJOE  SLA   R8,2           MULTIPLY BY 4
         AGO   .QSP10                                             UF020
.QSP9    ANOP                                                     UF020
NEXTJOE  LA    R8,0(,R8)      CLEAR EXTRA BITS                    UF020
         LTR   R8,R8          TEST FOR END OF QUEUE               UF020
.QSP10   ANOP                                                     UF020
         BZ    TESTJOE        END OF QUEUE. PASS HIGHEST TO CALLER.
         A     R8,QCJOTA      ADD BASE TO OFFSET
         AIF   (&QSP).QSP11                                       UF020
         LH    R9,JOEJQE      OFFSET TO JQE
         SLA   R9,2           MULTIPLY BY 4
         AGO   .QSP12                                             UF020
.QSP11   ANOP                                                     UF020
         L     R9,JOEJQE      OFFSET TO JQE                       UF020
         N     R9,=A(X'00FFFFFF')  CLEAR EXTRA BITS               UF020
.QSP12   ANOP                                                     UF020
         BZ    TRYJOE         THIS JOE ALREADY USED. TRY NEXT ONE.
         A     R9,QCJQTA      ADD BASE TO OFFSET
         LA    R7,255         PRESET MAXIMUM PRIORITY
         TM    JQEPRIO,240    IS THIS JOB PRIORITY 15?
         BO    HIGHJOE        YES. PASS TO CALLER.
         LA    R1,16          PRESET PRIORITY ONE
         CLI   JQETYPE,$HARDCPY IS THE JOB EXECUTING?
         BNE   EXECJOE        YES. USE PRIORITY ONE.
         IC    R1,JQEPRIO     INSERT JQE PRIORITY
EXECJOE  IC    R7,JOEPRIO     INSERT JOE PRIORITY
         AR    R7,R1          ADD PRIORITIES
         SRL   R7,1           BECAUSE HASP DOES IT, THAT'S WHY
HIGHJOE  C     R7,PRIORITY    IS THIS LESS THAN PREVIOUS HIGH?
         BL    TRYJOE         YES. TRY NEXT ONE.
         STM   R7,R9,PRIORITY NO. REPLACE PREVIOUS HIGH.
         AIF   (&QSP).QSP11A                                      UF020
TRYJOE   LH    R8,JOENEXT     ADDR OF NEXT JOE
         AGO   .QSP12A                                            UF020
.QSP11A  ANOP                                                     UF020
TRYJOE   L     R8,JOENEXT     ADDR OF NEXT JOE                    UF020
         N     R8,=A(X'00FFFFFF')  CLEAR EXTRA BITS               UF020
.QSP12A  ANOP                                                     UF020
         B     NEXTJOE        TRY NEXT JOE
TESTJOE  LM    R7,R9,PRIORITY LOAD ADDR OF HIGHEST JOE
         LTR   R8,R8          WAS THE QUEUE EMPTY?
         AIF   (&QSP).QSP12B                                      RNB16
         BZR   R2             YES. END OF QUEUE.
         MVC   JOEJQE,=F'0'   INDICATE THIS JOE USED              VBA01
         AGO   .QSP12C                                            RNB16
.QSP12B  ANOP                                                     RNB16
         BNZ   $2                                                 RNB16
         TM    QFLAG1,QFLG1LCL WAS THIS THE LOCAL QUEUE?          RNB16
         BO    SRCHJOE1       /YES - GO DO REMOTE QUEUE           RNB16
         BR    R2             /NO  - END OF QUEUE.                RNB16
$2       EQU   *                                                  RNB16
         MVC   JOEJQEB,=F'0'  INDICATE THIS JOE USED        VBA01 RNB16
.QSP12C  ANOP                                                     RNB16
*        MVC   JOEJQEB,=F'0'  INDICATE THIS JOE USED        VBA01 RNB16
*        MVC   JOEJQE,=F'0'   INDICATE THIS JOE USED        CBT1  UF020
         B     4(R2)          DETERMINE ELIGIBILITY
PRTJOE   LA    R1,4           INDICATE THIS IS A JOE
         AP    QCOUNT,=P'1'   INCREMENT COUNT
         L     R15,=V(FORMAT) ADDR OF PRINT MODULE
         BALR  R14,R15        PRINT THE JOE IN R9
REJJOE   B     FIRSTJOE       GET THE NEXT JOE
SKIPJOE  AP    QCOUNT,=P'1'   INCREMENT COUNT
         B     REJJOE         CONTINUE
***********************************************************************
*                                                                     *
*   DETERMINE INPUT QUEUE                                             *
*                                                                     *
***********************************************************************
FINDJQT  TR    QCLASS,CLASSTBL DETERMINE OFFSET
         LH    R4,QCLASSH     LOAD TABLE OFFSET
         BCTR  R4,0           SUBTRACT 1
         STH   R4,QCLASSH     RESTORE VALUE
         B     NEXTJQT2       CONTINUE
NEXTJQT  TR    QCLASS,CLASSTBL DETERMINE OFFSET FROM FIRST CLASS
         LH    R4,QCLASSH     LOAD TABLE OFFSET
         CH    R4,=H'36'      IS THIS THE LAST QUEUE?
         BNL   NEXTJQT9       YES. GO HOME.
NEXTJQT2 TR    QCLASS,NAMETBL MOVE CLASS NAME TO QCLASS
         AR    R4,R4          MULTIPLY BY 2
         AIF   (NOT &QSP).QSP13                                   UF020
         AR    R4,R4          AND BY 2 AGAIN                      UF020
.QSP13   ANOP                                                     UF020
         USING JQTDSECT,R1    BASE REG FOR JQT
         L     R1,QCJQHEAD    LOAD ADDR OF JQT
         LA    R4,JQTCLSA(R4) NEXT QUEUE
         DROP  R1
         BR    R2             RETURN TO CALLER
NEXTJQT9 CLI   QCODE,0        IS THIS A STATUS REQUEST?
         BE    ST5            YES. GO TO STATUS.
         CLI   QCODE,36       IS THIS A DJ REQUEST?
         BNE   STOP           NO. GO HOME.
         B     ST5            YES. GO TO STATUS.
***********************************************************************
*                                                                     *
*   DETERMINE OUTPUT QUEUE                                            *
*                                                                     *
***********************************************************************
FINDJOT  TR    QCLASS,CLASSTBL DETERMINE OFFSET
         LH    R4,QCLASSH     LOAD TABLE OFFSET
         BCTR  R4,0           SUBTRACT 1
         STH   R4,QCLASSH     RESTORE VALUE
         B     NEXTJOT2       CONTINUE
NEXTJOT  TR    QCLASS,CLASSTBL DETERMINE OFFSET FROM FIRST CLASS
         LH    R4,QCLASSH     LOAD TABLE OFFSET
         CH    R4,=H'36'      IS THIS THE LAST QUEUE?
         BNL   STOP           YES. GO HOME.
NEXTJOT2 TR    QCLASS,NAMETBL MOVE CLASS NAME TO QCLASS
         AR    R4,R4          MULTIPLY BY 2
         AIF   (NOT &QSP).QSP14                                   UF020
         SLL   R4,2           AND THEN BY 4 (WILL ONLY GET LOCALS)UF020
.QSP14   ANOP                                                     UF020
         USING JOTDSECT,R1    BASE REG FOR JOT
         L     R1,QCJOTA      LOAD ADDR OF JOT
         LA    R4,JOTCLSQ(R4) NEXT QUEUE
         DROP  R1
         BR    R2             RETURN TO CALLER
***********************************************************************
*                                                                     *
*   CALL DISPLAY ROUTINE                                              *
*                                                                     *
***********************************************************************
DISPLAY  LA    R1,QDMSG             SAVE ADDRESS
         ST    R1,QDMSGA                 OF THE MESSAGE
         MVC   QDMLNG,=H'80'        SET THE LENGTH
         L     R15,=V(DISPLAY)      BRANCH TO
         BALR  R14,R15                     DISPLAY
         BR    R2                   RETURN TO CALLER
***********************************************************************
*                                                                     *
*   GO HOME                                                           *
*                                                                     *
***********************************************************************
STOP     QSTOP
         LTORG
***********************************************************************
*                                                                     *
*   TABLES FOR CLASS DETERMINATION                                    *
*                                                                     *
***********************************************************************
NAMETBL  DC    C'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'
CLASSTBL DC    192X'01'
         DC    X'00010203040506070809',7X'00'
         DC    X'0A0B0C0D0E0F101112',8X'00'
         DC    X'131415161718191A',6X'00'
         DC    X'1B1C1D1E1F2021222324',6X'00'
***********************************************************************
*                                                                     *
*   MISCELLANEOUS GARBAGE                                             *
*                                                                     *
***********************************************************************
ED5      DC    X'402020202120'
DQHEADER DC    CL80'*** INPUT QUEUES ***'
DQLINE   DC    CL80' INPUT                        EXECUTING      WAITINX
               G      HELD'
DFHEADER DC    CL80'*** OUTPUT QUEUES ***'
DFLINE   DC    CL80' OUTPUT                       PRINTING'
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
SEARCH   CSECT ,                                                  UF023
         SPACE 1                                                  UF001
$MAXNODE EQU   99             FOR NJE $JOT EXPANSION              UF001
         SPACE 1                                                  UF001
         $JQE
         AIF   (NOT &QSP).NOEQU
JQEHQLOK EQU   JQEJBLOK       NEW LABEL FOR OLD FIELD             UF020
.NOEQU   ANOP
         $JOE
         $JOT
         $JQT
WORK     DSECT
         DS    CL80
PRIORITY DS    3F
         QCOMMON
         ORG   QDMSG
         DS    CL9
CLASS    DS    CL1
         DS    CL2
QTCOUNT  DS    CL6
         DS    CL7
QECOUNT  DS    CL3
         DS    CL12
QACOUNT  DS    CL3
         DS    CL10
QHCOUNT  DS    CL3
         ORG   QTCOUNT
FCOUNT   DS    CL6
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q21
SYSLOG   QSTART 'QUEUE COMMAND - PRINT THE SYSTEM LOG DATASET'
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING WORK,R13       BASE REG FOR TEMP WORK
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   CHECK JOBNAME EQUAL SYSLOG                                        *
*                                                                     *
***********************************************************************
         L     R9,QCJCTA      ADDR OF IOAREA FOR JCT
         USING JCTSTART,R9    BASE REG FOR JCT
         CLC   JCTJNAME,=CL8'SYSLOG' IS THIS SYSLOG?
         BNE   TILT           NO. TILT.
***********************************************************************
*                                                                     *
*   DETERMINE NUMBER OF DATASETS FROM CURRENT DATASET                 *
*                                                                     *
***********************************************************************
         LH    R3,JCTPDDBK    HIGHEST DATASET ID NUMBER
         LH    R2,QLNG2       LENGTH OF BACKUP PARM
         SH    R2,=H'1'       IS THE BACKUP PARM ZERO LENGTH?
         BM    CALLLIST       YES. SKIP.
         CLI   QPARM2,C'-'    IS THERE A MINUS SIGN?
         BNE   PLUS           NO. SKIP.
         MVI   QPARM2,C'0'    CHANGE MINUS TO ZERO
PLUS     MVC   QFZONES,QFZONE INITIALIZE NUMERIC TEST
         EX    R2,MVZ         MOVE THE ZONES FOR VALIDITY CHECK
         CLC   QFZONES,QFZONE IS THE FIELD NUMERIC?
         BNE   TILT           NO. QUIT.
         EX    R2,PACK        PACK THE FIELD
         CVB   R2,CONVERT     CONVERT TO BINARY
         SR    R3,R2          BACK UP NUMBER OF DATASETS
         CH    R3,=H'101'     IS THE NUMBER LESS THAN 101?
         BL    TILT           YES. TILT.
***********************************************************************
*                                                                     *
*   CALL LISTDS TO LIST THE DATASET                                   *
*                                                                     *
***********************************************************************
CALLLIST STH   R3,QPDSID      STORE DATASET ID
         MVC   QPOFFSET,=H'0' PRINT OFFSET ZERO
         L     R15,=V(LISTDS) ADDR OF LISTDS MODULE
         BALR  R14,R15        GO TO IT
         QSTOP
TILT     QTILT '*** INVALID PARAMETER ***'
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
MVZ      MVZ   QFZONES(1),QPARM2 CHECK FOR NUMERIC
PACK     PACK  CONVERT,QPARM2(1) CONVERT TO BINARY
         LTORG
         DROP  ,                   DROP ALL ADDRESSING            NERDC
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
SYSLOG   CSECT ,                                                  UF023
JCT      EQU   0
BUFSTART EQU   0
BUFDSECT EQU   0
         $JCT
WORK     DSECT
         DS    72C
CONVERT  DS    D
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q22
XDS      QSTART 'QUEUE COMMAND - PRINT A DATASET FROM SPOOL BY ID'
***********************************************************************
* RNB CHANGES:                                                        *
*      (1) RNB03 - RACF SUPPORT. HANDLE XDS COMMAND SPECIALLY.        *
*                                                                     *
***********************************************************************
         GBLB  &QRACF                                             RNB03
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING WORK,R13       BASE REG FOR TEMP WORK
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
         AIF   (NOT &QRACF).RNB03B                                RNB03
***************************************************************** RNB03
*                                                               * RNB03
*  RACF FOR XDS COMMAND: RACHECK FOR APPL-QUEUEXDS AND PASS     * RNB03
*                        THE JOBNAME AS THE APPL FOR LOGGING    * RNB03
*                                                               * RNB03
***************************************************************** RNB03
         L     R2,QCJCTA      GET JCT                             RNB03
         USING JCTDSECT,R2    #####                               RNB03
         RACHECK ENTITY=QRACNMXD,APPL=JCTJNAME,MF=(E,QRACHECK)    RNB03
         LTR   R15,R15        OK?                                 RNB03
         BZ    RNB03A         /YES - CONTINUE                     RNB03
         QTILT '*** XDS COMMAND NOT ALLOWED ***'                  RNB03
         DROP  R2                                                 RNB03
RNB03A   DS    0H                                                 RNB03
.RNB03B  ANOP                                                     RNB03
***********************************************************************
*                                                                     *
*   CHECK AND CONVERT THE DATASET ID NUMBER                           *
*                                                                     *
***********************************************************************
         LH    R2,QLNG2       LENGTH OF DATASET ID FIELD
         SH    R2,=H'1'       IS THE DATASET ID FIELD ZERO LENGTH?
         BM    TILT           YES. QUIT.
         MVC   QFZONES,QFZONE INITIALIZE NUMERIC TEST
         EX    R2,MVZ         MOVE THE ZONES FOR VALIDITY CHECK
         CLC   QFZONES,QFZONE IS THE FIELD NUMERIC?
         BNE   TILT           NO. QUIT.
         EX    R2,PACK        PACK THE FIELD
         CVB   R2,CONVERT     CONVERT TO BINARY
         STH   R2,QPDSID      STORE DATASET ID
***********************************************************************
*                                                                     *
*   CHECK AND CONVERT THE PRINT OFFSET                                *
*                                                                     *
***********************************************************************
         MVC   QPOFFSET,=H'0' DEFAULT TO ZERO
         LH    R2,QLNG3       LENGTH OF OFFSET FIELD
         SH    R2,=H'1'       IS THE OFFSET FIELD ZERO LENGTH?
         BM    CALLLIST       YES. USE ZERO OFFSET.
         MVC   QFZONES,QFZONE INITIALIZE NUMERIC TEST
         EX    R2,MVZ2        MOVE THE ZONES FOR VALIDITY CHECK
         CLC   QFZONES,QFZONE IS THE FIELD NUMERIC?
         BNE   TILT           NO. QUIT.
         EX    R2,PACK2       PACK THE FIELD
         CVB   R2,CONVERT     CONVERT TO BINARY
         STH   R2,QPOFFSET    STORE OFFSET
***********************************************************************
*                                                                     *
*   CALL LISTDS TO LIST THE DATASET                                   *
*                                                                     *
***********************************************************************
CALLLIST L     R15,=V(LISTDS) ADDR OF LISTDS MODULE
         BALR  R14,R15        GO TO IT
         QSTOP
TILT     QTILT '*** DATASET ID INVALID ***'
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
MVZ      MVZ   QFZONES(1),QPARM2 CHECK FOR NUMERIC
MVZ2     MVZ   QFZONES(1),QPARM3 CHECK FOR NUMERIC
PACK     PACK  CONVERT,QPARM2(1) CONVERT TO BINARY
PACK2    PACK  CONVERT,QPARM3(1) CONVERT TO BINARY
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
WORK     DSECT
         DS    72C
CONVERT  DS    D
         AIF   (NOT &QRACF).RNB03C                                RNB03
XDS      CSECT                                                    RNB03
JCT      EQU   0                                                  RNB03
BUFSTART EQU   0                                                  RNB03
BUFDSECT EQU   0                                                  RNB03
         $JCT                                                     RNB03
.RNB03C  ANOP                                                     RNB03
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q23
INITS    QSTART 'QUEUE COMMAND - LIST INITIATORS COMMAND'
         USING QCKPT,R9       BASE REG FOR CHECKPOINT AREA
         L     R9,QVCKPT      LOAD BASE REG
         USING WORK,R13       BASE REG FOR LOCAL WORK AREA
******************************************************************UF006
*                                                                 UF006
*   CALL - READ JES2 CHECKPOINT ROUTINE                           UF006
*                                                                 UF006
******************************************************************UF006
CALLCKPT L     R15,=V(CKPT)   ADDR OF CKPT ROUTINE                UF006
         BALR  R14,R15        GO TO IT                            UF006
         L     R8,16          POINT TO CVT
         USING CVTDSECT,R8
***********************************************************************
*                                                                     *
*        FIND THE ACTIVE MAIN SUBSYSTEM SSVT                          *
*                                                                     *
***********************************************************************
         L     R8,CVTJESCT    POINT TO JESCT
         DROP  R8
         USING JESCT,R8
         L     R8,JESSSCT     POINT TO SSCT
         DROP  R8
         USING SSCT,R8
         L     R8,SSCTSSVT    POINT TO SSVT
         DROP  R8
         USING SSVT,R8
***********************************************************************
*                                                                     *
*        FIND THE ACTIVE MAIN SUBSYSTEM'S PITS                        *
*                                                                     *
***********************************************************************
         L     R7,$SVPIT      POINT TO PITTABLE
         LTR   R6,R7          TEST IF ANY PITS
         BZ    NOPITS         NO, IGNORE COMMAND
         BCTR  R6,0           SUBTRACT ONE
         BCTR  R6,0           SUBTRACT ONE
         SR    R0,R0          ZERO FOR INSERT
         IC    R0,0(,R6)      INSERT NUMBER OF CLASSES
         LR    R6,R0          COPY THE COUNT
         IC    R6,$SVMAXCL    NUMBER OF CLASSES AFTER OZ35996     UF027
         USING PITDSECT,R7
         MVC   QDHLINE,INITHD MOVE IN THE HEADING
***********************************************************************
*                                                                     *
*        BUILD THE MESSAGE(S) DESCRIBING THE PITS                     *
*                                                                     *
***********************************************************************
BLDMSG   MVC   QDMSG,QBLANK   BLANK THE AREA
         MVC   INIT#(2),PITPATID MOVE IN PIT ID
         LR    R1,R6          COPY THE LENGTH
         BCTR  R1,0           SUBTRACT ONE
         EX    R1,MVCLAS      MOVE THE CLASSES
         TM    PITSTAT,PITHOLDA+PITHOLD1 TEST FOR DRAINED
         BNZ   HOLDPIT        YES
         TM    PITSTAT,PITHALTA+PITHALT1 TEST FOR HALTED
         BNZ   HALTPIT        YES
         MVC   STATUS,=CL8'ACTIVE'
         TM    PITSTAT,PITBUSY TEST FOR BUSY
         BO    ACTPIT         YES
         MVC   STATUS,=CL8'INACTIVE'
         B     NEXTPIT        END OF MESSAGE LINE.
MVCLAS   MVC   CLASSES(0),PITCLASS SET THE CLASSES
HOLDPIT  MVC   STATUS,=CL8'DRAINED' SET STATUS
         TM    PITSTAT,PITBUSY TEST FOR BUSY
         BZ    NEXTPIT        NO
         MVC   STATUS+5(3),=C'ING' SET STATUS
         B     ACTPIT         YES
HALTPIT  MVC   STATUS,=CL8'HALTED' SET STATUS
         TM    PITSTAT,PITBUSY TEST FOR BUSY
         BZ    NEXTPIT        NO
         MVC   STATUS+4(3),=C'ING' SET STATUS
ACTPIT   L     R5,PITSJB      POINT TO THE SJB
         USING SJBDSECT,R5
         L     R1,SJBJQOFF    POINT TO JOB QUEUE OFFSET
         A     R1,QCJQTA      POINT TO THE JQE
         USING JQEDSECT,R1
         CLC   JQEJNAME,SJBJOBNM TEST FOR RIGHT JOB
         BNE   NEXTPIT        RIGHT JOB, GOOD
         MVC   JOBNAME,SJBJOBNM MOVE IN JOBNAME
         LH    R0,JQEJOBNO    LOAD JOB NUMBER
         CVD   R0,CONVERT     GET THE DECIMAL VALUE
         MVC   JOBNUM,ED5     GET THE CHARACTER VALUE
         ED    JOBNUM,CONVERT+5 GET THE CHARACTER VALUE
***********************************************************************
*                                                                     *
*        SEND THE MESSAGE DESCRIBING THE PIT                          *
*                                                                     *
***********************************************************************
NEXTPIT  L     R7,PITNEXT     POINT TO NEXT PIT
         DROP  R1,R5
         MVC   QDMLNG,=H'80'  SET THE LENGTH
         LA    R0,QDMSG       GET THE ADDRESS
         ST    R0,QDMSGA      SET THE ADDRESS
         L     R15,=V(DISPLAY) POINT TO THE ROUTINE
         BALR  R14,R15        CALL THE ROUTINE
         LTR   R7,R7          TEST FOR NEXT PIT
         BNZ   BLDMSG         YES, GO DO IT
***********************************************************************
*                                                                     *
*        END IT ALL                                                   *
*                                                                     *
***********************************************************************
END      QSTOP
NOPITS   QTILT '***** NO PITS  TO DISPLAY *****'
INITHD   DC    CL80'INIT    STATUS   JOBNAME    NUMBER    CLASSES'
ED5      DC    X'402020202120'
         LTORG
***********************************************************************
*                                                                     *
*        DESCRIBE ALL THE DSECTS NEEDED BY THIS MODULE                *
*                                                                     *
***********************************************************************
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
INITS    CSECT ,                                                  UF023
         $CVT
         $JESCT
         $SSCT
         $SVT
         $PIT
         $DEB                                                     UF021
         $SJB
         $JQE
         QCOMMON
         ORG   QDMSG
         DS    C
INIT#    DS    CL2
         DS    CL4
STATUS   DS    CL8
         DS    CL2
JOBNAME  DS    CL8
         DS    CL3
JOBNUM   DS    CL6
         DS    CL4
CLASSES  DS    C
WORK     DSECT
         DS    CL72
CONVERT  DS    D
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q24
ACTIVE   QSTART 'QUEUE COMMAND - LIST ACTIVE JOB STATUS'
******************************************************************
* RNB CHANGES:                                                   *
*       (1) RNB07 - WHEN LISTING BATCH JOBS, SAY THEY            *
*                   ARE ON THE XEQ QUEUE INSTEAD OF INPUT QUEUE. *
*       (1) RNB26 - BUG FIX TO STOP LISTING A LOT OF STRANGE JOBS*
******************************************************************
         GBLB  &QSP           MVS/SP OPTION                       UF020
         USING QCKPT,R9       BASE REG FOR CHECKPOINT AREA
         L     R9,QVCKPT      LOAD BASE REG
         USING WORK,R13       BASE REG FOR LOCAL WORK AREA
******************************************************************UF006
*                                                                 UF006
*   CALL - READ JES2 CHECKPOINT ROUTINE                           UF006
*                                                                 UF006
******************************************************************UF006
CALLCKPT L     R15,=V(CKPT)   ADDR OF CKPT ROUTINE                UF006
         BALR  R14,R15        GO TO IT                            UF006
         L     R8,16          POINT TO CVT
         USING CVTDSECT,R8
***********************************************************************
*                                                                     *
*        FIND THE ACTIVE MAIN SUBSYSTEM SSVT                          *
*                                                                     *
***********************************************************************
         L     R7,CVTASVT     POINT TO ASVT
         L     R2,CVTMSER     POINT TO ASVT
         USING ASVT,R7
         L     R7,ASVTMAXU    LOAD THE MAX ASCBS
         DROP  R7
         L     R8,CVTJESCT    POINT TO JESCT
         DROP  R8
         USING JESCT,R8
         L     R8,JESSSCT     POINT TO SSCT
         DROP  R8
         USING SSCT,R8
         L     R8,SSCTSSVT    POINT TO SSVT
         DROP  R8
         USING SSVT,R8
***********************************************************************
*                                                                     *
*        FIND THE ACTIVE MAIN SUBSYSTEM'S HAVT                        *
*                                                                     *
***********************************************************************
         L     R6,$SVHAVT     POINT TO HAVT
         LTR   R6,R6          TEST IF ANY PITS
         BZ    NOHAVT         NO, IGNORE COMMAND
         LA    R6,4(,R6)      POINT TO FIRST SJB POINTER
         USING SJBDSECT,R5
         MVC   QDHLINE,INITHD MOVE IN THE HEADING
***********************************************************************
*                                                                     *
*        BUILD THE MESSAGE(S) DESCRIBING THE JOBS                     *
*                                                                     *
***********************************************************************
BLDMSG   MVC   QDMSG,QBLANK   BLANK THE AREA
         L     R5,0(,R6)      POINT TO SJB
         LTR   R5,R5          TEST FOR ANY
         BZ    NEXTSJB
         L     R4,SJBSJB      TEST FOR BATCH JOB
         LTR   R4,R4          IS IT
         BNZ   BATCHCHK
         L     R3,SJBJQOFF    LOAD JQE OFFSET
         LTR   R3,R3          ANY JQE?                            RNB26
         BZ    NEXTSJB        /NO  - TRY NEXT SJB                 RNB26
         AL    R3,QCJQTA      ADD TO JQE ORIGIN
         USING JQEDSECT,R3    BASE REG FOR JQE
         AIF   (&QSP).QSP1                                        UF020
         LH    R0,JQEJOBNO    GET JOB NO.
         CH    R0,=H'20000'   TSO USER?
         BNL   TSOCHK         YES. GO PROCESS
         B     STCCHK         NO. GO PROCESS AS STC
         AGO   .QSP2                                              UF020
.QSP1    ANOP                                                     UF020
         TM    JQEFLAG3,QUEJOB  BATCH JOB?  (SHOULDN'T BE)        RNB26
         BO    UNK              /YES - SAY UNKNOWN                RNB26
         TM    JQEFLAG3,QUETSU  TSO USER?                         UF020
         BO    TSOCHK         YES, GO PROCESS                     UF020
         TM    JQEFLAG3,QUESTC  STARTED TASK?                     UF020
         BO    STCCHK         YES, GO PROCESS                     UF020
UNK      MVC   QUEUE,=CL8'UNKNOWN'                                UF020
         B     NOTTSO         PRINT WHATEVER WE CAN FIND          UF020
.QSP2    ANOP                                                     UF020
BATCHCHK CLI   QPARM1,X'C2'   BATCH DISPLAY ONLY ?
         BE    BATCHMSG       YES. GO PROCESS
         CLI   QPARM1,X'40'   DISPLAY EVERYTHING ?
         BNE   NEXTSJB        NO. GET NEXT SJB
BATCHMSG LR    R5,R4          COPY THE SJB ADDRESS
         L     R3,SJBJQOFF    POINT TO JQE OFFSET
         LTR   R3,R3          ANY JQE?                            RNB26
         BZ    NEXTSJB        /NO  - TRY NEXT SJB                 RNB26
         AL    R3,QCJQTA      POINT TO THE JQE
         IC    R0,JQETYPE     GET THE JOB TYPE
         MVC   QUEUE,=CL8'   XEQ'                                 RNB07
         STC   R0,QUEUE+7     SET THE QUEUE TYPE
         OI    QUEUE+7,X'80'  SET THE PRINTABLE QUEUE TYPE
         B     NOTTSO         GO TO COMMON ROUTINE
TSOCHK   CLI   QPARM1,X'E3'   TSO DISPLAY ONLY ?
         BE    TSOMSG         YES. GO PROCESS
         CLI   QPARM1,X'40'   DISPLAY EVERYTHING ?
         BNE   NEXTSJB        NO. GET NEXT SJB ?
TSOMSG   MVC   QUEUE,=CL8'TSO USER'
         B     NOTTSO
STCCHK   CLI   QPARM1,X'E2'   STC DISPLAY ONLY ?
         BE    STCMSG         YES. GO PROCESS.
         CLI   QPARM1,X'40'   DISPLAY EVERYTHING ?
         BNE   NEXTSJB        NO. GET NEXT SJB.
STCMSG   MVC   QUEUE,=CL8'SYSTEM Q'
NOTTSO   L     R1,SJBASCBP    POINT TO ASCB
         USING ASCB,R1
         LM    R14,R15,ASCBEJST GET THE CPU TIME
         SRDL  R14,12         SKIP THE GARBAGE
         D     R14,=F'10000'  GET THE VALUE IN .01 SECS
         CVD   R15,CONVERT    GET THE DECIMAL VALUE
         MVC   TCBTIME,EDCPU  MOVE EDIT MASK
         ED    TCBTIME,CONVERT+4 EDIT THE NUMBER
         MVI   TCBTIME+L'TCBTIME-1,C'S' SET SECONDS
         LM    R14,R15,ASCBSRBT GET THE CPU TIME
         SRDL  R14,12         SKIP THE GARBAGE
         D     R14,=F'10000'  GET THE VALUE IN .01 SECS
         CVD   R15,CONVERT    GET THE DECIMAL VALUE
         MVC   SRBTIME,EDCPU  MOVE EDIT MASK
         ED    SRBTIME,CONVERT+4 EDIT THE NUMBER
         MVI   SRBTIME+L'SRBTIME-1,C'S' SET SECONDS
         MVC   JOBNAME,SJBJOBNM MOVE IN JOBNAME
         LH    R14,JQEJOBNO   LOAD JOB NUMBER
         CVD   R14,CONVERT    GET THE DECIMAL VALUE
         MVC   JOBNUM,ED5     GET THE CHARACTER VALUE
         ED    JOBNUM,CONVERT+5 GET THE CHARACTER VALUE
         LR    R4,R2          COPY THE ADDRESS
FINDCSCB ICM   R4,15,0(R4)    POINT TO THE NEXT CSCB
         BZ    NEXTSJB
         USING CSCDSECT,R4
         CLC   CHKEY,JQEJNAME TEST FOR RIGHT JOB
         BNE   FINDCSCB       NOPE
         MVC   STEPNAME,CHSTEP MOVE IN STEPNAME
         MVC   PROCSTEP,CHPROCSN MOVE IN THE PROCSTEP NAME
         DROP  R4
NOCSCB   LH    R0,ASCBFMCT    GET NUMBER OF SLOTS
         SLL   R0,2           GET NUMBER OF K
         CVD   R0,CONVERT     GET THE DECIMAL VALUE
         MVC   SLOTS,ED5      MOVE EDIT MASK
         ED    SLOTS,CONVERT+5 GET THE K
         MVI   SLOTS+L'SLOTS-1,C'K' SET THE 'K'
         MVC   QDMLNG,=H'80'  SET THE LENGTH
         LA    R0,QDMSG       GET THE ADDRESS
         ST    R0,QDMSGA      SET THE ADDRESS
         L     R15,=V(DISPLAY) POINT TO THE ROUTINE
         BALR  R14,R15        CALL THE ROUTINE
***********************************************************************
*                                                                     *
*        SEND THE MESSAGE DESCRIBING THE PIT                          *
*                                                                     *
***********************************************************************
NEXTSJB  LA    R6,4(,R6)      POINT TO NEXT HAVT POINTER
         DROP  R1,R5
         BCT   R7,BLDMSG      TEST FOR NEXT HAVT POINTER
***********************************************************************
*                                                                     *
*        END IT ALL                                                   *
*                                                                     *
***********************************************************************
END      QSTOP
NOHAVT   QTILT '***** NO JOBS TO DISPLAY *****'
INITHD   DC    CL80'  QUEUE  JOBNAME   JOB#  STEPNAME PROCSTEP   SLOTS *
                  TCB-TIME    SRB-TIME'
ED5      DC    X'402020202120'
EDCPU    DC    X'4020206B2021204B2020'
         LTORG
***********************************************************************
*                                                                     *
*        DESCRIBE ALL THE DSECTS NEEDED BY THIS MODULE                *
*                                                                     *
***********************************************************************
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
ACTIVE   CSECT ,                                                  UF023
         $CVT
         $JESCT
         $SSCT
         $SVT
         $ASVT
         $ASCB
         $CSCB
         $DEB                                                     UF021
         $SJB
         $JQE
         QCOMMON
         ORG   QDMSG
QUEUE    DS    CL8
         DS    C
JOBNAME  DS    CL8
         DS    C
JOBNUM   DS    CL6
         DS    C
STEPNAME DS    CL8
         DS    C
PROCSTEP DS    CL8
         DS    C
SLOTS    DS    CL7
         DS    C
TCBTIME  DS    CL11
         DS    C
SRBTIME  DS    CL11
         DS    C
WORK     DSECT
         DS    CL72
CONVERT  DS    D
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q25
FINDPDDB QSTART 'QUEUE COMMAND - FIND PDDB FOR A DSID'
         USING QCKPT,R10          BASE REG FOR CHECKPONT WORK AREA
         L     R10,QVCKPT         LOAD BASE REG
         USING QDISPLAY,R9        BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL          LOAD BASE REG
         USING WORK,R13           BASE REG FOR LOCAL WORK AREA
***********************************************************************
*                                                                     *
*   CONVERT DATASET ID TO BINARY                                      *
*                                                                     *
***********************************************************************
         XC    CONVERT,CONVERT       CLEAR CONVERT WORK AREA
         PACK  CONVERT+5(3),DSID+1(3) PACK ASID
         CVB   R7,CONVERT         CONVERT DSID TO BINARY
***********************************************************************
*                                                                     *
*   FIND  PDDB  FOR  THIS  DATASET  ID                                *
*                                                                     *
***********************************************************************
NORMAL   MVI   SWITCH,0           INITIALIZE SWITCH
         USING PDBDSECT,R2        BASE REG FOR PDDB
         USING IOTSTART,R3        BASE REG FOR IOT
         L     R3,QCIOTA          LOAD BASE REG
         L     R1,QCJCTA          ADDR OF JCT                     UF008
         USING JCTSTART,R1        SET TEMP ADDRESSING             UF008
         CLC   QCTRAK,JCTIOT      AT FIRST IOT?                   UF008
         BNE   *+8                NO, SKIP FLAG SET               UF008
         OI    SWITCH,X'02'       SET FLAG                        UF008
         DROP  R1                 DROP TEMP ADDRESSING            UF008
         LR    R5,R3              IOAREA FOR READ IOT BLOCK
NEXTIOT  LR    R4,R3              BASE OF IOT
         A     R4,IOTPDDBP        OFFSET BEYOND LAST PDDB
         LR    R2,R3              BASE OF IOT
         A     R2,QCPDDB1         OFFSET TO FIRST PDDB IN IOT
FINDDS   CH    R7,PDBDSKEY        IS THIS THE DATASET?
         BE    FOUNDDS            YES. CONTINUE
         LA    R2,PDBLENG(R2)     NO. LOOK AT NEXT PDDB
         CR    R2,R4              HAVE WE GONE PAST THE LAST PDDB
         BL    FINDDS             NO. TRY AGAIN
         L     R4,IOTIOTTR        DISK ADDR OF NEXT IOT
SPIN     LTR   R4,R4              IS THERE ANOTHER IOT?
         BZ    SPINIOT            NO. TRY THE SPIN IOT.
         BAL   R8,READ            READ THE IOT
         B     NEXTIOT            SEARCH THE NEXT IOT
         USING JCTSTART,R1        BASE REG FOR JCT
SPINIOT  TM    SWITCH,1           DID WE SEARCH THE SPINIOT ALREADY
         BO    CKIOT1             YES, SEE IF WE STARTED AT FRONT UF008
         OI    SWITCH,1           SET SWITCH
         L     R1,QCJCTA          LOAD BASE REG
         L     R4,JCTSPIOT        DISK ADDR OF SPIN IOT
         DROP  R1
         B     SPIN               SEARCH THE SPIN IOT CHAIN
FOUNDDS  L     R0,PDBRECCT        GET THE RECORD COUNT
         CVD   R0,CONVERT         CONVERT TO DECIMAL
         MVC   DSRECCT,ED8        MOVE EDIT PATTERN TO DISPLAY
         ED    DSRECCT,CONVERT+4  EDIT THE RECORD COUNT
         MVC   DSCLASS,PDBCLASS   MOVE PDBCLASS TO DISPLAY
STOP     QSTOP                    GO BACK TO CALLER
CKIOT1   TM    SWITCH,X'02'       DID WE START AT FIRST IOT?      UF008
         BO    STOP               YES, NOT FOUND                  UF008
         USING JCTSTART,R1        SET TEMP ADDRESSING             UF008
         L     R1,QCJCTA          POINT TO JCT                    UF008
         L     R4,JCTIOT          FIRST IOT ADDRESS               UF008
         DROP  R1                 DROP TEMP ADDRESSING            UF008
         BAL   R8,READ            READ THE IOT                    UF008
         OI    SWITCH,X'02'       SET STARTED AT FRONT            UF008
         B     NEXTIOT            AND TRY AGAIN                   UF008
***********************************************************************
*                                                                     *
*   READ A BLOCK FROM HASPACE                                         *
*                                                                     *
***********************************************************************
READ     ST    R4,QCTRAK          STORE DISK ADDR
         LR    R1,R5              IOAREA ADDRESS
         L     R15,=V(READSPC)    ADDR OF ROUTINE TO READ HASPACE
         BALR  R14,R15            GO TO IT
         BR    R8                 RETURN TO CALLER
ED8      DC    X'4020202020202120'
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
FINDPDDB CSECT ,                                                  UF023
JCT      EQU   0
BUFSTART EQU   0
BUFDSECT EQU   0
         $TAB
         $JCT
         $PDDB
         $IOT
WORK     DSECT
         DS    CL72
SWITCH   DS    C
CONVERT  DS    D
         QCOMMON
         ORG   QDMSG
         DS    CL24
DSID     DS    CL4
         DS    CL4
DSRECCT  DS    CL8
         DS    CL4
DSCLASS  DS    CL1
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q26
SYSOUT   QSTART 'QUEUE COMMAND - MANIPULATE SYSOUT'
***********************************************************************
* RNB CHANGES:                                                        *
*      (1) RNB00 - MOVED THINGS AROUND FOR FOX ASSEMBLER              *
*      (2) RNB08 - ALLOW CANCEL/REQ/DEL IF JOBNAME STARTS WITH USERID *
*                  OR NOTIFY IS FOR USERID, UNLESS JOB SUBMITTED FROM *
*                  PJS. ALLOW TEC USERS TO MANIPULATE OTHER TEC USER'S*
*                  JOBS, AND ALSO STC'S.  KEYED TO QRNB=1             *
*      (3) RNB09 - FOR A REQ COMMAND, IF NO NEWCLASS GIVEN USE CLASS C*
*                  KEYED TO QRNB=1.                                   *
***********************************************************************
         GBLB  &QRNB                                              RNB08
         USING QCKPT,R10
         L     R10,QVCKPT
         USING QDISPLAY,R9
         L     R9,QVDSPL
         USING WORK,R13
***********************************************************************
*                                                                     *
*   TEST AUTHORIZATION OF QUEUE                                       *
*                                                                     *
***********************************************************************
         TESTAUTH FCTN=1          TEST AUTHORIZATION OF USER
         LTR   R15,R15            ?/AUTHORIZED
         BZ    FJOB               YES. KEEP ON TRUCKING
         QTILT ' *** FUNCTION IS NOT AUTHORIZED ***'
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT AND IOT                       *
*                                                                     *
***********************************************************************
FJOB     L     R15,=V(FINDJOB)    ADDR OF MODULE TO FIND JOB
         BALR  R14,R15            GO TO IT
***********************************************************************
*                                                                     *
*   VALIDATE THE JOBNAME                                              *
*                                                                     *
***********************************************************************
         LA    R2,QLOGON          START ADDR OF QLOGON
         LR    R3,R2              SAVE START ADDR
         LA    R4,7               MAX LENGTH OF LOGON ID
VALID000 CLI   0(R2),C' '         ?/END OF LOGON ID
         BE    VALID010           YES. CONTINUE PROCESSING
         LA    R2,1(R2)           NO.  POINT TO NEXT FIELD
         BCT   R4,VALID000        GO CHECK AGAIN
VALID010 SR    R2,R3              LENGTH OF LOGON ID
         BCTR  R2,R0              DECREMENT FOR EXECUTE INSTRUCTION
         USING JCTSTART,R4        BASE REG FOR JCT
         L     R4,QCJCTA          A(JCT)
         EX    R2,VERJOBN         ?/JOB BELONGS TO USER
         AIF   (NOT &QRNB).RNB08A                                 RNB08
         BE    OK                 YES - LET IT GO                 RNB08
         CLC   =C'PJS',QLOGON IS THIS A PJS USER?                 RNB08
         BE    WRONGJOB       YES - INVALID                       RNB08
         BAL   R6,NOPJSJOB    ENSURE NOT A PJS JOB FOR CAN/DEL    RNB08
         CLC   QLOGON(*-*),JCTTSUID  ** EXECUTED **               RNB08
         EX    R2,*-6         IS THE USERID SAME AS NOTIFY ID?    RNB08
         BE    OK             YES - OK                            RNB08
         CLC   =C'TEC',QLOGON   IS THIS A TEC USER?               RNB08
         BNE   WRONGJOB         NO  - INVALID                     RNB08
         TM    JCTJOBFL,JCTSTCJB   IS IT AN STC?                  RNB08
         BO    OK                  /YES - OK FOR TEC USER         RNB08
         CLC   =C'TEC',JCTJNAME IS JOBNAME FOR A TEC USER?        RNB08
         BE    OK               YES - OK                          RNB08
         CLC   =C'TEC',JCTTSUID IS NOTIFY FOR A TEC USER?         RNB08
.RNB08A  ANOP                                                     RNB08
*        BNE   WRONGJOB           NO. GO TELL HIM  DELETED VBA01
OK       EQU   *                                                  RNB08
***********************************************************************
*                                                                     *
*   VALIDATE THE FUNCTION CODE                                        *
*                                                                     *
***********************************************************************
         LH    R1,QCODEH          GET FUNCTION CODE
         CH    R1,=H'8'           ?/VALID FUNCTION CODE
         BH    STOP               NO. EXIT
***********************************************************************
*                                                                     *
*   BRANCH TO THE APPROPIATE PROCESSOR                                *
*                                                                     *
***********************************************************************
         LA    R7,SSOBHDR         ADDR FOR SUBSYSTEM OPTION BLOCK
         USING SSOB,R7
         B     *+4(R1)
         B     DELETE             0   DELETE REQUEST
         B     REQUEUE            4   REQUEUE REQUEST
         B     CANCEL             8   CANCEL REQUEST
***********************************************************************
*                                                                     *
*   PROCESS CANCEL REQUEST                                            *
*                                                                     *
***********************************************************************
CANCEL   LA    R5,SSCSBGN         A(CANCEL PARAMETER LIST)
         BAL   R6,INITSSOB        GO INITIALIZE THE SSOB.
         MVC   SSOBFUNC,=AL2(SSOBCANC)  SET THE FUNCTION
         XC    SSCSBGN(SSCSIZE),SSCSBGN CLEAR PARM LIST
         MVC   SSCSLEN,=AL2(SSCSIZE) SET LENGTH OF CANCEL PARM LIST
         CLI   QPARM2,C'P'        ?/PURGE THE OUTPUT
         BNE   CAN000             NO. DON'T SET THE FLAG
         OI    SSCSFLGS,SSCSCOUT  YES
CAN000   MVC   SSCSJOBN,JCTJNAME  JOBNAME
         MVC   SSCSJOBI,JCTJOBID  JES2 JOB ID
         MVC   SSCSDIMP,=H'16'
         LA    R5,SSCSJOBI        A(JES2 JOB ID)
         BAL   R6,FIXJOBID        ENSURE JOBID HAS NO IMBEDDED BLANKS
         BAL   R6,VERREQ          VERIFY THE REQUEST
         BAL   R6,CALLSSI         GO CALL SUBSYSTEM INTERFACE RTN
         L     R1,SSOBRETN        GET RC FOR CANCEL FUNCTION
         B     *+4(R1)
         B     FUNCTOK            0 -  CANCEL COMPLETED
         B     TILTNOJB           4 -  JOBNAME NOT FOUND
         B     TILTBADI           8 -  INVALID JOBNAME/JOB ID COMB.
         B     TILTNCAN           12 - JOB NOT CANCELLED - DUP JOBN
         B     TILTMALL           16 - STATUS ARRAY TOO SMALL
         B     TILTOUTP           20 - JOB NOT CANCELLED - ON OUTPUT Q
         B     TILTYNTX           24 - JOB ID WITH INVALID SYNTAX
         B     TILTICAN           28 - INVALID CANCEL REQUEST
***********************************************************************
*                                                                     *
*   PROCESS REQUEUE REQUEST                                           *
*                                                                     *
***********************************************************************
REQUEUE  LA    R5,SSSOBGN         A(REQUEUE SYSOUT PARM LIST)
         BAL   R6,INITSSOB        GO INITIALIZE THE SSOB
         AIF   (NOT &QRNB).RNB09B                                 RNB09
         CLI   QPARM2,C' '        WAS NEW CLASS GIVEN?            RNB09
         BNE   RNB09A             /YES - USE IT                   RNB09
         MVI   QPARM2,C'C'        /NO  - DEFAULT TO CLASS C       RNB09
RNB09A   EQU   *                                                  RNB09
.RNB09B  ANOP                                                     RNB09
         MVC   SSOBFUNC,=AL2(SSOBSOUT) INDICATE SYSOUT IS THE FUNCTION
         XC    SSSOBGN(SSSOSIZE),SSSOBGN CLEAR PARM LIST
         MVC   SSSOLEN,=AL2(SSSOSIZE) SET LENGTH OF SYSOUT PARM LIST
         OI    SSSOUFLG,SSSOSETC  USE SSSOCLAS AS DISP
         OI    SSSOUFLG,SSSORLSE  RELEASE ALL SELECTED DATA SETS
         OI    SSSOFLG1,SSSOHLD   SELECTION INCLUDES HELD SYSOUT DS
         OI    SSSOFLG1,SSSOSJBN  JOB NAME IS PRESENT
         OI    SSSOFLG1,SSSOSJBI  JOB ID IS PRESENT
         OI    SSSOFLG2,SSSOCTRL  PROCESSING COMPLETED
         MVC   SSSOJOBN,JCTJNAME  JOBNAME
         MVC   SSSOJOBI,JCTJOBID  JOB ID
         MVC   SSSOCLAS,QPARM2    NEWCLASS
         LA    R5,SSSOJOBI        A(JES JOB ID)
         BAL   R6,FIXJOBID        ENSURE JOBID HAS NO EMBEDDED BLANKS
         BAL   R6,VERREQ          VERIFY THE REQUEST
         BAL   R6,CALLSSI         GO CALL SUBSYSTEM INTERFACE RTN
CHKSORC  L     R1,SSOBRETN        GET RETURN CODE FOR SYSOUT FUNCTION
         B     *+4(R1)
         B     FUNCTOK            0 -  SYSOUT COMPLETED
         B     TILTEODS           4 -  NO MORE DS TO SELECT
         B     TILTNJOB           8 -  JOB NOT FOUND
         B     TILTINVA           12 - INVALID SEARCH ARGUMENTS
         B     TILTUNAV           16 - UNABLE TO PROCESS NOW
         B     TILTDUPJ           20 - DUPLICATE JOB NAMES
         B     TILTINVJ           24 - INVALID JOBN/JOBID COMBO
         B     TILTIDST           28 - INVALID DEST SPECIFIED
***********************************************************************
*                                                                     *
*   PROCESS DELETE  REQUEST                                           *
*                                                                     *
***********************************************************************
DELETE   LA    R5,SSSOBGN         A(DELETE SYSOUT PARM LIST)
         BAL   R6,INITSSOB        GO INITIALIZE THE SSOB
         MVC   SSOBFUNC,=AL2(SSOBSOUT) INDICATE SYSOUT IS THE FUNCTION
         XC    SSSOBGN(SSSOSIZE),SSSOBGN CLEAR PARM LIST
         MVC   SSSOLEN,=AL2(SSSOSIZE) SET LENGTH OF SYSOUT PARM LIST
         OI    SSSOUFLG,SSSODELC  INDICATE DELETE REQUEST
         OI    SSSOFLG1,SSSOHLD   SELECTION INCLUDES HELD DS
         OI    SSSOFLG1,SSSOSJBN  JOB NAME PRESENT
         OI    SSSOFLG1,SSSOSJBI  JES2 JOB ID PRESENT
         OI    SSSOFLG2,SSSOCTRL  PROCESSING COMPLETED
         MVC   SSSOJOBN,JCTJNAME  JOBNAME
         MVC   SSSOJOBI,JCTJOBID  JES2 JOBID
         LA    R5,SSSOJOBI        A(JES2 JOBID)
         BAL   R6,FIXJOBID        ENSURE JOBID HAS NO EMBEDDED BLANKS
         BAL   R6,VERREQ          VERIFY THE REQUEST
         BAL   R6,CALLSSI         GO CALL SUBSYSTEM INTERFACE RTN.
         B     CHKSORC            GO CHECK RC
***********************************************************************
*                                                                     *
*   INITIALIZE THE SUBSYSTEM OPTION BLOCK (SSOB)                      *
*                                                                     *
*        R5 - ADDRESS OF FUNCTION PARM LIST                           *
*        R6 - RETURN ADDRESS                                          *
*        R7 - A(SSOB)                                                 *
*                                                                     *
***********************************************************************
INITSSOB XC    SSOBEGIN(SSOBHSIZ),SSOBEGIN CLEAR THE SSOB
         MVC   SSOBID,=C'SSOB'
         MVC   SSOBLEN,=AL2(SSOBHSIZ) LENGTH OF SSOB HEADER
         ST    R5,SSOBINDV        FUNCTION DEPENDENT AREA POINTER
         ST    R7,SSOBPTR         SAVE ADDR OF SSOB
         OI    SSOBPTR,X'80'      REQUIRED FOR IEFSSREQ INTERFACE
         BR    R6
***********************************************************************
*                                                                     *
*   REMOVE EMBEDDED BLANKS IN JES2 JOB ID                             *
*                                                                     *
***********************************************************************
FIXJOBID LA    R8,5               MAX LENGTH OF SCAN
         LA    R5,3(R5)           START LOCATION FOR SCAN
FIX000   CLI   0(R5),C' '         ?/EMBEDDED BLANK
         BNE   FIX010             NO. CONTINUE WITH THE SCAN
         MVI   0(R5),C'0'         YES. REPLACE WITH 0
FIX010   LA    R5,1(R5)           POINT TO NEXT BYTE
         BCT   R8,FIX000          GO DO IT AGAIN
         BR    R6                 ALL OVER. RETURN TO CALLER
***********************************************************************
*                                                                     *
*   TELL THE USER WHAT HE IS ABOUT TO DO                              *
*                                                                     *
***********************************************************************
VERREQ   MVC   VCLEAR,WARNING     MOVE IN THE WARNING MSG
         MVC   VJOBN(8),JCTJNAME
         MVC   VJOBID(8),JCTJOBID
         LR    R2,R6              SAVE RETURN ADDR
         LA    R5,VJOBID          A(JES JOB ID)
         BAL   R6,FIXJOBID        INSURE NO IMBEDDED BLANKS
         LR    R6,R2              RESTORE RETURN ADDR
         CLI   QSUBNAME,C'D'      ?/DELETE COMMAND
         BNE   VER000
         MVC   VCMD(6),=C'DELETE'
         B     VER020
VER000   CLI   QSUBNAME,C'C'      ?/CANCEL COMMAND
         BNE   VER010
         MVC   VCMD(6),=C'CANCEL'
         CLI   QPARM2,C'P'        PURGE SPECIFIED
         BNE   VER020
         MVC   VACTION(5),QPARM2
         B     VER020
VER010   MVC   VCMD(7),=C'REQUEUE'
         MVC   VACTION,RQACTION
         MVC   VCLASS(1),QPARM2
VER020   MVC   QDMLNG,=H'0'       TELL DISPLAY TO PRINT IT NOW
         L     R15,=V(DISPLAY)    A(MODULE TO DISPLAY THE MESSAGE)
         BALR  R14,R15            GO DISPLAY THE WARNING
         BR    R6                 RETURN TO THE CALLER
***********************************************************************
*                                                                     *
*   INTERFACE TO THE SUBSYSTEM                                        *
*                                                                     *
***********************************************************************
CALLSSI  L     R2,16              A(CVT)
         L     R2,296(R2)         A(JESCT)
         MODESET MODE=SUP         GET SUPER
         LA    R1,SSOBPTR         ADDR OF PTR TO SSOB
         L     R15,20(R2)         A(JESSSREQ)
         BALR  R14,R15
         LR    R2,R15             SAVE RETURN CODE
         MODESET MODE=PROB        BACK TO NORMAL
         B     *+4(R2)
         BR    R6                 0 -  SUCCESSFUL INSTRUCTION
         BR    R6                      DUMMY INSTRUCTION
         B     TILTNSUP           4 -  SS DOESN'T SUPPORT THIS FUNCTION
         B     TILTNTUP           8 -  SS EXIST, BUT IS NOT UP
         B     TILTNOSS           12 - SS DOES NOT EXIST
         B     TILTDIST           16 - FUNCTION NOT SUPPORTED
         B     TILTLERR           20 - LOGICAL ERROR
         AIF   (NOT &QRNB).RNB08B                                 RNB08
******************************************************************RNB08
*                                                                *RNB08
*   TILT IF PJS JOB (ONLY FOR CANCEL OR DELETE)                  *RNB08
*                                                                *RNB08
******************************************************************RNB08
         USING PDBDSECT,R1                                        RNB08
         USING IOTDSECT,R3                                        RNB08
*        USING USERIDLEN,R2                                       RNB08
NOPJSJOB CLI   QCODEH+1,4     IS THIS A REQUEUE?                  RNB08
         BER   R6             /YES - OK FOR NOW                   RNB08
*                             /NO  - ENSURE NOT A PJS JOB         RNB08
         L     R3,QCIOTA      LOAD BASE REG                       RNB08
         LR    R5,R3          BASE OF IOT                         RNB08
         A     R5,IOTPDDBP    OFFSET BEYOND LAST PDDB             RNB08
         LR    R1,R3          BASE OF IOT                         RNB08
         A     R1,QCPDDB1     OFFSET TO FIRST PDDB IN IOT         RNB08
         MVC   QPDSID,=H'0'   NULLIFY VALIDITY FOR LISTDS         RNB08
FINDDS   CLC   =H'5',PDBDSKEY IS THIS THE DATASET?                RNB08
         BE    FOUNDDS        YES. CONTINUE.                      RNB08
         LA    R1,PDBLENG(R1) NO. LOOK AT NEXT PDDB.              RNB08
         CR    R1,R5          HAVE WE GONE PAST THE LAST PDDB?    RNB08
         BL    FINDDS         NO. TRY AGAIN.                      RNB08
         B     BADDDTAB       ELSE BAD DD TABLE (INTERP. JCL)     RNB08
FOUNDDS  L     R5,PDBMTTR     DISK ADDR OF FIRST BLOCK            RNB08
         DROP  R1                                                 RNB08
         L     R7,QCBLKA      ADDR OF DATASET BLOCK IOAREA        RNB08
         MVC   QDMSG,QBLANK   BLANK OUT THE MESSAGE AREA          RNB08
         ST    R5,QCTRAK      STORE DISK ADDR                     RNB08
         LR    R1,R7          IOAREA ADDRESS                      RNB08
         L     R15,=V(READSPC) ADDR OF ROUTINE TO READ HASPACE    RNB08
         BALR  R14,R15        GO TO IT                            RNB08
         LA    R5,10(R7)      ADDR OF FIRST RECORD IN BLOCK       RNB08
         SR    R7,R7          ZERO OUT REG                        RNB08
         IC    R7,0(R5)       INSERT LENGTH                       RNB08
         CLI   5(R5),1        IS THIS A JOB RECORD?               RNB08
         BNE   BADDDTAB       /NO  - INVALID DD TABLE             RNB08
         LA    R5,9(R5)       ADDR OF FIRST KEY                   RNB08
         LR    R8,R7          REMAINING LENGTH OF RECORD          RNB08
         SR    R15,15         ZERO OUT R15                        RNB08
         SR    R14,R14        ZERO OUT R14                        RNB08
         SR    R1,R1          ZERO OUT R1                         RNB08
TRYFLD   CLI   0(R5),X'A5'    IS THIS THE USER= PARM?             RNB08
         BE    GOTUSER        YES. PROCESS IT.                    RNB08
NEXTFLD  IC    R1,1(R5)       NUMBER OF SUBFIELDS                 RNB08
         LA    R5,2(R5)       UPDATE LOCATION                     RNB08
         SH    R8,=H'2'       REMAINING COUNT                     RNB08
         SR    R8,R1          REMAINING COUNT                     RNB08
         BNP   BADDDTAB       RECORD IS EXHAUSTED                 RNB08
         LTR   R1,R1          ARE THERE ANY SUBFIELDS?            RNB08
         BZ    TRYFLD         NO. TRY NEXT FIELD.                 RNB08
LOOPFLD  TM    0(R5),X'80'    IS THIS A SUB-SUB-FIELD             RNB08
         BZ    NOSUB          NO. CONTINUE.                       RNB08
         NI    0(R5),X'7F'    CLEAR THE HEX 80 BIT                RNB08
         IC    R14,0(R5)      NUMBER OF SUB-SUB-FIELDS            RNB08
         LA    R5,1(R5)       UPDATE LOCATION                     RNB08
         SH    R8,=H'1'       REMAINING COUNT                     RNB08
         SR    R8,R14         REMAINING COUNT                     RNB08
         BNP   BADDDTAB       RECORD IS EXHAUSTED                 RNB08
         AR    R1,R14         INCREASE NUMBER OF SUBFIELDS        RNB08
         B     YESSUB         DECREMENT AND TRY AGAIN             RNB08
NOSUB    IC    R15,0(R5)      SUBFIELD LENGTH                     RNB08
         LA    R5,1(R15,R5)   ADD TO LOCATION                     RNB08
         SR    R8,R15         REMAINING COUNT                     RNB08
         BNP   BADDDTAB       RECORD IS EXHAUSTED                 RNB08
YESSUB   BCT   R1,LOOPFLD     DO NEXT SUBFIELD                    RNB08
         B     TRYFLD         TRY NEXT FIELD                      RNB08
GOTUSER  CLI   2(R5),7        IS USER ID LENGTH = 7?              RNB08
         BNER  R6             /NO  - NOT A PJS JOB, OK TO PROCESS RNB08
         CLI   2(R5),0        IS THE LENGTH ZERO?                 RNB08
         BER   R6             YES. SKIP THE FIELD.                RNB08
         CLC   =C'PROD',6(R5) IS IT A PJS JOB? (USER = ???PROD)   RNB08
         BE    PJSMSG         /YES - BAD                          RNB08
         BR    R6             /NO  - GO PROCESS                   RNB08
BADDDTAB QTILT '*** CANNOT PROCESS JOB - DDTABLE MISSING/INVALID' RNB08
PJSMSG   QTILT '*** CANNOT CAN/DEL JOB SUBMITTED VIA PJS ***'     RNB08
.RNB08B  ANOP                                                     RNB08
***********************************************************************
*                                                                     *
*   RETURN TO CALLER                                                  *
*                                                                     *
***********************************************************************
STOP     QSTOP
FUNCTOK  QTILT ' *** COMMAND SUCCESSFULLY PROCESSED ***'
***********************************************************************
*                                                                     *
*   ERROR MESSAGES                                                    *
*                                                                     *
***********************************************************************
WRONGJOB QTILT ' *** JOBNAME DOES NOT BELONG TO YOU ***'
TILTNSUP QTILT ' *** QUEUE LOGIC ERROR -- RC =4  FROM SSI ***'
TILTNTUP QTILT ' *** JES2 IS NOT UP ***'
TILTNOSS QTILT ' *** QUEUE LOGIC ERROR -- RC =12 FROM SSI ***'
TILTDIST QTILT ' *** DISASTROUS ERROR DURING PROCESSING ***'
TILTLERR QTILT ' *** QUEUE LOGIC ERROR -- RC =20 FROM SSI ***'
TILTNOJB EQU   *
TILTNJOB QTILT ' *** JOBNAME NOT FOUND ***'
TILTBADI EQU   *
TILTINVJ QTILT ' *** INVALID JOBNAME/JOB ID COMBINATION ***'
TILTNCAN EQU   *
TILTDUPJ QTILT ' *** DUPLICATE JOBNAME AND NO JOBID GIVEN ***'
TILTEODS QTILT ' *** JOB HAS NO HELD DATA SETS ***'
TILTICAN QTILT ' *** CAN''T CANCEL YOUR TSO SESSION OR A STARTED TASK *X
               **'
TILTOUTP QTILT ' *** JOB NOT CANCELLED - JOB ON OUTPUT QUEUE ***'
TILTMALL EQU   *
TILTYNTX EQU   *
TILTINVA EQU   *
TILTUNAV EQU   *
TILTIDST QTILT ' *** QUEUE LOGIC ERROR ***'
***********************************************************************
*                                                                     *
*   MISCELLANEOUS NUTS, BOLTS, ETC.                                   *
*                                                                     *
***********************************************************************
VERJOBN  CLC   QLOGON(*-*),JCTJNAME
WARNING  DS    0CL80
         DC    CL21' *** '
         DC    CL1'('
         DC    CL8' '
         DC    CL1')'
         DC    CL12' '
         DC    CL37'. HIT ENTER IF OK OR RESPECIFY. ***'
RQACTION DC    CL11'NEWCLASS( )'
         LTORG
         DROP  ,                   DROP ALL ADDRESSINGS           NERDC
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
SYSOUT   CSECT ,                                                  UF023
JCT      EQU   0
BUFSTART EQU   0
BUFDSECT EQU   0
         $TAB
         $JCT
         $PDDB                                                    RNB00
         $IOT                                                     RNB00
         IEFJSSOB (SO,CS),CONTIG=YES
         QCOMMON
         ORG   QDHLINE
VCLEAR   DS    0CL80
         DS    CL5
VCMD     DS    CL8
VJOBN    DS    CL9
VJOBID   DS    CL10
VACTION  DS    CL11
         DS    CL37
VCLASS   EQU   VACTION+9
WORK     DSECT
FILLER   DS    CL512              BIG FILLER
SSOBPTR  DS    F
SSOBHDR  DS    CL140
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q27
PRINT    QSTART 'QUEUE COMMAND - PRINT SCREEN DISPLAY ROUTINE'     FCI*
***********************************************************************
* RNB CHANGES:                                                        *
*      (1) RNB10 - CHANGE DEFAULT SYSOUT CLASS TO C (IF QRNB=1)       *
***********************************************************************
         GBLB  &QRNB                                              RNB10
         USING QDISPLAY,R10   BASE REG FOR DISPLAY WORK AREA       FCI*
         L     R10,QVDSPL     LOAD BASE REG                        FCI*
         USING QCPRINT,R9     BASE REG FOR PRINT WORK AREA         FCI*
         L     R9,QVPRINT     LOAD BASE REGISTER                   FCI*
         USING WORK,R13       BASE REG FOR LOCAL WORK AREA         FCI*
***********************************************************************
*   PROCESS THE PRINT COMMAND                                      FCI*
***********************************************************************
STARTIT  BAL   R7,PARSECMD    GO PARSE THE PRINT COMMAND           FCI*
         CLC   =C'ON',QPPARM1 IS IT ON?                            FCI*
         BE    STARTPRT         YES..GO START IT                   FCI*
         CLC   =C'OFF',QPPARM1 IS PRINT OFF?                       FCI*
         BE    STOPPRT          YES..GO STOP IT                    FCI*
         CLI   QPPARM1,C' '   NO PARM?                             FCI*
         BE    STARTPRT         YES..ASSUME START                  FCI*
STOP     MVC   QDREPLY,QBLANK   KISS OFF OUR REPLY  (SNEAKY)       FCI*
         XC    QDRLNG,QDRLNG    AND SAY NOBODY HOME                FCI*
         QSTOP                                                     FCI*
         EJECT ,                                                   FCI*
***********************************************************************
*   START (OR CONTINUE) THE PRINT PROCESS                          FCI*
***********************************************************************
STARTPRT DS 0H                                                     FCI*
         TM    QPFLAG,HARDCPY  IS HARDCOPY ON                      FCI*
         BO    JUSTPRT         YES..JUST PRINT                     FCI*
         ZAP   QPPAGE,=P'0'    RESET PAGE NUMBER                   FCI*
         MVI   QPHEAD1,C'0'    AND ASA ON HEADING SO WELL START FRESH
         BAL   R7,ALLOCHC      GO ALLOCATE / OPEN HARDCOPY         FCI*
JUSTPRT  BAL   R7,GETTIME      GO GET DATE AND TIME                FCI*
         MVC   QPUSER,QLOGON   MOVE IN USERID                      FCI*
         MVC   QPDATE,JDATE    MOVE IN DATE TIME INFO              FCI*
         MVC   QPPAGE#,QBLANK     CLEAR OUT PAGE # FIELD           FCI*
         XC    QPHEAD1(1),=X'01'  TOGGLE ASA FLAG 0-1 OR 1-0       FCI*
         CLI   QPHEAD1,C'1'    EJECT NOW SCHEDULED?                FCI*
         BNE   NOPAGE             NO..SKIP PAGE SETTING            FCI*
*                                                                  FCI*
         AP    QPPAGE,=P'1'    BUMP PAGE COUNT                     FCI*
         MVC   QPPAGE#,=X'402020202021'  MOVE IN MASK              FCI*
         ZAP   DBLWORK,QPPAGE  MOVE INTO AREA                      FCI*
         ED    QPPAGE#,DBLWORK+5   EDIT IN PAGE NUMBER             FCI*
NOPAGE   PUT   HASPPRNT,QPHEAD1  PUT OUT TITLE LINE                FCI*
         PUT   HASPPRNT,QPHEAD2  PUT OUT '-' LINE                  FCI*
*                                                                  FCI*
         MVC   QPLINE,QBLANK                   RECONSTRUCT IMAGE   FCI*
         MVC   QPLINE(15),=C'QUEUE COMMAND -'    OF HEADER LINE    FCI*
         MVC   QPLINE+16(L'QPRSAVE),QPRSAVE        WITHOUT 3270    FCI*
         PUT   HASPPRNT,QPDETAIL                      CONTROL CHARS
         EJECT ,                                                   FCI*
*                                                                  FCI*
*  PUT OUT ENTIRE SCREEN OF DETAIL LINES (BLANK OR NOT)            FCI*
*                                                                  FCI*
         MVC   QPLINE(80),QDHLINE MOVE HEADING LINE TO BUFFER     UF003
         PUT   HASPPRNT,QPDETAIL PRINT THE LINE                   UF003
         LH    R3,QDSCRLEN       SIZE OF SCREEN                   UF003
         SR    R2,R2             CLEAR FOR DIVIDE                 UF003
         LH    R7,QDLNELEN       LINE LENGTH                      UF003
         DR    R2,R7             NUMBER OF LINES                  UF003
         BCTR  R7,0              DROP LINE LEN FOR EXECUTES       UF003
         LA    R2,QDLINE1        LOAD ADDRESS OF FIRST LINE       UF003
PUTLOOP  EX    R7,PUTMVC         MOVE LINE TO BUFFER              UF003
         PUT   HASPPRNT,QPDETAIL PUT DETAIL LINE LOUT              FCI*
         LA    R2,1(R2,R7)       POINT TO NEXT LINE               UF003
         BCT   R3,PUTLOOP        AND GRIND THE SCREEN THROUGH      FCI*
*                                                                  FCI*
         MVC   QPLINE,QBLANK                   RECONSTRUCT IMAGE   FCI*
         MVC   QPLINE(07),=C'REPLY -'            OF COMMAND LINE   FCI*
         MVC   QPLINE+08(L'QDREPLY),QDREPLY        WITHOUT 3270    FCI*
         MVC   QPLINE+72(1),QDPLUS                   CONTROL CHARS FCI*
         PUT   HASPPRNT,QPDETAIL                       AND PRINT IT
*                                                                  FCI*
         MVI   QPDETAIL,C'-'       TRIPLE SPACE A BLANK LINE       FCI*
         MVC   QPLINE,QBLANK                                       FCI*
         PUT   HASPPRNT,QPDETAIL   AND PRINT IT                    FCI*
         MVI   QPDETAIL,C' '       RESTORE TO SINGLE SPACE         FCI*
*                                                                  FCI*
         MVC   QDTLINE+L'QDTLINE-L'PRTMSG-1(L'PRTMSG),PRTMSG       FCI*
GOTMSG   LA    R1,0               SET A ZERO                       FCI*
         L     R2,4(R13)              RETURN CODE                  FCI*
         ST    R1,16(R2)                  IN REGISTER 15 (SAVED)   FCI*
         B     STOP                                                FCI*
         SPACE 2                                                   FCI*
PUTMVC   MVC   QPLINE(*-*),0(R2)  EXECUTED MOVE                   UF003
PRTMSG   DC    C'SCREEN PRINTED'                                   FCI*
         EJECT ,                                                   FCI*
***********************************************************************
*   STOP PRINT PROCESS AND FREE HASPPRNT DDNAME                    FCI*
***********************************************************************
STOPPRT  TM    QPFLAG,HARDCPY             IS HARDCPY ON            FCI*
         BNO   STOP                       NOPE..NO WORK TO DO      FCI*
         LA    R2,HASPPRNT          BUILD                          FCI*
         LA    R1,DBLWORK                   LIST                   FCI*
         MVI   DBLWORK,X'80'              LAST ENTRY IN LIST       FCI*
         CLOSE ((2)),MF=(E,(1))           CLOSE OFF THE FILE       FCI*
         FREEPOOL (2)                     FREE THE BUFFERS TOO     FCI*
         MVC   DYNALLOC(F99LEN),F99PTR   COPY DYN FREE LIST        FCI*
         LA    R1,FREERB          RELOCATE THE LIST ADDRESSES.     FCI*
         STCM  R1,B'0111',FREEPTR+1   *                            FCI*
         LA    R1,FREETXPT            *                            FCI*
         ST    R1,FREETPTR            *                            FCI*
         LA    R1,FREETU1             *                            FCI*
         STCM  R1,B'0111',FREETXPT+1  *                            FCI*
         LA    R1,FREETU2             *                            FCI*
         STCM  R1,B'0111',FREETXPT+5  *                            FCI*
         LA    R1,FREEPTR                                          FCI*
         DYNALLOC                                                  FCI*
         NI    QPFLAG,255-HARDCPY    TURN OFF PRINT FLAG           FCI*
         MVC   QDTLINE+L'QDTLINE-L'PRTSTP-1(L'PRTSTP),PRTSTP       FCI*
         B     GOTMSG                                              FCI*
PRTSTP   DC    C'PRINT STOPPED; SYSOUT FREED FOR PRINT'            FCI*
         EJECT ,                                                   FCI*
***********************************************************************
*                                                                  FCI*
*   PARSE PRINT COMMAND                                            FCI*
*                                                                  FCI*
***********************************************************************
PARSECMD LH    R2,QDRLNG      LENGTH OF REPLY LINE                 FCI*
         OC    QDREPLY,QBLANK TRANSLATE TO UPPER CASE              FCI*
         CLC   QDREPLY,QBLANK IS THE ENTIRE REPLY BLANK?           FCI*
         BER   R7             YES. NOTHING TO PARSE..RETURN        FCI*
         MVC   FIELD,QBLANK   BLANK THE WORK FIELD                 FCI*
         MVC   OFFSET(4),=F'0' ZERO THE OFFSET AND LENGTH          FCI*
         MVC   QPOFF0(12),OFFSET INITIALIZE FIRST FIELD            FCI*
         MVC   QPOFF1(48),QPOFF0 INITIALIZE NEXT FOUR FIELDS       FCI*
         LA    R6,QPOFF4+12   ADDR PAST LAST FIELD                 FCI*
         LA    R5,QPOFF0      ADDR OF FIRST SET OF FIELDS          FCI*
         LA    R3,QDREPLY     FIRST BYTE OF REPLY LINE             FCI*
ENCORE   LA    R4,FIELD       FIRST BYTE OF WORK FIELD             FCI*
BLANK    CLI   0(R3),C' '     IS THIS BYTE BLANK?                  FCI*
         BNE   FIRST          NO. START OF FIELD.                  FCI*
         LA    R3,1(R3)       YES. SKIP IT.                        FCI*
         BCT   R2,BLANK       TRY NEXT BYTE                        FCI*
         B     EMPTY          END OF REPLY LINE.                   FCI*
FIRST    LH    R1,QDRLNG      REPLY LENGTH                         FCI*
         SR    R1,R2          COMPUTE OFFSET TO START OF FIELD     FCI*
         STH   R1,OFFSET      STORE OFFSET                         FCI*
         LR    R1,R2          SAVE COUNT OF REMAINING BYTES        FCI*
         B     CHAR           CONTINUE                             FCI*
LOOP     CLI   0(R3),C' '     IS THIS BYTE BLANK?                  FCI*
         BE    LAST           YES. END OF FIELD.                   FCI*
CHAR     MVC   0(1,R4),0(R3)  MOVE BYTE TO SUBNAME                 FCI*
         LA    R3,1(R3)       INCREMENT                            FCI*
         LA    R4,1(R4)       INCREMENT                            FCI*
         BCT   R2,LOOP        TRY NEXT BYTE                        FCI*
LAST     SR    R1,R2          COMPUTE FIELD LENGTH                 FCI*
         CH    R1,=H'8'       IS LENGTH GREATER THAN 8?            FCI*
         BNH   STORE          NO. USE IT.                          FCI*
         LA    R1,8           YES. USE LENGTH OF EIGHT.            FCI*
STORE    STH   R1,LENGTH      STORE FIELD LENGTH                   FCI*
EMPTY    MVC   0(12,R5),OFFSET MOVE FIELD TO QCOMMON               FCI*
         LTR   R2,R2          IS THE REMAINING LENGTH ZERO?        FCI*
         BZR   R7             YES. FINITO OF PARSE..RETURN         FCI*
*                                                                  FCI*
         MVC   FIELD,QBLANK   BLANK THE WORK FIELD                 FCI*
         MVC   OFFSET(4),=F'0' ZERO OUT OFFSET AND LENGTH          FCI*
         LA    R5,12(R5)      INCREMENT TO NEXT FIELD              FCI*
         CR    R5,R6          WAS THAT THE LAST FIELD?             FCI*
         BL    ENCORE         NO. PROCESS NEXT FIELD.              FCI*
         EJECT ,                                                   FCI*
***********************************************************************
* GET DATE/TIME FOR HEADING   ENTER WITH BAL R7,GETTIME            FCI*
* RETURNS WITH JDATE(LEN) = YY.DDD  HH:MM:SS DAY MTH DD,19YY       FCI*
*                           123456789.123456789.123456789.123      FCI*
*                                                                  FCI*
***********************************************************************
GETTIME  TIME  DEC                                                 FCI*
         ST    R1,DATE                 SAVE DATE FOR LATER         FCI*
***FORMAT THE PRESENT TIME (AS SET BY THE OPERATOR)                FCI*
         ST    R0,DBLWORK              CNVT PACKED TO DEC          FCI*
         MVC   MONMSK(MVCLEN),XMONMSK  MOVE IN AND INITIALIZE TABLE/DAT
         MVI   DBLWORK+4,X'0F'                                     FCI*
         UNPK  WORKWORD(9),DBLWORK(5)                              FCI*
         MVC   TIMEHRS,WORKWORD        MOVE TIME TO MSG            FCI*
         MVC   TIMMINS,WORKWORD+2                                  FCI*
         MVC   TIMSECS,WORKWORD+4                                  FCI*
***FORMAT TODAY'S DATE INTO THE OUTPUT MSG                         FCI*
         MVC   WORKWORD(4),DATE        MOVE DATE TO WORK AREA.     FCI*
         MVO   WORKWORD+1(3),WORKWORD(2)   MAKE 00YYDDDS INTO 00000YYS.
         UNPK  CYR(2),WORKWORD+2(2)    FORMAT YEAR.                FCI*
         XC    DBLWORK,DBLWORK                                     FCI*
         MVC   DBLWORK+4(4),WORKWORD   CNVT YEAR TO BIN            FCI*
         CVB   R0,DBLWORK                                          FCI*
         ST    R0,BINYEAR              AND SAVE                    FCI*
         TM    BINYEAR+3,X'03'         LEAP YEAR?                  FCI*
         BNZ   MON1                    NO.                         FCI*
         MVI   MONMSK+10,29            YES, CORRECT                FCI*
MON1     XC    DBLWORK,DBLWORK         CNVT DAYS TO BIN            FCI*
         MVC   DBLWORK+6(2),DATE+2                                 FCI*
         CVB   R2,DBLWORK                                          FCI*
         ST    R2,BINDAYS              SAVE FOR LATER              FCI*
         XR    R1,R1                                               FCI*
         LA    R15,11                                              FCI*
MON2     IC    R1,MONMSK(R15)          COMPUTE MON & DAY           FCI*
         SR    R2,R1                                               FCI*
         BNP   MONOVR                                              FCI*
         BCT   R15,MON2                                            FCI*
         B     *+6                                                 FCI*
MONOVR   AR    R2,R1                   CORRECT OVERDRAW            FCI*
         CVD   R2,DBLWORK              FORMAT DAY                  FCI*
         UNPK  CDAYN(2),DBLWORK+6(2)                               FCI*
         OI    CDAYN+1,X'F0'           FIX UP SIGN                 FCI*
         MH    R15,=H'3'               GET TABLE OFFSET            FCI*
         LA    R15,MONTAB(R15)         AND POINT AT MONTH          FCI*
         MVC   CMON(3),0(R15)          MOVE IT TO THE MSG          FCI*
         EJECT ,                                                   FCI*
***DAY OF WEEK                                                     FCI*
         L     R15,BINYEAR                                         FCI*
         SH    R15,=H'69'                                          FCI*
         BNP   OUTT                    MUST BE GREATER OR BAD      FCI*
         XR    R14,R14                 CLEAR DAY REG               FCI*
         D     R14,=F'4'                                           FCI*
         MH    R15,=H'5'                                           FCI*
         AR    R14,R15                                             FCI*
         A     R14,BINDAYS                                         FCI*
         SRDA  R14,32                                              FCI*
         D     R14,=F'7'               MODULO 7 FOR WEEK           FCI*
         MH    R14,=H'3'                                           FCI*
         LA    R14,DAYTAB(R14)         POINT AT TODAY              FCI*
         MVC   CDAY(3),0(R14)          INSERT IN MSG               FCI*
***                                                                FCI*
MOVEJD   MVC   JDATE-1(7),=X'4020204B202020'                       FCI*
         ED    JDATE-1(7),DATE+1                                   FCI*
*                                                                  FCI*
DATERTN  BR    R7                      RETURN TO MAINLINE          FCI*
*                                                                  FCI*
OUTT     MVC   CDAY(3),=CL3'???'                                   FCI*
         B     MOVEJD                                              FCI*
         SPACE 2                                                   FCI*
***********************************************************************
* LEAVE FIELDS TOGETHER.. INITIALIZED BY ONE MVC WITH VALUES       FCI*
*                                                                  FCI*
XMONMSK  DC    AL1(31,30,31,30,31,31,30,31,30,31,28,31)  L         FCI*
         DC    C' XX.XXX',C'  '                          E  F      FCI*
         DC    CL2' ',C':'                               A  I  T   FCI*
         DC    CL2' ',C':'                               V  E  O   FCI*
         DC    CL2' ',C' '                               E  L  G   FCI*
         DC    CL3' ',C' '                                  D  E   FCI*
         DC    CL3' ',C' '                                  S  T   FCI*
         DC    CL2' ',C',19'                                   H   FCI*
         DC    CL2'  ',C' '                                    E   FCI*
*                                                              R   FCI*
***********************************************************************
MVCLEN   EQU   *-XMONMSK                                           FCI*
*                                                                  FCI*
***********************************************************************
DAYTAB   DC    C'TUEWEDTHRFRISATSUNMON'                            FCI*
MONTAB   DC    C'DECNOVOCTSEPAUGJULJUNMAYAPRMARFEBJAN'             FCI*
         EJECT ,                                                   FCI*
***********************************************************************
* ALLOC HARDCOPY TO HASPPRNT DDNAME                                FCI*
*                                                                  FCI*
***********************************************************************
ALLOCHC  MVC   DYNALLOC(S99LENG),S99RBPTR COPY DYN ALLOCATION LIST.
         LA    R1,P99RB           RELOCATE THE LIST ADDRESSES.     FCI*
         STCM  R1,B'0111',P99RBPTR+1  *                            FCI*
         LA    R1,P99TUPL             *                            FCI*
         ST    R1,P99TXTPP            *                            FCI*
         LA    R1,P99TUKY1            *                            FCI*
         STCM  R1,B'0111',P99TUPL+1   *                            FCI*
         LA    R1,P99TUKY2            *                            FCI*
         STCM  R1,B'0111',P99TUPL+5   *                            FCI*
         LA    R1,P99TUKY3            *                            FCI*
         STCM  R1,B'0111',P99UPLL+1   *                            FCI*
*  PROCESS PARMS..........                                         FCI*
         LH    R1,QPLNG2        GET LENGTH OF SECOND PARM          FCI*
         CH    R1,=H'1'         LENGTH OF ONE?                     FCI*
         BNE   NOCLSCHG         NO..NO CHANGE OF SYSOUT CLASS      FCI*
         CLI   QPPARM2,C'A'     IS IT ALPHA                        FCI*
         BL    NOCLSCHG                                            FCI*
         MVC   P99SYSOC,QPPARM2 MOVE IN PARM FOR SYSOUT CLASS      FCI*
NOCLSCHG CLI   QPPARM3,C' '     ANY DEST SPECIFIED                 FCI*
         BE    NODEST                                              FCI*
         MVC   P99DEST,QPPARM3  MOVE IN DEST                       FCI*
         MVC   P99DESTL,QPLNG3  MOVE IN LENGTH                     FCI*
         MVI   P99EPARM,X'00'   SAY CLASS IS NOT LAST PARM         FCI*
*  DO THE ALLOCATE                                                 FCI*
NODEST   LA    1,DYNALLOC         ADDR OF PARM LIST FOR DYNALLOC.  FCI*
         DYNALLOC                                                  FCI*
         LTR   R15,R15            CHK RETURN CODE                  FCI*
         BNZ   CANTALLC           NO CAN DO..POST MESSAGE          FCI*
         LA    R6,HASPPRNT        ADDRESS OF OUTPUT DCB.           FCI*
         USING IHADCB,R6          ADDRESSABILITY TO OUTPUT DCB.    FCI*
         LA    R1,DBLWORK         BUILD                            FCI*
         MVI   0(R1),X'80'          ONLY ENTRY IN LIST             FCI*
         OPEN  ((6),(OUTPUT)),MF=(E,(1))  OPEN THE FILE            FCI*
         TM    DCBOFLGS,X'10'     CHECK FOR SUCCESSFUL OPEN.       FCI*
         DROP  R6                 ELIMINATE DCB ADDRESSABILITY.    FCI*
         BZ    PRNTBAD            BYPASS SWITCH SETTING IF BAD OPEN.
         OI    QPFLAG,HARDCPY     INDICATE HARDCPY FILE AVAILABLE. FCI*
         MVC   QDTLINE(L'MSGSTART),MSGSTART  MOVE IN START MSG     FCI*
         MVC   M1CLASS,P99SYSOC   MOVE IN SYSOUT CLASS             FCI*
         MVC   M1DEST,P99DEST                                      FCI*
         CLI   M1DEST,C' '        ANY DEST?                        FCI*
         BNE   PRNTOKAY                                            FCI*
         MVC   M1DEST,=CL8'LOCAL' SAY LOCAL                        FCI*
         B     PRNTOKAY           BYPASS TPUT ERROR MSG.           FCI*
         EJECT ,                                                   FCI*
PRNTBAD  QTILT 'SORRY...UNABLE TO ALLOC/OPEN HASPPRNT FOR HARDCOPY'
PRNTOKAY BR    R7                 RETURN                           FCI*
         SPACE 2                                                   FCI*
MSGSTART DC    CL63'PRINT STARTED; SYSOUT=X,DEST=XXXXXXXX'         FCI*
         EJECT ,                                                   FCI*
***********************************************************************
*        FORMULATE TEXT FOR SVC99 ALLOCATE FAILURE                 FCI*
***********************************************************************
         SPACE 3                                                   FCI*
CANTALLC MVC   QDTLINE,QBLANK     CLEAR OUT LINE                   FCI*
         CLC   P99ERROR,=X'046C'  WAS IT 'RMT NOT DEF TO JES2'?    FCI*
         BE    BADRMT             YES..POST MSG AND EXIT           FCI*
*                                                                  FCI*
         MVC   QDTLINE(L'MSGERR),MSGERR                            FCI*
         CVD   R15,DBLWORK        CONVERT SVC 99 RETURN CODE       FCI*
         MVC   M2RC,=X'40202020'   TO NICE PRINTABLE DECIMAL       FCI*
         ED    M2RC,DBLWORK+6                                      FCI*
*                                                                  FCI*
         UNPK  M2ERC(5),P99ERROR(3) CONVERT DYNAM ALLOC ERR CODE   FCI*
         NC    M2ERC,HEXMASK         TO PRINTABLE HEXADECIMAL      FCI*
         TR    M2ERC,HEXTAB          AND FIX IT UP PRETTY          FCI*
         MVI   M2ERC+4,C' '                                        FCI*
*                                                                  FCI*
         UNPK  M2INFO(5),P99INFO(3) CONVERT DYNAM ALLOC INFO       FCI*
         NC    M2INFO,HEXMASK        CODE TO PRNTABLE HEX          FCI*
         TR    M2INFO,HEXTAB         AND FIX IT UP PRETTY          FCI*
         MVI   M2INFO+4,C' '                                       FCI*
         B     GOTMSG                   AND GO POST THE MESSAGE    FCI*
*                                                                  FCI*
BADRMT   MVC   QDTLINE(L'MSGNRMT),MSGNRMT  MOVE IN NO SUCH REMOTE MSG
         MVC   MREMOTE,QPPARM3         MOVE IN REMOTE ASKED FOR    FCI*
         B     GOTMSG                   AND GO POST THE MESSAGE    FCI*
         SPACE 2                                                   FCI*
HEXTAB   DC    C'0123456789ABCDEF'                                 FCI*
HEXMASK  DC    X'0F0F0F0F0F0F0F0F'                                 FCI*
MSGNRMT  DC    C'REMOTE XXXXXXXX NOT DEFINED TO JES2; PRINT BYPASSED'
MSGERR   DC    C'CANT ALLOC SYSOUT FOR PRINT; DARC= XXXX INFO= XXXX R15X
               = XXXX '                                            FCI*
***********************************************************************
         EJECT ,                                                   FCI*
         LTORG                                                     FCI*
         SPACE 2                                                   FCI*
         DS    0F                                                  FCI*
*                                          SVC 99 REQUEST BLOCK  PTR
S99RBPTR DC    X'80',AL3(S99RB)                                    FCI*
*                                          SVC 99 REQUEST BLOCK    FCI*
S99RB    DS    0F                                                  FCI*
S99RBLN  DC    AL1(20)                     LENGTH=20 BYTES         FCI*
S99VERB  DC    X'01'                       VERB CODE=01 (DSNAME ALLOC)
S99FLAG1 DC    X'1000'                     DONT USE EXISTING ALLOC FCI*
S99ERROR DC    AL2(0)                              ERROR CODE      FCI*
S99INFO  DC    AL2(0)                              INFO  CODE      FCI*
S99TXTPP DC    A(S99TUPL)                 POINTER TO TEXT UNIT POINTERS
S99RSVD1 DC    A(0)                          RESERVED              FCI*
S99FLAG2 DC    A(0)                          FLAGS 2               FCI*
S99TUPL  DC    A(S99TUKY1)                TEXT UNIT POINTERS       FCI*
S99EPARM DC    X'80',AL3(S99TUKY2)        LAST PARM IF NO DEST=    FCI*
         DC    X'80',AL3(S99TUKY3)        LAST PARM IF DEST= GIVEN FCI*
S99TUNIT DS    0F                                                  FCI*
*                                                  DDNAME=HASPPRNT FCI*
S99TUKY1 DC    X'0001',X'0001',X'0008',C'HASPPRNT'                 FCI*
*                                                  SYSOUT=A        FCI*
S99TUKY2 DC    X'0018',X'0001',X'0001'                             FCI*
         AIF   (&QRNB).RNB10A                                     RNB10
S99SYSOC DC    C'A'                                                FCI*
         AGO   .RNB10B                                            RNB10
.RNB10A  ANOP                                                     RNB10
S99SYSOC DC    C'C'                                               RNB10
.RNB10B  ANOP                                                     RNB10
*                                      OPTIONAL    DEST=RMTXXX     FCI*
S99TUKY3 DC    X'0058',X'0001'                                     FCI*
S99DESTL DC    X'0000'   LENGTH OF DEST                            FCI*
S99DEST  DC    CL8' '  DEST PARAMETER                              FCI*
*                                                                  FCI*
         DS    0D                                                  FCI*
S99LENG  EQU   *-S99RBPTR              LENGTH OF WHOLE MAGILLA     FCI*
         EJECT ,                                                   FCI*
*.....................................................................*
*.       DYNAMIC ALLOCATION REQUEST BLOCK TO FREE DDNAME HASPPRNT    .*
*.....................................................................*
         SPACE 3                                                   FCI*
         DS    0F                  GET FULLWORD BOUNDARY           FCI*
F99PTR   DC    X'80',AL3(F99RB)    THE POINTER TO THE MESS..       FCI*
*                                                                  FCI*
F99RB    DC    FL1'20'            LENGTH OF RB IN BYTES = 20       FCI*
         DC    XL1'02'            VERB CODE=X'02'..FREE BY DDN     FCI*
         DC    AL2(0)             FLAGS1..NO OPTIONS               FCI*
F99RC    DC    XL2'0000'          ERROR CODE                       FCI*
F99INFO  DC    XL2'0000'          INFO CODE                        FCI*
         DC    AL4(F99TXPT)       ADDRESS OF TEXT UNITS            FCI*
         DC    XL4'00'            RESERVED                         FCI*
         DC    XL4'00'            FLAGS2                           FCI*
         SPACE 2                                                   FCI*
F99TXPT DC     AL4(F99TU1)        ADDR OF DSN TEXT UNIT            FCI*
         DC    X'80',AL3(F99TU2) ADDR OF UNALLOC TEXT TU(LAST)     FCI*
         SPACE 2                                                   FCI*
F99TU1   DC    X'0001',X'0001',FL2'8',C'HASPPRNT' DDNAME           FCI*
F99TU2   DC    X'0007',X'0000'        UNALLOC EVEN IF PERM ALLOC   FCI*
F99LEN   EQU   *-F99PTR           LENGTH OF FILEDS                 FCI*
         EJECT ,                                                   FCI*
***********************************************************************
WORK     DSECT                                                     FCI*
         DS    CL72                                                FCI*
OFFSET   DS    H                                                   FCI*
LENGTH   DS    H                                                   FCI*
FIELD    DS    CL8                                                 FCI*
RPASS    DS    CL8                                                 FCI*
DBLWORK  DC    D'0'                                                FCI*
BINYEAR  DC    F'0'                                                FCI*
BINDAYS  DC    F'0'                                                FCI*
DATE     DC    F'0'                                                FCI*
WORKWORD DC    2F'0'                                               FCI*
***********************************************************************
* LEAVE FIELDS TOGETHER.. INITIALIZED BY ONE MVC WITH VALUES       FCI*
*                                                                  FCI*
MONMSK   DC    AL1(31,30,31,30,31,31,30,31,30,31,28,31)            FCI*
         DC    CL1' '                                    L         FCI*
JDATE    DC    C'XX.XXX',C'  '                           E  F      FCI*
TIMEHRS  DC    CL2' ',C'.'                               A  I  T   FCI*
TIMMINS  DC    CL2' ',C'.'                               V  E  O   FCI*
TIMSECS  DC    CL2' ',C' '                               E  L  G   FCI*
CDAY     DC    CL3' ',C' '                                  D  E   FCI*
CMON     DC    CL3' ',C' '                                  S  T   FCI*
CDAYN    DC    CL2' ',C',19'                                   H   FCI*
CYR      DC    CL2'  ',C' '                                    E   FCI*
*                                                              R   FCI*
***********************************************************************
LEN      EQU   *-JDATE                                             FCI*
         SPACE 2                                                   FCI*
         DS    0F                                                  FCI*
DYNALLOC DS    (S99LENG)XL1                                        FCI*
         ORG   DYNALLOC                                            FCI*
*                                          SVC 99 REQUEST BLOCK  PTR
P99RBPTR DC    X'80',AL3(P99RB)                                    FCI*
*                                          SVC 99 REQUEST BLOCK    FCI*
P99RB    DS    0F                                                  FCI*
P99RBLN  DC    AL1(20)                     LENGTH=20 BYTES         FCI*
P99VERB  DC    X'01'                       VERB CODE=01 (DSNAME ALLOC)
P99FLAG1 DC    X'1000'                     DONT USE EXISTING ALLOC FCI*
P99ERROR DC    AL2(0)                              ERROR CODE      FCI*
P99INFO  DC    AL2(0)                              INFO  CODE      FCI*
P99TXTPP DC    A(P99TUPL)                 POINTER TO TEXT UNIT POINTERS
P99RSVD1 DC    A(0)                          RESERVED              FCI*
P99FLAG2 DC    A(0)                          FLAGS 2               FCI*
P99TUPL  DC    A(P99TUKY1)                TEXT UNIT POINTERS       FCI*
P99EPARM DC    X'80',AL3(P99TUKY2)        LAST PARM IF NO DEST=    FCI*
P99UPLL  DC    X'80',AL3(P99TUKY3)        LAST PARM IF DEST= GIVEN FCI*
P99TUNIT DS    0F                                                  FCI*
*                                                  DDNAME=HASPPRNT FCI*
P99TUKY1 DC    X'0001',X'0001',X'0008',C'HASPPRNT'                 FCI*
*                                                  SYSOUT=A        FCI*
P99TUKY2 DC    X'0018',X'0001',X'0001'                             FCI*
P99SYSOC DC    C'A'                                                FCI*
*                                      OPTIONAL    DEST=RMTXXX     FCI*
P99TUKY3 DC    X'0058',X'0001'                                     FCI*
P99DESTL DC    X'0000'   LENGTH OF DEST                            FCI*
P99DEST  DC    CL8' '  DEST PARAMETER                              FCI*
*                                                                  FCI*
         ORG   DYNALLOC                                            FCI*
         DS    0F                  GET FULLWORD BOUNDARY           FCI*
FREEPTR  DC    X'80',AL3(FREERB)   THE POINTER TO THE MESS..       FCI*
*                                                                  FCI*
FREERB   DC    FL1'20'            LENGTH OF RB IN BYTES = 20       FCI*
         DC    XL1'02'            VERB CODE=X'02'..FREE BY DDN     FCI*
         DC    AL2(0)             FLAGS1..NO OPTIONS               FCI*
FREERC   DC    XL2'0000'          ERROR CODE                       FCI*
FREEINFO DC    XL2'0000'          INFO CODE                        FCI*
FREETPTR DC    AL4(FREETXPT)      ADDRESS OF TEXT UNITS            FCI*
         DC    XL4'00'            RESERVED                         FCI*
         DC    XL4'00'            FLAGS2                           FCI*
         SPACE 2                                                   FCI*
FREETXPT DC    AL4(FREETU1)       ADDR OF DSN TEXT UNIT            FCI*
         DC    X'80',AL3(FREETU2) ADDR OF UNALLOC TEXT TU(LAST)    FCI*
         SPACE 2                                                   FCI*
FREETU1  DC    X'0001',X'0001',FL2'8',C'HASPPRNT' DDNAME           FCI*
FREETU2  DC    X'0007',X'0000'        UNALLOC EVEN IF PERM ALLOC   FCI*
         ORG   ,                                                   FCI*
*                                                                  FCI*
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON                                                   FCI*
         SPACE 2                                                   FCI*
MREMOTE  EQU   QDTLINE+7,8                                         FCI*
M2ERC    EQU   QDTLINE+35,4                                        FCI*
M2INFO   EQU   QDTLINE+46,4                                        FCI*
M2RC     EQU   QDTLINE+56,4                                        FCI*
M1CLASS  EQU   QDTLINE+22,1                                        FCI*
M1DEST   EQU   QDTLINE+29,8                                        FCI*
         EJECT ,                                                   FCI*
PRINT    CSECT                                                     FCI*
         PRINT NOGEN                                               FCI*
         DCBD  DSORG=(PS)                                          FCI*
         PRINT GEN                                                 FCI*
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END  ,                                                    FCI*
./ ADD NAME=Q28
HEXDUMP  QSTART 'QUEUE COMMAND - HEX DUMP OF PASSED DATA AREA'    UF011
         L     R10,QVCKPT     LOAD BASE REG
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R9,QVDSPL      LOAD BASE REG
         USING QDISPLAY,R9    BASE REG FOR DISPLAY WORK AREA
         L     R8,QVPRINT     LOAD BASE REG
         USING QCPRINT,R8     BASE REG FOR DISPLAY WORK AREA
         LA    R8,QPLINE      LOAD BASE REG
         USING WORK,R8        BASE REG FOR PRINT LINE AREA
***********************************************************************
*                                                                     *
*   INPUT:                                                            *
*        R1    POINTER TO DATA AREA TO BE DUMPED                      *
*        R0    OFFSET AND LENGTH OF AREA TO DUMP (2 BYTES EACH)       *
*              (OFFSET IS USED FOR PRINT DISPLACEMENT FIELD ONLY)     *
*              (AS AN EXAMPLE, THE DUMP OF A JCT IS MOST USEFUL       *
*              IF THE OFFSET IS SET TO THE LENGTH OF ITS              *
*              ASSOCIATED IOB)                                        *
*                                                                     *
***********************************************************************
         LR    R6,R1          POINTER TO START OF DATA AREA
         LR    R3,R0          PRINT OFFSET FOR AREA
         SRL   R3,16          MOVE TO PROPER POSITION
         LR    R4,R0          LENGTH TO DUMP
         SLL   R4,16          THROW AWAY OFFSET
         SRL   R4,16          MOVE LENGTH TO PROPER POSITION
***********************************************************************
*                                                                     *
*   FORMAT THE AREA                                                   *
*                                                                     *
***********************************************************************
         MVC   QDHLINE,QBLANK BLANK THE TITLE LINE
         LA    R5,WORKLINE    POINT TO LINE IN WORK AREA
         ST    R5,QDMSGA      STORE ADDR OF PRINT LINE
         MVC   QDMLNG,=H'80'  LENGTH OF MESSAGE
         CLC   QDLNELEN,=H'132' LONG ENOUGH FOR DOUBLE LINE?
         BL    *+4+6          NO, SKIP RESET OF LENGTH
         MVC   QDMLNG,=H'132' LENGTH OF MESSAGE
         SPACE 1
LOOP     MVC   WORKLINE,QBLANK  BLANK THE WORK AREA
         STH   R3,QDWORD      GET OFFSET
         UNPK  OFFSET(5),QDWORD(3) CONVERT TO HEX
         MVI   OFFSET+L'OFFSET,C' ' CLEAR GARBAGE BYTE
         TR    OFFSET,TABLEP  TRANSLATE TO PRINTABLE CHARACTERS
         SPACE 1
         LR    R2,R6          POINTER TO DATA AREA
         LA    R1,4           NUMBER OF WORDS IN LINE AREA
         LA    R14,O1         POINTER TO FIRST OUTPUT AREA
         LA    R15,P1         POINTER TO EBCDIC AREA
         MVI   PS1,C'*'       SET STARS
         MVI   PS2,C'*'       SET STARS
         CLC   QDLNELEN,=H'132' SHORT LINES?
         BL    LOOP1          YES, SKIP SETTING ALTERNATE PRINT AREA
         MVI   PS1,C' '       FIX OTHER FLAG
         MVI   PS2,C' '       FIX OTHER FLAG
         LA    R15,P1A        ALTERNATE EBCDIC AREA
         MVI   PS1A,C'*'      SET STARS
         MVI   PS2A,C'*'      SET STARS
         SPACE 1
LOOP1    UNPK  0(9,R14),0(5,R2)  UNPACK DATA TO PRINT LINE
         TR    0(8,R14),TABLEP TRANSLATE TO PRINTABLE CHARACTERS
         MVI   8(R14),C' '    CLEAR WASTE BYTE
         MVC   0(4,R15),0(R2) COPY DATA TO PRINT AREA
         TR    0(4,R15),PRTAB FIX UNPRINTABLES
         LA    R2,4(,R2)      NEXT DATA AREA
         LA    R3,4(,R3)      BUMP OFFSET
         LA    R14,9(,R14)    NEXT HEX AREA
         LA    R15,4(,R15)    NEXT PRINT AREA
         SH    R4,=H'4'       DROP BY PROCESSED LENGTH
         BNP   PRINT1
         BCT   R1,LOOP1       LOOP FOR ALL FOUR WORDS
         SPACE 1
         CLC   QDLNELEN,=H'132' SHORT LINES?
         BL    PRINT1         YES, PRINT WHAT WE HAVE
         LA    R14,O5         POINT TO OUTPUT AREA
         LA    R15,P5A        POINT TO OUTPUT AREA
         LA    R1,4           NUMBER OF WORDS
         SPACE 1
LOOP2    UNPK  0(9,R14),0(5,R2)  UNPACK DATA TO PRINT LINE
         TR    0(8,R14),TABLEP TRANSLATE TO PRINTABLE CHARACTERS
         MVI   8(R14),C' '    CLEAR WASTE BYTE
         MVC   0(4,R15),0(R2) COPY DATA TO PRINT AREA
         TR    0(4,R15),PRTAB FIX UNPRINTABLES
         LA    R2,4(,R2)      NEXT DATA AREA
         LA    R3,4(,R3)      BUMP OFFSET
         LA    R14,9(,R14)    NEXT HEX AREA
         LA    R15,4(,R15)    NEXT PRINT AREA
         SH    R4,=H'4'       DROP BY PROCESSED LENGTH
         BNP   PRINT1
         BCT   R1,LOOP2       LOOP FOR ALL FOUR WORDS
         SPACE 1
PRINT1   L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE
         BALR  R14,R15        GO TO IT
         LR    R15,R6         ADDR OF DATA JUST DUMPED
         LR    R6,R2          ADDRESS OF NEXT TO DUMP
         SR    R2,R15         LENGTH JUST DUMPED
         BCTR  R2,0           DROP FOR EXECUTE
         SPACE 1
SKIP     DS    0H
         LTR   R4,R4          TEST REMAINING LENGTH
         BNP   STOP           YES. GO HOME.
         EX    R2,CLC         IS THIS RECORD THE SAME AS PREVIOUS?
         BNE   LOOP           NO, PRINT IT
         LA    R6,1(R2,R6)    BUMP TO NEXT AREA
         LA    R3,1(R2,R3)    BUMP OFFSET
         SR    R4,R2          DROP BY LENGTH DUMPED
         BCTR  R4,0           FIX FOR EXECUTE STUFF
         B     SKIP           SKIP PRINTING DUPS
         SPACE 1
CLC      CLC   0(*-*,R15),0(R6)  TEST FOR SAME DATA
***********************************************************************
*                                                                     *
*   RETURN                                                            *
*                                                                     *
***********************************************************************
STOP     QSTOP
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
* TABLE TO REMOVE UNPRINTABLES
PRTAB    DC    CL64' '
         DC    192AL1(*-PRTAB)
* TABLE FOR HEX UNCONVERT
TABLEP   EQU   *-240
         DC    C'0123456789ABCDEF'
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
WORK     DSECT ,
WORKLINE DS    CL132          LINE TO PRINT
         ORG   WORKLINE       BACK UP TO WORK LINE
OFFSET   DS    CL4            OFFSET INTO AREA
         DS    XL3            SPACER
O1       DS    CL8            OUTPUT HEX AREA
         DS    X              SPACER
O2       DS    CL8            OUTPUT HEX AREA
         DS    X              SPACER
O3       DS    CL8            OUTPUT HEX AREA
         DS    X              SPACER
O4       DS    CL8            OUTPUT HEX AREA
         DS    XL3            SPACER
O5       DS    CL8            OUTPUT HEX AREA
         DS    X              SPACER
O6       DS    CL8            OUTPUT HEX AREA
         DS    X              SPACER
O7       DS    CL8            OUTPUT HEX AREA
         DS    X              SPACER
O8       DS    CL8            OUTPUT HEX AREA
         DS    XL2            SPACER
PS1A     DS    C              STAR FOR PRINT AREA
P1A      DS    CL4            PRINT AREA
P2A      DS    CL4            PRINT AREA
P3A      DS    CL4            PRINT AREA
P4A      DS    CL4            PRINT AREA
P5A      DS    CL4            PRINT AREA
P6A      DS    CL4            PRINT AREA
P7A      DS    CL4            PRINT AREA
P8A      DS    CL4            PRINT AREA
PS2A     DS    C              STAR FOR PRINT AREA
         ORG   O5-1           BACK UP FOR SHORT LINES
PS1      DS    C              STAR FOR PRINT AREA
P1       DS    CL4            PRINT AREA
P2       DS    CL4            PRINT AREA
P3       DS    CL4            PRINT AREA
P4       DS    CL4            PRINT AREA
PS2      DS    C              STAR FOR PRINT AREA
         ORG   ,              BACK TO NORMAL ADDRESSING
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q29
CJQE     QSTART 'QUEUE COMMAND - DUMP A JQE IN HEX'               UF015
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE                                    *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   CALL HEXDUMP TO DUMP THE JQE                                      *
*                                                                     *
***********************************************************************
         L     R10,QVCKPT     BASE FOR CKPT WORK AREA
         USING QCKPT,R10      ADDRESSING FOR IT
         L     R1,QCJQEA      ADDRESS OF JQE
         LA    R0,JQELNGTH    GET ACTUAL LENGTH OF JQE
         L     R15,=V(HEXDUMP) ADDR OF HEXDUMP MODULE
         BALR  R14,R15        GO TO IT
         QSTOP
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
CJQE     CSECT ,                                                  UF023
        $JQE
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q3
CKPT     QSTART 'QUEUE COMMAND - READ JES2 CKPT RECORDS'
         USING QCKPT,R10      BASE REG FOR HASP WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
***********************************************************************
*                                                                     *
*   REPOSITION DATASET                                                *
*                                                                     *
***********************************************************************
         POINT HASPCKPT,TIR3  POINT PAST SYNC RECORDS
***********************************************************************
*                                                                     *
*   READ CHECKPOINT DATASET                                           *
*                                                                     *
***********************************************************************
         L     R2,QCJQTL      ADDR OF IOAREA FOR CKPT HEADER REC
         L     R3,QCJOTL      NUMBER OF RECORDS IN CKPT DATASET
LOOP     READ  HDECB1,SF,,(R2),MF=E
         CHECK HDECB1
         AH    R2,HDECB1+6    INCREMENT TO NEXT BUFFER
         BCT   R3,LOOP        READ NEXT RECORD.
***********************************************************************
*                                                                     *
*   RETURN TO CALLER                                                  *
*                                                                     *
***********************************************************************
         QSTOP
         LTORG
         DS    0F
TIR3     DC    X'00000300'    POINT PAST SYNC RECORDS
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q30
CJCT     QSTART 'QUEUE COMMAND - DUMP A JCT IN HEX'               UF016
***********************************************************************
* JCT JOBNAME <OFFSET>                                                *
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JCT                                    *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   CALL HEXDUMP TO DUMP THE JCT                                      *
*                                                                     *
***********************************************************************
         L     R10,QVCKPT     BASE FOR CKPT WORK AREA
         USING QCKPT,R10      ADDRESSING FOR IT
         L     R1,QCJCTA      ADDRESS OF JCT
         LA    R0,JCTSTART-JCTDSECT  OFFSET TO START OF JCT
         SR    R1,R0          BACK UP TO PREFIX
         LH    R15,QLNG2      LENGTH OF USER OFFSET INTO JCT
         LTR   R15,R15        IS THE LENGTH ZERO?
         BNP   DUMP0          YES. NONE SPECIFIED
         CH    R15,=H'8'      IS THE LENGTH TOO BIG?
         BH    TILTO          YES, GIVE UP
         EX    R15,OFFTR      CONVERT TO HEX
         EX    R15,OFFPACK    PACK INTO QDWORD
         LH    R15,QDWORD     PICK UP OFFSET
         CR    R0,R15         COMPARE TO BASE OFFSET
         BNL   DUMP0          USE R0 FOR OFFSET
         LR    R0,R15         GET OTHER OFFSET
DUMP0    AR    R1,R0          ADD TO BASE ADDRESS
         LH    R15,HASPACE+62 MAX LEN INCLUDING NETWORK HEADERS
         LA    R15,JCTSTART-JCTDSECT(R15)  + LEN OF PREFIX
         SR    R15,R0         TOTAL LENGTH - OFFSET = LENGTH TO DUMP
         SLL   R0,16          MOVE OFFSET TO PROPER POSITION
         OR    R0,R15         INSERT INTO LENGTH REG
         L     R15,=V(HEXDUMP) ADDRESS OF DUMP ROUTINE
         BALR  R14,R15        LINK TO IT
STOP     QSTOP
***********************************************************************
*                                                                     *
*   EXCEPTIONS AND RETURN                                             *
*                                                                     *
***********************************************************************
TILTO    QTILT '*** INVALID OFFSET SPECIFIED ***'
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
OFFTR    TR    QPARM2,TABLEH       CONVERT TO HEX
OFFPACK  PACK  QDWORD(3),QPARM2(1) PACK TO WORK AREA
         LTORG
* TABLE FOR HEX CONVERT
TABLEH   DC    CL193' '
         DC    X'0A0B0C0D0E0F',CL41' ',C'01234567890',CL6' '
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
CJCT     CSECT ,                                                  UF023
        $BUFFER
        $JQE
JCT      EQU   0
        $JCT
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q31
CTSO     QSTART 'ISSUE TSO COMMANDS WHILE IN QUEUE COMMAND.'      UF017
         USING WORK,R13       BASE FOR WORK AREA
         L     R10,QVCKPT     BASE FOR CKTP AREA
         USING QCKPT,R10      ADDRESSING FOR AREA
         L     R9,QVDSPL      BASE FOR DISPLAY AREA
         USING QDISPLAY,R9    ADDRESSING FOR AREA
         LA    R8,WCPPL       BASE FOR CPPL AREA
         USING CPPL,R8        ADDRESSING FOR AREA
         OC    QLNG1,QLNG1    TEST LENGTH OF COMMAND
         BZ    NOCMD          NONE, ABORT
         MVC   QDHLINE,QBLANK BLANK HEADING LINE
         TPUT  CLEAR,L'CLEAR,FULLSCR,MF=(E,QTPUT)  CLEAR THE SCREEN
*        STLINENO LINE=1,MODE=OFF  TURN OFF FULL SCREEN MODE
         MVC   WMODEL(WMODELEN),MODEL  COPY MODEL AREA TO DSECT AREA
         MVC   WBLDLFF,=AL2(1)  1 ENTRY IN LIST
         MVC   WBLDLLL,=AL2(12) 12 BYTES TO BE RETURNED
         L     R1,DAPLECT     POINT TO ECT
         USING ECT,R1         SET TEMP ADDRESSING
         MVC   QDWORD,ECTPCMD SAVE PRIMARY COMMAND NAME
         MVC   QDWORK,ECTSCMD  AND SECONDARY COMMAND NAME
         DROP  R1             DROP TEMP ADDRESSING
         SPACE 1
         MVC   CPPLUPT,DAPLUPT   COPY UPT POINTER
         MVC   CPPLPSCB,DAPLPSCB COPY PSCB POINTER
         MVC   CPPLECT,DAPLECT   COPY ECT POINTER
         SPACE 1
         LA    R15,QDREPLY    POINT TO COMMAND LINE
         AH    R15,QOFF1      POINT TO 1ST PARM (AFTER "TSO")
         SH    R15,=H'4'      BACK UP FOR BUFFER HEADER
         USING CMDBUF,R15     TEMP ADDRESSING FOR BUFFER
         LH    R14,QDRLNG     LENGTH OF REPLY
         SH    R14,QOFF1      - OFFSET TO OPERAND = TEXT LENGTH
         LA    R14,4(,R14)    + HEADER
         STH   R14,CMDLEN     SAVE AS LENGTH IN BUFFER
SCAN     ST    R15,CPPLCBUF   SET BUFFER CB POINTER
         XC    CMDOFF,CMDOFF  CLEAR OFFSET TO SECOND OPERAND
         DROP  R15            DROP TEMP ADDRESSING
         LA    R1,WCSPL       POINT TO IKJSCAN PARM LIST
         USING CSPL,R1        SET TEMP ADDRESSING
         L     R2,DAPLUPT     POINT TO UPT
         ST    R2,CSPLUPT
         L     R2,DAPLECT     POINT TO ECT
         ST    R2,CSPLECT
         LA    R2,WTCBECB     POINT TO ECB
         MVI   0(R2),0          CLEAR ECB
         ST    R2,CSPLECB
         LA    R2,WTCBADDR    WORD FOR FLAGS
         MVI   0(R2),0          CLEAR FLAGS
         ST    R2,CSPLFLG
         LA    R2,WCSOA       POINT TO OUTPUT AREA
         ST    R2,CSPLOA
         ST    R15,CSPLCBUF   COMMAND BUFFER ADDRESS TO CSPL
         DROP  R1             DROP TEMP ADDRESSING
         CALLTSSR EP=IKJSCAN  SCAN INPUT BUFFER
         LA    R1,WCSOA       POINT TO OUTPUT AREA
         USING CSOA,R1        SET TEMP ADDRESSING
         L     R14,CSOACNM    POINTER TO COMMAND NAME
         ICM   R15,3,CSOALNM  LENGTH OF NAME
         BZ    NOCMD2         NONE, SKIP REST
         BCTR  R15,0          DROP FOR EXECUTE
         DROP  R1             DROP TEMP ADDRESSING
         MVC   WBLDLNAM,QBLANK FILL WITH BLANKS
         EX    R15,MVCCMD      MOVE COMMAND TO WBLDLNAM
         CLC   =C'EX',QSUBNAME   IMPLICIT EXEC OF CLIST?
         BNE   NOTEXEC           NO, SKIP THIS
SETEXEC  NI    QSUBNAME,255-X'40'  DROP TO LOWER CASE
         MVC   WBLDLNAM,=CL8'EXEC' SET MODULE NAME TO ATTACH
         L     R1,CPPLCBUF       POINT TO BUFFER
         USING CMDBUF,R1         TEMP ADDRESSING
         XC    CMDOFF,CMDOFF     CLEAR OFFSET FOR EXEC
         B     OKATTACH       AND GO DO IT
         DROP  R1                DROP TEMP ADDRESSING
NOTEXEC  DS    0H
         BLDL  0,WBLDLPRM     CHECK FOR MODULE PRESENT
         LTR   R15,R15        CHECK RETURN CODE
         BNZ   SETEXEC        NONE, MUST BE CLIST
         SPACE 1
OKATTACH L     R1,DAPLECT     POINT TO ECT
         USING ECT,R1         SET TEMP ADDRESSING
         MVC   ECTPCMD,WBLDLNAM FAKE PRIMARY COMMAND NAME
         MVC   ECTSCMD,QBLANK AND SECONDARY COMMAND NAME
         DROP  R1             DROP TEMP ADDRESSING
         SPACE 1
         MVI   WTCBECB,0      CLEAR ECB
         LA    R1,WCPPL       CPPL PTR FOR COMMAND
ATTACH   DS    0H
         ATTACH EPLOC=WBLDLNAM,ECB=WTCBECB,                            +
               MF=(1,(1)),SF=(E,WATTL)
         ST    R1,WTCBADDR    SAVE TCB ADDR
WAIT     DS    0H
         WAIT  ECB=WTCBECB    WAIT
DETACH   DS    0H
         DETACH WTCBADDR
         SPACE 1
NOCMD2   DS    0H
         ICM   R1,15,WGTPB+4  ADDRESS OF GETLINE BUFFER
         BZ    NOFREE         NONO, SKIP FREEMAIN
         LH    R0,0(R1)       LENGTH OF BUFFER
         ICM   R0,B'1000',=X'01'  SUBPOOL 1
         FREEMAIN R,LV=(0),A=(1)  FREE THE BUFFER
         SPACE 1
NOFREE   L     R1,DAPLECT     POINT TO ECT
         USING ECT,R1         TEMP ADDRESSING
         L     R1,ECTIOWA     --> I/O WORK AREA
         DROP  R1             DROP TEMP ADDRESSING
         L     R1,0(R1)       --> TO ELEMENT ON STACK
         TM    0(R1),X'40'    FROM STORAGE (CLIST)?
         BZ    DONE           NO, DONE WITH PROCESSING
         LA    R1,WIOPL       ADDRESS OF IO PARM LIST
         L     R2,CPPLUPT     ADDRESS OF UPT
         L     R3,CPPLECT     ADDRESS OF ECT
         LA    R4,WTCBECB     ADDRESS OF ECB
         MVI   WTCBECB,0      CLEAR ECB
         GETLINE PARM=WGTPB,UPT=(R2),ECT=(R3),ECB=(R4),MF=(E,(1))
         CH    R15,=H'16'     END OF INPUT?
         BE    DONE           YES, CLEAN UP AND RETURN
         LA    R1,WGTPB       POINT TO GETLINE PARM LIST
         USING GTPB,R1        TEMP ADDRESSING
         L     R15,GTPBIBUF   POINT TO INPUT BUFFER
         DROP  R1             DROP TEMP ADDRESSING
         B     SCAN           AND GO TO SCAN PROCESSING
         SPACE 1
DONE     L     R1,DAPLECT     POINT TO ECT
         USING ECT,R1         SET TEMP ADDRESSING
         MVC   ECTPCMD,QDWORD RESTORE PRIMARY COMMAND NAME
         MVC   ECTSCMD,QDWORK  AND SECONDARY COMMAND NAME
         DROP  R1             DROP TEMP ADDRESSING
TPUT     DS    0H
*        TPUT  DONEMSG,L'DONEMSG  ASK FOR ENTER WHEN DONE
TGET     DS    0H
*        TGET  QDWORD,L'QDWORD,EDIT,MF=(E,QTGET)  READ RESPONCE
*        STFSMODE ON          RESTORE FULL SCREEN MODE
QSTOP    DS    0H
         QSTOP
         SPACE 1
NOCMD    QTILT '*** NO COMMAND SPECIFIED ***'
         SPACE 1
MVCCMD   MVC   WBLDLNAM(*-*),0(R14) MOVE COMMAND TO WBLDLNAM
         SPACE 1
DONEMSG  DC    C'*** PRESS ENTER TO RETURN TO QUEUE COMMAND ***'
CLEAR1   EQU   *
*        DC    X'27F5C1
         DC    X'115D7E'
         DC    X'114040'
         DC    X'3C404000'
         DC    X'1DC8'
         DC    X'13'
CLEAR    EQU   CLEAR1,*-CLEAR1
         SPACE 1
MODEL    DS    0D
MGTPB    GETLINE MF=L
MATTL    ATTACH SHSPV=78,     NEEDED TO PREVENT S305 ABENDS            +
               SF=L
MODELEN  EQU   *-MODEL        LENGTH OF MODEL AREA
         SPACE 1
         LTORG
         SPACE  1
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
WORK     DSECT ,              .
         DS    18F            SAVE AREA
         DS    0D
WMODEL   DS    0D             START OF MODEL AREA
WGTPB    GETLINE MF=L
WATTL    ATTACH  SF=L
WMODELEN EQU   *-WMODEL       CHECK FOR SAME LENGTH.
         SPACE 1
WTCBADDR DC    A(0)           ADDRESS OF CREATED TASK
WTCBECB  DC    A(0)           COMPLETION CONTROL BLOCK.
WCPPL    DS    4F             SPACE FOR CPPL TO BE PASSED TO CMD
WPARML   DS    12F            SPACE FOR PARM LISTS
WIOPL    EQU   WPARML,16      IO PARM LIST FOR GETLINE
WCSPL    EQU   WPARML,24      PARM LIST FOR IKJSCAN
WCSOA    EQU   WPARML+24,8    OUTPUT AREA FROM IKJSCAN
         SPACE 1
         DS    0F
WBLDLPRM DS    XL16           WORK AREA FOR BLDL
WBLDLFF  EQU   WBLDLPRM,2     NUMBER OF ENTRIES IN LIST
WBLDLLL  EQU   WBLDLPRM+2,2   LENGTH OF EACH ENTRY
WBLDLNAM EQU   WBLDLPRM+4,8   MEMBER NAME
WBLDLTTR EQU   WBLDLPRM+12,3  TTR OF START
WBLDLK   EQU   WBLDLPRM+15,1  CONCATENATION NUMBER
         SPACE 1
WORKLEN  EQU   *-WORK         LENGTH OF WORK AREA
         SPACE 1
         IKJCPPL  ,
         IKJCSOA  ,
         IKJCSPL  ,
         IKJECT   ,
         IKJGTPB  ,
         CVT   DSECT=YES
         SPACE 1
CMDBUF   DSECT
CMDLEN   DC    H'0'           LENGTH, INCLUDES HEADER (+4)
CMDOFF   DC    H'0'           OFFSET TO NONBLANK PAST COMMAND.
CMDTEXT  DC    C' '           FIRST TEXT BYTE.
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q32
CHCT     QSTART 'QUEUE COMMAND - DUMP A HCT IN HEX'               UF022
***********************************************************************
* HCT                                                                 *
***********************************************************************
*                                                                     *
*   CALL - READ JES2 CHECKPOINT ROUTINE                               *
*                                                                     *
***********************************************************************
         L     R15,=V(CKPT)        ADDR OF CKPT ROUTINE
         BALR  R14,R15             GO TO IT
***********************************************************************
*                                                                     *
*   CALL HEXDUMP TO DUMP THE HCT CHECKPOINT AREA                      *
*                                                                     *
***********************************************************************
         L     R10,QVCKPT     BASE FOR CKPT WORK AREA
         USING QCKPT,R10      ADDRESSING FOR IT
         L     R1,QCJQTL      ADDRESS OF HCT SAVEAREA
         LA    R0,$SAVEBEG-HCTDSECT  OFFSET TO START OF AREA
         LA    R15,$SAVELEN   LENGTH OF $SAVEAREA
         SLL   R0,16          MOVE OFFSET TO PROPER POSITION
         OR    R0,R15         INSERT INTO LENGTH REG
         L     R15,=V(HEXDUMP) ADDRESS OF DUMP ROUTINE
         BALR  R14,R15        LINK TO IT
STOP     QSTOP
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
CHCT     CSECT
         DROP
JCT      EQU   10
BASE1    EQU   11
SAVE     EQU   13
         GBLC  &VERSION
&VERSION SETC  '0'
$RPS     EQU   0
$MSGID   EQU   0
$DUPVOLT EQU   0
$PRIOOPT EQU   0
$PRTBOPT EQU   0
$PRTRANS EQU   0
$QSONDA  EQU   0
$CMBDEF  EQU   0
$JQEDEF  EQU   0
$MAXDA   EQU   32
$MAXJBNO EQU   0
$SMFDEF  EQU   0
$TGDEF   EQU   0
FF       EQU   255
        $BUFFER
        $JCT
        $CAT
        $JQE
        $PCE
        $HCT
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q33
CPDDB    QSTART 'QUEUE COMMAND - LIST PDDBS FOF A JOB'            UF025
***********************************************************************
*                                                                     *
*        PDDB JOBNAME <PDDB#>                                         *
*                                                                     *
* DISPLAY LIMITED INFORMATION ABOUT ALL OF THE PDDB'S FOR A JOB       *
*                                                                     *
* IF THE OPTIONAL PDDB NUMBER IS SPECIFIED, ONLY THAT PDDB WILL       *
* BE DUMPED IN HEX.                                                   *
*                                                                     *
***********************************************************************
         GBLB  &QJTIP             JTIP OPTION, DEFINED BY QSTART
         USING QCKPT,R10          BASE REG FOR CHECKPONT WORK AREA
         L     R10,QVCKPT         LOAD BASE REG
         USING QDISPLAY,R9        BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL          LOAD BASE REG
         USING WORK,R13           BASE REG FOR LOCAL WORK AREA
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JCT                                    *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB)    ADDR OF MODULE TO FIND JOB
         BALR  R14,R15            GO TO IT
***********************************************************************
*                                                                     *
*   FIND ALL PDDBS FOR THIS JOB                                       *
*                                                                     *
***********************************************************************
         USING PDBDSECT,R2        BASE REG FOR PDDB
         USING IOTSTART,R3        BASE REG FOR IOT
         MVC   QDHLINE,HEADING    SET HEADING LINE
         MVI   SWITCH,0           CLEAR FLAG BYTE
         L     R3,QCIOTA          LOAD BASE REG
         LR    R5,R3              IOAREA FOR READ IOT BLOCK
         USING JCTSTART,R1        SET TEMP ADDRESSING
         L     R1,QCJCTA          POINT TO JCT
         L     R4,JCTIOT          FIRST IOT ADDRESS
         DROP  R1                 DROP TEMP ADDRESSING
         BAL   R8,READ            READ THE IOT
         SPACE 1
         LH    R6,QLNG2           WAS A PDDB SPECIFIED?
         LTR   R6,R6
         BZ    NEXTIOT            NO, PROCEED NORMALLY
         BCTR  R6,0               DROP FOR EXECUTES
         MVC   QFZONES,QFZONE     PREPARE FOR NUMERIC TEST
         EX    R6,MVZ             MOVE ZONES FOR TEST
         CLC   QFZONES,QFZONE     ALL NUMERIC?
         BNE   TILT               NO, SKIP IT
         EX    R6,PACK            PACK TO DWORD
         CVB   R6,CONVERT         GET PDDB NUMBER
         OI    SWITCH,X'02'       AND INDICATE FOR LATER
         SPACE 1
NEXTIOT  LR    R4,R3              BASE OF IOT
         A     R4,IOTPDDBP        OFFSET BEYOND LAST PDDB
         LR    R2,R3              BASE OF IOT
         A     R2,QCPDDB1         OFFSET TO FIRST PDDB IN IOT
PDDBLOOP LH    R0,PDBDSKEY        GET THE DSID
         TM    SWITCH,X'02'       ONLY WANT ONE PDDB?
         BZ    PDDBLP1            NO, SKIP SPECIAL TEST
         CR    R0,R6              FOUND RIGHT PDDB?
         BNE   NEXTPDDB           NO, TRY NEXT ONE
         LR    R1,R2              POINT TO PDDB
         LA    R0,PDBLENG         LENGTH OF PDDB
         L     R15,=V(HEXDUMP)    POINT TO DISPLAY ROUTINE
         BALR  R14,R15            AND LINK TO IT
         B     NEXTPDDB           JUST INCASE MULTIPLE PDDBS (SYSLOG)
         SPACE 1
PDDBLP1  MVC   QDMSG,QBLANK       BLANK WORK LINE AREA
         LTR   R0,R0              TEST FOR NULL PDDB#
         BZ    NEXTPDDB           SKIP IF SO
         CVD   R0,CONVERT         CONVERT TO DECIMAL
         MVC   DSID-4(8),ED8      MOVE EDIT PATTERN TO DISPLAY
         ED    DSID-4(8),CONVERT+4  EDIT THE DSID
         UNPK  DSFLAG1(3),PDBFLAG1(2)  HEX OF FLAG BYTE
         TR    DSFLAG1,HEXTAB     MAKE PRINTABLE
         MVI   DSFLAG1+2,C' '     CLEAR TRASH BYTE
         L     R0,PDBRECCT        GET THE RECORD COUNT
         CVD   R0,CONVERT         CONVERT TO DECIMAL
         MVC   DSRECCT,ED8        MOVE EDIT PATTERN TO DISPLAY
         ED    DSRECCT,CONVERT+4  EDIT THE RECORD COUNT
         MVC   DSCLASS,PDBCLASS   MOVE PDBCLASS TO DISPLAY
         UNPK  DSMTTR(9),PDBMTTR(5)  UNPACK MTTR TO DISPLAY
         TR    DSMTTR,HEXTAB      MAKE PRINTABLE
         MVI   DSMTTR+9,C' '      CLEAR JUNK BYTE
         AIF   (NOT &QJTIP).JTIP1
         MVC   DS#PROC,PDB#PROC   SET JTIP PROC NAME
         MVC   DS#STEP,PDB#STEP   SET JTIP STEP NAME
         MVC   DS#DDNM,PDB#DDN    SET JTIP DD NAME
.JTIP1   ANOP
         MVC   QDMLNG,=H'80'      SET THE LENGTH
         LA    R0,QDMSG           POINT TO MESSAGE
         ST    R0,QDMSGA          SET IN AREA
         L     R15,=V(DISPLAY)    POINT TO DISPLAY ROUTINE
         BALR  R14,R15            LINK TO IT
NEXTPDDB LA    R2,PDBLENG(R2)     POINT TO NEXT PDDB
         CR    R2,R4              HAVE WE GONE PAST THE LAST PDDB
         BL    PDDBLOOP           NO. KEEP TRYING
         L     R4,IOTIOTTR        DISK ADDR OF NEXT IOT
SPIN     LTR   R4,R4              IS THERE ANOTHER IOT?
         BZ    SPINIOT            NO. TRY THE SPIN IOT.
         BAL   R8,READ            READ THE IOT
         B     NEXTIOT            SEARCH THE NEXT IOT
         USING JCTSTART,R1        BASE REG FOR JCT
SPINIOT  TM    SWITCH,1           DID WE SEARCH THE SPINIOT ALREADY
         BO    STOP               YES, DONE
         OI    SWITCH,1           SET SWITCH
         L     R1,QCJCTA          LOAD BASE REG
         L     R4,JCTSPIOT        DISK ADDR OF SPIN IOT
         B     SPIN               SEARCH THE SPIN IOT CHAIN
         DROP  R1
STOP     QSTOP                    GO BACK TO CALLER
***********************************************************************
*                                                                     *
*   READ A BLOCK FROM HASPACE                                         *
*                                                                     *
***********************************************************************
READ     ST    R4,QCTRAK          STORE DISK ADDR
         LR    R1,R5              IOAREA ADDRESS
         L     R15,=V(READSPC)    ADDR OF ROUTINE TO READ HASPACE
         BALR  R14,R15            GO TO IT
         BR    R8                 RETURN TO CALLER
ED8      DC    X'4020202020202120'
MVZ      MVZ   QFZONES(1),QPARM2
PACK     PACK  CONVERT,QPARM2(1)
HEXTAB   EQU   *-X'F0'
         DC    C'0123456789ABCDEF'
TILT     QTILT 'INVALID PDDB# SPECIFIED'
HEADING  DC    CL80' '
         ORG   HEADING            POINT TO START OF AREA
         DC    C'    DSID'
         DC    C' F1'             FLAG BYTE 1
         DC    C'  RECORDS'
         DC    C' C'              CLASS
         DC    C'   MTTR  '       MTTR
         AIF   (NOT &QJTIP).JTIP2
         DC    C' PROCNAME'
         DC    C' STEPNAME'
         DC    C' DDNAME  '
.JTIP2   ANOP
         ORG   ,                  BACK TO NORMAL ADDRESSING
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
FINDPDDB CSECT ,                                                  UF023
JCT      EQU   0
BUFSTART EQU   0
BUFDSECT EQU   0
         $TAB
         $JCT
         $PDDB
         $IOT
WORK     DSECT
         DS    CL72
SWITCH   DS    C
CONVERT  DS    D
         QCOMMON
         ORG   QDMSG
         DS    CL4
DSID     DS    CL4
         DS    CL1
DSFLAG1  DS    CL2
         DS    CL1
DSRECCT  DS    CL8
         DS    CL1
DSCLASS  DS    CL1
         DS    CL1
DSMTTR   DS    CL8
         AIF   (NOT &QJTIP).JTIP3
         DS    CL1
DS#PROC  DS    CL8
         DS    CL1
DS#STEP  DS    CL8
         DS    CL1
DS#DDNM  DS    CL8
.JTIP3   ANOP
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q34
CJOE     QSTART 'QUEUE COMMAND - DUMP A JOE IN HEX'               UF026
         GBLB  &QSP           MVS/SP OPTION
         AIF   (&QSP).SPOK
         QTILT 'JOE COMMAND ONLY SUPPORT UNDER SP VERSION OF QUEUE'
         AGO   .BYEBYE                                            VBA01
.SPOK    ANOP
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE                                    *
*                                                                     *
***********************************************************************
FINDJQE  L     R15,=V(FINDJOB) ADDR OF MODULE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   CALL HEXDUMP TO DUMP THE JOES                                     *
*                                                                     *
***********************************************************************
         L     R10,QVCKPT     BASE FOR CKPT WORK AREA
         USING QCKPT,R10      ADDRESSING FOR IT
         L     R1,QCJQEA      ADDRESS OF JQE
         USING JQEDSECT,R1    ADDRESSING FOR JQE
         SR    R2,R2          CLEAR WORK REG
         ICM   R2,7,JQEJOEB   OFFSET TO FIRST WORK JOE
         BNZ   JOELOOP        CONTINUE IF ANY
         QTILT 'JOB HAS NO JOES'
         DROP  R1             DROP JQE ADDRESSING
         USING JOEDSECT,R2    ADDRESSING FOR JOE
         SPACE 1
JOELOOP  A     R2,QCJOTA      ADD TO GET ACTUAL ADDRESS
         LA    R1,MSGJWORK    WORK JOE MESSAGE
         ST    R1,QDMSGA      SAVE MESSAGE ADDRESS
         LA    R1,L'MSGJWORK  LENGTH OF MESSAGE
         STH   R1,QDMLNG      SAVE FOR DISPLAY ROUTINE
         L     R15,=V(DISPLAY) ADDRESS OF DISPLAY ROUTINE
         BALR  R14,R15        LINK TO IT
         LR    R1,R2          POINTER TO JOE TO DUMP
         LA    R0,JOE1END-JOEDSECT ACTUAL LENGTH OF WORK JOE
         L     R15,=V(HEXDUMP) ADDR OF HEXDUMP MODULE
         BALR  R14,R15        GO TO IT
         SPACE 1
         LA    R1,MSGJCHAR    CHAR JOE MESSAGE
         ST    R1,QDMSGA      SAVE MESSAGE ADDRESS
         LA    R1,L'MSGJCHAR  LENGTH OF MESSAGE
         STH   R1,QDMLNG      SAVE FOR DISPLAY ROUTINE
         L     R15,=V(DISPLAY) ADDRESS OF DISPLAY ROUTINE
         BALR  R14,R15        LINK TO IT
         ICM   R1,7,JOECHARB  POINTER TO CHARACTERISTICS JOE
         A     R1,QCJOTA      ADD TO GET ACTUAL ADDRESS
         LA    R0,JOE2END-JOEDSECT ACTUAL LENGTH OF CHAR JOE
         L     R15,=V(HEXDUMP) ADDR OF HEXDUMP MODULE
         BALR  R14,R15        GO TO IT
         SPACE 1
         LA    R1,MSGJCKPT    CKPT JOE MESSAGE
         ST    R1,QDMSGA      SAVE MESSAGE ADDRESS
         LA    R1,L'MSGJCKPT  LENGTH OF MESSAGE
         STH   R1,QDMLNG      SAVE FOR DISPLAY ROUTINE
         ICM   R1,7,JOECKPTB  POINTER TO CKPT JOE
         BZ    NEXTWORK       NONE, GET NEXT WORK JOB FOR THIS JOB
         L     R15,=V(DISPLAY) ADDRESS OF DISPLAY ROUTINE
         BALR  R14,R15        LINK TO IT
         A     R1,QCJOTA      ADD TO GET ACTUAL ADDRESS
         LA    R0,JOE3END-JOEDSECT ACTUAL LENGTH OF CKPT JOE
         L     R15,=V(HEXDUMP) ADDR OF HEXDUMP MODULE
         BALR  R14,R15        GO TO IT
         SPACE 1
NEXTWORK ICM   R2,7,JOEJQNXB  GET NEXT WORK JOE FOR THIS JOB
         BNZ   JOELOOP          AND DUMP IT
.BYEBYE  ANOP                                                     VBA01
         QSTOP
MSGJWORK DC    C'*** WORK JOE ***'
MSGJCHAR DC    C'*** CHAR JOE ***'
MSGJCKPT DC    C'*** CKPT JOE ***'
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
CJOE     CSECT ,                                                  UF023
        $JOE
        $JQE
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q4
DDNAME   QSTART 'QUEUE COMMAND - LIST DDNAMES AND DSIDS FOR A JOB'
***********************************************************************
* RNB CHANGES:                                                        *
*      (1) RNB11 - ALLOW COMMAND OF FORM   DD NAME S  WHERE S MEANS   *
*                  TO LIST THE SPIN DATA SETS EVEN IF A BATCH JOB.    *
*                  ADDED BECAUSE OUR IMS SYSTEM SPINS OFF DUMP DATA   *
*                  SETS THAT WE WANT TO LOOK AT.                      *
*      (2) RNB12 - WITH SP2 JES2 WE ALWAYS SEEM TO GET THE 'ALREADY   *
*                  PRINTED' MESSAGE FOR SPIN DATA SETS. THIS CHANGE   *
*                  BYPASSES THE MESSAGE IF QSP=1.                     *
***********************************************************************
         GBLB  &QRNB                                              RNB11
         GBLB  &QSP                                               RNB12
         USING QCKPT,R10      BASE REG FOR CHECKPOINT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING QDISPLAY,R9    BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL      LOAD BASE REG
         USING WORK,R13
***********************************************************************
*                                                                     *
*   CALL FINDJOB TO LOCATE THE JQE, JCT, AND IOT                      *
*                                                                     *
***********************************************************************
         L     R15,=V(FINDJOB) ROUTINE TO FIND JOB
         BALR  R14,R15        GO TO IT
***********************************************************************
*                                                                     *
*   DETERMINE JOB TYPE (BATCH OR TSO)                                 *
*                                                                     *
***********************************************************************
         USING JCTSTART,R1    BASE REG FOR JCT
         USING PDBDSECT,R2    BASE REG FOR PDDB
         USING IOTSTART,R3    BASE REG FOR IOT
         L     R1,QCJCTA      A(JCT)
         CLI   QPARM2,C'S'                                        RNB11
         BE    DDTSO                                              RNB11
         CLC   JCTJOBID(3),=CL3'TSU' ?/TSO USER
         BE    DDTSO          YES. GO PROCESS
         CLC   JCTJOBID(3),=CL3'STC' ?/STARTED TASK
         BE    DDTSO          YES. GO PROCESS
***********************************************************************
*                                                                     *
*   LOCATE PDDB NUMBER 5                                              *
*                                                                     *
***********************************************************************
DDJOB    L     R3,QCIOTA      LOAD BASE REG
         LR    R4,R3          BASE OF IOT
         A     R4,IOTPDDBP    OFFSET BEYOND LAST PDDB
         LR    R2,R3          BASE OF IOT
         A     R2,QCPDDB1     OFFSET TO FIRST PDDB IN IOT
         MVC   QPDSID,=H'0'   NULLIFY VALIDITY FOR LISTDS
FINDDS   CLC   =H'5',PDBDSKEY IS THIS THE DATASET?
         BE    FOUNDDS        YES. CONTINUE.
         LA    R2,PDBLENG(R2) NO. LOOK AT NEXT PDDB.
         CR    R2,R4          HAVE WE GONE PAST THE LAST PDDB?
         BL    FINDDS         NO. TRY AGAIN.
         QTILT '*** JOB DOES NOT HAVE DD TABLE ***'
FOUNDDS  L     R4,PDBMTTR     DISK ADDR OF FIRST BLOCK
         L     R5,QCBLKA      ADDR OF DATASET BLOCK IOAREA
         MVC   QDMSG,QBLANK   BLANK OUT THE MESSAGE AREA
         B     FIRST          PROCESS DATASET
CPTSOID  CLC   QLOGON(0),QPARM1  IS PARM THE USER'S TSOID.
***********************************************************************
*                                                                     *
*   PROCESS DATASET                                                   *
*                                                                     *
***********************************************************************
NEXTBLK  L     R4,0(R5)       DISK ADDR OF NEXT BLOCK
FIRST    LTR   R4,R4          IS THE DISK ADDR ZERO?
         BZ    END            YES. END OF DATASET.
         BAL   R8,READ        READ A BLOCK
         CLC   QPJOBID,4(R5)  DOES THE JOBID MATCH?
         BNE   END            NO. END OF DATASET.
         CLC   =H'5',8(R5)    IS THE DSID 5?
         BNE   END            NO. END OF DATASET.
         LA    R4,10(R5)      ADDR OF FIRST RECORD IN BLOCK
***********************************************************************
*                                                                     *
*   PROCESS RECORDS                                                   *
*                                                                     *
***********************************************************************
NEXTREC  CLI   0(R4),X'FF'    IS LENGTH BYTE FF?
         BE    NEXTBLK        YES. END OF BLOCK.
         TM    1(R4),X'10'    IS THIS A SPANNED RECORD?
         BO    SPAN           YES. SKIP IT.
         SR    R6,R6          ZERO OUT REG
         IC    R6,0(R4)       INSERT LENGTH
         TM    5(R4),2        IS THIS AN EXEC RECORD?
         BO    EXEC           YES. PROCESS IT.
         TM    5(R4),4        IS THIS A DD RECORD?
         BO    DD             YES. PROCESS IT.
SKIPREC  LA    R4,3(R6,R4)    INCREMENT TO NEXT RECORD
         B     NEXTREC        PROCESS NEXT RECORD
SPAN     LH    R6,2(R4)       LENGTH OF SEGMENT
         TM    1(R4),X'08'    IS THIS THE FIRST SEGMENT?
         BO    SPANFRST       YES. USE HEADER LENGTH OF 6.
         LA    R4,4(R6,R4)    INCREMENT TO NEXT RECORD
         B     NEXTREC        PROCESS NEXT RECORD
SPANFRST LA    R4,6(R6,R4)    INCREMENT TO NEXT RECORD
         B     NEXTREC        PROCESS NEXT RECORD
END      QSTOP
***********************************************************************
*                                                                     *
*   PROCESS AN EXEC RECORD                                            *
*                                                                     *
***********************************************************************
EXEC     MVC   STEPNAME,QBLANK BLANK OUT THE STEPNAME
         CLI   7(R4),X'94'    IS THERE A STEPNAME?
         BNE   SKIPREC        NO. SKIP THE REST.
         SR    R1,R1          ZERO OUT R1
         IC    R1,9(R4)       LENGTH OF STEPNAME
         SH    R1,=H'1'       DECREMENT BY 1
         BM    SKIPREC        STEPNAME WAS ZERO LENGTH.
         EX    R1,MVCSTEP     MOVE THE STEPNAME
         B     SKIPREC        CONTINUE PROCESSING
***********************************************************************
*                                                                     *
*   PROCESS DD RECORDS                                                *
*                                                                     *
***********************************************************************
DD       TM    6(R4),X'30'    IS THIS A SYSIN OR SYSOUT DD?
         BZ    SKIPREC        NO. SKIP THE RECORD.
         MVC   DDN,QBLANK     BLANK OUT THE DDNAME
         MVC   DSID,QBLANK    BLANK OUT THE DSID
         MVC   DSRECCT,QBLANK BLANK OUT THE DS RECORD COUNT
         MVC   DSCLASS,QBLANK BLANK OUT THE DS CLASS
         LA    R7,7(R4)       ADDR OF FIRST KEY
         LR    R8,R6          REMAINING LENGTH OF RECORD
         SR    R15,15         ZERO OUT R15
         SR    R14,R14        ZERO OUT R14
         SR    R1,R1          ZERO OUT R1
TRYFLD   CLI   0(R7),X'6E'    IS THIS THE DDNAME?
         BE    DDKEY          YES. PROCESS IT.
         CLI   0(R7),X'4A'    IS THIS THE DSNAME?
         BNE   NEXTFLD        NO. GET NEXT FIELD
         CLC   3(3,R7),=C'JES' YES. IS THIS TRULY A JES2 SYSIN/OUT DS?
         BE    DSKEY          YES. PROCESS IT.
NEXTFLD  IC    R1,1(R7)       NUMBER OF SUBFIELDS
         LA    R7,2(R7)       UPDATE LOCATION
         SH    R8,=H'2'       REMAINING COUNT
         SR    R8,R1          REMAINING COUNT
         BNP   SKIPREC        RECORD IS EXHAUSTED
         LTR   R1,R1          ARE THERE ANY SUBFIELDS?
         BZ    TRYFLD         NO. TRY NEXT FIELD.
LOOPFLD  TM    0(R7),X'80'    IS THIS A SUB-SUB-FIELD
         BZ    NOSUB          NO. CONTINUE.
         NI    0(R7),X'7F'    CLEAR THE HEX 80 BIT
         IC    R14,0(R7)      NUMBER OF SUB-SUB-FIELDS
         LA    R7,1(R7)       UPDATE LOCATION
         SH    R8,=H'1'       REMAINING COUNT
         SR    R8,R14         REMAINING COUNT
         BNP   SKIPREC        RECORD IS EXHAUSTED
         AR    R1,R14         INCREASE NUMBER OF SUBFIELDS
         B     YESSUB         DECREMENT AND TRY AGAIN
NOSUB    IC    R15,0(R7)      SUBFIELD LENGTH
         LA    R7,1(R15,R7)   ADD TO LOCATION
         SR    R8,R15         REMAINING COUNT
         BNP   SKIPREC        RECORD IS EXHAUSTED
YESSUB   BCT   R1,LOOPFLD     DO NEXT SUBFIELD
         B     TRYFLD         TRY NEXT FIELD
DDKEY    IC    R1,2(R7)       LENGTH OF DDNAME
         LTR   R1,R1          IS THE LENGTH ZERO?
         BZ    NEXTFLD        YES. SKIP THE FIELD.
         BCTR  R1,0           DECREMENT BY 1
         EX    R1,MVCDDN      MOVE THE DDNAME
         B     NEXTFLD        PROCESS NEXT FIELD
DSKEY    MVC   DSID+1(3),20(R7)  MOVE THE DSID
         L     R15,=V(FINDPDDB) ADDR OF FINDPDDB MODULE
         BALR  R14,R15        GO TO IT
         MVC   QDHLINE,HEADING MOVE IN HEADING
         LA    R1,QDMSG       ADDR OF MESSAGE LINE
         ST    R1,QDMSGA      STORE IN MESSAGE ADDR
         MVC   QDMLNG,=H'80'  MESSAGE LENGTH
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE
         BALR  R14,R15        GO TO IT
         B     SKIPREC        PROCESS NEXT RECORD
***********************************************************************
*                                                                     *
*   PROCESS DD TSU                                                    *
*                                                                     *
***********************************************************************
DDTSO    L     R5,QCBLKA      ADDR OF DATASET BLOCK IOAREA
         LR    R3,R5          BASE OF IOAREA
         L     R4,JCTSPIOT    ADDR OF FIRST SPIN IOT
TSO010   LTR   R4,R4          IS IOT ADDR ZERO?
         BZ    DDJOB          YES, GO READ REGULAR IOT'S
         BAL   R8,READ        READ IOT
         LR    R4,R3          BASE OF IOT
         A     R4,IOTPDDBP    OFFSET BEYOND LAST PDDB
         LR    R2,R3          BASE OF IOT
         A     R2,QCPDDB1     OFFSET TO FIRST PDDB IN IOT
TSO020   CLI   PDBFLAG1,X'00' IS THIS PDDB VALID
         BE    TSO040         NO, GET NEXT IOT
         MVC   QDMSG,QBLANK   BLANK MESSAGE LINE
         MVC   DDN,=CL8'SPIN-DS'      MOVE IN DDNAME
         SR    R0,R0          CLEAR REG 0
         LH    R0,PDBDSKEY    CONVERT
         CVD   R0,CONVERT        DATA SET
         MVC   DSID,ED4               ID  TO
         ED    DSID,CONVERT+6             ZERO
         L     R0,PDBRECCT    CONVERT
         CVD   R0,CONVERT        RECORD
         MVC   DSRECCT,ED8          COUNT TO
         ED    DSRECCT,CONVERT+4        CHARACTER
         MVC   DSCLASS,PDBCLASS  MOVE IN SYSOUT CLASS
         AIF   (&QSP).RNB12A                                      RNB12
         TM    PDBFLAG1,PDB1PSO  HAS DATA SET BEEN PRINTED
         BO    TSO030         NO
         MVC   MESSAGE,PRTMSG INDICATE DATA SET PRINTED
.RNB12A  ANOP
TSO030   MVC   QDHLINE,HEADING MOVE IN HEADING
         LA    R1,QDMSG       ADDR OF MESSAGE LINE
         ST    R1,QDMSGA      STORE IN MESSAGE ADDR
         MVC   QDMLNG,=H'80'  MESSAGE LENGTH
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE
         BALR  R14,R15        GO TO IT
         LA    R2,PDBLENG(R2) LOOK AT NEXT PDDB
         CR    R2,R4          HAVE WE GONE PAST THE LAST PDDB
         BL    TSO020         NO, TRY AGAIN
TSO040   L     R4,IOTIOTTR    DISK ADDR OF NEXT IOT
         B     TSO010         GO SEARCH THE NEXT IOT
***********************************************************************
*                                                                     *
*   READ A BLOCK FROM HASPACE                                         *
*                                                                     *
***********************************************************************
READ     ST    R4,QCTRAK      STORE DISK ADDR
         LR    R1,R5          IOAREA ADDRESS
         L     R15,=V(READSPC) ADDR OF ROUTINE TO READ HASPACE
         BALR  R14,R15        GO TO IT
         BR    R8             RETURN TO CALLER
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
MVCSTEP  MVC   STEPNAME(1),10(R4)
MVCDDN   MVC   DDN(1),3(R7)
HEADING  DC    CL80'STEPNAME    DDNAME      DSID      LINES   CLASS'
ED4      DC    X'40202120'
ED5      DC    X'4020202120'
ED8      DC    X'4020202020202120'
PRTMSG   DC    CL15'ALREADY PRINTED'
         DROP  ,                   DROP ALL ADDRESSINGS           NERDC
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
DDNAME   CSECT ,                                                  UF023
JCT      EQU   0
BUFSTART EQU   0
BUFDSECT EQU   0
         $TAB
         $JCT
         $PDDB
         $IOT
WORK     DSECT
         DS    CL72
CONVERT  DS    D
         QCOMMON
         ORG   QDMSG
STEPNAME DS    CL8
         DS    CL4
DDN      DS    CL8 END OF DATA. LAST REC #'
         DS    CL4
DSID     DS    CL4
         DS    CL4
DSRECCT  DS    CL8
         DS    CL4
DSCLASS  DS    CL1
         DS    CL6
MESSAGE  DS    CL15
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q5
DISPLAY  QSTART 'QUEUE COMMAND - 3270 DISPLAY ROUTINES'
***********************************************************************
* RNB CHANGES:                                                        *
*     (1) RNB13 - MODIFICATIONS TO FIX PROBLEMS WITH TCAM FULL-SCREEN *
*                 PROCESSING OF TEST-REQUEST, SYSTEM REQUEST, AND THE *
*                 PA2/PA3 KEYS.                                       *
*     (2) RNB14 - MODIFICATIONS TO FIX PROBLEMS FULL-SCREEN           *
*                 PROCESSING. THIS ONE ALLOWS THE USER TO TYPE IN THE *
*                 TOP COMMAND LINE WITHOUT QUEUE MISINTERPRETING WHAT *
*                 WAS ENTERED. (TRY THE DO COMMAND FROM BOTH PLACES   *
*                 WITHOUT THE MOD TO SEE THE EFFECT.)                 *
*     (3) RNB15 - RESTORE PFK DEFINITIONS FOR PF7 AND PF8 TO ORIGINAL *
*                 ICBC VALUES OF -27 AND +27. WE DON'T HAVE THE OTHER *
*                 3278 MODELS, AND PARTIAL SCROLLING IS EASIER AND    *
*                 MORE SPF CONSISTENT WITH THE ORIGINAL VALUES. ONLY  *
*                 IF QRNB=1.                                          *
***********************************************************************
         GBLB  &QPFK          PF-KEY OPTION. DEFINED BY QSTART     ICBC
         GBLB  &QRNB                                              RNB13
         USING QDISPLAY,R10   BASE REG FOR DISPLAY WORK AREA
         L     R10,QVDSPL     ADDR OF DISPLAY WORK AREA
         USING QCPRINT,R9     BASE REG FOR PRINT   WORK AREA       FCI*
         L     R9,QVPRINT     ADDR OF PRINT   WORK AREA            FCI*
***********************************************************************
*                                                                     *
*   CHECK FOR ROOM ON SCREEN                                          *
*                                                                     *
***********************************************************************
         MVI   QDOVER,0       ZERO OUT THE PAGE OVERFLOW INDICATOR
         MVI   QDPLUS,C' '    BLANK THE OVERFLOW INDICATOR
         LH    R4,QDMLNG      LOAD MSG LENGTH
         CH    R4,QDSCRLEN    IS THE MSG LENGTH > SCRSIZE?        UF003
         BH    RETURN         YES. GO AWAY.
         MVC   QPRSAVE,QDTLINE        SAVE SUBTITLE LINE ON ENTRY  FCI*
         LTR   R4,R4          IS MSG LENGTH ZERO?
         BZ    WRTSCR         YES. WRITE SCREEN.
         MVI   QDPLUS,C'+'    INDICATE SCREEN OVERFLOW
         AH    R4,QDNEXT      ADD CURRENT LOCATION ON SCREEN
         CH    R4,QDSCRLEN    IS THERE ROOM ON THE SCREEN?        UF003
         BH    WRTSCR         NO. WRITE SCREEN.
***********************************************************************
*                                                                     *
*   MOVE THE MESSAGE TO THE SCREEN                                    *
*                                                                     *
***********************************************************************
DSP2     LH    R7,QDMLNG      LOAD MESSAGE LENGTH
         LTR   R7,R7          IS MESSAGE LENGTH ZERO?
         BZ    RETURN         YES. RETURN.
         LH    R4,QDNEXT      LOAD CURRENT SCREEN LINE NUMBER
         LR    R1,R4          SAVE LINE NUMBER
         LA    R4,QDLINE1(R4) LOAD ADDRESS OF NEXT LINE
         L     R6,QDMSGA      LOAD ADDR OF MESSAGE
         LH    R5,QDLNELEN    LENGTH MUST BE MULTIPLE OF LINESIZE UF003
DSP3     CR    R5,R7          IS 5 NOT LESS THAN 7?
         BNL   DSP4           YES. GO DO IT.
         AH    R5,QDLNELEN    INCR BY LINE LENGTH                 UF003
         B     DSP3           TRY AGAIN
DSP4     AR    R1,R5          UPDATE LINE NUMBER
         STH   R1,QDNEXT      STORE LINE NUMBER
         MVCL  R4,R6          MOVE THE MESSAGE TO THE SCREEN
***********************************************************************
*                                                                     *
*   RETURN TO CALLER                                                  *
*                                                                     *
***********************************************************************
RETURN   QSTOP
***********************************************************************
*                                                                     *
*   WRITE A FULL SCREEN, WAIT FOR REPLY                               *
*                                                                     *
***********************************************************************
WRTSCR   LA    R1,QDLINE1     ENSURE PRINTABILITY                 UF003
         LH    R15,QDSCRLEN   LENGTH TO XLATE                     UF003
         LA    R14,255        SET FOR EXECUTE                     UF003
WRTSCR1  CR    R15,R14        SEE IF ONLY ONE NEEDED              UF003
         BNH   WRTSCRN        YES, DO IT                          UF003
         EX    R14,WRTSCRTR   TRANSLATE PART OF BUFFER            UF003
         LA    R1,1(R1,R14)   POINT TO NEXT SLOT                  UF003
         SR    R15,R14        DROP FOR LENGTH DONE                UF003
         BCTR  R15,0          END FOR EXECUTE FIX                 UF003
         B     WRTSCR1        LOOP TILL DONE                      UF003
         SPACE 1                                                  UF003
WRTSCRTR TR    0(*-*,R1),TABLE  FIX UNPRINTABLES                  UF003
         SPACE 1                                                  UF003
WRTSCRN  BCTR  R15,0          DROP FOR EXECUTE                    UF003
         LTR   R15,R15        TEST FOR NULL                       UF003
         BM    *+8            SKIP IF NULL                        UF003
         EX    R15,WRTSCRTR   TRANSLATE END OF BUFFER             UF003
         SPACE 1                                                  UF003
TPUTSCRN DS    0H                                                 UF003
         LH    R0,QDSCRPLN    LOAD LENGTH FOR TPUT                UF003
         TPUT  QDSCREEN,(0),FULLSCR,MF=(E,QTPUT)                  UF003
         MVC   QDTLINE,QPRSAVE        RESTORE SUBTITLE INFO        FCI*
         AIF  (&QPFK).PFK1    SKIP NON-PFK CODE                    ICBC
         TGET  QDREPLY,63,EDIT,MF=(E,QTGET)
         CH    R15,=H'12'     IS INPUT LONGER THAN BUFFER?
         BNE   NOCLEAR        NO. CONTINUE.
         TCLEARQ INPUT        CLEAR THE QUEUE
NOCLEAR  STH   R1,QDRLNG      STORE LENGTH OF REPLY
         AGO   .PFK2                                               ICBC
.PFK1    ANOP                                                      ICBC
         LA    R6,QDREPLY                                          ICBC
         XC    PFREPLY,PFREPLY                                     ICBC
         XC    QDREPLY,QDREPLY                                     ICBC
         TGET  PFREPLY,69,ASIS,MF=(E,QTGET)
         CH    R15,=H'12'     IS INPUT LONGER THAN BUFFER?         ICBC
         BNE   NOCLEAR        NO. CONTINUE.                        ICBC
         TCLEARQ INPUT        CLEAR THE QUEUE                      ICBC
NOCLEAR  IC    R4,PFCODE                                           ICBC
         XR    R5,R5                                               ICBC
         CLI   PFCODE,X'F0'      TEST-REQ/SYS-REQ?                RNB13
         BE    ENTKEY            /YES - TREAT AS ENTER            RNB13
         CLI   PFCODE,X'01'      OTHER KIND OF SYS-REQ?           RNB13
         BE    ENTKEY            /YES - TREAT AS ENTER            RNB13
         CLI   PFCODE,X'6E'      PA2?                             RNB13
         BE    TPUTSCRN          /YES - GO RESHOW SCREEN          RNB13
         CLI   PFCODE,X'6B'      PA3?  (TCAM GENERATED)           RNB13
         BE    TPUTSCRN          /YES - GO RESHOW SCREEN          RNB13
         N     R4,=X'0000000F'   EXTRACT PF-KEY NUMBER             ICBC
         CH    R4,=H'12'                                           ICBC
         BH    ENTKEY           "ENTER" KEY                        ICBC
         BCTR  R4,0                                                ICBC
         MH    R4,=H'5'                                            ICBC
         LA    R5,PFKTAB                                           ICBC
         LA    R5,0(R4,R5)                                         ICBC
         MVC   QDREPLY(5),0(R5)  MOVE PF-KEY VALUE                 ICBC
         LA    R5,5                                                ICBC
         LA    R6,3(,R6)                                           ICBC
         SH    R1,=H'3'          ALLOW USER TO INPUT ON EITHER    RNB14
         BZ    NOTXT             THE TOP OR BOTTOM COMMAND LINE   RNB14
         MVC   0(60,R6),PFTXT                                     RNB14
         LA    R5,3                                               RNB14
         SH    R1,=H'3'                                           RNB14
         B     NOTXT                                              RNB14
ENTKEY   EQU   *                                                   ICBC
         SH    R1,=H'3'                                            ICBC
         BZ    NOTXT                                               ICBC
         MVC   0(63,R6),PFTXT                                     RNB14
         SH    R1,=H'3'                                            ICBC
NOTXT    LA    R1,0(R5,R1)                                         ICBC
         STH   R1,QDRLNG      STORE LENGTH OF REPLY                ICBC
.PFK2    ANOP                                                      ICBC
         OC    QDREPLY,QBLANK     UPPERCASE THE COMMAND            FCI*
         CLC   QDREPLY(2),=CL2'PR' POSSIBLE PRINT COMMAND      PWF FCI*
         BNE   CLSCRN             NOPE..SPLIT NORMALLY             FCI*
*                                                                  FCI*
         L     R15,=V(PRINT)  FETCH PRINT ENTRY ADDRESS            FCI*
         BALR  R14,R15        AND CALL HIM                         FCI*
         LTR   R15,R15        HOW IS HIS RETURN CODE               FCI*
         BNZ   CLSCRN         NOTHING TO REPORT                    FCI*
*                                                                  FCI*
         B     TPUTSCRN       GO REPOST SCREEN                     FCI*
CLSCRN   LA    R4,QDLINE1     LOAD ADDRESS OF FIRST LINE           FCI*
         LH    R5,QDSCRLEN    LOAD LENGTH OF SCREEN               UF003
         SR    R6,R6          NO SENDING FIELD NEEDED              FCI*
         STH   R6,QDNEXT      STORE ZERO IN LINE NUMBER            FCI*
         SR    R7,R7          FILL SCREEN WITH NULLS               FCI*
         MVCL  R4,R6          CLEAR THE SCREEN                     FCI*
*
         LH    R1,QDRLNG      STORE LENGTH OF REPLY
         LTR   R1,R1          WAS THERE A RESPONSE FROM USER?
         BNZ   INTER          YES. INTERRUPT PROCESSING.
         MVI   QDOVER,1       INDICATE PAGE OVERFLOW
         B     DSP2           CONTINUE PROCESSING
INTER    L     R13,QFRSTSA    GO BACK TO MAIN MODULE
         LM    R14,R12,12(R13) RESTORE REGISTERS FROM FIRST SAVEAREA
         BR    R10            ADDRESS OF INTERRUPT HANDLER IN QUEUE
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
         AIF  (NOT &QPFK).PFK3                                     ICBC
* PF-KEY DEFINITIONS                                               ICBC
PFKTAB   DS    0CL60                                               ICBC
PF1      DC    CL5'H'                                              ICBC
PF2      DC    CL5'DA'                                       FCI*  ICBC
PF3      DC    CL5'E'                                              ICBC
PF4      DC    CL5'PRINT'                                    FCI*  ICBC
PF5      DC    CL5'F'                                              ICBC
PF6      DC    CL5'DI'                                             ICBC
         AIF   (&QRNB).RNB15A                                     RNB15
PF7      DC    CL5'PB'                                            UF003
PF8      DC    CL5'PF'                                            UF003
         AGO   .RNB15B                                            RNB15
.RNB15A  ANOP                                                     RNB15
PF7      DC    CL5'-  21'                                         RNB15
PF8      DC    CL5'+  21'                                         RNB15
.RNB15B  ANOP                                                     RNB15
PF9      DC    CL5'DO'                                             ICBC
PF10     DC    CL5'CO 1'                                           ICBC
PF11     DC    CL5'CO 41'                                          ICBC
PF12     DC    CL5'ST'                                             ICBC
.PFK3    ANOP                                                      ICBC
* TABLE OF PRINTABLE CHARACTERS
TABLE    DC    CL64' '
         DC    192AL1(*-TABLE)  REST OF TABLE IS OK               UF003
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q6
FINDJOB  QSTART 'QUEUE COMMAND - LOCATE JQE, JCT, AND IOT BY JOBNAME'
***********************************************************************
* RNB CHANGES:                                                        *
*     (1) RNB22 - IN CASE JOBNAME = * (FOR CURRENT JOB), AFTER READING*
*                 THE JCT ENSURE JQEJNAME = JCTJNAME AND QPJOBID =    *
*                 JCTJBKEY. THIS IS DONE IN CASE THE JOB PURGED SINCE *
*                 THE LAST FINDJOB.                                   *
***********************************************************************
         GBLB   &QACF2         ACF2 CHECKING FOR AUTH              FCI*
         GBLB   &QSP           MVS/SP OPTION                      UF020
         AIF    (NOT &QACF2).NACF1                                 FCI*
*******************************************************************FCI*
* MOD 1 - K TRUE  - 22 OCT 79 -                                    FCI*
*   ADD ACF2 AUTH CHKING FOR USER AUTH TO LOOK AT STUFF.           FCI*
*    OPER CHKS ALL..                                               FCI*
*    USER CHKS OWN GOODIES (LOGONID = LOGONID IN JCT)              FCI*
*    OTHER: ISSUE ACFVLD CHK FOR AUTH                              FCI*
*******************************************************************FCI*
.NACF1   ANOP                                                      FCI*
         USING QCKPT,R10      BASE REG FOR CHECKPOINT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING WORK,R13       LOCAL WORK AREA
         LH    R1,QLNG1       LENGTH OF PARAMETER FIELD
         SH    R1,=H'1'       IS THE LENGTH ZERO?
         BM    TILT           YES. TILT.
******************************************************************UF007
*                                                                 UF007
*   ALLOW JOBNAME = "*" TO SIGNIFY CURRENT JOB & SKIP CKPT READ   UF007
*                                                                 UF007
******************************************************************UF007
         CLI   QPARM1,C'*'    WANT CURRENT JOB AGAIN?             UF007
         BE    JOBAGAIN       YES, SKIP CKPT READ                 UF007
******************************************************************UF006
*                                                                 UF006
*   CALL - READ JES2 CHECKPOINT ROUTINE                           UF006
*                                                                 UF006
******************************************************************UF006
CALLCKPT L     R15,=V(CKPT)   ADDR OF CKPT ROUTINE                UF006
         BALR  R14,R15        GO TO IT                            UF006
***********************************************************************
*                                                                     *
*   DETERMINE IF SEARCH IS BY JOBNUMBER OR JOBNAME                    *
*                                                                     *
***********************************************************************
         LH    R1,QLNG1       LENGTH OF PARAMETER FIELD
         SH    R1,=H'1'       IS THE LENGTH ZERO?
         BM    TILT           YES. TILT.
         CLI   QPARM1,C'0'    IS THE FIRST CHARACTER NUMERIC?
         BL    JOBNAME        NO. SEARCH BY JOBNAME
         MVC   QFZONES,QFZONE INITIALIZE NUMERIC TEST
         EX    R1,MVZ         MOVE THE ZONES FOR VALIDITY CHECK
         CLC   QFZONES,QFZONE IS THE FIELD NUMERIC?
         BNE   TILT           NO. TILT.
         EX    R1,PACK        PACK THE FIELD
         CVB   R5,CONVERT     CONVERT TO BINARY
***********************************************************************
*                                                                     *
*   LOCATE JQE BY JOBNAME                                             *
*                                                                     *
***********************************************************************
JOBNAME  L     R2,QCJQHEAD    LOAD ADDR OF JQT
         USING JQTDSECT,R2    BASE REG FOR JQT
         LA    R2,JQTOUT      FIRST JQE QUEUE
         LA    R1,JQTQMAX     MAXIMUM NUMBER OF QUEUES
         DROP  R2
         AIF   (&QSP).QSP1                                        UF020
NEXTJQT  LH    R3,0(R2)       OFFSET TO FIRST JQE IN QUEUE
NEXTJQE  SLA   R3,2           MULTIPLY BY 4
         AGO   .QSP2                                              UF020
.QSP1    ANOP                                                     UF020
NEXTJQT  L     R3,0(R2)       OFFSET TO FIRST JQE IN QUEUE        UF020
NEXTJQE  N     R3,=A(X'00FFFFFF')  TEST FOR END OF CHAIN          UF020
.QSP2    ANOP                                                     UF020
         BZ    ENDJQE         END OF QUEUE
         A     R3,QCJQTA      ADD BASE TO OFFSET
         USING JQEDSECT,R3    BASE REG FOR JQE
         CLI   QPARM1,C'0'    IS SEARCH BY JOBNUMBER?
         BL    CLCNAME        NO. SEARCH BY JOBNAME.
         CH    R5,JQEJOBNO    IS THIS THE RIGHT JOBNUMBER?
         BNE   NOMATCH        NO. TRY NEXT JQE.
         B     FOUND          YES. PROCESS IT.
CLCNAME  CLC   QPARM1,JQEJNAME IS THIS THE RIGHT JOBNAME?
         BE    FOUND          YES. PROCESS IT.
         AIF   (&QSP).QSP3                                        UF020
NOMATCH  LH    R3,JQECHAIN    NO. TRY NEXT ENTRY.
         B     NEXTJQE        LOOP
ENDJQE   LA    R2,2(R2)       TRY NEXT QUEUE
         AGO   .QSP4                                              UF020
.QSP3    ANOP                                                     UF020
NOMATCH  L     R3,JQENEXT     NO. TRY NEXT ENTRY.                 UF020
         B     NEXTJQE        LOOP                                UF020
ENDJQE   LA    R2,4(R2)       TRY NEXT QUEUE                      UF020
.QSP4    ANOP                                                     UF020
         BCT   R1,NEXTJQT     LOOP IF NOT LAST QUEUE
TILT     QTILT '*** JOBNAME NOT FOUND OR INVALID ***'
         SPACE 1                                                  UF007
JOBAGAIN L     R3,QCJQEA      PRIME JQE ADDRESS                   UF007
***********************************************************************
*                                                                     *
*   READ JCT AND IOT                                                  *
*                                                                     *
***********************************************************************
FOUND    ST    R3,QCJQEA      SAVE THE ADDRESS
         LR    R4,R3          SAVE THE ADDRESS FOR COMPARE        RNB22
         MVC   QCTRAK,JQETRAK DISK ADDR OF JCT
         DROP  R3
         L     R3,QCJCTA      ADDR OF IOAREA FOR JCT
         LR    R1,R3          PARM FOR READSPC
         L     R15,=V(READSPC) ROUTINE TO READ HASPACE
         BALR  R14,R15        GO TO IT
         USING JCTSTART,R3    BASE REG FOR JCT
         USING JQEDSECT,R4    BASE FOR JQE                        RNB22
         CLI   QPARM1,C'*'         WAS REQUEST FOR CURRENT JOB?   RNB22
         BNE   RNB22A              /NO  - DON'T NEED EXTRA CHECK  RNB22
         CLC   JQEJNAME,JCTJNAME   IS JOBNAME RIGHT?              RNB22
         BNE   TILT                /NO  - TILT                    RNB22
         CLC   QPJOBID,JCTJBKEY    IS JOBID RIGHT?                RNB22
         BNE   TILT                /NO  - TILT                    RNB22
RNB22A   EQU   *                                                  RNB22
         MVC   QPJOBID,JCTJBKEY JOB IDENTIFICATION
         AIF    (NOT &QACF2).NACF2                                 FCI*
*******************************************************************FCI*
* MOD 1 - K TRUE  - 22 OCT 79 -                                    FCI*
*                                                                  FCI*
         CLC   QLOGON,LIDLID  SEE IF USERS LOGONID=JOBS ACF LOGONIDKMT*
         BE    ACF2OK         YES..CONTINUE FORTHWITH              FCI*
         TM    QXAUTH,X'80'   IS USER OPER PRIVLEDGE ?             FCI*
         BO    ACF2OK         YES..CONTINUE FORTHWITH              FCI*
*                                                                  FCI*
         USING ACCVT,R8                                            FCI*
         ACFGACVT R8,NONE=NOTOK   GET THE ACF2 CVT                 FCI*
*                                                                  FCI*
         MVC   DSNAME,=CL44'SYSOUT. '  INITIALIZE DSNAME TO USE    FCI*
         XC    ACFSPARM(ACFSPRML),ACFSPARM   CLEAR REQUEST BLOCK   FCI*
         MVI   ACFSPREQ,ACFSPRDS  DSNAME ACCESS ONLY               FCI*
         MVI   ACFSPID1,ACFSPIUR  DIS AM DE USER TALKING....       FCI*
         LA    R7,DSNAME          GET DSNAME ADDRESS               FCI*
         ST    R7,ACFSPDSN        AND GIVE IT TO ACF PARM LIST     FCI*
*                                                                  FCI*
*  GENERATE DSNAME OF FORMAT 'SYSOUT.LOGONID.JOBNAME' FOR CHKING   FCI*
*                                                                  FCI*
         MVC   DSNAME+7(8),LIDLID  MOVE LID TO DSNAME              FCI*
         CLI   DSNAME+7,C' '       IS THE LID BLANK?               FCI*
         BNE   ADSNCHK0            NO..NORMAL PROCESS              FCI*
*                                                                  FCI*
*  GOT HERE BECAUSE LID IS ' ' (BLANK)..SUBSTITUTE 'SYSTEM'        FCI*
         MVC   DSNAME+7(8),=CL8'SYSTEM'                            FCI*
*                                                                  FCI*
ADSNCHK0 LA    R1,DSNAME+7         GET ADDRESS                     FCI*
         LA    R7,8                LOAD COUNT                      FCI*
ADSNCHK  CLI   0(R1),C' '          LOOK FOR BLANK                  FCI*
         BE    ADSNCHK1            GOTIT..                         FCI*
         LA    R1,1(R1)            BUMP AND                        FCI*
         BCT   R7,ADSNCHK            GRIND                         FCI*
ADSNCHK1 MVI   0(R1),C'.'          MOVE IN PERIOD..                FCI*
         MVC   1(8,R1),JCTJNAME    MOVE IN JOBNAME                 FCI*
*                                                                  FCI*
         LA    R1,ACFSPARM        GET ADDRESS OF PARM FIELD        FCI*
         ACFSVC (1),TYPE=S,NONE=NOTOK,CVT=HAVE   INVOKE A C F 2    FCI*
*                                                                  FCI*
         LTR   R15,R15            HOW DID YOU LIKE THEM APPLES?    FCI*
         BC    8,ACF2OK           ..OK BY YOU...CONTINUE..         FCI*
*                                                                  FCI*
NOTOK    QTILT '*** SORRY..NO ACF2 AUTHORITY TO LOOK AT THIS JOB'  FCI*
*******************************************************************FCI*
ACF2OK   DS    0H                                                  FCI*
.NACF2   ANOP                                                      FCI*
         MVC   QCTRAK,JCTIOT  DISK ADDR OF IOT
         DROP  R3
         L     R1,QCIOTA      ADDR OF IOAREA FOR IOT
         L     R15,=V(READSPC) ROUTINE TO READ HASPACE
         BALR  R14,R15        GO TO IT
STOP     QSTOP
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
MVZ      MVZ   QFZONES(1),QPARM1 CHECK FOR NUMERIC
PACK     PACK  CONVERT,QPARM1(1) CONVERT TO BINARY
         LTORG
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
FINDJOB  CSECT ,                                                  UF023
JCT      EQU   0
BUFSTART EQU   0
BUFDSECT EQU   0
         $JQE
         $JCT
         $JQT
         QCOMMON
WORK     DSECT
         DS    72C
CONVERT  DS    D
         AIF    (NOT &QACF2).NACF3                                 FCI*
         ACDSV DSECT=NO                                            FCI*
DSNAME   DS    CL44                                                FCI*
         EJECT   ,                                                 FCI*
         ACCVT   ,                                                 FCI*
         ACUCB   ,                                                 FCI*
         PRINT OFF                                                 FCI*
         IHAPSA  ,                                                 FCI*
         PRINT ON                                                  FCI*
.NACF3   ANOP   ,                                                  FCI*
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q7
FORMAT   QSTART 'QUEUE COMMAND - JQE AND JOE FORMAT ROUTINES'
***********************************************************************
* RNB CHANGES:                                                        *
*      (1) RNB17 - WHEN FORMATTING JOES, CHECK FOR JOE ON PSO AND     *
*                  INDICATE 'EXT-WTR' IF SO. ALSO, DON'T INDICATE ON  *
*                  ON PRINT/PUNCH UNLESS SHOWS ACTIVE IN JOEFLAGS.    *
*                  ALSO, FIX BUG IN GETTING TO CHECKPOINT JOE FOR     *
*                  RECORDS LEFT, AND FIX RECORDS LEFT FOR SP2.        *
*                  ALSO, IF JOE NOT BUSY, BUT CHKPT JOE VALID, PRINT  *
*                  NUMBER OF RECORDS LEFT, NOT TOTAL RECORDS.         *
*      (2) RNB18 - DISTINGUISH BETWEEN JOES WITH REMOTE ROUTING AND   *
*                  THOSE WITH SPECIAL LOCAL ROUTING (DEFINED BY DESTID*
*                  STATEMENTS WITH DEST=UNNN).                        *
*      (3) RNB19 - WHEN LISTING JQE'S, DON'T ASSUME INPUT QUEUE, BUT  *
*                  USE THE JQETYPE INSTEAD. ALSO, SPECIALLY HANDLE    *
*                  CONVERSION AND DUMP QUEUES, AND AWAITING OUTPUT.   *
*      (4) RNB20 - WHEN LISTING THINGS, DISTINGUISH BETWEEN NORMAL    *
*                  HOLD, HOLD ALL, AND DUPLICATE HOLD. ALSO, FOR      *
*                  JOES, INDICATE SELECT=NO IF APPLICABLE.            *
*      (5) RNB21 - FIX SETDEVIC SUBROUTINE FOR SP2.                   *
*      (5) RNB25 - ALLOW 'COUNT' PARM TO HO TO INDICATE TOTAL LINE    *
*                  COUNT DESIRED FOR JOBS ON HELD OUTPUT QUEUE        *
***********************************************************************
         GBLB  &QSP           MVS/SP OPTION                       UF020
         USING QDISPLAY,R10   BASE REG FOR DISPLAY WORK AREA
         L     R10,QVDSPL     LOAD BASE REG
         USING JQEDSECT,R9    BASE REG FOR JQE DSECT
         USING JOEDSECT,R8    BASE REG FOR JOE DSECT
         USING WORK,R13       BASE FOR LOCAL WORK AREA
***********************************************************************
*                                                                     *
*   INPUT TO THIS MODULE -                                            *
*     R1 = 0 INDICATES PRINT JQE                                      *
*     R1 = 4 INDICATES PRINT JOE                                      *
*     R9 CONTAINS JQE ADDRESS                                         *
*     R8 CONTAINS JOE ADDRESS                                         *
*                                                                     *
***********************************************************************
*                                                                     *
*   BRANCH TO PROPER ROUTINE                                          *
*                                                                     *
***********************************************************************
         MVC   FCLEAR,=CL80' ' CLEAR THE PRINT AREA
         MVC   FQUEUE,QCLASS  CLASS NAME
         MVC   QDHLINE,HEADING REPORT HEADING
         CLI   QSUBNAME,C'X'  IS THE REQUEST FOR A HEX DUMP?
         BE    NOTBUSY        YES. SKIP.
*        CLC   =X'01000100',JQEPRTRT IS THE PRINT/PUNCH FOR LOCAL?
*        BE    LOCAL          YES. SKIP THIS ROUTINE.
*        MVC   FREMOTE,=C'RJE' INDICATE THIS JOB IS REMOTE
         TM    JQEFLAGS,QUEBUSY IS THE JOB EXECUTING?
         BZ    NOTBUSY        NO. SKIP THIS ROUTINE.
         IC    R15,JQEFLAGS   GET SYSTEM NUMBER
         N     R15,=F'7'      ZERO OUT UNWANTED BITS
         SLL   R15,3          MULTIPLY BY 8
         LA    R15,QSYSID(R15) OBTAIN SYSTEM ID
         MVC   FSYSID,0(R15)  MOVE SYSTEM ID TO DISPLAY
NOTBUSY  CLI   QCLASS,0       IS THIS THE TSO QUEUE?
         BE    LISTTSO        YES. DO IT.
         CLI   QCLASS,4       IS THIS THE STC QUEUE?
         BE    LISTSTC        YES. DO IT.
         CLI   QCLASS,8       IS THIS THE HELD OUTPUT QUEUE?
         BE    LISTHO         YES. DO IT.
         AIF   (NOT &QSP).RNB19A                                  RNB19
         CLI   QCLASS,12      IS THIS THE DUMP QUEUE?             RNB19
         BE    LISTDM         YES. DO IT.                         RNB19
         CLI   QCLASS,16      IS THIS THE CONVERSION QUEUE?       RNB19
         BE    LISTCN         YES. DO IT.                         RNB19
         CLI   QCLASS,20      IS THIS THE AWAITING OUTPUT QUEUE?  RNB19
         BE    LISTAOUT       YES. DO IT.                         RNB19
.RNB19A  ANOP                                                     RNB19
         LTR   R1,R1          IS REQUEST FOR JQE OR JOE?
         BZ    LISTJQE        JQE.
***********************************************************************
*                                                                     *
*   FORMAT JOE                                                        *
*                                                                     *
***********************************************************************
LISTJOE  MVC   FQNAME,=C'OUTPUT' MOVE IN NAME OF QUEUE
         CLI   QSUBNAME,C'X'  IS THE REQUEST FOR A HEX DUMP?
         BE    HEXO           YES. DO IT.
         AIF   (NOT &QSP).RNB20A                                  RNB20
         TM    JOEFLAG2,$JOESLEC   IS THIS JOE SELECTABLE?        RNB20
         BZ    LSTJOEAA            /YES - DON'T FLAG IT           RNB20
         MVC   FHOLD,=C' S=N'      /NO  - SAY SO                  RNB20
LSTJOEAA EQU   *                                                  RNB20
.RNB20A  ANOP                                                     RNB20
         L     R0,JOERECCT    NUMBER OF PRINT LINES
         CVD   R0,CONVERT     CONVERT TO DECIMAL
         MVC   FLINES,ED8     PREPARE FOR EDIT
         ED    FLINES,CONVERT+4 EDIT NUMBER OF LINES
*        TM    JOEFLAG,X'20'  IS THIS JOB PRINTING?               RNB17
*        BNO   LOCAL          NO. SKIP.                           RNB17
         TM    JOEFLAG,$JOEBUSY  IS JOE ACTIVE?                   RNB17
         BZ    LSTJOE$$          /NO  - DON'T SET DEVICE ID       RNB17
*                                /YES -                           RNB17
         CLI   JOEDEVID,X'0F'    IS JOB ON PSO (EXTERNAL WRITER)? RNB17
         BNE   LSTJOE$           /NO  - GO DO REAL DEVICE         RNB17
         MVC   FPRINT,=CL8'EXT-WTR'  /YES - SAY SO                RNB17
         B     LSTJOE$$                                           RNB17
         AIF   (&QSP).RNB17A                                      RNB17
LSTJOE$  TM    JOEFLAG,$JOEPRT+$JOEPUN  JOB PRINTING OR PUNCHING? RNB17
         BZ    LOCAL                     /NO  - SKIP DEVICE ID    RNB17
         AGO   .RNB17B                                            RNB17
.RNB17A  ANOP                                                     RNB17
LSTJOE$  TM    JOEDEVID,X'40'           JOB ON NJE DEVICE?        RNB17
         BO    LOCAL                     /YES - SKIP DEVICE ID    RNB17
.RNB17B  ANOP                                                     RNB17
         LA    R3,JOEDEVID    A(OUTPUT DEVICE DESCRIPTOR            FCI
         BAL   R7,SETDEVIC    SET THE OUTPUT DEVICE                 FCI
LSTJOE$$ EQU   *                                                  RNB17
         TM    JOEFLAG,$JOECKV  IS CKPT JOE VALID?                RNB17
         BO    LSTJOE##         /YES - USE RECORDS PRINTED        RNB17
         TM    JOEFLAG,$JOEBUSY /NO  - IS JOE BUSY?               RNB17
         BZ    LOCAL            IF NOT, GO DO LOCAL STUFF         RNB17
         B     LIST             IF YES, SKIP LOCAL STUFF, GO LIST RNB17
LSTJOE## EQU   *                                                  RNB17
         L     R0,JOERECCT      RESTORE R0 FOR REMOTES            CBT1
         LR    R3,R8            SAVE WORK JOE ADDRESS             RNB17
         AIF   (&QSP).QSP01                                       UF020
         LH    R8,JOECKPT     OFFSET TO CHECKPOINT JOE
         SLA   R8,2           MULTIPLY BY 4
         AGO   .QSP02                                             UF020
.QSP01   ANOP                                                     UF020
         LA    R8,0(,R8)      CLEAR HIGH BYTE FOR ICM             RNB17
         ICM   R8,B'0111',JOECKPTB OFFSET TO CKPT JOE             UF020
.QSP02   ANOP                                                     UF020
         BZ    LIST           CHECKPOINT DOES NOT EXIST. SKIP.
         USING QCKPT,R1       BASE REG FOR CKPT WORK AREA
         L     R1,QVCKPT      LOAD BASE REG
         A     R8,QCJOTA      ADD BASE TO OFFSET
         DROP  R1
         AIF   (&QSP).QSP02A                                      RNB17
         S     R0,JOETLNC     SUBTRACT RECORDS PRINTED FROM TOTAL
         AGO   .QSP02B                                            RNB17
.QSP02A  ANOP
         SL    R0,JOECRECN    SUBTRACT RECORDS PRINTED FROM TOTAL RNB17
.QSP02B  ANOP
         LR    R8,R3          BACK TO WORK JOE                    RNB17
         CVD   R0,CONVERT     CONVERT TO DECIMAL
         MVC   FLINES,ED8     PREPARE FOR EDIT
         ED    FLINES,CONVERT+4 PRINT UPDATED LINE COUNT
         TM    JOEFLAG,$JOEBUSY IS JOE ACTIVE?                    RNB17
         BNZ   LIST                  /YES - GO LIST IT            RNB17
         MVC   FLINES+9(4),=C'LEFT'  /NO  - SHOW IT'S LINES LEFT  RNB17
*                                    AND FORMAT ROUTING INFO      RNB17
LOCAL    LA    R15,FREMOTE    ADDRESS TO PUT TEXT
         LA    R1,JOEROUT     POINT TO ROUTING INFO                FCI*
***********************************************************************
*RMTORLCL SUBROUTINE - DETERMINE REMOTE OR LOCAL DESTINATION       FCI*
* R1 POINTS TO PRTRT/PUNRT, R15 TO ASSEMBLY POINTER                FCI*
***********************************************************************
         AIF   (&QSP).QSP1                                        UF020
RMTORLCL CLI   1(R1),0        IS IT FOR REMOTE 00=LOCAL            FCI*
         AGO   .QSP2                                              UF020
.QSP1    ANOP                                                     UF020
RMTORLCL CLI   3(R1),0        IS IT FOR REMOTE 00=LOCAL            FCI*
.QSP2    ANOP                                                     UF020
         BE    LIST           NO LUCK .. HAVE TO WORK FOR IT       FCI*
         AIF   (&QSP).RNB18A                                      RNB18
         CLI   0(R1),0        SPECIAL LOCAL ROUTING?              RNB18
         AGO   .RNB18B                                            RNB18
.RNB18A  ANOP                                                     RNB18
         CLC   =H'0',0(R1)    SPECIAL LOCAL ROUTING (SP2) ?       RNB18
.RNB18B  ANOP                                                     RNB18
         BNE   RMTORLC1          /NO  - GO FORMAT RMTNN           RNB18
         MVC   0(L'LCL,R15),LCL  /YES - MOVE IN LCL               RNB18
         LA    R15,L'LCL(R15)    BUMP POINTER                     RNB18
         B     RMTORLC2                                           RNB18
RMTORLC1 EQU   *                                                  RNB18
         MVC   0(L'RMT,R15),RMT       MOVE IN 'RMT'                FCI*
         LA    R15,L'RMT(R15)  BUMP POINTER                        FCI*
RMTORLC2 EQU   *                                                  RNB18
         SR    R14,R14        LOAD RMT FLAGS                       FCI*
         AIF   (&QSP).RNB18C                                      RNB18
         IC    R14,1(R1)      FROM PRT/PUN                         FCI*
         AGO   .RNB18D                                            RNB18
.RNB18C  ANOP                                                     RNB18
         IC    R14,3(R1)      FROM JOEROUT                        RNB18
.RNB18D  ANOP                                                     RNB18
         CVD   R14,DOUBLEWD   RMT NUMBER TO DECIMAL                FCI*
         B     FITINUM1       FIT THE NUMBER IN RMT MESSAGE        FCI*
         SPACE 2
***********************************************************************
* FITINUM SUBROUTINE - CONVERT BIN NUMBER TO NICE FORMAT           FCI*
*                                                                  FCI*
***********************************************************************
FITINUM  CVD   R1,DOUBLEWD    CONVERT TO PACKED DECIMAL            FCI*
FITINUM1 MVC   NUMBER(L'NORMAL),NORMAL INITIALIZE THE EDIT FORMAT  FCI*
         LA    R1,NUMBER+SIGNORM IN CASE OF ZEROES                 FCI*
         EDMK  NUMBER(L'NORMAL),DOUBLEWD+2 CONVERT TO EBCDIC       FCI*
         LA    R14,NUMBER+L'NORMAL-1 A(END OF CONVERTED NUMBER)    FCI*
         SLR   R14,R1         LENGTH OF THE CONVERTED NUMBER - 1   FCI*
         EX    R14,MVNUMBER   PUT THE NUMBER IN THE MSG            FCI*
         LA    R15,1(R14,R15) A(NEXT SPOT IN MSG)                  FCI*
         B     LIST           RETURN TO OUR CALLER                 FCI*
         SPACE 3                                                   FCI*
MVNUMBER MVC   0(0,R15),0(R1) TO BE EXECUTED                       FCI*
         SPACE 2                                                   FCI*
NORMAL   DC    X'402020202020202020202120' EDIT MASK               FCI*
SIGNORM  EQU   11             OFFSET TO LAST DIGIT                 FCI*
RMT      DC    C'RMT'                                              FCI*
LCL      DC    C'LCL'                                             RNB18
***********************************************************************
*                                                                     *
*   FORMAT JQE                                                        *
*                                                                     *
***********************************************************************
LISTTSO  MVC   FQNAME(8),=C'TSO USER' NAME OF QUEUE
         B     LIST           CONTINUE
LISTSTC  MVC   FQNAME(8),=C'SYSTEM Q' NAME OF QUEUE
         B     LIST           CONTINUE
LISTHO   MVC   FQNAME(8),=C'HELD OUT' NAME OF QUEUE
         B     LIST           CONTINUE
         AIF   (NOT &QSP).RNB19B                                  RNB19
LISTDM   MVC   FQNAME(4),=C'DUMP'     NAME OF QUEUE               RNB19
         B     LIST                                               RNB19
LISTAOUT MVC   FQNAME(6),=C'AW OUT'   NAME OF QUEUE               RNB19
         B     LISTCN1                GO DO SYSAFF                RNB19
LISTCN   MVC   FQNAME(6),=C'CONVRT'   NAME OF QUEUE               RNB19
         MVC   FQUEUE,JQEJCLAS        JOB CLASS                   RNB19
LISTCN1  TM    JQEFLAGS,QUEBUSY       IS JOB CONVERTING?          RNB19
         BNZ   LIST                   /YES - GO LIST IT           RNB19
*                                     /NO  - PUT SYSAFF IN        RNB19
         TM    JQEFLAG2,QUESYSAF      CHECK SYSTEM AFFINITY       RNB19
         BO    LIST                   LIST IT IF NO SPECIAL AFF   RNB19
         LA    R15,QSYSID+8           GET FIRST SID               RNB19
         TM    JQEFLAG2,X'01'         IS THIS IT?                 RNB19
         BO    LISTCN2                /YES -                      RNB19
         LA    R15,8(,R15)            /NO  - CHECK REST           RNB19
         TM    JQEFLAG2,X'02'                                     RNB19
         BO    LISTCN2                                            RNB19
         LA    R15,8(,R15)                                        RNB19
         TM    JQEFLAG2,X'04'                                     RNB19
         BO    LISTCN2                                            RNB19
         LA    R15,8(,R15)                                        RNB19
         TM    JQEFLAG2,X'08'                                     RNB19
         BO    LISTCN2                                            RNB19
         LA    R15,8(,R15)                                        RNB19
         TM    JQEFLAG2,X'10'                                     RNB19
         BO    LISTCN2                                            RNB19
         LA    R15,8(,R15)                                        RNB19
         TM    JQEFLAG2,X'20'                                     RNB19
         BO    LISTCN2                                            RNB19
         LA    R15,8(,R15)                                        RNB19
LISTCN2  MVC   FREMOTE(4),0(R15)      MOVE SYSTEM ID TO DISPLAY   RNB19
         B     LIST                                               RNB19
.RNB19B  ANOP                                                     RNB19
*LISTJQE  MVC   FQNAME,=C' INPUT' NAME OF QUEUE                   RNB19
LISTJQE  MVC   FQNAME(5),=CL5'XEQ'  ASSUME XEQ QUEUE              RNB19
         TM    JQETYPE,$XEQ         IS IT XEQ QUEUE?              RNB19
         BO    LIST                 /YES - GO LIST IT             RNB19
         MVC   FQNAME(5),=C'INPUT'  ELSE ASSUME INPUT, ETC.       RNB19
         TM    JQETYPE,$INPUT                                     RNB19
         BO    LIST                                               RNB19
         MVC   FQNAME(6),=C'OUTPUT'                               RNB19
         TM    JQETYPE,$OUTPUT+$HARDCPY                           RNB19
         BNZ   LIST                                               RNB19
         MVC   FQNAME(5),=C'PURGE'                                RNB19
         TM    JQETYPE,$PURGE                                     RNB19
         BO    LIST                                               RNB19
         MVC   FQNAME(8),=CL8'????????'                           RNB19
LIST     CLI   QSUBNAME,C'X'  IS THE REQUEST FOR A HEX DUMP?
         BE    HEX            YES. DO IT.
         MVC   FCOUNT,ED5     PREPARE FOR EDIT
         ED    FCOUNT,QCOUNT  EDIT THE POSITION IN QUEUE
         MVC   FNAME,JQEJNAME MOVE IN JOBNAME
         MVC   FJOBNO,ED5     PREPARE FOR EDIT
         LH    R0,JQEJOBNO    LOAD HASP JOBNUMBER
         CVD   R0,CONVERT     CONVERT TO DECIMAL
         ED    FJOBNO,CONVERT+5 EDIT HASP JOBNUMBER
         SR    R0,R0          ZERO OUT REGISTER
         IC    R0,JQEPRIO     LOAD JQE PRIORITY
         SRL   R0,4           DIVIDE BY 16
         CVD   R0,CONVERT     CONVERT TO DECIMAL
         MVC   FPRIO,ED3      PREPARE FOR EDIT
         ED    FPRIO,CONVERT+6 EDIT JQE PRIORITY
         TM    JQEFLAGS,X'E0' IS THE JOB HELD?
         BZ    NOHOLD         NO.
         MVC   FHOLD,=C'HELD' INDICATE JOB HELD
         TM    JQEFLAGS,QUEHOLD1  SPECIFIC HOLD?                  RNB20
         BO    NOHOLD             /YES - GO DISPLAY               RNB20
         MVC   FHOLD,=C'DUP '     ASSUME DUPLICATE                RNB20
         TM    JQEFLAGS,QUEHOLD2  IS IT DUPLICATE HOLD?           RNB20
         BO    NOHOLD             /YES - GO DISPLAY               RNB20
         MVC   FHOLD,=C'$HA '     ELSE MUST BE FROM $HA           RNB20
NOHOLD   DS    0H
         CLC   QCODEH,=H'28'  IS THIS THE HO COMMAND?             RNB25
         BNE   LIST2          /NO  - DO NORMAL LISTING            RNB25
*                             /YES -                              RNB25
         CLC   =C'COUNT',QPARM1  DOES USER WANT LINE COUNTS?      RNB25
         BNE   LIST2          /NO  - DO NORMAL LISTING            RNB25
*                             /YES - GET JCT AND FORMAT LINE CNT  RNB25
         MVC   QCTRAK,JQETRAK DISK ADDR OF JCT                    RNB25
         L     R3,QCJCTA      ADDR OF IOAREA FOR JCT              RNB25
         LR    R1,R3          PARM FOR READSPC                    RNB25
         L     R15,=V(READSPC)  ROUTINE TO READ HASPACE           RNB25
         BALR  R14,R15          GO DO IT                          RNB25
         USING JCTSTART,R3    BASE FOR JCT                        RNB25
         L     R0,JCTLINES    GET TOTAL LINES GENERATED BY JOB    RNB25
         DROP  R3                                                 RNB25
         CVD   R0,CONVERT     CONVERT TO DECIMAL                  RNB25
         MVC   FLINES,ED8     PREPARE FOR EDIT                    RNB25
         ED    FLINES,CONVERT+4  PRINT TOTAL LINE COUNT           RNB25
         C     R0,=F'9999999' IS THE LINE COUNT >= 10 MILLION?    RNB25
         BNH   LIST2          /NO  - GO LIST IT                   RNB25
         MVI   FLINES+8,C'+'  /YES - SHOW OVERFLOW                RNB25
LIST2    EQU   *                                                  RNB25
         LA    R1,QDMSG       ADDR OF MESSAGE AREA
         ST    R1,QDMSGA      STORE MESSAGE ADDR
         MVC   QDMLNG,=H'80'  LENGTH OF DISPLAY LINE
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE
         BALR  R14,R15        DISPLAY THE LINE
STOP     QSTOP
***********************************************************************
*                                                                     *
*   TAKE HEX DUMP OF JOE                                              *
*                                                                     *
***********************************************************************
HEXO     UNPK  FHEX1,0(8,R8)  UNPK FIRST PART OF JOE INTO HEX
         UNPK  FHEX2,7(8,R8)  SECOND
         UNPK  FHEX3,14(8,R8) THIRD
         UNPK  FHEX4,21(8,R8) FOURTH
         UNPK  FHEX5,28(5,R8) FIFTH
         MVI   FHEXOC,C' '    CLEAR LAST BYTE
         TR    FHEXO,TABLE    CHANGE TO PRINTABLE HEX
         LA    R1,QDMSG       ADDR OF MESSAGE AREA
         ST    R1,QDMSGA      STORE MESSAGE ADDR
         MVC   QDMLNG,=H'80'  LENGTH OF DISPLAY LINE
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE
         BALR  R14,R15        DISPLAY THE LINE
***********************************************************************
*                                                                     *
*   TAKE HEX DUMP OF JQE                                              *
*                                                                     *
***********************************************************************
HEX      UNPK  FHEX1,0(8,R9)  UNPK FIRST PART OF JOE INTO HEX
         UNPK  FHEX2,7(8,R9)  SECOND
         UNPK  FHEX3,14(8,R9) THIRD
         UNPK  FHEX4,21(8,R9) FOURTH
         MVC   FHEXC,QBLANK   CLEAR LAST BYTES
         TR    FHEX,TABLE     CHANGE TO PRINTABLE HEX
         B     NOHOLD         CALL DISPLAY
***********************************************************************
* SETDEVIC SUBROUTINE - GET DEVICE DATA (R3) POINTS TO DEVID       FCI*
*                                                                  FCI*
***********************************************************************
SETDEVIC ST    R7,SETDHOLD       SAVE LINK ADDRESS                 FCI*
         MVC   FPRINT(9),=CL9' '
         TM    0(R3),HIGHBIT REMOTE DEVICE?                        FCI*
         BO    RMTDEV         YES => OUTPUT IT                     FCI*
         SR    R1,R1          FOR THE INSERT CHARACTER             FCI*
         IC    R1,0(R3)         DEVICE TYPE                        FCI*
         SRL   R1,4           RIGHT JUSTIFIED                      FCI*
         MH    R1,DEVTYPEL    TYPE * LENGTH OF A DEVICE ENTRY      FCI*
         LA    R1,DEVTABLE(R1) A(DEVICE TYPE)                      FCI*
         MVC   FPRINT,1(R1)   PUT IN THE DEVICE TYPE
         CLI   0(R3),0          INTERNAL READER?                   FCI*
         BE    SETDRTN        YES => GIVE THE USER THE INFO        FCI*
         SR    R15,R15        FOR THE INSERT CHARACTER             FCI*
         AIF   (&QSP).RNB21A                                      RNB21
         IC    R15,1(R3)        DEVICE NUMBER                      FCI*
         AGO   .RNB21B                                            RNB21
.RNB21A  ANOP                                                     RNB21
         ICM   R15,3,1(R3)      DEVICE NUMBER  (SP2)              RNB21
.RNB21B  ANOP                                                     RNB21
         CVD   R15,DOUBLEWD   IN PACKED DECIMAL                    FCI*
         IC    R15,0(R1)      OFFSET TO WHERE THE DEV # GOES       FCI*
         LA    R15,FPRINT(R15) A(WHERE THE DEV # GOES)
         MVC   1(L'DIGITS3,R15),DIGITS3 SET UP THE EDIT OF 3 DIGITSKMT*
         EDMK  0(L'DIGITS3+1,R15),DOUBLEWD+6 DEV # IN EBCDIC       FCI*
         MVC   0(L'DIGITS3+1,R15),0(R1) ADJUST FOR BLANKS          FCI*
*                                                                  FCI*
         B     SETDRTN        GO EXIT
*                                                                  FCI*
RMTDEV   SR    R0,R0          FOR THE INSERT CHARACTER             FCI*
         AIF   (&QSP).QSP3                                        UF020
         IC    R0,1(R3)         REMOTE NUMBER                      FCI*
         AGO   .QSP4                                              UF020
.QSP3    ANOP                                                     UF020
         IC    R0,2(R3)         REMOTE NUMBER                     RNB21
.QSP4    ANOP                                                     UF020
         CVD   R0,DOUBLEWD    IN PACKED DECIMAL                    FCI*
         MVI   FPRINT,C'R'    INDICATE A REMOTE DEVICE             FCI*
         MVC   FPRINT+2(L'THREEPT),THREEPT SET UP THE EDIT MASK    FCI*
         EDMK  FPRINT+1(L'THREEPT),DOUBLEWD+6 CONVERT TO EBCDIC    FCI*
         MVC   FPRINT+1(L'THREEPT),0(R1) ADJUST FOR BLANKS         FCI*
         LA    R1,FPRINT+1    A(SPOT JUST BEFORE POSSIBLE SEP)     FCI*
FINDPT   LA    R1,1(R1)       A(NEXT BYTE)                         FCI*
         CLI   0(R1),C'.'     FOUND THE SEPARATOR?                 FCI*
         BNE   FINDPT         NO => KEEP LOOKING                   FCI*
         SR    R15,R15        FOR THE INSERT CHARACTER             FCI*
         IC    R15,0(R3)        DEVICE TYPE INDICATOR              FCI*
         SRL   R15,3          RIGHT JUSTIFIED                      FCI*
         LA    R15,RMTDEVS-HIGHBIT/8(R15) A(DEVICE TYPE)           FCI*
         MVC   1(2,R1),0(R15) PUT IN THE DEVICE TYPE               FCI*
         MVC   3(1,R1),0(R3) PUT IN THE DEVICE NUMBER              FCI*
         OI    3(R1),C'0'     MAKE THE DEVICE NUMBER PRINTABLE     FCI*
         B     SETDRTN
         EJECT ,                                                   FCI*
SETDRTN  L     R7,SETDHOLD    GET RETURN ADDRESS                   FCI*
         BR    R7             RETURN TO OUR CALLER                 FCI*
         SPACE 5                                                   FCI*
DIGITS3  DC    X'202020'                                           FCI*
THREEPT  DC    X'2020204B'                                         FCI*
         DS    0H                                                  FCI*
DEVTABLE DC    AL1(0),CL8'INTRDR',AL1(6),CL8'READER'               FCI*
         DC    AL1(7),CL8'PRINTER',AL1(5),CL8'PUNCH'               FCI*
DEVTYPEL DC    AL2((*-DEVTABLE)/4)                                 FCI*
RMTDEVS  DC    C'**',C'RD',C'PR',C'PU'                             FCI*
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
ED8      DC    X'4020202020202120'
ED5      DC    X'402020202021'
ED3      DC    X'40202021'
HEADING  DC    C'  QUEUE  POSITION JOBNAME    JOB#  PRIORITY  LINES'
         DC    CL40'   EXECUTING'
HIGHBIT  EQU   X'80'
TABLE    EQU   *-240
         DC    C'0123456789ABCDEF' TRANSLATE TO PRINTABLE HEX
WORK     DSECT
         DS    CL80
CONVERT  DS    D
SETDHOLD DS    F
DOUBLEWD DS    D
NUMBER   DS    CL16
FORMAT   CSECT
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
FORMAT   CSECT ,                                                  UF023
         $JQE
         $JOE
JCT      EQU   0                                                  RNB25
BUFSTART EQU   0                                                  RNB25
BUFDSECT EQU   0                                                  RNB25
         $JCT                                                     RNB25
         QCOMMON
         ORG   QDMSG
FCLEAR   DS    0CL80          FORMAT FOR QUEUE RECORDS
FQNAME   DS    CL6            NAME OF QUEUE
         DS    C
FQUEUE   DS    C              CLASS NAME
         DS    CL2
FCOUNT   DS    CL6            POSITION IN QUEUE
         DS    CL2
FNAME    DS    CL8            JOBNAME
         DS    CL2
FJOBNO   DS    CL6            JES2 JOB NUMBER
         DS    CL2
FPRIO    DS    CL4            JOB PRIORITY
         DS    CL2
FLINES   DS    CL8            NUMBER OF OUTPUT LINES
         DS    CL3
FSYSID   DS    CL8            SYSTEM ID
         DS    CL3
FHOLD    DS    CL4            JOB HOLD STATUS
         DS    CL1
FREMOTE  DS    CL8            REMOTE
         ORG   FSYSID
FPRINT   DS    CL8            PRINTING
         ORG   FCOUNT
FHEX     DS    0CL56          LENGTH OF JQE HEX DUMP
FHEXO    DS    0CL64          LENGTH OF JOE HEX DUMP
FHEX1    DS    0CL15
         DS    CL14
FHEX2    DS    0CL15
         DS    CL14
FHEX3    DS    0CL15
         DS    CL14
FHEX4    DS    0CL15
         DS    CL14
FHEXC    DS    0CL9           CLEAR LAST BYTES FOR JQE
FHEX5    DS    0CL9
         DS    CL8
FHEXOC   DS    C              CLEAR LAST BYTE FOR JOE
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q8
HELP     QSTART 'QUEUE COMMAND - DISPLAY HELP'
         GBLB  &QPFK          PF-KEY OPTION. DEFINED BY QSTART     ICBC
         USING QDISPLAY,R10   BASE REG FOR DISPLAY WORK AREA
         L     R10,QVDSPL     ADDR OF DISPLAY WORK AREA
***********************************************************************
*                                                                     *
*   PASS HELP SCREEN TO DISPLAY MODULE                                *
*                                                                     *
***********************************************************************
         MVC   QDHLINE,HEADING MOVE HEADING
         LA    R2,MESSAG1N     NUMBER OF MESSAGES                 UF003
         L     R3,=A(MESSAGE1) ADDRESS OF FIRST MESSAGE           UF003
         BAL   R4,PUTHELP      WRITE THE MESSAGES                 UF003
         SPACE 1                                                  UF003
         LA    R2,MESSAG2N     NUMBER OF MESSAGES                 UF003
         L     R3,=A(MESSAGE2) ADDRESS OF FIRST MESSAGE           UF003
         BAL   R4,PUTHELP      WRITE THE MESSAGES                 UF003
         SPACE 1                                                  UF003
         LA    R2,MESSAG3N     NUMBER OF MESSAGES                 UF003
         L     R3,=A(MESSAGE3) ADDRESS OF FIRST MESSAGE           UF003
         BAL   R4,PUTHELP      WRITE THE MESSAGE                  UF003
         SPACE 1                                                  UF003
         TM    QXAUTH,1       IS THE USER PRIVILEGED?             UF003
         BNO   NOAUTH         NO. SKIP.                           UF003
         LA    R2,MESSAGXN    NUMBER OF PRIV MSGS                 UF003
         L     R3,=A(MESSAGEX) ADDRESS OF FIRST MESSAGE           UF003
         BAL   R4,PUTHELP      WRITE THE MESSAGE                  UF003
         SPACE 1                                                  UF003
NOAUTH   DS    0H
         AIF  (NOT &QPFK).PFK1    SKIP DISPLAY OF PF-KEYS          ICBC
         MVC   QDHLINE,HEADINGP MOVE HEADING FOR PF KEYS           ICBC
         LA    R2,MESSAGPN     NUMBER OF MESSAGES                 UF003
         L     R3,=A(MESSAGEP) ADDRESS OF FIRST MESSAGE           UF003
         BAL   R4,PUTHELP      WRITE THE MESSAGES                 UF003
         SPACE 1                                                  UF003
.PFK1    ANOP                                                      ICBC
         QSTOP
         SPACE 3                                                  UF003
PUTHELP  MVC   QDMLNG,=H'80'   SET MSG LENGTH                     UF003
PUTHELP1 ST    R3,QDMSGA       SET MESSAGE ADDRESS                UF003
         L     R15,=V(DISPLAY) ADDRESS OF DISPLAY ROUTINE         UF003
         BALR  R14,R15         LINK TO ROUTINE                    UF003
         LA    R3,80(,R3)      POINT TO NEXT LINE                 UF003
         BCT   R2,PUTHELP1     LOOP TILL DONE                     UF003
         SPACE 1                                                  UF003
         XC    QDMLNG,QDMLNG   SET TO FLUSH BUFFER                UF003
         L     R15,=V(DISPLAY) ADDRESS OF DISPLAY ROUTINE         UF003
         BALR  R14,R15         LINK TO ROUTINE                    UF003
         BR    R4              RETURN TO CALLER                   UF003
         SPACE 3                                                  UF003
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
         LTORG
HEADING  DC    CL80'THE FOLLOWING SUBCOMMANDS ARE SUPPORTED:'
         AIF  (NOT &QPFK).PFK2    SKIP DISPLAY OF PF-KEYS          ICBC
HEADINGP DC    CL80'THE PF KEYS ARE DEFINED AS FOLLOWS:'           ICBC
.PFK2    ANOP                                                      ICBC
MESSAGE1 DC    CL4' '
 DC CL80'DA           - DISPLAY ALL JOBS IN EXECUTION'
 DC CL80'DT           - DISPLAY TSO USERS'
 DC CL80'DS           - DISPLAY SYSTEM TASKS'
 DC CL80'DC           - DISPLAY CPU BATCH/STC/TSO'
 DC CL80'STATUS LEVEL - DISPLAY ALL JOBS BEGINNING WITH LEVEL'
 DC CL80'DQ           - DISPLAY INPUT QUEUES'
 DC CL80'DI CLASS     - DISPLAY ALL JOBS IN INPUT CLASS'
 DC CL80'AI CLASS     - DISPLAY JOBS AVAILABLE FOR PROCESSING'
 DC CL80'HI CLASS     - DISPLAY HELD JOBS IN INPUT CLASS'
 DC CL80'DF           - DISPLAY OUTPUT QUEUES'
 DC CL80'DO CLASS     - DISPLAY ALL JOBS IN OUTPUT CLASS'
 DC CL80'AO CLASS     - DISPLAY AVAILABLE OUTPUT'
 DC CL80'HO CLASS     - DISPLAY HELD OUTPUT'
 DC CL80'END          - TERMINATE PROCESSING'
 DC CL84' '
 DC CL80'DEFAULT FOR LEVEL IS LOGON ID'
 DC CL80'DEFAULT FOR CLASS IS ALL CLASSES'
 DC CL80'NO DEFAULT FOR JOBNAME'
 DC CL76' '
MESSAG1N EQU   (*-MESSAGE1)/80 NUMBER OF MESSAGES                 UF003
         SPACE 1                                                  UF003
MESSAGE2 DC    CL4' '
 DC CL80'DJ JOBNAME        - DISPLAY JOB BY JOBNAME'
 DC CL80'JCL  JOBNAME      - LIST JCL FOR A JOB'
 DC CL80'JLOG JOBNAME      - LIST JOBLOG FOR A JOB (ONLY ON OUTPUT Q)'
 DC CL80'JMSG JOBNAME      - LIST SYSTEM MESSAGES FOR A JOB'
 DC CL80'DD   JOBNAME      - LIST SYSIN AND SYSOUT DATASETS FOR A JOB'
 DC CL80'PDDB JOBNAME      - LIST PDDB''S FOR A JOB'              UF025
 DC CL80'LIST JOBNAME DSID - LIST A SYSIN OR SYSOUT DATASET'
 DC CL80'FIND ''STRING'' COL(SS,EE)  - FIND CHARACTER STRING IN DATA'
 DC CL80'FALL ''STRING'' COL(SS,EE)  - FIND ALL OCCURRENCES OF STRING'
 DC CL80'                              COL DEFAULTS TO ALL           '
 DC CL80'COL  #            - REPOSITION HORIZONTALLY TO COLUMN NUMBER'
 DC CL80'@/MD #            - REPOSITION TO SPECIFIC RECORD NUMBER'
 DC CL80'+/D  #            - REPOSITION FORWARD IN DATASET # RECORDS'
 DC CL80'-/UP #            - REPOSITION BACKWARD IN DATASET # RECORDS'
 DC CL80'T/TOP             - REPOSITION TO TOP OF DATASET'
 DC CL80'B/BOTTOM          - REPOSITION TO BOTTOM OF DATASET'
 DC CL80'HF/HB #           - FORWARD/BACKWARD # HALF PAGES'
 DC CL80'PF/PB #           - FORWARD/BACKWARD # PAGES'
 DC CL84' '
 DC CL80'DSID CAN BE DETERMINED BY USING SUBCOMMAND DD OR PDDB'   UF025
 DC CL72'JOBNAME CAN BE JOB NAME, NUMBER, OR "*" FOR CURRENT JOB' UF007
MESSAG2N EQU   (*-MESSAGE2)/80 NUMBER OF MESSGES                  UF003
         SPACE 1                                                  UF003
MESSAGE3 DC    CL4' '
 DC CL80'SLOG JOB# SEQ - LIST THE SYSTEM LOG DATASET'
 DC CL80'FTIME TIME    - REPOSITION SYSTEM LOG TO GIVEN TIME'
 DC CL80'SAVE DSNAME   - CREATE A COPY OF THE CURRENT DATASET'
 DC CL80'PRINT ON CLASS DEST  - OPEN SCREEN LOG'
 DC CL80'PRINT                - PRINT CURRENT SCREEN'
 DC CL80'PRINT OFF            - CLOSE SCREEN LOG'
 DC CL84' '
 DC CL80'JOB# MAY BE DETERMINED BY STATUS SYSLOG'
 DC CL80'DEFAULT FOR SEQ IS 0 (THE CURRENT SYSLOG DATASET)'
 DC CL80'    (USE A VALUE OF 1, 2, ... TO OBTAIN PREVIOUS DATASETS)'
 DC CL80'TIME IS IN THE FORM HH.MM.SS'
 DC CL80'DSNAME WILL BE EXPANDED TO USERID.DSNAME.DATA'
 DC CL76' '
 DC CL80'MODEL         - SET 3270 MODEL 2, 3, 4, OR 5'            UF003
 DC CL80'TSO  CMD PRMS - ISSUE ANY TSO COMMAND W/ OPTIONAL PARMS' UF017
 DC CL80'EXEC CMD PRMS - ISSUE ANY TSO COMMAND W/ OPTIONAL PARMS' UF017
 DC CL80' '                                                       UF003
MESSAG3N EQU   (*-MESSAGE3)/80 NUMBER OF MESSAGES                 UF003
         SPACE 1                                                  UF003
MESSAGEX DC    CL4' '                                             UF003
 DC CL84'PRIVILEGED SUBCOMMANDS:'
 DC CL80'XB MTTR              - DISPLAY BLOCK FROM SYS1.HASPACE'
 DC CL80'XD JOBNAME DSID      - UNRESTRICTED DISPLAY OF DATASETS'
 DC CL80'XI                   - DISPLAY ACTIVE INITIATORS       '
 DC CL80'XJ JOBNAME           - DISPLAY UNINTERPRETED JQES AND JOES'
 DC CL80'JQE JOBNAME          - DISPLAY JQE IN HEX/EBCDIC'        UF015
 DC CL80'JCT JOBNAME <OFFSET> - DISPLAY JCT IN HEX/EBCDIC'        UF016
 DC CL80'JOE JOBNAME          - DISPLAY JOES IN HEX/EBCDIC'       UF026
 DC CL80'HCT                  - DISPLAY HCT $SAVE AREA   '        UF022
MESSAGXN EQU   (*-MESSAGEX)/80 NUMBER OF MESSAGES                 UF003
         AIF  (NOT &QPFK).PFK3    SKIP DISPLAY OF PF-KEYS          ICBC
MESSAGEP DC    CL4' '                                              ICBC
 DC CL80'_____________________________'                            ICBC
 DC CL80'|PK1     |PK2     |PK3      |'                            ICBC
 DC CL80'|  HELP  |  DA    |   END   |'                            ICBC
 DC CL80'|________|________|_________|'                            ICBC
 DC CL80'|PK4     |PK5     |PK6      |'                            ICBC
 DC CL80'|  PRINT |  FIND  |   DI    |'                            ICBC
 DC CL80'|________|________|_________|'                            ICBC
 DC CL80'|PK7     |PK8     |PK9      |'                            ICBC
 DC CL80'|  PB    |  PF    |   DO    |'                            ICBC
 DC CL80'|________|________|_________|'                            ICBC
 DC CL80'|PK10    |PK11    |PK12     |'                            ICBC
 DC CL80'|  COL 1 | COL 41 |   ST    |'                            ICBC
 DC CL80'|________|________|_________|'                            ICBC
 DC CL76' '                                                        ICBC
 DC CL80'TO SPECIFY OPERANDS (FOR PF5, AND OPTIONALLY FOR PF6, 9, 12),'
 DC CL80'OR TO TEMPORARILY OVERRIDE THE DEFAULTS (FOR PF7, 8, 10, 11),'
 DC CL80'KEY IN THE VALUE AND PRESS THE APPROPRIATE PF KEY.'       ICBC
 DC CL4' '                                                         ICBC
MESSAGPN EQU   (*-MESSAGEP)/80 NUMBER OF MESSAGES                 UF003
.PFK3    ANOP                                                      ICBC
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=Q9
HEXBLK   QSTART 'QUEUE COMMAND - HEXADECIMAL DUMP OF A BLOCK'
         USING QCKPT,R10      BASE REG FOR CKPT WORK AREA
         L     R10,QVCKPT     LOAD BASE REG
         USING QDISPLAY,R9    BASE REG FOR DISPLAY WORK AREA
         L     R9,QVDSPL      LOAD BASE REG
         L     R2,QCBLKA      BLOCK IOAREA ADDR                   UF013
***********************************************************************
*                                                                     *
*   VALIDATE AND CONVERT BLOCK ADDRESS                                *
*                                                                     *
***********************************************************************
         LH    R1,QLNG1       LENGTH OF USER PARM
         LTR   R1,R1          IS THE LENGTH ZERO?
         BNP   TILT           YES. TILT.
         CH    R1,=H'8'       IS THE LENGTH TOO BIG?
         BH    TILT           YES. TILT.
         CLI   QPARM1,C'*'    USE CURRENT BUFFER CONTENTS?        UF013
         BE    READOK         YES, SKIP THE READ                  UF013
         CLI   QPARM1,C'+'    CHAIN TO NEXT BLOCK?                UF013
         BNE   READ1          NO, CONTINUE WITH NORMAL CODE       UF013
         MVC   QCTRAK,0(R2)   GET NEXT BLOCK ADDRESS              UF013
         OC    QCTRAK,QCTRAK  TEST FOR END OF CHAIN               UF013
         BNZ   READ2          GO READ BLOCK IF OK                 UF013
         QTILT ' *** BLOCK CHAIN FIELD IS ZERO ***'               UF013
READ1    MVC   QDWORD,QPARM1  LEAVE THE ORIGINAL ALONE            UF013
         TR    QDWORD,TABLEH  CONVERT TO HEX                      UF013
         EX    R1,PACK        PACK INTO QCTRAK
***********************************************************************
*                                                                     *
*   READ THE BLOCK FROM HASPACE                                       *
*                                                                     *
***********************************************************************
READ2    DS    0H                                                 UF013
         LR    R1,R2          PARM FOR READSPC
         L     R15,=V(READSPC) ROUTINE TO READ HASPACE
         BALR  R14,R15        GO TO IT
READOK   DS    0H                                                 UF013
***********************************************************************
*                                                                     *
*   PRINT THE BLOCK                                                   *
*                                                                     *
***********************************************************************
         LH    R0,HASPACE+62  LENGTH OF DATA                      UF012
         LH    R1,QLNG2       LENGTH OF USER OFFSET               UF013
         LTR   R1,R1          IS THE LENGTH ZERO?                 UF013
         BNP   DUMP1          YES. NONE SPECIFIED                 UF013
         CH    R1,=H'8'       IS THE LENGTH TOO BIG?              UF013
         BH    TILTO          YES, GIVE UP                        UF013
         EX    R1,OFFTR       CONVERT TO HEX                      UF013
         EX    R1,OFFPACK     PACK INTO QDWORD                    UF013
         LH    R1,QDWORD      PICK UP OFFSET                      UF013
         AR    R2,R1          ADD TO BASE ADDRESS                 UF013
         SR    R0,R1          SUBTRACT FROM TOTAL LENGTH          UF013
         SLL   R1,16          MOVE TO PROPER POSITION             UF013
         OR    R0,R1          INSERT INTO LENGTH REG              UF013
DUMP1    LR    R1,R2          POINT TO BUFFER READ                UF012
         L     R15,=V(HEXDUMP) ADDRESS OF DUMP ROUTINE            UF012
         BALR  R14,R15        LINK TO IT                          UF012
STOP     QSTOP
***********************************************************************
*                                                                     *
*   EXCEPTIONS AND RETURN                                             *
*                                                                     *
***********************************************************************
TILT     QTILT '*** BLOCK ADDRESS WAS OMITTED ***'
TILTO    QTILT '*** INVALID OFFSET SPRCIFIED ***'
***********************************************************************
*                                                                     *
*   MISCELLANY                                                        *
*                                                                     *
***********************************************************************
PACK     PACK  QCTRAK(5),QDWORD(1) BLOCK ADDRESS                  UF013
OFFTR    TR    QPARM2,TABLEH       CONVERT TO HEX                 UF013
OFFPACK  PACK  QDWORD(3),QPARM2(1) PACK TO WORK AREA              UF013
         LTORG
* TABLE FOR HEX CONVERT
TABLEH   DC    CL193' '
         DC    X'0A0B0C0D0E0F',CL41' ',C'01234567890',CL6' '
SYMDEL   DSECT ,                   KILL SYM CARD GENERATION       UF023
         QCOMMON
SYMNODEL DSECT ,                   RESTORE SYM CARD GENERATION    UF023
         END
./ ADD NAME=QCOMMON
         MACRO
         QCOMMON &CSECT=NO,                                            X
               &UNIT=3350,     DEFAULT UNIT NAME FOR SYS1.HASPCKPT     X
               &VOLSER=MVSDLB, DEFAULT VOLUME SERIAL FOR SYS1.HASPCKPT X
               &SID1='BSP1',   SYSTEM ID FOR SYSTEM # 1 (UP TO 8 CHARS)X
               &SID2='BSP2',   SYSTEM ID FOR SYSTEM # 2                X
               &SID3='BSP3',   SYSTEM ID FOR SYSTEM # 3                X
               &SID4='BSP4',   SYSTEM ID FOR SYSTEM # 4                X
               &SID5='BSP5',   SYSTEM ID FOR SYSTEM # 5                X
               &SID6='BSP6',   SYSTEM ID FOR SYSTEM # 6                X
               &SID7='BSP7'    SYSTEM ID FOR SYSTEM # 7
         GBLB  &QPFK      PF-KEY OPTION. SEE QSTART MACRO          ICBC
         GBLB  &QSP       MVS/SP OPTION. SEE QSTART MACRO         UF020
         GBLB  &QRACF     RACF OPTION. SEE QSTART MACRO           RNB03
         GBLC  &QRACUSR   RACF USERID. SEE QSTART MACRO           RNB03
         LCLA  &RACLEN    LENGTH OF RACF USERID                   RNB03
         LCLA  &SIZE      BLOCK SIZE FOR CKPT DCB
         AIF   ('&CSECT' EQ 'YES').CSECT
         TITLE 'QUEUE COMMAND - COMMON AREA DSECT'
***********************************************************************
*                                                                     *
*   QUEUE COMMAND - COMMON AREA DSECT                                 *
*                                                                     *
***********************************************************************
QCOMMON  DSECT
.CSECT   ANOP
***********************************************************************
*                                                                     *
*   VECTOR TABLE - ADDRESSES OF AREAS IN QCOMMON                      *
*                                                                     *
***********************************************************************
QVDSPL   DC    A(QDISPLAY)    PTR TO DISPLAY WORK AREA
QVDAIR   DC    A(QDAIR)       PTR TO DAIR WORK AREA
QVCKPT   DC    A(QCKPT)       PTR TO CKPT WORK AREA
QVPRINT  DC    A(QCPRINT)     PTR TO PRINT WORK AREA               FCI*
         DC    3F'0'          SPARE POINTERS RESERVED FOR FUTURE
QFRSTSA  DC    A(0)           ADDRESS OF FIRST SAVE AREA
***********************************************************************
*                                                                     *
*   MISCELLANEOUS NUTS AND BOLTS                                      *
*                                                                     *
***********************************************************************
QDWORK   DC    D'0'           SCRATCH DOUBLE WORD                 UF009
QDWORD   DC    D'0'           SCRATCH DOUBLE WORD                 UF009
QLOGON   DC    CL8' '         LOGON ID (JOBNAME)
QCLASSH  DC    0H'0',X'00'    HALFWORD BOUNDARY
QCLASS   DC    C' '           SEARCH CLASS
QCODEH   DC    0H'0',X'00'    HALFWORD BOUNDARY
QCODE    DC    X'00'          SEARCH FUNCTION CODE
QSUBCMD  DC    A(0)           ADDR OF CURRENT SUBCOMMAND
QOFF0    DC    H'0'           OFFSET TO SUBCOMMAND
QLNG0    DC    H'0'           LENGTH OF SUBCOMMAND
QSUBNAME DC    CL8' '         NAME OF SUBCOMMAND                  UF018
QOFF1    DC    H'0'           OFFSET TO QPARM1
QLNG1    DC    H'0'           LENGTH OF QPARM1
QPARM1   DC    CL8' '         USER SUPPLIED PARAMETER #1
QOFF2    DC    H'0'
QLNG2    DC    H'0'
QPARM2   DC    CL8' '                                 #2
QOFF3    DC    H'0'
QLNG3    DC    H'0'
QPARM3   DC    CL8' '                                 #3
QOFF4    DC    H'0'
QLNG4    DC    H'0'
QPARM4   DC    CL8' '                                 #4
QXAUTH   DC    X'00'          AUTOMATIC HOLD
QFLAG1   DC    X'00'          FLAG BYTE                           UF009
QFLG1IOE EQU   X'80'          I/O ERROR ON SPOOL READ             UF009
QFLG1OPR EQU   X'40'          TSO OPERATOR AUTHORITY              UF010
QFLG1DBC EQU   X'20'          ESTAE ENVIRONMENT ESTABLISHED       UF024
QFLG1LCL EQU   X'10'          Q20 - SEARCHING LOCAL JOE QUE (SP3) RNB16
         DC    XL2'0'         RESERVED                            UF009
QBLANK   DC    CL132' '       132 BLANKS                          UF003
QFZONE   DC    C'0'           USED TO CLEAR QFZONES
QFZONES  DC    C'00000000'    USED FOR NUMERIC CHECK
QCOUNT   DC    PL3'0'         NUMBER OF ELEMENTS IN QUEUE
QCOUNTA  DC    PL3'0'         NUMBER OF ELEMENTS IN AWAITING QUEUE
QCOUNTE  DC    PL3'0'         NUMBER OF ELEMENTS IN EXECUTION QUEUE
QCOUNTH  DC    PL3'0'         NUMBER OF ELEMENTS IN HOLD QUEUE
QOFFS    DC    H'0'           START COLUMN FOR FIND
QOFFE    DC    H'0'           END COLUMN FOR FIND
QDELIMIT DC    C' '           DELIMITER
QRSVD    DC    XL15'0'        RSVD
QPJOBID  DC    F'0'           JOB ID FOR LISTDS     ** THESE TWO FIELDS
QPDSID   DC    H'0'           DATASET ID FOR LISTDS ** MUST BE CONTIG.
QPOFFSET DC    H'0'           PRINT OFFSET FROM BEGINNING OF RECORD
QPREC    DC    PL4'0'         CURRENT RECORD COUNT
QPLNG    DC    H'0'           LENGTH OF COMPARE FIELD FOR FIND
QPFIND   DC    CL58' '        COMPARE FIELD FOR FIND
QSYSID   DC    CL8' '         SYSTEM ID TABLE
* YOU MUST SUPPLY THE NAME OF EACH CPU IN YOUR COMPLEX
         DC    CL8&SID1       SYSTEM ID FOR SYSTEM 1
         DC    CL8&SID2                            2
         DC    CL8&SID3                            3
         DC    CL8&SID4                            4
         DC    CL8&SID5                            5
         DC    CL8&SID6                            6
         DC    CL8&SID7                            7
         EJECT
***********************************************************************
*                                                                     *
*   DATASET ALLOCATION FIELDS                                         *
*      (ADAPTED FROM SYS1.MACLIB (IKJDAPL,IKJDAP08,0C,18))            *
*                                                                     *
***********************************************************************
QDAIR    DS    0D             START OF DAIR WORK AREAS
DAIRECB  DC    F'0'           ECB USED BY DAIR
DAIRFLAG DC    X'00'          FLAG USED BY ALLOCATE SUBROUTINE
         DC    XL3'0'         DEAD SPACE FOR ALLIGNMENT
***********************************************************************
*    THE DYNAMIC ALLOCATION INTERFACE ROUTINE (DAIR) PARAMETER LIST   *
*    (DAPL) IS A LIST OF ADDRESSES PASSED FROM THE INVOKER TO DAIR    *
*    VIA REGISTER 1                                                   *
***********************************************************************
DAPLUPT  DC    A(0)     PTR TO UPT
DAPLECT  DC    A(0)     PTR TO ECT
DAPLECB  DC    A(DAIRECB) PTR TO CP'S ECB
DAPLPSCB DC    A(0)     PTR TO PSCB
DAPLDAPB DC    A(0)     PTR TO DAIR PARAMETER BLOCK
***********************************************************************
*                                                                     *
*   ALLOCATE DDNAME(W) DSNAME(X) SHR UNIT(Y) VOLUME(Z)                *
*                                                                     *
***********************************************************************
DA08CD   DC    X'0008'  DAIR ENTRY CODE
DA08FLG  DC    X'00'    FUNCTIONS TO BE PERFORMED WHEN RET CODE IS 0
         DC    X'00'
DA08DARC DC    H'0'     DYN ALLOC RETURN CODE
DA08CTRC DC    H'0'     CATALOG RETURN CODE
DA08PDSN DC    A(0)     POINTER TO DSNAME TO BE SEARCHED IN DSE
DA08DDN  DC    CL8' '   DDNAME TO BE SEARCHED IN DSE
* YOU MUST SUPPLY THE DEFAULT UNIT AND VOLUME SERIAL FOR YOUR SYSTEM
DA08UNIT DC    CL8'&UNIT' UNITNAME FOR SYS1.HASPCKPT
DA08SER  DC    CL8'&VOLSER' VOLUME SERIAL FOR SYS1.HASPCKPT
DA08BLK  DC    F'0'     DATA SET  AVERAGE RECORD LENGTH
DA08PQTY DC    F'0'     PRIMARY SPACE QUANTITY
DA08SQTY DC    F'0'     SECONDARY SPACE QUANTITY
DA08DQTY DC    F'0'     DIRECTORY BLOCK QUANTITY
DA08MNM  DC    CL8' '   MEMBER NAME
DA08PSWD DC    CL8' '   PASSWORD
DA08DSP1 DC    X'08'    DATA SET STATUS FLGS - SHR
DA08DPS2 DC    X'08'    DATA SET DISPOSITION - KEEP
DA08DPS3 DC    X'08'    DATA SET CONDITIONAL DISPOSITION - KEEP
DA08CTL  DC    X'00'    FLAGS TO CONTROL ACTIONS TAKEN BY DAIR
         DC    XL3'0'   RESERVED
DA08DSO  DC    X'00'    DSORG
DA08ALN  DC    CL8' '   ATTR-LIST-NAME                           C99236
***********************************************************************
*                                                                     *
*   FREE DDNAME(XXXXXXXX)                                             *
*                                                                     *
***********************************************************************
DA18CD   DC    X'0018'  DAIR ENTRY CODE
DA18FLG  DC    X'00'    FUNCTIONS TO BE PERFORMED WHEN RET CODE IS 0
         DC    X'00'
DA18DARC DC    H'0'     DYNAMIC ALLOCATION RETURN CODE
DA18CTRC DC    H'0'     CATALOG RETURN CODE AREA
DA18PDSN DC    A(0)     POINTER TO DSNAME TO BE SEARCHED IN DSE
DA18DDN  DC    CL8' '   DDNAME TO BE SEARCHED IN DSE
DA18MNM  DC    CL8' '   MEMBER NAME
DA18SCLS DC    CL2' '   SYSOUT CLASS DESIRED WHEN UNALLOCATING  A
*                       SYSOUT DATA SET
DA18DPS2 DC    X'08'    DATA SET DISPOSITION - KEEP
DA18CTL  DC    X'10'    FLAGS FOR SPECIAL DAIR PROCESSING
DA18JBNM DC    CL8' '   IGNORED AS OF OS VS/2 RELEASE 2       Y02670
         EJECT
***********************************************************************
*                                                                     *
*   CHECKPOINT WORK AREAS                                             *
*                                                                     *
***********************************************************************
* NOTE - BLOCKSIZES ARE INSTALLATION DEPENDENT
QCKPT    DS    0D
         AIF   (NOT &QSP).QSP1                                    UF020
QCJIXL   DC    A(0)                                               UF020
QCJIXA   DC    A(0)           ADDRESS OF JIX IOAREA               UF020
.QSP1    ANOP                                                     UF020
QCJQTA   DC    A(0)           ADDRESS OF JQT IOAREA
QCJOTA   DC    A(0)           ADDRESS OF JOT IOAREA
QCJCTA   DC    A(0)           ADDRESS OF JCT IOAREA
QCIOTA   DC    A(0)           ADDRESS OF IOT IOAREA
QCBLKA   DC    A(0)           ADDRESS OF DATASET BLOCK IOAREA
QCJQTL   DC    F'0'           ADDRESS OF FIRST CKPT REOCRD
QCJQEA   DC    A(0)           ADDR OF CURRENT JQE
QCJOTL   DC    F'0'           COUNT OF RECORDS ON CKPT DS
QCPDDB1  DC    F'0'           OFFSET IN IOT TO FIRST PDDB
QCTRAK   DS    0F             DISK ADDR IN THE FORM MTTR
QCTRAKM  DC    X'0'           EXTENT NUMBER
QCTRAKTT DC    X'0000'        ABSOLUTE TRACK NUMBER
QCTRAKR  DC    X'0'           RECORD NUMBER
         DC    X'0'           EXTRA SPACE NEEDED FOR HEX CONVERT
QCDAD    DS    0XL8           DISK ADDR IN THE FORM MBBCCHHR
QCDADM   DC    X'0'           EXTENT NUMBER
QCDADBB  DC    X'0000'        BIN NUMBER
QCDADCC  DC    X'0000'        CYLINDER NUMBER
QCDADHH  DC    X'0000'        HEAD NUMBER
QCDADR   DC    X'0'           RECORD NUMBER
         DC    XL3'0'         DEAD SPACE TO GET BACK TO FULLWORD
QCJQHEAD DC    A(0)           OFFSET TO JQE HEADERS
         DS    0F
QCCREC   DC    PL4'0'         CURRENT RECORD NUMBER
QCCPTR   DC    A(0)           CURRENT TABLE ADDRESS
QCHREC   DC    PL4'0'         HIGHEST RECORD NUMBER
QCHPTR   DC    A(0)           HIGHEST TABLE ADDRESS
QCSTART  DC    A(0)           ADDRESS OF TABLE START
QCEND    DC    A(0)           ADDRESS OF TABLE END
QCHLINE  DS    0CL80          HEADING LINE FOR LISTDS
         DC    C'JOB '
QCJNAME  DC    CL8' '         JOBNAME
         DC    C', DSID '
QCDSNO   DC    CL8' '         DATASET ID NUMBER
         DC    C', REC #       1'
         DC    CL40' '
QCLRECL  DC    H'0'           LRECL FOR SAVE
QCRECFM  DC    X'0'           RECFM FOR SAVE
QCSPOOLS DC    36F'0'         LIST OF DCBS FOR HASPACE
QCTRKCYL DC    36F'0'         LIST OF TRACKS/CYLINDER FOR EACH DCB
&SIZE    SETA  4096
HASPCKPT DCB   DDNAME=HASPCKPT,DSORG=PS,MACRF=(RCP),                   X
               RECFM=U,BLKSIZE=&SIZE
HASPACE  DCB   DDNAME=HASPACE1,DSORG=DA,MACRF=(RIC),OPTCD=A,           X
               RECFM=F
QCDCBL   EQU   *-HASPACE      LENGTH OF HASPACE DCB
QCOUT    DCB   DDNAME=HASPSAVE,DSORG=PS,MACRF=(PM),BUFL=8192
         READ  HDECB1,SF,HASPCKPT,,&SIZE,MF=L
         READ  HDECB2,DI,HASPACE,,0,0,QCDAD,MF=L
QCOPEN   OPEN  (QCOUT,OUTPUT),MF=L
HOCKPT   OPEN  (HASPCKPT),MF=L
***********************************************************************
*                                                                  FCI*
*   PRINT WORKAREA                                                 FCI*
*                                                                  FCI*
***********************************************************************
QCPRINT  DS    0D                                                  FCI*
QPOFF0   DC    H'0'           OFFSET TO SUBCOMMAND                 FCI*
QPLNG0   DC    H'0'           LENGTH OF SUBCOMMAND                 FCI*
QPSUBNME DC    CL8'PRINT'     NAME OF SUBCOMMAND                   FCI*
QPOFF1   DC    H'0'           OFFSET TO QPPARM1                    FCI*
QPLNG1   DC    H'0'           LENGTH OF QPPARM1                    FCI*
QPPARM1  DC    CL8' '         USER SUPPLIED PARAMETER #1           FCI*
QPOFF2   DC    H'0'                                                FCI*
QPLNG2   DC    H'0'                                                FCI*
QPPARM2  DC    CL8' '                                 #2           FCI*
QPOFF3   DC    H'0'                                                FCI*
QPLNG3   DC    H'0'                                                FCI*
QPPARM3  DC    CL8' '                                 #3           FCI*
QPOFF4   DC    H'0'                                                FCI*
QPLNG4   DC    H'0'                                                FCI*
QPPARM4  DC    CL8' '                                 #4           FCI*
QPHEAD1  DC    CL1'1'                                              FCI*
*        123456789.123456789.123456789.123456789.'                 FCI*
 DC CL40'QUEUE HARDCOPY LOG  USER=XXXXXXXX  DATE='                 FCI*
 DC CL40'YY.DDD  HH:MM:SS DAY MON DD,19XX   XXXXX'                 FCI*
 DC CL52' '                                                       UF003
         ORG   QPHEAD1+26                                          FCI*
QPUSER   DS    CL8           FOR USERID                            FCI*
         ORG   QPHEAD1+41                                          FCI*
QPDATE   DS    CL32                                                FCI*
         ORG   QPHEAD1+75                                          FCI*
QPPAGE#  DS    CL6                                                 FCI*
         ORG   ,                                                   FCI*
QPHEAD2  DS    0CL81                                               FCI*
         DC    C' ',80C'-'                                         FCI*
         DC    52C' '                                             UF003
QPDETAIL DC    CL1' '         ASA CONTROL CHARACTER                FCI*
QPLINE   DC    CL132' '       TO HOLD PRINT LINE                  UF003
QPPAGE   DC    PL3'1'                                              FCI*
QPFLAG   DC    XL1'00'                                             FCI*
HARDCPY  EQU   X'80'                                               FCI*
QPRSAVE  DS    CL63           SAVE AREA TO HOLD SUBTITLE INFO      FCI*
QPPWORK  DC    6F'0'          SPARE WORK ZONE                      FCI*
         DS    0F                                                  FCI*
*HASPPRNT DCB  DDNAME=HASPPRNT,DSORG=PS,MACRF=(PM),                FCI*
*              RECFM=FA,LRECL=133,BLKSIZE=133                     UF003
HASPPRNT DCB   DDNAME=HASPPRNT,DSORG=PS,MACRF=(PM),                FCI*X
               RECFM=FA,LRECL=133,BLKSIZE=133                     UF003
         AIF   (NOT &QRACF).RNB03A                                RNB03
******************************************************************RNB03
*                                                                *RNB03
*   RACF FIELDS                                                  *RNB03
*                                                                *RNB03
******************************************************************RNB03
&RACLEN  SETA  K'&QRACUSR       LENGTH OF NEW RACF USERID         RNB03
QNEWUSR  DC    AL1(&RACLEN),CL8'&QRACUSR'  NEW USERID             RNB03
QUSRSAV  EQU   *,9                         OLD USERID             RNB03
         DC    AL1(0),CL8' '               OLD USERID             RNB03
QRACNMXP DC    CL8'QUEUEXP'       ENTITY FOR RACHECK FOR XP CMD   RNB03
QRACNMXD DC    CL8'QUEUEXDS'      ENTITY FOR RACHECK FOR XDS CMD  RNB03
QRACHECK RACHECK ENTITY=QRACNMXP,CLASS='APPL',ATTR=READ,          RNB03X
               APPL=QRACNMXP,MF=L                                 RNB03
.RNB03A  ANOP                                                     RNB03
***********************************************************************
*                                                                     *
*   LIST FORM OF TPUT/TGET                                            *
*                                                                     *
***********************************************************************
QTPUT    TPUT  QDSCREEN,QDSLNG,FULLSCR,MF=L
QTGET    TGET  QDREPLY,63,MF=L
         EJECT
***********************************************************************
*                                                                     *
*   DISPLAY WORK FIELDS                                               *
*                                                                     *
***********************************************************************
QDISPLAY DS    0D             START OS DISPLAY WORK AREA
QDOSZR0  DC    F'0'           ORIG SCREEN DEPTH                   UF003
QDOSZR1  DC    F'0'           ORIG SCREEN LINESZ                  UF003
QDLNELEN DC    H'80'          LENGTH OF DISPLAY LINE              UF003
QDLNES   DC    PL2'21'        LINES PER SCREEN                    UF003
QDSCRLEN DC    AL2(21*80)     LEN OF DISPLAY AREA                 UF003
QDSCRPLN DC    AL2(21*80+QDLINE1-QDSCREEN)   WHAT A PAIN          UF003
         DS    0D                                                 UF003
         AIF   (NOT &QPFK).PFK1
PFREPLY  DS    0CL69                                               ICBC
PFCODE   DC    CL6' '                                              ICBC
PFTXT    DC    CL63' '                                             ICBC
.PFK1    ANOP
QDMSGA   DC    A(0)           ADDRESS OF MESSAGE TO BE DISPLAYED
QDMLNG   DC    H'0'           MESSAGE LENGTH
QDMSG    DC    CL80' '        WORK AREA FOR BUILDING OUTPUT LINE
QDRLNG   DC    H'4'           REPLY LENGTH                        UF018
QDREPLY  DC    CL63'HELP'     TERMINAL USER REPLY                 UF018
         DC    C' '           RESERVED
QDNEXT   DC    H'0'           CURRENT LINE NUMBER ON SCREEN
         DC    C' '           RESERVED
QDSCREEN DS    0C             DISPLAY SCREEN
         DC    X'27'          CONTROL                             UF003
QDSCRO1  DC    X'F5'          ERASE/WRITE ALTERNATE (132 COL)     UF003
         DC    X'C1115D7F1140403C404000' CLEAR SCREEN
         DC    C'QUEUE COMMAND -' TITLE LINE
         DC    X'1DC8'        MARK NEXT FIELD AS INPUT FIELD
QDTLINE  DC    CL63' '        SUBTITLE
         DC    X'1DF0'        TERMINATE INPUT FIELD
         DC    X'11'          SET BUFFER ADDRESS                  UF003
QDSCRO2  DC    X'C150'        (2,1)                               UF003
QDHLINE  DC    CL80' '        HEADING LINE
         DC    X'11'          SET BUFFER ADDRESS                  UF003
QDSCRO3  DC    X'5CF0'        (24,1)                              UF003
         DC    C'REPLY -'     REPLY PROMPT
*        DC    X'1DC8115DF71DF0' 3270 CONTROL CHARACTERS          UF003
         DC    X'1DC8'        MARK NEXT FIELD AS INPUT FIELD      UF003
         DC    X'13'          SET CURSOR ADDRESS                  UF003
         DC    X'11'          SET BUFFER ADDRESS                  UF003
QDSCRO4  DC    X'5DF7'        (24,72)                             UF003
         DC    X'1DF0'        TERMINATE INPUT FIELD               UF003
QDPLUS   DC    C' '           INDICATES MORE TO BE DISPLAYED
         DC    X'11'          SET BUFFER ADDRESS                  UF003
QDSCRO5  DC    X'C260'        (3,1)                               UF003
QDLINE1  DC    40CL80' '      MESSAGE TEXT AREA (FOR 40X80 MAX)   UF003
*DLINE1  DC    CL80' '        FIRST MESSAGE LINE ON SCREEN        UF003
*        DC    20CL80' '      NEXT 20 LINES                       UF003
*        DC    X'115CF813'    TCAM REQUIRES CURSOR AT END OF STR  UF003
QDLINEND EQU   *              END OF LINE BUFFERS                 UF003
QDSLNG   EQU   *-QDSCREEN     LENGTH OF SCREEN BUFFER
QDOVER   DC    X'00'          PAGE OVERFLOW INDICATOR
         EJECT
***********************************************************************
*                                                                     *
*   SAVE AREA FOR GETMAIN/FREEMAIN                                    *
*                                                                     *
***********************************************************************
QGETAREA DC    3F'0'
QGETA1   EQU   QGETAREA+0
QGETA2   EQU   QGETAREA+4
QGETA3   EQU   QGETAREA+8
QGETLNGH DC    F'65536',2F'0'
QGETL2   EQU   QGETLNGH+4
QGETL3   EQU   QGETLNGH+8
QFREE    FREEMAIN L,LA=QGETLNGH,A=QGETAREA,MF=L
         MEND
./ ADD NAME=QSTART
         MACRO
&NAME    QSTART &TITLE,&MAIN=NO,&TYPE=NORMAL
***********************************************************************
*                                                                     *
*   GLOBAL FLAG DEFINITIONS                                           *
*                                                                     *
***********************************************************************
         GBLB  &QPFK          PF-KEY OPTION (SEE Q5 AND Q8)
         GBLB  &QACF2         ACF2 AUTH CHECKING (SEE Q6 AND Q14)  FCI*
         GBLB  &QSP           MVS/SP LEVEL OF JES2.               UF020
         GBLB  &QGEN          FORCE PRINT GEN OF MACRO EXPANSIONS UF019
         GBLB  &QJTIP         JTIP PRODUCT INSTALLED (Q33)        UF025
         GBLB  &QDBC          DBC  PRODUCT INSTALLED              UF024
         GBLB  &QRNB          ENABLES RNB-SPECIFIC CODE           RNB05
.*                              (Q4,Q5,Q14,Q16,Q24,Q26,Q27)       RNB05
         GBLB  &QRACF         RACF CHECKING (QCOMMON,Q10,Q16,Q17) RNB03
         GBLC  &QRACUSR       NEW RACF USERID (QCOMMON,Q10)       RNB03
.*                                                                UF019
.* QPFK=0 SELECTS NO PF-KEY SUPPORT
.* QPFK=1 SELECTS PF=KEY SUPPORT
.*QACF2=0 SELECTS NO ACF2 CHECKING (SHOPS WITHOUT ACF2)            FCI*
.*QACF2=1 SELECTS ACF2 AUTH TO SYSOUT VIA DSN='SYSOUT.LID.JOBNAME' FCI*
.*  QSP=0 SELECTS PRE-SP SUPPORT                                  UF020
.*  QSP=1 SELECTS SP SUPPORT                                      UF020
.* QGEN=0 SELECTS PRINT NOGEN OPTION                              UF019
.* QGEN=1 SELECTS PRINT GEN OPTION                                UF019
.*QJTIP=0 SELECTS NO JTIP SUPPORT.                                UF025
.*QJTIP=1 SELECTS SHOPS WITH JTIP INSTALLED                       UF025
.* QDBC=0 SELECTS NO DBC SUPPORT.                                 UF024
.* QDBC=1 SELECTS SHOPS WITH DBC INSTALLED                        UF024
.*QRACF=0 SELECTS NO RACF SUPPORT                                 RNB03
.*QRACF=1 SELECTS RACF SUPPORT FOR ACCESS TO THE SPOOL/CHECKPOINT RNB03
.*        AND FOR THE XP AND XDS COMMANDS. DEFINE TWO RACF        RNB03
.*        RESOURCES IN CLASS(APPL): QUEUEXP WILL CONTROL THE XP   RNB03
.*        COMMAND AND QUEUEXDS WILL PROVIDE FURTHER CONTROL OVER  RNB03
.*        THE XDS COMMAND. WHEN THE RACHECK FOR THE XDS COMMAND   RNB03
.*        IS DONE, THE JOBNAME WILL BE SPECIFIED AS THE APPLID.   RNB03
.*        THUS, IF YOU SPECIFY AUDIT(ALL) FOR APPL-QUEUEXDS YOU   RNB03
.*        WILL KNOW WHAT DATA YOUR PRIVILEGED USERS HAVE BEEN     RNB03
.*        EXAMINING (AUDITORS LIKE THIS). QRACF IS NOT SUPPORTED  RNB03
.*        VIA THE SYSPARM OPTION.                                 RNB03
.*QRACUSR IS USED IF YOUR SPOOL AND CHECKPOINT ARE DEFINED TO     RNB03
.*        RACF WITH UACC=NONE. IT SPECIFIES A USERID THAT HAS     RNB03
.*        ACCESS TO THE SPOOL AND CHECKPOINT WITH READ AUTHORITY. RNB03
.*        DURING INITIALIZATION, THE SPECIFIED USERID WILL BE     RNB03
.*        SUBSTITUTED INTO THE RACF ACEE SO THE USER OF QUEUE HAS RNB03
.*        ACCESS TO THE SPOOL AND CHECKPOINT DATA SETS ONLY WHILE RNB03
.*        THE QUEUE COMMAND IS IN PROGRESS. IF QRACF=1, THEN      RNB03
.*        QRACUSR MUST BE SPECIFIED. IF YOUR SPOOL AND CHECKPOINT RNB03
.*        HAVE A UACC OF >= READ, SPECIFY QRACUSR AS NULL ('') TO RNB03
.*        BYPASS CHANGING THE ACEE USERID. QRACUSR IS NOT         RNB03
.*        SUPPORTED VIA THE SYSPARM OPTION.                       RNB03
.*                                                                UF019
&QPFK    SETB  1
&QACF2   SETB  0                                                   FCI*
&QSP     SETB  0                                                  UF020
&QGEN    SETB  1                                                  UF019
&QJTIP   SETB  0                                                  UF025
&QDBC    SETB  0                                                  UF024
&QRNB    SETB  0                                                  RNB05
&QRACF   SETB  0                                                  RNB03
&QRACUSR SETC  'QCMD'                                             RNB03
.*                                                                UF019
         LCLA  &CNT,&CTR,&STRNG,&LNTH,&SUB                        UF019
         AIF   (K'&SYSPARM EQ 0).SYSPEND                          UF019
         MNOTE *,'SYSPARM IS ''&SYSPARM'' '                       UF019
         AIF   ('&SYSPARM'(1,1) EQ '(').MORE                      UF019
  MNOTE 2,'SYSPARM SYNTAX ERROR--MUST BE ENCLOSED IN PARENS'      UF019
         AGO   .SYSPEND                                           UF019
.MORE    ANOP                                                     UF019
&CNT     SETA  K'&SYSPARM                                         UF019
&CTR     SETA  1                                                  UF019
&STRNG   SETA  &CTR+1                                             UF019
.LOOP    AIF   ('&SYSPARM'(&CTR,1) EQ ',' OR &CTR EQ &CNT).FOUND  UF019
&CTR     SETA  &CTR+1                                             UF019
         AGO   .LOOP                                              UF019
.FOUND   ANOP                                                     UF019
&LNTH    SETA  &CTR-&STRNG                                        UF019
         AIF   (&LNTH EQ 0).NULL                                  UF019
         AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'PFK').SPNPFK         UF019
&QPFK    SETB  1                                                  UF019
.SPNPFK  AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'NOPFK').SPNPFK2      UF019
&QPFK    SETB  0                                                  UF019
.SPNPFK2 AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'ACF2').SPNACF        UF019
&QACF2   SETB  1                                                  UF019
.SPNACF  AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'NOACF2').SPNACF2     UF019
&QACF2   SETB  0                                                  UF019
.SPNACF2 AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'SP').SPNSP           UF019
&QSP     SETB  1                                                  UF019
.SPNSP   AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'NOSP').SPNSP2        UF019
&QSP     SETB  0                                                  UF019
.SPNSP2  AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'GEN').SPNGEN         UF019
&QGEN    SETB  1                                                  UF019
.SPNGEN  AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'NOGEN').SPNGEN2      UF019
&QGEN    SETB  0                                                  UF019
.SPNGEN2 ANOP                                                     UF019
         AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'JTIP').SPNJTIP       UF019
&QJTIP   SETB  1                                                  UF019
.SPNJTIP AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'NOJTIP').SPNJTP2     UF019
&QJTIP   SETB  0                                                  UF019
.SPNJTP2 ANOP                                                     UF019
         AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'DBC').SPNDBC         UF019
&QDBC    SETB  1                                                  UF019
.SPNDBC  AIF   ('&SYSPARM'(&STRNG,&LNTH) NE 'NODBC').SPNDBC2      UF019
&QDBC    SETB  0                                                  UF019
.SPNDBC2 ANOP                                                     UF019
.NULL    ANOP                                                     UF019
         AIF   (&CTR EQ &CNT).SYSPEND                             UF019
&CTR     SETA  &CTR+1                                             UF019
&STRNG   SETA  &CTR                                               UF019
         AGO   .LOOP                                              UF019
.SYSPEND ANOP                                                     UF019
         AIF   ('&TYPE'  EQ 'GLOBAL').GEN  FORCE PRINT GEN FOR QCOMMON
         AIF   (&QGEN).GEN                                        UF019
         PRINT NOGEN                                              UF019
         AGO   .START                                             UF019
.GEN     PRINT GEN                                                UF019
.START   ANOP                                                     UF019
***********************************************************************
 MNOTE *,'PFK=&QPFK, ACF2=&QACF2, SP=&QSP, GEN=&QGEN, JTIP=&QJTIP, DBC=+
               &QDBC, RACF=&QRACF, RACUSR=&QRACUSR '              RNB03
***********************************************************************
&NAME    START 0
***********************************************************************
*                                                                     *
*   REGISTER USAGE TABLE                                              *
*                                                                     *
***********************************************************************
R0       EQU   0              TEMP WORK
R1       EQU   1              TEMP WORK
R2       EQU   2              WORK REG
R3       EQU   3              WORK REG
R4       EQU   4              WORK REG
R5       EQU   5              WORK REG
R6       EQU   6              WORK REG
R7       EQU   7              WORK REG
R8       EQU   8              WORK REG
R9       EQU   9              ADDRESS OF COMMON SUB-AREA
R10      EQU   10             ADDRESS OF COMMON SUB-AREA
R11      EQU   11             ADDRESS OF COMMON VECTOR TABLE
R12      EQU   12             BASE REGISTER
R13      EQU   13             SAVE AREA AND TEMPORARY WORK AREA
R14      EQU   14             TEMP WORK
R15      EQU   15             TEMP WORK
***********************************************************************
*                                                                     *
*   THE QUEUE COMMAND WAS WRITTEN FOR YOUR AMUSEMENT AND AMAZEMENT BY *
*     THE INTERGALACTIC MESSIANIC INDIVIDUAL GROUP THERAPY DIVISION   *
*     OF TRW SYSTEMS, 1 SPACE PARK, REDONDO BEACH, CA. 90278          *
*   THE ORIGINAL PROGRAMMING WAS DONE BY ANDY ZIDE, CHIEF PROGRAMMER  *
*     AND RESIDENT FLAKE WHO HAS SINCE DEPARTED TRW TO PLAY WITH      *
*     MICROCODE.                                                      *
*   PLEASE ADDRESS ANY COMMENTS, SUGGESTIONS, COMPLAINTS, OR THREATS  *
*     TO STEVE ANDERSON (R3/1028)   (213) 535-0682   OR               *
*        PAUL FELIX     (R3/1028)   (213) 535-0682                    *
*                                                                     *
*   STEVE ANDERSON HAS LEFT TRW.  PLEASE ADDRESS ANY COMMENTS OR      *
*   FIXES TO JACK SCHUDEL AT THE ADDRESS LISTED BELOW.                *
*                                                                     *
***********************************************************************
*                                                                     *
*   THE FOLLOWING INDIVIDUALS HAVE MADE MODIFICATIONS TO QUEUE WHICH  *
*     HAVE BEEN INCORPORATED INTO THIS CURRENT VERSION.               *
*                                                                     *
*        VILKO MACEK                                                  *
*        INSURANCE CORPORATION OF BRITISH COLUMBIA                    *
*        MODIFICATION: PFK SUPPORT                                    *
*                                                                     *
*        TRW ISD                                                      *
*        ANAHEIM, CALIFORNIA                                          *
*        MODIFICATION: DISPLAY CPU TIME FOR BATCH, STC AND TSO        *
*                      DISPLAY INITIATORS                             *
*                                                                     *
*        KEN TRUE                                                     *
*        FAIRCHILD CAMERA AND INSTRUMENT                              *
*        MOUNTAIN VIEW, CALIFORNIA                                    *
*        MODIFICATION: ACF2 SUPPORT                                   *
*                      PRINT SCREEN SUPPORT                           *
*                                                                     *
*        JACK SCHUDEL                                                 *
*        NORTHEAST REGIONAL DATA CENTER                               *
*        233 SSRB, UNIVERSITY OF FLORIDA                              *
*        GAINESVILLE, FLORIDA  32611                                  *
*        (904) 392-4601                                               *
*        MODIFICATIONS:  SEE MEMBER $UFDOC                            *
*                                                                     *
*        WALT FARRELL                                                 *
*        RAINIER NATIONAL BANK                                        *
*        P. O. BOX C34030                                             *
*        SEATTLE, WASHINGTON  98124                                   *
*        (206) 433-7467                                               *
*        MODIFICATIONS:  SEE MEMBER $RNBDOC                           *
*                                                                     *
***********************************************************************
*
         AIF   ('&TYPE' EQ 'NORMAL').GO
         MEXIT
.GO      ANOP
&NAME    TITLE &TITLE
         USING *,R12          BASE REGISTER
         USING QCOMMON,R11    ACCESS TO COMMON VECTOR TABLE
         STM   R14,R12,12(R13) STANDARD REGISTER SAVE
         LR    R12,R15        LOAD BASE REG
         B     *+28           BRANCH AROUND IDENTIFIER
         DC    CL8'&NAME'     MODULE IDENTIFIER
         DC    CL8'&SYSDATE'  ASSEMBLY DATE
         DC    CL8' &SYSTIME'  ASSEMBLY TIME
         AIF   ('&MAIN' EQ 'YES').MAINYES
         LR    R15,R13        RETAIN SAVE AREA ADDR
         LA    R13,72(R13)    POINT TO NEXT SAVE AREA
         AGO   .MAINNO
.MAINYES ANOP
         LR    R2,R1          SAVE PARAMETER REGISTER
         GETMAIN R,LV=4096    GET STORAGE FOR SAVEAREA
         ST    R1,8(R13)      FORWARD POINTER
         ST    R13,4(R1)      BACKWARD POINTER
         LR    R13,R1         MOVE ADDR TO R1
         MEXIT
.MAINNO  ANOP
         ST    R13,8(R15)     FORWARD POINTER
         ST    R15,4(R13)     BACKWARD POINTER
         MEND
./ ADD NAME=QSTOP
         MACRO
&NAME    QSTOP
&NAME    L     R13,4(R13)     LOAD NEXT LOWER SAVE AREA SET
         LM    R14,R12,12(R13) STANDARD REGISTER RESTORE
         BR    R14            RETURN TO CALLER
         MEND
./ ADD NAME=QTILT
         MACRO                                                          00872
&NAME    QTILT &MESSAGE                                                 00873
         USING QDISPLAY,R15   BASE REG FOR DISPLAY WORK AREA            00874
&NAME    L     R15,QVDSPL     LOAD BASE REG                             00875
         MVC   QDHLINE,=CL80&MESSAGE                                    00876
         MVC   QDMLNG,=H'0'   ZERO MESSAGE LENGTH                       00877
         DROP  R15                                                      00878
         L     R15,=V(DISPLAY) ADDR OF DISPLAY MODULE                   00879
         LR    R14,R15        SET FOR LOOP                              00880
         BR    R15            GO TO IT                                  00881
         MEND                                                           00882
./ ADD NAME=RELINK
//RELINK JOB ,JACK,CLASS=9,MSGCLASS=A
/*JOBPARM Q=F,I
//LINK   EXEC  PGM=IEWL,PARM='TEST,LIST,LET,NCAL,XREF,MAP'
//SYSPRINT DD  SYSOUT=A
//SYSUT1   DD  UNIT=VIO3350,SPACE=(CYL,(3,3))
//SYSLMOD  DD  DSN=JES2.SP2.LINKLIB,DISP=SHR
//SYSLIB   DD  DSN=NER.S685.PGMLIB,DISP=SHR
//SYSLIN   DD  *
 INCLUDE SYSLIB(Q2)
 ENTRY   QUEUE
 NAME    QUEUE(R)
/*
./ ADD NAME=TABLE
//COMMANDS EXEC ASMFCL,PARM.LKED='LET,LIST,RENT,REUS'
//ASM.SYSIN DD *
         ENTRY APFCTABL
IKJEFTE2 CSECT
         DC    CL8'IKJEFTE2'
         DC    CL8'06.01.80'
APFCTABL DC    CL8'QUEUE   '       QUEUE COMMAND
         DC    CL8'Q       '       ALIAS
         DC    CL8'CMD1    '       SPARE TABLE ENTRIES
         DC    CL8'CMD2    '       SPARE TABLE ENTRIES
         DC    CL8'CMD3    '       SPARE TABLE ENTRIES
         DC    CL8'        '       8 BLANKS TABLE TERMINATOR
         END
/*
//LKED.SYSLMOD DD DSN=T90000.IPO38.GENLIB(IKJEFTE2),DISP=SHR
//*
//* CHANGE SYSLMOD TO WHATEVER LIBRARY YOU USE TO HOLD SYSTEM MODULES
//*
//TSOCMDS EXEC IPOSMP4
//SMP.SMPCNTL DD *
  RECEIVE S(TR00003).
  APPLY S(TR00003) DIS(WRITE).
/*
//*
//* THE VERIFY CARD BELOW IS SET UP FOR A MVS 3.8 SYSTEM WITH THE
//* TSO COMMAND PACKAGE INSTALLED. IF YOU DON'T HAVE THE COMMAND
//* PACKAGE YOU WILL NEED TO MODIFY THE VERIFY TO MATCH YOUR
//* SYSTEM ENVIRONMENT.
//*
//SMP.SMPPTFIN DD *
++ USERMOD(TR00003) /* TSO AUTHORIZED COMMANDS */.
++ VER(Z038) FMID(EBB1102) PRE(JBB1112).
++ MOD(IKJEFTE2) DISTLIB(AOST4) LKLIB(GENLIB).
/*
//GENLIB DD DSN=T90000.IPO38.GENLIB,DISP=SHR
//*
//* CHANGE GENLIB TO WHATEVER LIBRARY YOU USE TO HOLD SYSTEM MODULES
//*
./ ADD NAME=TOPAN
//TOPAN  JOB ,JACK,CLASS=9,MSGCLASS=A
/*JOBPARM Q=F,I
//PUNLIB EXEC  PGM=PUNLIB
//SYSPRINT DD  SYSOUT=A
//SYSUT1   DD  DSN=NER.S685.NEW.QUEUE,DISP=SHR
//SYSUT2   DD  UNIT=VIO,DISP=(,PASS),SPACE=(CYL,(5,5)),
//             DCB=(LRECL=80,RECFM=FB,BLKSIZE=3120)
//*
//CHNGE  EXEC  PGM=PANCHNGE
//STEPLIB  DD  DSN=NER.S685.PGMLIB,DISP=SHR
//SYSUT1   DD  DSN=*.PUNLIB.SYSUT2,DISP=(OLD,PASS)
//SYSUT2   DD  UNIT=VIO,DISP=(,PASS),SPACE=(CYL,(5,5)),
//             DCB=(LRECL=80,RECFM=FB,BLKSIZE=3120)
//PAN1   EXEC  PAN#1,LIBRARY='JES2.NJE3.PANLIB'
//SYSIN    DD  *
--UPDATE QUEUE,0,ALL
/*
//         DD  DSN=*.CHNGE.SYSUT2,DISP=(OLD,PASS)
//         DD  *
--COMMENT QUEUE,NERDC VERSION OF TRW QUEUE COMMAND PROCESSOR
/*
./ ADD NAME=TOTAPE
//SP2DTR   JOB ,JACK,CLASS=9,MSGCLASS=A
/*JOBPARM Q=F,I
/*SETUP        TAPE9,1
//*
//* DISTRIBUTION TAPE FOR NERDC VERSION OF JES2 SP2 STUFF.
//*
//* FILE1 - IEBCOPY DUMP OF NERDC QUEUE COMMAND. (SEE $UFDOC)
//*         (SUPPORT OF NJE OR SP2 VERSIONS VIA SYSPARM OPTIONS)
//*         (SOME OF THIS MAY BE ASSEMBLER H DEPENDENT)
//* FILE2 - COPY OF FILE1 JUST IN CASE THERE ARE PROBLEMS
//*         WITH THE TAPE.
//*
//* FOR FURTHER INFORMATION, CONTACT:
//*   JACK SCHUDEL
//*   NORTHEAST REGIONAL DATA CENTER
//*   ROOM 233 SSRB
//*   UNIVERSITY OF FLORIDA
//*   GAINESVILLE, FLORIDA  32611
//*   (904) 392-4601
//*
//COPY   EXEC  VEBCOPY
//SYSPRINT DD  SYSOUT=T
//IN       DD  DSN=NER.S685.NEW.QUEUE,DISP=SHR
//OUT      DD  DSN=NER.S685.QTEMP,DISP=(,PASS),
//             UNIT=SYSDA,VOL=SER=WORK03,
//             SPACE=(CYL,(3,3,36),RLSE)
//SYSIN    DD  *
 COPY INDD=IN,OUTDD=OUT
/*
//SCR    EXEC  PGM=IUTPROGM
//SYSPRINT DD  SYSOUT=T
//SYSIN    DD  *
 SCR MEMBER=$DTRDOC,DSN=NER.S685.QTEMP,V=WORK03
 CC  0
/*
//INITT  EXEC  PGM=IEHINITT
//SYSPRINT DD  SYSOUT=A
//TAPE1    DD  UNIT=(TAPE9,,DEFER),DCB=(DEN=4)
//SYSIN    DD  *
TAPE1    INITT SER=NERDTR,OWNER='NERDC.MODS'
/*
//F1     EXEC  VEBCOPY
//IN       DD  DSN=NER.S685.QTEMP,DISP=(OLD,DELETE)
//OUT1     DD  UNIT=TAPE9,VOL=SER=NERDTR,DISP=(,PASS),
//             LABEL=(1,SL),DSN=NER.JES2.QUEUE
//OUT2     DD  UNIT=TAPE9,VOL=SER=NERDTR,DISP=(,PASS),
//             LABEL=(2,SL),DSN=NER.JES2.QUEUE
//SYSIN    DD  *
 COPY INDD=IN,OUTDD=OUT1
 COPY INDD=IN,OUTDD=OUT2
/*
//*
//MAP    EXEC  PGM=TAPEMAP
//STEPLIB  DD  DSN=NER.S685.MNM.LOAD,DISP=SHR
//SYSPRINT DD  SYSOUT=A
//SYSPRNT2 DD  SYSOUT=A
//SYSUT1   DD  UNIT=TAPE9,VOL=SER=NERDTR,DISP=OLD
//SYSIN    DD  DUMMY
./ ADD NAME=TTGET
         MACRO                                                          05433
&NAME    TGET  &BFF,&SIZE,&EDIT,&WAIT,&MF=                     @G76XRYU 05434
.* THIS VERSION IS FROM PTF UZ29403 PUT IN THIS PDS BY CBT              05435
.*                                                                 @01A 05436
.* $MAC(TGET) COMP(Y@) PROD(TIOC):                                 @01A 05437
.*                                                                 @01A 05438
.* CHANGE ACTIVITY =                                               @01A 05439
.* A000000-999999                                              @G76XR00 05440
.* C44364000,44376000                                          @OZ42972 05441
.* $01=OZ43111  ETI1106  79.11.28  579667:                         @01A 05442
.* C448976                                                     @ZA44765 05443
.*                                                                 @01A 05444
         LCLA  &OPT,&FLAGON,&FLAGOFF                           @G76XRYU 05445
         LCLB  &RET,&E,&W                                          @01C 05446
         LCLC  &ERROPT,&NDX                                    @G76XRYU 05447
&NDX     SETC  '&SYSNDX'                                       @G76XRYU 05448
&OPT     SETA  X'80'                                                    05449
&FLAGOFF SETA  145                     ..SET FOR AND OPERATION @G76XRYU 05450
         AIF   (N'&SYSLIST LE 4).POSOPOK  ..# POS. OPERANDS OK @G76XRYU 05451
         MNOTE 12,'IHB300 EXCESSIVE POSITIONAL OPERANDS SPECIFIED'      05452
         MEXIT                                                 @G76XRYU 05453
.POSOPOK ANOP                            ..CHECK VALID MF PARM @G76XRYU 05454
         AIF   ('&MF' EQ '').FORMOK                            @G76XRYU 05455
         AIF   ('&MF' EQ 'I' OR '&MF' EQ 'L' OR ('&MF(1)' EQ 'E' AND N'X05456
               &MF EQ 2)).FORMOK                               @G76XRYU 05457
         MNOTE 12,'IHB303 INVALID OPERAND MF=&MF'              @G76XRYU 05458
         MEXIT                                                 @G76XRYU 05459
.FORMOK  ANOP                                                  @G76XRYU 05460
         AIF   (('&BFF' EQ '' OR '&SIZE' EQ '') AND ('&MF' EQ '' OR '&MX05461
               F' EQ 'I')).ERROR1   ..STANDARD FORM ERROR..    @G76XRYU 05462
         AIF   ('&EDIT' EQ 'R').RF      CHECK FOR R FORM                05463
         AIF   ('&EDIT' EQ '').WAIT       SKIP IF NULL                  05464
         AIF   ('&EDIT' EQ 'EDIT').EDI    SET EDIT                      05465
         AIF   ('&EDIT' EQ 'ASIS').ASI    SET ASIS                      05466
         AIF   ('&EDIT' EQ 'WAIT').WAI    SET WAIT (EDIT PARM OMITTED)  05467
         AIF   ('&EDIT' EQ 'NOWAIT').NOW  SET NOWAIT (EDIT OMITTED)     05468
&ERROPT  SETC  '&EDIT'                  SET FOR ERROR MSG               05469
         AGO   .ERROR3                                                  05470
.WAIT    ANOP                                                           05471
&RET     SETB  1                                                        05472
         AIF   ('&WAIT' EQ '').CHKFORM    SKIP IF NULL                  05473
         AIF   ('&WAIT' EQ 'EDIT').EDI    SET EDIT                      05474
         AIF   ('&WAIT' EQ 'ASIS').ASI    SET ASIS                      05475
         AIF   ('&WAIT' EQ 'WAIT').WAI    SET WAIT                      05476
         AIF   ('&WAIT' EQ 'NOWAIT').NOW  SET NOWAIT                    05477
&ERROPT  SETC  '&WAIT'                  SET FOR ERROR MSG               05478
         AGO   .ERROR3                                                  05479
.EDI     ANOP                                                           05480
         AIF   (&E).ERROR2              DUP OPTION                      05481
&E       SETB  1                        EDIT OPTION SPECFIED            05482
&FLAGOFF SETA  &FLAGOFF-1               EDIT FOR EXEC FORM     @G76XRYU 05483
         AGO   .RET                                                     05484
.ASI     ANOP                                                           05485
         AIF   (&E).ERROR2              DUP OPTION                      05486
&E       SETB  1                        EDIT OPTION SPECFIED            05487
&OPT     SETA  &OPT+1                   ASIS OPTION            @G76XRYU 05488
&FLAGON  SETA  &FLAGON+1                SET ASIS FOR EXECUTE   @G76XRYU 05489
         AGO   .RET                                                     05490
.WAI     ANOP                                                           05491
         AIF   (&W).ERROR2              DUP OPTION                      05492
&W       SETB  1                        WAIT OPTION SPECIFIED           05493
&FLAGOFF SETA  &FLAGOFF-16              SET WAIT OPTION FOR EX @G76XRYU 05494
         AGO   .RET                                                     05495
.NOW     ANOP                                                           05496
         AIF   (&W).ERROR2              DUP OPTION                      05497
&W       SETB  1                        WAIT OPTION SPECIFIED           05498
&OPT     SETA  &OPT+16                  NOWAIT OPTION          @G76XRYU 05499
&FLAGON  SETA  &FLAGON+16               SET NOWAIT OPT FOR EX  @G76XRYU 05500
         AGO   .RET                                                     05501
.RET     ANOP                                                           05502
         AIF   (&RET).CHKFORM                                  @G76XRYU 05503
         AGO   .WAIT                    NEXT POSITION                   05504
.CHKFORM ANOP                                                  @G76XRYU 05505
         AIF   ('&MF' EQ 'L').LFORM    ..LIST EXPANSION...     @G76XRYU 05506
         AIF   ('&MF' EQ 'I' OR '&MF' EQ '').OLDFORM STANDARD      @01C 05507
.******************                                            @G76XRYU 05508
.*  EXECUTE FORM  *                                            @G76XRYU 05509
.******************                                            @G76XRYU 05510
&NAME    CNOP  0,4                     TGET EXECUTE FORM       @G76XRYU 05511
         AIF   ('&MF(2)'(1,1) EQ '(').MFREG  ..IF PARM IS RX.. @G76XRYU 05512
         LA    1,&MF(2)                R1=> EXECUTE PARM LIST  @G76XRYU 05513
         AGO   .GOTPARM                                        @G76XRYU 05514
.MFREG   ANOP                                ..ELSE, IN A REG. @G76XRYU 05515
         AIF   ('&MF(2)' EQ '(1)').GOTPARM  ..IF NOT REG 1..   @G76XRYU 05516
         LR    1,&MF(2)                POINT R1 AT PARM LIST   @G76XRYU 05517
.GOTPARM ANOP                    ...CHECK FLAG BIT SETTINGS    @G76XRYU 05518
         MVI   0(1),0                  INSURE HI BIT OF R0 OFF @G76XRYU 05519
         AIF   (&FLAGOFF EQ 145).SKIPAND .ANY FLAGS TURNED OFF @G76XRYU 05520
         NI    4(1),&FLAGOFF           RESET TGET FLAGS1       @G76XRYU 05521
.SKIPAND ANOP                    ...CHECK FOR FLAGS TO TURN ON @G76XRYU 05522
         AIF   (&FLAGON EQ 0).PARMCK ..SKIP OR IF NO RESETS    @G76XRYU 05523
         OI    4(1),&FLAGON            RESET TGET FLAGS 1      @G76XRYU 05524
.PARMCK  ANOP                                                      @01C 05525
         AIF   ('&SIZE' EQ '').CKBUFF  ...IF BUFF SIZE GIVEN.. @G76XRYU 05526
         AIF   ('&SIZE'(1,1) EQ '(').SIZEREG ..IF INTEGER FORM @G76XRYU 05527
         AIF   (T'&SIZE NE 'N').AROUND         .VALID & ^ NEG. @OZ42972 05528
         AIF   (&SIZE GT 32767).SIZERR          ..NOT > 32767. @G76XRYU 05529
.AROUND  ANOP                                                      @01C 05530
         B     *+6                      BR AROUND SIZE             @01C 05531
         DC    AL2(&SIZE)               SIZE CAN EXCEED 4095       @01C 05532
         LH    0,*-2                   GET THE SIZE VALUE      @G76XRYU 05533
         STH   0,2(1)                  INTO THE PARM LIST      @G76XRYU 05534
         AGO   .CKBUFF                                         @G76XRYU 05535
.SIZEREG ANOP                                  ..ELSE A REG..  @G76XRYU 05536
         STH   &SIZE(1),2(1)           PUT BUFFER SIZE IN PARM @G76XRYU 05537
.CKBUFF  ANOP                                                  @G76XRYU 05538
         AIF   ('&BFF' EQ '').LOAD      ..IF A BUFF ADDR GIVEN @G76XRYU 05539
         AIF   ('&BFF'(1,1) EQ '(').BUFFREG  ..IF AN RX ADDR.. @G76XRYU 05540
         LA    0,&BFF                  GET ADDR OF INPUT BUFF  @G76XRYU 05541
         STCM  0,B'0111',5(1)          PUT IN THE PARM LIST    @G76XRYU 05542
         AGO   .LOAD                                           @G76XRYU 05543
.BUFFREG ANOP                                ..ELSE A REG..    @G76XRYU 05544
         STCM  &BFF(1),B'0111',5(1)    STORE BUFF ADDR IN PARM @G76XRYU 05545
.LOAD    ANOP                          ..LOAD 0 & 1 FOR SVC..  @G76XRYU 05546
         LM    0,1,0(1)                REG 0: BUFFER SIZE      @G76XRYU 05547
*                                      REG 1: FLAGS,BUFF ADDR  @G76XRYU 05548
         AGO   .SVC                                                @01C 05549
.******************                                            @G76XRYU 05550
.*   LIST FORM    *                                            @G76XRYU 05551
.******************                                            @G76XRYU 05552
.LFORM   ANOP                                                  @G76XRYU 05553
&NAME    DS    0F                      TGET LIST FORM          @G76XRYU 05554
         DC    H'0'                    MUST BE 0 FOR TGET      @G76XRYU 05555
         AIF   ('&SIZE' NE '').LSTSIZE  ..IF NO BUFFER SIZE..  @G76XRYU 05556
         DC    H'0'                    BUFFER SIZE HALFWORD    @G76XRYU 05557
         AGO   .LBFADDR                                        @G76XRYU 05558
.LSTSIZE ANOP                           ..ELSE A BUFFER SIZE.. @G76XRYU 05559
         AIF   ('&SIZE'(1,1) EQ '(').REGERR  ..IF NOT A REG..  @G76XRYU 05560
         AIF   (T'&SIZE NE 'N').ARNSIZL IF AN INTEGER              @01C 05561
         AIF   (&SIZE GT 32767).SIZERR        .AND NOT >32767. @G76XRYU 05562
.ARNSIZL DC    AL2(&SIZE)              INPUT BUFFER SIZE           @01C 05563
.LBFADDR ANOP                          ...CHECK FOR BUFF ADDR. @G76XRYU 05564
         DC    AL1(&OPT)               TGET FLAGS              @G76XRYU 05565
         AIF   ('&BFF' NE '').LBFFLAB  ..IF NO BUFFER ADDR..   @G76XRYU 05566
         DC    AL3(0)                  INPUT BUFFER ADDRESS    @G76XRYU 05567
         MEXIT                                                 @G76XRYU 05568
.LBFFLAB ANOP                          ..ELSE BUFFER ADDRESS.. @G76XRYU 05569
         AIF   ('&BFF'(1,1) EQ '(').REGERR  ..IF NOT A REG..   @G76XRYU 05570
         DC    AL3(&BFF)               INPUT BUFFER ADDRESS    @G76XRYU 05571
         MEXIT                                                 @G76XRYU 05572
.REGERR  ANOP                                                  @G76XRYU 05573
         MNOTE 12,'IHB300 INCOMPATIBLE OPERANDS: MF=L, REGISTER OPERAND*05574
                SPECIFIED'                                     @G76XRYU 05575
         MEXIT                                                 @G76XRYU 05576
.OLDFORM AIF   ('&BFF'(1,1) EQ '(' OR '&SIZE'(1,1) EQ '(').REGST   @01C 05577
.*                                                                 @01P 05578
.*   REGULAR EXPANSION                                             @01P 05579
.*                                                                 @01P 05580
&NAME    CNOP  0,4                                             @ZA44765 05581
         B     *+12                    BRANCH AROUND CONSTANTS @ZA44765 05582
         DC    AL2(0)                   FILLER                     @01P 05583
         DC    AL2(&SIZE)               BUFFER SIZE                @01P 05584
         DC    AL1(&OPT)                OPTION BITS                @01P 05585
         DC    AL3(&BFF)                ADDR OF BUFFER             @01P 05586
         LM    0,1,*-8                  LOAD PARAMETER REGISTERS   @01P 05587
.SVC     SVC   93                       ISSUE SVC                  @01P 05588
         SPACE 1                                                   @01C 05589
         MEXIT                                                     @01P 05590
.*                                                                 @01P 05591
.*   REGISTER NOTATION                                             @01P 05592
.*                                                                 @01P 05593
.REGST   ANOP                                                      @01P 05594
&NAME    B     *+8                      BRANCH AROUND CONSTANT     @01P 05595
         AIF   ('&BFF'(1,1) EQ '(' AND '&SIZE'(1,1) EQ '(').BOTH   @01C 05596
.*                                      PARAMETERS ARE IN REG FORM @01C 05597
         AIF   ('&SIZE'(1,1) EQ '(').SZREG   SIZE IN REG           @01P 05598
.*                                                                 @01P 05599
.*   BUFFER ADDR IN REGISTER FORM                                  @01P 05600
.*                                                                 @01P 05601
         DC    AL1(&OPT)                OPTION BITS                @01P 05602
         DC    AL3(0)                   BUFFER ADDR                @01P 05603
         LA    1,0(,&BFF(1))            CLR HIGH ORDR BYTE + LD BFR@01P 05604
         O     1,*-8                    SET OPTIONS                @01P 05605
         LA    0,&SIZE                  LOAD SIZE OF BUFFER        @01P 05606
         AGO   .SVC                     GOTO ISSUE SVC             @01P 05607
.*                                                                 @01P 05608
.*   BUFFER SIZE IN REGISTER FORM                                  @01P 05609
.*                                                                 @01P 05610
.SZREG   DC    AL1(&OPT)                OPTION BITS                @01P 05611
         DC    AL3(&BFF)                BUFFER ADDR                @01P 05612
         L     1,*-4                    LOAD PARAMETER REGISTER    @01P 05613
         AIF   ('&SIZE' EQ '(0)').SVC   SIZE IN REG. 0             @01P 05614
         LR    0,&SIZE(1)               LOAD BUFFER SIZE IN REG 0  @01P 05615
         AGO   .SVC                     GOTO ISSUE SVC             @01P 05616
.*                                                                 @01P 05617
.*   WHEN BOTH ARE IN REGISTER NOTATION                            @01P 05618
.*                                                                 @01P 05619
.BOTH    DC    AL1(&OPT)                OPTION BITS                @01P 05620
         DC    AL3(0)                   BUFFER ADDR                @01P 05621
         LA    1,0(,&BFF(1))            CLR HIGH ORDR BYTE + LD BFR@01P 05622
         O     1,*-8                    SET OPTIONS                @01P 05623
         AIF   ('&SIZE' EQ '(0)').SVC   GOTO SVC IF (0) SPECIFIED  @01P 05624
         LR    0,&SIZE(1)               LOAD BUFFER SIZE IN REG 0  @01P 05625
         AGO   .SVC                     GOTO ISSUE SVC             @01P 05626
.RF      ANOP                                                      @01P 05627
         AIF   ('&WAIT' NE '').RERR                                @01P 05628
         AIF   ('&BFF'(1,1) NE '(' OR '&SIZE'(1,1) NE '(').RERR    @01P 05629
&NAME    DS    0H                                                  @01P 05630
         AIF   ('&BFF' EQ '(1)').SIZE                              @01P 05631
         LR    1,&BFF(1)                LOAD BUFFER ADDRESS IN REG @01P 05632
.SIZE    AIF   ('&SIZE' EQ '(0)').SVC                              @01P 05633
         LR    0,&SIZE(1)               LOAD BUFFER SIZE IN REG 0  @01P 05634
         AGO   .SVC                                                @01P 05635
.SIZERR  MNOTE 12,'IHB300 SIZE NOT IN RANGE 0-32767'               @01C 05636
         MEXIT                                                 @G76XRYU 05637
.RERR    IHBERMAC 192                                              @01P 05638
         MEXIT                                                     @01P 05639
.ERROR1  IHBERMAC 24                                               @01P 05640
         MEXIT                                                     @01P 05641
.ERROR2  IHBERMAC 54,,,                                            @01P 05642
         MEXIT                                                     @01P 05643
.ERROR3  IHBERMAC 49,,&ERROPT                                      @01P 05644
         MEND                                                           05645
         EJECT                                                          05646
TGETTEST CSECT                                                          05647
         USING TGETTEST,12,11                                           05648
         DS    51X  33 IN HEX                                           05649
BUFFER   DS    0X                                                       05650
SIZE     EQU   119  77 IN HEX                                           05651
R2       EQU   2                                                        05652
R3       EQU   3                                                        05653
         TGET BUFFER                                                    05654
         TGET ,SIZE                                                     05655
         TGET ,,EDIT                                                    05656
         TGET ,,,WAIT                                                   05657
         TGET ,,,,MF=I                                                  05658
*        ALL SINGLE PARMS                                               05659
         TGET BUFFER,SIZE                                               05660
         TGET BUFFER,,EDIT                                              05661
         TGET BUFFER,,,WAIT                                             05662
         TGET BUFFER,,,,MF=I                                            05663
*        ALL BUFFER + 1 PARM                                            05664
         TGET BUFFER,SIZE,EDIT                                          05665
         TGET BUFFER,SIZE,,WAIT                                         05666
         TGET BUFFER,SIZE,,,MF=I                                        05667
* ALL BUFFER + 2 PARMS                                                  05668
         TGET BUFFER,SIZE,EDIT,WAIT                                     05669
         TGET BUFFER,SIZE,EDIT,,MF=I                                    05670
*        ALL BUFFER +3 PARMS                                            05671
         TGET BUFFER,SIZE,EDIT,WAIT,MF=I                                05672
*  ALL PARMS                                                            05673
         TGET ,SIZE,EDIT                                                05674
         TGET ,SIZE,,WAIT                                               05675
         TGET ,SIZE,,,MF=I                                              05676
* ALL SIZE + 1 PARM                                                     05677
         TGET ,SIZE,EDIT,WAIT                                           05678
         TGET ,SIZE,=EDIT,,MF=I                                         05679
* ALL SIZE + 2 PARMS                                                    05680
         TGET ,SIZE,EDIT,WAIT,MF=I                                      05681
* ALL SIZE + ALL PARMS BUT BUFFER                                       05682
         TGET ,,EDIT,WAIT                                               05683
         TGET ,,EDIT,MF=I                                               05684
         TGET ,,EDIT,WAIT,MF=I                                          05685
* ALL REST OF EDIT COMBINATIONS                                         05686
         TGET ,,,WAIT,MF=I                                              05687
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05688
         TGET (R2)                                                      05689
         TGET ,SIZE                                                     05690
         TGET ,,EDIT                                                    05691
         TGET ,,,WAIT                                                   05692
         TGET ,,,,MF=I                                                  05693
*        ALL SINGLE PARMS                                               05694
         TGET (R2),SIZE                                                 05695
         TGET (R2),,EDIT                                                05696
         TGET (R2),,,WAIT                                               05697
         TGET (R2),,,,MF=I                                              05698
*        ALL (R2) + 1 PARM                                              05699
         TGET (R2),SIZE,EDIT                                            05700
         TGET (R2),SIZE,,WAIT                                           05701
         TGET (R2),SIZE,,,MF=I                                          05702
* ALL (R2) + 2 PARMS                                                    05703
         TGET (R2),SIZE,EDIT,WAIT                                       05704
         TGET (R2),SIZE,EDIT,,MF=I                                      05705
*        ALL (R2) +3 PARMS                                              05706
         TGET (R2),SIZE,EDIT,WAIT,MF=I                                  05707
*  ALL PARMS                                                            05708
         TGET ,SIZE,EDIT                                                05709
         TGET ,SIZE,,WAIT                                               05710
         TGET ,SIZE,,,MF=I                                              05711
* ALL SIZE + 1 PARM                                                     05712
         TGET ,SIZE,EDIT,WAIT                                           05713
         TGET ,SIZE,=EDIT,,MF=I                                         05714
* ALL SIZE + 2 PARMS                                                    05715
         TGET ,SIZE,EDIT,WAIT,MF=I                                      05716
* ALL SIZE + ALL PARMS BUT (R2)                                         05717
         TGET ,,EDIT,WAIT                                               05718
         TGET ,,EDIT,MF=I                                               05719
         TGET ,,EDIT,WAIT,MF=I                                          05720
* ALL REST OF EDIT COMBINATIONS                                         05721
         TGET ,,,WAIT,MF=I                                              05722
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05723
         TGET (2)                                                       05724
         TGET ,SIZE                                                     05725
         TGET ,,EDIT                                                    05726
         TGET ,,,WAIT                                                   05727
         TGET ,,,,MF=I                                                  05728
*        ALL SINGLE PARMS                                               05729
         TGET (2),SIZE                                                  05730
         TGET (2),,EDIT                                                 05731
         TGET (2),,,WAIT                                                05732
         TGET (2),,,,MF=I                                               05733
*        ALL (2) + 1 PARM                                               05734
         TGET (2),SIZE,EDIT                                             05735
         TGET (2),SIZE,,WAIT                                            05736
         TGET (2),SIZE,,,MF=I                                           05737
* ALL (2) + 2 PARMS                                                     05738
         TGET (2),SIZE,EDIT,WAIT                                        05739
         TGET (2),SIZE,EDIT,,MF=I                                       05740
*        ALL (2) +3 PARMS                                               05741
         TGET (2),SIZE,EDIT,WAIT,MF=I                                   05742
*  ALL PARMS                                                            05743
         TGET ,SIZE,EDIT                                                05744
         TGET ,SIZE,,WAIT                                               05745
         TGET ,SIZE,,,MF=I                                              05746
* ALL SIZE + 1 PARM                                                     05747
         TGET ,SIZE,EDIT,WAIT                                           05748
         TGET ,SIZE,=EDIT,,MF=I                                         05749
* ALL SIZE + 2 PARMS                                                    05750
         TGET ,SIZE,EDIT,WAIT,MF=I                                      05751
* ALL SIZE + ALL PARMS BUT (2)                                          05752
         TGET ,,EDIT,WAIT                                               05753
         TGET ,,EDIT,MF=I                                               05754
         TGET ,,EDIT,WAIT,MF=I                                          05755
* ALL REST OF EDIT COMBINATIONS                                         05756
         TGET ,,,WAIT,MF=I                                              05757
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05758
         TGET 12(2)                                                     05759
         TGET ,SIZE                                                     05760
         TGET ,,EDIT                                                    05761
         TGET ,,,WAIT                                                   05762
         TGET ,,,,MF=I                                                  05763
*        ALL SINGLE PARMS                                               05764
         TGET 12(2),SIZE                                                05765
         TGET 12(2),,EDIT                                               05766
         TGET 12(2),,,WAIT                                              05767
         TGET 12(2),,,,MF=I                                             05768
*        ALL 12(2) + 1 PARM                                             05769
         TGET 12(2),SIZE,EDIT                                           05770
         TGET 12(2),SIZE,,WAIT                                          05771
         TGET 12(2),SIZE,,,MF=I                                         05772
* ALL 12(2) + 2 PARMS                                                   05773
         TGET 12(2),SIZE,EDIT,WAIT                                      05774
         TGET 12(2),SIZE,EDIT,,MF=I                                     05775
*        ALL 12(2) +3 PARMS                                             05776
         TGET 12(2),SIZE,EDIT,WAIT,MF=I                                 05777
*  ALL PARMS                                                            05778
         TGET ,SIZE,EDIT                                                05779
         TGET ,SIZE,,WAIT                                               05780
         TGET ,SIZE,,,MF=I                                              05781
* ALL SIZE + 1 PARM                                                     05782
         TGET ,SIZE,EDIT,WAIT                                           05783
         TGET ,SIZE,=EDIT,,MF=I                                         05784
* ALL SIZE + 2 PARMS                                                    05785
         TGET ,SIZE,EDIT,WAIT,MF=I                                      05786
* ALL SIZE + ALL PARMS BUT 12(2)                                        05787
         TGET ,,EDIT,WAIT                                               05788
         TGET ,,EDIT,MF=I                                               05789
         TGET ,,EDIT,WAIT,MF=I                                          05790
* ALL REST OF EDIT COMBINATIONS                                         05791
         TGET ,,,WAIT,MF=I                                              05792
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05793
         TGET BUFFER                                                    05794
         TGET ,100                                                      05795
         TGET ,,EDIT                                                    05796
         TGET ,,,WAIT                                                   05797
         TGET ,,,,MF=I                                                  05798
*        ALL SINGLE PARMS                                               05799
         TGET BUFFER,100                                                05800
         TGET BUFFER,,EDIT                                              05801
         TGET BUFFER,,,WAIT                                             05802
         TGET BUFFER,,,,MF=I                                            05803
*        ALL BUFFER + 1 PARM                                            05804
         TGET BUFFER,100,EDIT                                           05805
         TGET BUFFER,100,,WAIT                                          05806
         TGET BUFFER,100,,,MF=I                                         05807
* ALL BUFFER + 2 PARMS                                                  05808
         TGET BUFFER,100,EDIT,WAIT                                      05809
         TGET BUFFER,100,EDIT,,MF=I                                     05810
*        ALL BUFFER +3 PARMS                                            05811
         TGET BUFFER,100,EDIT,WAIT,MF=I                                 05812
*  ALL PARMS                                                            05813
         TGET ,100,EDIT                                                 05814
         TGET ,100,,WAIT                                                05815
         TGET ,100,,,MF=I                                               05816
* ALL 100 + 1 PARM                                                      05817
         TGET ,100,EDIT,WAIT                                            05818
         TGET ,100,=EDIT,,MF=I                                          05819
* ALL 100 + 2 PARMS                                                     05820
         TGET ,100,EDIT,WAIT,MF=I                                       05821
* ALL 100 + ALL PARMS BUT BUFFER                                        05822
         TGET ,,EDIT,WAIT                                               05823
         TGET ,,EDIT,MF=I                                               05824
         TGET ,,EDIT,WAIT,MF=I                                          05825
* ALL REST OF EDIT COMBINATIONS                                         05826
         TGET ,,,WAIT,MF=I                                              05827
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05828
         TGET (R2)                                                      05829
         TGET ,100                                                      05830
         TGET ,,EDIT                                                    05831
         TGET ,,,WAIT                                                   05832
         TGET ,,,,MF=I                                                  05833
*        ALL SINGLE PARMS                                               05834
         TGET (R2),100                                                  05835
         TGET (R2),,EDIT                                                05836
         TGET (R2),,,WAIT                                               05837
         TGET (R2),,,,MF=I                                              05838
*        ALL (R2) + 1 PARM                                              05839
         TGET (R2),100,EDIT                                             05840
         TGET (R2),100,,WAIT                                            05841
         TGET (R2),100,,,MF=I                                           05842
* ALL (R2) + 2 PARMS                                                    05843
         TGET (R2),100,EDIT,WAIT                                        05844
         TGET (R2),100,EDIT,,MF=I                                       05845
*        ALL (R2) +3 PARMS                                              05846
         TGET (R2),100,EDIT,WAIT,MF=I                                   05847
*  ALL PARMS                                                            05848
         TGET ,100,EDIT                                                 05849
         TGET ,100,,WAIT                                                05850
         TGET ,100,,,MF=I                                               05851
* ALL 100 + 1 PARM                                                      05852
         TGET ,100,EDIT,WAIT                                            05853
         TGET ,100,=EDIT,,MF=I                                          05854
* ALL 100 + 2 PARMS                                                     05855
         TGET ,100,EDIT,WAIT,MF=I                                       05856
* ALL 100 + ALL PARMS BUT (R2)                                          05857
         TGET ,,EDIT,WAIT                                               05858
         TGET ,,EDIT,MF=I                                               05859
         TGET ,,EDIT,WAIT,MF=I                                          05860
* ALL REST OF EDIT COMBINATIONS                                         05861
         TGET ,,,WAIT,MF=I                                              05862
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05863
         TGET (2)                                                       05864
         TGET ,100                                                      05865
         TGET ,,EDIT                                                    05866
         TGET ,,,WAIT                                                   05867
         TGET ,,,,MF=I                                                  05868
*        ALL SINGLE PARMS                                               05869
         TGET (2),100                                                   05870
         TGET (2),,EDIT                                                 05871
         TGET (2),,,WAIT                                                05872
         TGET (2),,,,MF=I                                               05873
*        ALL (2) + 1 PARM                                               05874
         TGET (2),100,EDIT                                              05875
         TGET (2),100,,WAIT                                             05876
         TGET (2),100,,,MF=I                                            05877
* ALL (2) + 2 PARMS                                                     05878
         TGET (2),100,EDIT,WAIT                                         05879
         TGET (2),100,EDIT,,MF=I                                        05880
*        ALL (2) +3 PARMS                                               05881
         TGET (2),100,EDIT,WAIT,MF=I                                    05882
*  ALL PARMS                                                            05883
         TGET ,100,EDIT                                                 05884
         TGET ,100,,WAIT                                                05885
         TGET ,100,,,MF=I                                               05886
* ALL 100 + 1 PARM                                                      05887
         TGET ,100,EDIT,WAIT                                            05888
         TGET ,100,=EDIT,,MF=I                                          05889
* ALL 100 + 2 PARMS                                                     05890
         TGET ,100,EDIT,WAIT,MF=I                                       05891
* ALL 100 + ALL PARMS BUT (2)                                           05892
         TGET ,,EDIT,WAIT                                               05893
         TGET ,,EDIT,MF=I                                               05894
         TGET ,,EDIT,WAIT,MF=I                                          05895
* ALL REST OF EDIT COMBINATIONS                                         05896
         TGET ,,,WAIT,MF=I                                              05897
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05898
         TGET 12(2)                                                     05899
         TGET ,100                                                      05900
         TGET ,,EDIT                                                    05901
         TGET ,,,WAIT                                                   05902
         TGET ,,,,MF=I                                                  05903
*        ALL SINGLE PARMS                                               05904
         TGET 12(2),100                                                 05905
         TGET 12(2),,EDIT                                               05906
         TGET 12(2),,,WAIT                                              05907
         TGET 12(2),,,,MF=I                                             05908
*        ALL 12(2) + 1 PARM                                             05909
         TGET 12(2),100,EDIT                                            05910
         TGET 12(2),100,,WAIT                                           05911
         TGET 12(2),100,,,MF=I                                          05912
* ALL 12(2) + 2 PARMS                                                   05913
         TGET 12(2),100,EDIT,WAIT                                       05914
         TGET 12(2),100,EDIT,,MF=I                                      05915
*        ALL 12(2) +3 PARMS                                             05916
         TGET 12(2),100,EDIT,WAIT,MF=I                                  05917
*  ALL PARMS                                                            05918
         TGET ,100,EDIT                                                 05919
         TGET ,100,,WAIT                                                05920
         TGET ,100,,,MF=I                                               05921
* ALL 100 + 1 PARM                                                      05922
         TGET ,100,EDIT,WAIT                                            05923
         TGET ,100,=EDIT,,MF=I                                          05924
* ALL 100 + 2 PARMS                                                     05925
         TGET ,100,EDIT,WAIT,MF=I                                       05926
* ALL 100 + ALL PARMS BUT 12(2)                                         05927
         TGET ,,EDIT,WAIT                                               05928
         TGET ,,EDIT,MF=I                                               05929
         TGET ,,EDIT,WAIT,MF=I                                          05930
* ALL REST OF EDIT COMBINATIONS                                         05931
         TGET ,,,WAIT,MF=I                                              05932
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05933
         TGET BUFFER                                                    05934
         TGET ,(R3)                                                     05935
         TGET ,,EDIT                                                    05936
         TGET ,,,WAIT                                                   05937
         TGET ,,,,MF=I                                                  05938
*        ALL SINGLE PARMS                                               05939
         TGET BUFFER,(R3)                                               05940
         TGET BUFFER,,EDIT                                              05941
         TGET BUFFER,,,WAIT                                             05942
         TGET BUFFER,,,,MF=I                                            05943
*        ALL BUFFER + 1 PARM                                            05944
         TGET BUFFER,(R3),EDIT                                          05945
         TGET BUFFER,(R3),,WAIT                                         05946
         TGET BUFFER,(R3),,,MF=I                                        05947
* ALL BUFFER + 2 PARMS                                                  05948
         TGET BUFFER,(R3),EDIT,WAIT                                     05949
         TGET BUFFER,(R3),EDIT,,MF=I                                    05950
*        ALL BUFFER +3 PARMS                                            05951
         TGET BUFFER,(R3),EDIT,WAIT,MF=I                                05952
*  ALL PARMS                                                            05953
         TGET ,(R3),EDIT                                                05954
         TGET ,(R3),,WAIT                                               05955
         TGET ,(R3),,,MF=I                                              05956
* ALL (R3) + 1 PARM                                                     05957
         TGET ,(R3),EDIT,WAIT                                           05958
         TGET ,(R3),=EDIT,,MF=I                                         05959
* ALL (R3) + 2 PARMS                                                    05960
         TGET ,(R3),EDIT,WAIT,MF=I                                      05961
* ALL (R3) + ALL PARMS BUT BUFFER                                       05962
         TGET ,,EDIT,WAIT                                               05963
         TGET ,,EDIT,MF=I                                               05964
         TGET ,,EDIT,WAIT,MF=I                                          05965
* ALL REST OF EDIT COMBINATIONS                                         05966
         TGET ,,,WAIT,MF=I                                              05967
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                05968
         TGET (R2)                                                      05969
         TGET ,(R3)                                                     05970
         TGET ,,EDIT                                                    05971
         TGET ,,,WAIT                                                   05972
         TGET ,,,,MF=I                                                  05973
*        ALL SINGLE PARMS                                               05974
         TGET (R2),(R3)                                                 05975
         TGET (R2),,EDIT                                                05976
         TGET (R2),,,WAIT                                               05977
         TGET (R2),,,,MF=I                                              05978
*        ALL (R2) + 1 PARM                                              05979
         TGET (R2),(R3),EDIT                                            05980
         TGET (R2),(R3),,WAIT                                           05981
         TGET (R2),(R3),,,MF=I                                          05982
* ALL (R2) + 2 PARMS                                                    05983
         TGET (R2),(R3),EDIT,WAIT                                       05984
         TGET (R2),(R3),EDIT,,MF=I                                      05985
*        ALL (R2) +3 PARMS                                              05986
         TGET (R2),(R3),EDIT,WAIT,MF=I                                  05987
*  ALL PARMS                                                            05988
         TGET ,(R3),EDIT                                                05989
         TGET ,(R3),,WAIT                                               05990
         TGET ,(R3),,,MF=I                                              05991
* ALL (R3) + 1 PARM                                                     05992
         TGET ,(R3),EDIT,WAIT                                           05993
         TGET ,(R3),=EDIT,,MF=I                                         05994
* ALL (R3) + 2 PARMS                                                    05995
         TGET ,(R3),EDIT,WAIT,MF=I                                      05996
* ALL (R3) + ALL PARMS BUT (R2)                                         05997
         TGET ,,EDIT,WAIT                                               05998
         TGET ,,EDIT,MF=I                                               05999
         TGET ,,EDIT,WAIT,MF=I                                          06000
* ALL REST OF EDIT COMBINATIONS                                         06001
         TGET ,,,WAIT,MF=I                                              06002
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06003
         TGET (2)                                                       06004
         TGET ,(R3)                                                     06005
         TGET ,,EDIT                                                    06006
         TGET ,,,WAIT                                                   06007
         TGET ,,,,MF=I                                                  06008
*        ALL SINGLE PARMS                                               06009
         TGET (2),(R3)                                                  06010
         TGET (2),,EDIT                                                 06011
         TGET (2),,,WAIT                                                06012
         TGET (2),,,,MF=I                                               06013
*        ALL (2) + 1 PARM                                               06014
         TGET (2),(R3),EDIT                                             06015
         TGET (2),(R3),,WAIT                                            06016
         TGET (2),(R3),,,MF=I                                           06017
* ALL (2) + 2 PARMS                                                     06018
         TGET (2),(R3),EDIT,WAIT                                        06019
         TGET (2),(R3),EDIT,,MF=I                                       06020
*        ALL (2) +3 PARMS                                               06021
         TGET (2),(R3),EDIT,WAIT,MF=I                                   06022
*  ALL PARMS                                                            06023
         TGET ,(R3),EDIT                                                06024
         TGET ,(R3),,WAIT                                               06025
         TGET ,(R3),,,MF=I                                              06026
* ALL (R3) + 1 PARM                                                     06027
         TGET ,(R3),EDIT,WAIT                                           06028
         TGET ,(R3),=EDIT,,MF=I                                         06029
* ALL (R3) + 2 PARMS                                                    06030
         TGET ,(R3),EDIT,WAIT,MF=I                                      06031
* ALL (R3) + ALL PARMS BUT (2)                                          06032
         TGET ,,EDIT,WAIT                                               06033
         TGET ,,EDIT,MF=I                                               06034
         TGET ,,EDIT,WAIT,MF=I                                          06035
* ALL REST OF EDIT COMBINATIONS                                         06036
         TGET ,,,WAIT,MF=I                                              06037
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06038
         TGET 12(2)                                                     06039
         TGET ,(R3)                                                     06040
         TGET ,,EDIT                                                    06041
         TGET ,,,WAIT                                                   06042
         TGET ,,,,MF=I                                                  06043
*        ALL SINGLE PARMS                                               06044
         TGET 12(2),(R3)                                                06045
         TGET 12(2),,EDIT                                               06046
         TGET 12(2),,,WAIT                                              06047
         TGET 12(2),,,,MF=I                                             06048
*        ALL 12(2) + 1 PARM                                             06049
         TGET 12(2),(R3),EDIT                                           06050
         TGET 12(2),(R3),,WAIT                                          06051
         TGET 12(2),(R3),,,MF=I                                         06052
* ALL 12(2) + 2 PARMS                                                   06053
         TGET 12(2),(R3),EDIT,WAIT                                      06054
         TGET 12(2),(R3),EDIT,,MF=I                                     06055
*        ALL 12(2) +3 PARMS                                             06056
         TGET 12(2),(R3),EDIT,WAIT,MF=I                                 06057
*  ALL PARMS                                                            06058
         TGET ,(R3),EDIT                                                06059
         TGET ,(R3),,WAIT                                               06060
         TGET ,(R3),,,MF=I                                              06061
* ALL (R3) + 1 PARM                                                     06062
         TGET ,(R3),EDIT,WAIT                                           06063
         TGET ,(R3),=EDIT,,MF=I                                         06064
* ALL (R3) + 2 PARMS                                                    06065
         TGET ,(R3),EDIT,WAIT,MF=I                                      06066
* ALL (R3) + ALL PARMS BUT 12(2)                                        06067
         TGET ,,EDIT,WAIT                                               06068
         TGET ,,EDIT,MF=I                                               06069
         TGET ,,EDIT,WAIT,MF=I                                          06070
* ALL REST OF EDIT COMBINATIONS                                         06071
         TGET ,,,WAIT,MF=I                                              06072
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06073
         TGET BUFFER                                                    06074
         TGET ,(3)                                                      06075
         TGET ,,EDIT                                                    06076
         TGET ,,,WAIT                                                   06077
         TGET ,,,,MF=I                                                  06078
*        ALL SINGLE PARMS                                               06079
         TGET BUFFER,(3)                                                06080
         TGET BUFFER,,EDIT                                              06081
         TGET BUFFER,,,WAIT                                             06082
         TGET BUFFER,,,,MF=I                                            06083
*        ALL BUFFER + 1 PARM                                            06084
         TGET BUFFER,(3),EDIT                                           06085
         TGET BUFFER,(3),,WAIT                                          06086
         TGET BUFFER,(3),,,MF=I                                         06087
* ALL BUFFER + 2 PARMS                                                  06088
         TGET BUFFER,(3),EDIT,WAIT                                      06089
         TGET BUFFER,(3),EDIT,,MF=I                                     06090
*        ALL BUFFER +3 PARMS                                            06091
         TGET BUFFER,(3),EDIT,WAIT,MF=I                                 06092
*  ALL PARMS                                                            06093
         TGET ,(3),EDIT                                                 06094
         TGET ,(3),,WAIT                                                06095
         TGET ,(3),,,MF=I                                               06096
* ALL (3) + 1 PARM                                                      06097
         TGET ,(3),EDIT,WAIT                                            06098
         TGET ,(3),=EDIT,,MF=I                                          06099
* ALL (3) + 2 PARMS                                                     06100
         TGET ,(3),EDIT,WAIT,MF=I                                       06101
* ALL (3) + ALL PARMS BUT BUFFER                                        06102
         TGET ,,EDIT,WAIT                                               06103
         TGET ,,EDIT,MF=I                                               06104
         TGET ,,EDIT,WAIT,MF=I                                          06105
* ALL REST OF EDIT COMBINATIONS                                         06106
         TGET ,,,WAIT,MF=I                                              06107
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06108
         TGET (R2)                                                      06109
         TGET ,(3)                                                      06110
         TGET ,,EDIT                                                    06111
         TGET ,,,WAIT                                                   06112
         TGET ,,,,MF=I                                                  06113
*        ALL SINGLE PARMS                                               06114
         TGET (R2),(3)                                                  06115
         TGET (R2),,EDIT                                                06116
         TGET (R2),,,WAIT                                               06117
         TGET (R2),,,,MF=I                                              06118
*        ALL (R2) + 1 PARM                                              06119
         TGET (R2),(3),EDIT                                             06120
         TGET (R2),(3),,WAIT                                            06121
         TGET (R2),(3),,,MF=I                                           06122
* ALL (R2) + 2 PARMS                                                    06123
         TGET (R2),(3),EDIT,WAIT                                        06124
         TGET (R2),(3),EDIT,,MF=I                                       06125
*        ALL (R2) +3 PARMS                                              06126
         TGET (R2),(3),EDIT,WAIT,MF=I                                   06127
*  ALL PARMS                                                            06128
         TGET ,(3),EDIT                                                 06129
         TGET ,(3),,WAIT                                                06130
         TGET ,(3),,,MF=I                                               06131
* ALL (3) + 1 PARM                                                      06132
         TGET ,(3),EDIT,WAIT                                            06133
         TGET ,(3),=EDIT,,MF=I                                          06134
* ALL (3) + 2 PARMS                                                     06135
         TGET ,(3),EDIT,WAIT,MF=I                                       06136
* ALL (3) + ALL PARMS BUT (R2)                                          06137
         TGET ,,EDIT,WAIT                                               06138
         TGET ,,EDIT,MF=I                                               06139
         TGET ,,EDIT,WAIT,MF=I                                          06140
* ALL REST OF EDIT COMBINATIONS                                         06141
         TGET ,,,WAIT,MF=I                                              06142
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06143
         TGET (2)                                                       06144
         TGET ,(3)                                                      06145
         TGET ,,EDIT                                                    06146
         TGET ,,,WAIT                                                   06147
         TGET ,,,,MF=I                                                  06148
*        ALL SINGLE PARMS                                               06149
         TGET (2),(3)                                                   06150
         TGET (2),,EDIT                                                 06151
         TGET (2),,,WAIT                                                06152
         TGET (2),,,,MF=I                                               06153
*        ALL (2) + 1 PARM                                               06154
         TGET (2),(3),EDIT                                              06155
         TGET (2),(3),,WAIT                                             06156
         TGET (2),(3),,,MF=I                                            06157
* ALL (2) + 2 PARMS                                                     06158
         TGET (2),(3),EDIT,WAIT                                         06159
         TGET (2),(3),EDIT,,MF=I                                        06160
*        ALL (2) +3 PARMS                                               06161
         TGET (2),(3),EDIT,WAIT,MF=I                                    06162
*  ALL PARMS                                                            06163
         TGET ,(3),EDIT                                                 06164
         TGET ,(3),,WAIT                                                06165
         TGET ,(3),,,MF=I                                               06166
* ALL (3) + 1 PARM                                                      06167
         TGET ,(3),EDIT,WAIT                                            06168
         TGET ,(3),=EDIT,,MF=I                                          06169
* ALL (3) + 2 PARMS                                                     06170
         TGET ,(3),EDIT,WAIT,MF=I                                       06171
* ALL (3) + ALL PARMS BUT (2)                                           06172
         TGET ,,EDIT,WAIT                                               06173
         TGET ,,EDIT,MF=I                                               06174
         TGET ,,EDIT,WAIT,MF=I                                          06175
* ALL REST OF EDIT COMBINATIONS                                         06176
         TGET ,,,WAIT,MF=I                                              06177
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06178
         TGET 12(2)                                                     06179
         TGET ,(3)                                                      06180
         TGET ,,EDIT                                                    06181
         TGET ,,,WAIT                                                   06182
         TGET ,,,,MF=I                                                  06183
*        ALL SINGLE PARMS                                               06184
         TGET 12(2),(3)                                                 06185
         TGET 12(2),,EDIT                                               06186
         TGET 12(2),,,WAIT                                              06187
         TGET 12(2),,,,MF=I                                             06188
*        ALL 12(2) + 1 PARM                                             06189
         TGET 12(2),(3),EDIT                                            06190
         TGET 12(2),(3),,WAIT                                           06191
         TGET 12(2),(3),,,MF=I                                          06192
* ALL 12(2) + 2 PARMS                                                   06193
         TGET 12(2),(3),EDIT,WAIT                                       06194
         TGET 12(2),(3),EDIT,,MF=I                                      06195
*        ALL 12(2) +3 PARMS                                             06196
         TGET 12(2),(3),EDIT,WAIT,MF=I                                  06197
*  ALL PARMS                                                            06198
         TGET ,(3),EDIT                                                 06199
         TGET ,(3),,WAIT                                                06200
         TGET ,(3),,,MF=I                                               06201
* ALL (3) + 1 PARM                                                      06202
         TGET ,(3),EDIT,WAIT                                            06203
         TGET ,(3),=EDIT,,MF=I                                          06204
* ALL (3) + 2 PARMS                                                     06205
         TGET ,(3),EDIT,WAIT,MF=I                                       06206
* ALL (3) + ALL PARMS BUT 12(2)                                         06207
         TGET ,,EDIT,WAIT                                               06208
         TGET ,,EDIT,MF=I                                               06209
         TGET ,,EDIT,WAIT,MF=I                                          06210
* ALL REST OF EDIT COMBINATIONS                                         06211
         TGET ,,,WAIT,MF=I                                              06212
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06213
* SEPARATOR                                                             06214
         TGET BUFFER                                                    06215
         TGET ,SIZE                                                     06216
         TGET ,,EDIT                                                    06217
         TGET ,,,WAIT                                                   06218
         TGET ,,,,MF=(E,(1))                                            06219
*        ALL SINGLE PARMS                                               06220
         TGET BUFFER,SIZE                                               06221
         TGET BUFFER,,EDIT                                              06222
         TGET BUFFER,,,WAIT                                             06223
         TGET BUFFER,,,,MF=(E,(1))                                      06224
*        ALL BUFFER + 1 PARM                                            06225
         TGET BUFFER,SIZE,EDIT                                          06226
         TGET BUFFER,SIZE,,WAIT                                         06227
         TGET BUFFER,SIZE,,,MF=(E,(1))                                  06228
* ALL BUFFER + 2 PARMS                                                  06229
         TGET BUFFER,SIZE,EDIT,WAIT                                     06230
         TGET BUFFER,SIZE,EDIT,,MF=(E,(1))                              06231
*        ALL BUFFER +3 PARMS                                            06232
         TGET BUFFER,SIZE,EDIT,WAIT,MF=(E,(1))                          06233
*  ALL PARMS                                                            06234
         TGET ,SIZE,EDIT                                                06235
         TGET ,SIZE,,WAIT                                               06236
         TGET ,SIZE,,,MF=(E,(1))                                        06237
* ALL SIZE + 1 PARM                                                     06238
         TGET ,SIZE,EDIT,WAIT                                           06239
         TGET ,SIZE,=EDIT,,MF=(E,(1))                                   06240
* ALL SIZE + 2 PARMS                                                    06241
         TGET ,SIZE,EDIT,WAIT,MF=(E,(1))                                06242
* ALL SIZE + ALL PARMS BUT BUFFER                                       06243
         TGET ,,EDIT,WAIT                                               06244
         TGET ,,EDIT,MF=(E,(1))                                         06245
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06246
* ALL REST OF EDIT COMBINATIONS                                         06247
         TGET ,,,WAIT,MF=(E,(1))                                        06248
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06249
         TGET (R2)                                                      06250
         TGET ,SIZE                                                     06251
         TGET ,,EDIT                                                    06252
         TGET ,,,WAIT                                                   06253
         TGET ,,,,MF=(E,(1))                                            06254
*        ALL SINGLE PARMS                                               06255
         TGET (R2),SIZE                                                 06256
         TGET (R2),,EDIT                                                06257
         TGET (R2),,,WAIT                                               06258
         TGET (R2),,,,MF=(E,(1))                                        06259
*        ALL (R2) + 1 PARM                                              06260
         TGET (R2),SIZE,EDIT                                            06261
         TGET (R2),SIZE,,WAIT                                           06262
         TGET (R2),SIZE,,,MF=(E,(1))                                    06263
* ALL (R2) + 2 PARMS                                                    06264
         TGET (R2),SIZE,EDIT,WAIT                                       06265
         TGET (R2),SIZE,EDIT,,MF=(E,(1))                                06266
*        ALL (R2) +3 PARMS                                              06267
         TGET (R2),SIZE,EDIT,WAIT,MF=(E,(1))                            06268
*  ALL PARMS                                                            06269
         TGET ,SIZE,EDIT                                                06270
         TGET ,SIZE,,WAIT                                               06271
         TGET ,SIZE,,,MF=(E,(1))                                        06272
* ALL SIZE + 1 PARM                                                     06273
         TGET ,SIZE,EDIT,WAIT                                           06274
         TGET ,SIZE,=EDIT,,MF=(E,(1))                                   06275
* ALL SIZE + 2 PARMS                                                    06276
         TGET ,SIZE,EDIT,WAIT,MF=(E,(1))                                06277
* ALL SIZE + ALL PARMS BUT (R2)                                         06278
         TGET ,,EDIT,WAIT                                               06279
         TGET ,,EDIT,MF=(E,(1))                                         06280
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06281
* ALL REST OF EDIT COMBINATIONS                                         06282
         TGET ,,,WAIT,MF=(E,(1))                                        06283
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06284
         TGET (2)                                                       06285
         TGET ,SIZE                                                     06286
         TGET ,,EDIT                                                    06287
         TGET ,,,WAIT                                                   06288
         TGET ,,,,MF=(E,(1))                                            06289
*        ALL SINGLE PARMS                                               06290
         TGET (2),SIZE                                                  06291
         TGET (2),,EDIT                                                 06292
         TGET (2),,,WAIT                                                06293
         TGET (2),,,,MF=(E,(1))                                         06294
*        ALL (2) + 1 PARM                                               06295
         TGET (2),SIZE,EDIT                                             06296
         TGET (2),SIZE,,WAIT                                            06297
         TGET (2),SIZE,,,MF=(E,(1))                                     06298
* ALL (2) + 2 PARMS                                                     06299
         TGET (2),SIZE,EDIT,WAIT                                        06300
         TGET (2),SIZE,EDIT,,MF=(E,(1))                                 06301
*        ALL (2) +3 PARMS                                               06302
         TGET (2),SIZE,EDIT,WAIT,MF=(E,(1))                             06303
*  ALL PARMS                                                            06304
         TGET ,SIZE,EDIT                                                06305
         TGET ,SIZE,,WAIT                                               06306
         TGET ,SIZE,,,MF=(E,(1))                                        06307
* ALL SIZE + 1 PARM                                                     06308
         TGET ,SIZE,EDIT,WAIT                                           06309
         TGET ,SIZE,=EDIT,,MF=(E,(1))                                   06310
* ALL SIZE + 2 PARMS                                                    06311
         TGET ,SIZE,EDIT,WAIT,MF=(E,(1))                                06312
* ALL SIZE + ALL PARMS BUT (2)                                          06313
         TGET ,,EDIT,WAIT                                               06314
         TGET ,,EDIT,MF=(E,(1))                                         06315
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06316
* ALL REST OF EDIT COMBINATIONS                                         06317
         TGET ,,,WAIT,MF=(E,(1))                                        06318
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06319
         TGET 12(2)                                                     06320
         TGET ,SIZE                                                     06321
         TGET ,,EDIT                                                    06322
         TGET ,,,WAIT                                                   06323
         TGET ,,,,MF=(E,(1))                                            06324
*        ALL SINGLE PARMS                                               06325
         TGET 12(2),SIZE                                                06326
         TGET 12(2),,EDIT                                               06327
         TGET 12(2),,,WAIT                                              06328
         TGET 12(2),,,,MF=(E,(1))                                       06329
*        ALL 12(2) + 1 PARM                                             06330
         TGET 12(2),SIZE,EDIT                                           06331
         TGET 12(2),SIZE,,WAIT                                          06332
         TGET 12(2),SIZE,,,MF=(E,(1))                                   06333
* ALL 12(2) + 2 PARMS                                                   06334
         TGET 12(2),SIZE,EDIT,WAIT                                      06335
         TGET 12(2),SIZE,EDIT,,MF=(E,(1))                               06336
*        ALL 12(2) +3 PARMS                                             06337
         TGET 12(2),SIZE,EDIT,WAIT,MF=(E,(1))                           06338
*  ALL PARMS                                                            06339
         TGET ,SIZE,EDIT                                                06340
         TGET ,SIZE,,WAIT                                               06341
         TGET ,SIZE,,,MF=(E,(1))                                        06342
* ALL SIZE + 1 PARM                                                     06343
         TGET ,SIZE,EDIT,WAIT                                           06344
         TGET ,SIZE,=EDIT,,MF=(E,(1))                                   06345
* ALL SIZE + 2 PARMS                                                    06346
         TGET ,SIZE,EDIT,WAIT,MF=(E,(1))                                06347
* ALL SIZE + ALL PARMS BUT 12(2)                                        06348
         TGET ,,EDIT,WAIT                                               06349
         TGET ,,EDIT,MF=(E,(1))                                         06350
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06351
* ALL REST OF EDIT COMBINATIONS                                         06352
         TGET ,,,WAIT,MF=(E,(1))                                        06353
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06354
         TGET BUFFER                                                    06355
         TGET ,100                                                      06356
         TGET ,,EDIT                                                    06357
         TGET ,,,WAIT                                                   06358
         TGET ,,,,MF=(E,(1))                                            06359
*        ALL SINGLE PARMS                                               06360
         TGET BUFFER,100                                                06361
         TGET BUFFER,,EDIT                                              06362
         TGET BUFFER,,,WAIT                                             06363
         TGET BUFFER,,,,MF=(E,(1))                                      06364
*        ALL BUFFER + 1 PARM                                            06365
         TGET BUFFER,100,EDIT                                           06366
         TGET BUFFER,100,,WAIT                                          06367
         TGET BUFFER,100,,,MF=(E,(1))                                   06368
* ALL BUFFER + 2 PARMS                                                  06369
         TGET BUFFER,100,EDIT,WAIT                                      06370
         TGET BUFFER,100,EDIT,,MF=(E,(1))                               06371
*        ALL BUFFER +3 PARMS                                            06372
         TGET BUFFER,100,EDIT,WAIT,MF=(E,(1))                           06373
*  ALL PARMS                                                            06374
         TGET ,100,EDIT                                                 06375
         TGET ,100,,WAIT                                                06376
         TGET ,100,,,MF=(E,(1))                                         06377
* ALL 100 + 1 PARM                                                      06378
         TGET ,100,EDIT,WAIT                                            06379
         TGET ,100,=EDIT,,MF=(E,(1))                                    06380
* ALL 100 + 2 PARMS                                                     06381
         TGET ,100,EDIT,WAIT,MF=(E,(1))                                 06382
* ALL 100 + ALL PARMS BUT BUFFER                                        06383
         TGET ,,EDIT,WAIT                                               06384
         TGET ,,EDIT,MF=(E,(1))                                         06385
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06386
* ALL REST OF EDIT COMBINATIONS                                         06387
         TGET ,,,WAIT,MF=(E,(1))                                        06388
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06389
         TGET (R2)                                                      06390
         TGET ,100                                                      06391
         TGET ,,EDIT                                                    06392
         TGET ,,,WAIT                                                   06393
         TGET ,,,,MF=(E,(1))                                            06394
*        ALL SINGLE PARMS                                               06395
         TGET (R2),100                                                  06396
         TGET (R2),,EDIT                                                06397
         TGET (R2),,,WAIT                                               06398
         TGET (R2),,,,MF=(E,(1))                                        06399
*        ALL (R2) + 1 PARM                                              06400
         TGET (R2),100,EDIT                                             06401
         TGET (R2),100,,WAIT                                            06402
         TGET (R2),100,,,MF=(E,(1))                                     06403
* ALL (R2) + 2 PARMS                                                    06404
         TGET (R2),100,EDIT,WAIT                                        06405
         TGET (R2),100,EDIT,,MF=(E,(1))                                 06406
*        ALL (R2) +3 PARMS                                              06407
         TGET (R2),100,EDIT,WAIT,MF=(E,(1))                             06408
*  ALL PARMS                                                            06409
         TGET ,100,EDIT                                                 06410
         TGET ,100,,WAIT                                                06411
         TGET ,100,,,MF=(E,(1))                                         06412
* ALL 100 + 1 PARM                                                      06413
         TGET ,100,EDIT,WAIT                                            06414
         TGET ,100,=EDIT,,MF=(E,(1))                                    06415
* ALL 100 + 2 PARMS                                                     06416
         TGET ,100,EDIT,WAIT,MF=(E,(1))                                 06417
* ALL 100 + ALL PARMS BUT (R2)                                          06418
         TGET ,,EDIT,WAIT                                               06419
         TGET ,,EDIT,MF=(E,(1))                                         06420
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06421
* ALL REST OF EDIT COMBINATIONS                                         06422
         TGET ,,,WAIT,MF=(E,(1))                                        06423
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06424
         TGET (2)                                                       06425
         TGET ,100                                                      06426
         TGET ,,EDIT                                                    06427
         TGET ,,,WAIT                                                   06428
         TGET ,,,,MF=(E,(1))                                            06429
*        ALL SINGLE PARMS                                               06430
         TGET (2),100                                                   06431
         TGET (2),,EDIT                                                 06432
         TGET (2),,,WAIT                                                06433
         TGET (2),,,,MF=(E,(1))                                         06434
*        ALL (2) + 1 PARM                                               06435
         TGET (2),100,EDIT                                              06436
         TGET (2),100,,WAIT                                             06437
         TGET (2),100,,,MF=(E,(1))                                      06438
* ALL (2) + 2 PARMS                                                     06439
         TGET (2),100,EDIT,WAIT                                         06440
         TGET (2),100,EDIT,,MF=(E,(1))                                  06441
*        ALL (2) +3 PARMS                                               06442
         TGET (2),100,EDIT,WAIT,MF=(E,(1))                              06443
*  ALL PARMS                                                            06444
         TGET ,100,EDIT                                                 06445
         TGET ,100,,WAIT                                                06446
         TGET ,100,,,MF=(E,(1))                                         06447
* ALL 100 + 1 PARM                                                      06448
         TGET ,100,EDIT,WAIT                                            06449
         TGET ,100,=EDIT,,MF=(E,(1))                                    06450
* ALL 100 + 2 PARMS                                                     06451
         TGET ,100,EDIT,WAIT,MF=(E,(1))                                 06452
* ALL 100 + ALL PARMS BUT (2)                                           06453
         TGET ,,EDIT,WAIT                                               06454
         TGET ,,EDIT,MF=(E,(1))                                         06455
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06456
* ALL REST OF EDIT COMBINATIONS                                         06457
         TGET ,,,WAIT,MF=(E,(1))                                        06458
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06459
         TGET 12(2)                                                     06460
         TGET ,100                                                      06461
         TGET ,,EDIT                                                    06462
         TGET ,,,WAIT                                                   06463
         TGET ,,,,MF=(E,(1))                                            06464
*        ALL SINGLE PARMS                                               06465
         TGET 12(2),100                                                 06466
         TGET 12(2),,EDIT                                               06467
         TGET 12(2),,,WAIT                                              06468
         TGET 12(2),,,,MF=(E,(1))                                       06469
*        ALL 12(2) + 1 PARM                                             06470
         TGET 12(2),100,EDIT                                            06471
         TGET 12(2),100,,WAIT                                           06472
         TGET 12(2),100,,,MF=(E,(1))                                    06473
* ALL 12(2) + 2 PARMS                                                   06474
         TGET 12(2),100,EDIT,WAIT                                       06475
         TGET 12(2),100,EDIT,,MF=(E,(1))                                06476
*        ALL 12(2) +3 PARMS                                             06477
         TGET 12(2),100,EDIT,WAIT,MF=(E,(1))                            06478
*  ALL PARMS                                                            06479
         TGET ,100,EDIT                                                 06480
         TGET ,100,,WAIT                                                06481
         TGET ,100,,,MF=(E,(1))                                         06482
* ALL 100 + 1 PARM                                                      06483
         TGET ,100,EDIT,WAIT                                            06484
         TGET ,100,=EDIT,,MF=(E,(1))                                    06485
* ALL 100 + 2 PARMS                                                     06486
         TGET ,100,EDIT,WAIT,MF=(E,(1))                                 06487
* ALL 100 + ALL PARMS BUT 12(2)                                         06488
         TGET ,,EDIT,WAIT                                               06489
         TGET ,,EDIT,MF=(E,(1))                                         06490
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06491
* ALL REST OF EDIT COMBINATIONS                                         06492
         TGET ,,,WAIT,MF=(E,(1))                                        06493
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06494
         TGET BUFFER                                                    06495
         TGET ,(R3)                                                     06496
         TGET ,,EDIT                                                    06497
         TGET ,,,WAIT                                                   06498
         TGET ,,,,MF=(E,(1))                                            06499
*        ALL SINGLE PARMS                                               06500
         TGET BUFFER,(R3)                                               06501
         TGET BUFFER,,EDIT                                              06502
         TGET BUFFER,,,WAIT                                             06503
         TGET BUFFER,,,,MF=(E,(1))                                      06504
*        ALL BUFFER + 1 PARM                                            06505
         TGET BUFFER,(R3),EDIT                                          06506
         TGET BUFFER,(R3),,WAIT                                         06507
         TGET BUFFER,(R3),,,MF=(E,(1))                                  06508
* ALL BUFFER + 2 PARMS                                                  06509
         TGET BUFFER,(R3),EDIT,WAIT                                     06510
         TGET BUFFER,(R3),EDIT,,MF=(E,(1))                              06511
*        ALL BUFFER +3 PARMS                                            06512
         TGET BUFFER,(R3),EDIT,WAIT,MF=(E,(1))                          06513
*  ALL PARMS                                                            06514
         TGET ,(R3),EDIT                                                06515
         TGET ,(R3),,WAIT                                               06516
         TGET ,(R3),,,MF=(E,(1))                                        06517
* ALL (R3) + 1 PARM                                                     06518
         TGET ,(R3),EDIT,WAIT                                           06519
         TGET ,(R3),=EDIT,,MF=(E,(1))                                   06520
* ALL (R3) + 2 PARMS                                                    06521
         TGET ,(R3),EDIT,WAIT,MF=(E,(1))                                06522
* ALL (R3) + ALL PARMS BUT BUFFER                                       06523
         TGET ,,EDIT,WAIT                                               06524
         TGET ,,EDIT,MF=(E,(1))                                         06525
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06526
* ALL REST OF EDIT COMBINATIONS                                         06527
         TGET ,,,WAIT,MF=(E,(1))                                        06528
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06529
         TGET (R2)                                                      06530
         TGET ,(R3)                                                     06531
         TGET ,,EDIT                                                    06532
         TGET ,,,WAIT                                                   06533
         TGET ,,,,MF=(E,(1))                                            06534
*        ALL SINGLE PARMS                                               06535
         TGET (R2),(R3)                                                 06536
         TGET (R2),,EDIT                                                06537
         TGET (R2),,,WAIT                                               06538
         TGET (R2),,,,MF=(E,(1))                                        06539
*        ALL (R2) + 1 PARM                                              06540
         TGET (R2),(R3),EDIT                                            06541
         TGET (R2),(R3),,WAIT                                           06542
         TGET (R2),(R3),,,MF=(E,(1))                                    06543
* ALL (R2) + 2 PARMS                                                    06544
         TGET (R2),(R3),EDIT,WAIT                                       06545
         TGET (R2),(R3),EDIT,,MF=(E,(1))                                06546
*        ALL (R2) +3 PARMS                                              06547
         TGET (R2),(R3),EDIT,WAIT,MF=(E,(1))                            06548
*  ALL PARMS                                                            06549
         TGET ,(R3),EDIT                                                06550
         TGET ,(R3),,WAIT                                               06551
         TGET ,(R3),,,MF=(E,(1))                                        06552
* ALL (R3) + 1 PARM                                                     06553
         TGET ,(R3),EDIT,WAIT                                           06554
         TGET ,(R3),=EDIT,,MF=(E,(1))                                   06555
* ALL (R3) + 2 PARMS                                                    06556
         TGET ,(R3),EDIT,WAIT,MF=(E,(1))                                06557
* ALL (R3) + ALL PARMS BUT (R2)                                         06558
         TGET ,,EDIT,WAIT                                               06559
         TGET ,,EDIT,MF=(E,(1))                                         06560
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06561
* ALL REST OF EDIT COMBINATIONS                                         06562
         TGET ,,,WAIT,MF=(E,(1))                                        06563
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06564
         TGET (2)                                                       06565
         TGET ,(R3)                                                     06566
         TGET ,,EDIT                                                    06567
         TGET ,,,WAIT                                                   06568
         TGET ,,,,MF=(E,(1))                                            06569
*        ALL SINGLE PARMS                                               06570
         TGET (2),(R3)                                                  06571
         TGET (2),,EDIT                                                 06572
         TGET (2),,,WAIT                                                06573
         TGET (2),,,,MF=(E,(1))                                         06574
*        ALL (2) + 1 PARM                                               06575
         TGET (2),(R3),EDIT                                             06576
         TGET (2),(R3),,WAIT                                            06577
         TGET (2),(R3),,,MF=(E,(1))                                     06578
* ALL (2) + 2 PARMS                                                     06579
         TGET (2),(R3),EDIT,WAIT                                        06580
         TGET (2),(R3),EDIT,,MF=(E,(1))                                 06581
*        ALL (2) +3 PARMS                                               06582
         TGET (2),(R3),EDIT,WAIT,MF=(E,(1))                             06583
*  ALL PARMS                                                            06584
         TGET ,(R3),EDIT                                                06585
         TGET ,(R3),,WAIT                                               06586
         TGET ,(R3),,,MF=(E,(1))                                        06587
* ALL (R3) + 1 PARM                                                     06588
         TGET ,(R3),EDIT,WAIT                                           06589
         TGET ,(R3),=EDIT,,MF=(E,(1))                                   06590
* ALL (R3) + 2 PARMS                                                    06591
         TGET ,(R3),EDIT,WAIT,MF=(E,(1))                                06592
* ALL (R3) + ALL PARMS BUT (2)                                          06593
         TGET ,,EDIT,WAIT                                               06594
         TGET ,,EDIT,MF=(E,(1))                                         06595
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06596
* ALL REST OF EDIT COMBINATIONS                                         06597
         TGET ,,,WAIT,MF=(E,(1))                                        06598
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06599
         TGET 12(2)                                                     06600
         TGET ,(R3)                                                     06601
         TGET ,,EDIT                                                    06602
         TGET ,,,WAIT                                                   06603
         TGET ,,,,MF=(E,(1))                                            06604
*        ALL SINGLE PARMS                                               06605
         TGET 12(2),(R3)                                                06606
         TGET 12(2),,EDIT                                               06607
         TGET 12(2),,,WAIT                                              06608
         TGET 12(2),,,,MF=(E,(1))                                       06609
*        ALL 12(2) + 1 PARM                                             06610
         TGET 12(2),(R3),EDIT                                           06611
         TGET 12(2),(R3),,WAIT                                          06612
         TGET 12(2),(R3),,,MF=(E,(1))                                   06613
* ALL 12(2) + 2 PARMS                                                   06614
         TGET 12(2),(R3),EDIT,WAIT                                      06615
         TGET 12(2),(R3),EDIT,,MF=(E,(1))                               06616
*        ALL 12(2) +3 PARMS                                             06617
         TGET 12(2),(R3),EDIT,WAIT,MF=(E,(1))                           06618
*  ALL PARMS                                                            06619
         TGET ,(R3),EDIT                                                06620
         TGET ,(R3),,WAIT                                               06621
         TGET ,(R3),,,MF=(E,(1))                                        06622
* ALL (R3) + 1 PARM                                                     06623
         TGET ,(R3),EDIT,WAIT                                           06624
         TGET ,(R3),=EDIT,,MF=(E,(1))                                   06625
* ALL (R3) + 2 PARMS                                                    06626
         TGET ,(R3),EDIT,WAIT,MF=(E,(1))                                06627
* ALL (R3) + ALL PARMS BUT 12(2)                                        06628
         TGET ,,EDIT,WAIT                                               06629
         TGET ,,EDIT,MF=(E,(1))                                         06630
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06631
* ALL REST OF EDIT COMBINATIONS                                         06632
         TGET ,,,WAIT,MF=(E,(1))                                        06633
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06634
         TGET BUFFER                                                    06635
         TGET ,(3)                                                      06636
         TGET ,,EDIT                                                    06637
         TGET ,,,WAIT                                                   06638
         TGET ,,,,MF=(E,(1))                                            06639
*        ALL SINGLE PARMS                                               06640
         TGET BUFFER,(3)                                                06641
         TGET BUFFER,,EDIT                                              06642
         TGET BUFFER,,,WAIT                                             06643
         TGET BUFFER,,,,MF=(E,(1))                                      06644
*        ALL BUFFER + 1 PARM                                            06645
         TGET BUFFER,(3),EDIT                                           06646
         TGET BUFFER,(3),,WAIT                                          06647
         TGET BUFFER,(3),,,MF=(E,(1))                                   06648
* ALL BUFFER + 2 PARMS                                                  06649
         TGET BUFFER,(3),EDIT,WAIT                                      06650
         TGET BUFFER,(3),EDIT,,MF=(E,(1))                               06651
*        ALL BUFFER +3 PARMS                                            06652
         TGET BUFFER,(3),EDIT,WAIT,MF=(E,(1))                           06653
*  ALL PARMS                                                            06654
         TGET ,(3),EDIT                                                 06655
         TGET ,(3),,WAIT                                                06656
         TGET ,(3),,,MF=(E,(1))                                         06657
* ALL (3) + 1 PARM                                                      06658
         TGET ,(3),EDIT,WAIT                                            06659
         TGET ,(3),=EDIT,,MF=(E,(1))                                    06660
* ALL (3) + 2 PARMS                                                     06661
         TGET ,(3),EDIT,WAIT,MF=(E,(1))                                 06662
* ALL (3) + ALL PARMS BUT BUFFER                                        06663
         TGET ,,EDIT,WAIT                                               06664
         TGET ,,EDIT,MF=(E,(1))                                         06665
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06666
* ALL REST OF EDIT COMBINATIONS                                         06667
         TGET ,,,WAIT,MF=(E,(1))                                        06668
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06669
         TGET (R2)                                                      06670
         TGET ,(3)                                                      06671
         TGET ,,EDIT                                                    06672
         TGET ,,,WAIT                                                   06673
         TGET ,,,,MF=(E,(1))                                            06674
*        ALL SINGLE PARMS                                               06675
         TGET (R2),(3)                                                  06676
         TGET (R2),,EDIT                                                06677
         TGET (R2),,,WAIT                                               06678
         TGET (R2),,,,MF=(E,(1))                                        06679
*        ALL (R2) + 1 PARM                                              06680
         TGET (R2),(3),EDIT                                             06681
         TGET (R2),(3),,WAIT                                            06682
         TGET (R2),(3),,,MF=(E,(1))                                     06683
* ALL (R2) + 2 PARMS                                                    06684
         TGET (R2),(3),EDIT,WAIT                                        06685
         TGET (R2),(3),EDIT,,MF=(E,(1))                                 06686
*        ALL (R2) +3 PARMS                                              06687
         TGET (R2),(3),EDIT,WAIT,MF=(E,(1))                             06688
*  ALL PARMS                                                            06689
         TGET ,(3),EDIT                                                 06690
         TGET ,(3),,WAIT                                                06691
         TGET ,(3),,,MF=(E,(1))                                         06692
* ALL (3) + 1 PARM                                                      06693
         TGET ,(3),EDIT,WAIT                                            06694
         TGET ,(3),=EDIT,,MF=(E,(1))                                    06695
* ALL (3) + 2 PARMS                                                     06696
         TGET ,(3),EDIT,WAIT,MF=(E,(1))                                 06697
* ALL (3) + ALL PARMS BUT (R2)                                          06698
         TGET ,,EDIT,WAIT                                               06699
         TGET ,,EDIT,MF=(E,(1))                                         06700
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06701
* ALL REST OF EDIT COMBINATIONS                                         06702
         TGET ,,,WAIT,MF=(E,(1))                                        06703
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06704
         TGET (2)                                                       06705
         TGET ,(3)                                                      06706
         TGET ,,EDIT                                                    06707
         TGET ,,,WAIT                                                   06708
         TGET ,,,,MF=(E,(1))                                            06709
*        ALL SINGLE PARMS                                               06710
         TGET (2),(3)                                                   06711
         TGET (2),,EDIT                                                 06712
         TGET (2),,,WAIT                                                06713
         TGET (2),,,,MF=(E,(1))                                         06714
*        ALL (2) + 1 PARM                                               06715
         TGET (2),(3),EDIT                                              06716
         TGET (2),(3),,WAIT                                             06717
         TGET (2),(3),,,MF=(E,(1))                                      06718
* ALL (2) + 2 PARMS                                                     06719
         TGET (2),(3),EDIT,WAIT                                         06720
         TGET (2),(3),EDIT,,MF=(E,(1))                                  06721
*        ALL (2) +3 PARMS                                               06722
         TGET (2),(3),EDIT,WAIT,MF=(E,(1))                              06723
*  ALL PARMS                                                            06724
         TGET ,(3),EDIT                                                 06725
         TGET ,(3),,WAIT                                                06726
         TGET ,(3),,,MF=(E,(1))                                         06727
* ALL (3) + 1 PARM                                                      06728
         TGET ,(3),EDIT,WAIT                                            06729
         TGET ,(3),=EDIT,,MF=(E,(1))                                    06730
* ALL (3) + 2 PARMS                                                     06731
         TGET ,(3),EDIT,WAIT,MF=(E,(1))                                 06732
* ALL (3) + ALL PARMS BUT (2)                                           06733
         TGET ,,EDIT,WAIT                                               06734
         TGET ,,EDIT,MF=(E,(1))                                         06735
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06736
* ALL REST OF EDIT COMBINATIONS                                         06737
         TGET ,,,WAIT,MF=(E,(1))                                        06738
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06739
         TGET 12(2)                                                     06740
         TGET ,(3)                                                      06741
         TGET ,,EDIT                                                    06742
         TGET ,,,WAIT                                                   06743
         TGET ,,,,MF=(E,(1))                                            06744
*        ALL SINGLE PARMS                                               06745
         TGET 12(2),(3)                                                 06746
         TGET 12(2),,EDIT                                               06747
         TGET 12(2),,,WAIT                                              06748
         TGET 12(2),,,,MF=(E,(1))                                       06749
*        ALL 12(2) + 1 PARM                                             06750
         TGET 12(2),(3),EDIT                                            06751
         TGET 12(2),(3),,WAIT                                           06752
         TGET 12(2),(3),,,MF=(E,(1))                                    06753
* ALL 12(2) + 2 PARMS                                                   06754
         TGET 12(2),(3),EDIT,WAIT                                       06755
         TGET 12(2),(3),EDIT,,MF=(E,(1))                                06756
*        ALL 12(2) +3 PARMS                                             06757
         TGET 12(2),(3),EDIT,WAIT,MF=(E,(1))                            06758
*  ALL PARMS                                                            06759
         TGET ,(3),EDIT                                                 06760
         TGET ,(3),,WAIT                                                06761
         TGET ,(3),,,MF=(E,(1))                                         06762
* ALL (3) + 1 PARM                                                      06763
         TGET ,(3),EDIT,WAIT                                            06764
         TGET ,(3),=EDIT,,MF=(E,(1))                                    06765
* ALL (3) + 2 PARMS                                                     06766
         TGET ,(3),EDIT,WAIT,MF=(E,(1))                                 06767
* ALL (3) + ALL PARMS BUT 12(2)                                         06768
         TGET ,,EDIT,WAIT                                               06769
         TGET ,,EDIT,MF=(E,(1))                                         06770
         TGET ,,EDIT,WAIT,MF=(E,(1))                                    06771
* ALL REST OF EDIT COMBINATIONS                                         06772
         TGET ,,,WAIT,MF=(E,(1))                                        06773
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06774
         TGET BUFFER                                                    06775
         TGET ,SIZE                                                     06776
         TGET ,,EDIT                                                    06777
         TGET ,,,WAIT                                                   06778
         TGET ,,,,MF=L                                                  06779
*        ALL SINGLE PARMS                                               06780
         TGET BUFFER,SIZE                                               06781
         TGET BUFFER,,EDIT                                              06782
         TGET BUFFER,,,WAIT                                             06783
         TGET BUFFER,,,,MF=L                                            06784
*        ALL BUFFER + 1 PARM                                            06785
         TGET BUFFER,SIZE,EDIT                                          06786
         TGET BUFFER,SIZE,,WAIT                                         06787
         TGET BUFFER,SIZE,,,MF=L                                        06788
* ALL BUFFER + 2 PARMS                                                  06789
         TGET BUFFER,SIZE,EDIT,WAIT                                     06790
         TGET BUFFER,SIZE,EDIT,,MF=L                                    06791
*        ALL BUFFER +3 PARMS                                            06792
         TGET BUFFER,SIZE,EDIT,WAIT,MF=L                                06793
*  ALL PARMS                                                            06794
         TGET ,SIZE,EDIT                                                06795
         TGET ,SIZE,,WAIT                                               06796
         TGET ,SIZE,,,MF=L                                              06797
* ALL SIZE + 1 PARM                                                     06798
         TGET ,SIZE,EDIT,WAIT                                           06799
         TGET ,SIZE,=EDIT,,MF=L                                         06800
* ALL SIZE + 2 PARMS                                                    06801
         TGET ,SIZE,EDIT,WAIT,MF=L                                      06802
* ALL SIZE + ALL PARMS BUT BUFFER                                       06803
         TGET ,,EDIT,WAIT                                               06804
         TGET ,,EDIT,MF=L                                               06805
         TGET ,,EDIT,WAIT,MF=L                                          06806
* ALL REST OF EDIT COMBINATIONS                                         06807
         TGET ,,,WAIT,MF=L                                              06808
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06809
         TGET (R2)                                                      06810
         TGET ,SIZE                                                     06811
         TGET ,,EDIT                                                    06812
         TGET ,,,WAIT                                                   06813
         TGET ,,,,MF=L                                                  06814
*        ALL SINGLE PARMS                                               06815
         TGET (R2),SIZE                                                 06816
         TGET (R2),,EDIT                                                06817
         TGET (R2),,,WAIT                                               06818
         TGET (R2),,,,MF=L                                              06819
*        ALL (R2) + 1 PARM                                              06820
         TGET (R2),SIZE,EDIT                                            06821
         TGET (R2),SIZE,,WAIT                                           06822
         TGET (R2),SIZE,,,MF=L                                          06823
* ALL (R2) + 2 PARMS                                                    06824
         TGET (R2),SIZE,EDIT,WAIT                                       06825
         TGET (R2),SIZE,EDIT,,MF=L                                      06826
*        ALL (R2) +3 PARMS                                              06827
         TGET (R2),SIZE,EDIT,WAIT,MF=L                                  06828
*  ALL PARMS                                                            06829
         TGET ,SIZE,EDIT                                                06830
         TGET ,SIZE,,WAIT                                               06831
         TGET ,SIZE,,,MF=L                                              06832
* ALL SIZE + 1 PARM                                                     06833
         TGET ,SIZE,EDIT,WAIT                                           06834
         TGET ,SIZE,=EDIT,,MF=L                                         06835
* ALL SIZE + 2 PARMS                                                    06836
         TGET ,SIZE,EDIT,WAIT,MF=L                                      06837
* ALL SIZE + ALL PARMS BUT (R2)                                         06838
         TGET ,,EDIT,WAIT                                               06839
         TGET ,,EDIT,MF=L                                               06840
         TGET ,,EDIT,WAIT,MF=L                                          06841
* ALL REST OF EDIT COMBINATIONS                                         06842
         TGET ,,,WAIT,MF=L                                              06843
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06844
         TGET (2)                                                       06845
         TGET ,SIZE                                                     06846
         TGET ,,EDIT                                                    06847
         TGET ,,,WAIT                                                   06848
         TGET ,,,,MF=L                                                  06849
*        ALL SINGLE PARMS                                               06850
         TGET (2),SIZE                                                  06851
         TGET (2),,EDIT                                                 06852
         TGET (2),,,WAIT                                                06853
         TGET (2),,,,MF=L                                               06854
*        ALL (2) + 1 PARM                                               06855
         TGET (2),SIZE,EDIT                                             06856
         TGET (2),SIZE,,WAIT                                            06857
         TGET (2),SIZE,,,MF=L                                           06858
* ALL (2) + 2 PARMS                                                     06859
         TGET (2),SIZE,EDIT,WAIT                                        06860
         TGET (2),SIZE,EDIT,,MF=L                                       06861
*        ALL (2) +3 PARMS                                               06862
         TGET (2),SIZE,EDIT,WAIT,MF=L                                   06863
*  ALL PARMS                                                            06864
         TGET ,SIZE,EDIT                                                06865
         TGET ,SIZE,,WAIT                                               06866
         TGET ,SIZE,,,MF=L                                              06867
* ALL SIZE + 1 PARM                                                     06868
         TGET ,SIZE,EDIT,WAIT                                           06869
         TGET ,SIZE,=EDIT,,MF=L                                         06870
* ALL SIZE + 2 PARMS                                                    06871
         TGET ,SIZE,EDIT,WAIT,MF=L                                      06872
* ALL SIZE + ALL PARMS BUT (2)                                          06873
         TGET ,,EDIT,WAIT                                               06874
         TGET ,,EDIT,MF=L                                               06875
         TGET ,,EDIT,WAIT,MF=L                                          06876
* ALL REST OF EDIT COMBINATIONS                                         06877
         TGET ,,,WAIT,MF=L                                              06878
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06879
         TGET 12(2)                                                     06880
         TGET ,SIZE                                                     06881
         TGET ,,EDIT                                                    06882
         TGET ,,,WAIT                                                   06883
         TGET ,,,,MF=L                                                  06884
*        ALL SINGLE PARMS                                               06885
         TGET 12(2),SIZE                                                06886
         TGET 12(2),,EDIT                                               06887
         TGET 12(2),,,WAIT                                              06888
         TGET 12(2),,,,MF=L                                             06889
*        ALL 12(2) + 1 PARM                                             06890
         TGET 12(2),SIZE,EDIT                                           06891
         TGET 12(2),SIZE,,WAIT                                          06892
         TGET 12(2),SIZE,,,MF=L                                         06893
* ALL 12(2) + 2 PARMS                                                   06894
         TGET 12(2),SIZE,EDIT,WAIT                                      06895
         TGET 12(2),SIZE,EDIT,,MF=L                                     06896
*        ALL 12(2) +3 PARMS                                             06897
         TGET 12(2),SIZE,EDIT,WAIT,MF=L                                 06898
*  ALL PARMS                                                            06899
         TGET ,SIZE,EDIT                                                06900
         TGET ,SIZE,,WAIT                                               06901
         TGET ,SIZE,,,MF=L                                              06902
* ALL SIZE + 1 PARM                                                     06903
         TGET ,SIZE,EDIT,WAIT                                           06904
         TGET ,SIZE,=EDIT,,MF=L                                         06905
* ALL SIZE + 2 PARMS                                                    06906
         TGET ,SIZE,EDIT,WAIT,MF=L                                      06907
* ALL SIZE + ALL PARMS BUT 12(2)                                        06908
         TGET ,,EDIT,WAIT                                               06909
         TGET ,,EDIT,MF=L                                               06910
         TGET ,,EDIT,WAIT,MF=L                                          06911
* ALL REST OF EDIT COMBINATIONS                                         06912
         TGET ,,,WAIT,MF=L                                              06913
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06914
         TGET BUFFER                                                    06915
         TGET ,100                                                      06916
         TGET ,,EDIT                                                    06917
         TGET ,,,WAIT                                                   06918
         TGET ,,,,MF=L                                                  06919
*        ALL SINGLE PARMS                                               06920
         TGET BUFFER,100                                                06921
         TGET BUFFER,,EDIT                                              06922
         TGET BUFFER,,,WAIT                                             06923
         TGET BUFFER,,,,MF=L                                            06924
*        ALL BUFFER + 1 PARM                                            06925
         TGET BUFFER,100,EDIT                                           06926
         TGET BUFFER,100,,WAIT                                          06927
         TGET BUFFER,100,,,MF=L                                         06928
* ALL BUFFER + 2 PARMS                                                  06929
         TGET BUFFER,100,EDIT,WAIT                                      06930
         TGET BUFFER,100,EDIT,,MF=L                                     06931
*        ALL BUFFER +3 PARMS                                            06932
         TGET BUFFER,100,EDIT,WAIT,MF=L                                 06933
*  ALL PARMS                                                            06934
         TGET ,100,EDIT                                                 06935
         TGET ,100,,WAIT                                                06936
         TGET ,100,,,MF=L                                               06937
* ALL 100 + 1 PARM                                                      06938
         TGET ,100,EDIT,WAIT                                            06939
         TGET ,100,=EDIT,,MF=L                                          06940
* ALL 100 + 2 PARMS                                                     06941
         TGET ,100,EDIT,WAIT,MF=L                                       06942
* ALL 100 + ALL PARMS BUT BUFFER                                        06943
         TGET ,,EDIT,WAIT                                               06944
         TGET ,,EDIT,MF=L                                               06945
         TGET ,,EDIT,WAIT,MF=L                                          06946
* ALL REST OF EDIT COMBINATIONS                                         06947
         TGET ,,,WAIT,MF=L                                              06948
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06949
         TGET (R2)                                                      06950
         TGET ,100                                                      06951
         TGET ,,EDIT                                                    06952
         TGET ,,,WAIT                                                   06953
         TGET ,,,,MF=L                                                  06954
*        ALL SINGLE PARMS                                               06955
         TGET (R2),100                                                  06956
         TGET (R2),,EDIT                                                06957
         TGET (R2),,,WAIT                                               06958
         TGET (R2),,,,MF=L                                              06959
*        ALL (R2) + 1 PARM                                              06960
         TGET (R2),100,EDIT                                             06961
         TGET (R2),100,,WAIT                                            06962
         TGET (R2),100,,,MF=L                                           06963
* ALL (R2) + 2 PARMS                                                    06964
         TGET (R2),100,EDIT,WAIT                                        06965
         TGET (R2),100,EDIT,,MF=L                                       06966
*        ALL (R2) +3 PARMS                                              06967
         TGET (R2),100,EDIT,WAIT,MF=L                                   06968
*  ALL PARMS                                                            06969
         TGET ,100,EDIT                                                 06970
         TGET ,100,,WAIT                                                06971
         TGET ,100,,,MF=L                                               06972
* ALL 100 + 1 PARM                                                      06973
         TGET ,100,EDIT,WAIT                                            06974
         TGET ,100,=EDIT,,MF=L                                          06975
* ALL 100 + 2 PARMS                                                     06976
         TGET ,100,EDIT,WAIT,MF=L                                       06977
* ALL 100 + ALL PARMS BUT (R2)                                          06978
         TGET ,,EDIT,WAIT                                               06979
         TGET ,,EDIT,MF=L                                               06980
         TGET ,,EDIT,WAIT,MF=L                                          06981
* ALL REST OF EDIT COMBINATIONS                                         06982
         TGET ,,,WAIT,MF=L                                              06983
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                06984
         TGET (2)                                                       06985
         TGET ,100                                                      06986
         TGET ,,EDIT                                                    06987
         TGET ,,,WAIT                                                   06988
         TGET ,,,,MF=L                                                  06989
*        ALL SINGLE PARMS                                               06990
         TGET (2),100                                                   06991
         TGET (2),,EDIT                                                 06992
         TGET (2),,,WAIT                                                06993
         TGET (2),,,,MF=L                                               06994
*        ALL (2) + 1 PARM                                               06995
         TGET (2),100,EDIT                                              06996
         TGET (2),100,,WAIT                                             06997
         TGET (2),100,,,MF=L                                            06998
* ALL (2) + 2 PARMS                                                     06999
         TGET (2),100,EDIT,WAIT                                         07000
         TGET (2),100,EDIT,,MF=L                                        07001
*        ALL (2) +3 PARMS                                               07002
         TGET (2),100,EDIT,WAIT,MF=L                                    07003
*  ALL PARMS                                                            07004
         TGET ,100,EDIT                                                 07005
         TGET ,100,,WAIT                                                07006
         TGET ,100,,,MF=L                                               07007
* ALL 100 + 1 PARM                                                      07008
         TGET ,100,EDIT,WAIT                                            07009
         TGET ,100,=EDIT,,MF=L                                          07010
* ALL 100 + 2 PARMS                                                     07011
         TGET ,100,EDIT,WAIT,MF=L                                       07012
* ALL 100 + ALL PARMS BUT (2)                                           07013
         TGET ,,EDIT,WAIT                                               07014
         TGET ,,EDIT,MF=L                                               07015
         TGET ,,EDIT,WAIT,MF=L                                          07016
* ALL REST OF EDIT COMBINATIONS                                         07017
         TGET ,,,WAIT,MF=L                                              07018
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07019
         TGET 12(2)                                                     07020
         TGET ,100                                                      07021
         TGET ,,EDIT                                                    07022
         TGET ,,,WAIT                                                   07023
         TGET ,,,,MF=L                                                  07024
*        ALL SINGLE PARMS                                               07025
         TGET 12(2),100                                                 07026
         TGET 12(2),,EDIT                                               07027
         TGET 12(2),,,WAIT                                              07028
         TGET 12(2),,,,MF=L                                             07029
*        ALL 12(2) + 1 PARM                                             07030
         TGET 12(2),100,EDIT                                            07031
         TGET 12(2),100,,WAIT                                           07032
         TGET 12(2),100,,,MF=L                                          07033
* ALL 12(2) + 2 PARMS                                                   07034
         TGET 12(2),100,EDIT,WAIT                                       07035
         TGET 12(2),100,EDIT,,MF=L                                      07036
*        ALL 12(2) +3 PARMS                                             07037
         TGET 12(2),100,EDIT,WAIT,MF=L                                  07038
*  ALL PARMS                                                            07039
         TGET ,100,EDIT                                                 07040
         TGET ,100,,WAIT                                                07041
         TGET ,100,,,MF=L                                               07042
* ALL 100 + 1 PARM                                                      07043
         TGET ,100,EDIT,WAIT                                            07044
         TGET ,100,=EDIT,,MF=L                                          07045
* ALL 100 + 2 PARMS                                                     07046
         TGET ,100,EDIT,WAIT,MF=L                                       07047
* ALL 100 + ALL PARMS BUT 12(2)                                         07048
         TGET ,,EDIT,WAIT                                               07049
         TGET ,,EDIT,MF=L                                               07050
         TGET ,,EDIT,WAIT,MF=L                                          07051
* ALL REST OF EDIT COMBINATIONS                                         07052
         TGET ,,,WAIT,MF=L                                              07053
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07054
         TGET BUFFER                                                    07055
         TGET ,(R3)                                                     07056
         TGET ,,EDIT                                                    07057
         TGET ,,,WAIT                                                   07058
         TGET ,,,,MF=L                                                  07059
*        ALL SINGLE PARMS                                               07060
         TGET BUFFER,(R3)                                               07061
         TGET BUFFER,,EDIT                                              07062
         TGET BUFFER,,,WAIT                                             07063
         TGET BUFFER,,,,MF=L                                            07064
*        ALL BUFFER + 1 PARM                                            07065
         TGET BUFFER,(R3),EDIT                                          07066
         TGET BUFFER,(R3),,WAIT                                         07067
         TGET BUFFER,(R3),,,MF=L                                        07068
* ALL BUFFER + 2 PARMS                                                  07069
         TGET BUFFER,(R3),EDIT,WAIT                                     07070
         TGET BUFFER,(R3),EDIT,,MF=L                                    07071
*        ALL BUFFER +3 PARMS                                            07072
         TGET BUFFER,(R3),EDIT,WAIT,MF=L                                07073
*  ALL PARMS                                                            07074
         TGET ,(R3),EDIT                                                07075
         TGET ,(R3),,WAIT                                               07076
         TGET ,(R3),,,MF=L                                              07077
* ALL (R3) + 1 PARM                                                     07078
         TGET ,(R3),EDIT,WAIT                                           07079
         TGET ,(R3),=EDIT,,MF=L                                         07080
* ALL (R3) + 2 PARMS                                                    07081
         TGET ,(R3),EDIT,WAIT,MF=L                                      07082
* ALL (R3) + ALL PARMS BUT BUFFER                                       07083
         TGET ,,EDIT,WAIT                                               07084
         TGET ,,EDIT,MF=L                                               07085
         TGET ,,EDIT,WAIT,MF=L                                          07086
* ALL REST OF EDIT COMBINATIONS                                         07087
         TGET ,,,WAIT,MF=L                                              07088
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07089
         TGET (R2)                                                      07090
         TGET ,(R3)                                                     07091
         TGET ,,EDIT                                                    07092
         TGET ,,,WAIT                                                   07093
         TGET ,,,,MF=L                                                  07094
*        ALL SINGLE PARMS                                               07095
         TGET (R2),(R3)                                                 07096
         TGET (R2),,EDIT                                                07097
         TGET (R2),,,WAIT                                               07098
         TGET (R2),,,,MF=L                                              07099
*        ALL (R2) + 1 PARM                                              07100
         TGET (R2),(R3),EDIT                                            07101
         TGET (R2),(R3),,WAIT                                           07102
         TGET (R2),(R3),,,MF=L                                          07103
* ALL (R2) + 2 PARMS                                                    07104
         TGET (R2),(R3),EDIT,WAIT                                       07105
         TGET (R2),(R3),EDIT,,MF=L                                      07106
*        ALL (R2) +3 PARMS                                              07107
         TGET (R2),(R3),EDIT,WAIT,MF=L                                  07108
*  ALL PARMS                                                            07109
         TGET ,(R3),EDIT                                                07110
         TGET ,(R3),,WAIT                                               07111
         TGET ,(R3),,,MF=L                                              07112
* ALL (R3) + 1 PARM                                                     07113
         TGET ,(R3),EDIT,WAIT                                           07114
         TGET ,(R3),=EDIT,,MF=L                                         07115
* ALL (R3) + 2 PARMS                                                    07116
         TGET ,(R3),EDIT,WAIT,MF=L                                      07117
* ALL (R3) + ALL PARMS BUT (R2)                                         07118
         TGET ,,EDIT,WAIT                                               07119
         TGET ,,EDIT,MF=L                                               07120
         TGET ,,EDIT,WAIT,MF=L                                          07121
* ALL REST OF EDIT COMBINATIONS                                         07122
         TGET ,,,WAIT,MF=L                                              07123
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07124
         TGET (2)                                                       07125
         TGET ,(R3)                                                     07126
         TGET ,,EDIT                                                    07127
         TGET ,,,WAIT                                                   07128
         TGET ,,,,MF=L                                                  07129
*        ALL SINGLE PARMS                                               07130
         TGET (2),(R3)                                                  07131
         TGET (2),,EDIT                                                 07132
         TGET (2),,,WAIT                                                07133
         TGET (2),,,,MF=L                                               07134
*        ALL (2) + 1 PARM                                               07135
         TGET (2),(R3),EDIT                                             07136
         TGET (2),(R3),,WAIT                                            07137
         TGET (2),(R3),,,MF=L                                           07138
* ALL (2) + 2 PARMS                                                     07139
         TGET (2),(R3),EDIT,WAIT                                        07140
         TGET (2),(R3),EDIT,,MF=L                                       07141
*        ALL (2) +3 PARMS                                               07142
         TGET (2),(R3),EDIT,WAIT,MF=L                                   07143
*  ALL PARMS                                                            07144
         TGET ,(R3),EDIT                                                07145
         TGET ,(R3),,WAIT                                               07146
         TGET ,(R3),,,MF=L                                              07147
* ALL (R3) + 1 PARM                                                     07148
         TGET ,(R3),EDIT,WAIT                                           07149
         TGET ,(R3),=EDIT,,MF=L                                         07150
* ALL (R3) + 2 PARMS                                                    07151
         TGET ,(R3),EDIT,WAIT,MF=L                                      07152
* ALL (R3) + ALL PARMS BUT (2)                                          07153
         TGET ,,EDIT,WAIT                                               07154
         TGET ,,EDIT,MF=L                                               07155
         TGET ,,EDIT,WAIT,MF=L                                          07156
* ALL REST OF EDIT COMBINATIONS                                         07157
         TGET ,,,WAIT,MF=L                                              07158
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07159
         TGET 12(2)                                                     07160
         TGET ,(R3)                                                     07161
         TGET ,,EDIT                                                    07162
         TGET ,,,WAIT                                                   07163
         TGET ,,,,MF=L                                                  07164
*        ALL SINGLE PARMS                                               07165
         TGET 12(2),(R3)                                                07166
         TGET 12(2),,EDIT                                               07167
         TGET 12(2),,,WAIT                                              07168
         TGET 12(2),,,,MF=L                                             07169
*        ALL 12(2) + 1 PARM                                             07170
         TGET 12(2),(R3),EDIT                                           07171
         TGET 12(2),(R3),,WAIT                                          07172
         TGET 12(2),(R3),,,MF=L                                         07173
* ALL 12(2) + 2 PARMS                                                   07174
         TGET 12(2),(R3),EDIT,WAIT                                      07175
         TGET 12(2),(R3),EDIT,,MF=L                                     07176
*        ALL 12(2) +3 PARMS                                             07177
         TGET 12(2),(R3),EDIT,WAIT,MF=L                                 07178
*  ALL PARMS                                                            07179
         TGET ,(R3),EDIT                                                07180
         TGET ,(R3),,WAIT                                               07181
         TGET ,(R3),,,MF=L                                              07182
* ALL (R3) + 1 PARM                                                     07183
         TGET ,(R3),EDIT,WAIT                                           07184
         TGET ,(R3),=EDIT,,MF=L                                         07185
* ALL (R3) + 2 PARMS                                                    07186
         TGET ,(R3),EDIT,WAIT,MF=L                                      07187
* ALL (R3) + ALL PARMS BUT 12(2)                                        07188
         TGET ,,EDIT,WAIT                                               07189
         TGET ,,EDIT,MF=L                                               07190
         TGET ,,EDIT,WAIT,MF=L                                          07191
* ALL REST OF EDIT COMBINATIONS                                         07192
         TGET ,,,WAIT,MF=L                                              07193
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07194
         TGET BUFFER                                                    07195
         TGET ,(3)                                                      07196
         TGET ,,EDIT                                                    07197
         TGET ,,,WAIT                                                   07198
         TGET ,,,,MF=L                                                  07199
*        ALL SINGLE PARMS                                               07200
         TGET BUFFER,(3)                                                07201
         TGET BUFFER,,EDIT                                              07202
         TGET BUFFER,,,WAIT                                             07203
         TGET BUFFER,,,,MF=L                                            07204
*        ALL BUFFER + 1 PARM                                            07205
         TGET BUFFER,(3),EDIT                                           07206
         TGET BUFFER,(3),,WAIT                                          07207
         TGET BUFFER,(3),,,MF=L                                         07208
* ALL BUFFER + 2 PARMS                                                  07209
         TGET BUFFER,(3),EDIT,WAIT                                      07210
         TGET BUFFER,(3),EDIT,,MF=L                                     07211
*        ALL BUFFER +3 PARMS                                            07212
         TGET BUFFER,(3),EDIT,WAIT,MF=L                                 07213
*  ALL PARMS                                                            07214
         TGET ,(3),EDIT                                                 07215
         TGET ,(3),,WAIT                                                07216
         TGET ,(3),,,MF=L                                               07217
* ALL (3) + 1 PARM                                                      07218
         TGET ,(3),EDIT,WAIT                                            07219
         TGET ,(3),=EDIT,,MF=L                                          07220
* ALL (3) + 2 PARMS                                                     07221
         TGET ,(3),EDIT,WAIT,MF=L                                       07222
* ALL (3) + ALL PARMS BUT BUFFER                                        07223
         TGET ,,EDIT,WAIT                                               07224
         TGET ,,EDIT,MF=L                                               07225
         TGET ,,EDIT,WAIT,MF=L                                          07226
* ALL REST OF EDIT COMBINATIONS                                         07227
         TGET ,,,WAIT,MF=L                                              07228
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07229
         TGET (R2)                                                      07230
         TGET ,(3)                                                      07231
         TGET ,,EDIT                                                    07232
         TGET ,,,WAIT                                                   07233
         TGET ,,,,MF=L                                                  07234
*        ALL SINGLE PARMS                                               07235
         TGET (R2),(3)                                                  07236
         TGET (R2),,EDIT                                                07237
         TGET (R2),,,WAIT                                               07238
         TGET (R2),,,,MF=L                                              07239
*        ALL (R2) + 1 PARM                                              07240
         TGET (R2),(3),EDIT                                             07241
         TGET (R2),(3),,WAIT                                            07242
         TGET (R2),(3),,,MF=L                                           07243
* ALL (R2) + 2 PARMS                                                    07244
         TGET (R2),(3),EDIT,WAIT                                        07245
         TGET (R2),(3),EDIT,,MF=L                                       07246
*        ALL (R2) +3 PARMS                                              07247
         TGET (R2),(3),EDIT,WAIT,MF=L                                   07248
*  ALL PARMS                                                            07249
         TGET ,(3),EDIT                                                 07250
         TGET ,(3),,WAIT                                                07251
         TGET ,(3),,,MF=L                                               07252
* ALL (3) + 1 PARM                                                      07253
         TGET ,(3),EDIT,WAIT                                            07254
         TGET ,(3),=EDIT,,MF=L                                          07255
* ALL (3) + 2 PARMS                                                     07256
         TGET ,(3),EDIT,WAIT,MF=L                                       07257
* ALL (3) + ALL PARMS BUT (R2)                                          07258
         TGET ,,EDIT,WAIT                                               07259
         TGET ,,EDIT,MF=L                                               07260
         TGET ,,EDIT,WAIT,MF=L                                          07261
* ALL REST OF EDIT COMBINATIONS                                         07262
         TGET ,,,WAIT,MF=L                                              07263
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07264
         TGET (2)                                                       07265
         TGET ,(3)                                                      07266
         TGET ,,EDIT                                                    07267
         TGET ,,,WAIT                                                   07268
         TGET ,,,,MF=L                                                  07269
*        ALL SINGLE PARMS                                               07270
         TGET (2),(3)                                                   07271
         TGET (2),,EDIT                                                 07272
         TGET (2),,,WAIT                                                07273
         TGET (2),,,,MF=L                                               07274
*        ALL (2) + 1 PARM                                               07275
         TGET (2),(3),EDIT                                              07276
         TGET (2),(3),,WAIT                                             07277
         TGET (2),(3),,,MF=L                                            07278
* ALL (2) + 2 PARMS                                                     07279
         TGET (2),(3),EDIT,WAIT                                         07280
         TGET (2),(3),EDIT,,MF=L                                        07281
*        ALL (2) +3 PARMS                                               07282
         TGET (2),(3),EDIT,WAIT,MF=L                                    07283
*  ALL PARMS                                                            07284
         TGET ,(3),EDIT                                                 07285
         TGET ,(3),,WAIT                                                07286
         TGET ,(3),,,MF=L                                               07287
* ALL (3) + 1 PARM                                                      07288
         TGET ,(3),EDIT,WAIT                                            07289
         TGET ,(3),=EDIT,,MF=L                                          07290
* ALL (3) + 2 PARMS                                                     07291
         TGET ,(3),EDIT,WAIT,MF=L                                       07292
* ALL (3) + ALL PARMS BUT (2)                                           07293
         TGET ,,EDIT,WAIT                                               07294
         TGET ,,EDIT,MF=L                                               07295
         TGET ,,EDIT,WAIT,MF=L                                          07296
* ALL REST OF EDIT COMBINATIONS                                         07297
         TGET ,,,WAIT,MF=L                                              07298
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07299
         TGET 12(2)                                                     07300
         TGET ,(3)                                                      07301
         TGET ,,EDIT                                                    07302
         TGET ,,,WAIT                                                   07303
         TGET ,,,,MF=L                                                  07304
*        ALL SINGLE PARMS                                               07305
         TGET 12(2),(3)                                                 07306
         TGET 12(2),,EDIT                                               07307
         TGET 12(2),,,WAIT                                              07308
         TGET 12(2),,,,MF=L                                             07309
*        ALL 12(2) + 1 PARM                                             07310
         TGET 12(2),(3),EDIT                                            07311
         TGET 12(2),(3),,WAIT                                           07312
         TGET 12(2),(3),,,MF=L                                          07313
* ALL 12(2) + 2 PARMS                                                   07314
         TGET 12(2),(3),EDIT,WAIT                                       07315
         TGET 12(2),(3),EDIT,,MF=L                                      07316
*        ALL 12(2) +3 PARMS                                             07317
         TGET 12(2),(3),EDIT,WAIT,MF=L                                  07318
*  ALL PARMS                                                            07319
         TGET ,(3),EDIT                                                 07320
         TGET ,(3),,WAIT                                                07321
         TGET ,(3),,,MF=L                                               07322
* ALL (3) + 1 PARM                                                      07323
         TGET ,(3),EDIT,WAIT                                            07324
         TGET ,(3),=EDIT,,MF=L                                          07325
* ALL (3) + 2 PARMS                                                     07326
         TGET ,(3),EDIT,WAIT,MF=L                                       07327
* ALL (3) + ALL PARMS BUT 12(2)                                         07328
         TGET ,,EDIT,WAIT                                               07329
         TGET ,,EDIT,MF=L                                               07330
         TGET ,,EDIT,WAIT,MF=L                                          07331
* ALL REST OF EDIT COMBINATIONS                                         07332
         TGET ,,,WAIT,MF=L                                              07333
* ALL POSSIBLE COMBINATIONS OF OPERANDS?                                07334
         END                                                            07335
./ ADD NAME=TTPUT
         MACRO                                                          07337
&NAME    TPUT  &BFF,&SIZE,&EDIT,&WAIT,&HOLD,&BRKI,&PRTY,&TJID=,        *07338
               &TJIDLOC=,&ASID=,&ASIDLOC=,&USERIDL=,&MF=       @G76XRYU 07339
.* THIS VERSION IS FROM PTF UZ29403 PUT IN THIS PDS BY CBT              07340
.* A000000-999999                                              @G76XR00 07341
.* A770501,896051,896076,896158,896167,960000                  @OZ43223 07342
.* C896050,896054,896063-896064,896075,896089,896157,896159,   @OZ43223 07343
.* C896166,896168                                              @OZ43223 07344
.* D896058-896062,896083-896087                                @OZ43223 07345
.*                                                                      07346
         LCLA  &FLAGON,&FLAGOFF,&FLAGS2,&OPT,&NTJ,&RET         @G76XRYU 07347
         LCLB  &E,&W,&H,&B,&P,&OLDBUFF                         @G76XRYU 07348
         LCLC  &TSID,&TSIDLOC,&PARM,&NDX,&ID                   @G76XRYU 07349
&NDX     SETC  '&SYSNDX'                                       @G76XRYU 07350
         AIF   (N'&SYSLIST LE 7).POSOPOK .IF TOO MANY OPERANDS @G76XRYU 07351
         MNOTE 12,'IHB300 EXCESSIVE POSITIONAL OPERANDS SPECIFIED'      07352
         MEXIT                                                 @G76XRYU 07353
.POSOPOK ANOP                         ..POSITIONAL OPERANDS OK @G76XRYU 07354
         AIF   ('&MF' EQ '').FORMOK     NON-EXTENDED FORM OK   @G76XRYU 07355
         AIF   ('&MF' EQ 'I' OR '&MF' EQ 'L' OR ('&MF(1)' EQ 'E' AND N'*07356
               &MF EQ 2)).FORMOK     ...FORMAT OPERANDS OK...  @G76XRYU 07357
         MNOTE 12,'IHB303 INVALID OPERAND MF=&MF '             @G76XRYU 07358
         MEXIT                                                 @G76XRYU 07359
.FORMOK  ANOP                                                  @G76XRYU 07360
         AIF   (('&BFF' EQ '' OR '&SIZE' EQ '') AND '&MF' EQ '').ERROR1 07361
         AIF   ('&SIZE' EQ '' AND '&MF' EQ 'I').SIZERR         @G76XRYU 07362
         AIF   ('&BFF' NE '' OR '&MF' NE 'I').BFFEXOK          @G76XRYU 07363
         MNOTE 12,'IHB300 BUFFER ADDRESS NOT SPECIFIED'        @G76XRYU 07364
         MEXIT                                                 @G76XRYU 07365
.BFFEXOK ANOP              ...BUFFER ADDR GIVEN W/ MF=I,E,L    @G76XRYU 07366
&ID      SETC  '0'                                             @G76XRYU 07367
&FLAGOFF SETA  127                   ...SET FOR AND OPERATION  @G76XRYU 07368
&NTJ     SETA  N'&TJID+N'&TJIDLOC+N'&ASID+N'&ASIDLOC+N'&USERIDL         07369
         AIF   (&NTJ GT 1).ERROR2                                       07370
         AIF   (&NTJ EQ 0).KEEPID    ..IF ANY ID SPECIFIED ..  @G76XRYU 07371
&FLAGOFF SETA  &FLAGOFF-64            ..INSURE USER ID FLAG    @G76XRYU 07372
.*                                      TURNED OFF FOR EX FORM @G76XRYU 07373
.KEEPID  ANOP                        ..ELSE RETAIN PRESENT SET @G76XRYU 07374
&TSID    SETC  '&ASID&TJID'                                             07375
&TSIDLOC SETC  '&ASIDLOC&TJIDLOC'                                       07376
         AIF   ('&EDIT' EQ 'R').RF      CHECK FOR R FORM                07377
&PARM    SETC  '&EDIT'                                                  07378
         AIF   ('&USERIDL' EQ '').CKPARM                                07379
&OPT     SETA  X'40'                    DENOTE USERID SPECIFIED         07380
&FLAGON  SETA  &FLAGON+64               TO OR USER ID FLAG     @G76XRYU 07381
.CKPARM  ANOP                                                           07382
&RET     SETA  &RET+1                                                   07383
         AIF   ('&PARM' EQ '').RET           NULL, TRY NEXT             07384
         AIF   ('&PARM' EQ 'EDIT').EDI       SET EDIT                   07385
         AIF   ('&PARM' EQ 'ASIS').ASI       SET ASIS                   07386
         AIF   ('&PARM' EQ 'CONTROL').CON    SET CONTROL                07387
         AIF   ('&PARM' EQ 'FULLSCR').FULLS  SET FULL SCREEN    SA60002 07388
         AIF   ('&PARM' EQ 'NOEDIT').NOED    SET NO EDIT MODE  @G76XRYU 07389
         AIF   ('&PARM' EQ 'WAIT').WAI       SET WAIT                   07390
         AIF   ('&PARM' EQ 'NOWAIT').NOW     SET NOWAIT                 07391
         AIF   ('&PARM' EQ 'HOLD').HOL       SET HOLD                   07392
         AIF   ('&PARM' EQ 'NOHOLD').NOH     SET NOHOLD                 07393
         AIF   ('&PARM' EQ 'NOBREAK').NOB    SET NOBREAK                07394
         AIF   ('&PARM' EQ 'BREAKIN').BRE    SET BREAKIN                07395
         AIF   ('&PARM' EQ 'HIGHP').HPR      SET HIGHP                  07396
         AIF   ('&PARM' EQ 'LOWP').LPR       SET LOWP                   07397
         AGO   .ERROR3                                                  07398
.EDI     ANOP                                                           07399
         AIF   (&E).ERROR2              DUP OPTION                      07400
&E       SETB  1                        EDIT OPTION SPECFIED            07401
&FLAGOFF SETA  &FLAGOFF-3               EDIT FOR EXECUTE FORM  @G76XRYU 07402
         AGO   .EDDONE                                         @G76XRYU 07403
.ASI     ANOP                                                           07404
         AIF   (&E).ERROR2              DUP OPTION                      07405
&E       SETB  1                        EDIT OPTION SPECFIED            07406
&FLAGOFF SETA  &FLAGOFF-2               1ST BIT OF ASIS FOR EX @G76XRYU 07407
&FLAGON  SETA  &FLAGON+1                2ND BIT OF ASIS FOR EX @G76XRYU 07408
&OPT     SETA  &OPT+1                   SET EDIT=ASIS                   07409
         AGO   .EDDONE                                         @G76XRYU 07410
.CON     ANOP                                                           07411
         AIF   (&E).ERROR2              DUP OPTION                      07412
&E       SETB  1                        EDIT OPTION SPECFIED            07413
&OPT     SETA  &OPT+2                   SET EDIT=CONTROL                07414
&FLAGOFF SETA  &FLAGOFF-1               1ST BIT OF CNTR FOR EX @G76XRYU 07415
&FLAGON  SETA  &FLAGON+2                2ND BIT OF CNTR FOR EX @G76XRYU 07416
         AGO   .EDDONE                                         @G76XRYU 07417
.FULLS   ANOP                                                   SA60002 07418
         AIF   (&E).ERROR2              DUP OPTION              SA60002 07419
&E       SETB  1                        EDIT OPTION SPECIFIED   SA60002 07420
&OPT     SETA  &OPT+3                   CNTL+ASIS FOR FULLSCR   SA60002 07421
&FLAGON  SETA  &FLAGON+3                SET FULLSCREEN FOR EX  @G76XRYU 07422
         AGO   .EDDONE                                         @G76XRYU 07423
.NOED    ANOP                                                  @G76XRYU 07424
         AIF   (&E).ERROR2              DUP OPTION             @G76XRYU 07425
         AIF   (&NTJ EQ 1).ASIDERR      CAN'T SAY NOEDIT & ASID@OZ43223 07426
&E       SETB  1                                               @G76XRYU 07427
&OPT     SETA  &OPT+3                   FLAGS1 TO FULLSCR STAN @G76XRYU 07428
&FLAGS2  SETA  1                        SET FLAGS2 TO NOEDIT   @G76XRYU 07429
&FLAGON  SETA  &FLAGON+3                FLAGS1 TO FULLSCR EXEC @G76XRYU 07430
.EDDONE  ANOP                      EDIT OPERAND IN RIGHT PLACE @G76XRYU 07431
         AIF   (&RET NE 1).BADPOS  ..IF NOT IN 3RD POS-WARNING @G76XRYU 07432
         AGO   .RET                ..ELSE OK                   @G76XRYU 07433
.WAI     ANOP                                                           07434
         AIF   (&W).ERROR2              DUP OPTION                      07435
&W       SETB  1                        WAIT OPTION SPECIFIED           07436
&FLAGOFF SETA  &FLAGOFF-16              SET WAIT OPTION IN EX  @G76XRYU 07437
         AGO   .WAIDONE                 CHECK POSITION         @G76XRYU 07438
.NOW     ANOP                                                           07439
         AIF   (&W).ERROR2              DUP OPTION                      07440
&W       SETB  1                        WAIT OPTION SPECIFIED           07441
&OPT     SETA  &OPT+X'10'               SET WAIT=NOWAIT                 07442
&FLAGON  SETA  &FLAGON+16               SET FOR NOWAIT IN EXEC @G76XRYU 07443
.WAIDONE ANOP                       ..WAIT IN RIGHT POSITION   @G76XRYU 07444
         AIF   (&RET NE 2).BADPOS   ..IF NOT 4TH, WARNING      @G76XRYU 07445
         AGO   .RET                 ..ELSE OK                  @G76XRYU 07446
.HOL     ANOP                                                           07447
         AIF   (&H).ERROR2              DUP OPTION                      07448
&H       SETB  1                        HOLD OPTION SPECIFIED           07449
&OPT     SETA  &OPT+X'08'               SET HOLD=HOLD                   07450
&FLAGON  SETA  &FLAGON+8                SET FOR HOLD IN EXEC   @G76XRYU 07451
         AGO   .HOLDONE                 CHECK POSITION         @G76XRYU 07452
.NOH     ANOP                                                           07453
         AIF   (&H).ERROR2              DUP OPTION                      07454
&H       SETB  1                        NOHOLD OPTION SPECIFIED         07455
&FLAGOFF SETA  &FLAGOFF-8               SET FOR NOHOLD IN EXEC @G76XRYU 07456
.HOLDONE ANOP                        ..CHECK HOLD POSITION     @G76XRYU 07457
         AIF   (&RET NE 3).BADPOS    ..IF ^ 5TH OPER, WARNING  @G76XRYU 07458
         AGO   .RET                  ..ELSE OK                 @G76XRYU 07459
.BRE     ANOP                                                           07460
         AIF   (&B).ERROR2              DUP OPTION                      07461
&B       SETB  1                        BREAK OPTION SPECIFIED          07462
&OPT     SETA  &OPT+X'04'               SET BREAKIN                     07463
&FLAGON  SETA  &FLAGON+4                SET BREAKIN IN EXEC    @G76XRYU 07464
         AGO   .BRDONE                  CHECK BREAK POSITION   @G76XRYU 07465
.NOB     ANOP                                                           07466
         AIF   (&B).ERROR2              DUP OPTION                      07467
&B       SETB  1                        BREAK OPTION SPECIFIED          07468
&FLAGOFF SETA  &FLAGOFF-4               SET NOBREAK OPTION EX  @G76XRYU 07469
.BRDONE  ANOP                           CHECK BREAK POSITION   @G76XRYU 07470
         AIF   (&RET NE 4).BADPOS    ..IF NOT THE 6TH OPERAND  @G76XRYU 07471
         AGO   .RET                  ..ELSE OK                 @G76XRYU 07472
.HPR     ANOP                                                           07473
         AIF   (&P).ERROR2              DUP OPTION                      07474
&P       SETB  1                        PRIORITY OPTION SPECIFIED       07475
&FLAGOFF SETA  &FLAGOFF-32              SET HI PRIO OPTION EX  @G76XRYU 07476
         AGO   .PRDONE                  CHECK POSITION         @G76XRYU 07477
.LPR     ANOP                                                           07478
         AIF   (&P).ERROR2              DUP OPTION                      07479
&P       SETB  1                        PRIORITY OPTION SPECIFIED       07480
&OPT     SETA  &OPT+X'20'               SET  LOW PRIORITY OPTION        07481
&FLAGON  SETA  &FLAGON+32               SET LOW PRI OPTION EX  @G76XRYU 07482
.PRDONE  ANOP                     ..CHECK PRIORITY OPERAND POS @G76XRYU 07483
         AIF   (&RET NE 5).BADPOS   ..IF ^7TH OPERAND,WARNING  @G76XRYU 07484
         AGO   .RET                 ..ELSE OK                  @G76XRYU 07485
.BADPOS  ANOP             ..ISSUE WARNING IF OPERAND MISPLACED @G76XRYU 07486
         MNOTE 4,'IHB300 WARNING: &PARM POSITIONAL PARAMETER MISPLACED' 07487
.RET     ANOP                                                           07488
&PARM    SETC  '&WAIT'                                                  07489
         AIF   ('&RET' EQ '1').CKPARM   CHECK WAIT                      07490
&PARM    SETC  '&HOLD'                                                  07491
         AIF   ('&RET' EQ '2').CKPARM   CHECK HOLD                      07492
&PARM    SETC  '&BRKI'                                                  07493
         AIF   ('&RET' EQ '3').CKPARM   CHECK BRKI                      07494
&PARM    SETC  '&PRTY'                                                  07495
         AIF   ('&RET' EQ '4').CKPARM   CHECK PRTY                      07496
.*  PARAMETERS PROCESSED                                       @G76XRYU 07497
         AIF   ('&MF' EQ '' AND &FLAGS2 EQ 0).OLD NON-EXTENDED @G76XRYU 07498
         AIF   ('&MF' EQ 'L').LFORM       ...LIST EXPANSION... @G76XRYU 07499
         AIF   ('&MF' EQ 'I' OR '&MF' EQ '').STFORM .ST. FORM. @G76XRYU 07500
.******************                                            @G76XRYU 07501
.*  EXECUTE FORM  *                                            @G76XRYU 07502
.******************                                            @G76XRYU 07503
&NAME    CNOP  0,4                          TPUT EXECUTE FORM  @G76XRYU 07504
         AIF   ('&MF(2)'(1,1) EQ '(').MFREG  IF IN RX FORM  .. @G76XRYU 07505
         LA    1,&MF(2)                     R1=>USER PARM LIST @G76XRYU 07506
         AGO   .GOTPARM                                        @G76XRYU 07507
.MFREG   ANOP                             .. ELSE, IN A REG .. @G76XRYU 07508
         AIF   ('&MF(2)' EQ '(1)').GOTPARM ..IF NOT REG 1..    @G76XRYU 07509
         LR    1,&MF(2)                     POINT R1 AT PARMS  @G76XRYU 07510
.GOTPARM ANOP                                                  @G76XRYU 07511
         AIF   (&FLAGOFF EQ 127).SKIPAND ..TURN OFF ANY FLAGS? @G76XRYU 07512
         NI    4(1),&FLAGOFF                RESET FLAGS 1      @G76XRYU 07513
.SKIPAND ANOP                      ..CHECK FOR FLAGS TURNED ON @G76XRYU 07514
         AIF   (&FLAGON EQ 0).NOSET  ..TURN ON ANY FLAGS?      @G76XRYU 07515
         OI    4(1),&FLAGON                 IN EXEC PARM LIST  @G76XRYU 07516
.NOSET   ANOP                                                  @G76XRYU 07517
         AIF   (&FLAGS2 EQ 0 AND NOT &E).NOFLAG2 ..IF NEW EDIT @G76XRYU 07518
         MVI   12(1),&FLAGS2                RESET FLAGS2       @G76XRYU 07519
.NOFLAG2 ANOP                                                  @G76XRYU 07520
         AGO   .PARMCHK                 ..END UNIQUE E CODE..  @G76XRYU 07521
.****************************                                  @G76XRYU 07522
.*  STANDARD EXTENDED FORM  *                                  @G76XRYU 07523
.****************************                                  @G76XRYU 07524
.STFORM  ANOP                   ..STANDARD EXTENDED FORM CODE. @G76XRYU 07525
&NAME    CNOP  0,4                          STANDARD EXTENDED  @G76XRYU 07526
         AIF   ('&BFF' NE '(1)').NOTOLD  .IF OLD STANDARD FORM @G76XRYU 07527
         STCM  1,B'0111',*+13               OLD SUPPORT ONLY   @G76XRYU 07528
&OLDBUFF SETB  1                         .FLAG OLD BUFF ADDR.. @G76XRYU 07529
.NOTOLD  ANOP                                                  @G76XRYU 07530
         BAL   1,*+20                       BRANCH AROUND PARM @G76XRYU 07531
TPUT&NDX DS    0H                           TPUT EXTENDED PARM @G76XRYU 07532
         DC    H'0'                         ADDR SPACE ID      @G76XRYU 07533
         DC    H'0'                         OUTPUT BUFFER SIZE @G76XRYU 07534
         DC    AL1(&OPT)                    FLAGS 1            @G76XRYU 07535
         DC    AL3(0)                       OUTPUT BUFFER ADDR @G76XRYU 07536
         DC    A(0)                         ADDRESS OF USER ID @G76XRYU 07537
         DC    AL1(&FLAGS2)                 FLAGS 2            @G76XRYU 07538
         DC    AL3(0)                       RESERVED BYTES     @G76XRYU 07539
.************************************************              @G76XRYU 07540
.*  COMMON CODE FOR STANDARD AND EXECUTE FORMS  *              @G76XRYU 07541
.************************************************              @G76XRYU 07542
.PARMCHK ANOP                           ..GET PARMS FOR E & I  @G76XRYU 07543
         AIF   ('&SIZE' EQ '').CKID     ...IF BUFF SIZE GIVEN. @G76XRYU 07544
         AIF   ('&SIZE'(1,1) EQ '(').SIZEREG  ...IF AN INTEGER @G76XRYU 07545
         AIF   (T'&SIZE NE 'N').SIZEQU  IF AN EQUATE           @OZ43223 07546
         AIF   (&SIZE GT 32767).SIZERR          .NOT > 32767.. @G76XRYU 07547
.SIZEQU  ANOP                                                  @OZ43223 07548
         AIF   ('&MF' NE 'I' AND '&MF' NE '').SIZEEX .STANDARD @G76XRYU 07549
         ORG   TPUT&NDX+2                   PUT SIZE VALUE     @G76XRYU 07550
         DC    AL2(&SIZE)                   IN PARM LIST       @OZ43223 07551
         ORG                                                            07552
         AGO   .CKID                                           @G76XRYU 07553
.SIZEEX  ANOP                         ..IF EXECUTE             @G76XRYU 07554
         B     *+6                          BR PAST SIZE VALUE @OZ43223 07555
         DC    AL2(&SIZE)                   BUFSIZE            @OZ43223 07556
         LH    0,*-2                        GET THE SIZE VALUE @G76XRYU 07557
         STH   0,2(1)                       INTO THE PARM LIST @G76XRYU 07558
         AGO   .CKID                                           @G76XRYU 07559
.SIZEREG ANOP                                 ...ELSE A REG .. @G76XRYU 07560
         STH   &SIZE(1),2(1)                PUT SIZE IN PARM   @G76XRYU 07561
.CKID    ANOP                           ... CHECK IDS ...      @G76XRYU 07562
         AIF   (&NTJ EQ 0).CKADDR       ..IF THERE IS AN ID..  @G76XRYU 07563
         AIF   ('&TSID' EQ '').CKIDLOC  ..IF AN ASID # GIVEN.. @G76XRYU 07564
         AIF   ('&TSID'(1,1) EQ '(').ASIDREG  ..IF AN INTEGER. @G76XRYU 07565
         AIF   ((T'&ASID NE 'N' AND T'&TJID EQ 'O') OR (T'&TJID NE 'N' X07566
               AND T'&ASID EQ 'O')).IDEQU                      @OZ43223 07567
         AIF   (&TSID GT 32767).IDERROR         .NOT > 32767.. @G76XRYU 07568
.IDEQU   ANOP                                                  @OZ43223 07569
         AIF   ('&MF' NE 'I' AND '&MF' NE '').IDEX ..STANDARD  @G76XRYU 07570
         ORG   TPUT&NDX                     PUT ASID VALUE     @G76XRYU 07571
         DC    AL2(&TSID)                   IN PARM LIST       @G76XRYU 07572
         ORG                                                            07573
         AGO   .CKADDR                                         @G76XRYU 07574
.IDEX    ANOP                               IF EXECUTE         @G76XRYU 07575
         B     *+6                          GET AROUND ID #    @G76XRYU 07576
         DC    AL2(&TSID)                   PUT ID # HERE      @OZ43223 07577
         LH    0,*-2                        STORE ASID # IN    @G76XRYU 07578
         STH   0,0(1)                       PARAMETER LIST     @G76XRYU 07579
         AGO   .CKADDR                                         @G76XRYU 07580
.ASIDREG ANOP                           .. ELSE ASID IN A REG. @G76XRYU 07581
         STH   &TSID,0(1)                   STORE REG IN PARM  @G76XRYU 07582
         AGO   .CKADDR                                         @G76XRYU 07583
.CKIDLOC ANOP                           .. ELSE ID AT AN ADDR  @G76XRYU 07584
.*                                            (ASIDLOC)        @G76XRYU 07585
         AIF   ('&TSIDLOC' EQ '').CKUSER ..IF AN ADDRESS GIVEN @G76XRYU 07586
         AIF   ('&TSIDLOC'(1,1) EQ '(').LOCIDRG  ..IF RX ADDR. @G76XRYU 07587
         MVC   0(2,1),&TSIDLOC              MOVE ID INTO PARMS @G76XRYU 07588
         AGO   .CKADDR                                         @G76XRYU 07589
.LOCIDRG ANOP                           .. ELSE ID ADDR IN REG @G76XRYU 07590
         MVC   0(2,1),0&TSIDLOC             MOVE ID INTO PARMS @G76XRYU 07591
         AGO   .CKADDR                                         @G76XRYU 07592
.CKUSER  ANOP                           ..ELSE A USER ID GIVEN @G76XRYU 07593
         AIF   ('&USERIDL'(1,1) EQ '(').USEREG ..IF RX ADDR..  @G76XRYU 07594
         AIF   ('&USERIDL'(K'&USERIDL,1) EQ ')' OR ('&MF' NE 'I' AND '&*07595
               MF' NE '')).USERX         ..IF STANDARD FORM    @G76XRYU 07596
         ORG   TPUT&NDX+8                   PUT USER ID ADDR   @G76XRYU 07597
         DC    A(&USERIDL)                  IN PARM LIST       @G76XRYU 07598
         ORG                                                            07599
         AGO   .CKADDR                                         @G76XRYU 07600
.USERX   ANOP                         ..IF EXECUTE OR LA ADDR  @G76XRYU 07601
         LA    0,&USERIDL                   GET USER ID ADDR   @G76XRYU 07602
         ST    0,8(1)                       INTO THE PARM LIST @G76XRYU 07603
         AGO   .CKADDR                                         @G76XRYU 07604
.USEREG  ANOP                           ...      ELSE A REG .. @G76XRYU 07605
         ST    &USERIDL(1),8(1)             PUT ID IN PARM     @G76XRYU 07606
.CKADDR  ANOP                           ..GET OUT BUFFER ADDR  @G76XRYU 07607
         AIF   (&OLDBUFF).FINISH        ..IF OLD FORM,COMPLETE @G76XRYU 07608
         AIF   ('&BFF' EQ '').FINISH    ..IF BUFFER ADDR GIVEN @G76XRYU 07609
         AIF   ('&BFF'(1,1) EQ '(').BFFREG  ..IF AN RX ADDR... @G76XRYU 07610
         AIF   ('&BFF'(K'&BFF,1) EQ ')' OR ('&MF' NE 'I' AND '&MF' NE '*07611
               ')).BFFRX                 ..AND STANDARD FORM   @G76XRYU 07612
         ORG   TPUT&NDX+5                   PUT BUFFER ADDRESS @G76XRYU 07613
         DC    AL3(&BFF)                    IN PARM LIST       @G76XRYU 07614
         ORG                                                            07615
         AGO   .FINISH                                         @G76XRYU 07616
.BFFRX   ANOP                      ..IF EXECUTE OR LA TYPE..   @G76XRYU 07617
         LA    0,&BFF                       GET ADDR OF BUFFER @G76XRYU 07618
         STCM  0,B'0111',5(1)               PUT IN PARM LIST   @G76XRYU 07619
         AGO   .FINISH                                         @G76XRYU 07620
.BFFREG  ANOP                               ..ELSE IN A REG .. @G76XRYU 07621
         STCM  &BFF(1),B'0111',5(1)         STORE BUFFER ADDR  @G76XRYU 07622
.FINISH  ANOP                                                  @G76XRYU 07623
         OI    12(1),128                    SET HI BIT OF PARM @G76XRYU 07624
         ICM   0,B'1000',*-3                SET HI BIT OF R0   @G76XRYU 07625
.*                                        FROM 128 IN OI INSTR @G76XRYU 07626
.SVCNEW  ANOP                           .. ISSUE SVC HERE ...  @G76XRYU 07627
         SVC   93                           SVC TO MSG ROUTER  @G76XRYU 07628
         MEXIT                                                 @G76XRYU 07629
.**********************                                        @G76XRYU 07630
.*  LIST FORM CODE    *                                        @G76XRYU 07631
.**********************                                        @G76XRYU 07632
.LFORM   ANOP                                                  @G76XRYU 07633
         AIF   ('&TSIDLOC' EQ '').IDLOCOK ..IF L FORM INVALID. @G76XRYU 07634
         MNOTE 12,'IHB300 INCOMPATIBLE OPERANDS: MF=L, ASIDLOC'         07635
         MEXIT                                                 @G76XRYU 07636
.IDLOCOK ANOP                           ..ASIDLOC OPERAND NULL @G76XRYU 07637
&NAME    DS    0F                           L-FORM PARM LIST   @G76XRYU 07638
         AIF   ('&TSID' NE '').LSTID    ..IF NO TSID GIVEN..   @G76XRYU 07639
         DC    H'0'                         ASID HALFWORD      @G76XRYU 07640
         AGO   .LBFFSIZ                                        @G76XRYU 07641
.LSTID   ANOP                           ..ELSE TSID SPECIFIED. @G76XRYU 07642
         AIF   ('&TSID'(1,1) EQ '(').REGERR   ..NOT A REGISTER @G76XRYU 07643
         AIF   ((T'&ASID NE 'N' AND T'&TJID EQ 'O') OR (T'&TJID NE 'N' X07644
               AND T'&ASID EQ 'O')).IDEQU0                     @OZ43223 07645
         AIF   (&TSID GT 32767).IDERROR         ..NOT > 32767. @G76XRYU 07646
.IDEQU0  ANOP                                                  @OZ43223 07647
         DC    AL2(&TSID)                   ADDR SPACE VALUE   @OZ43223 07648
.LBFFSIZ ANOP                           .. CHECK BUFFER SIZE . @G76XRYU 07649
         AIF   ('&SIZE' NE '').LSTSIZE  .. IF NO BUFFER SIZE . @G76XRYU 07650
         DC    H'0'                         BUFF SIZE HALFWORD @G76XRYU 07651
         AGO   .LBFADDR                                        @G76XRYU 07652
.LSTSIZE ANOP                           .. ELSE A BUFFER SIZE. @G76XRYU 07653
         AIF   ('&SIZE'(1,1) EQ '(').REGERR   .IF NOT IN A REG @G76XRYU 07654
         AIF   (T'&SIZE NE 'N').SIZEQU0 IF AN EQUATE           @OZ43223 07655
         AIF   (&SIZE GT 32767).SIZERR          .NOT > 32767.. @G76XRYU 07656
.SIZEQU0 ANOP                                                  @OZ43223 07657
         DC    AL2(&SIZE)                   BUFFER SIZE VALUE  @OZ43223 07658
.LBFADDR ANOP                           .. CHECK BUFFER ADDR.. @G76XRYU 07659
         DC    AL1(&OPT)                    FLAGS 1            @G76XRYU 07660
         AIF   ('&BFF' NE '').LBFFLAB   ..IF NO BUFFER ADDR..  @G76XRYU 07661
         DC    AL3(0)                       BUFFER ADDRESS     @G76XRYU 07662
         AGO   .LSTUSER                                        @G76XRYU 07663
.LBFFLAB ANOP                           .. ELSE BUFFER ADDRESS @G76XRYU 07664
         AIF   ('&BFF'(1,1) EQ '(').REGERR  ..IF NOT IN A REG  @G76XRYU 07665
         DC    AL3(&BFF)                    ADDR OUTPUT BUFFER @G76XRYU 07666
.LSTUSER ANOP                                                  @G76XRYU 07667
         AIF   ('&USERIDL' NE '').LUSADDR  ..IF NO USER ID ..  @G76XRYU 07668
         DC    A(0)                         USER ID            @G76XRYU 07669
         AGO   .LISTEND                                        @G76XRYU 07670
.LUSADDR ANOP                              ..ELSE USER ID ...  @G76XRYU 07671
         AIF   ('&USERIDL'(1,1) EQ '(').REGERR  ..IF NOT REG . @G76XRYU 07672
         DC    A(&USERIDL)                  USER ID            @G76XRYU 07673
.LISTEND ANOP                               .. GEN FLAGS2 ..   @G76XRYU 07674
         DC    AL1(&FLAGS2)                 FLAGS 2            @G76XRYU 07675
         DC    AL3(0)                       RESERVED           @G76XRYU 07676
         MEXIT                                                 @G76XRYU 07677
.REGERR  ANOP                              ..REGISTER ERROR..  @G76XRYU 07678
         MNOTE 12,'IHB300 INCOMPATIBLE OPERANDS: MF=L, REGISTER OPERANDX07679
                SPECIFIED'                                     @G76XRYU 07680
         MEXIT                                                 @G76XRYU 07681
.*********************                                         @G76XRYU 07682
.*   REGISTER FORM   *                                         @G76XRYU 07683
.*********************                                         @G76XRYU 07684
.RF      ANOP                                                           07685
         AIF   ('&MF' EQ '').RFNOMF   ..IF MF OPERAND GIVEN... @G76XRYU 07686
         MNOTE 12,'IHB300 INCOMPATIBLE OPERANDS: R, MF'        @G76XRYU 07687
         MEXIT                                                 @G76XRYU 07688
.RFNOMF  ANOP                         ..IF NOEDIT SPECIFIED... @G76XRYU 07689
         AIF   ('&WAIT' NE 'NOEDIT' AND '&HOLD' NE 'NOEDIT' AND '&BRKI'*07690
               NE 'NOEDIT' AND '&PRTY' NE 'NOEDIT').RFNOED     @G76XRYU 07691
         MNOTE 12,'IHB300, INCOMPATIBLE OPERANDS: R, NOEDIT'   @G76XRYU 07692
         MEXIT                                                 @G76XRYU 07693
.RFNOED  ANOP                         CHECK REMAINING OPERANDS @G76XRYU 07694
         AIF   ('&WAIT' NE '' OR '&HOLD' NE '' OR '&BRKI' NE '' OR '&PRX07695
               TY' NE '' OR &NTJ GT 0).RERR                             07696
         AIF   ('&BFF'(1,1) NE '(' OR '&SIZE'(1,1) NE '(').RERR         07697
&NAME    DS    0H                                                       07698
         AIF   ('&BFF' EQ '(1)').SIZE                                   07699
         LR    1,&BFF(1)                LOAD OPTIONS & BUFFER ADDR      07700
.SIZE    AIF   ('&SIZE' EQ '(0)').SVC    ..IF REG 0-ISSUE SVC..         07701
         LR    0,&SIZE(1)               LOAD TJID & BUFFER SIZE         07702
         AGO   .SVC                     ... ISSUE SVC CALL ...          07703
.************                                                  @G76XRYU 07704
.*  MNOTES  *                                                  @G76XRYU 07705
.************                                                  @G76XRYU 07706
.SIZERR  ANOP                      ..SIZE INTEGER NOT 0-32767. @G76XRYU 07707
&PARM    SETC  'SIZE'                ..INDICATE BAD SIZE PARM. @G76XRYU 07708
         AGO   .INTERR                                         @G76XRYU 07709
.IDERROR ANOP                      ..ASID INTEGER NOT 0-32767. @G76XRYU 07710
&PARM    SETC  'ASID'                ..INDICATE BAD ASID PARM. @G76XRYU 07711
.INTERR  MNOTE 12,'IHB300 &PARM NOT IN RANGE 0-32767'          @G76XRYU 07712
         MEXIT                                                 @G76XRYU 07713
.RERR    IHBERMAC 192                                                   07714
         MEXIT                                                          07715
.ERROR1  IHBERMAC 24                                                    07716
         MEXIT                                                          07717
.ERROR2  IHBERMAC 54,,,                                                 07718
         MEXIT                                                          07719
.ERROR3  IHBERMAC 49,,&PARM                                             07720
         MEXIT                                                 @OZ43223 07721
.ASIDERR MNOTE 12,'IHB300 ASID/USERID INVALID WITH NOEDIT'     @OZ43223 07722
         MEXIT                                                 @OZ43223 07723
.***********************                                       @G76XRYU 07724
.*  NON-EXTENDED FORM  *                                       @G76XRYU 07725
.***********************                                       @G76XRYU 07726
.OLD     ANOP            ....NON EXTENDED TPUT EXPANSION       @G76XRYU 07727
         AIF   ('&BFF'(1,1) EQ '(' OR '&SIZE'(1,1) EQ '(').REGFM  REG.  07728
.*                                      FORM MACRO                      07729
         AIF   ('&TSID' EQ '').CHKLOC   GOTO CHECK TSIDLOC              07730
         AIF   ('&TSID'(1,1) EQ '(').REGFM   REG. FORM MACRO            07731
&ID      SETC  '&TSID'                  SET TSID                        07732
         AGO   .EXPAND                  GOTO EXPANSION                  07733
.CHKLOC  AIF   ('&TSIDLOC' EQ '').EXPAND  GO EXPAND IF NO 'TSIDLOC'     07734
         AIF   ('&TSIDLOC'(1,1) EQ '(').REGFM  REG. FORM MACRO          07735
.*   REGULAR FORMAT OF MACRO                                            07736
.EXPAND  CNOP  0,4                                                      07737
         AIF   ('&TSIDLOC' NE '').LOC   TJLOC SPECIFIED                 07738
&NAME    B     *+12                     BRANCH AROUND CONSTANTS         07739
         DC    AL2(&ID)                 TSID                            07740
         DC    AL2(&SIZE)               BUFFER SIZE                     07741
         DC    AL1(&OPT)                OPTIONS                         07742
         DC    AL3(&BFF)                BUFFER ADDR                     07743
         LM    0,1,*-8                  LOAD PARAMETER REGISTERS        07744
.SVC     ANOP                                                           07745
         AIF   ('&USERIDL' EQ '').GENSVC                                07746
         AIF   ('&USERIDL'(1,1) EQ '(').LR                              07747
         LA    15,&USERIDL                                              07748
         AGO   .GENSVC                                                  07749
.LR      ANOP                                                           07750
         AIF   ('&USERIDL' EQ '(15)').GENSVC                            07751
         LR    15,&USERIDL(1)                                           07752
.GENSVC  ANOP                                                           07753
         SVC   93                       ISSUE TGET/TPUT SVC             07754
         SPACE 1                                                        07755
         MEXIT                                                          07756
.*   TSIDLOC IS SPECIFIED                                               07757
.LOC     ANOP                                                           07758
&NAME    ICM   0,B'0011',&TSIDLOC       TSID IN HIGH 2 BYTES   @G76XRYU 07759
         SLL   0,16                     SHIFT TJID TO HI-ORDER BYTES    07760
         AIF   (&OPT EQ 0).ZERO         BRANCH IF OPTIONS ARE ZERO      07761
         O     0,*+8                    LOAD BUFFER SIZE                07762
         B     *+12                     BRANCH AROUND CONSTANT          07763
         DC    AL2(0)                   TJID                            07764
         DC    AL2(&SIZE)               BUFFER SIZE                     07765
         DC    AL1(&OPT)                OPTIONS                         07766
         DC    AL3(&BFF)                BUFFER ADDR                     07767
         L     1,*-4                    LOAD OPTIONS & BUFFER ADDR      07768
         AGO   .SVC                     GOTO ISSUE SVC                  07769
.ZERO    LA    1,&SIZE                  LOAD BUFFER SIZE                07770
         OR    0,1                      OR IT INTO REGISTER 0           07771
         LA    1,&BFF                   Z HIGH ORDR BYTE & LD BFR ADDR  07772
         AGO   .SVC                     GOTO ISSUE SVC                  07773
.*   REGISTER FORMAT                                                    07774
.REGFM   AIF   ('&TSIDLOC' EQ '').NOLOC   SKIP IF TJIDLOC NOT SPECIFIED 07775
         AIF   ('&TSIDLOC'(1,1) EQ '(').REGLOC    LOC IN REG  FORM      07776
&NAME    ICM   15,B'0011',&TSIDLOC      TSID IN HIGH 2 BYTES   @G76XRYU 07777
         SLL   15,16                    MOVE TJID TO HI=ORDER 2 BYTES   07778
         AGO   .CHKSIZE                 GOTO CHECK SIZE                 07779
.REGLOC  ANOP                                                           07780
&NAME    ICM   15,B'0011',0&TSIDLOC     TSID IN HIGH 2 BYTES   @G76XRYU 07781
         SLL   15,16                    MOVE TJID TO HI-ORDER 2 BYTES   07782
         AGO   .CHKSIZE                 GOTO CHECK SIZE                 07783
.*   WHEN TJIDLOC IS NOT SPECIFIED                                      07784
.NOLOC   AIF   ('&TSID' NE '').TJIDYES                                  07785
&NAME    DS    0H                       TJID IS '0'                     07786
         AGO   .CHKSIZE                 GOTO CHECK SIZE                 07787
.TJIDYES AIF   ('&TSID'(1,1) EQ '(').IDREG   TJID IN REG FORM           07788
&NAME    LA    15,&TSID                 LOAD TJID                       07789
         AGO   .SHIFT                   GOTO SHIFT REG.0                07790
.IDREG   ANOP                                                           07791
&NAME    LR    15,&TSID                 LOAD TJID IN REG 15             07792
.SHIFT   SLL   15,16                    SHIFT TJID TO HI-ORDER BYTE     07793
.*  CHECK SIZE OF BUFFER (BY NOW TJID IS IN HI-ORDER 2 BYTES OF REG 15) 07794
.CHKSIZE AIF   ('&SIZE'(1,1) EQ '(').SZREG   SKIP IF SIZE IN REG        07795
         LA    0,&SIZE                  LOAD SIZE IN REG.0              07796
         AGO   .ORSIZE                  GOTO OR SIZE                    07797
.SZREG   AIF   ('&SIZE' EQ '(0)').ORSIZE  GOTO SET SIZE IN REG. 0       07798
         LR    0,&SIZE(1)               LOAD BUFFER SIZE                07799
.ORSIZE  AIF   ('&TSID' EQ '' AND '&TSIDLOC' EQ '').PAST                07800
         OR    0,15                     LOAD TJID + BUFFER SIZE         07801
.PAST    AIF   (&OPT EQ 0 AND '&BFF'(1,1) EQ '(').ORONE                 07802
         AIF   (&OPT EQ 0 AND '&BFF'(1,1) NE '(').ZOPT ZERO OPTN        07803
         CNOP  0,4                                                      07804
         B     *+8                                                      07805
         DC    AL1(&OPT)                OPTION BITS                     07806
         AIF   ('&BFF'(1,1) EQ '(').REGGO   BFFR IN REG.                07807
         DC    AL3(&BFF)                BUFFER ADDR                     07808
         L     1,*-4                    LOAD PARAMETER IN REG.1         07809
         AGO   .SVC                     GOTO ISSUE SVC                  07810
.ZOPT    LA    1,&BFF                   LOAD BUFFER ADDR IN REG 1       07811
         AGO   .SVC                     ISSUE SVC                       07812
.REGGO   DC    AL3(0)                   BUFFER ADDR                     07813
         AIF   ('&BFF' EQ '(1)').ORONE  GOTO OR OPTIONS                 07814
         L     1,*-4                    LOAD OPTIONS                    07815
         OR    1,&BFF(1)                SET OPTIONS AND BUFFER ADDR     07816
         AGO   .SVC                     GOTO ISSUE SVC                  07817
.ORONE   LA    1,0(,&BFF(1))            CLR HIGH ORDR BYTE + LD BFR ADR 07818
         AIF   (&OPT EQ 0).SVC          GOTO ISSUE SVC IF OPT EQ 0      07819
         O     1,*-8                    SET OPTIONS                     07820
         AGO   .SVC                                                     07821
         MEND                                                           07822
##
//
