Bill O'Boyle
CICS Moderator
Joined: 14 Jan 2008
Posts: 2501
Location: Atlanta, Georgia, USA
|
|
|
|
Here's an Assembler sub-program (KIKSDESC, my own creation) which returns the description of a particular EIBRESP. It uses the CICS In-Core program "DFHEITAB" to find this description. Comments in the program-source should suffice for usage. Converting this to a HLL should not pose a major challenge.
Note - As of 2015/09/01, this is an updated version of KIKSDESC, which includes an adjustment factor for the TBLDSECT, due to the expansion of a single table-entry from 22 to 24 positions, beginning with CICS/TS 5.1. The adjustment factor is calculated accordingly, based upon the CICSTSLEVEL obtained from an INQUIRE SYSTEM API.
| Code: |
*PROCESS RENT PROGRAM IS RE-ENTRANT
*ASM XOPTS(NOEPILOG) SUPPRESS EPILOGUE
***********************************************************************
*---------------------------------------------------------------------*
* *
* THIS SUB-PROGRAM WILL RETURN THE DESCRIPTN ASSOCIATED WITH *
* A PARTICULAR EIBRESP VALUE AS WELL AS THE EIBFN AND EIBRCODE *
* IN READABLE-HEX FORMAT. *
* *
* EXAMPLE COMMAREA (LENGTH IS ALWAYS 40) - *
* *
* 03 WS-KIKSDESC-COMMAREA. *
* 05 WS-KIKSDESC-EIBRESP *
* PIC 9(08) COMP-5. *
* 05 WS-KIKSDESC-EIBRESP2 *
* PIC 9(08) COMP-5. *
* 05 WS-KIKSDESC-EIBFN PIC X(04). *
* 05 WS-KIKSDESC-EIBRCODE *
* PIC X(12). *
* 05 WS-KIKSDESC-DESCRIPTN-LGTH *
* PIC 9(04) COMP-5. *
* 05 WS-KIKSDESC-DESCRIPTN *
* PIC X(12). *
* 05 WS-KIKSDESC-RETURN-CODE *
* PIC 9(04) COMP-5. *
* 03 WS-KIKSDESC PIC X(08) VALUE 'KIKSDESC'. *
* *
* MOVE LOW-VALUES TO WS-KIKSDESC-COMMAREA *
* MOVE EIBRESP TO WS-KIKSDESC-EIBRESP *
* MOVE EIBRESP2 TO WS-KIKSDESC-EIBRESP2 *
* MOVE EIBFN TO WS-KIKSDESC-EIBFN *
* (1:LENGTH OF EIBFN) *
* MOVE EIBRCODE TO WS-KIKSDESC-EIBRCODE *
* (1:LENGTH OF EIBRCODE) *
* MOVE SPACES TO WS-KIKSDESC-DESCRIPTN *
* *
* EXEC CICS LINK *
* PROGRAM (WS-KIKSDESC) *
* COMMAREA(WS-KIKSDESC-COMMAREA) *
* END-EXEC *
* *
* UPON RETURN, 'WS-KIKSDESC-DESCRIPTN' WILL CONTAIN THE *
* DESCRIPTN-TEXT ASSOCIATED WITH THE PASSED 'EIBRESP'. ALSO, *
* 'WS-KIKSDESC-DESCRIPTN-LGTH' WILL CONTAIN THE ACTUAL LENGTH *
* OF THE DESCRIPTN-TEXT. FOR EXAMPLE, THE 'EIBRESP' VALUE THAT *
* WAS PASSED WAS 19 AND ITS ASSOCIATED DESCRIPTN-TEXT WILL BE *
* 'NOTOPEN'. THE DESCRIPTN-LGTH WILL EQUAL 07. *
* *
* THE RETURN-CODE IS RETURNED IN R15 TO THE CALLER, OTHERWISE *
* KNOWN AS THE RETURN-CODE SPECIAL-REGISTER FOR COBOL-CALLERS. *
* *
* IT IS ALSO RETURNED IN THE COMMAREA AS A BINARY-HALFWORD. *
* *
*---------------------------------------------------------------------*
***********************************************************************
PRINT GEN ACTIVATE MACRO-EXPANSION
GBLC &PGMNAME
&PGMNAME SETC 'KIKSDESC'
COMDSECT DSECT COMMAREA DSECT (R7)
USING *,R7 INFORM ASSEMBLER
COMMAREA EQU * BEGIN COMMAREA
COMMRSP1 DS AL4 PASSED 'EIBRESP' (FWORD)
COMMRSP2 DS AL4 CALLER'S 'EIBRESP2' (SAVED)
COMMFCTN DS CL4 CALLER'S 'EIBFN' (READABLE HEX)
COMMRCDE DS CL12 CALLER'S 'EIBRCODE' (SAME)
COMMDLEN DS AL2 DESCRIPTN-LGTH (HWORD)
COMMDESC DS CL12 DESCRIPTN-TEXT
COMMRTNC DS AL2 RETURN-CODE (HWORD)
COMMLGTH EQU *-COMMAREA COMMAREA-LGTH
TBLDSECT DSECT DFHEITAB DSECT (R9)
USING *,R9 INFORM ASSEMBLER
TBLENTRY EQU * BEGIN ENTRY
TBLDESC DS CL(L'COMMDESC) ASSOCIATED-DESCRIPTN
TBLEYECT DS H EYECATCHER (X'50C0')
DS XL4 NOT USED
TBLRSPCD DS H RESPONSE-CODE (ALIGNED-HWORD)
DS XL2 NOT USED
TBLLGTH EQU *-TBLENTRY BASE-LGTH OF TBL-DSECT (22)
DFHEISTG DSECT DYNAMIC-STG DSECT (R13)
DWORD DS D DBLWORD-WORKAREA
DBLWORD DS D SAME
TSLEVEL DS F CICS/TS LEVEL (FMT=X'00NNNNNN')
SANITYMX DS F SANITY-MAX TBL-SEARCH
RESPCODE DS F RESPONSE/RETURN CODE FWORD
ADJFACTR DS H TBL-ADJUSTMENT FACTOR-HWORD
WORKDESC DS CL(L'COMMDESC+1) DESCRIPTN-WORKAREA
UNPKAREA DS CL16 UNPACK-WORKAREA
TRANSTBL DS XL256 DYNAMIC TRANSLATE-TBL
&PGMNAME DFHEIENT USE DEFAULTS (R3, R13, R11)
LA R1,22 PREPARE FOR 'ST' (LENGERR)
ST R1,RESPCODE STORE IN FWORD
LH R1,EIBCALEN LOAD COMMAREA-LGTH
CHI R1,COMMLGTH MINIMUM-LGTH?
JL CICSRETN NO, RETURN TO CALLER
L R7,DFHEICAP COMMAREA ADDRESSABILITY
NILF R7,X'7FFFFFFF' CLEAR TOP-BIT
XC COMMRTNC,COMMRTNC ENSURE X'00'S
XC DFHEIUSR(L'TRANSTBL),DFHEIUSR
XC DFHEIUSR+L'TRANSTBL((DFHEIEND-DFHEIUSR)-L'TRANSTBL),DFHEX
IUSR+L'TRANSTBL
OI DWORD+L'DWORD-1,15 ENSURE 'F' SIGN-NIBBLE
LA R1,L'COMMDESC PREPARE FOR 'STH'
STH R1,COMMDLEN MAX DESCRIPTN-LGTH
UNPK UNPKAREA(L'COMMFCTN+1),EIBFN(L'EIBFN+1)
MVC COMMFCTN,UNPKAREA PREPARE FOR 'TR'
LA R1,=CL16'0123456789ABCDEF'-240
TR COMMFCTN,0(R1) MAKE IT READABLE-HEX
UNPK UNPKAREA(L'COMMRCDE+1),EIBRCODE(L'EIBRCODE+1)
MVC COMMRCDE,UNPKAREA PREPARE FOR 'TR'
TR COMMRCDE,0(R1) MAKE IT READABLE-HEX
UNPK UNPKAREA,DWORD ENSURE CHARACTER-ZEROS
MVI WORKDESC,C' ' ENSURE SPACES
MVC WORKDESC+1(L'WORKDESC-1),WORKDESC
MVC COMMDESC,WORKDESC SAME
*
EXEC CICS INQUIRE SYSTEM, OBTAIN THE CICS/TS LEVEL, X
CICSTSLEVEL(UNPKAREA), SUPPRESSING ALL ERRORS X
NOHANDLE,
*
PACK DWORD,UNPKAREA(L'EIBRCODE)
MVO DWORD,DWORD SHIFT-LEFT 4-BITS
L R1,DWORD+L'TSLEVEL PREPARE FOR 'SRL'
SRL R1,L'DWORD RIGHT-JUSTIFY AS X'00NNNNNN'
ST R1,TSLEVEL STORE IN FWORD (SAFEKEEPING)
CFI R1,X'00050100' TS/5.1 LEVEL OR GREATER?
JL MAXVALUE NO, CHECK FOR MAX-VALUE
LA R1,2 LOAD ADJUSTMENT-FACTOR
STH R1,ADJFACTR STORE IN HWORD
MAXVALUE EQU *
L R1,COMMRSP1 PREPARE FOR 'CFI' AND 'LTR'
CFI R1,32767 EXCEEDS HWORD-MAXIMUM?
JH INVRSPCD YES, THIS IS INVALID
LTR R1,R1 EXCEEDS X'00'S?
JP LOADTBL YES, LOAD IN-CORE TBL
XC COMMRSP1,COMMRSP1 ENSURE X'00'S
MVC COMMDESC(L'EIBRCODE),=C'NORMAL'
MVI RESPCODE+L'RESPCODE-1,L'RESPCODE
J CALCLGTH CALCULATE DESCRIPTN-LGTH
LOADTBL EQU *
*
EXEC CICS LOAD NOHANDLE, ESTABLISH ADDRESSABILITY TO THE X
PROGRAM('DFHEITAB'), CICS IN-CORE TABLE 'DFHEITAB', X
SET (R9), SUPPRESSING ALL ERRORS X
FLENGTH(DBLWORD),
*
ICM R15,B'1111',EIBRESP TABLE-LOAD OK?
ST R15,RESPCODE STORE IN FWORD
JNZ BADTABLD NO, THERE WAS A PROBLEM
LHI R6,20672 PREPARE FOR SEARCH (X'50C0')
LM R14,R15,24(R9) PREPARE FOR 'MHI'
MHI R15,24 CALCULATE 'SANITY-MAX'
LA R1,0(R14,R15) LOAD 'SANITY-MAX'
ST R1,SANITYMX STORE IN FWORD
L R9,24(,R9) RECALCULATE STARTING-ADDRESS
LAY R9,5676(,R9) INITIAL STARTING-ADDRESS BUMP
L R1,TSLEVEL RELOAD FOR 'CFI'
CFI R1,X'00050100' TS/5.1 LEVEL OR GREATER?
JL FFRSTEYE NO, FIND FIRST 'EYECATCHER'
LA R9,732(,R9) BUMP STARTING-ADDRESS AGAIN
J FFRSTEYE FIND FIRST 'EYECATCHER'
BADTABLD EQU *
MVC COMMDESC,=C'@TBLDERR000@'
CVD R15,DWORD MAKE IT DECIMAL
OI DWORD+L'DWORD-1,15 ENSURE 'F' SIGN-NIBBLE
UNPK COMMDESC+8(3),DWORD UNPACK 'EIBRESP' FROM LOAD
J SETRETCD SET COMMAREA RETURN-CODE
FFRSTEYE EQU *
CH R6,0(,R9) 1ST-EYECATCHER FOUND?
JNE BUMP4EYE NO, BUMP TO 'NEXT' BYTE
AHI R9,-L'TBLDESC REPOSITION AT ENTRY-START
LH R1,ADJFACTR LOAD 'ADJUSTMENT' FACTOR
LA R1,TBLLGTH(,R1) COMPLETE 'ADJUSTMENT' FACTOR
STH R1,ADJFACTR STORE BACK IN HWORD
L R1,COMMRSP1 LOAD AS FWORD
J SRCHDESC BEGIN DESCRIPTN-SEARCH
BUMP4EYE EQU *
LA R9,1(,R9) BUMP TO 'NEXT' BYTE
C R9,SANITYMX EXCEEDS 'SANITY-MAX'?
JNH FFRSTEYE NO, KEEP SEARCHING
LA R1,241 LOAD WITH X'F1'
J NORESPCD RESPONSE-CODE NOT FOUND
SRCHDESC EQU *
CH R1,TBLRSPCD RESPONSE-CODES MATCH?
JNE BUMPDESC NO, CHECK 'NEXT' ENTRY
MVC COMMDESC,TBLDESC POPULATE DESCRIPTN
J CALCLGTH CALCULATE DESCRIPTN-LGTH
BUMPDESC EQU *
AH R9,ADJFACTR BUMP TO 'NEXT' TBL-ENTRY
CH R6,TBLEYECT ANY MORE ENTRIES?
JE SRCHDESC YES, KEEP SEARCHING
LA R1,242 LOAD WITH X'F2'
J NORESPCD RESPONSE-CODE NOT FOUND
CALCLGTH EQU *
MVC WORKDESC(L'COMMDESC),COMMDESC
MVI TRANSTBL+64,X'FF' SET SPACE-SLOT TO X'FF'
TRT WORKDESC,TRANSTBL FIND 1ST-SPACE
LA R2,WORKDESC POINT TO STARTING-ADDRESS
SR R1,R2 IS THERE A DESCRIPTN?
JNP NODSCRPT NO, USE OUR DEFAULT
STH R1,COMMDLEN POPULATE DESCRIPTN-LGTH
J SETRETCD SET COMMAREA RETURN-CODE
INVRSPCD EQU *
MVI RESPCODE+L'RESPCODE-1,L'DWORD
MVC COMMDESC,=C'@@INVRSPCD@@'
J SETRETCD SET COMMAREA RETURN-CODE
NORESPCD EQU *
MVI RESPCODE+L'RESPCODE-1,L'DWORD
MVC COMMDESC,=C'@NORESPCD-0@'
STC R1,COMMDESC+10 STORE R1 LOW-ORDER
J SETRETCD SET COMMAREA RETURN-CODE
NODSCRPT EQU *
MVI RESPCODE+L'RESPCODE-1,L'DWORD
MVC COMMDESC,=C'@NODESCRPTN@'
SETRETCD EQU *
L R1,RESPCODE PREPARE FOR 'STH'
STH R1,COMMRTNC STORE IN COMMAREA
CICSRETN EQU *
L R15,RESPCODE LOAD FOR CALLER
*
DFHEIRET RCREG=R15 RETURN TO CALLER
*
DFHREGS , CICS REGISTER-MACRO
*
&PGMNAME AMODE 31 ,
&PGMNAME RMODE ANY ,
*
END , END 'KIKSDESC'
|
|
|
