Quelle  csq4tvd5.cob   Sprache: Cobol

CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
      * ------------------------------------------------------------- *
       IDENTIFICATION DIVISION.
      * ------------------------------------------------------------- *
       PROGRAM-ID. CSQ4TVD5.
      *REMARKS
      *****************************************************************
      *                                                               *
      * @START_COPYRIGHT@                                             *
      *   Statement:     Licensed Materials - Property of IBM         *
      *                                                               *
      *                  5695-137                                     *
      *                  (C) Copyright IBM Corporation. 1993, 1997    *
      *                                                               *
      *   Status:        Version 1 Release 2                          *
      * @END_COPYRIGHT@                                               *
      *                                                               *
      * ************************************************************* *
      *                                                               *
      *  Product Number   : 5695-137                                  *
      *                                                               *
      *  Module Name      : CSQ4TVD5                                  *
      *                                                               *
      *  Environment      : MVS TSO/ISPF; COBOL II                    *
      *                                                               *
      *  Function         : This program provides nickname creation   *
      *                     function for the mail manager sample.     *
      *                     See IBM MQSeries for MVS/ESA              *
      *                     Application Programming Reference,        *
      *                     for further details.                      *
      *                                                               *
      *  Description      : This program will allow the user to define*
      *                     nicknames for users of the system         *
      *                     that are commonly contacted. This program *
      *                     will put all requests on to the           *
      *                     SYSTEM.COMMAND.INPUT queue to be processed*
      *                     by the command server. All replies will   *
      *                     be returned on a temporary dynamic queue  *
      *                     based on the model queue                  *
      *                     SYSTEM.DEFAULT.MODEL.QUEUE.               *
      *                                                               *
      * ************************************************************* *
      *                                                               *
      *                      Program Logic                            *
      *                      -------------                            *
      *                                                               *
      *   Start  (A-MAIN SECTION)                                     *
      *   -----                                                       *
      *       Define required variables to ISPF                       *
      *       Display the create nickname panel (CSQ4VDP5)            *
      *                                                               *
      *       Do while return code form ISPF is zero                  *
      *          Perform VALIDATE-USER-ENTRY                          *
      *          If valid user entry                                  *
      *             Perform CREATE-NICKNAME                           *
      *          End-if                                               *
      *          Update the message variables in the shared pool      *
      *          Display the create nickname panel                    *
      *       End-do                                                  *
      *                                                               *
      *       Return to ISPF                                          *
      *                                                               *
      *                                                               *
      *   VALIDATE-USER-ENTRY SECTION                                 *
      *   ---------------------------                                 *
      *       If no nickname has been entered                         *
      *          Build 'enter valid nickname' message                 *
      *       Else                                                    *
      *          Check that nickname entered starts in the first      *
      *          position of the variable and contains no spaces      *
      *          If check fails                                       *
      *             Build 'enter valid nickname' message              *
      *          Else                                                 *
      *             If no userid has been entered                     *
      *                Build 'Enter valid userid' message             *
      *             Else                                              *
      *                Check that userid entered starts in the first  *
      *                position of the variable and contains no spaces*
      *                If check fails                                 *
      *                   Build 'enter valid userid' message          *
      *                End-if                                         *
      *             End-if                                            *
      *          End-if                                               *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   SET-UP-NICKNAME-FIELDS SECTION                              *
      *   ------------------------------                              *
      *       Put the information from ISPF variables                 *
      *       into the program variables to be used for nickname      *
      *       checking and creation                                   *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   CHECK-NICKNAME SECTION                                      *
      *   ----------------------                                      *
      *       Set the variables for the open call                     *
      *       Open the nickname queue for inquire                     *
      *       If the call is successful                               *
      *          Build 'nickname already exists' message              *
      *       Else                                                    *
      *          If reason for call failure is not unknown object name*
      *             Build error message                               *
      *          Else                                                 *
      *             Set message to spaces                             *
      *          End-if                                               *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   CREATE-NICKNAME SECTION                                     *
      *   -----------------------                                     *
      *       Perform SET-UP-NICKNAME-FIELDS                          *
      *       Perform CHECK-NICKNAME                                  *
      *       Evaluate                                                *
      *          When message not spaces                              *
      *             do nothing (because there is an error)            *
      *          When user has not entered a queue manager name       *
      *             Perform CREATE-ALIAS-QUEUE                        *
      *          Otherwise                                            *
      *             If queue manager name is not local queue manager  *
      *                Perform CREATE-REMOTE-QUEUE                    *
      *             Else                                              *
      *                Perform CREATE-ALIAS-QUEUE                     *
      *             End-if                                            *
      *       End-evaluate                                            *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   CREATE-REMOTE-QUEUE SECTION                                 *
      *   ---------------------------                                 *
      *       Perform CREATE-TEMP-DYNAMIC-QUEUE                       *
      *       If the queue is not created successfully                *
      *          Build an error message                               *
      *          Go to CREATE-REMOTE-QUEUE-EXIT                       *
      *       End-if                                                  *
      *                                                               *
      *       Initialize the variables for the put1 call              *
      *       Put the define queue message on the system command queue*
      *       If the open is not successful                           *
      *          Build an error message                               *
      *       Else                                                    *
      *          Perform GET-COMMAND-SERVER-RESP                      *
      *       End-if                                                  *
      *                                                               *
      *       Perform CLOSE-TEMP-DYNAMIC-QUEUE                        *
      *                                                               *
      *   CREATE-REMOTE-QUEUE-EXIT                                    *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   CREATE-ALIAS-QUEUE SECTION                                  *
      *   --------------------------                                  *
      *       Perform CREATE-TEMP-DYNAMIC-QUEUE                       *
      *       If the queue is not created successfully                *
      *          Build an error message                               *
      *          Go to CREATE-ALIAS-QUEUE-EXIT                        *
      *       End-if                                                  *
      *                                                               *
      *       Initialize the variables for the put1 call              *
      *       Put the define queue message on the system command queue*
      *       If the open is not successful                           *
      *          Build an error message                               *
      *       Else                                                    *
      *          Perform GET-COMMAND-SERVER-RESP                      *
      *       End-if                                                  *
      *                                                               *
      *       Perform CLOSE-TEMP-DYNAMIC-QUEUE                        *
      *                                                               *
      *   CREATE-ALIAS-QUEUE-EXIT                                     *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   CREATE-TEMP-DYNAMIC-QUEUE SECTION                           *
      *   ---------------------------------                           *
      *       Initialize the variables for the open call              *
      *       Create the temporary dynamic queue by opening the model *
      *       queue                                                   *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   GET-COMMAND-SERVER-RESPONSE SECTION                         *
      *   -----------------------------------                         *
      *       Initialize the variables for the get call               *
      *       Do until expected response message received or get fails*
      *          Get the message                                      *
      *          If compcode not ok                                   *
      *             If not no message available                       *
      *                Build an error message                         *
      *             End-if                                            *
      *          Else                                                 *
      *             If expected message received                      *
      *                If queue was created successfully              *
      *                   Set create-worked to Y                      *
      *                Else                                           *
      *                   Set create-worked to N                      *
      *                   Perform GET-ERROR-DETAILS                   *
      *                End-if                                         *
      *             End-if                                            *
      *          End-if                                               *
      *       End-do                                                  *
      *                                                               *
      *       If create queue worked                                  *
      *          Set 'nickname created' message                       *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   CLOSE-TEMP-DYNAMIC-QUEUE SECTION                            *
      *   --------------------------------                            *
      *       Close the queue                                         *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *   GET-ERROR-DETAILS SECTION                                   *
      *   -------------------------                                   *
      *       Initialize the variables for the get call               *
      *       Get the next message from the temporary queue           *
      *       Move the message received to the display message 2 line *
      *                                                               *
      *       Initialize the variables for the get call               *
      *       Get the next message from the temporary queue           *
      *       Move the message received to the display message 3 line *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      * ************************************************************* *
      * ------------------------------------------------------------- *
       ENVIRONMENT DIVISION.
      * ------------------------------------------------------------- *
       DATA DIVISION.
      * ------------------------------------------------------------- *
       WORKING-STORAGE SECTION.
      * ------------------------------------------------------------- *
      *
      *    W00 - General work fields
      *
       01  W00-NICKNAME                PIC X(08)         VALUE SPACES.
       01  W00-USERQ                   PIC X(08)         VALUE SPACES.
       01  W00-VALIDATE                PIC X(01)         VALUE SPACES.
      *
       01  W00-QNAME                   PIC X(48)         VALUE SPACES.
       01  W00-Q-PREFIX                PIC X(17)         VALUE
                                      'CSQ4SAMP.MAILMGR.'.
       01  W00-SYSTEM-REPLY-MODEL      PIC X(26)         VALUE
                                      'SYSTEM.DEFAULT.MODEL.QUEUE'.
       01  W00-SYSTEM-COMMAND-QUEUE    PIC X(20)         VALUE
                                      'SYSTEM.COMMAND.INPUT'.
       01  W00-SYSTEM-REPLY-INITIAL    PIC X(10)         VALUE
                                      'CSQ4SAMP.*'.
      *
       01  W00-GET-WAIT-30SECS         PIC S9(09) BINARY VALUE 30000.
       01  W00-GET-WAIT-2SECS          PIC S9(09) BINARY VALUE 2000.
      *
       01  W00-DEFINE-ALIAS-COMMAND.
           05                          PIC X(14)         VALUE
                                      'DEFINE QALIAS('.
           05  W00-ALIAS-QNAME         PIC X(48).
           05                          PIC X(63)         VALUE
                                      ') LIKE(CSQ4SAMP.MAILMGR.ALIAS.TEM
      -                               'PLATE) TARGQ(CSQ4SAMP.MAILMGR.'.
           05  W00-TARGQ-QNAME         PIC X(08)         VALUE SPACES.
           05                          PIC X             VALUE
                                      ')'.
       01  W00-DEFINE-REMOTE-COMMAND.
           05                          PIC X(16)         VALUE
                                      'DEFINE QREMOTE('.
           05  W00-LOCAL-QNAME         PIC X(48).
           05                          PIC X(63)         VALUE
                                      ') PUT(ENABLED) DEFPRTY(2) DEFPSIS
      -                               'T(YES) RNAME(CSQ4SAMP.MAILMGR.'.
           05  W00-REMOTE-QNAME        PIC X(08)         VALUE SPACES.
           05                          PIC X(10)         VALUE
                                      ') RQMNAME('.
           05  W00-REMOTE-QMGR         PIC X(48)         VALUE SPACES.
           05                          PIC X(08)         VALUE
                                      ') XMITQ('.
           05  W00-XMIT-QNAME          PIC X(48)         VALUE SPACES.
           05                          PIC X             VALUE
                                      ')'.
       01  W00-DEFINE-ALIAS-LENGTH     PIC S9(09) BINARY.
       01  W00-DEFINE-REMOTE-LENGTH    PIC S9(09) BINARY.
       01  W00-REPLY-LENGTH            PIC S9(09) BINARY VALUE 100.
       01  W00-COMMAND-REPLY.
           05  W00-REPLY-NUM           PIC X(08).
           05                          PIC X(26).
           05  W00-RETURN              PIC X(08).
           05                          PIC X(09).
           05  W00-REASON              PIC X(08).
           05                          PIC X(41).
       01  FILLER REDEFINES W00-COMMAND-REPLY.
           05                          PIC X(34).
           05  W00-RETURN-NUM          PIC 9(08).
           05                          PIC X(09).
           05  W00-REASON-NUM          PIC 9(08).
           05                          PIC X(41).
       01  W00-CREATE-WORKED           PIC X.
       01  W00-DATA-LENGTH             PIC S9(09) BINARY.
      *
      *    The following copy book contains messages that will be
      *    displayed to the user
      *
       COPY CSQ4VD0.
      *
      *    ISPF definitions used in this program
      *
       COPY CSQ4VD1.
      *
       01  W01-ALIAS                   PIC X(08)         VALUE
                                      '(ALIAS)'.
       01  W01-CMDMSG1                 PIC X(09)         VALUE
                                      '(CMDMSG1)'.
       01  W01-CMDMSG2                 PIC X(09)         VALUE
                                      '(CMDMSG2)'.
       01  W01-PANEL5                  PIC X(08)         VALUE
                                      'CSQ4VDP5'.
       01  W01-USERQ                   PIC X(08)         VALUE
                                      '(USERQ)'.
      *
      *    ISPF variable definitions used in this program
      *
       COPY CSQ4VD2.
      *
       01  ALIAS                       PIC X(08) VALUE SPACES.
       01  CMDMSG1                     PIC X(79) VALUE SPACES.
       01  CMDMSG2                     PIC X(79) VALUE SPACES.
       01  QMGR                        PIC X(48) VALUE SPACES.
       01  USERQ                       PIC X(08) VALUE SPACES.
      *
      *    W03 - API fields
      *
       01  W03-OPTIONS                 PIC S9(9) BINARY  VALUE ZERO.
       01  W03-HOBJ                    PIC S9(9) BINARY  VALUE ZERO.
      *
      *    API control blocks
      *
       01  MQM-OBJECT-DESCRIPTOR.
           COPY CMQODV SUPPRESS.
       01  MQM-MESSAGE-DESCRIPTOR.
           COPY CMQMDV SUPPRESS.
       01  MQM-PUT-MESSAGE-OPTIONS.
           COPY CMQPMOV SUPPRESS.
       01  MQM-GET-MESSAGE-OPTIONS.
           COPY CMQGMOV SUPPRESS.
      *
      *    Copy book of constants (for filling in the control blocks)
      *    and return codes (for testing the result of a call)
      *
       01  CMQV.
       COPY CMQV SUPPRESS.
           EJECT
      * ------------------------------------------------------------- *
       LINKAGE SECTION.
      * ------------------------------------------------------------- *
           EJECT
      * ------------------------------------------------------------- *
       PROCEDURE DIVISION.
      * ------------------------------------------------------------- *
       A-MAIN SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      * This section initializes the ISPF variables and then displays,*
      * in a loop, the create nickname panel. Once the user has       *
      * entered data a check is made to validate that the nickname    *
      * does not already exist. If it does not exist it               *
      * will be created by sending a message to the system command    *
      * server queue.                                                 *
      *                                                               *
      * Errors are reported to the user. The program terminates when  *
      * a non-zero return code is returned by ISPF.                   *
      *                                                               *
      * ------------------------------------------------------------- *
      *
      *    Define the variables to ISPF
      *    - this also copies current values into the program
      *      of those variables already known to ISPF
      *
           CALL 'ISPLINK' USING  VD1-VDEFINE   W01-ALIAS    ALIAS
                                     VD1-CHAR  VD1-LENGTH8  .
           CALL 'ISPLINK' USING  VD1-VDEFINE   W01-CMDMSG1  CMDMSG1
                                     VD1-CHAR  VD1-LENGTH79  .
           CALL 'ISPLINK' USING  VD1-VDEFINE   W01-CMDMSG2  CMDMSG2
                                     VD1-CHAR  VD1-LENGTH79  .
           CALL 'ISPLINK' USING  VD1-VDEFINE   VD1-QMGR     QMGR
                                     VD1-CHAR  VD1-LENGTH48  .
           CALL 'ISPLINK' USING  VD1-VDEFINE   W01-USERQ    USERQ
                                     VD1-CHAR  VD1-LENGTH8  .
      *
           CALL 'ISPLINK' USING  VD1-VDEFINE   VD1-HCONN    HCONN
                                     VD1-CHAR  VD1-LENGTH4  VD1-COPY  .
           CALL 'ISPLINK' USING  VD1-VDEFINE   VD1-HOBJ     HOBJ
                                     VD1-CHAR  VD1-LENGTH4  VD1-COPY  .
           CALL 'ISPLINK' USING  VD1-VDEFINE   VD1-MSG      MSG
                                     VD1-CHAR  VD1-LENGTH60 VD1-COPY  .
           CALL 'ISPLINK' USING  VD1-VDEFINE   VD1-SUBSYS   SUBSYS
                                     VD1-CHAR  VD1-LENGTH48 VD1-COPY  .
           CALL 'ISPLINK' USING  VD1-VDEFINE   VD1-USERID   USERID
                                     VD1-CHAR  VD1-LENGTH8  VD1-COPY  .
      *
      *    Update the relevant screen fields. If an error occurred
      *    it is recorded in MSG
      *
           MOVE SPACES TO MSG.
           MOVE SPACES TO CMDMSG1.
           MOVE SPACES TO CMDMSG2.
      *
           CALL 'ISPLINK' USING VD1-DISPLAY W01-PANEL5.
      *
      *    Loop from here to END-PERFORM until the PF3 key is pressed
      *    or until an ISPF error occurs
      *
           PERFORM WITH TEST BEFORE UNTIL RETURN-CODE NOT = ZERO
      *
               MOVE SPACES TO MSG
               MOVE SPACES TO CMDMSG1
               MOVE SPACES TO CMDMSG2
      *
               PERFORM VALIDATE-USER-ENTRY
               IF MSG = SPACES THEN
                   PERFORM CREATE-NICKNAME
               END-IF
      *
               CALL 'ISPLINK' USING VD1-VPUT VD1-MSG
               CALL 'ISPLINK' USING VD1-VPUT W01-CMDMSG1
               CALL 'ISPLINK' USING VD1-VPUT W01-CMDMSG2
      *
               CALL 'ISPLINK' USING VD1-DISPLAY W01-PANEL5
      *
           END-PERFORM.
      *
       A-MAIN-EXIT.
      *
      *    Return to ISPF
      *
           STOP RUN.
           EJECT
      *
      * ------------------------------------------------------------- *
       VALIDATE-USER-ENTRY SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section validates that both alias and user mail queue  *
      *  names have been entered.                                    *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           IF ((ALIAS = SPACES) OR (ALIAS = LOW-VALUES)) THEN
              MOVE VD0-MESSAGE-10 TO MSG
           ELSE
              MOVE SPACES TO W00-NICKNAME W00-VALIDATE
              UNSTRING ALIAS DELIMITED BY ALL SPACE
                                INTO W00-NICKNAME W00-VALIDATE
              IF ((W00-NICKNAME = SPACES) OR
                  (W00-VALIDATE NOT = SPACE))
                  MOVE VD0-MESSAGE-10 TO MSG
              ELSE
                  IF  ((USERQ = SPACES) OR
                       (USERQ = LOW-VALUES)) THEN
                      MOVE VD0-MESSAGE-11     TO MSG
                  ELSE
                      MOVE SPACES TO W00-USERQ W00-VALIDATE
                      UNSTRING USERQ DELIMITED BY ALL SPACE
                                        INTO W00-USERQ W00-VALIDATE
                      IF ((W00-NICKNAME = SPACES) OR
                          (W00-VALIDATE NOT = SPACE))
                          MOVE VD0-MESSAGE-11 TO MSG
                      END-IF
                  END-IF
              END-IF
           END-IF.
      *
       VALIDATE-USER-ENTRY-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       SET-UP-NICKNAME-FIELDS SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section puts the information from ISPF variables        *
      * into the program variables to be used for nickname           *
      * checking and creation.                                       *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           MOVE USERQ     TO W00-TARGQ-QNAME
                             W00-REMOTE-QNAME.
           MOVE QMGR      TO W00-REMOTE-QMGR
                             W00-XMIT-QNAME.
      *
           MOVE SPACES    TO W00-QNAME.
           STRING W00-Q-PREFIX USERID '.' ALIAS
                        DELIMITED BY SPACES
                        INTO W00-QNAME.
      *
           MOVE W00-QNAME TO W00-ALIAS-QNAME
                             W00-LOCAL-QNAME.
      *
      *
       SET-UP-NICKNAME-FIELDS-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CREATE-NICKNAME SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section checks whether the nickname to be created       *
      * already exists, if it does the program returns to the        *
      * calling section. Otherwise a nickname will be created.       *
      *                                                              *
      * If the target queue is on the local queue manager, an alias  *
      * queue is created by performing CREATE-ALIAS-QUEUE. If the    *
      * target queue is on another queue manager, a remote queue     *
      * is created by performing CREATE-REMOTE-QUEUE.                *
      *                                                              *
      * Error messages are set by performed sections and displayed   *
      * by the performing section.                                   *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           PERFORM SET-UP-NICKNAME-FIELDS.
      *
           PERFORM CHECK-NICKNAME.
      *
           EVALUATE TRUE
               WHEN MSG NOT = SPACES
      *            we have an error - so report it
                   CONTINUE
      *            we have no error - so lets do the processing
               WHEN QMGR = SPACES
               WHEN QMGR = LOW-VALUES
                       PERFORM CREATE-ALIAS-QUEUE
      *
               WHEN OTHER
                   IF (QMGR NOT = SUBSYS)
                       PERFORM CREATE-REMOTE-QUEUE
                   ELSE
                       PERFORM CREATE-ALIAS-QUEUE
                   END-IF
      *
           END-EVALUATE.
      *
       CREATE-NICKNAME-EXIT.
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CHECK-NICKNAME SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section checks whether a nickname exists by trying to   *
      * open the queue corresponding to the nickname for inquiry.    *
      *                                                              *
      * If the open fails for unknown object name the nickname does  *
      * not exist (so no error message is set). If the open succeeds *
      * or fails for any other reason an error message is set for    *
      * display to the user by the calling section.  If the          *
      * queue was opened it is closed.                               *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *    Set up the MQSeries API control blocks.
      *    Apart from the following values, all other values in the
      *    control blocks will be set to their default values
      *
           MOVE MQOT-Q          TO MQOD-OBJECTTYPE.
           MOVE W00-QNAME       TO MQOD-OBJECTNAME.
      *
      *    W03-OPTIONS is set to open the queue for INQUIRE
      *           NOTE: The open option is irrelevant to this
      *                 program. The open is only used to
      *                 validate if the nickname already
      *                 exists
      *
           MOVE MQOO-INQUIRE TO W03-OPTIONS.
      *
      *    Open the queue
      *
           CALL 'MQOPEN' USING HCONN
                               MQOD
                               W03-OPTIONS
                               W03-HOBJ
                               COMPCODE
                               REASON.
      *
      *    Test the output of the open call.
      *
      *    If the open succeeds, the queue already exists. Move an
      *    error message to the panel, close the queue.
      *
      *    If the open fails and the reason is not UNKNOWN-OBJECT-NAME
      *    move an error message showing the completion and reason codes
      *    to the panel.
      *
      *    If the open fails with UNKNOWN-OBJECT-NAME, set the message
      *    to blanks
      *
           IF COMPCODE = MQCC-OK THEN
               MOVE VD0-MESSAGE-12 TO MSG
               CALL 'MQCLOSE' USING HCONN
                                    W03-HOBJ
                                    MQCO-NONE
                                    COMPCODE
                                    REASON
           ELSE
               IF (REASON NOT = MQRC-UNKNOWN-OBJECT-NAME) THEN
                   MOVE 'OPEN NICKQ'     TO VD0-MSG1-TYPE
                   MOVE COMPCODE         TO VD0-MSG1-COMPCODE
                   MOVE REASON           TO VD0-MSG1-REASON
                   MOVE VD0-MESSAGE-1    TO MSG
               ELSE
                   MOVE SPACES TO MSG
              END-IF
           END-IF.
      *
       CHECK-NICKNAME-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CREATE-REMOTE-QUEUE SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section creates a remote queue by sending a command to  *
      * the queue manager system command input queue.  A temporary   *
      * dynamic queue is created to receive the command server       *
      * responses and these responses are checked to determine if    *
      * the queue has been successfully created.                     *
      * Status and error messages are prepared for display by the    *
      * calling section.                                             *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           PERFORM CREATE-TEMP-DYNAMIC-QUEUE.
      *
      *    Test the output of the open call.  If the call failed,
      *    build an error message showing the completion code and
      *    reason, and return to the performing section
      *    to allow it to be displayed
      *
           IF (COMPCODE NOT = MQCC-OK) THEN
              MOVE 'OPEN TEMPQ'  TO VD0-MSG1-TYPE
              MOVE COMPCODE      TO VD0-MSG1-COMPCODE
              MOVE REASON        TO VD0-MSG1-REASON
              MOVE VD0-MESSAGE-1 TO MSG
              GO TO CREATE-REMOTE-QUEUE-EXIT
           END-IF.
      *
      *    Save the queue name and also place it in the REPLYTOQ field.
      *    Use the REQUEST message type to ensure that the Command
      *    Server sends back all reply messages. The define remote queue
      *    message is then written to the SYSTEM-COMMAND-INPUT queue to
      *    be processed
      *
           MOVE MQOD-OBJECTNAME          TO MQMD-REPLYTOQ.
           MOVE MQMT-REQUEST             TO MQMD-MSGTYPE.
           MOVE MQPER-NOT-PERSISTENT     TO MQMD-PERSISTENCE.
           MOVE MQOT-Q                   TO MQOD-OBJECTTYPE.
           MOVE W00-SYSTEM-COMMAND-QUEUE TO MQOD-OBJECTNAME.
      *
           MOVE MQPMO-NO-SYNCPOINT       TO MQPMO-OPTIONS.
      *
           MOVE LENGTH OF W00-DEFINE-REMOTE-COMMAND
                                         TO W00-DEFINE-REMOTE-LENGTH.
      *
      *    Put the define remote command
      *
           CALL 'MQPUT1' USING HCONN
                               MQOD
                               MQMD
                               MQPMO
                               W00-DEFINE-REMOTE-LENGTH
                               W00-DEFINE-REMOTE-COMMAND
                               COMPCODE
                               REASON.
      *
      *    If the compcode is not OK after the PUT1 request
      *    display an error message and return
      *
           IF (COMPCODE NOT = MQCC-OK) THEN
               MOVE 'MQPUT1-R '  TO VD0-MSG1-TYPE
               MOVE COMPCODE      TO VD0-MSG1-COMPCODE
               MOVE REASON        TO VD0-MSG1-REASON
               MOVE VD0-MESSAGE-1 TO MSG
           ELSE
               PERFORM GET-COMMAND-SERVER-RESP
      *
      *        The response messages are set in the function, no
      *        testing is done after return
      *
           END-IF.
      *
           PERFORM CLOSE-TEMP-DYNAMIC-QUEUE.
      *
       CREATE-REMOTE-QUEUE-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CREATE-ALIAS-QUEUE SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section creates an alias queue by sending a command to  *
      * the queue manager system command input queue.  A temporary   *
      * dynamic queue is created to receive the command server       *
      * responses and these responses are checked to determine if    *
      * the queue has been successfully created.                     *
      * Status and error messages are prepared for display by the    *
      * performing section.                                          *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           PERFORM CREATE-TEMP-DYNAMIC-QUEUE.
      *
      *    Test the output of the open call.  If the call failed,
      *    build an error message showing the completion code and
      *    reason, and return to the performing section
      *    to allow it to be displayed
      *
           IF (COMPCODE NOT = MQCC-OK) THEN
              MOVE 'OPEN TEMPQ'  TO VD0-MSG1-TYPE
              MOVE COMPCODE      TO VD0-MSG1-COMPCODE
              MOVE REASON        TO VD0-MSG1-REASON
              MOVE VD0-MESSAGE-1 TO MSG
              GO TO CREATE-ALIAS-QUEUE-EXIT
           END-IF.
      *
      *    Save the queue name and also place it in the REPLYTOQ field.
      *    Use the REQUEST message type to ensure that the Command
      *    Server sends back all reply messages. The define alias queue
      *    message is then written to the SYSTEM-COMMAND-INPUT queue to
      *    be processed
      *
           MOVE MQOD-OBJECTNAME          TO MQMD-REPLYTOQ.
           MOVE MQMT-REQUEST             TO MQMD-MSGTYPE.
           MOVE MQPER-NOT-PERSISTENT     TO MQMD-PERSISTENCE.
           MOVE MQOT-Q                   TO MQOD-OBJECTTYPE.
           MOVE W00-SYSTEM-COMMAND-QUEUE TO MQOD-OBJECTNAME.
      *
           MOVE MQPMO-NO-SYNCPOINT       TO MQPMO-OPTIONS.
      *
           MOVE LENGTH OF W00-DEFINE-ALIAS-COMMAND
                                         TO W00-DEFINE-ALIAS-LENGTH.
      *
      *    Put the define alias command
      *
           CALL 'MQPUT1' USING HCONN
                               MQOD
                               MQMD
                               MQPMO
                               W00-DEFINE-ALIAS-LENGTH
                               W00-DEFINE-ALIAS-COMMAND
                               COMPCODE
                               REASON.
      *
      *    If the compcode is not OK after the PUT1 request
      *    display an error message and return
      *
           IF (COMPCODE NOT = MQCC-OK) THEN
               MOVE 'MQPUT1-A '  TO VD0-MSG1-TYPE
               MOVE COMPCODE      TO VD0-MSG1-COMPCODE
               MOVE REASON        TO VD0-MSG1-REASON
               MOVE VD0-MESSAGE-1 TO MSG
           ELSE
               PERFORM GET-COMMAND-SERVER-RESP
      *
      *        The response messages are set in the function, no
      *        testing is done after return
      *
           END-IF.
      *
           PERFORM CLOSE-TEMP-DYNAMIC-QUEUE.
      *
       CREATE-ALIAS-QUEUE-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CREATE-TEMP-DYNAMIC-QUEUE SECTION.
      * ------------------------------------------------------------- *
      * This section creates a temporary dynamic queue using a       *
      * model queue.                                                 *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *    Initialize the Object Descriptor (MQOD) control block.
      *    (The remaining fields are already initialized)
      *
      *    OBJECTNAME   - Contains the name of the model queue that is
      *                   to be used to create the temporary dynamic
      *                   queue name.
      *    DYNAMICQNAME - Contains the characters that the queue name
      *                   is to begin with.
      *
           MOVE MQOT-Q                   TO MQOD-OBJECTTYPE.
           MOVE W00-SYSTEM-REPLY-MODEL   TO MQOD-OBJECTNAME.
           MOVE W00-SYSTEM-REPLY-INITIAL TO MQOD-DYNAMICQNAME.
           MOVE ZERO                     TO W03-HOBJ.
           MOVE MQOO-INPUT-AS-Q-DEF      TO W03-OPTIONS.
      *
      *    Open the queue and, therefore, create the queue
      *
           CALL 'MQOPEN' USING HCONN
                               MQOD
                               W03-OPTIONS
                               W03-HOBJ
                               COMPCODE
                               REASON.
      *
       CREATE-TEMP-DYNAMIC-QUEUE-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
      *
      * ------------------------------------------------------------- *
       GET-COMMAND-SERVER-RESP SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section gets the command server responses in a loop     *
      * until the right message (CSQN205I) arrives or an error       *
      * occurs.                                                      *
      * When the message is received it is checked to see if the     *
      * queue creation was successful - if it was an appropriate     *
      * message is prepared for display by the calling section,      *
      * otherwise GET-ERROR-DETAILS is called to get the reasons     *
      * for the error.                                               *
      * If any errors occur, appropriate messages are prepared for   *
      * display by the calling section.                              *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *    Set up the options for the get-wait call
      *
           MOVE MQGMO-ACCEPT-TRUNCATED-MSG TO MQGMO-OPTIONS.
           ADD  MQGMO-WAIT                 TO MQGMO-OPTIONS.
           ADD  MQGMO-NO-SYNCPOINT         TO MQGMO-OPTIONS.
      *
           MOVE W00-GET-WAIT-30SECS        TO MQGMO-WAITINTERVAL.
      *
      *    Loop around until an error occurs or until the right
      *    message arrives
      *
           MOVE SPACES TO W00-CREATE-WORKED
           PERFORM WITH TEST AFTER UNTIL ((COMPCODE NOT = MQCC-OK) OR
                                     (W00-CREATE-WORKED NOT = SPACES))
      *
               MOVE MQMI-NONE  TO MQMD-MSGID
               MOVE MQCI-NONE  TO MQMD-CORRELID
               MOVE SPACES     TO W00-COMMAND-REPLY
      *
               CALL 'MQGET' USING HCONN
                                  W03-HOBJ
                                  MQMD
                                  MQGMO
                                  W00-REPLY-LENGTH
                                  W00-COMMAND-REPLY
                                  W00-DATA-LENGTH
                                  COMPCODE
                                  REASON
      *
      *        If the compcode is not OK after the get, and the reason
      *        is not NO-MSG-AVAILABLE, build an error message.
      *        If the reason is NO-MSG-AVAILABLE just exit the loop.
      *        Otherwise each message is checked to locate the command
      *        server reply (CSQN205I). When this is located the return
      *        code is checked. Depending on the return code received
      *        the create worked flag is set. If the create failed,
      *        the error details are retrieved and built for display
      *
               IF (COMPCODE NOT = MQCC-OK) THEN
                   IF (REASON NOT = MQRC-NO-MSG-AVAILABLE) THEN
                       MOVE 'MQGET '  TO VD0-MSG1-TYPE
                       MOVE COMPCODE      TO VD0-MSG1-COMPCODE
                       MOVE REASON        TO VD0-MSG1-REASON
                       MOVE VD0-MESSAGE-1 TO MSG
                       MOVE 'N'           TO W00-CREATE-WORKED
                   END-IF
               ELSE
                   IF W00-REPLY-NUM = 'CSQN205I' THEN
      *        Validate the response from the create queue section.
      *        Move either a 'success' or 'fail' message to the panel
      *        dependant on W00-CREATE-WORKED
      *
                       IF W00-RETURN = '00000000' THEN
                           MOVE 'Y' TO W00-CREATE-WORKED
                           MOVE VD0-MESSAGE-14 TO MSG
                       ELSE
                           MOVE 'N' TO W00-CREATE-WORKED
                           MOVE VD0-MESSAGE-13 TO MSG
      *
      *                    The next two messages should contain
      *                    details of the failure. GET-ERROR-DETAILS
      *                    puts them in the screen message fields
      *
                           PERFORM GET-ERROR-DETAILS
      *
                       END-IF
                   END-IF
               END-IF
      *
           END-PERFORM.
      *
           IF W00-CREATE-WORKED = SPACES THEN
               MOVE VD0-MESSAGE-26 TO MSG
           END-IF.
      *
       GET-COMMAND-SERVER-RESP-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
      *
      * ------------------------------------------------------------- *
       CLOSE-TEMP-DYNAMIC-QUEUE SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section closes, and thus deletes, the temporary         *
      * dynamic queue.                                               *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *
      *    Close the reply queue and purge it
      *
           CALL 'MQCLOSE' USING HCONN
                                W03-HOBJ
                                MQCO-NONE
                                COMPCODE
                                REASON.
      *
       CLOSE-TEMP-DYNAMIC-QUEUE-EXIT.
      *
      *
      *    Return to performing section
      *
           EXIT.
      *
      * ------------------------------------------------------------- *
       GET-ERROR-DETAILS SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section get two messages from the queue and puts the    *
      * message data into message fields for display by the calling  *
      * section. If errors occur in getting these messages, no       *
      * additional data will be available to the user.  No error     *
      * checking is done on the calls.                               *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *    Get the next message on the queue which should
      *    contain a displayable message of what went wrong
      *
           MOVE W00-GET-WAIT-2SECS TO MQGMO-WAITINTERVAL.
           MOVE MQMI-NONE          TO MQMD-MSGID.
           MOVE MQCI-NONE          TO MQMD-CORRELID.
           MOVE SPACES             TO W00-COMMAND-REPLY.
      *
           CALL 'MQGET' USING HCONN
                              W03-HOBJ
                              MQMD
                              MQGMO
                              W00-REPLY-LENGTH
                              W00-COMMAND-REPLY
                              W00-DATA-LENGTH
                              COMPCODE
                              REASON.
      *
           MOVE W00-COMMAND-REPLY TO CMDMSG1.
      *
      *    Get the next message on the queue which should
      *    contain another displayable message of what went wrong
      *
           MOVE MQMI-NONE  TO MQMD-MSGID.
           MOVE MQCI-NONE  TO MQMD-CORRELID.
           MOVE SPACES     TO W00-COMMAND-REPLY.
      *
           CALL 'MQGET' USING HCONN
                              W03-HOBJ
                              MQMD
                              MQGMO
                              W00-REPLY-LENGTH
                              W00-COMMAND-REPLY
                              W00-DATA-LENGTH
                              COMPCODE
                              REASON.
      *
           MOVE W00-COMMAND-REPLY TO CMDMSG2.
      *
      *
       GET-ERROR-DETAILS-EXIT.
      *
      *
      *    Return to performing section
      *
           EXIT.
      *
      * ---------------------------------------------------------------
      *                  End of program
      * ---------------------------------------------------------------