)MSG DFS996I
/*---------Language: OPS/MVS RULES----------------------------$$PROLOG*/
/*  Program Name: DFS996I                                             */
/*   Description: This rule will process the IMS WTOR msg and issue   */
/*                the next IMS command, if any are queued for         */
/*                delivery to IMS.  If not, the queue is unlocked.    */
/*       Related: IMSCMD REXX program.                                */
/* 56 DFS996I *IMS READY*  IMST                                       */
/*    Change log: Add new entries to the top                          */
/*-----------------Changed 03/17/1999 by: Bob Stark --------------1.0-*/
/* 1. Cleanup for release of version 1.0                              */
/*-----------------Changed 08/16/1998 by: Bob Stark ------------------*/
/* 1. Reworked locking logic to eliminate window during Compare&Update*/
/*    loop.                                                           */
/*-----------------Changed 08/13/1998 by: Bob Stark ------------------*/
/* 1. Changed to not re-lock the queue if cmd is waiting for response.*/
/* 2. Removed all additional ADDRESS OPER parms.                      */
/*-----------------Changed 07/20/1998 by: Bob Stark ------------------*/
/* 1. Initial coding                                                  */
/*--------------------------------------------------------------------*/
/* Copyright (C) 1999 ProTech Professional Technical Services. No war-*/
/* ranty expressed or implied. Permission to use, copy, and distribute*/
/* this document without fee is hereby granted, provided that this    */
/* copyright notice appear in all copies.  Permission to modify the   */
/* code is granted, but not the right to distribute the modified code,*/
/* which should be returned to the maintainer for inclusion into the  */
/* distributed version.  Contacts: 412-373-8855  www.protechpts.com   */
/*--------------------------------------------------------------------*/
)PROC
TRACE N
imsid = msg.imsid
IF DATATYPE(msg.replyid) <> 'NUM'     /* Just make sure this is a WTOR*/
THEN return                           /* It's not, hmmmm, better bail */

/*--------------------------------------------------------------------*/
/* Check to make sure that this is the same IMS region we processed   */
/* last msg.  If not, clear out the pending command queue, so we      */
/* don't issue old commands to a brand new IMS.                       */
/*--------------------------------------------------------------------*/
glvname = 'GLOBAL0.IMSCMD.'imsid'.ASID' /* IMS addr space id varname  */
updated = 0                           /* Variable not updated (yet)   */
  DO i = 1 BY 1 UNTIL updated = 1     /* Spin until update succeeds   */
  current = OPSVALUE(glvname,'V')     /* Get current value or name.   */
  IF C2X(OPSINFO('ASID')) = current
  THEN LEAVE i
  updated = OPSVALUE(glvname,'C',C2X(OPSINFO('ASID')),current)
  END i

glvname = 'GLOBAL0.IMSCMD.'imsid'.Q'  /* IMS status variable name     */
IF updated = 1 THEN                   /* Is this a new region?        */
  DO i = 1 BY 1 UNTIL updated = 1     /* Yes, trash the existing queue*/
  current = OPSVALUE(glvname,'N')     /* Get current value            */
  updated = OPSVALUE(glvname,'C',msg.replyid,current)
  END i

updated = 0                           /* Variable not updated (yet)   */

  DO i = 1 BY 1 UNTIL updated = 1     /* Spin until update succeeds   */
  /* Get current value and parse into several variables               */
  PARSE VALUE OPSVALUE(glvname,'N') WITH ,
    current 1 . allcmds 1 . nextcmd '$EOT$' morecmds
  new = msg.replyid' 'allcmds         /* Assume we're just unlocking  */
  IF nextcmd <> '' THEN               /* Cmd is queued, examine it    */
    DO
    IF POS('CMDWAIT(0)',nextcmd) > 0  /* Will issuer want a response? */
    THEN new = '-'msg.replyid' 'morecmds /* No, take nextcmd from q   */
    ELSE nextcmd = ''                    /* Yes, let him issue it     */
    END
  updated = OPSVALUE(GLVNAME,'C',new,current)
  END i

IF nextcmd <> '' THEN              /* Did we find a cmd to issue?     */
  DO                               /* Yes.  Now issue it.             */
  /*------------------------------------------------------------------*/
  /* But first, we have to remove any CMDWAIT() parm from the command,*/
  /* because OPS thinks you are trying to wait in a rule, even though */
  /* the wait time is zero.                                           */
  /* Also can't issue ADDRESS OPER w/ IMSID(xx) in a rule because it  */
  /* checks inline to see if the WTOR is outstanding, and it isn't,   */
  /* because we are processing it- after we're done, it will go onto  */
  /* the console address space, and show up in a D R,R display.       */
  /*------------------------------------------------------------------*/
  PARSE VAR nextcmd nextcmd "COMMAND('" text "')" right
  nextcmd = "COMMAND('R "msg.replyid","text"') "

  ADDRESS OPER nextcmd
  IF rc <> 0                       /* If bad retcode, issue warning.  */
  THEN CALL WARNMSG 'ADDRESS OPER 'nextcmd' FAILED RC='rc
  RETURN 'SUPPRESS'                /* Suppress msg to quiet console   */
  END

IF allcmds = ''                    /* Any cmds pending?               */
THEN RETURN                        /* No, allow msg to display        */
RETURN 'SUPPRESS'                  /* Suppress msg to quiet console   */

/*RXCOPY WARNMSG **** 21 LINES COPIED ON 03-16-99 AT 15:52*************/
/*-Start of WARNMSG function----------------------------Version-01.02-*/
/*:WARNMSG SUBROUTINE: Issues a formatted warning message and returns */
/* Parameters: Message text                                           */
/* For example:                                                       */
/* IF missing <> ''                                                   */
/* then call WARNMSG('Missing required parameter(s):'missing)         */
/* Copyright (C) 1996, 1998 Washington Systems. All rights reserved.  */
/*--------------------------------------------------------------------*/
WARNMSG: PROCEDURE EXPOSE gbl.
TRACE N
PARSE ARG msgtext
parse source . . filename .
errtext = 'REXX Warning: 'filename' 'msgtext
SAY errtext
IF ADDRESS() = 'AXC' THEN
  DO
  ADDRESS AXC "WTXC '"errtext"'"
  ADDRESS AXC "WTO '"errtext"'"
  END
RETURN
/*-End of WARNMSG  subroutine-----------------------------------------*/