Bill O'Boyle
CICS Moderator
Joined: 14 Jan 2008
Posts: 2501
Location: Atlanta, Georgia, USA
|
|
|
|
Here's the example sub-program I had described -
| Code: |
*PROCESS RENT PROGRAM IS RE-ENTRANT
***********************************************************************
*---------------------------------------------------------------------*
* *
* THIS SUB-PROGRAM CAN BE CALLED FROM BATCH OR ON-LINE COBOL *
* AND RETURNS THE DECIMAL EQUIVILENT OF AN 8-BYTE 'STCK' AS *
* 9-BYTES, PACKED-DECIMAL SIGNED. *
* *
* WHEN CALLED FROM CICS, THE CALLER NEEDS TO USE CICS 'ENQ' *
* BEFORE THE CALL AND CICS 'DEQ' AFTER THE CALL, ENSURING *
* SERIALIZATION. *
* *
* WHEN CALLED FROM BATCH, THIS SUB-PROGRAM WILL ISSUE MVS *
* 'ENQ/DEQ' MACROS, ENSURING SERIALIZATION. *
* *
* THIS SUB-PROGRAM DETERMINES THE RUN-ENVIRONMENT, SO THERE'S *
* NO NEED TO PASS THIS INFORMATION. *
* *
* NOTE THE 88-BYTES AFTER THE HALFWORD RETURN-CODE. THIS STG *
* IS NECESSARY FOR RE-ENTRANCY AND IS REQUIRED IN A CICS *
* ENVIRONMENT. *
* *
* EXAMPLE SYNTAX: *
* *
* 03 WS-RANDOM-PARM. *
* 05 WS-RANDOM-NBR PIC S9(17) PACKED-DECIMAL. *
* 05 WS-RANDOM-RTNCODE PIC 9(04) BINARY. *
* 88 WS-RANDOM-SUCCESS VALUE ZERO. *
* 05 FILLER PIC X(88). *
* 03 WS-RANDOM PIC X(08). VALUE 'RANDOM'. *
* *
* CALL WS-RANDOM USING WS-RANDOM-PARM. *
* *
*---------------------------------------------------------------------*
***********************************************************************
STGDSECT DSECT CALLER-STG (R7)
USING *,R7 INFORM ASSEMBLER
STGAREA DS 0XL88 DYNAMIC-STG WORKAREA (FROM CALLER)
QUADWORD DS L ALIGNED-QUADWORD
REGSAVEA DS XL72 REGISTER-SAVEAREA
PRMDSECT DSECT PARMAREA (R9)
USING *,R9 INFORM ASSEMBLER
PRMAREA DS 0XL11 PARMAREA FROM CALLER
PRMRNDOM DS PL9 PARM RANDOM-NBR (PACKED-DECIMAL)
PRMRETCD DS XL2 PARM RETURN-CODE (HWORD)
RANDOM CSECT
USING *,R3 INFORM ASSEMBLER
SAVE (14,12) SAVE REGISTERS
LA R3,0(,R15) CSECT-ADDRESSABILITY
B ADDRPARM ADDRESS THE PARMAREA
********
******** ASSEMBLY DATE/TIME 'EYECATCHER'
********
EYECTCHR DS 0CL46
DC CL46' <<< ASSEMBLY DATE/TIME: &SYSDATC/&SYSTIME..00 >>>'
ORG EYECTCHR+6 REDEFINITION
DC X'A2A285948293A8' LOWER-CASE 'SSEMBLY'
ORG EYECTCHR+15 REDEFINITION
DC X'81A385' LOWER-CASE 'ATE'
ORG EYECTCHR+20 REDEFINITION
DC X'899485' LOWER-CASE 'IME'
ORG EYECTCHR+L'EYECTCHR RESET LOCATION-KTR
DC CL1' ' SEPARATOR-SPACE
********
******** CONSTANTS USED IN 'BATCH' ONLY
********
ENQNAME DS 0CL18
DC CL18'$$RANDOM/ENQ/DEQ$$'
ORG ENQNAME+3 REDEFINITION
DC X'8195849694' LOWER-CASE 'ANDOM'
ORG ENQNAME+10 REDEFINITION
DC X'9598' LOWER-CASE 'NQ'
ORG ENQNAME+14 REDEFINITION
DC X'8598' LOWER-CASE 'EQ'
ORG ENQNAME+L'ENQNAME RESET LOCATION-KTR
DC CL1' ' SEPARATOR-SPACE
ENQRES DC 0CL24
DC CL24'$$RANDOM/NBR/GENERATOR$$'
ORG ENQRES+3 REDEFINITION
DC X'8195849694' LOWER-CASE 'ANDOM'
ORG ENQRES+10 REDEFINITION
DC X'8299' LOWER-CASE 'BR'
ORG ENQRES+14 REDEFINITION
DC X'8595859981A39699' LOWER-CASE 'ENERATOR'
ORG ENQRES+L'ENQRES RESET LOCATION-KTR
DC CL1' ' SEPARATOR-SPACE
********
******** BEGIN EXECUTION
********
ADDRPARM DS 0H
L R9,0(,R1) PARMAREA-ADDRESSABILITY
LA R9,0(,R9) CLEAR TOP-BIT
XC PRMAREA,PRMAREA ENSURE X'00'S
OI PRMRNDOM+L'PRMRNDOM-1,X'0C'
LA R7,L'PRMAREA(,R9) STORAGE-ADDRESSABILITY
XC STGAREA,STGAREA ENSURE X'00'S
LA R15,REGSAVEA POINT TO OUR 'RSA'
ST R13,4(,R15) BACKWORD-CHAIN
ST R15,8(,R13) FORWARD-CHAIN
LR R13,R15 POINT TO OUR 'RSA'
L R15,X'21C' ADDRESS CURRENT TCB
L R15,X'D0'(,R15) ADDRESS TCB EXTN
L R15,X'14'(,R15) ADDRESS AFCB
LTR R15,R15 BATCH-ENVIRONMENT?
BZ BATCHENQ YES, ISSUE BATCH 'ENQ'
CLC =CL3'AFC',0(R15) BATCH-ENVIRONMENT?
BNE BATCHENQ YES, ISSUE BATCH 'ENQ'
XR R2,R2 ENSURE X'00'S FOR 'CICS'
B STCKRQST REQUEST FOR 'STORE-CLOCK'
BATCHENQ EQU *
LA R2,16 SET TO NON-ZERO FOR 'BATCH'
ENQ (ENQNAME,ENQRES,E,L'ENQRES,SYSTEMS),RET=NONE
STCKRQST EQU *
MVC PRMRETCD,=AL2(4095) LOAD 'INVALID' RETURN-CODE
STCK QUADWORD REQUEST FOR 'STORE-CLOCK'
OC QUADWORD,QUADWORD VALID NON-ZERO VALUE?
BZ CHKRNENV NO, CHECK RUN-ENVIRONMENT
XC PRMRETCD,PRMRETCD ENSURE 'VALID' RETURN-CODE
LG R1,QUADWORD PREPARE FOR 'CVDG'
LPGR R1,R1 ENSURE IT'S POSITIVE
CVDG R1,QUADWORD MAKE IT 16-BYTES DECIMAL
OI QUADWORD+L'QUADWORD-1,X'0F'
ZAP PRMRNDOM,QUADWORD POPULATE AS A PL9
CHKRNENV EQU *
LTR R2,R2 CICS ENVIRONMENT?
BZ RTN2CLLR YES, RETURN TO THE CALLER
DEQ (ENQNAME,ENQRES,L'ENQRES,SYSTEMS),RET=NONE
RTN2CLLR EQU *
L R13,4(,R13) RESTORE CALLER'S R13
MVC QUADWORD(L'PRMRETCD),PRMRETCD
LH R15,QUADWORD LOAD AS HWORD
XC STGAREA,STGAREA ENSURE X'00'S
RETURN (14,12),RC=(15) RESTORE AND RETURN
LTORG ,
YREGS ,
RANDOM AMODE 31
RANDOM RMODE ANY
END ,
|
Note that lower-case letters are constructed using ORG (Redefines) statements, so that some "goof ball" doesn't come along, issue a CAPS ON and accidentally hits a line where lower-case letters have been specified. I know this, because I've done it many times. 
I understand that you need a 9-Byte Display-Numeric value, but the sub-program returns a 9-Byte (PIC S9(17) COMP-3) value, so you can possibly develop a method to choose different digits for your Display-Numeric field? It's good to have choices. 
Usage instructions can be found in the comments. Must be Assembled/Linked as AMODE(31), RMODE(ANY).
And yes, I'm still stuck on using 8-Byte labels or less. 
HTH.... |
|
