This appendix lists the example global user exit program, DFH$XTSE. The example shows you how to:
***********************************************************************
* *
* MODULE NAME = DFH$XTSE *
* *
* FUNCTION = *
* Example global user exit program to run at the XTSEREQ and *
* XTSEREQC exits. *
* *
* DESCRIPTION = *
* The program gives examples of: *
* 1) Coding Exec Interface global user exits, showing how to *
* modify and add parameters to the Command Parameter List. *
* 2) Issuing a mixture of EXEC CICS API and XPI calls within *
* the same global user exit program. *
* 3) Modifying Temporary Storage requests, by renaming the queue *
* name and allowing the SYSID to be added so that the request *
* is routed to a queue-owning region (QOR). *
* *
* ------------------------------------------------------------------- *
* NOTE that this program is only intended to DEMONSTRATE the use *
* of the TS request user exit XTSEREQ, and to show the sort of *
* information which can be obtained from the exit parameter list. *
* IT SHOULD BE TAILORED BEFORE BEING USED IN A PRODUCTION ENVIRONMENT.*
* ------------------------------------------------------------------- *
* *
* NOTES = *
* The important notes to remember when coding similar global user *
* exits are: *
* *
* 1) If the exit program modifies the Command Parameter List, you *
* MUST ensure that the storage used for additional fields such *
* as the SYSID is non-volatile. Here are examples of storage *
* that is safe: *
* a) Shared storage obtained by GETMAIN. This should be *
* obtained in the Request exit, and freed in the Request *
* Complete exit.. The shared storage address can be passed *
* using the 4-byte token in the DFHUEPAR parameter list. *
* b) Shared global work area storage. *
* c) Storage obtained by using the LOAD HOLD option. *
* d) TCTUA or CWA storage. *
* *
* It is not safe to use the following storage: *
* Program storage (DFHEISTG) since this is freed as soon *
* as the exit program returns control to CICS. *
* *
* 2) When adding or removing a field in the command parameter list, *
* you must remember: *
* a) To set/clear the field's existence bit in the EID *
* b) To set/clear the appropriate address in the Addr_List *
* c) To set the hi-order bit in the LAST address in the *
* Addr_List. *
* *
* 3) If you are planning to use the CICS API in the exit, you *
* must: *
* a) Use the DFHEIENT macro to control module entry. *
* b) Use the DFHEIRET macro to return control to CICS. However,*
* the exit return code MUST be set in Register 15. *
* c) Issue an ADDRESS EIB command before issuing any EXEC CICS *
* commands. *
* *
* 4) If you are planning to use the API and XPI in the same *
* global user exit program, take care to ensure that Register *
* 13 points to the kernel stack entry (UEPSTACK) for XPI calls, *
* and is restored for API calls if necessary. *
* *
* *
***********************************************************************
EJECT ,
*---------------------------------------------------------------------*
* *
* Copybook and DSECTS required by the exit program *
* *
*---------------------------------------------------------------------*
DFHUEXIT TYPE=EP,ID=(XTSEREQ,XTSEREQC)
DFHUEXIT TYPE=XPIENV Exit programming interface (XPI)
COPY DFHTRPTY Trace XPI definitions
COPY DFHTSUED Command Level Plist definitions
*
*---------------------------------------------------------------------*
* The following DSECT maps the shared storage obtained by the *
* EXEC CICS GETMAIN API call. This storage is used to store the *
* modified SYSID and/or TS QNAME that is passed to CICS on return *
* from the exit program. *
*---------------------------------------------------------------------*
SHARED_STORAGE DSECT
SHARED_EYECATCHER DS CL16
SHARED_NAME DS CL8
SHARED_SYSID DS CL4
*
*---------------------------------------------------------------------*
* The TS Routing table is made up of a set of entries. Each entry *
* can be mapped by the TABLE_ENTRY DSECT *
*---------------------------------------------------------------------*
TABLE_ENTRY DSECT
ENTRY_NAME DS CL8
NEW_NAME DS CL8
NEW_SYSID DS CL4
ENTRY_ACTION DS XL1
FILLER DS CL3
*
*---------------------------------------------------------------------*
* The following definitions are for program working storage. *
*---------------------------------------------------------------------*
DFHEISTG DSECT
RETCODE DS XL4 Program Return Code
TR_ERROR_N DS X Error Number for Trace Entry
RESP DS X API Response
EJECT ,
***********************************************************************
* PROGRAM REGISTER USAGE : *
* R0 - Work Register *
* R1 - Points to DFHUEPAR plist on entry *
* Work Register *
* R2 - DFHUEPAR parameter List *
* R3 - Code Base Register *
* R4 - <unused> *
* R5 - <unused> *
* R6 - Subroutine Linkage Register *
* R7 - Address of TS Queue Name from Command Plist *
* R8 - Command Parameter list UEPCLPS *
* R9 - Address of Table_Entry in TS_Routing_Table *
* R10- <unused> *
* R11- EIB Register *
* R12- Work Register *
* R13- DFHEISTG for API calls *
* Kernel Stack for XPI calls *
* R14- Work Register *
* R15- Work Register *
***********************************************************************
EJECT ,
***********************************************************************
* DFH$XTSE - Main Routine *
* This is the entry point for the exit program. Control is passed *
* to the TS_REQUEST or TS_REQUEST_COMPLETE routines depending *
* on whether the exit was invoked at the XTSEREQ or XTSEREQC exit *
* points. *
* *
* Registers: *
* R1 = UEPAR plist (set on entry) *
* = Work register *
* R2 = UEPAR plist *
* R3 = Program base register (set by DFHEIENT) *
* R6 = Linkage register *
* R11= EIB register *
* R13= EISTG register (set by DFHEIENT) *
* R15= Work register *
* User Exit Return Code *
* *
* Logic: *
* DFH$XTSE: *
* Exec Interface Entry *
* Address DFHUEPAR plist *
* Set OK Return Code *
* Address the EIB *
* Trace entry *
* Select Exitid *
* When(XTSEREQ) then call TS_Request *
* When(XTSEREQC) then call TS_Request_Complete *
* Otherwise call Error(Invalid_Exit) *
* End Select *
* Trace exit *
* Set Exit return code *
* Return *
***********************************************************************
DFH$XTSE DFHEIENT
DFH$XTSE AMODE 31
DFH$XTSE RMODE ANY
LR R2,R1 DFHUEPAR plist provided by caller
USING DFHUEPAR,R2 Use R2 to address UEPAR PLIST
*
LA R15,UERCNORM Set OK Response
ST R15,RETCODE in working storage
*
EXEC CICS ADDRESS EIB(R11)
USING DFHEIBLK,R11
*
BAL R6,TRACE_ENTRY Trace program entry
*
L R1,UEPEXN Address of the 1 byte Exit Id
CLI 0(R1),XTSEREQ Is this XTSEREQ exit?
BE TS_REQUEST ..Yes Branch to routine
CLI 0(R1),XTSEREQC Is this XTSEREQC exit?
BE TS_REQUEST_COMPLETE .. Yes Branch to routine
B ERROR1 Otherwise Branch to error routine
*
RETURN DS 0H Return point
BAL R6,TRACE_EXIT Trace program exit
*
L R15,RETCODE Fetch return code
DFHEIRET RCREG=15 Return to CICS
EJECT ,
*=====================================================================*
* TS_REQUEST - Invoked at XTSEREQ exit point *
* Determine the TS Queue Name and scan the TS_Routing_Table for *
* a match. If an entry exists in the table, then check the action *
* field and call the ROUTE_REQUEST or LOCAL_REQUEST routines. *
* *
* The TS_Routing_Table is made up of entries with the following *
* structure: *
* *
* TABLE_ENTRY: *
* ---------------------------------------------------------- *
* | Entry_Name | New_Name | QOR_Sysid | Action | *filler* | *
* | Char 8 | Char 8 | Char 4 | Bin 1 | Char 3 | *
* ---------------------------------------------------------- *
* Last Entry is indicated by special TS_Queue Name *
* *
* Registers: *
* R1 = Work register *
* R7 = Set to the TS Queue Name *
* R8 = Command Parameter List (CLPS) *
* R9 = Points to the next entry in the TS_Routing_Table *
* R15= Work register *
* *
* Logic: *
* TS_Request: *
* If called recursively then *
* call Error(Recursive_Call1) *
* Else *
* If the Command GROUP code is not a TS request then *
* call Error(Invalid_Group_Code1) *
* Else *
* Clear the UEPTQTOK *
* Address the Command Plist UEPCLPS *
* Fetch tsq_name *
* Fetch start of TS_Routing_Table *
* Check_Next_Entry: *
* Get the next table entry *
* Select (entry_name) *
* When (last_entry) call Entry_Not_Found *
* When (tsq_name) *
* Select (entry_action) *
* When (Route) call Route_Request *
* When (Local) call Local_Request *
* Otherwise call Error(Invalid_Table_Action) *
* End Select *
* Otherwise *
* Goto Check_Next_Entry *
* End Select *
* End If *
* End If *
* Return *
*=====================================================================*
TS_REQUEST DS 0H
* Check for possible recursion
L R1,UEPRECUR Address of recursive count
LH R1,0(R1) Fetch count
LTR R1,R1 Has exit been invoked recursively?
BNZ ERROR2 ..Yes Branch to error routine
*
* Extract pointer to the EID and TS queue name from CLPS
L R8,UEPCLPS Fetch address of Command Plist
USING TS_ADDR_LIST,R8 Use R8 to address CLPS
L R1,TS_ADDR0 Address the EID..
L R7,TS_ADDR1 Fetch address of TS QUEUE
DROP R8 Drop addressability to CLPS
*
* Check that the Command GROUP code corresponds to a TS request
USING TS_EID,R1 ..with Register 1
CLI TS_GROUP,TS_TEMPSTOR_GROUP Is this a TS request?
BNE ERROR3 ..No Branch to error routine
DROP R1 Drop addressability to EID
*
* Clear the TS Request token
L R1,UEPTQTOK Fetch address of token
XC 0(4,R1),0(R1) Clear Token for XTSEREQC
*
*
*---------------------------------------------------------------------*
* Start scan of TS_Routing Table *
*---------------------------------------------------------------------*
LA R9,TS_ROUTING_TABLE Fetch address of routing table
USING TABLE_ENTRY,R9 Address entries from R9
*
CHECK_NEXT_ENTRY DS 0H
CLC ENTRY_NAME,ENTRY_NAME_LAST Is this the last entry
BE ENTRY_NOT_FOUND ..Yes Take default routing action
CLC ENTRY_NAME,0(R7) Is this the wanted TS queue name?
BE ENTRY_FOUND ..Yes Check for the action required
LA R9,24(R9) Point to next entry
B CHECK_NEXT_ENTRY Start search again
*
ENTRY_FOUND DS 0H
CLI ENTRY_ACTION,ROUTE Is the action to route request?
BE ROUTE_REQUEST ..Yes Branch to Route routine
CLI ENTRY_ACTION,LOCAL Is the action to rename queue?
BE LOCAL_REQUEST ..Yes Branch to Local routine
B ERROR4 Otherwise Branch to error routine
DROP R9 Drop addressability to Entry
EJECT ,
*
*=====================================================================*
* TS_REQUEST_COMPLETE - Invoked at XTSEREQC exit point *
* Free any shared storage that was acquired during previous *
* invocation at XTSEREQ. *
* *
* Registers: *
* R1 = Work register *
* R6 = Linkage register *
* R8 = Command Parameter List (CLPS) *
* *
* Logic: *
* TS_Request_Complete: *
* If called recursively then *
* call Error(Recursive_Call2) *
* Else *
* If the Command GROUP code is not a TS request then *
* call Error(Invalid_Group_Code2) *
* Else *
* If UEPTQTOK->token ¬= 0 then Call Freemain_Shared_Plist *
* End If *
* End If *
* Return *
*=====================================================================*
TS_REQUEST_COMPLETE DS 0H
* Check for possible recursion
L R1,UEPRECUR Address of recursive count
LH R1,0(R1) Fetch count
LTR R1,R1 Has exit been invoked recursively?
BNZ ERROR5 ..Yes Branch to error routine
*
* Check that the Command GROUP code corresponds to a TS request
L R8,UEPCLPS Fetch address of Command Plist
USING TS_ADDR_LIST,R8 Use R8 to address CLPS
L R1,TS_ADDR0 Address the EID..
USING TS_EID,R1 ..with Register 1
CLI TS_GROUP,TS_TEMPSTOR_GROUP Is this a TS request?
BNE ERROR6 ..No Branch to error routine
DROP R1 Drop addressability to EID
DROP R8 Drop addressability to CLPS
*
L R1,UEPTQTOK Fetch address of Token
L R1,0(R1) Fetch actual token
LTR R1,R1 Did XTSEREQ GETMAIN any storage?
BZ RETURN ..No Return to caller
BAL R6,FREEMAIN_SHARED ..Yes Issue FREEMAIN
B RETURN Return to caller
EJECT ,
*
*=====================================================================*
* LOCAL_REQUEST: Process Local TS Queues *
* An entry has been found in the TS_Routing Table for this TS *
* Queue Name. If required, rename the TS Queue Name, but do not *
* modify the SYSID. *
* *
* Registers: *
* R1 = Work register *
* R6 = Link Register *
* R7 = Address of current Queue name (Set on entry) *
* R8 = Command Parameter List (CLPS) *
* R9 = Address of table entry (Set on entry) *
* R12= Work register (Shared_storage) *
* *
* Logic: *
* Local_Request: *
* If entry_name ¬= new_name then *
* Call Getmain_Shared *
* Copy new_name into shared storage *
* Address the command plist *
* Update ADDR1 to point to address of the new TS QUEUE name *
* Set the Hi-order bit if last address in CLPS *
* End If *
* Return *
*=====================================================================*
LOCAL_REQUEST DS 0H
USING TABLE_ENTRY,R9 R9 points to the table entry
CLC NEW_NAME,0(R7) Is the new_name=current_queue name?
BE RETURN ..Yes Return
*
* Obtain Shared storage to hold the new queue name
BAL R6,GETMAIN_SHARED GETMAIN SHARED storage
L R12,UEPTQTOK Fetch address of token
L R12,0(R12) Fetch shared storage pointer
USING SHARED_STORAGE,R12 Address using R12
MVC SHARED_NAME,NEW_NAME Copy QNAME into shared storage
*
* Update the Queue Name in CLPS
L R8,UEPCLPS Address the CLPS.
USING TS_ADDR_LIST,R8 ..with Register 8
LA R1,SHARED_NAME Fetch address of the new QNAME
TM TS_ADDR1,X'80' Is the hi-order bit on?
BZ LOCAL1 ..No continue
O R1,=X'80000000' Indicate ADDR1 is last parameter
LOCAL1 DS 0H
ST R1,TS_ADDR1 Store address in TS_ADDR1
B RETURN Return
DROP R8 Drop TS_ADDR_LIST
DROP R12 Drop SHARED_STORAGE
DROP R9 Drop addressability to Entry
EJECT ,
*
*=====================================================================*
* ROUTE_REQUEST: Ship request to remote system *
* An entry has been found in the TS_Routing Table for this TS *
* Queue Name. The request is modified by adding a SYSID to the *
* command and renaming the queue if required. *
* *
* Registers: *
* R1 = Work register *
* R6 = Link Register *
* R7 = Address of current Queue name (Set on entry) *
* R8 = Command Parameter List (CLPS) *
* R9 = Address of table entry (Set on entry) *
* R12= Work register (Shared_storage) *
* *
* Logic: *
* Route_Request: *
* Call Getmain_Shared *
* If entry_name ¬= new_name then *
* Copy new_name into shared storage *
* Address the command plist *
* Update ADDR1 to point to address of the new TS QUEUE name *
* End If *
* Copy new_sysid into shared storage *
* Address the command plist *
* Update ADDR7 to point to the address of the new SYSID *
* Set the SYSID existence bit in the EID *
* Set the Hi-order bit in last address in CLPS *
* Return *
*=====================================================================*
ROUTE_REQUEST DS 0H
BAL R6,GETMAIN_SHARED GETMAIN SHARED storage
L R12,UEPTQTOK Fetch address of token
L R12,0(R12) Fetch Shared storage address
USING SHARED_STORAGE,R12 Address using R12
*
* Update the Queue Name in CLPS
USING TABLE_ENTRY,R9 R9 points to the table entry
CLC NEW_NAME,0(R7) Is the new_name=current_queue name?
BE ROUTE1 ..Yes No need to update Queue Name
MVC SHARED_NAME,NEW_NAME Copy QNAME into shared storage
L R8,UEPCLPS Address the CLPS..
USING TS_ADDR_LIST,R8 ..with Register 8
LA R1,SHARED_NAME Fetch address of the new QNAME
ST R1,TS_ADDR1 Store address in TS_ADDR1
DROP R8 Drop TS_ADDR_LIST
*
* Update the Sysid in CLPS
ROUTE1 DS 0H
MVC SHARED_SYSID,NEW_SYSID Copy SYSID into shared storage
L R8,UEPCLPS Address the CLPS..
USING TS_ADDR_LIST,R8 ..with Register 8
L R1,TS_ADDR0 Address the EID..
USING TS_EID,R1 ..with Register 1
OI TS_BITS1,TS_SYSID_V Indicate SYSID now present in CLPS
DROP R1 Drop addressability to EID
LA R1,SHARED_SYSID Fetch address of the new SYSID
ST R1,TS_ADDR7 Store address in TS_ADDR7
OI TS_ADDR7,X'80' Indicate SYSID is end of plist
*
* Clear hi-order bits in ARGs 1 to 5
NI TS_ADDR1,X'7F' Indicate not last parameter in CLPS
NI TS_ADDR2,X'7F' Indicate not last parameter in CLPS
NI TS_ADDR3,X'7F' Indicate not last parameter in CLPS
NI TS_ADDR4,X'7F' Indicate not last parameter in CLPS
NI TS_ADDR5,X'7F' Indicate not last parameter in CLPS
B RETURN Return
DROP R8 Drop TS_ADDR_LIST
DROP R12 Drop SHARED_STORAGE
DROP R9 Drop addressability to Entry
EJECT ,
*
*=====================================================================*
* ENTRY_NOT_FOUND - No entry was found in the TS_Routing_Table *
* No entry found in Routing Table for this TS Queue Name. In the *
* sample program, all such requests are routed. *
* *
* Registers: *
* R1 = Work register *
* R6 = Link Register *
* R8 = Command Parameter List (CLPS) *
* R12= Work register (Shared_storage) *
* *
* Logic: *
* Entry_Not_Found: *
* Call Getmain_Shared *
* Copy default_sysid into shared storage *
* Address the command plist *
* Update ADDR7 to point to the address of the default SYSID *
* Set the SYSID existence bit in the EID *
* Set the Hi-order bit in last address in CLPS *
* Return *
*=====================================================================*
ENTRY_NOT_FOUND DS 0H
BAL R6,GETMAIN_SHARED GETMAIN SHARED storage
L R12,UEPTQTOK Fetch address of token
L R12,0(R12) Fetch shared storage address
USING SHARED_STORAGE,R12 Address using R12
*
* Update the Sysid in CLPS
MVC SHARED_SYSID,DEFAULT_SYSID Copy SYSID to shared storage
L R8,UEPCLPS Address the CLPS..
USING TS_ADDR_LIST,R8 ..with Register 8
L R1,TS_ADDR0 Address the EID..
USING TS_EID,R1 ..with Register 1
OI TS_BITS1,TS_SYSID_V Indicate SYSID now present in CLPS
DROP R1 Drop addressability to EID
LA R1,SHARED_SYSID Fetch address of the new SYSID
ST R1,TS_ADDR7 Store address in TS_ADDR7
OI TS_ADDR7,X'80' Indicate SYSID is end of plist
*
* Clear hi-order bits in ARGs 1 to 5
NI TS_ADDR1,X'7F' Indicate not last parameter in CLPS
NI TS_ADDR2,X'7F' Indicate not last parameter in CLPS
NI TS_ADDR3,X'7F' Indicate not last parameter in CLPS
NI TS_ADDR4,X'7F' Indicate not last parameter in CLPS
NI TS_ADDR5,X'7F' Indicate not last parameter in CLPS
B RETURN Return
DROP R8 Drop TS_ADDR_LIST
DROP R12 Drop SHARED_STORAGE
EJECT ,
*
*=====================================================================*
* GETMAIN_SHARED - Obtain Shared storage *
* *
* Registers: *
* R0 = Used by EXEC CICS call *
* R1 = Used by EXEC CICS call *
* Work Register *
* R6 = Link Register - Return Address *
* R11= EIB register (set on entry) *
* R12= Work register *
* R14= Used by EXEC CICS call *
* R15= Used by EXEC CICS call *
* *
* Logic: *
* Getmain_Shared: *
* EXEC CICS GETMAIN LENGTH(32) SET(UEPTQTOK) SHARED RESP(resp) *
* If resp ¬= OK then *
* Call Error(Getmain_Failed) *
* Else *
* Address shared storage *
* Set eyecatcher 'XTSEREQ Storage' *
* End If *
* Return *
*=====================================================================*
GETMAIN_SHARED DS 0H
L R12,UEPTQTOK Fetch address of token
L R12,0(R12) Fetch shared storage anchor
LTR R12,R12 Is the storage already present?
BNZR R6 ..Yes Return
EXEC CICS GETMAIN LENGTH(32) SET(R12) SHARED X
INITIMG(X'00') RESP(RESP)
CLC RESP,DFHRESP(NORMAL) GETMAIN worked OK?
BNE ERROR7 ..No Goto Error routine
L R1,UEPTQTOK Fetch address of token
ST R12,0(R1) Save address of storage
USING SHARED_STORAGE,R12
MVC SHARED_EYECATCHER,EYE_CATCHER Set Eyecatcher
DROP R12 Drop R12
BR R6 Return to caller
EJECT ,
*
*=====================================================================*
* FREEMAIN_SHARED - Free shared storage *
* Free the shared storage associated with this command. *
* Registers: *
* R0 = Used by EXEC CICS call *
* R1 = Used by EXEC CICS call *
* R6 = Link Register - Return Address *
* R11= EIB register (set on entry) *
* R12= Work register *
* R14= Used by EXEC CICS call *
* R15= Used by EXEC CICS call *
* Logic: *
* Freemain_Shared: *
* Address shared storage *
* If eyecatcher ¬= 'XTSEREQ Storage' then *
* Call Error(Freemain_Logic_Error) *
* Else *
* EXEC CICS FREEMAIN DATAPOINTER(UEPTQTOK) RESP(resp) *
* If resp ¬= OK then *
* Call Error(Freemain_Failed) *
* End If *
* End If *
* Return *
*=====================================================================*
FREEMAIN_SHARED DS 0H
L R12,UEPTQTOK Fetch token address
L R12,0(R12) Address shared storage address
USING SHARED_STORAGE,R12 ..Using R12
CLC SHARED_EYECATCHER,EYE_CATCHER Is this our storage?
BNE ERROR8 ..No Goto Error routine
DROP R12 Drop R12
EXEC CICS FREEMAIN DATAPOINTER(R12) RESP(RESP)
CLC RESP,DFHRESP(NORMAL) FREEMAIN worked OK?
BNE ERROR9 ..No Goto Error routine
L R12,UEPTQTOK Fetch token address
XC 0(4,R12),0(R12) Clear token address
BR R6 Return to caller
EJECT ,
*=====================================================================*
* Trace Routines *
* Issue a Trace XPI call *
* *
* Registers: *
* R0 = Used by XPI call *
* R1 = DFHTRPT plist *
* R6 = Link Register - Return Address *
* R12= Work register *
* R13= EISTG register (set by DFHEIENT) *
* Kernel Stack entry *
* R14= Used by XPI call *
* R15= Used by XPI call *
*=====================================================================*
USING DFHTRPT_ARG,R1
TRACE_ENTRY DS 0H
L R1,UEPXSTOR Prepare for XPI call
DFHTRPTX CLEAR, X
POINT_ID(TR_ENTRY)
B ISSUE_TRACE
TRACE_EXIT DS 0H
L R1,UEPXSTOR Prepare for XPI call
DFHTRPTX CLEAR, X
POINT_ID(TR_EXIT)
B ISSUE_TRACE
TRACE_ERROR DS 0H
L R1,UEPXSTOR Prepare for XPI call
DFHTRPTX CLEAR, X
POINT_ID(TR_ERROR), X
DATA1(TR_ERROR_N,1)
BAL R6,ISSUE_TRACE
B RETURN
*
*---------------------------------------------------------------------*
* Issue the Trace XPI call *
*---------------------------------------------------------------------*
ISSUE_TRACE DS 0H
L R8,UEPTRACE Address of trace flag
TM 0(R8),UEPTRON Is trace on?
BZ NO_TRACE No - do not issue trace then
LR R12,R13 Save R13 round XPI call
L R13,UEPSTACK
DFHTRPTX CALL, X
IN, X
FUNCTION(TRACE_PUT), X
POINT_ID(*), X
OUT, X
RESPONSE(*), X
REASON(*)
LR R13,R12 Restore R13 (DFHEISTG)
NO_TRACE DS 0H
BR R6 Return to caller
DROP R1
*
*=====================================================================*
* ERRORn *
* Error has occurred during processing *
* Issue a trace point and return to the CICS *
*=====================================================================*
ERROR1 DS 0H
MVI TR_ERROR_N,1
B TRACE_ERROR
ERROR2 DS 0H
MVI TR_ERROR_N,2
B TRACE_ERROR
ERROR3 DS 0H
MVI TR_ERROR_N,3
B TRACE_ERROR
ERROR4 DS 0H
MVI TR_ERROR_N,4
B TRACE_ERROR
ERROR5 DS 0H
MVI TR_ERROR_N,5
B TRACE_ERROR
ERROR6 DS 0H
MVI TR_ERROR_N,6
B TRACE_ERROR
ERROR7 DS 0H
MVI TR_ERROR_N,7
B TRACE_ERROR
ERROR8 DS 0H
MVI TR_ERROR_N,7
B TRACE_ERROR
ERROR9 DS 0H
MVI TR_ERROR_N,7
B TRACE_ERROR
EJECT ,
DROP R2 Drop DFHUEPAR
DROP R11 Drop EIB
LTORG ,
***********************************************************************
* CONSTANTS *
***********************************************************************
DS 0D
EYE_CATCHER DC CL16'XTSEREQ Storage '
DEFAULT_SYSID DC CL4'MQ1 '
LOCAL EQU X'01'
ROUTE EQU X'02'
*
* Trace point ids
TR_ENTRY DC XL2'120'
TR_EXIT DC XL2'121'
TR_ERROR DC XL2'122'
*
*---------------------------------------------------------------------*
* TABLE_ENTRY: *
* ---------------------------------------------------------- *
* | Entry_Name | New_Name | QOR_Sysid | Action | *filler* | *
* | Char 8 | Char 8 | Char 4 | Bin 1 | Char 3 | *
* ---------------------------------------------------------- *
* Last Entry is indicated by special TS_Queue Name *
*---------------------------------------------------------------------*
TS_ROUTING_TABLE DS 0D
ENTRY_NAME_1 DC CL8'AAAAAAAA' Rename Queue AAAAAAAA as
NEW_NAME_1 DC CL8'BBBBBBBB' BBBBBBBBB
QOR_SYSID_1 DC CL4' '
ACTION_1 DC XL1'01' Local request
FILLER_1 DC CL3' '
ENTRY_NAME_2 DC CL8'A1 ' Rename Queue A1 as
NEW_NAME_2 DC CL8'B1 ' B1
QOR_SYSID_2 DC CL4' '
ACTION_2 DC XL1'01' Local request
FILLER_2 DC CL3' '
ENTRY_NAME_3 DC CL8'A2 ' Rename Queue A2 as
NEW_NAME_3 DC CL8'B2 ' B2
QOR_SYSID_3 DC CL4' '
ACTION_3 DC XL1'01' Local request
FILLER_3 DC CL3' '
ENTRY_NAME_4 DC CL8'RRRRRRRR' Rename Queue RRRRRRRR as
NEW_NAME_4 DC CL8'REMOTE ' REMOTE and ship request
QOR_SYSID_4 DC CL4'MQ1 ' to System MQ1
ACTION_4 DC XL1'02'
FILLER_4 DC CL3' '
ENTRY_NAME_5 DC CL8'R1 ' Don't rename Queue R1, but
NEW_NAME_5 DC CL8'R1 ' ship request to System MQ1
QOR_SYSID_5 DC CL4'MQ1 '
ACTION_5 DC XL1'02'
FILLER_5 DC CL3' '
ENTRY_NAME_LAST DC XL8'FFFFFFFFFFFFFFFF'
NEW_NAME_LAST DC CL8' '
QOR_SYSID_LAST DC CL4' '
ACTION_LAST DC XL1'00'
FILLER_LAST DC CL3' '
END DFH$XTSE
Before using the sample program in a production environment, you would need to customize it to suit your installation.