QGET
PRGM QGET;
# TITLE QGET - GET QUEUE FILE.                                        # 
  
      BEGIN  # QGET # 
  
# 
***   QGET - GET QUEUE FILE.
* 
*     *QGET* WILL ALLOW USERS TO OBTAIN ANY JOB OUTPUT FROM THEIR 
*     PRINT, PUNCH, PLOT, OR WAIT QUEUES. 
* 
*     QGET,JSN=JJJJ,DC=XX,UJN=NAME,FN=XXXXXXX,OP=NA,DQ=XXX. 
* 
*       OR
* 
*     QGET,JJJJ,XX,NAME,XXXXXXX,NA,XXX
* 
*     PRGM QGET.
* 
*     ENTRY.            *QGET* PARAMETERS ARE - 
* 
*     PARAMETER         DESCRIPTION 
* 
*     JSN = JJJJ        FOUR CHARACTER JOB SEQUENCE NAME SPECIFYING 
*                       THE QUEUED FILE TO BE OBTAINED. 
* 
*     DC = XX           DISPOSITION CODE WHICH SELECTS QUEUE THAT THE 
*                       JOB IS LOCATED IN IS ONE OF THE FOLLOWING - 
* 
*                         PR - PRINT QUEUE. 
*                         PU - PUNCH QUEUE. 
*                         PL - PLOT QUEUE.
*                         IN - INPUT QUEUE. 
*                         TT OR WT - WAIT QUEUE (DEFAULT IF *DC*
*                              OMITTED).
* 
*     UJN = NAME        ONE TO SEVEN CHARACTER USER JOB NAME
*                       SPECIFYING THE QUEUED FILE TO BE OBTAINED.
* 
*     FN = XXXXXXX      ONE TO SEVEN CHARACTER FILE NAME INDICATING THE 
*                       LOCAL FILE NAME THAT IS TO BE ASSOCIATED WITH 
*                       THE ATTACHED OUTPUT FILE. 
* 
*     OP = NA           INDICATES THAT *QGET* IS NOT TO ABORT IN THE
*                       EVENT OF A NON-SYNTACTICAL ERROR, FOR EXAMPLE 
*                       *FILE NOT FOUND* OR *DUPLICATE UJN*.
* 
*     DQ = XXX          A VALUE OF EITHER *YES* OR *NO* INDICATING
*                       WHETHER THE FILE SHOULD BE REMOVED FROM THE 
*                       QUEUE AFTER IT IS ATTACHED TO THE JOB.  A 
*                       VALUE OF *YES* (DEFAULT) INDICATES THAT THE 
*                       FILE WILL BE REMOVED FROM THE QUEUE.  A VALUE 
*                       OF *NO* INDICATES THAT THE PRIOR ROUTING FOR
*                       THE FILE REMAINS IN EFFECT - IT IS NOT REMOVED
*                       FROM THE QUEUE.  THE FILE IS LOCKED AND MAY 
*                       NOT BE MODIFIED, BUT MAY BE EXAMINED OR COPIED. 
* 
*     EXIT.      THE QUEUE FILE IS OBTAINED IF THERE WERE NO ERRORS.
*                IF AN ERROR CONDITION IS ENCOUNTERED, *QGET* WILL
*                NORMALLY ABORT WITH A DAYFILE MESSAGE.  IF THE *NA*
*                OPTION IS SELECTED AND A NON-SYNTACTICAL ERROR OCCURS, 
*                SUCH AS *FILE NOT FOUND* OR *DUPLICATE UJN*, *QGET*
*                ISSUES THE DAYFILE ERROR MESSAGE BUT DOES NOT ABORT. 
* 
*     MESSAGES.  * DUPLICATE UJN - MUST SPECIFY JSN.* 
*                * INCORRECT DC PARAMETER - XXX.* 
*                * INCORRECT LOCAL FILE NAME - XXXXXXX.*
*                * INCORRECT OP PARAMETER - XXXXXXX.* 
*                * INCORRECT PARAMETER.*
*                * JSN MORE THAN FOUR CHARACTERS.*
*                * JSN OR UJN MUST BE SPECIFIED.* 
*                * LOCAL FILE XXXXXXX ALREADY EXISTS.*
*                * PRU LIMIT.*
*                * QGET COMPLETE.*
*                * SYSTEM ERROR - NOTIFY SITE ANALYST.* 
*                * XXXXXXX NOT FOUND.*
*                * XXXX/YYYYYYY NOT FOUND.* 
* 
*     NOTES.     EITHER JSN OR UJN MUST BE SPECIFIED.  IF BOTH ARE
*                SPECIFIED THEY MUST REFER TO THE SAME FILE.  IF UJN
*                IS SPECIFIED, THE UJN WILL BE THE LOCAL FILE NAME OF 
*                THE RETURNED FILE, OTHERWISE THE JSN WILL BE THE 
*                LOCAL FILE NAME OF THE RETURNED FILE.
* 
*     COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
# 
  
# 
****  PRGM QGET - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # CALLS *ABORT* MACRO #
        PROC BZFILL;                 # BLANK FILLS ITEM # 
        PROC CALLQAC;                # SETS UP *QAC* CALL # 
        PROC MSG;                    # CALLS *MESSAGE* MACRO #
        PROC PKP;                    # CRACKS PARAMETERS #
        PROC RETERN;                 # CALLS *RETURN* MACRO # 
        PROC RET$JSN;                # RETURNS JSN #
        PROC ROUTE;                  # CALLS *ROUTE* MACRO #
        PROC SETNM;                  # SET NAME IN MESSAGE #
        PROC SQA;                    # SET ARGUMENT LIST #
        PROC ZFILL;                  # ZERO FILLS BUFFER #
        PROC ZSETFET;                # SETS UP FET #
        END 
  
# 
****  PRGM QGET - XREF LIST END.
# 
  
  
# 
*     DAYFILE MESSAGES. 
# 
  
      DEF COMPLETE   #" QGET COMPLETE.;"#;
      DEF INCDC      #" INCORRECT DC PARAMETER - XXXXXXX.;"#; 
      DEF INCJSN     #" JSN MORE THAN FOUR CHARACTERS.;"#;
      DEF INCOP      #" INCORRECT OP PARAMETER - XXXXXXX.;"#; 
      DEF INCPRM     #" INCORRECT PARAMETER.;"#;
      DEF JNREQ      #" JSN OR UJN MUST BE SPECIFIED.;"#; 
      DEF JOBNF      #" XXXX/+++++++ NOT FOUND.;"#; 
      DEF NOTFD      #" XXXXXXX NOT FOUND.;"#;
      DEF NOTRMVD    #" PRIOR ROUTING REMAINS IN EFFECT.;"#;
  
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS # 
*CALL,COMAMSS 
*CALL,COMABZF 
*CALL,COMUQPR 
*CALL,COMUQQC 
  
      ITEM ARGLIST    U;             # ADDRESS OF ARGUMENT LIST # 
      ITEM ARGLEN     U;             # LENGTH OF ARGUMENT LIST #
      ITEM BLKFILL    S:TYPFILL = S"BFILL";  # BLANK FILL # 
      ITEM ERR        U;             # ERROR RETURN CODE #
      ITEM FLAG       U;             # SYNTAX FLAG #
      ITEM JSN        C(4);          # JSN #
      ITEM LFN        C(7);          # LFN #
      ITEM TEMPPAR    C(7);          # TEMPORARY CHARACTER FIELD #
  
# 
*     *DSP* PARAMETER BLOCK.
# 
  
      ARRAY DSPBLK [0:0] S(DSPBLKL);
        BEGIN 
        ITEM DSP$LFN    C(00,00,07);  # LFN # 
        ITEM DSP$DISP   C(01,24,02);  # DISPOSITION CODE #
        ITEM DSP$DISPF  B(01,55,01);  # CODE SELECTION FLAG # 
        END 
  
      ARRAY FETRET [0:0] S(SFETL);; 
                                               CONTROL EJECT; 
  
# 
*     CRACK COMMAND.
# 
  
      SQA(ARGLIST,ARGLEN);
      PKP(ARGLIST,ARGLEN,FLAG);      # CRACK THE PARAMETERS # 
  
      IF FLAG NQ SYNTAXOK 
      THEN                           # INCORRECT PARAMETER #
        BEGIN 
        MSG(INCPRM,SYSUDF1);
        ABORT;
        END 
  
# 
*     CHECK PARAMETERS AND SET UP *QAC* CALL. 
# 
  
  
      IF QARG$OPI[0] NQ 0 
      THEN
        BEGIN  # *OP* SPECIFIED # 
        TEMPPAR = QARG$OP[0]; 
        BZFILL(TEMPPAR,TYPFILL"BFILL",7);  # BLANK FILL OPTION #
        IF TEMPPAR NQ "NA"
        THEN
          BEGIN 
          SETNM(TEMPPAR,"X",";",INCOP,MSGLINE); 
          MSG(MSGLINE,SYSUDF1); 
          ABORT;
          END 
  
        END  # *OP* SPECIFIED # 
  
      IF QARG$DCI[0] EQ 0 
      THEN                           # *DC* NOT SPECIFIED # 
        BEGIN 
        QARG$DC[0] = DC$TT;          # SET DEFAULT *DC* VALUE # 
        END 
  
      TEMPPAR = QARG$DC[0]; 
      BZFILL(TEMPPAR,BLKFILL,7);     # BLANK FILL DISPOSITION # 
      IF TEMPPAR EQ DC$WT 
      THEN
        BEGIN 
        QARG$DC[0] = DC$TT; 
        END 
  
      IF TEMPPAR NQ DC$PL 
        AND TEMPPAR NQ DC$PR
        AND TEMPPAR NQ DC$PU
        AND TEMPPAR NQ DC$TT
        AND TEMPPAR NQ DC$WT
        AND TEMPPAR NQ DC$IN
        AND QARG$DCI[0] NQ 0
      THEN                           # INCORRECT *DC* PARAMETER # 
        BEGIN 
        SETNM(TEMPPAR,"X",";",INCDC,MSGLINE); 
        MSG(MSGLINE,SYSUDF1); 
        ABORT;
        END 
  
      IF QARG$JSEND[0] NQ 0 
      THEN                           # JSN MORE THAN FOUR CHARACTERS #
        BEGIN 
        MSG(INCJSN,SYSUDF1);
        ABORT;
        END 
  
      IF QARG$JSI[0] EQ 0 
      THEN
        BEGIN  # CHECK UJN WITH NO JSN SPECIFIED #
        IF QARG$UJI[0] EQ 0 
        THEN                         # JSN OR UJN REQUIRED #
          BEGIN 
          MSG(JNREQ,SYSUDF1); 
          ABORT;
          END 
  
        ELSE
          BEGIN  # ONLY UJN SPECIFIED # 
          RET$JSN(ERR); 
          IF ERR EQ 0 
          THEN
            BEGIN 
            IF RETJSNI[0] EQ 0
            THEN                     # UJN NOT FOUND #
              BEGIN 
              SETNM(QARG$UJ[0],"X",";",NOTFD,MSGLINE);
              MSG(MSGLINE,SYSUDF1); 
              ERR = 1;               # INDICATE ERROR DETECTED #
              END 
  
            ELSE
              BEGIN 
              LFN = QARG$UJ[0]; 
              JSN = RETJSN[0];
              END 
            END 
  
          END  # ONLY UJN SPECIFIED # 
  
        END  # CHECK UJN WITH NO JSN SPECIFIED #
  
      ELSE
        BEGIN  # CHECK UJN WITH JSN SPECIFIED # 
        IF QARG$UJI[0] EQ 0 
        THEN
          BEGIN  # JSN ONLY # 
          LFN = QARG$JS[0]; 
          JSN = QARG$JS[0]; 
          END  # JSN ONLY # 
  
        ELSE
          BEGIN  # BOTH JSN AND UJN # 
          RET$JSN(ERR); 
          IF ERR EQ 0 
          THEN
            BEGIN 
            IF RETJSNI[0] NQ QARG$JSI[0]
            THEN                     # JSN/UJN NOT FOUND #
              BEGIN 
              SETNM(QARG$JS[0],"X",";",JOBNF,MSGLINE);
              SETNM(QARG$UJ[0],"+",0,MSGLINE,MSGLINE);
              MSG(MSGLINE,SYSUDF1); 
              ERR = 1;               # INDICATE ERROR DETECTED #
              END 
  
            ELSE
              BEGIN 
              LFN = QARG$UJ[0]; 
              JSN = QARG$JS[0]; 
              END 
            END 
  
          END  # BOTH JSN AND UJN # 
  
        END  # CHECK UJN WITH JSN # 
  
      IF QARG$FNI[0] NQ 0 
      THEN
        BEGIN 
        LFN = QARG$FN[0]; 
        END 
  
      IF ERR EQ 0 
      THEN                           # IF NO ERRORS DETECTED #
        BEGIN 
        P<DUMAR> = LOC(QACPARM);
        ZFILL(DUMAR[0],PREFIXL);
        CALLQAC(FCN"GET",LFN,JSN,QARG$DC[0],ERR); 
        IF ERR EQ NOTFND
        THEN                         # JOB NOT FOUND #
          BEGIN 
          IF QARG$JSI[0] NQ 0 
          THEN
            BEGIN 
            SETNM(QARG$JS[0],"X",";",NOTFD,MSGLINE);
            END 
  
          ELSE
            BEGIN 
            SETNM(QARG$UJ[0],"X",";",NOTFD,MSGLINE);
            END 
  
          MSG(MSGLINE,SYSUDF1); 
          END 
        END 
  
      IF ERR NQ 0 
      THEN                           # IF AN ERROR OCCURRED # 
        BEGIN 
        IF QARG$OPI[0] EQ 0 
        THEN                         # NO ABORT NOT SELECTED #
          BEGIN 
          ABORT;
          END 
        END 
  
      ELSE
        BEGIN 
# 
*     MAKE *QAC* FILE LOCAL.
# 
  
        TEMPPAR = QARG$DQ[0];          # BLANK FILL DQ VALUE #
        BZFILL(TEMPPAR,BLKFILL,7);
        IF TEMPPAR NQ DQ$NO 
        THEN                           # IF FILE IS TO BE DEQUEUED #
          BEGIN 
          P<DUMAR> = LOC(DSPBLK[0]);   # BUILD *DSP* BLOCK #
          ZFILL(DUMAR[0],DSPBLKL);
          DSP$LFN[0] = LFN; 
          DSP$DISP[0] = DC$SC;
          DSP$DISPF[0] = TRUE;
          ROUTE(DSPBLK[0],RCL);        # DEQUEUE THE FILE # 
          END 
        ELSE
          BEGIN 
          MSG(NOTRMVD,UDFL1);          # PRIOR RTNG REMAINS IN EFF. # 
          END 
  
        MSG(COMPLETE,UDFL1);         # *QGET* COMPLETE #
        END 
  
      END  # QGET # 
  
    TERM
PRGM DROP;
# TITLE DROP - DROP QUEUE FILE.                                       # 
  
      BEGIN  # DROP # 
  
# 
***   DROP - DROP QUEUE FILE. 
* 
*     *DROP* WILL ALLOW USERS TO DROP THEIR EXECUTING JOBS OR QUEUED
*     FILES.  *DROP* CANNOT BE USED TO DROP THE JOB FROM WHICH THE
*     *DROP* COMMAND IS ENTERED.
* 
*     DROP,JSN=JJJJ,DC=XX,UJN=NAME,OP=R.
* 
*       OR
* 
*     DROP,JJJJ,XX,NAME,R.
* 
*     PRGM DROP.
* 
*     ENTRY.            *DROP* PARAMETERS ARE - 
* 
*     PARAMETER         DESCRIPTION 
* 
*     JSN = JJJJ        FOUR CHARACTER JOB SEQUENCE NAME SPECIFYING 
*                       THE QUEUED FILE TO BE DROPPED.
* 
*     DC = XX           DISPOSITION CODE WHICH SELECTS QUEUE THAT THE 
*                       JOB IS LOCATED IN.  IF NEITHER THE JSN NOR THE
*                       UJN IS SPECIFIED, *DC* IS REQUIRED.  IN THIS
*                       CASE, THE SYSTEM DROPS ALL OF THE USER-S JOBS 
*                       WITH THE SPECIFIED DISPOSITION. 
* 
*                       *XX* MAY BE ONE OF THE FOLLOWING -
* 
*                       PR - PRINT QUEUE. 
*                       PU - PUNCH QUEUE. 
*                       PL - PLOT QUEUE.
*                       TT OR WT - WAIT QUEUE.
*                       IN - INPUT QUEUE. 
*                       EX - EXECUTING JOB QUEUE. 
*                       ALL - ALL QUEUES (DEFAULT IF *DC* OMITTED). 
* 
*     UJN = NAME        ONE TO SEVEN CHARACTER USER JOB NAME
*                       SPECIFYING THE QUEUED FILE TO BE DROPPED. 
* 
*     OP = R            INDICATES THAT FOR JOBS WITH REPRIEVE 
*                       PROCESSING, ONLY A SINGLE REPRIEVE WILL BE
*                       PROCESSED BEFORE THE DROP.  THE EXECUTING JOBS
*                       WILL BE DROPPED WITHOUT EXIT PROCESSING.
* 
*     EXIT.      THE QUEUE FILE IS DROPPED IF THERE WERE NO ERRORS. 
*                IF AN ERROR CONDITION IS ENCOUNTERED, *DROP* WILL
*                ABORT WITH A DAYFILE MESSAGE.
* 
*     MESSAGES.  * CALLING JOB MAY NOT DROP ITSELF.*
*                * DC REQUIRED IF JSN/UJN NOT SPECIFIED.* 
*                * DROP COMPLETE.*
*                * DROPPED BY USER JOB XXXX.* 
*                * DUPLICATE UJN - MUST SPECIFY JSN.* 
*                * INCORRECT DC PARAMETER - XXXXXXX.* 
*                * INCORRECT OP PARAMETER - XXXXXXX.* 
*                * INCORRECT PARAMETER.*
*                * JSN MORE THAN FOUR CHARACTERS.*
*                * SYSTEM ERROR - NOTIFY SITE ANALYST.* 
*                * UNABLE TO DROP JOB.* 
*                * XXXXXXX NOT FOUND.*
*                * XXXX/YYYYYYY NOT FOUND.* 
* 
*     NOTES.     IF BOTH JSN AND UJN ARE SPECIFIED, THEY MUST REFER TO
*                THE SAME FILE. 
* 
*     COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
# 
  
# 
****  PRGM DROP - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # CALLS *ABORT* MACRO #
        PROC BZFILL;                 # BLANK FILLS ITEM # 
        PROC CALLQAC;                # SETS UP *QAC* CALL # 
        PROC GETJN;                  # GETS JOB SEQUENCE NUMBER # 
        PROC MSG;                    # CALLS *MESSAGE* MACRO #
        PROC PKP;                    # CRACKS PARAMETERS #
        PROC RET$JSN;                # RETURNS JSN #
        PROC SDA;                    # SET ARGUMENT LIST #
        PROC SETNM;                  # SET NAME IN MESSAGE #
        END 
  
# 
****  PRGM DROP - XREF LIST END.
# 
  
# 
*     DAYFILE MESSAGES. 
# 
  
      DEF COMPLETE   #" DROP COMPLETE.;"#;
      DEF DCREQ      #" DC REQUIRED IF JSN/UJN NOT SPECIFIED.;"#; 
      DEF INCDC      #" INCORRECT DC PARAMETER - XXXXXXX.;"#; 
      DEF INCJSN     #" JSN MORE THAN FOUR CHARACTERS.;"#;
      DEF INCOP      #" INCORRECT OP PARAMETER - XXXXXXX.;"#; 
      DEF INCPRM     #" INCORRECT PARAMETER.;"#;
      DEF JOBNF      #" XXXX/+++++++ NOT FOUND.;"#; 
      DEF NOTFD      #" XXXXXXX NOT FOUND.;"#;
      DEF SAMEJOB    #" CALLING JOB MAY NOT DROP ITSELF.;"#;
      DEF USERDROP   #" DROPPED BY USER JOB XXXX.;"#; 
  
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS # 
*CALL COMAMSS 
*CALL COMABZF 
*CALL COMUQPR 
*CALL COMUQQC 
  
      ITEM ARGLIST    U;             # ADDRESS OF ARGUMENT LIST # 
      ITEM ARGLEN     U;             # LENGTH OF ARGUMENT LIST #
      ITEM ERR        U;             # ERROR RETURN CODE #
      ITEM FLAG       U;             # SYNTAX FLAG #
      ITEM JSN        C(4);          # JSN #
      ITEM JSNSAVE    C(4);          # JSN STORAGE #
      ITEM TEMPPAR    C(7);          # TEMPORARY CHARACTER FIELD #
      ITEM TEMPJSN    C(4);          # TEMPORARY JSN FIELD #
                                               CONTROL EJECT; 
  
# 
*     CRACK COMMAND.
# 
  
      SDA(ARGLIST,ARGLEN);
      PKP(ARGLIST,ARGLEN,FLAG);      # CRACK THE PARAMETERS # 
  
      IF FLAG NQ SYNTAXOK 
      THEN                           # INCORRECT PARAMETER #
        BEGIN 
        MSG(INCPRM,SYSUDF1);
        ABORT;
        END 
  
# 
*     CHECK PARAMETERS AND SET UP *QAC* CALL. 
# 
  
      IF QARG$OPI[0] NQ 0 
      THEN
        BEGIN  # *OP* SPECIFIED # 
        TEMPPAR = QARG$OP[0]; 
        BZFILL(TEMPPAR,TYPFILL"BFILL",7);  # BLANK FILL OPTION #
        IF TEMPPAR NQ "R" 
        THEN
          BEGIN 
          SETNM(TEMPPAR,"X",";",INCOP,MSGLINE); 
          MSG(MSGLINE,SYSUDF1); 
          ABORT;
          END 
  
        END  # *OP* SPECIFIED # 
  
      TEMPPAR = QARG$DC[0]; 
      BZFILL(TEMPPAR,TYPFILL"BFILL",7);  # BLANK FILL DISPOSITION # 
      IF TEMPPAR EQ DC$WT 
      THEN
        BEGIN 
        QARG$DC[0] = DC$TT; 
        END 
  
      IF TEMPPAR NQ DC$EX 
        AND TEMPPAR NQ DC$IN
        AND TEMPPAR NQ DC$PL
        AND TEMPPAR NQ DC$PR
        AND TEMPPAR NQ DC$PU
        AND TEMPPAR NQ DC$TT
        AND TEMPPAR NQ DC$WT
        AND TEMPPAR NQ DC$ALL 
        AND QARG$DCI[0] NQ 0
      THEN                           # INCORRECT *DC* PARAMETER # 
        BEGIN 
        SETNM(TEMPPAR,"X",";",INCDC,MSGLINE); 
        MSG(MSGLINE,SYSUDF1); 
        ABORT;
        END 
  
      IF QARG$JSEND[0] NQ 0 
      THEN                           # JSN MORE THAN FOUR CHARACTERS #
        BEGIN 
        MSG(INCJSN,SYSUDF1);
        ABORT;
        END 
  
      IF QARG$DCI[0] EQ 0 
      THEN
        BEGIN  # *DC* NOT SPECIFIED # 
        IF QARG$JSI[0] EQ 0 AND QARG$UJI[0] EQ 0
        THEN                         # DISPOSITION REQUIRED # 
          BEGIN 
          MSG(DCREQ,SYSUDF1); 
          ABORT;
          END 
  
        ELSE                         # SET DEFAULT DISPOSITION #
          BEGIN 
          QARG$DC[0] = DC$ALL;
          TEMPPAR = DC$ALL; 
          END 
  
        END  # *DC* NOT SPECIFIED # 
  
      IF QARG$JSI[0] EQ 0 
      THEN                           # JSN NOT SPECIFIED #
        BEGIN 
        SETNM(QARG$UJ[0],"X",";",NOTFD,MSGLINE);
        END 
  
      IF QARG$UJI[0] NQ 0 
      THEN
        BEGIN  # UJN SPECIFIED #
        RET$JSN(ERR); 
        IF ERR NQ 0 
        THEN                         # IF DUPLICATE UJN ERROR # 
          BEGIN 
          ABORT;
          END 
        JSN = RETJSN[0];
        IF QARG$JSI[0] EQ 0 
        THEN                         # ONLY UJN SPECIFIED # 
          BEGIN 
          IF RETJSNI[0] EQ 0
          THEN                       # UJN NOT FOUND #
            BEGIN 
            MSG(MSGLINE,SYSUDF1); 
            ABORT;
            END 
  
          END 
  
        ELSE                         # JSN AND UJN SPECIFIED #
          BEGIN 
          IF RETJSNI[0] NQ QARG$JSI[0]
          THEN                       # JSN/UJN NOT FOUND #
            BEGIN 
            SETNM(QARG$JS[0],"X",";",JOBNF,MSGLINE);
            SETNM(QARG$UJ[0],"+",0,MSGLINE,MSGLINE);
            MSG(MSGLINE,SYSUDF1); 
            ABORT;
            END 
  
          END 
  
        END  # UJN SPECIFIED #
  
      ELSE                           # UJN NOT SPECIFIED #
        BEGIN 
        JSN = QARG$JS[0]; 
        END 
  
      IF QARG$JSI[0] NQ 0 
      THEN                           # JSN SPECIFIED #
        BEGIN 
        SETNM(QARG$JS[0],"X",";",NOTFD,MSGLINE);
        TEMPJSN = QARG$JS[0]; 
        BZFILL(TEMPJSN,TYPFILL"BFILL",4);      # BLANK FILL JSN # 
        QARG$JS[0] = TEMPJSN; 
        END 
  
      GETJN(JSNSAVE);                # GET JOB NAME # 
      IF TEMPPAR EQ DC$EX OR TEMPPAR EQ DC$ALL AND QARG$JSI[0] NQ 0 
      THEN
        BEGIN 
        IF JSN EQ JSNSAVE 
        THEN                         # CANNOT DROP CALLING JOB #
          BEGIN 
          MSG(SAMEJOB,SYSUDF1); 
          ABORT;
          END 
        END 
  
      SETNM(JSNSAVE,"X",";",USERDROP,USRLINE);
  
# 
*     ISSUE *QAC* CALL. 
# 
  
      CALLQAC(FCN"ALTER",JSNSAVE,JSN,QARG$DC[0],ERR); 
  
      IF ERR NQ 0 
      THEN                           # QUEUE FILE NOT FOUND # 
        BEGIN 
        MSG(MSGLINE,SYSUDF1); 
        ABORT;
        END 
  
      MSG(COMPLETE,UDFL1);           # DROP COMPLETE #
      END  # DROP # 
  
    TERM
PROC CALLQAC((FUNCT),(LFN),(JSN),(DC),FLAG);
# TITLE CALLQAC - SETS UP *QAC* PARAMETER BLOCK AND CALLS *QAC*.      # 
  
      BEGIN  # CALLQAC #
  
# 
**    CALLQAC - SETS UP *QAC* PARAMETER BLOCK AND CALLS *QAC*.
* 
*     *CALLQAC* WILL SET UP THE PARAMETER BLOCK REQUIRED TO PERFORM THE 
*     SPECIFIED FUNCTION AND CALL *QAC*.
* 
*     PROC CALLQAC((FUNCT),(LFN),(JSN),(DC),FLAG) 
* 
*     ENTRY     (FUNCT) - *QAC* FUNCTION CODE.
*               (LFN)   - LFN OF FILE FOR *GET* FUNCTION. 
*                       - JSN OF CALLING JOB FOR *ALTER* FUNCTION.
*               (JSN)   - JOB SEQUENCE NAME TO LOOK FOR.
*               (DC)    - DISPOSITION CODE. 
* 
*     EXIT      (FLAG) - IF *PEEK* FUNCTION, *FLAG* INDICATES WHEN
*                        ALL QUEUES ARE SEARCHED. 
*                        IF *ALTER* FUNCTION, *FLAG* INDICATES WHETHER
*                        SPECIFIED FILE WAS FOUND (ZERO = FOUND). 
*                        IF *GET* FUNCTION, *FLAG* INDICATES WHETHER AN 
*                        ERROR OCCURRED. ((*FLAG*) = ERROR CODE). 
* 
*     MESSAGES   * INCORRECT LOCAL FILE NAME - XXXXXXX.*
*                * LOCAL FILE XXXXXXX ALREADY EXISTS.*
*                * PRU LIMIT.*
*                * SYSTEM ERROR - NOTIFY SITE ANALYST.* 
*                * UNABLE TO DROP JOB.* 
# 
  
      ITEM FUNCT      U;             # FUNCTION CODE #
      ITEM LFN        C(10);         # LFN #
      ITEM JSN        C(4);          # JSN #
      ITEM DC         C(3);          # DISPOSITION CODE # 
      ITEM FLAG       U;             # COMMUNICATION FLAG/CODE #
  
# 
****  PROC CALLQAC - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # CALLS *ABORT* MACRO #
        PROC MQC;                    # MAKES *QAC* CALL # 
        PROC MSG;                    # CALLS *MESSAGE* MACRO #
        FUNC QSET I;                 # SETS QUEUE TYPE #
        PROC SETNM;                  # SET NAME IN MESSAGE #
        PROC ZFILL;                  # ZERO FILLS BUFFER #
        END 
  
# 
****  PROC CALLQAC - XREF LIST END. 
# 
  
# 
*     ERROR MESSAGES. 
# 
  
      DEF DUPLFNM    #" LOCAL FILE ZZZZZZZ ALREADY EXISTS.;"#;
      DEF INCLFN     #" INCORRECT LOCAL FILE NAME - XXXXXXX.;"#;
      DEF NODROP     #" UNABLE TO DROP JOB.;"#; 
      DEF PRULIM     #" PRU LIMIT.;"#;
      DEF SYSERROR   #" SYSTEM ERROR - NOTIFY SITE ANALYST.;"#; 
  
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS # 
*CALL,COMAMSS 
*CALL,COMABZF 
*CALL,COMUQPR 
*CALL,COMUQQC 
  
      ITEM I          U;             # INDEX #
      ITEM INIT$PEEK  B = TRUE;      # INITIAL *PEEK* FLAG #
      ITEM QUEUE      U;             # QUEUE TYPE # 
  
      ARRAY FOUIBUF [0:0] S(1);      # *QAC* *PEEK* REPLY ENTRY # 
        BEGIN 
        ITEM QACREP$DFO U(00,00,06);  # DESTINATION FAMILY ORDINAL #
        ITEM QACREP$DUI U(00,06,18);  # DESTINATION USER INDEX #
        ITEM QACREP$CFO U(00,24,06);  # CREATION FAMILY ORDINAL # 
        ITEM QACREP$CUI U(00,30,18);  # CREATION USER INDEX # 
        END 
  
# 
*     SWITCH FOR *QAC* FUNCTION.
# 
  
      SWITCH FUNCJMP
      PEEKJ,
      ALTERJ, 
      GETJ; 
                                               CONTROL EJECT; 
      FLAG = 0; 
      GOTO FUNCJMP[FUNCT];
  
# 
*     BEGIN *QAC* FUNCTION PROCESSORS.
# 
  
PEEKJ:                               # PROCESS *PEEK* FUNCTION #
  
  
# 
*     PROCESS INITIAL *QAC* CALL OR INTERRUPTED *QAC* CALL. 
# 
  
  
      IF QAC$W4ORD[0] NQ 0 AND QAC$W4Q[0] NQ 0
      THEN
        BEGIN  # *PEEK* INTERRUPTED # 
        FLAG = 1; 
        SLOWFOR I = QAC$QBITS STEP 1 WHILE I LQ QAC$END 
        DO
          BEGIN  # FIND INTERRUPTED QUEUE # 
          IF QBIT(I) NQ 0 
          THEN
            BEGIN 
            IF I EQ TTBIT 
            THEN
              BEGIN 
              QAC$TTCNT[0] = MAXCNT;
              END 
  
            ELSE
              BEGIN 
              QCOUNT(I) = MAXCNT; 
              END 
  
            FLAG = 0; 
            QAC$COMP[0] = FALSE;
            END 
  
          END  # FIND INTERRUPTED QUEUE # 
  
        END  # *PEEK* INTERRUPTED # 
  
      ELSE
        BEGIN  # CHECK INITIAL *QAC* CALL # 
        IF INIT$PEEK
        THEN
          BEGIN  # IF INITIAL *QAC* CALL #
          P<DUMAR> = LOC(QACPARM) + PREFIXL;
          ZFILL(DUMAR[0],PARMNOPREL); 
          QAC$FCN[0] = PEEK;         # SET FUNCTION # 
          QAC$LEN[0] = PEEKL;        # SET BLOCK LENGTH # 
          QAC$PEEKJS[0] = TRUE; 
          QAC$PEEKUJ[0] = TRUE; 
          QAC$LID[0] = TRUE;
          QAC$LIDC[0] = "***";
          IF DC EQ DC$ALL 
          THEN
            BEGIN 
            QAC$W8Q[0] = ALLQUEUES; 
            END 
  
          ELSE
            BEGIN 
            QUEUE = QSET(DC); 
            QBIT(QUEUE) = 1;
            END 
  
          FLAG = 0; 
          INIT$PEEK = FALSE;
          QAC$TTCNT[0] = MAXCNT;
  
          SLOWFOR I = QAC$QBITS STEP 1 WHILE I LQ COUNT$END 
          DO
            BEGIN 
            QCOUNT(I) = MAXCNT; 
            END 
  
          END  # IF INITIAL *QAC* CALL #
  
        ELSE
          BEGIN 
          QAC$COMP[0] = FALSE;
          FLAG = 1; 
          END 
  
        END  # CHECK INITIAL *QAC* CALL # 
  
      IF FLAG EQ 0
      THEN
        BEGIN  # MAKE *QAC* CALL #
        MQC(LOC(QACPARM));
  
        IF QAC$ERR[0] NQ 0
          AND QAC$ERR[0] NQ NOTFND
        THEN                         # *QAC* ERROR #
          BEGIN 
          GOTO SYSERR;               # PROCESS UNEXPECTED ERROR # 
          END 
  
        END  # MAKE *QAC* CALL #
  
      RETURN; 
                                               CONTROL EJECT; 
  
# 
*     *ALTER* FUNCTION. 
# 
  
ALTERJ:                              # PROCESS *ALTER* FUNCTION # 
  
      P<DUMAR> = LOC(QACPARM);       # GET FO AND UI OF CALLER #
      ZFILL(DUMAR[0],PARML);
      QAC$FCN[0] = PEEK;
      QAC$LEN[0] = PEEKL; 
      QAC$JSN[0] = LFN; 
      QAC$SETJS[0] = TRUE;
      QAC$PKFOUI[0] = TRUE; 
      QUEUE = QSET("EX"); 
      QBIT(QUEUE) = 1;
      QAC$EXCNT[0] = 1; 
      QAC$FIRST[0] = LOC(FOUIBUF[0]); 
      QAC$IN[0] = LOC(FOUIBUF[0]);
      QAC$OUT[0] = LOC(FOUIBUF[0]); 
      QAC$LIMIT[0] = LOC(FOUIBUF[0]) + 2; 
      QAC$LID[0] = TRUE;
      QAC$LIDC[0] = "***";
  
      MQC(LOC(QACPARM));
  
      IF QAC$ERR[0] NQ 0
      THEN                           # *QAC* ERROR #
        BEGIN 
        IF QAC$ERR[0] EQ NOTFND 
        THEN                         # CALLER MUST BE *DIS* # 
          BEGIN 
          QACREP$CUI[0] = 0;         # TREAT *DIS* AS A USER JOB #
          END 
        ELSE                         # UNEXPECTED ERROR # 
          BEGIN 
          GOTO SYSERR;               # PROCESS UNEXPECTED ERROR # 
          END 
        END 
  
      ZFILL(DUMAR[0],PARML);         # ISSUE *ALTER* REQUEST #
      QAC$FCN[0] = ALTER; 
      QAC$LEN[0] = ALTERL;
      QAC$LID[0] = TRUE;
      QAC$LIDC[0] = "***";
      IF JSN NQ 0 
      THEN
        BEGIN 
        QAC$JSN[0] = JSN; 
        IF C<3,1>QAC$JSN[0] EQ O"0" 
        THEN                         # BLANK-FILL THREE-CHARACTER JSN # 
          BEGIN 
          C<3,1>QAC$JSN[0] = O"55"; 
          END 
        QAC$SETJS[0] = TRUE;
        END 
  
      IF QARG$OPI[0] EQ 0 
      THEN                           # *DROP* COMMAND # 
        BEGIN 
        QAC$DROP[0] = TRUE; 
        END 
  
      ELSE                           # *DROP,OP=R* COMMAND #
        BEGIN 
        QAC$KILL[0] = TRUE; 
        END 
  
      QAC$PRI[0] =TRUE; 
      QAC$SETLD[0] = TRUE;
      QAC$NWLD[0] = 0;
      IF DC EQ DC$ALL 
      THEN
        BEGIN 
        QAC$W8Q[0] = ALLQUEUES; 
        END 
  
      ELSE
        BEGIN 
        QUEUE = QSET(DC); 
        QBIT(QUEUE) = 1;
        END 
  
      IF NOT((QACREP$CFO[0] EQ 1) AND (QACREP$CUI[0] EQ O"377777")) 
      THEN                           # CALLED BY USER # 
        BEGIN 
        QAC$FIRST[0] = LOC(USRLINE);
        QAC$IN[0] = LOC(USRLINE) + AJLC/10; 
        QAC$OUT[0] = LOC(USRLINE);
        QAC$LIMIT[0] = LOC(USRLINE) + AJLC/10 + 1;
        QAC$MSGA[0] = TRUE; 
        END 
  
      MQC(LOC(QACPARM));
  
      IF QAC$ERR[0] EQ 0
      THEN
        BEGIN 
        RETURN; 
        END 
  
      IF QAC$ERR[0] EQ BADSTP 
      THEN                           # UNABLE TO DROP JOB # 
        BEGIN 
        MSG(NODROP,SYSUDF1);
  
        IF JSN EQ 0 
        THEN                         # JSN NOT SPECIFIED #
          BEGIN 
          RETURN; 
          END 
        ELSE                         # JSN SPECIFIED #
          BEGIN 
          ABORT;
          END 
        END 
  
      GOTO ENDQAC;                   # PROCESS ERRORS # 
                                               CONTROL EJECT; 
  
# 
*     *GET* FUNCTION. 
# 
  
GETJ:                                # PROCESS *GET* FUNCTION # 
      P<DUMAR> = LOC(QACPARM);
      ZFILL(DUMAR[0],PARML);
      QAC$LFN[0] = LFN; 
      QAC$FCN[0] = GET; 
      QAC$LEN[0] = GETL;
      QAC$JSN[0] = JSN; 
      QAC$LID[0] = TRUE;
      QAC$LIDC[0] = "***";
      QAC$SETJS[0] = TRUE;
      QAC$PRI[0] = TRUE;
      QUEUE = QSET(DC); 
      QBIT(QUEUE) = 1;
      IF C<3,1>QAC$JSN[0] EQ O"0" 
      THEN                           # BLANK-FILL THREE-CHARACTER JSN # 
        BEGIN 
        C<3,1>QAC$JSN[0] = O"55"; 
        END 
  
      MQC(LOC(QACPARM));
  
      IF QAC$ERR[0] EQ 0
      THEN
        BEGIN 
        RETURN; 
        END 
  
      IF QAC$ERR[0] EQ DUPLFN        # DUPLICATE LOCAL FILE NAME #
      THEN
        BEGIN 
        SETNM(QAC$LFN[0],"Z",";",DUPLFNM,MSGLINE);
        MSG(MSGLINE,SYSUDF1); 
        FLAG = DUPLFN;
        RETURN; 
        END 
  
      IF QAC$ERR[0] EQ INVNM
      THEN                           # INCORRECT LFN #
        BEGIN 
        SETNM(LFN,"X",";",INCLFN,MSGLINE);
        MSG(MSGLINE,SYSUDF1); 
        ABORT;
        END 
  
      IF QAC$ERR[0] EQ PRULIMIT 
      THEN                           # PRU LIMIT #
        BEGIN 
        MSG(PRULIM,SYSUDF1);
        FLAG = PRULIMIT;
        RETURN; 
        END 
  
# 
*     END OF *QAC* FUNCTION PROCESSORS. 
# 
  
ENDQAC:                              # PROCESS *QAC* ERROR #
      IF QAC$ERR[0] EQ NOTFND 
      THEN                           # QUEUE FILE NOT FOUND # 
        BEGIN 
        FLAG = NOTFND;
        RETURN; 
        END 
  
SYSERR:                              # UNEXPECTED ERROR # 
      MSG(SYSERROR,SYSUDF1);
      ABORT;
  
      END  # CALLQAC #
  
    TERM
PROC GETNXT;
# TITLE GETNXT - GET NEXT REPLY BUFFER ENTRY.                         # 
  
      BEGIN  # GETNXT # 
  
# 
**    GETNXT - GET NEXT REPLY BUFFER ENTRY. 
* 
*     *GETNXT* WILL RETURN THE NEXT JSN AND THE NEXT UJN FROM THE 
*     CIRCULAR *PEEK* REPLY BUFFER. 
* 
*     PROC GETNXT 
* 
*     ENTRY     THE REPLY BUFFER HAS BEEN FILLED BY *QAC*.
* 
* 
*     EXIT      (NEXTJSN) - NEXT JSN FROM REPLY BUFFER. 
*               (NEXTUJN) - NEXT UJN FROM REPLY BUFFER. 
* 
*     NOTES     THIS PROCEDURE ASSUMES THAT THE REPLY BUFFER LENGTH 
*               (*REPLEN* DEFINED IN *COMUQQC*) HAS BEEN DEFINED AS 
*               A MULTIPLE OF THE ENTRY LENGTH (*QACRETL* DEFINED IN
*               *COMUQQC*). 
# 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECK #
*CALL,COMAMSS 
*CALL,COMUQQC 
                                               CONTROL EJECT; 
  
# 
*     EXTRACT THE NEXT ENTRY INFORMATION AND UPDATE THE BUFFER
*     POINTERS. 
# 
  
  
      IF QAC$OUT[0] EQ QAC$IN[0]
      THEN                           # REPLY BUFFER IS EMPTY #
        BEGIN 
        NEXTJSNI[0] = 0;
        NEXTUJNI[0] = 0;
        RETURN; 
        END 
  
      P<QACREP> = QAC$OUT[0]; 
      NEXTJSN[0] = QACREP$JSN[0]; 
      NEXTUJN[0] = QACREP$UJN[0]; 
      QAC$OUT[0] = QAC$OUT[0] + QACRETL;
      IF QAC$OUT[0] EQ QAC$LIMIT[0] 
      THEN
        BEGIN 
        QAC$OUT[0] = QAC$FIRST[0];
        END 
  
      RETURN; 
      END  # GETNXT # 
  
    TERM
FUNC QSET(DC);
# TITLE QSET - SETS QUEUE TYPE OFFSET ACCORDING TO *DC* PARAMETER.    # 
  
      BEGIN  # QSET # 
  
# 
**    QSET - SETS QUEUE TYPE OFFSET ACCORDING TO *DC* PARAMETER.
* 
*     *QSET* WILL RETURN A NUMBER INDICATING THE QUEUE BIT OFFSET INTO
*     WORD 8 OF THE PARAMETER BLOCK.
* 
*     Y = QSET(DC)
* 
*     ENTRY     (DC) - *DC* PARAMETER INDICATES QUEUE TYPE. 
* 
*     EXIT      (Y) - QUEUE TYPE OFFSET FOR SPECIFIED *DC* PARAMETER. 
# 
  
      ITEM DC         C(2);          # DISPOSITION CODE # 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL,COMAMSS 
*CALL,COMUQQC 
      ITEM I          U;             # INDEX #
  
  
  
  
  
# 
*     FIND THE 6 BIT CODE FIELD FOR THE SPECIFIED DISPOSITION CODE AND
*     EXTRACT THE UPPER 3 BITS. 
# 
  
      SLOWFOR I = QAC$QBITS STEP 1 WHILE I LQ ENDDC 
      DO
        BEGIN  # CHECK *DC* # 
        IF DCITEM$FUL[I] EQ DC
        THEN
          BEGIN 
          QSET = DCITEM$Q[I]; 
          RETURN; 
          END 
  
        END  # CHECK *DC* # 
  
      END  # QSET # 
  
    TERM
PROC RET$JSN(FLAG); 
# TITLE RET$JSN - RETURN JSN FOR A SPECIFIC UJN.                    # 
  
      BEGIN  # RET$JSN #
  
# 
**    RET$JSN - RETURN JSN FOR A SPECIFIED UJN. 
* 
*     *RET$JSN* WILL SEARCH THE SPECIFIED QUEUE(S) FOR THE JSN OR THE 
*     JSN-S THAT BELONG TO THE SPECIFIED UJN. 
* 
*     PROC RET$JSN(FLAG)
* 
*     ENTRY     THE COMMAND ARGUMENTS *JSN*, *UJN* AND *DC* ARE 
*               VALIDATED AND STORED IN ARRAY *QARGUMENTS*. 
* 
*     EXIT      (RETJSN) - JSN THAT BELONGS TO UJN. 
*               (FLAG) - ERROR CODE - ZERO IF NO ERROR. 
* 
*     MESSAGES  * DUPLICATE UJN - MUST SPECIFY JSN. * 
# 
  
      ITEM FLAG       U;             # COMMUNICATION FLAG/CODE #
  
# 
****  PROC RET$JSN - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # CALLS *ABORT* MACRO #
        PROC CALLQAC;                # SETS UP *QAC* CALL # 
        PROC GETNXT;                 # GETS NEXT REPLY BUFFER ENTRY # 
        PROC MSG;                    # CALLS *MESSAGE* MACRO #
        PROC ZFILL;                  # ZERO FILLS BUFFER #
        END 
  
# 
****  PROC RET$JSN - XREF LIST END. 
# 
  
      DEF DUPUJN    #" DUPLICATE UJN - MUST SPECIFY JSN.;"#;
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL,COMAMSS 
*CALL,COMUQPR 
*CALL,COMUQQC 
  
      ITEM I          I;             # LOOP VARIABLE #
      ITEM PEEK$DONE  B;             # *PEEK* DONE FLAG # 
      ITEM STOPS      B;             # *PEEK* SCAN FLAG # 
  
      ARRAY REPBUF [0:0] S(REPLEN);;  # *QAC* REPLY BUFFER #
                                               CONTROL EJECT; 
  
# 
*     SET UP REPLY BUFFER FET POINTERS. 
# 
  
      P<DUMAR> = LOC(QACPARM);
      ZFILL(DUMAR[0],PREFIXL);
  
      QAC$FIRST[0] = LOC(REPBUF[0]);
      QAC$IN[0] = LOC(REPBUF[0]); 
      QAC$OUT[0] = LOC(REPBUF[0]);
      QAC$LIMIT[0] = LOC(REPBUF[0]) + REPLEN; 
  
      PEEK$DONE = FALSE;
      RETJSNI[0] = 0; 
      FLAG = 0; 
  
      REPEAT WHILE NOT PEEK$DONE
      DO
        BEGIN  # CALL *QAC* AND PROCESS REPLY BUFFER #
  
# 
*     SEARCH THE REPLY BUFFER FOR THE JSN THAT BELONGS TO THE 
*     SPECIFIED UJN.
# 
  
        CALLQAC(FCN"PEEK",0,0,QARG$DC[0],PEEK$DONE);
        STOPS = FALSE;
        SLOWFOR I = 0 WHILE NOT STOPS 
        DO
          BEGIN  # SCAN *PEEK* BUFFER # 
          GETNXT; 
          IF NEXTUJNI[0] EQ 0 
          THEN                       # END OF REPLY BUFFER ENTRIES #
            BEGIN 
            STOPS = TRUE; 
            TEST I; 
            END 
  
          IF NEXTUJN[0] EQ QARG$UJ[0] 
          THEN
            BEGIN  # UJN FOUND #
            IF RETJSNI[0] NQ 0 AND QARG$JSI[0] EQ 0 
            THEN                     # DUPLICATE UJN - JSN REQUIRED # 
              BEGIN 
              MSG(DUPUJN,SYSUDF1);
              FLAG = 1;              # INDICATE ERROR OCCURRED #
              RETURN; 
              END 
  
            RETJSN[0] = NEXTJSN[0]; 
            IF QARG$JSI[0] EQ RETJSNI[0]
            THEN                     # JSN/UJN FOUND #
              BEGIN 
              RETURN; 
              END 
  
            END  # UJN FOUND #
  
          END  # SCAN *PEEK* BUFFER # 
  
        END  # CALL *QAC* AND PROCESS REPLY BUFFER #
  
      END  # RETJSN # 
  
    TERM
*WEOR 
          IDENT  MQC
          ENTRY  MQC
          SYSCOM B1 
*COMMENT  MAKE *QAC* CALL.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          SPACE  4,10 
**        FOLLOWING ARE THE *QGET*/*DROP* COMPASS INTERFACE ROUTINES. 
          SPACE  4,10 
**        MQC - MAKE *QAC* CALL.
* 
*         MQC(ADDR);         (SYMPL CALL) 
* 
*         ENTRY  (ADDR) = ADDRESS OF *QAC* PARAMETER BLOCK. 
* 
*         EXIT   *QAC* HAS BEEN CALLED. 
* 
*         USES   X - 1. 
*                A - 1. 
*                B - 1. 
* 
*         MACROS SYSTEM.
          SPACE  4,10 
*         COMMON DECKS. 
  
*CALL,COMCMAC 
  
  
 MQC      SUBR               ENTRY/EXIT 
          SB1    1
          SA1    X1 
          SA2    X1+7 
          MX3    24 
          BX4    X3*X2
          ZR     X4,MQC1     IF JSN NOT SUPPLIED
          MX7    -42
          BX7    -X7*X4 
          NZ     X7,MQC1     IF 4 CHARACTER JSN 
          SX5    1R          BLANK FILL THE JSN 
          LX5    36 
          BX6    X2+X5
          SA6    A2 
 MQC1     SYSTEM QAC,R,X1 
          EQ     MQCX        EXIT 
  
          END 
          IDENT  PKP
          ENTRY  PKP
          SYSCOM B1 
*COMMENT  PROCESS KEYWORD OR POSITIONAL ARGUMENTS.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          SPACE  4,10 
**        PKP - PROCESS KEYWORD OR POSITIONAL ARGUMENTS.
* 
*         PKP(ARGLIST,ARGLEN,FLAG);  (SYMPL CALL) 
* 
*         ENTRY  (ARGLIST) = ADDRESS OF ARGUMENT LIST.
*                (ARGLEN) = LENGTH OF ARGUMENT LIST.
* 
*         EXIT   (FLAG) = ERROR STATUS. 
*                         0 = NO ERROR. 
*                         1 = ERROR.
* 
*         USES   X - 1, 2, 3, 4, 5, 6, 7. 
*                A - 1, 2, 3, 4, 5, 6, 7. 
*                B - 1, 2, 3, 4, 6. 
* 
*         CALLS  ARM, CPA, USB. 
          SPACE  4,10 
*         COMMON DECKS. 
  
*CALL,COMCMAC 
*CALL,COMCARM 
*CALL,COMCCPA 
*CALL,COMCPOP 
*CALL,COMCUSB 
  
 PKP2     SX6    1           SET ERROR FLAG 
          SA5    PKPB 
          SA6    X5 
  
 PKP      SUBR               ENTRY/EXIT 
          SB1    1
          SA3    A1+B1       ADDRESS OF ARGUMENT LENGTH 
          SA4    A3+B1       ADDRESS OF FLAG
          BX6    X4 
          SA6    PKPB        SAVE ADDRESS OF FLAG 
          SA4    X4 
          SA3    X3 
          BX7    X3          SET UP LIST LENGTH 
          SA3    X1 
          BX6    X3          SET UP ARGUMENT LIST 
          SA6    PKPA        SAVE ADDRESS AND LENGTH
          SA7    A6+1 
          SB2    CCDR        UNPACK COMMAND 
          RJ     USB
          SA1    A6          ASSURE TERMINATION 
          SX6    1R.
          SA6    X1+B1
  
*         SKIP TO FIRST ARGUMENT. 
  
 PKP1     SA1    B6          SKIP OVER COMMAND NAME 
          SB6    B6+B1       ADVANCE CHARACTER ADDRESS
          SB2    X1-1R9-1 
          NG     B2,PKP1     IF NOT END OF NAME 
          SB2    X1-1R
          ZR     B2,PKP1     IF A BLANK 
          SB3    X1-1R. 
          SB4    X1-1R) 
          ZR     B3,PKPX     IF NO ARGUMENTS
          ZR     B4,PKPX     IF NO ARGUMENTS
  
*         PROCESS ARGUMENTS.
  
          SA1    PKPA        RETRIEVE ADDRESS AND LENGTH
          SA2    A1+B1
          SB3    X1          ARGUMENT TABLE ADDRESS 
          SB2    X2+
          SB4    ABUF        CONVERT POSITIONAL ARGUMENTS 
          RJ     CPA
          NG     B5,PKP2     IF ARGUMENT ERROR
          SX6    B5+         SET LWA OF ARGUMENTS 
          SB6    ABUF        SET FWA OF ARGUMENTS 
          SA6    USBC 
          RJ     ARM         PROCESS ARGUMENTS
          NZ     X1,PKP2     IF ARGUMENT ERROR
          SX6    B0          NO ERROR 
          SA5    PKPB 
          SA6    X5 
          EQ     PKPX        RETURN 
  
 PKPA     CON    0           ARGUMENT TABLE ADDRESS 
          CON    0           ARGUMENT TABLE LENGTH
 PKPB     BSS    1           FLAG 
 ABUF     BSS    200         UNPACK STRING BUFFER 
          END 
          IDENT  SDA
          ENTRY  SDA
          SYSCOM B1 
*COMMENT  SET UP *DROP* ARGUMENT LIST.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          SPACE  4,15 
**        SDA - SET UP *DROP* ARGUMENT LIST.
* 
*         SDA(DARG);         (SYMPL CALL) 
* 
*         EXIT   (DARG) = ADDRESS OF ARGUMENT LIST. 
* 
*         USES   X - 6. 
*                A - 6. 
*                B - 1. 
* 
*         MACROS ARG. 
          SPACE  4,10 
*         COMMON DECKS. 
  
*CALL     COMCMAC 
  
  
 SDA      SUBR               ENTRY/EXIT 
          SB1    1
          SX6    DARG        ADDRESS OF ARGUMENT LIST 
          SA6    X1 
          SA1    A1+B1
          SX6    DARGL       LENGTH OF ARGUMENT LIST
          SA6    X1+
          EQ     SDAX        EXIT 
  
  
 DARG     BSS    0           *DROP* ARGUMENT LIST 
 JSN      ARG    JS,JS,400B  JOB SEQUENCE NAME
 DC       ARG    DC,DC       DISPOSITION CODE 
 UJN      ARG    UJ,UJ,400B  USER JOB NAME
 OP       ARG    OP,OP       SINGLE REPRIEVE OPTION 
 DARGL    EQU    *-DARG      LENGTH OF ARGUMENT LIST
          ARG                END OF ARGUMENT LIST 
  
*CALL     COMUQPR 
  
          END 
          IDENT  SQA
          ENTRY  SQA
          SYSCOM B1 
*COMMENT  SET UP *QGET* ARGUMENT LIST.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          SPACE  4,15 
**        SQA - SET UP *QGET* ARGUMENT LIST.
* 
*         SQA(QARG);         (SYMPL CALL) 
* 
*         EXIT   (QARG) = ADDRESS OF ARGUMENT LIST. 
* 
*         USES   X - 6. 
*                A - 6. 
*                B - 1. 
* 
*         MACROS ARG. 
          SPACE  4,10 
*         COMMON DECKS. 
  
*CALL     COMCMAC 
  
  
 SQA      SUBR               ENTRY/EXIT 
          SB1    1
          SX6    QARG        ADDRESS OF ARGUMENT LIST 
          SA6    X1 
          SA1    A1+B1
          SX6    QARGL       LENGTH OF ARGUMENT LIST
          SA6    X1+
          EQ     SQAX        EXIT 
  
  
 QARG     BSS    0           *QGET* ARGUMENT LIST 
 JSN      ARG    JS,JS,400B  JOB SEQUENCE NAME
 DC       ARG    DC,DC       DISPOSITION CODE 
 UJN      ARG    UJ,UJ,400B  USER JOB NAME
 FN       ARG    FN,FN,400B  LOCAL FILE NAME
 OP       ARG    OP,OP       NO ABORT OPTION
 DQ       ARG    DQ,DQ,400B  DEQUEUE OPTION 
 QARGL    EQU    *-QARG      LENGTH OF ARGUMENT LIST
          ARG                END OF ARGUMENT LIST 
  
*CALL     COMUQPR 
  
          END 
          IDENT  RFL= 
          ENTRY  RFL= 
*COMMENT  QGET - DEFINE *QGET* *RFL=* VALUE.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          SPACE  4,10 
**        RFL= - DEFINE *QGET* *RFL=* VALUE.
* 
*         THIS ROUTINE GENERATES AN *RFL=* VALUE TO PREVENT MODE
*         ERRORS DURING INSTRUCTION LOOK AHEAD. 
* 
  
  
*         REQUIRED FOR LOADER TO GENERATE ACCURATE LOAD MAPS. 
  
          BSS    1
  
*         REQUIRED TO PREVENT *RFL=* FROM EQUALING XXXX00B OCTAL IF 
*         LAST WORD LOADED IS IN ADDRESS XXXX77B. 
  
          USE    // 
          BSS    8D          FILL 
  
 RFL=     BSS    0           DEFINE ENTRY POINT 
          SPACE  4,10 
          END 
