/*---------Language: REXX-------------------------------------$$PROLOG*/ /* Program Name: IMSCMDQA */ /* Description: QA Test / demo / IVP routine for IMSCMD */ /* Customization: See >>>CUSTOMIZE HERE<<<, below */ /* Invokes: IMSCMD */ /* Return Codes: 0 - Successful Completion */ /* Related Routines: */ /* Base Release: CA-OPS/MVS 4.2 */ /* Restrictions: None */ /* Dependencies: None */ /* Change log: Add new entries to the top */ /*-----------------Changed 03/17/1999 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 */ /*--------------------------------------------------------------------*/ CALL ON ERROR NAME RXERROR SIGNAL ON SYNTAX NAME RXERROR SIGNAL ON NOVALUE NAME RXERROR /* >>>CUSTOMIZE HERE<<< */ imsid = 'IMST' /* IMSID to send commands to */ /*--------------------------------------------------------------------*/ /* This first call type works reliably in TSO/E REXX. */ /*--------------------------------------------------------------------*/ INTERPRET IMSCMD("'/DIS Q TRANS' IMS("imsid") CMDWAIT(15)", "CMDRESP(REXX) DEBUG") SAY 'rc = 'rc DO i = 0 TO CMDOUT.0; SAY i cmdout.i; save.i = cmdout.i; END i /*--------------------------------------------------------------------*/ /* If running in OPS/REXX, and the IMSCMD response is large, parse it */ /* it apart and interpret it one clause at a time, as shown below. */ /*--------------------------------------------------------------------*/ result = IMSCMD("'/DIS A' IMS(IMST) CMDWAIT(20) CMDRESP(REXX) ") DO WHILE result <> '' PARSE VAR result clause ';' result INTERPRET clause END SAY 'rc = 'rc DO i = 0 TO CMDOUT.0; SAY i cmdout.i; save.i = cmdout.i; END i SIGNAL EXIT EXIT:EXIT 0 /*RXCOPY RXERROR **** 122 LINES COPIED ON 03-17-99 AT 11:18************/ /*START OF RXERROR--------------------------------------Version-01.05-*/ /*:RXERROR SUBROUTINE: Generic REXX error condition handler. This */ /* routine gets control when a condition is raised, and: */ /* a. Validates that the condition is ok, and returns quietly, or */ /* b. Issues diagnostic messages about the error & where it occured. */ /* */ /* To use this routine, code the following near the top of your exec: */ /* CALL ON ERROR NAME RXERROR */ /* SIGNAL ON SYNTAX NAME RXERROR */ /* SIGNAL ON NOVALUE NAME RXERROR */ /* */ /* In addition, set the variable 'ok' to any return code values */ /* that are acceptable for host commands. For example: */ /* */ /* ok=4; ADDRESS TSO 'GETVARL GLOBAL_*'; DROP ok */ /* ok='4 8';"host cmd"; DROP ok <-- return codes 4 or 8 are ok */ /* ok='all';"host cmd"; DROP ok <-- all return codes are acceptable */ /* */ /* The first example permits GETVARL to get rc 4 and not fail or */ /* issue any error messages. Note that "ok=0" is always implied */ /* because the REXX ERROR condition is not raised if rc=0. */ /*------------------------------------------------------------------- */ /*NOTES: This subroutine does not use the PROCEDURE instruction, so */ /* variable names used within it must be _hidden. */ /* */ /* If an error occurs that's not one of the 'OK' values, */ /* execution will fall thru this subroutine and any statements */ /* following it will be executed. This is a good place to put */ /* cleanup logic, or a signal to your "cleanup-and-exit" label. */ /* */ /* As a side effect, RXERROR sets ISPF "CONTROL ERRORS RETURN". */ /* If your routine doesn't run this way, you'll need to restore */ /* your ISPF CONTROL ERRORS setting. */ /* Copyright (C) 1996,1998 Washington Systems. All rights reserved. */ /*--------------------------------------------------------------------*/ RXERROR: TRACE N /* Turn off tracing for this func. */ _sigl = sigl CALL OFF ERROR SIGNAL OFF SYNTAX IF SYMBOL('rc') = 'VAR' THEN _rc = rc ELSE _rc = 'n/a' PARSE SOURCE _EX_ENV . _EX_NAME . . . . _EX_ADDRSPC . IF POS(CONDITION('C'),'ERROR FAILURE') > 0 THEN /* Error or Failure? */ /* Yes. Were we CALLed? */ IF CONDITION('I') = 'CALL' | _EX_ENV = 'OPS/REXX' THEN IF SYMBOL('OK') = 'VAR' THEN /* Yes. Is OK a variable? */ IF WORDPOS(_rc,ok)>0 | TRANSLATE(ok)='ALL' THEN /* Is error ok? */ DO /* Yes, return */ CALL ON ERROR NAME RXERROR /* Restore the */ SIGNAL ON SYNTAX NAME RXERROR /* Error handler */ DROP ZERRLM /* Toss any ISPF error msg */ rc = _rc /* Restore orig RC for caller */ RETURN /* Return to point of error */ END _errtext = ''; /* Initialize error text */ IF CONDITION('C') = 'SYNTAX' THEN /* If a REXX syntax error, */ IF _rc >= 0 & _rc < 100 /* and rc is within valid range, */ THEN _errtext = ' ('ERRORTEXT(_rc)')';/* then get REXX error text. */ ELSE NOP; ELSE IF CONDITION('C') = 'NOVALUE' THEN /* See if undefined variable */ DO; _errtext = ' (No value for variable 'CONDITION('D')')'; _rc = 'n/a'; /* RC not set for NOVALUE */ END ELSE IF POS(CONDITION('C'),'ERROR FAILURE') > 0 THEN /*Hostcmd problem?*/ DO /* Extract host cmd name... */ _cmd = STRIP(STRIP(WORD(CONDITION('D'),1),'B','"'),'B',"'") _errtext = ' (Host command '_cmd')' _addr = ADDRESS() /* Find environment of failing cmd */ IF _sigl <= SOURCELINE() THEN/* Is source code avail? */ IF TRANSLATE(WORD(SOURCELINE(_sigl),1)) = 'ADDRESS' THEN _addr = TRANSLATE(WORD(SOURCELINE(_sigl),2)) _addr = STRIP(TRANSLATE(_addr,,'!@#$%&*()_-+=;:,./?"'"'",' ')) IF _addr = 'PPQ' & SYMBOL('PPQ.ERROR') = 'VAR' THEN _errtext = ' (Host command PPQ, 'ppq.error')' IF _addr = 'VOX' & SYMBOL('VOX.ERROR') = 'VAR' THEN _errtext = ' (Host command VOX, 'vox.error')' IF _addr = 'ASODDE' | SYMBOL('ASODDE.ERROR') = 'VAR' THEN _errtext = ' (Host command ASODDE, 'asodde.error')' IF SYMBOL('SQLCODE') = 'VAR' THEN _errtext = ' ( SQLCODE=' sqlcode')' END ELSE _errtext = ' (Condition='CONDITION('C')', Description=', CONDITION('D')')' IF _ex_addrspc = 'ISPF' THEN /* Running under ISPF? */ DO /* Yes, issue short & long msgs... */ ADDRESS ISPEXEC "CONTROL ERRORS RETURN" /* Capture all ISPF RCs */ zedsmsg = '' /* Format ISPF short message */ zedlmsg = "Error RC "_rc""_errtext" at line "_sigl" in EXEC" _EX_NAME IF _sigl <= SOURCELINE() /* Is source code avail? */ THEN zedlmsg = LEFT(zedlmsg': ',78)STRIP(SOURCELINE(_sigl)) IF SYMBOL('ZERRLM') = 'VAR' THEN zedlmsg = LEFT(zedlmsg,156) 'ISPF Error: 'STRIP(ZERRLM) ADDRESS ISPEXEC "SETMSG MSG(ISRZ001)" IF rc = 12 THEN /* ISPMLIB MESSAGE found? */ DO /* No, use SAY instead. */ SAY 'RXERROR ISPMLIB Message ISRZ001 Not Found' SIGNAL _SAY_ERRMSG; END SIGNAL _SAY_SQLMSG; END _SAY_ERRMSG: SAY "RXERROR Error RC "_rc""_errtext" at line "_sigl, "in EXEC "_ex_name IF _sigl <= SOURCELINE() /* Is source code avail? */ THEN SAY "RXERROR Source Line "_sigl": "STRIP(SOURCELINE(_sigl)) SAY '' _SAY_SQLMSG: IF SYMBOL('SQLCODE') = 'VAR' & QUEUED() > 0 THEN IF WORDPOS(sqlcode,'0 100') = 0 THEN DO _i = 1 BY 1 WHILE QUEUED() > 0 PULL _stack SAY 'SQL STACK:'RIGHT(_i,2)':'_stack END /*END OF RXERROR------------------------------------------------------*/