|
midrange.com
Hi Ron,
The following code is a working example of how compiler directives work.
The first program is a test program that does nothing more than use the
"SndPgmMsg" procedure. Notice how the "/Define Copying Prototypes"
statement is used to cause the prototypes to be read in. I built this
procedure to send program messages easily using the message API's.
-------------------------------------------------------------------
******Test Sending a Program Message.
/DEFINE Copying_Prototypes
/COPY SndPgmMsg
/UNDEFINE Copying_Prototypes
C CALLP SndPgmMsg('CPF2250' : 'QCPFMSG ')
C EVAL *INLR = *ON
-------------------------------------------------------------------
****** This is the actual program for Sending a Program Message via API.
/TITLE Send Program Msg. via API Subprocedure
/IF NOT DEFINED(Copying_Prototypes)
H Nomain
/ENDIF
/IF NOT DEFINED(SndPgmMsg_Prototype_Copied)
*** Define the Prototype for the "Send Program Msg. via API"
Subprocedure.
D SndPgmMsg PR
D MessageID 7 Const
D MsgFile 10 Const
D MessageDta 132 Const Options(*Nopass)
D MessageTyp 10 Const Options(*Nopass)
D PgmMsgQ 10 Const Options(*Nopass)
D PgmMsgQRel 5 Const Options(*Nopass)
/DEFINE SndPgmMsg_Prototype_Copied
/IF DEFINED(Copying_Prototypes)
/EOF
/ENDIF
/ENDIF
P SndPgmMsg B Export
*** Define the Procedure Interface.
D SndPgmMsg PI
D MessageID 7 Const
D MsgFile 10 Const
D MessageDta 132 Const Options(*Nopass)
D MessageTyp 10 Const Options(*Nopass)
D PgmMsgQ 10 Const Options(*Nopass)
D PgmMsgQRel 5 Const Options(*Nopass)
*** Define Data Structures.
D ErrorCode DS
D BytesProv 9B 0
D BytesAvail 9B 0
D ExceptID 7
D Reserved 1
D ExceptData 16
*** Define Standalone Fields.
D DataLength S 9B 0
D Error S 1
D MessageKey S 4
D MsgFileLib S 10
D PAR_MsgID S Like(MessageID)
D PAR_MsgDta S Like(MessageDta)
D PAR_MsgQ S Like(PgmMsgQ)
D PAR_MsgQRl S Like(PgmMsgQRel)
D PAR_MsgTyp S Like(MessageTyp)
D QualMsgFil S 20
D RelLevel S 9B 0
/EJECT
*** Initialize any "*NOPASS" parameters that weren't passed.
C IF %Parms < 3
C EVAL PAR_MsgDta = *Blanks
C ELSE
C EVAL PAR_MsgDta = MessageDta
C ENDIF
C IF %Parms < 4
C EVAL PAR_MsgTyp = *Blanks
C ELSE
C EVAL PAR_MsgTyp = MessageTyp
C ENDIF
C IF %Parms < 5
C EVAL PAR_MsgQ = *Blanks
C ELSE
C EVAL PAR_MsgQ = PgmMsgQ
C ENDIF
C IF %Parms < 6
C EVAL PAR_MsgQRl = *Blanks
C ELSE
C EVAL PAR_MsgQRl = PgmMsgQRel
C ENDIF
*** Default the Message File Library, if not specifed.
C EVAL MsgFileLib = '*LIBL'
C MsgFile CAT MsgFileLib QualMsgFil
*** Default the Program Message Queue, if not specifed.
C IF PAR_MsgQ = *BLANKS
C EVAL PAR_MsgQ = '*'
C IF PAR_MsgQRl = *BLANKS
C EVAL PAR_MsgQRl = '*PRV'
C ENDIF
C ENDIF
*** Default the Relative Level, if not specifed.
C IF PAR_MsgQRl = *BLANKS
C EVAL PAR_MsgQRl = '*SAME'
C ENDIF
*** Set up for the External Message Queue, if necessary.
C IF PAR_MsgQRl = '*EXT'
C EVAL PAR_MsgQ = '*EXT'
C ENDIF
*** Default the Message Type, if not specifed.
C IF PAR_MsgTyp = *BLANKS
C EVAL PAR_MsgTyp = '*DIAG'
C ENDIF
*** Determine Relative Level.
C IF PAR_MsgQRl = '*SAME'
C Or PAR_MsgQ = '*EXT'
C EVAL RelLevel = 0
C ELSE
C EVAL RelLevel = 1
C ENDIF
*** Initialize Fields.
C EVAL DataLength = 132
C EVAL MessageKey = *BLANKS
C EVAL Error = '0'
C EVAL ErrorCode = *BLANKS
C EVAL BytesProv = 0
C EVAL BytesAvail = 0
C EVAL PAR_MsgID = MessageID
/EJECT
*** Send the Program Message, by calling the API.
C CALL 'QMHSNDPM' 90
C PARM PAR_MsgID
C PARM QualMsgFil
C PARM PAR_MsgDta
C PARM DataLength
C PARM PAR_MsgTyp
C PARM PAR_MsgQ
C PARM RelLevel
C PARM MessageKey
C PARM ErrorCode
*** Did an Error occur?
C IF *IN90 = *ON
C Or BytesAvail > 0
C EVAL Error = '1'
C ENDIF
C IF Error = '1'
C EVAL *INH1 = *ON
C ENDIF
C RETURN
P SndPgmMsg E
Hope this helps. Let me know if you don't understand what's going on.
Bill
William K. Reger
Senior Project Manager
Levitz Furniture Corporation
Phone: (561) 994-5114
E-mail: breger@levitz.com <mailto:breger@levitz.com>
+---
| This is the Midrange System Mailing List!
| To submit a new message, send your mail to MIDRANGE-L@midrange.com.
| To subscribe to this list send email to MIDRANGE-L-SUB@midrange.com.
| To unsubscribe from this list send email to MIDRANGE-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-2025 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.
