|
midrange.com
The following code will clear the program message queue/ will remove a
specific message from the program message queue and write the messages to
program message queue.
D DS
D MSGLEN 1 4B 0 INZ
D PGMSTK 5 8B 0 INZ
* ==> The following data variable decleration is used to retrive
* the messages from program message queue. For evaluate the
* type of message.
DRCVM0100_Ds DS
D ByteReturn 9B 0 INZ
D ByteAvail 9B 0 INZ
D MsgSever 9B 0 INZ
D MessageID 7 INZ
D MessageTyp 2 INZ
D MessageKy1 4 INZ
D Resserve_1 7 INZ
D CCSID_Flag 9B 0 INZ
D CCSID_RplD 9B 0 INZ
D CCSID_RplL 9B 0 INZ
D MsgRplData 127 INZ
DMessageLen 9B 0 INZ(171)
DFormatName 8 INZ('RCVM0100')
DStackPtr * INZ(*NULL)
DStackCntr 9B 0 INZ(*ZEROS)
DMessageType 10 INZ
DMessageKey 4 INZ
DWaitTime 9B 0 INZ(*ZEROS)
DMessageActn 10 INZ('*SAME')
DLengthStack 9B 0 INZ(16)
DEntryQual 20 INZ('*NONE *NONE ')
DStackType 10 INZ('*PTR')
DCCSID_Set 9B 0 INZ(*ZEROS)
* ==> Data structure for AS/400 APIs to return the error information
* whenever a API is called.
DApiErrDts DS
D ApiErrLen 1 4B 0 INZ(272)
D ApiErrAvl 5 8B 0 INZ
D ApiErrId 9 15A INZ
D ApiErrDta 17 272A INZ
* ==> Parameter for QMHRMVPH (Remove message API)
C PREMOV PLIST
C PARM PGMMSQ
C PARM PGMSTK
C PARM MSGKEY
C PARM TORMV 10
C PARM ApiErrDts
* ==> Parameter for QMHRCVPM (Receive Program Message).
C QMHRCV_Prm PLIST
C PARM RCVM0100_Ds
C PARM MessageLen
C PARM FormatName
C PARM *NULL StackPtr
C PARM *ZEROS StackCntr
C PARM MessageType
C PARM MessageKey
C PARM WaitTime
C PARM MessageActn
C PARM APIErrDts
C PARM LengthStack
C PARM EntryQual
C PARM StackType
C PARM CCSID_Set
* ==> Parameter for QMHSNDPM (To send the message to program msgq)
C PSENDM PLIST
C PARM MSGID 7
C PARM MSGF 20
C PARM MSGDTA 512
C PARM 512 MSGLEN
C PARM '*INFO' MSGTYP 10
C PARM PGMMSQ 10
C PARM *ZEROS PGMSTK
C PARM MSGKEY 4
C PARM ApiErrDts
* +---------------------------------------------------------------+ *
* ¦ $MsgHndlr : This subroutine will clear or send messages ¦ *
* ¦ to the program message queue. ¦ *
* ¦ ¦ *
* ¦ Basic Inp : ERRFNCTYP - (C)lear or (E) or Blanks ¦ *
* ¦ PREMOV - Variables declared under PREMOV ¦ *
* ¦ parameter list. ¦ *
* ¦ PSENDM - Variables declared under PSENDM ¦ *
* ¦ parameter list. ¦ *
* +---------------------------------------------------------------+ *
C $MSGHNDLR BEGSR
C EVAL PgmMsq = PgmName
C MOVE *IN89 ErrIND89 1
* ==> Clear the program message queue when ERRFNCTYP = (C)lear.
C SELECT
C WHEN ErrFncTyp = 'C'
C EVAL PGMSTK = *ZEROS
C EVAL MSGKEY = *BLANKS
C EVAL TORMV = '*ALL'
C CALL 'QMHRMVPM' PREMOV 8989
C RESET ErrFncTyp
* ==> Remove unwanted message. This part will retain only those message
* which was written by the application and not by the system.
C WHEN ErrFncTyp = 'E'
C RESET ErrFncTyp
C RESET RCVM0100_Ds
C RESET MessageActn
C EVAL MessageType = '*NEXT'
C EVAL MessageKey = X'00000000'
C CALL 'QMHRCVPM' QMHRCV_Prm
C DOW MessageID <> *BLANKS
C IF MessageTyp <> '04'
C EVAL PGMSTK = *ZEROS
C EVAL MSGKEY = MessageKy1
C EVAL TORMV = '*BYKEY'
C CALL 'QMHRMVPM' PREMOV 8989
C ENDIF
C RESET RCVM0100_Ds
C RESET MessageActn
C EVAL MessageType = '*NEXT'
C EVAL MessageKey = MessageKy1
C CALL 'QMHRCVPM' QMHRCV_Prm
C ENDDO
* ==> Write the message to the program message queue.
C OTHER
C EVAL MSGF = 'QCPFMSGF *LIBL '
C CALL 'QMHSNDPM' PSENDM 8989
C EVAL MSGID = *BLANKS
C EVAL MSGDTA = *BLANKS
C ENDSL
C EVAL *IN89 = ErrIND89
C ENDSR
+---
| This is the RPG/400 Mailing List!
| To submit a new message, send your mail to RPG400-L@midrange.com.
| To subscribe to this list send email to RPG400-L-SUB@midrange.com.
| To unsubscribe from this list send email to RPG400-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
