如何監控系統中執行狀態為 MSGW 的工作，並傳送訊息至 MSGQ 或 Email？(Command CHKJOBMSGW -- Check Job Message Wait with QGYOLJOB Open list of jobs API)
File : QRPGLESRC
Member: CHKJOBMSGW
Usage : CRTBNDRPG PGM(CHKJOBMSGW)
**
** Program . . : CHKJOBMSGW
** Description : Check job msgw and send msgw info to msgq or mail
** Author . . : Vengoal Chang
** Published . : AS400ePaper
** Date . . . : June 5, 2015
**
**
** Program summary
** ---------------
**
** Work management APIs:
** QGYOLJOB Open list of jobs Lists jobs on the system based on
** the specified selection criteria.
**
** Optionally a sort order for the
** returned jobs can be specified -
** in this case the jobname first
**
** QWVRCSTK Retrieve Call Stack Lists the program call stack for
** the specified job or thread.
** The current invocation level is
** returned first.
**
** Message handling API:
** QMHSNDM Send message Sends a message to the specified
** non-program message queue - here
** an informational message is sent
** to the current user running this
** program.
**
** QMHRTVM Retrieve Message Retrieves the message description
** of a predefined message.
**
** Open list APIs:
** QGYGTLE Get list entries To retrieve open lists entries
** from an already open list the
** QGYGTLE (Get List Entries) API
** is available.
**
** QGYCLST Close list This API closes the previously
** opened list identified by the
** request handle parameter.
** Storage allocated is freed.
**
** MI builtins:
** _MEMMOVE Copy memory Copies a string from one pointer
** specified location to another.
**
** Unix Type - Signal APIs:
** Sleep Suspends program processing for
** the specified number of seconds.
**
**
** Sequence of events:
** 1. The list jobs API input parameters are initialized
**
** 2. The open list of jobs API is called
**
** 3. For each job get key data
** 101 Active job status
** 305 Current user profile
** 1307 Message reply
** 1308 Message key, when active job waiting for a message
** 1309 Message queue name - qualified, when active job waiting for a message
** 1906 Subsystem description name - qualified
**
** List job name and check whether job waiting message or not.
** If job wait for a reply to a message, send message to user
** which run the CHKJOBMSGW program.
**
** 4. The job list resources are cleaned up.
**
** 5. Sleep wakeup interval, then go to step 2. lsit msgw job
**
**
**
** Programmer's notes:
** To retrieve another job's call stack *JOBCTL special authority is
** required.
**
**
** Compile options:
**
** CrtBndPgm Pgm( CHKJOBMSGW )
**
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt ) DecEdit( *JobRun ) BndDir( 'QC2LE' )
H DftActGrp(*NO) Debug
**-- System information: -----------------------------------------------**
D PgmSts SDs
D PsPgmNam *Proc
D PsSts 5a Overlay( PgmSts: 11 )
D PsCurJob 10a Overlay( PgmSts: 244 )
D PsUsrPrf 10a Overlay( PgmSts: 254 )
D PsJobNbr 6a Overlay( PgmSts: 264 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- API error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeExcpId 7a
D 1a
D AeExcpDta 128a
**-- API parameters: ---------------------------------------------------**
D JlRtnRcdNbr s 10i 0 Inz( 1 )
D JlNbrFldRtn s 10i 0 Inz( %Elem( JlKeyFld ))
D JlKeyFld s 10i 0 Dim( 6 )
**-- Job information OLJB0300:
D*JlJobInf0300 Ds 512
D* JbJobId 26a
D* JbJobUsd 10a Overlay( JbJobId: 1 )
D* JbUsrUsd 10a Overlay( JbJobId: *Next )
D* JbNbrUsd 6a Overlay( JbJobId: *Next )
D* JbActSts 4a
D* JbJobTyp 1a
D* JbJobSubTyp 1a
D* JbDtaLen 10i 0
D* 4a
D* JbDta 256a
**-- Job information OLJB0200:
D JlJobInf Ds 512
D JbJobId 26a
D JbJobUsd 10a Overlay( JbJobId: 1 )
D JbUsrUsd 10a Overlay( JbJobId: *Next )
D JbNbrUsd 6a Overlay( JbJobId: *Next )
D JbJobIntId 16a
D JbJobSts 10a
D JbJobTyp 1a
D JbJobSubTyp 1a
D 2a
D JbJobInfoSts 1a
D 3a
D JbDta 256a
**-- Key information:
D JlKeyInf Ds
D KiFldNbrRtn 10i 0
D KiKeyInf 20a Dim( %Elem( JlKeyFld ))
D KiFldInfLen 10i 0 Overlay( KiKeyInf : 1 )
D KiKeyFld 10i 0 Overlay( KiKeyInf : 5 )
D KiDtaTyp 1a Overlay( KiKeyInf : 9 )
D 3a Overlay( KiKeyInf : 10 )
D KiDtaLen 10i 0 Overlay( KiKeyInf : 13 )
D KiDtaOfs 10i 0 Overlay( KiKeyInf : 17 )
**-- Sort information:
D JlSrtInf Ds
D SiNbrKeys 10i 0 Inz( 1 )
D SiSrtInf 12a Dim( 10 )
D SiKeyFldOfs 10i 0 Overlay( SiSrtInf : 1 )
D SiKeyFldLen 10i 0 Overlay( SiSrtInf : 5 )
D SiKeyFldTyp 5i 0 Overlay( SiSrtInf : 9 )
D SiSrtOrd 1a Overlay( SiSrtInf : 11 )
D SiRsv 1a Overlay( SiSrtInf : 12 )
**-- List information:
D JlLstInf Ds
D LiRcdNbrTot 10i 0
D LiRcdNbrRtn 10i 0
D LiHandle 4a
D LiRcdLen 10i 0
D LiInfSts 1a
D LiDts 13a
D LiLstSts 1a
D 1a
D LiInfLen 10i 0
D LiRcd1 10i 0
D 40a
**-- Selection information:
D JlSltInf Ds
D SiJobNam 10a Inz( '*ALL' )
D SiUsrNam 10a Inz( '*ALL' )
D SiJobNbr 6a Inz( '*ALL' )
D* SiJobTyp 1a Inz( 'I' )
D SiJobTyp 1a Inz( '*' )
D 1a
D SiOfsPriSts 10i 0 Inz(108 )
D SiNbrPriSts 10i 0 Inz( 1 )
D SiOfsActSts 10i 0 Inz(118 )
D SiNbrActSts 10i 0 Inz( 1 )
D SiOfsJbqSts 10i 0 Inz(126 )
D SiNbrJbqSts 10i 0 Inz( 0 )
D SiOfsJbqNam 10i 0 Inz(136 )
D SiNbrJbqNam 10i 0 Inz( 0 )
D SiOfsCurUsr 10i 0 Inz(156 )
D SiNbrCurUsr 10i 0 Inz( 0 )
D SiOfsSvrTyp 10i 0 Inz(166 )
D SiNbrSvrTyp 10i 0 Inz( 0 )
D SiOfsActSbs 10i 0 Inz(196 )
D SiNbrActSbs 10i 0 Inz( 0 )
D SiOfsMemPol 10i 0 Inz(206 )
D SiNbrMemPol 10i 0 Inz( 0 )
D SiOfsJobTypE 10i 0 Inz(210 )
D SiNbrJobTypE 10i 0 Inz( 0 )
D SiOfsQualJob 10i 0 Inz(214 )
D SiNbrQualJob 10i 0 Inz( 0 )
**
D SiPriSts 10a Dim( 1 )
D SiActSts 4a Dim( 2 )
D SiJbqSts 10a Dim( 1 )
D SiJbqNam 20a Dim( 1 )
D SiCurUsr 10a Dim( 1 )
D SiSvrTyp 30a Dim( 1 )
D SiActSbs 10a Dim( 1 )
D SiMemPol 10i 0 Dim( 1 )
D SiJobTypEn 10i 0 Dim( 1 )
D SiQualJob 26 Dim( 1 )
**-- Job information key fields:
D JbKeyDta Ds
D JbCurUSr 10
D JbMsgRpy 1
D JbMsgKeyRpy 4
D JbMsgQRpy 20
D JbQualSbs 20
**-- General return data:
D JlGenDta Ds
D GdBytRtn 10i 0
D GdBytAvl 10i 0
D GdElpTim 20u 0
D 16a
**-- API constants: ----------------------------------------------------**
D JOB_RESET_STAT c '1'
D JOB_KEEP_STAT c '0'
**-- Open list of jobs: ------------------------------------------------**
D LstJobs Pr ExtPgm( 'QGYOLJOB' )
D LjRcvVar 65535a Options( *VarSize )
D LjRcvVarLen 10i 0 Const
D LjFmtNam 8a Const
D LjRcvVarDfn 65535a Options( *VarSize )
D LjRcvDfnLen 10i 0 Const
D LjLstInf 80a
D LjNbrRcdRtn 10i 0 Const
D LjSrtInf 1024a Const Options( *VarSize )
D LjJobSltInf 1024a Const Options( *VarSize )
D LjJobSltLen 10i 0 Const
D LjNbrFldRtn 10i 0 Const
D LjKeyFldRtn 10i 0 Const Options( *VarSize ) Dim( 32 )
D LjError 1024a Options( *VarSize )
**
D LjJobSltFmt 8a Const Options( *NoPass )
**
D LjResStc 1a Const Options( *NoPass )
D LjGenRtnDta 32a Options( *NoPass: *VarSize )
D LjGenRtnDtaLn 10i 0 Const Options( *NoPass )
**-- Get list entry: ---------------------------------------------------**
D GetLstEnt Pr ExtPgm( 'QGYGTLE' )
D GlRcvVar 65535a Options( *VarSize )
D GlRcvVarLen 10i 0 Const
D GlHandle 4a Const
D GlLstInf 80a
D GlNbrRcdRtn 10i 0 Const
D GlRtnRcdNbr 10i 0 Const
D GlError 1024a Options( *VarSize )
**-- Close list: -------------------------------------------------------**
D CloseLst Pr ExtPgm( 'QGYCLST' )
D ClHandle 4a Const
D ClError 1024a Options( *VarSize )
**-- Send message: -----------------------------------------------------**
D SndMsg Pr ExtPgm( 'QMHSNDM' )
D SmMsgId 7a Const
D SmMsgFq 20a Const
D SmMsgDta 512a Const Options( *VarSize )
D SmMsgDtaLen 10i 0 Const
D SmMsgTyp 10a Const
D SmMsgQq 1000a Const Options( *VarSize )
D SmMsgQnbr 10i 0 Const
D SmMsgQrpy 20a Const
D SmMsgKey 4a
D SmError 10i 0 Const
**
D SmCcsId 10i 0 Const Options( *NoPass )
**-- Copy memory: ------------------------------------------------------**
D memcpy Pr * ExtProc( '_MEMMOVE' )
D outmem * Value
D inpmem * Value
D memsiz 10u 0 Value
**-- Delay job: --------------------------------------------------------**
D sleep Pr 10i 0 ExtProc( 'sleep' )
D seconds 10u 0 Value
**-- Get top stack entry: ----------------------------------------------**
D GetTopStkE Pr 20a
D GtJobId 26a Const
*** Prototypes for external subprocedures:
D Cmd PR ExtPgm('QCMDEXC')
D command 4096A OPTIONS(*VARSIZE) CONST
D length 15P 5 const
D tmpnam PR * extproc('_C_IFS_tmpnam')
D string 39A options(*omit)
D filename S 40A Varying
D fd S 10I 0
D CRLF S 2 INZ(X'0D25')
**-- Receive non-program message:
D RcvMsg Pr ExtPgm( 'QMHRCVM' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 10a Const
D MsgQueQ 20a Const
D MsgTyp 10a Const
D MsgKey 4a Const
D Wait 10i 0 Const
D MsgAct 10a Const
D Error 32767a Options( *VarSize )
D CcsId 10i 0 Const Options( *NoPass )
D AlwDftRpyRjt 10i 0 Const Options( *NoPass )
**-- Message information structure:
D RCVM0200 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D MsgSev 10i 0
D MsgId 7a
D MsgTyp 2s 0
D MsgKey 4a
D MsgFilNam 10a
D MsgFilLib_s 10a
D MsgFilLib_u 10a
D SndJobNam 10a
D SndJobUsr 10a
D SndJobNbr 6a
D SndPgmNam 12a
D 4a
D DatSnt 7s 0
D TimSnt 6s 0
D TimSntMs 6s 0
D SndUsrPrf 10a
D 1a
D CcsIdStsTxt 10i 0
D CcsIdStsDta 10i 0
D AlrOpt 9a
D CcsIdMsgTxt 10i 0
D CcsIdMsgDta 10i 0
D DtaLenRtn 10i 0
D DtaLenAvl 10i 0
D MsgLenRtn 10i 0
D MsgLenAvl 10i 0
D HlpLenRtn 10i 0
D HlpLenAvl 10i 0
D VarDta 32767a
**
**
D MsqNam_q Ds
D ObjNam 10a
D LibNam 10a
D DateSentC S 19
D DateSent Ds 13
D DateSnt 7s 0
D TimeSnt 6s 0
D SentYY 2 overlay(DateSent:2)
D SentMM 2 overlay(DateSent:4)
D SentDD 2 overlay(DateSent:6)
D SentHH 2 overlay(DateSent:8)
D SentMin 2 overlay(DateSent:10)
D Sentss 2 overlay(DateSent:12)
**-- Global variables: -------------------------------------------------**
D PgmNam s 20a
D MsgDta s 256a Varying
D MsgKey s 4a
D MsgTyp s 10a
D Subject s 60a
D PgmJob s 100a
D MsgTxt s 1024a Varying
D MsgHlpTxt s 1024a Varying
D SecLvlMsgTxt s 2048a Varying
D SecLvl s 4096a Varying
D MailText s 2048a Varying
D tempText s 2048a
D Ix s 5i 0
D Offset s 5i 0
D pos s 5i 0
D CmdStr S 4096
D QualMsgQ S 20
D SecLvlFmt s 78a Dim( 64 )
D MsgTxtFmt s 78a Dim( 64 )
D NbrLinMsg s 5i 0
D NbrLinSec s 5i 0
D LinIdx s 5i 0
D SysDts s z
D Idx s 5i 0
D IfsCcsid s 10U 0
**-- Global constants:
D OFS_MSGDTA c 16
D JOB_CCSID c 0
D RPY_SENT c '2'
D TYP_INQ c 5
D TYP_RPY c 21
D MSG_TXT c '&N Message . . . . : '
D RPY_DTA c 'Reply . . . . . : '
D NO_WAIT c 0
D KEEP_STS c '*SAME'
D NULL c ''
D WAIT_MAX c -1
D OLD_STS c '*OLD'
D QUOTE C X'7D'
D* Flags for use in open()
D O_RDWR C 4
D* Create File if not exist
D O_CREAT C 8
D* Exclusively create
D O_EXCL C 16
D* Assign a CCSID
D O_CCSID C 32
D* Truncate File to 0 bytes
D O_TRUNC C 64
D* Writing Only
D O_WRONLY C 2
D O_TEXTDATA C 16777216
D* Note: O_TEXT_CREAT requires all of the following flags to work:
D* O_CREAT+O_TEXTDATA+(O_CODEPAGE or O_CCSID)
D O_TEXT_CREAT C 33554432
D* owner authority
D S_IRUSR C 256
D S_IWUSR C 128
D*--------------------------------------------------------------------
D* Open a File
D open PR 10I 0 ExtProc('open')
D filename * value options(*string)
D openflags 10I 0 value
D mode 10U 0 value options(*nopass)
D codepage 10U 0 value options(*nopass)
D txtcreatid 10U 0 value options(*nopass)
D*--------------------------------------------------------------------
D* Close a file
D close PR 10I 0 ExtProc('close')
D handle 10I 0 value
D*--------------------------------------------------------------------
D* Remove Link to File.
D unlink PR 10I 0 ExtProc('unlink')
D path * Value options(*string)
D*--------------------------------------------------------------------
D* Write to a file
D write PR 10I 0 ExtProc('write')
D handle 10I 0 value
D buffer * value
D bytes 10U 0 value
**-- Retrieve message:
D RtvMsg Pr ExtPgm( 'QMHRTVM' )
D RcvVar 32767a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 10a Const
D MsgId 7a Const
D MsgFil_q 20a Const
D MsgDta 512a Const Options( *VarSize )
D MsgDtaLen 10i 0 Const
D RplSubVal 10a Const
D RtnFmtChr 10a Const
D Error 32767a Options( *VarSize )
D RtvOpt 10a Const Options( *NoPass )
D CvtCcsId 10i 0 Const Options( *NoPass )
D RplCcsId 10i 0 Const Options( *NoPass )
**-- Retrieve second level help text:
D RtvSecLvl Pr 4096a Varying
D PxMsgFil_q 20a Const
D PxMsgId 7a Const
D PxMsgDta 4096a Const Varying
**-- Format message string:
D FmtMsgStr Pr 78a Dim( 64 )
D PxMsgStr 4096a Value Varying
D PxNbrLin 5i 0
**-- Format message line:
D FmtMsgLin Pr 78a
D PxMsgLin 82a Const Varying
D PxPrcLen 5i 0
D PxInzInd n Options( *NoPass )
**-- Find format instruction:
D FndFmtIns Pr 5u 0
D PxMsgLin 82a Const Varying
D PxOffSet 5u 0 Const Options( *NoPass )
**-- Get indent positions:
D GetIndpos Pr 5u 0
D PxFmtIns 2a Const
D PxInxNxt 5u 0
**-- Scan reverse:
D ScanR Pr 5u 0
D PxArg 128a Const Varying
D PxString 4096a Const Varying
D PxOfs 5u 0 Const Options( *NoPass )
**-- Check AS400 Object exist ?
D As400ObjFound PR N
D QlObjName 20 Value
D ObjType 10 Value
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**-- Send program message:
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D MsgId 7a Const
D MsgFq 20a Const
D MsgDta 128a Const
D MsgDtaLen 10i 0 Const
D MsgTyp 10a Const
D CalStkE 10a Const Options( *VarSize )
D CalStkCtr 10i 0 Const
D MsgKey 4a
D Error 1024a Options( *VarSize )
**
**-- Mainline: ---------------------------------------------------------**
**
C *Entry Plist
C Parm WakeUp 5 0
C Parm Mail 4
C Parm MsgQ 4
C Parm ToMail 32
C IfsCcsid Parm CltCCSID 5 0
C Parm ToMsgQ 20
C If MsgQ = '*YES'
C CallP As400ObjFound( ToMsgQ : '*MSGQ' )
C EndIf
C Eval SiPriSts(1) = '*ACTIVE'
C Eval SiActSts(1) = 'MSGW'
**-- Job information return fields:
C Eval JlKeyFld(1) = 101
C Eval JlKeyFld(2) = 305
C Eval JlKeyFld(3) = 1307
C Eval JlKeyFld(4) = 1308
C Eval JlKeyFld(5) = 1309
C Eval JlKeyFld(6) = 1906
**
**-- Sort field specification:
C Eval SiNbrKeys = 1
C Eval SiKeyFldOfs(1) = 1
C Eval SiKeyFldLen(1) = 10
C Eval SiKeyFldTyp(1) = 4
C Eval SiSrtOrd(1) = '1'
C Eval SiRsv(1) = x'00'
**
C DoW 1 = 1
**
**-- Retrieve job list:
C CallP LstJobs( JlJobInf
C : %Size( JlJobInf )
C : 'OLJB0200'
C : JlKeyInf
C : %Size( JlKeyInf )
C : JlLstInf
C : 1
C : JlSrtInf
C : JlSltInf
C : %Size( JlSltInf )
C : JlNbrFldRtn
C : JlKeyFld
C : ApiError
C : 'OLJS0200'
C : JOB_KEEP_STAT
C : JlGenDta
C : %Size( JlGenDta )
C )
**
C If AeBytAvl = *Zero
**
C DoW LiLstSts <> '2' Or
C LiRcdNbrTot > JlRtnRcdNbr
**
C ExSr GetKeyDta
**
C Eval JlRtnRcdNbr = JlRtnRcdNbr + 1
**
C CallP GetLstEnt( JlJobInf
C : %Size( JlJobInf )
C : LiHandle
C : JlLstInf
C : 1
C : JlRtnRcdNbr
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Leave
C EndIf
**
C EndDo
**
C CallP CloseLst( LiHandle
C : ApiError
C )
**
**-- Wait 10 seconds:
C CallP sleep( WakeUp )
**
C Reset JlLstInf
C Eval JlRtnRcdNbr = 1
C Else
C Leave
C EndIf
C EndDo
C If AeBytAvl > *Zero
C CallP SndEscMsg( AeExcpId
C : 'QCPFMSG'
C : %Subst( AeExcpDta: 1: AeBytAvl- 16 )
C )
C EndIf
**
C Eval *InLr = *On
**
C Return
**
**-- Get KEY data: -----------------------------------------------------**
C GetKeyDta BegSr
**
C Clear JbKeyDta
**
C For Ix = 1 To KiFldNbrRtn
**
C Select
C When KiKeyFld(Ix) = 305
C CallP memcpy( %Addr( JbCurUsr )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 1307
C CallP memcpy( %Addr( JbMsgRpy )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 1308
C CallP memcpy( %Addr( JbMsgKeyRpy )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 1309
C CallP memcpy( %Addr( JbMsgQRpy )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 1906
C CallP memcpy( %Addr( JbQualSbs )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
C EndSl
C EndFor
**
C If JbMsgRpy = '1'
C Eval PgmNam = GetTopStkE( JbJobId )
C If MsgQ = '*YES'
C Exsr SndCmpMsg
C EndIf
C If Mail = '*YES'
C Exsr GetMsgTxt
C Exsr SndMailAtch
C EndIf
C EndIf
**
C EndSr
**-- Get Message Text: -------------------------------------------------**
C GetMsgTxt BegSr
**
C Eval MsgTyp = '*INQ'
C Eval MsgKey = JbMsgKeyRpy
C Eval MsqNam_q= JbMsgQRpy
C CallP RcvMsg( RCVM0200
C : %Size( RCVM0200 )
C : 'RCVM0200'
C : MsqNam_q
C : MsgTyp
C : MsgKey
C : NO_WAIT
C : OLD_STS
C : ApiError
C : JOB_CCSID
C )
C If RCVM0200.MsgFilLib_u=*Blanks
C eval RCVM0200.MsgFilLib_u=RCVM0200.MsgFilLib_s
C EndIf
C Eval MsgDta = %Subst( RCVM0200.VarDta
C : 1
C : RCVM0200.DtaLenRtn
C )
C eval MsgTxt = %Subst( RCVM0200.VarDta
C : RCVM0200.DtaLenRtn + 1
C : RCVM0200.MsgLenRtn
C )
C If RCVM0200.MsgId = *Blanks
C eval MsgTxt = MsgDta
C Else
C eval SecLvl = RtvSecLvl( RCVM0200.MsgFilNam +
C RCVM0200.MsgFilLib_u
C : RCVM0200.MsgId
C : MsgDta
C )
C eval SecLvlFmt=FmtMsgStr( SecLvl: NbrLinSec )
C eval SecLvlMsgTxt = *Blanks
C For idx = 1 to 64
C If %len(%trimr(SecLvlFmt(idx))) > 0
C If %Subst(SecLvlFmt(idx):1:2) <> 'Ca' and
C %Subst(SecLvlFmt(idx):1:2) <> 'Re'
C eval %Subst(SecLvlFmt(idx):1:2) = ' '
C EndIf
C eval SecLvlMsgTxt = %trimr(SecLvlMsgTxt) +
C SecLvlFmt(idx) + CRLF
C Else
C leave
C EndIf
C EndFor
C EndIf
C
C EndSr
**-- Send completion message: ------------------------------------------**
C SndCmpMsg BegSr
**
C Eval QualMsgQ = PsCurUsr + '*LIBL'
C If MsgQ <> *Blanks
C Eval QualMsgQ = ToMsgQ
C EndIf
C Eval MsgDta = 'Program ' +
C %Trim(%SubSt(PgmNam:11:10)) +
C '/' +
C %Trim(%SubSt(PgmNam: 1:10)) +
C ' in job ' +
C %Trim( JbNbrUsd ) + '/' +
C %Trim( JbUsrUsd ) + '/' +
C %Trim( JbJobUsd ) +
C ' waiting for a message' +
C ' in Msgq ' +
C %Trim(%SubSt(JbMsgQRpy:11:10))+
C '/' +
C %Trim(%SubSt(JbMsgQRpy:1:10))+
C '.'
**
C CallP(e) SndMsg( *Blanks
C : *Blanks
C : MsgDta
C : %Len( MsgDta )
C : '*COMP'
C : QualMsgQ
C : 1
C : *Blanks
C : MsgKey
C : 0
C )
**
C EndSr
**-- Send mail message with attach file: -------------------------------**
c SndMailAtch BegSr
c Eval DateSnt = RCVM0200.DatSnt
c Eval TimeSnt = RCVM0200.TimSnt
c Eval DateSentC = '20' + SentYY + '-' +
c SentMM + '-' + SentDD + '-' +
c SentHH + ':' + SentMIN+ ':' +
c SentSS
C Eval PgmJob = 'Program ' +
C %Trim(%SubSt(PgmNam:11:10)) +
C '/' +
C %Trim(%SubSt(PgmNam: 1:10)) +
C ' error in job ' +
C %Trim( JbNbrUsd ) + '/' +
C %Trim( JbUsrUsd ) + '/' +
C %Trim( JbJobUsd )
C Eval MailText =
C %trim(PgmJob) + CRLF +
C 'Time sent: '+DateSentc+' '+
C CRLF +
C 'Message ID: ' +
C RCVM0200.MsgId + CRLF +
C 'Message: ' + %trim(MsgTxt) +
C CRLF + CRLF
C* Eval filename = %str(tmpnam(*OMIT))
C Eval filename = '/tmp/' +
C 'Error_'+ %trim(JbJobUsd) +
C '_' + %trim(JbUsrUsd) +
C '_' + %trim(JbNbrUsd) +
C '.TXT'
C callp unlink(filename)
C
C Eval fd = open( filename
C : O_CREAT + O_CCSID+ O_WRONLY
C + O_TEXT_CREAT + O_TEXTDATA
C : S_IRUSR + S_IWUSR
C : IfsCcsid
C : 0 )
C
C if fd = -1
C* open failed, check errno for the reason why.
C endif
C callp write(fd: %addr(MailText)+2
C : %len(%trim(MailText)))
C
C If %len(SecLvlMsgTxt) > 0
C callp write(fd: %addr(SecLvlMsgTxt)+2
C : %len(%trim(SecLvlMsgTxt)))
C EndIf
C callp close(fd)
C
C Eval Subject = 'AS400 program ' +
C %Trim(%SubSt(PgmNam:11:10)) +
C '/' +
C %Trim(%SubSt(PgmNam: 1:10)) +
C ' exception occurred.'
C EVAL cmdSTR = 'SNDSMTPEMM RCP(' +
C %trim(ToMail) +
C ') SUBJECT(' + QUOTE +
C %trim(Subject) +
C QUOTE + ') NOTE(' +
C QUOTE +
C %trim( MailText) +
C QUOTE + ') ATTACH(' +
C QUOTE +
C %trim(filename) +
C QUOTE + ')'
C* ' CONTENT(*HTML)'
C callp(e) Cmd(%trim(cmdStr) : %len(%trim(cmdstr)))
C callp unlink(filename)
c EndSr
**-- Get top stack entry: ----------------------------------------------**
P GetTopStkE B Export
D Pi 20a
D GtJobId 26a Const
**-- API parameters:
D CsRcvVar Ds
D CsBytRtn 10i 0
D CsBytAvl 10i 0
D CsNbrStkE 10i 0
D CsOfsStkE 10i 0
D CsNbrEntRtn 10i 0
D CsThrId 8a
D CsInfSts 1a
D CsCalStk 32767a
**
D CsCalStkE Ds Based( pCalStkE )
D CsStkEntLen 10i 0
D CsOfsStmIds 10i 0
D CsNbrStmIds 10i 0
D CsOfsPrcNam 10i 0
D CsLenPrcNam 10i 0
D CsRqsLvl 10i 0
D CsPgmNam 10a
D CsPgmLib 10a
D CsMiInst 10i 0
D CsModNam 10a
D CsModLib 10a
D CsCtlBdy 1a
D CsRsv 3a
D CsActGrpNbr 10u 0
D CsActGrpNam 10a
D CsAddInf 4096a
**
D CsStmIds 10a Dim( 16 )
D CsPrcNam 512a
**
D CsJobId Ds
D JiJobId 26a
D JiJobNam 10a Overlay( JiJobId: 1 )
D JiUsrNam 10a Overlay( JiJobId: *Next )
D JiJobNbr 6a Overlay( JiJobId: *Next )
D JiIntId 16a
D JiRsv 2a Inz( *Allx'00' )
D JiThrInd 10i 0 Inz( 2 )
D JiThrId 8a Inz( *Allx'00' )
**-- Retrieve call stack:
D RtvCalStk Pr ExtPgm( 'QWVRCSTK' )
D RcRcvVar 32767a
D RcRcvVarLen 10i 0 Const
D RcRcvInfFmt 8a Const
D RcJobId 56a Const
D RcJobIdFmt 8a Const
D RcError 32767a Options( *VarSize )
**
D EntNbr s 5u 0
**-- Get stack entries: ------------------------------------------------**
**
C Eval JiJobId = GtJobId
**
C CallP RtvCalStk( CsRcvVar
C : %Size( CsRcvVar )
C : 'CSTK0100'
C : CsJobId
C : 'JIDF0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C Eval pCalStkE = %Addr( CsRcvVar ) + CsOfsStkE
**
C For EntNbr = 1 to CsNbrEntRtn
**
C* If EntNbr = 1
**
C Eval CsStmIds = *Blanks
C Eval CsPrcNam = *Blanks
**
C If CsOfsStmIds > *Zero
C CallP MemCpy( %Addr( CsStmIds )
C : %Addr( CsCalStkE ) +
C CsOfsStmIds
C : CsNbrStmIds * %Size( CsStmIds )
C )
C EndIf
**
C If CsOfsPrcNam > *Zero
C CallP MemCpy( %Addr( CsPrcNam )
C : %Addr( CsCalStkE ) +
C CsOfsPrcNam
C : CsLenPrcNam
C )
C EndIf
**
C* Leave
C* EndIf
C If %SubSt(CsPgmNam:1:1) <> 'Q'
C Leave
C EndIf
**
C If EntNbr < CsNbrEntRtn
C Eval pCalStkE = PCalStkE + CsStkEntLen
C EndIf
C EndFor
**
C Return CsPgmNam + CsPgmLib
**
C Else
C Return *Blanks
C EndIf
**
P GetTopStkE E
**-- Retrieve second level help text:
P RtvSecLvl B
D Pi 4096a Varying
D PxMsgFil_q 20a Const
D PxMsgId 7a Const
D PxMsgDta 4096a Const Varying
**-- Message information structure:
D RTVM0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D RtnMsgLen 10i 0
D RtnMsgAvl 10i 0
D RtnHlpLen 10i 0
D RtnHlpAvl 10i 0
D Msg 4096a
**
D RPL_SUB_VAL c '*YES'
D INC_FMT_CTL c '*YES'
/Free
RtvMsg( RTVM0100
: %Size( RTVM0100 )
: 'RTVM0100'
: PxMsgId
: PxMsgFil_q
: PxMsgDta
: %Len( PxMsgDta )
: RPL_SUB_VAL
: INC_FMT_CTL
: ApiError
);
If AeBytAvl > *Zero;
Return NULL;
Else;
Return %Subst( RTVM0100.Msg
: RTVM0100.RtnMsgLen + 1
: RTVM0100.RtnHlpLen
);
EndIf;
/End-Free
P RtvSecLvl E
**-- Format message string:
P FmtMsgStr B
D Pi 78a Dim( 64 )
D PxMsgStr 4096a Value Varying
D PxNbrLin 5i 0
**-- Local variables:
D InzInd s n Inz( *On )
D LinIdx s 5i 0
D PrcLen s 5i 0
D Strpos s 10i 0 Inz( 1 )
D RtnFmt s 78a Dim( 64 )
/Free
If PxMsgStr > *Blanks;
For LinIdx = 1 To %Elem( RtnFmt );
RtnFmt(LinIdx) = FmtMsgLin( %TrimL( PxMsgStr ): PrcLen: InzInd );
If %Len( %TrimL( PxMsgStr )) > PrcLen;
PxMsgStr = %Subst( %TrimL( PxMsgStr ): PrcLen + 1 );
Else;
Leave;
EndIf;
If PxMsgStr = *Blanks;
Leave;
EndIf;
EndFor;
EndIf;
PxNbrLin = LinIdx;
Return RtnFmt;
/End-Free
P FmtMsgStr E
**-- Format message line:
P FmtMsgLin B
D Pi 78a
D PxMsgLin 82a Const Varying
D PxPrcLen 5i 0
D PxInzInd n Options( *NoPass )
**-- Local variables:
D Indpos s 5u 0 Inz( 1 ) Static
D IndNxt s 5u 0 Inz( 1 ) Static
D StrLen s 5u 0
D Fmtpos s 5u 0
D FmtIns s 2a
D FmtBeg s n
D LeadBlk s 10i 0
**
D MsgLin Ds Qualified
D Lstpos 1a Overlay( MsgLin: 78 )
D Nxtpos 1a Overlay( MsgLin: 79 )
/Free
If %Parms = 3 And PxInzInd = *On;
Reset Indpos;
Reset IndNxt;
PxInzInd = *Off;
EndIf;
FmtBeg = *Off;
Fmtpos = FndFmtIns( PxMsgLin );
If Fmtpos > *Zero;
FmtIns = %Subst( PxMsgLin: Fmtpos: 2 );
If Fmtpos = 1;
FmtBeg = *On;
Indpos = GetIndpos( FmtIns: IndNxt );
Fmtpos = FndFmtIns( PxMsgLin: 4 );
If Fmtpos > *Zero;
%Subst( MsgLin: Indpos ) = %Subst( PxMsgLin: 4: Fmtpos - 4 );
Else;
%Subst( MsgLin: Indpos ) = %Subst( PxMsgLin: 4 );
EndIf;
Else;
%Subst( MsgLin: Indpos ) = %Subst( PxMsgLin: 1: Fmtpos - 1 );
EndIf;
Else;
%Subst( MsgLin: Indpos ) = %Subst( PxMsgLin: 1 );
EndIf;
LeadBlk = %Check( ' ': MsgLin );
If LeadBlk > *Zero;
LeadBlk -= Indpos;
EndIf;
Indpos = IndNxt;
If MsgLin.Lstpos = *Blank Or MsgLin.Nxtpos = *Blank;
StrLen = %Size( MsgLin ) - 1;
Else;
StrLen = ScanR( ' ': MsgLin ) - 1;
If StrLen = *Zero;
StrLen = %Size( MsgLin ) - 1;
EndIf;
EndIf;
MsgLin = %Subst( MsgLin: 1: StrLen );
If FmtBeg = *On;
PxPrcLen = %Len( %Trim( MsgLin )) + 3 + LeadBlk;
Else;
PxPrcLen = %Len( %Trim( MsgLin )) + 1 + LeadBlk;
EndIf;
Return MsgLin;
/End-Free
P FmtMsgLin E
**-- Find format instruction:
P FndFmtIns B
D Pi 5u 0
D PxMsgLin 82a Const Varying
D PxOffSet 5u 0 Const Options( *NoPass )
**-- Local variables:
D FmtposN s 5u 0
D FmtposP s 5u 0
D FmtposB s 5u 0
D OffSet s 5u 0
/Free
If %Parms = 2;
OffSet = PxOffSet;
Else;
OffSet = 1;
EndIf;
FmtposN = %Scan( '&N': PxMsgLin: OffSet );
FmtposP = %Scan( '&P': PxMsgLin: OffSet );
FmtposB = %Scan( '&B': PxMsgLin: OffSet );
If FmtposN = *Zero;
FmtposN = *HiVal;
EndIf;
If FmtposP = *Zero;
FmtposP = *HiVal;
EndIf;
If FmtposB = *Zero;
FmtposB = *HiVal;
EndIf;
Select;
When FmtposN < FmtposP And
FmtposN < FmtposB;
Return FmtposN;
When FmtposP < FmtposN And
FmtposP < FmtposB;
Return FmtposP;
When FmtposB < FmtposN And
FmtposB < FmtposP;
Return FmtposB;
EndSl;
Return *Zero;
/End-Free
P FndFmtIns E
**-- Get inden positions:
P GetIndpos B
D Pi 5u 0
D PxFmtIns 2a Const
D PxIndNxt 5u 0
/Free
Select;
When PxFmtIns = '&N';
PxIndNxt = 3;
Return 1;
When PxFmtIns = '&P';
PxIndNxt = 3;
Return 5;
When PxFmtIns = '&B';
PxIndNxt = 5;
Return 3;
Other;
PxIndNxt = 0;
Return 0;
EndSl;
/End-Free
P GetIndpos E
**-- Scan reverse:
P ScanR B
D Pi 5u 0
D PxArg 128a Const Varying
D PxString 4096a Const Varying
D PxOfs 5u 0 Const Options( *NoPass )
**
D pos s 5u 0
D Ofs s 5u 0
/Free
If %Parms = 3;
Ofs = PxOfs - %Len( PxArg ) + 1;
Else;
Ofs = %Len( PxString ) - %Len( PxArg ) + 1;
EndIf;
If Ofs > %Len( PxString );
pos = %Len( PxString ) + 1;
Else;
For pos = Ofs DownTo 1;
If %SubSt( PxString: pos: %Len( PxArg )) = PxArg;
Leave;
EndIf;
EndFor;
EndIf;
Return pos;
/End-Free
P ScanR E
** As400ObjFound - Attempts to locate an AS/400 object
P As400ObjFound B
D As400ObjFound PI N
D QlObjName 20 Value
D ObjType 10 Value
* Local variables and prototypes
D RtvObjDesc PR ExtPgm( 'QUSROBJD' )
D RcvrVar 8
D LenRcvrVar 10I 0 Const
D FmtName 8 Const
D QlObjName 20 Const
D ObjType 10 Const
D ApiErrInf Like( ApiError )
D Rcvr S 8
* Invoke the QUSROBJD API to attempt to locate the object
C CallP RtvObjDesc( Rcvr:
C %Size( Rcvr ):
C 'OBJD0100':
C QlObjName:
C ObjType:
C ApiError )
* If the API returns any error at all, I assume we were unable to
* locate the object.
C If AeBytAvl > *Zero
C CallP SndEscMsg( AeExcpId
C : 'QCPFMSG'
C : %Subst( AeExcpDta: 1: AeBytAvl- 16 )
C )
C Return *Off
C Else
C Return *On
C EndIf
P As400ObjFound E
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
D MsgFQual s 20a
C If %SubSt(PxMsgId: 1: 3) = 'GUI'
C eval %SubSt(MsgFQual : 1: 10) = 'QGUIMSG'
C Else
C eval %SubSt(MsgFQual : 1: 10) = PxMsgF
C EndIf
C eval %SubSt(MsgFQual :11: 10) = '*LIBL'
C Callp SndPgmMsg( PxMsgId
C : MsgFQual
C : PxMsgDta
C : %Len( PxMsgDta )
C : '*ESCAPE'
C : '*PGMBDY'
C : 1
C : MsgKey
C : ApiError
C )
C If AeBytAvl > *Zero
C Return -1
C
C Else
C Return 0
C EndIf
P SndEscMsg E
File : QCMDSRC
Member: CHKJOBMSGW
Usage : CrtCmd Cmd( CHKJOBMSGW )
Pgm( CHKJOBMSGW )
SrcFile( YourSourceFile )
/* =============================================================== */
/* = Command....... ChkJobMsgw = */
/* = CPP........... ChkJobMsgw RPGLE = */
/* = Description... Check job message waiting and send = */
/* = notification to msgq or detail info to mail = */
/* = or both = */
/* = = */
/* = CrtCmd Cmd( ChkJobMsgw ) = */
/* = Pgm( ChkJobMsgw ) = */
/* = SrcFile( YourSourceFile ) = */
/* =============================================================== */
/* = Date : 2015/06/05 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
/* = Usage: = */
/* = Notification send to MsgQ QSYSOPR : = */
/* = SBMJOB CMD(CHKJOBMSGW WAKEUP(600)) = */
/* = JOB(CHKJOBMSGW) = */
/* = JOBQ(QSYSNOMAX) = */
/* = = */
/* = Notification send to Mail with attachement by SNDSMTPEMM = */
/* = SBMJOB CMD(CHKJOBMSGW WAKEUP(600) = */
/* = MAIL(*YES) = */
/* = MSGQ(*NO ) = */
/* = TOMAIL('user@domain') = */
/* = CLTCCSID(819) = */
/* = ) = */
/* = JOB(CHKJOBMSGW) = */
/* = JOBQ(QSYSNOMAX) = */
/* = = */
/* =============================================================== */
Cmd Prompt('Check Job Message Wait')
Parm WAKEUP *Dec (5 0) +
Dft(300) +
Prompt('Wakeup interval for the batch')
Parm MAIL *Char 4 +
Dft(*NO) +
Values(*YES *NO) +
Rstd(*YES) +
Prompt('Send to mail')
Parm MSGQ *Char 4 +
Dft(*YES) +
Values(*YES *NO) +
Rstd(*YES) +
Prompt('Send to MsgQ')
Parm TOMAIL *Char 32 +
PmtCtl(IFMAIL) +
Prompt('Notification send to email')
Parm CLTCCSID *Dec (5 0) +
PmtCtl(IFMAIL) +
Dft(950) +
Prompt('Client ccsid for mail used')
Parm TOMSGQ +
Type( Qual2) +
PmtCtl(IFMSGQ) +
Prompt('Notification send to MsgQ')
QUAL2: Qual Type(*NAME) +
Dft(QSYSOPR) +
Expr(*YES)
Qual Type(*NAME) +
Dft(*LIBL) +
SpcVal((*LIBL) (*CURLIB)) +
Expr(*YES) +
Prompt('Library')
IFMAIL: PmtCtl Ctl(MAIL) Cond((*EQ *YES))
IFMSGQ: PmtCtl Ctl(MSGQ) Cond((*EQ *YES))
Dep Ctl(&MAIL *EQ *YES) +
Parm((&TOMAIL *NE ' ')) +
NbrTrue(*EQ 1)
Dep Ctl(&MAIL *EQ *NO) +
Parm((&MSGQ *NE *NO)) +
NbrTrue(*EQ 1)
File : QRPGLESRC
Member: CHKJOBMSGW
Usage : CRTBNDRPG PGM(CHKJOBMSGW)
**
** Program . . : CHKJOBMSGW
** Description : Check job msgw and send msgw info to msgq or mail
** Author . . : Vengoal Chang
** Published . : AS400ePaper
** Date . . . : June 5, 2015
**
**
** Program summary
** ---------------
**
** Work management APIs:
** QGYOLJOB Open list of jobs Lists jobs on the system based on
** the specified selection criteria.
**
** Optionally a sort order for the
** returned jobs can be specified -
** in this case the jobname first
**
** QWVRCSTK Retrieve Call Stack Lists the program call stack for
** the specified job or thread.
** The current invocation level is
** returned first.
**
** Message handling API:
** QMHSNDM Send message Sends a message to the specified
** non-program message queue - here
** an informational message is sent
** to the current user running this
** program.
**
** QMHRTVM Retrieve Message Retrieves the message description
** of a predefined message.
**
** Open list APIs:
** QGYGTLE Get list entries To retrieve open lists entries
** from an already open list the
** QGYGTLE (Get List Entries) API
** is available.
**
** QGYCLST Close list This API closes the previously
** opened list identified by the
** request handle parameter.
** Storage allocated is freed.
**
** MI builtins:
** _MEMMOVE Copy memory Copies a string from one pointer
** specified location to another.
**
** Unix Type - Signal APIs:
** Sleep Suspends program processing for
** the specified number of seconds.
**
**
** Sequence of events:
** 1. The list jobs API input parameters are initialized
**
** 2. The open list of jobs API is called
**
** 3. For each job get key data
** 101 Active job status
** 305 Current user profile
** 1307 Message reply
** 1308 Message key, when active job waiting for a message
** 1309 Message queue name - qualified, when active job waiting for a message
** 1906 Subsystem description name - qualified
**
** List job name and check whether job waiting message or not.
** If job wait for a reply to a message, send message to user
** which run the CHKJOBMSGW program.
**
** 4. The job list resources are cleaned up.
**
** 5. Sleep wakeup interval, then go to step 2. lsit msgw job
**
**
**
** Programmer's notes:
** To retrieve another job's call stack *JOBCTL special authority is
** required.
**
**
** Compile options:
**
** CrtBndPgm Pgm( CHKJOBMSGW )
**
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt ) DecEdit( *JobRun ) BndDir( 'QC2LE' )
H DftActGrp(*NO) Debug
**-- System information: -----------------------------------------------**
D PgmSts SDs
D PsPgmNam *Proc
D PsSts 5a Overlay( PgmSts: 11 )
D PsCurJob 10a Overlay( PgmSts: 244 )
D PsUsrPrf 10a Overlay( PgmSts: 254 )
D PsJobNbr 6a Overlay( PgmSts: 264 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- API error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeExcpId 7a
D 1a
D AeExcpDta 128a
**-- API parameters: ---------------------------------------------------**
D JlRtnRcdNbr s 10i 0 Inz( 1 )
D JlNbrFldRtn s 10i 0 Inz( %Elem( JlKeyFld ))
D JlKeyFld s 10i 0 Dim( 6 )
**-- Job information OLJB0300:
D*JlJobInf0300 Ds 512
D* JbJobId 26a
D* JbJobUsd 10a Overlay( JbJobId: 1 )
D* JbUsrUsd 10a Overlay( JbJobId: *Next )
D* JbNbrUsd 6a Overlay( JbJobId: *Next )
D* JbActSts 4a
D* JbJobTyp 1a
D* JbJobSubTyp 1a
D* JbDtaLen 10i 0
D* 4a
D* JbDta 256a
**-- Job information OLJB0200:
D JlJobInf Ds 512
D JbJobId 26a
D JbJobUsd 10a Overlay( JbJobId: 1 )
D JbUsrUsd 10a Overlay( JbJobId: *Next )
D JbNbrUsd 6a Overlay( JbJobId: *Next )
D JbJobIntId 16a
D JbJobSts 10a
D JbJobTyp 1a
D JbJobSubTyp 1a
D 2a
D JbJobInfoSts 1a
D 3a
D JbDta 256a
**-- Key information:
D JlKeyInf Ds
D KiFldNbrRtn 10i 0
D KiKeyInf 20a Dim( %Elem( JlKeyFld ))
D KiFldInfLen 10i 0 Overlay( KiKeyInf : 1 )
D KiKeyFld 10i 0 Overlay( KiKeyInf : 5 )
D KiDtaTyp 1a Overlay( KiKeyInf : 9 )
D 3a Overlay( KiKeyInf : 10 )
D KiDtaLen 10i 0 Overlay( KiKeyInf : 13 )
D KiDtaOfs 10i 0 Overlay( KiKeyInf : 17 )
**-- Sort information:
D JlSrtInf Ds
D SiNbrKeys 10i 0 Inz( 1 )
D SiSrtInf 12a Dim( 10 )
D SiKeyFldOfs 10i 0 Overlay( SiSrtInf : 1 )
D SiKeyFldLen 10i 0 Overlay( SiSrtInf : 5 )
D SiKeyFldTyp 5i 0 Overlay( SiSrtInf : 9 )
D SiSrtOrd 1a Overlay( SiSrtInf : 11 )
D SiRsv 1a Overlay( SiSrtInf : 12 )
**-- List information:
D JlLstInf Ds
D LiRcdNbrTot 10i 0
D LiRcdNbrRtn 10i 0
D LiHandle 4a
D LiRcdLen 10i 0
D LiInfSts 1a
D LiDts 13a
D LiLstSts 1a
D 1a
D LiInfLen 10i 0
D LiRcd1 10i 0
D 40a
**-- Selection information:
D JlSltInf Ds
D SiJobNam 10a Inz( '*ALL' )
D SiUsrNam 10a Inz( '*ALL' )
D SiJobNbr 6a Inz( '*ALL' )
D* SiJobTyp 1a Inz( 'I' )
D SiJobTyp 1a Inz( '*' )
D 1a
D SiOfsPriSts 10i 0 Inz(108 )
D SiNbrPriSts 10i 0 Inz( 1 )
D SiOfsActSts 10i 0 Inz(118 )
D SiNbrActSts 10i 0 Inz( 1 )
D SiOfsJbqSts 10i 0 Inz(126 )
D SiNbrJbqSts 10i 0 Inz( 0 )
D SiOfsJbqNam 10i 0 Inz(136 )
D SiNbrJbqNam 10i 0 Inz( 0 )
D SiOfsCurUsr 10i 0 Inz(156 )
D SiNbrCurUsr 10i 0 Inz( 0 )
D SiOfsSvrTyp 10i 0 Inz(166 )
D SiNbrSvrTyp 10i 0 Inz( 0 )
D SiOfsActSbs 10i 0 Inz(196 )
D SiNbrActSbs 10i 0 Inz( 0 )
D SiOfsMemPol 10i 0 Inz(206 )
D SiNbrMemPol 10i 0 Inz( 0 )
D SiOfsJobTypE 10i 0 Inz(210 )
D SiNbrJobTypE 10i 0 Inz( 0 )
D SiOfsQualJob 10i 0 Inz(214 )
D SiNbrQualJob 10i 0 Inz( 0 )
**
D SiPriSts 10a Dim( 1 )
D SiActSts 4a Dim( 2 )
D SiJbqSts 10a Dim( 1 )
D SiJbqNam 20a Dim( 1 )
D SiCurUsr 10a Dim( 1 )
D SiSvrTyp 30a Dim( 1 )
D SiActSbs 10a Dim( 1 )
D SiMemPol 10i 0 Dim( 1 )
D SiJobTypEn 10i 0 Dim( 1 )
D SiQualJob 26 Dim( 1 )
**-- Job information key fields:
D JbKeyDta Ds
D JbCurUSr 10
D JbMsgRpy 1
D JbMsgKeyRpy 4
D JbMsgQRpy 20
D JbQualSbs 20
**-- General return data:
D JlGenDta Ds
D GdBytRtn 10i 0
D GdBytAvl 10i 0
D GdElpTim 20u 0
D 16a
**-- API constants: ----------------------------------------------------**
D JOB_RESET_STAT c '1'
D JOB_KEEP_STAT c '0'
**-- Open list of jobs: ------------------------------------------------**
D LstJobs Pr ExtPgm( 'QGYOLJOB' )
D LjRcvVar 65535a Options( *VarSize )
D LjRcvVarLen 10i 0 Const
D LjFmtNam 8a Const
D LjRcvVarDfn 65535a Options( *VarSize )
D LjRcvDfnLen 10i 0 Const
D LjLstInf 80a
D LjNbrRcdRtn 10i 0 Const
D LjSrtInf 1024a Const Options( *VarSize )
D LjJobSltInf 1024a Const Options( *VarSize )
D LjJobSltLen 10i 0 Const
D LjNbrFldRtn 10i 0 Const
D LjKeyFldRtn 10i 0 Const Options( *VarSize ) Dim( 32 )
D LjError 1024a Options( *VarSize )
**
D LjJobSltFmt 8a Const Options( *NoPass )
**
D LjResStc 1a Const Options( *NoPass )
D LjGenRtnDta 32a Options( *NoPass: *VarSize )
D LjGenRtnDtaLn 10i 0 Const Options( *NoPass )
**-- Get list entry: ---------------------------------------------------**
D GetLstEnt Pr ExtPgm( 'QGYGTLE' )
D GlRcvVar 65535a Options( *VarSize )
D GlRcvVarLen 10i 0 Const
D GlHandle 4a Const
D GlLstInf 80a
D GlNbrRcdRtn 10i 0 Const
D GlRtnRcdNbr 10i 0 Const
D GlError 1024a Options( *VarSize )
**-- Close list: -------------------------------------------------------**
D CloseLst Pr ExtPgm( 'QGYCLST' )
D ClHandle 4a Const
D ClError 1024a Options( *VarSize )
**-- Send message: -----------------------------------------------------**
D SndMsg Pr ExtPgm( 'QMHSNDM' )
D SmMsgId 7a Const
D SmMsgFq 20a Const
D SmMsgDta 512a Const Options( *VarSize )
D SmMsgDtaLen 10i 0 Const
D SmMsgTyp 10a Const
D SmMsgQq 1000a Const Options( *VarSize )
D SmMsgQnbr 10i 0 Const
D SmMsgQrpy 20a Const
D SmMsgKey 4a
D SmError 10i 0 Const
**
D SmCcsId 10i 0 Const Options( *NoPass )
**-- Copy memory: ------------------------------------------------------**
D memcpy Pr * ExtProc( '_MEMMOVE' )
D outmem * Value
D inpmem * Value
D memsiz 10u 0 Value
**-- Delay job: --------------------------------------------------------**
D sleep Pr 10i 0 ExtProc( 'sleep' )
D seconds 10u 0 Value
**-- Get top stack entry: ----------------------------------------------**
D GetTopStkE Pr 20a
D GtJobId 26a Const
*** Prototypes for external subprocedures:
D Cmd PR ExtPgm('QCMDEXC')
D command 4096A OPTIONS(*VARSIZE) CONST
D length 15P 5 const
D tmpnam PR * extproc('_C_IFS_tmpnam')
D string 39A options(*omit)
D filename S 40A Varying
D fd S 10I 0
D CRLF S 2 INZ(X'0D25')
**-- Receive non-program message:
D RcvMsg Pr ExtPgm( 'QMHRCVM' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 10a Const
D MsgQueQ 20a Const
D MsgTyp 10a Const
D MsgKey 4a Const
D Wait 10i 0 Const
D MsgAct 10a Const
D Error 32767a Options( *VarSize )
D CcsId 10i 0 Const Options( *NoPass )
D AlwDftRpyRjt 10i 0 Const Options( *NoPass )
**-- Message information structure:
D RCVM0200 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D MsgSev 10i 0
D MsgId 7a
D MsgTyp 2s 0
D MsgKey 4a
D MsgFilNam 10a
D MsgFilLib_s 10a
D MsgFilLib_u 10a
D SndJobNam 10a
D SndJobUsr 10a
D SndJobNbr 6a
D SndPgmNam 12a
D 4a
D DatSnt 7s 0
D TimSnt 6s 0
D TimSntMs 6s 0
D SndUsrPrf 10a
D 1a
D CcsIdStsTxt 10i 0
D CcsIdStsDta 10i 0
D AlrOpt 9a
D CcsIdMsgTxt 10i 0
D CcsIdMsgDta 10i 0
D DtaLenRtn 10i 0
D DtaLenAvl 10i 0
D MsgLenRtn 10i 0
D MsgLenAvl 10i 0
D HlpLenRtn 10i 0
D HlpLenAvl 10i 0
D VarDta 32767a
**
**
D MsqNam_q Ds
D ObjNam 10a
D LibNam 10a
D DateSentC S 19
D DateSent Ds 13
D DateSnt 7s 0
D TimeSnt 6s 0
D SentYY 2 overlay(DateSent:2)
D SentMM 2 overlay(DateSent:4)
D SentDD 2 overlay(DateSent:6)
D SentHH 2 overlay(DateSent:8)
D SentMin 2 overlay(DateSent:10)
D Sentss 2 overlay(DateSent:12)
**-- Global variables: -------------------------------------------------**
D PgmNam s 20a
D MsgDta s 256a Varying
D MsgKey s 4a
D MsgTyp s 10a
D Subject s 60a
D PgmJob s 100a
D MsgTxt s 1024a Varying
D MsgHlpTxt s 1024a Varying
D SecLvlMsgTxt s 2048a Varying
D SecLvl s 4096a Varying
D MailText s 2048a Varying
D tempText s 2048a
D Ix s 5i 0
D Offset s 5i 0
D pos s 5i 0
D CmdStr S 4096
D QualMsgQ S 20
D SecLvlFmt s 78a Dim( 64 )
D MsgTxtFmt s 78a Dim( 64 )
D NbrLinMsg s 5i 0
D NbrLinSec s 5i 0
D LinIdx s 5i 0
D SysDts s z
D Idx s 5i 0
D IfsCcsid s 10U 0
**-- Global constants:
D OFS_MSGDTA c 16
D JOB_CCSID c 0
D RPY_SENT c '2'
D TYP_INQ c 5
D TYP_RPY c 21
D MSG_TXT c '&N Message . . . . : '
D RPY_DTA c 'Reply . . . . . : '
D NO_WAIT c 0
D KEEP_STS c '*SAME'
D NULL c ''
D WAIT_MAX c -1
D OLD_STS c '*OLD'
D QUOTE C X'7D'
D* Flags for use in open()
D O_RDWR C 4
D* Create File if not exist
D O_CREAT C 8
D* Exclusively create
D O_EXCL C 16
D* Assign a CCSID
D O_CCSID C 32
D* Truncate File to 0 bytes
D O_TRUNC C 64
D* Writing Only
D O_WRONLY C 2
D O_TEXTDATA C 16777216
D* Note: O_TEXT_CREAT requires all of the following flags to work:
D* O_CREAT+O_TEXTDATA+(O_CODEPAGE or O_CCSID)
D O_TEXT_CREAT C 33554432
D* owner authority
D S_IRUSR C 256
D S_IWUSR C 128
D*--------------------------------------------------------------------
D* Open a File
D open PR 10I 0 ExtProc('open')
D filename * value options(*string)
D openflags 10I 0 value
D mode 10U 0 value options(*nopass)
D codepage 10U 0 value options(*nopass)
D txtcreatid 10U 0 value options(*nopass)
D*--------------------------------------------------------------------
D* Close a file
D close PR 10I 0 ExtProc('close')
D handle 10I 0 value
D*--------------------------------------------------------------------
D* Remove Link to File.
D unlink PR 10I 0 ExtProc('unlink')
D path * Value options(*string)
D*--------------------------------------------------------------------
D* Write to a file
D write PR 10I 0 ExtProc('write')
D handle 10I 0 value
D buffer * value
D bytes 10U 0 value
**-- Retrieve message:
D RtvMsg Pr ExtPgm( 'QMHRTVM' )
D RcvVar 32767a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 10a Const
D MsgId 7a Const
D MsgFil_q 20a Const
D MsgDta 512a Const Options( *VarSize )
D MsgDtaLen 10i 0 Const
D RplSubVal 10a Const
D RtnFmtChr 10a Const
D Error 32767a Options( *VarSize )
D RtvOpt 10a Const Options( *NoPass )
D CvtCcsId 10i 0 Const Options( *NoPass )
D RplCcsId 10i 0 Const Options( *NoPass )
**-- Retrieve second level help text:
D RtvSecLvl Pr 4096a Varying
D PxMsgFil_q 20a Const
D PxMsgId 7a Const
D PxMsgDta 4096a Const Varying
**-- Format message string:
D FmtMsgStr Pr 78a Dim( 64 )
D PxMsgStr 4096a Value Varying
D PxNbrLin 5i 0
**-- Format message line:
D FmtMsgLin Pr 78a
D PxMsgLin 82a Const Varying
D PxPrcLen 5i 0
D PxInzInd n Options( *NoPass )
**-- Find format instruction:
D FndFmtIns Pr 5u 0
D PxMsgLin 82a Const Varying
D PxOffSet 5u 0 Const Options( *NoPass )
**-- Get indent positions:
D GetIndpos Pr 5u 0
D PxFmtIns 2a Const
D PxInxNxt 5u 0
**-- Scan reverse:
D ScanR Pr 5u 0
D PxArg 128a Const Varying
D PxString 4096a Const Varying
D PxOfs 5u 0 Const Options( *NoPass )
**-- Check AS400 Object exist ?
D As400ObjFound PR N
D QlObjName 20 Value
D ObjType 10 Value
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**-- Send program message:
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D MsgId 7a Const
D MsgFq 20a Const
D MsgDta 128a Const
D MsgDtaLen 10i 0 Const
D MsgTyp 10a Const
D CalStkE 10a Const Options( *VarSize )
D CalStkCtr 10i 0 Const
D MsgKey 4a
D Error 1024a Options( *VarSize )
**
**-- Mainline: ---------------------------------------------------------**
**
C *Entry Plist
C Parm WakeUp 5 0
C Parm Mail 4
C Parm MsgQ 4
C Parm ToMail 32
C IfsCcsid Parm CltCCSID 5 0
C Parm ToMsgQ 20
C If MsgQ = '*YES'
C CallP As400ObjFound( ToMsgQ : '*MSGQ' )
C EndIf
C Eval SiPriSts(1) = '*ACTIVE'
C Eval SiActSts(1) = 'MSGW'
**-- Job information return fields:
C Eval JlKeyFld(1) = 101
C Eval JlKeyFld(2) = 305
C Eval JlKeyFld(3) = 1307
C Eval JlKeyFld(4) = 1308
C Eval JlKeyFld(5) = 1309
C Eval JlKeyFld(6) = 1906
**
**-- Sort field specification:
C Eval SiNbrKeys = 1
C Eval SiKeyFldOfs(1) = 1
C Eval SiKeyFldLen(1) = 10
C Eval SiKeyFldTyp(1) = 4
C Eval SiSrtOrd(1) = '1'
C Eval SiRsv(1) = x'00'
**
C DoW 1 = 1
**
**-- Retrieve job list:
C CallP LstJobs( JlJobInf
C : %Size( JlJobInf )
C : 'OLJB0200'
C : JlKeyInf
C : %Size( JlKeyInf )
C : JlLstInf
C : 1
C : JlSrtInf
C : JlSltInf
C : %Size( JlSltInf )
C : JlNbrFldRtn
C : JlKeyFld
C : ApiError
C : 'OLJS0200'
C : JOB_KEEP_STAT
C : JlGenDta
C : %Size( JlGenDta )
C )
**
C If AeBytAvl = *Zero
**
C DoW LiLstSts <> '2' Or
C LiRcdNbrTot > JlRtnRcdNbr
**
C ExSr GetKeyDta
**
C Eval JlRtnRcdNbr = JlRtnRcdNbr + 1
**
C CallP GetLstEnt( JlJobInf
C : %Size( JlJobInf )
C : LiHandle
C : JlLstInf
C : 1
C : JlRtnRcdNbr
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Leave
C EndIf
**
C EndDo
**
C CallP CloseLst( LiHandle
C : ApiError
C )
**
**-- Wait 10 seconds:
C CallP sleep( WakeUp )
**
C Reset JlLstInf
C Eval JlRtnRcdNbr = 1
C Else
C Leave
C EndIf
C EndDo
C If AeBytAvl > *Zero
C CallP SndEscMsg( AeExcpId
C : 'QCPFMSG'
C : %Subst( AeExcpDta: 1: AeBytAvl- 16 )
C )
C EndIf
**
C Eval *InLr = *On
**
C Return
**
**-- Get KEY data: -----------------------------------------------------**
C GetKeyDta BegSr
**
C Clear JbKeyDta
**
C For Ix = 1 To KiFldNbrRtn
**
C Select
C When KiKeyFld(Ix) = 305
C CallP memcpy( %Addr( JbCurUsr )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 1307
C CallP memcpy( %Addr( JbMsgRpy )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 1308
C CallP memcpy( %Addr( JbMsgKeyRpy )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 1309
C CallP memcpy( %Addr( JbMsgQRpy )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 1906
C CallP memcpy( %Addr( JbQualSbs )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
C EndSl
C EndFor
**
C If JbMsgRpy = '1'
C Eval PgmNam = GetTopStkE( JbJobId )
C If MsgQ = '*YES'
C Exsr SndCmpMsg
C EndIf
C If Mail = '*YES'
C Exsr GetMsgTxt
C Exsr SndMailAtch
C EndIf
C EndIf
**
C EndSr
**-- Get Message Text: -------------------------------------------------**
C GetMsgTxt BegSr
**
C Eval MsgTyp = '*INQ'
C Eval MsgKey = JbMsgKeyRpy
C Eval MsqNam_q= JbMsgQRpy
C CallP RcvMsg( RCVM0200
C : %Size( RCVM0200 )
C : 'RCVM0200'
C : MsqNam_q
C : MsgTyp
C : MsgKey
C : NO_WAIT
C : OLD_STS
C : ApiError
C : JOB_CCSID
C )
C If RCVM0200.MsgFilLib_u=*Blanks
C eval RCVM0200.MsgFilLib_u=RCVM0200.MsgFilLib_s
C EndIf
C Eval MsgDta = %Subst( RCVM0200.VarDta
C : 1
C : RCVM0200.DtaLenRtn
C )
C eval MsgTxt = %Subst( RCVM0200.VarDta
C : RCVM0200.DtaLenRtn + 1
C : RCVM0200.MsgLenRtn
C )
C If RCVM0200.MsgId = *Blanks
C eval MsgTxt = MsgDta
C Else
C eval SecLvl = RtvSecLvl( RCVM0200.MsgFilNam +
C RCVM0200.MsgFilLib_u
C : RCVM0200.MsgId
C : MsgDta
C )
C eval SecLvlFmt=FmtMsgStr( SecLvl: NbrLinSec )
C eval SecLvlMsgTxt = *Blanks
C For idx = 1 to 64
C If %len(%trimr(SecLvlFmt(idx))) > 0
C If %Subst(SecLvlFmt(idx):1:2) <> 'Ca' and
C %Subst(SecLvlFmt(idx):1:2) <> 'Re'
C eval %Subst(SecLvlFmt(idx):1:2) = ' '
C EndIf
C eval SecLvlMsgTxt = %trimr(SecLvlMsgTxt) +
C SecLvlFmt(idx) + CRLF
C Else
C leave
C EndIf
C EndFor
C EndIf
C
C EndSr
**-- Send completion message: ------------------------------------------**
C SndCmpMsg BegSr
**
C Eval QualMsgQ = PsCurUsr + '*LIBL'
C If MsgQ <> *Blanks
C Eval QualMsgQ = ToMsgQ
C EndIf
C Eval MsgDta = 'Program ' +
C %Trim(%SubSt(PgmNam:11:10)) +
C '/' +
C %Trim(%SubSt(PgmNam: 1:10)) +
C ' in job ' +
C %Trim( JbNbrUsd ) + '/' +
C %Trim( JbUsrUsd ) + '/' +
C %Trim( JbJobUsd ) +
C ' waiting for a message' +
C ' in Msgq ' +
C %Trim(%SubSt(JbMsgQRpy:11:10))+
C '/' +
C %Trim(%SubSt(JbMsgQRpy:1:10))+
C '.'
**
C CallP(e) SndMsg( *Blanks
C : *Blanks
C : MsgDta
C : %Len( MsgDta )
C : '*COMP'
C : QualMsgQ
C : 1
C : *Blanks
C : MsgKey
C : 0
C )
**
C EndSr
**-- Send mail message with attach file: -------------------------------**
c SndMailAtch BegSr
c Eval DateSnt = RCVM0200.DatSnt
c Eval TimeSnt = RCVM0200.TimSnt
c Eval DateSentC = '20' + SentYY + '-' +
c SentMM + '-' + SentDD + '-' +
c SentHH + ':' + SentMIN+ ':' +
c SentSS
C Eval PgmJob = 'Program ' +
C %Trim(%SubSt(PgmNam:11:10)) +
C '/' +
C %Trim(%SubSt(PgmNam: 1:10)) +
C ' error in job ' +
C %Trim( JbNbrUsd ) + '/' +
C %Trim( JbUsrUsd ) + '/' +
C %Trim( JbJobUsd )
C Eval MailText =
C %trim(PgmJob) + CRLF +
C 'Time sent: '+DateSentc+' '+
C CRLF +
C 'Message ID: ' +
C RCVM0200.MsgId + CRLF +
C 'Message: ' + %trim(MsgTxt) +
C CRLF + CRLF
C* Eval filename = %str(tmpnam(*OMIT))
C Eval filename = '/tmp/' +
C 'Error_'+ %trim(JbJobUsd) +
C '_' + %trim(JbUsrUsd) +
C '_' + %trim(JbNbrUsd) +
C '.TXT'
C callp unlink(filename)
C
C Eval fd = open( filename
C : O_CREAT + O_CCSID+ O_WRONLY
C + O_TEXT_CREAT + O_TEXTDATA
C : S_IRUSR + S_IWUSR
C : IfsCcsid
C : 0 )
C
C if fd = -1
C* open failed, check errno for the reason why.
C endif
C callp write(fd: %addr(MailText)+2
C : %len(%trim(MailText)))
C
C If %len(SecLvlMsgTxt) > 0
C callp write(fd: %addr(SecLvlMsgTxt)+2
C : %len(%trim(SecLvlMsgTxt)))
C EndIf
C callp close(fd)
C
C Eval Subject = 'AS400 program ' +
C %Trim(%SubSt(PgmNam:11:10)) +
C '/' +
C %Trim(%SubSt(PgmNam: 1:10)) +
C ' exception occurred.'
C EVAL cmdSTR = 'SNDSMTPEMM RCP(' +
C %trim(ToMail) +
C ') SUBJECT(' + QUOTE +
C %trim(Subject) +
C QUOTE + ') NOTE(' +
C QUOTE +
C %trim( MailText) +
C QUOTE + ') ATTACH(' +
C QUOTE +
C %trim(filename) +
C QUOTE + ')'
C* ' CONTENT(*HTML)'
C callp(e) Cmd(%trim(cmdStr) : %len(%trim(cmdstr)))
C callp unlink(filename)
c EndSr
**-- Get top stack entry: ----------------------------------------------**
P GetTopStkE B Export
D Pi 20a
D GtJobId 26a Const
**-- API parameters:
D CsRcvVar Ds
D CsBytRtn 10i 0
D CsBytAvl 10i 0
D CsNbrStkE 10i 0
D CsOfsStkE 10i 0
D CsNbrEntRtn 10i 0
D CsThrId 8a
D CsInfSts 1a
D CsCalStk 32767a
**
D CsCalStkE Ds Based( pCalStkE )
D CsStkEntLen 10i 0
D CsOfsStmIds 10i 0
D CsNbrStmIds 10i 0
D CsOfsPrcNam 10i 0
D CsLenPrcNam 10i 0
D CsRqsLvl 10i 0
D CsPgmNam 10a
D CsPgmLib 10a
D CsMiInst 10i 0
D CsModNam 10a
D CsModLib 10a
D CsCtlBdy 1a
D CsRsv 3a
D CsActGrpNbr 10u 0
D CsActGrpNam 10a
D CsAddInf 4096a
**
D CsStmIds 10a Dim( 16 )
D CsPrcNam 512a
**
D CsJobId Ds
D JiJobId 26a
D JiJobNam 10a Overlay( JiJobId: 1 )
D JiUsrNam 10a Overlay( JiJobId: *Next )
D JiJobNbr 6a Overlay( JiJobId: *Next )
D JiIntId 16a
D JiRsv 2a Inz( *Allx'00' )
D JiThrInd 10i 0 Inz( 2 )
D JiThrId 8a Inz( *Allx'00' )
**-- Retrieve call stack:
D RtvCalStk Pr ExtPgm( 'QWVRCSTK' )
D RcRcvVar 32767a
D RcRcvVarLen 10i 0 Const
D RcRcvInfFmt 8a Const
D RcJobId 56a Const
D RcJobIdFmt 8a Const
D RcError 32767a Options( *VarSize )
**
D EntNbr s 5u 0
**-- Get stack entries: ------------------------------------------------**
**
C Eval JiJobId = GtJobId
**
C CallP RtvCalStk( CsRcvVar
C : %Size( CsRcvVar )
C : 'CSTK0100'
C : CsJobId
C : 'JIDF0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C Eval pCalStkE = %Addr( CsRcvVar ) + CsOfsStkE
**
C For EntNbr = 1 to CsNbrEntRtn
**
C* If EntNbr = 1
**
C Eval CsStmIds = *Blanks
C Eval CsPrcNam = *Blanks
**
C If CsOfsStmIds > *Zero
C CallP MemCpy( %Addr( CsStmIds )
C : %Addr( CsCalStkE ) +
C CsOfsStmIds
C : CsNbrStmIds * %Size( CsStmIds )
C )
C EndIf
**
C If CsOfsPrcNam > *Zero
C CallP MemCpy( %Addr( CsPrcNam )
C : %Addr( CsCalStkE ) +
C CsOfsPrcNam
C : CsLenPrcNam
C )
C EndIf
**
C* Leave
C* EndIf
C If %SubSt(CsPgmNam:1:1) <> 'Q'
C Leave
C EndIf
**
C If EntNbr < CsNbrEntRtn
C Eval pCalStkE = PCalStkE + CsStkEntLen
C EndIf
C EndFor
**
C Return CsPgmNam + CsPgmLib
**
C Else
C Return *Blanks
C EndIf
**
P GetTopStkE E
**-- Retrieve second level help text:
P RtvSecLvl B
D Pi 4096a Varying
D PxMsgFil_q 20a Const
D PxMsgId 7a Const
D PxMsgDta 4096a Const Varying
**-- Message information structure:
D RTVM0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D RtnMsgLen 10i 0
D RtnMsgAvl 10i 0
D RtnHlpLen 10i 0
D RtnHlpAvl 10i 0
D Msg 4096a
**
D RPL_SUB_VAL c '*YES'
D INC_FMT_CTL c '*YES'
/Free
RtvMsg( RTVM0100
: %Size( RTVM0100 )
: 'RTVM0100'
: PxMsgId
: PxMsgFil_q
: PxMsgDta
: %Len( PxMsgDta )
: RPL_SUB_VAL
: INC_FMT_CTL
: ApiError
);
If AeBytAvl > *Zero;
Return NULL;
Else;
Return %Subst( RTVM0100.Msg
: RTVM0100.RtnMsgLen + 1
: RTVM0100.RtnHlpLen
);
EndIf;
/End-Free
P RtvSecLvl E
**-- Format message string:
P FmtMsgStr B
D Pi 78a Dim( 64 )
D PxMsgStr 4096a Value Varying
D PxNbrLin 5i 0
**-- Local variables:
D InzInd s n Inz( *On )
D LinIdx s 5i 0
D PrcLen s 5i 0
D Strpos s 10i 0 Inz( 1 )
D RtnFmt s 78a Dim( 64 )
/Free
If PxMsgStr > *Blanks;
For LinIdx = 1 To %Elem( RtnFmt );
RtnFmt(LinIdx) = FmtMsgLin( %TrimL( PxMsgStr ): PrcLen: InzInd );
If %Len( %TrimL( PxMsgStr )) > PrcLen;
PxMsgStr = %Subst( %TrimL( PxMsgStr ): PrcLen + 1 );
Else;
Leave;
EndIf;
If PxMsgStr = *Blanks;
Leave;
EndIf;
EndFor;
EndIf;
PxNbrLin = LinIdx;
Return RtnFmt;
/End-Free
P FmtMsgStr E
**-- Format message line:
P FmtMsgLin B
D Pi 78a
D PxMsgLin 82a Const Varying
D PxPrcLen 5i 0
D PxInzInd n Options( *NoPass )
**-- Local variables:
D Indpos s 5u 0 Inz( 1 ) Static
D IndNxt s 5u 0 Inz( 1 ) Static
D StrLen s 5u 0
D Fmtpos s 5u 0
D FmtIns s 2a
D FmtBeg s n
D LeadBlk s 10i 0
**
D MsgLin Ds Qualified
D Lstpos 1a Overlay( MsgLin: 78 )
D Nxtpos 1a Overlay( MsgLin: 79 )
/Free
If %Parms = 3 And PxInzInd = *On;
Reset Indpos;
Reset IndNxt;
PxInzInd = *Off;
EndIf;
FmtBeg = *Off;
Fmtpos = FndFmtIns( PxMsgLin );
If Fmtpos > *Zero;
FmtIns = %Subst( PxMsgLin: Fmtpos: 2 );
If Fmtpos = 1;
FmtBeg = *On;
Indpos = GetIndpos( FmtIns: IndNxt );
Fmtpos = FndFmtIns( PxMsgLin: 4 );
If Fmtpos > *Zero;
%Subst( MsgLin: Indpos ) = %Subst( PxMsgLin: 4: Fmtpos - 4 );
Else;
%Subst( MsgLin: Indpos ) = %Subst( PxMsgLin: 4 );
EndIf;
Else;
%Subst( MsgLin: Indpos ) = %Subst( PxMsgLin: 1: Fmtpos - 1 );
EndIf;
Else;
%Subst( MsgLin: Indpos ) = %Subst( PxMsgLin: 1 );
EndIf;
LeadBlk = %Check( ' ': MsgLin );
If LeadBlk > *Zero;
LeadBlk -= Indpos;
EndIf;
Indpos = IndNxt;
If MsgLin.Lstpos = *Blank Or MsgLin.Nxtpos = *Blank;
StrLen = %Size( MsgLin ) - 1;
Else;
StrLen = ScanR( ' ': MsgLin ) - 1;
If StrLen = *Zero;
StrLen = %Size( MsgLin ) - 1;
EndIf;
EndIf;
MsgLin = %Subst( MsgLin: 1: StrLen );
If FmtBeg = *On;
PxPrcLen = %Len( %Trim( MsgLin )) + 3 + LeadBlk;
Else;
PxPrcLen = %Len( %Trim( MsgLin )) + 1 + LeadBlk;
EndIf;
Return MsgLin;
/End-Free
P FmtMsgLin E
**-- Find format instruction:
P FndFmtIns B
D Pi 5u 0
D PxMsgLin 82a Const Varying
D PxOffSet 5u 0 Const Options( *NoPass )
**-- Local variables:
D FmtposN s 5u 0
D FmtposP s 5u 0
D FmtposB s 5u 0
D OffSet s 5u 0
/Free
If %Parms = 2;
OffSet = PxOffSet;
Else;
OffSet = 1;
EndIf;
FmtposN = %Scan( '&N': PxMsgLin: OffSet );
FmtposP = %Scan( '&P': PxMsgLin: OffSet );
FmtposB = %Scan( '&B': PxMsgLin: OffSet );
If FmtposN = *Zero;
FmtposN = *HiVal;
EndIf;
If FmtposP = *Zero;
FmtposP = *HiVal;
EndIf;
If FmtposB = *Zero;
FmtposB = *HiVal;
EndIf;
Select;
When FmtposN < FmtposP And
FmtposN < FmtposB;
Return FmtposN;
When FmtposP < FmtposN And
FmtposP < FmtposB;
Return FmtposP;
When FmtposB < FmtposN And
FmtposB < FmtposP;
Return FmtposB;
EndSl;
Return *Zero;
/End-Free
P FndFmtIns E
**-- Get inden positions:
P GetIndpos B
D Pi 5u 0
D PxFmtIns 2a Const
D PxIndNxt 5u 0
/Free
Select;
When PxFmtIns = '&N';
PxIndNxt = 3;
Return 1;
When PxFmtIns = '&P';
PxIndNxt = 3;
Return 5;
When PxFmtIns = '&B';
PxIndNxt = 5;
Return 3;
Other;
PxIndNxt = 0;
Return 0;
EndSl;
/End-Free
P GetIndpos E
**-- Scan reverse:
P ScanR B
D Pi 5u 0
D PxArg 128a Const Varying
D PxString 4096a Const Varying
D PxOfs 5u 0 Const Options( *NoPass )
**
D pos s 5u 0
D Ofs s 5u 0
/Free
If %Parms = 3;
Ofs = PxOfs - %Len( PxArg ) + 1;
Else;
Ofs = %Len( PxString ) - %Len( PxArg ) + 1;
EndIf;
If Ofs > %Len( PxString );
pos = %Len( PxString ) + 1;
Else;
For pos = Ofs DownTo 1;
If %SubSt( PxString: pos: %Len( PxArg )) = PxArg;
Leave;
EndIf;
EndFor;
EndIf;
Return pos;
/End-Free
P ScanR E
** As400ObjFound - Attempts to locate an AS/400 object
P As400ObjFound B
D As400ObjFound PI N
D QlObjName 20 Value
D ObjType 10 Value
* Local variables and prototypes
D RtvObjDesc PR ExtPgm( 'QUSROBJD' )
D RcvrVar 8
D LenRcvrVar 10I 0 Const
D FmtName 8 Const
D QlObjName 20 Const
D ObjType 10 Const
D ApiErrInf Like( ApiError )
D Rcvr S 8
* Invoke the QUSROBJD API to attempt to locate the object
C CallP RtvObjDesc( Rcvr:
C %Size( Rcvr ):
C 'OBJD0100':
C QlObjName:
C ObjType:
C ApiError )
* If the API returns any error at all, I assume we were unable to
* locate the object.
C If AeBytAvl > *Zero
C CallP SndEscMsg( AeExcpId
C : 'QCPFMSG'
C : %Subst( AeExcpDta: 1: AeBytAvl- 16 )
C )
C Return *Off
C Else
C Return *On
C EndIf
P As400ObjFound E
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
D MsgFQual s 20a
C If %SubSt(PxMsgId: 1: 3) = 'GUI'
C eval %SubSt(MsgFQual : 1: 10) = 'QGUIMSG'
C Else
C eval %SubSt(MsgFQual : 1: 10) = PxMsgF
C EndIf
C eval %SubSt(MsgFQual :11: 10) = '*LIBL'
C Callp SndPgmMsg( PxMsgId
C : MsgFQual
C : PxMsgDta
C : %Len( PxMsgDta )
C : '*ESCAPE'
C : '*PGMBDY'
C : 1
C : MsgKey
C : ApiError
C )
C If AeBytAvl > *Zero
C Return -1
C
C Else
C Return 0
C EndIf
P SndEscMsg E
File : QCMDSRC
Member: CHKJOBMSGW
Usage : CrtCmd Cmd( CHKJOBMSGW )
Pgm( CHKJOBMSGW )
SrcFile( YourSourceFile )
/* =============================================================== */
/* = Command....... ChkJobMsgw = */
/* = CPP........... ChkJobMsgw RPGLE = */
/* = Description... Check job message waiting and send = */
/* = notification to msgq or detail info to mail = */
/* = or both = */
/* = = */
/* = CrtCmd Cmd( ChkJobMsgw ) = */
/* = Pgm( ChkJobMsgw ) = */
/* = SrcFile( YourSourceFile ) = */
/* =============================================================== */
/* = Date : 2015/06/05 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
/* = Usage: = */
/* = Notification send to MsgQ QSYSOPR : = */
/* = SBMJOB CMD(CHKJOBMSGW WAKEUP(600)) = */
/* = JOB(CHKJOBMSGW) = */
/* = JOBQ(QSYSNOMAX) = */
/* = = */
/* = Notification send to Mail with attachement by SNDSMTPEMM = */
/* = SBMJOB CMD(CHKJOBMSGW WAKEUP(600) = */
/* = MAIL(*YES) = */
/* = MSGQ(*NO ) = */
/* = TOMAIL('user@domain') = */
/* = CLTCCSID(819) = */
/* = ) = */
/* = JOB(CHKJOBMSGW) = */
/* = JOBQ(QSYSNOMAX) = */
/* = = */
/* =============================================================== */
Cmd Prompt('Check Job Message Wait')
Parm WAKEUP *Dec (5 0) +
Dft(300) +
Prompt('Wakeup interval for the batch')
Parm MAIL *Char 4 +
Dft(*NO) +
Values(*YES *NO) +
Rstd(*YES) +
Prompt('Send to mail')
Parm MSGQ *Char 4 +
Dft(*YES) +
Values(*YES *NO) +
Rstd(*YES) +
Prompt('Send to MsgQ')
Parm TOMAIL *Char 32 +
PmtCtl(IFMAIL) +
Prompt('Notification send to email')
Parm CLTCCSID *Dec (5 0) +
PmtCtl(IFMAIL) +
Dft(950) +
Prompt('Client ccsid for mail used')
Parm TOMSGQ +
Type( Qual2) +
PmtCtl(IFMSGQ) +
Prompt('Notification send to MsgQ')
QUAL2: Qual Type(*NAME) +
Dft(QSYSOPR) +
Expr(*YES)
Qual Type(*NAME) +
Dft(*LIBL) +
SpcVal((*LIBL) (*CURLIB)) +
Expr(*YES) +
Prompt('Library')
IFMAIL: PmtCtl Ctl(MAIL) Cond((*EQ *YES))
IFMSGQ: PmtCtl Ctl(MSGQ) Cond((*EQ *YES))
Dep Ctl(&MAIL *EQ *YES) +
Parm((&TOMAIL *NE ' ')) +
NbrTrue(*EQ 1)
Dep Ctl(&MAIL *EQ *NO) +
Parm((&MSGQ *NE *NO)) +
NbrTrue(*EQ 1)
看到這裡真的有霧煞煞的感覺吧～
