Page History
...
The source code for this exit program is stored in QCLSRC in the JSM library.
...
/* JSM LANSA/RPG EXIT PROGRAM */
...
PGM PARM(&SERVICE &SERVERHOST &HOST &PORT &REMOTEUSER &REMOTEADDR +
...
...
&PROCESS &FUNCTION &PARTITION &LANGUAGE &PROGRAM &RDMLX +...
...
&CONTINUE &MESSAGE)
...
DCL VAR(&SERVICE)
...
TYPE(*CHAR) LEN(30)...
DCL VAR(&SERVERHOST) TYPE(*CHAR) LEN(80)
...
DCL VAR(&HOST)
...
TYPE(*CHAR) LEN(80)
...
DCL VAR(&PORT)
...
TYPE(*CHAR) LEN(5)
...
DCL VAR(&REMOTEUSER) TYPE(*CHAR) LEN(30)
...
DCL VAR(&REMOTEADDR) TYPE(*CHAR) LEN(45)
...
DCL VAR(&REQUEST)
...
...
TYPE(*CHAR) LEN(10) VALUE(RUN)...
DCL VAR(&PROCESS)
...
TYPE(*CHAR) LEN(10)...
DCL VAR(&FUNCTION)
...
TYPE(*CHAR) LEN(10)...
DCL VAR(&PARTITION)
...
TYPE(*CHAR) LEN(3)
...
DCL VAR(&LANGUAGE)
...
TYPE(*CHAR) LEN(4)
...
DCL VAR(&PROGRAM)
...
TYPE(*CHAR) LEN(32)...
DCL VAR(&RDMLX)
...
TYPE(*CHAR) LEN(1)...
DCL VAR(&CONTINUE)
...
...
TYPE(*CHAR) LEN(1)...
DCL VAR(&MESSAGE)
...
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM01)
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM02)
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM03)
...
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM04)
...
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM05)
...
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM06)
...
TYPE(*CHAR) LEN(256)
...
DCL VAR(&PARM07)
...
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM08)
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM09)
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&PARM10)
...
...
TYPE(*CHAR) LEN(256)...
DCL VAR(&TASKID)
...
...
TYPE(*CHAR) LEN(8)...
DCL VAR(&PCTYPE)
...
TYPE(*CHAR) LEN(1) VALUE(N)...
DCL VAR(&DEVELOPER)
...
TYPE(*CHAR) LEN(1) VALUE(N)
...
DCL VAR(&ALLOWMSGS)
...
TYPE(*CHAR) LEN(1) VALUE(N)...
DCL VAR(&PCNAME)
...
...
TYPE(*CHAR) LEN(10)...
DCL VAR(&DATESRC)
...
...
TYPE(*CHAR) LEN(1) VALUE(S)...
DCL VAR(&BDEBUG)
...
TYPE(*CHAR) LEN(1) VALUE(N)
...
DCL VAR(&BDEBUGDEV)
...
TYPE(*CHAR) LEN(10)...
DCL VAR(&BDEBUGMSG)
...
TYPE(*CHAR) LEN(10)
...
DCL VAR(&XRUNADPRM)
...
TYPE(*CHAR) LEN(512)...
DCL VAR(&CTIME)
...
TYPE(*CHAR) LEN(6)...
DCL VAR(&JOBMSG)
...
...
TYPE(*CHAR) LEN(100)...
DCL VAR(&MSGID)
...
TYPE(*CHAR) LEN(7)...
DCL VAR(&MSGKEY)
...
TYPE(*CHAR) LEN(4)...
MONMSG MSGID(CPF0000)
...
/* DEFAULT VALUE FOR CONTINUE IS 'Y' */
...
/* CHGVAR VAR(&CONTINUE) VALUE('N') */
...
/* CHGVAR VAR(&MESSAGE)
...
VALUE('I do not know you') */...
/* GOTO END */
...
/* CALLSUBR SUBR(LOGSTR) */
...
IF COND(&PROGRAM *NE ' ') THEN(DO)
...
/* CALL RPG */
...
CALL &PROGRAM
...
GOTO END
...
ENDDO
IF COND(&RDMLX *EQ 'Y') THEN(DO)
...
/* CHANGE REQUEST TO RUN RDMLX */
...
CHGVAR VAR(&REQUEST) VALUE(X_RUN)
...
ENDDO
IF COND(&PROCESS *NE ' ' *AND &FUNCTION *NE ' ') THEN(DO)
...
IF COND(&REQUEST *EQ 'RUN') THEN(DO)
...
/* CALL LANSA V10 OR V11 */
...
CALL PGM(LANSA) PARM(&REQUEST &PROCESS &FUNCTION +
...
...
&PARM01 &PARM02 &PARM03 &PARM04 &PARM05 +
...
...
&PARM06 &PARM07 &PARM08 &PARM09 &PARM10 +
...
...
&PARTITION &LANGUAGE &TASKID &PCTYPE +
...
...
&DEVELOPER &ALLOWMSGS &PCNAME &DATESRC +
...
...
&BDEBUG &BDEBUGDEV &BDEBUGMSG)
...
MONMSG MSGID(DCM0000) EXEC(DO)
...
SNDPGMMSG MSG('LANSA RDML has ended abnormally')
...
ENDDO
...
GOTO END
...
ENDDO
...
IF COND(&REQUEST *EQ 'X_RUN') THEN(DO)
...
/* CALL LANSA V11 - RDMLX */
...
CALL PGM(LANSA) PARM(&REQUEST &PROCESS &FUNCTION +
...
...
&PARM01 &PARM02 &PARM03 &PARM04 &PARM05 +
...
...
&PARM06 &PARM07 &PARM08 &PARM09 &PARM10 +
...
...
&PARTITION &LANGUAGE &TASKID &PCTYPE +
...
...
&DEVELOPER &ALLOWMSGS &PCNAME &DATESRC +
...
...
&BDEBUG &BDEBUGDEV &BDEBUGMSG &XRUNADPRM)
...
MONMSG MSGID(DCM0000) EXEC(DO)
...
SNDPGMMSG MSG('LANSA RDMLX has ended abnormally')
...
ENDDO
...
GOTO END
...
ENDDO
...
ENDDO
SNDPGMMSG MSG('No program or function specified for execution')
...
END:
...
/* LANSA REPLACE LIBRARY LIST ON EXIT OPTION
...
ENABLED
...
*/...
/* CALLSUBR SUBR(RMVMSG) */
...
/* LANSA RECLAIM RESOURCES ON EXIT OPTION NOT ENABLED */
...
RCLRSC
/* CALLSUBR SUBR(LOGEND) */
...
/* =================================================================== */
...
...
/*
...
SUBROUTINES */
...
/* =================================================================== */...
SUBR SUBR(LOGSTR)
...
/* START TIME */
...
RTVSYSVAL SYSVAL(QTIME) RTNVAR(&CTIME)
...
CHGVAR VAR(&JOBMSG) VALUE('JSMLSAEXT START' *BCAT &CTIME)
...
SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&JOBMSG)
...
SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&FUNCTION)
...
/* RESET JOB INFO */
...
CALL PGM(LOGJOBINFO) PARM('*
...
YES ')
ENDSUBR
...
SUBR SUBR(LOGEND)
...
/* LOG JOB INFO */
...
CALL PGM(LOGJOBINFO) PARM('*
...
NO ')
...
/* END TIME */...
RTVSYSVAL SYSVAL(QTIME) RTNVAR(&CTIME)
...
CHGVAR VAR(&JOBMSG) VALUE('JSMLSAEXT END' *BCAT &CTIME)
...
SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&JOBMSG)
...
ENDSUBR
SUBR SUBR(RMVMSG)
...
/* LANSA REPLACE LIBRARY LIST ON EXIT OPTION
...
ENABLED */
...
/...
* Remove LANSA's CPC2101 Library list changed. ...
message */
...
/...
* http://www-01.ibm.com/support/docview.wss?uid=nas8N1016727 */
...
/...
* MSGKEY is 4-byte unsigned incrementing ...
integer */
...
/...
* Each job has a limited number of program messages ...
when */
...
/...
* 4,294,967,293 has been reached the OS terminates the ...
job */
...
CHGVAR VAR(&MSGID) VALUE(' ')...
SNDPGMMSG MSG('TEXT') TOPGMQ(*SAME) KEYVAR(&MSGKEY)
...
RMVMSG MSGKEY(&MSGKEY)
...
CHGVAR %BIN(&MSGKEY 1 4)
...
(%BIN(&MSGKEY 1 4) - 1)
...
RCVMSG PGMQ(*SAME (*)) MSGKEY(&MSGKEY) RMV(*NO) MSGID(&MSGID)
...
IF COND(&MSGID *EQ 'CPC2101') THEN(DO)
...
/* CPC2101 Library list changed. */
...
RCVMSG PGMQ(*SAME (*)) MSGKEY(&MSGKEY) RMV(*YES) MSGID(&MSGID)
...
ENDDO
...
ENDSUBR
ENDPGM