Part of service program I have that does message functions.
**FREE
dcl-pr SendProgramMessage ExtPgm('QMHSNDPM');
PR_MessageId Char(7) Const;
PR_QualifiedMessageFile Char(20) Const;
PR_MessageData Char(32767) Options(*VarSize) Const;
PR_MessageDataLength Int(10) Const;
PR_MessageType Char(10) Const;
PR_CallStackEntry Char(4096) Options(*Varsize) Const;
PR_CallStackEntryCounter Int(10) Const;
PR_MessageKey Char(4);
PR_ErrorReturn LikeDs(TD_StdErrorModel);
PR_LengthOfCallStackEntry Int(10) Const Options(*NoPass);
PR_CallStackQualification Char(20) Const Options(*NoPass);
PR_WaitTime Int(10) Const Options(*NoPass);
end-pr;
dcl-pr ReceiveProgramMessage ExtPgm('QMHRCVPM');
PR_MessageInformation Char(32767) Options(*VarSize);
PR_LengthOfMessageInformation Int(10) Const;
PR_FormatName Char(8) Const;
PR_CallStackEntry Char(4096) Options(*Varsize) Const;
PR_CallStackEntryCounter Int(10) Const;
PR_MessageType Char(10) Const;
PR_MessageKey Char(4) Const;
PR_WaitTime Int(10) Const;
PR_MessageAction Char(10) Const;
PR_ErrorReturn LikeDs(TD_StdErrorModel);
end-pr;
dcl-ds TD_ReturnMessage Qualified Template;
BytesReturn Int(10);
BytesAvailable Int(10);
MessageSeverity Int(10);
MessageIdentifier Char(7);
MessageType Char(2);
MessageKey Char(4);
MessageFileName Char(10);
MessageFileLibrarySpecified Char(10);
MessageFileLibraryUsed Char(10);
SendingJob Char(10);
SendingJobUserProfile Char(10);
SendingJobNumber Char(6);
SendingProgramName Char(12);
SendingInstructionNumber Char(4);
DateSent Char(7);
TimeSent Char(6);
ReceivingProgramName Char(10);
ReceivingInstructionNumber Char(4);
SendingType Char(1);
ReceivingType Char(1);
Reserved1 Char(1);
ConversionStatusIndText Int(10);
ConversionStatusIndData Int(10);
AlertOption Char(9);
CCSIDOfMessageText Int(10);
CCSIDOFReplacementText Int(10);
LengthOfReplacementText Int(10);
LengthOfReplacementTextAvailable Int(10);
LengthOfMessageReturn Int(10);
LengthOfMessageAvailable Int(10);
LengthOfMessageHelpAvailable Int(10);
end-ds;
dcl-ds TD_StdErrorModel Qualified Template;
Size Int(10) Inz(%Size(TD_StdErrorModel));
BytesAvailable Int(10) Inz(0);
MessageId Char(7);
Reserved1 Char(1);
MessageData Char(1024);
end-ds;
dcl-c CPF_MESSAGE_FILE_NAME 'QCPFMSG *LIBL ';
dcl-c FALSE '0';
dcl-c TRUE '1';
//* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
//* UTCALLS_GetTriggerProgram
//* Get name of program causing trigger to fired.
//* Function send a message to the database program used for the
//* insert or update. When it find it, it knows that the previous
//* program is the program that caused the insert or update.
//* In - Trigger Event.
//* Out - None
//* Returns - Name of program
//* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
dcl-proc UTCALLS_GetTriggerProgram Export;
dcl-pi *N VarChar(10);
InTriggerEvent Char(1) Value;
end-pi;
dcl-s PtrReturnMessage Pointer Inz(%Addr(MessageBuffer));
dcl-ds ReturnMessage LikeDs(TD_ReturnMessage) Based(ptrReturnMessage);
dcl-ds ErrorReturn LikeDs(TD_StdErrorModel) Inz(*LikeDs);
dcl-c INSERT_PROGRAM 'QDBPUT';
dcl-c UPDATE_DELETE_PROGRAM 'QDBUDR';
dcl-s MessageBuffer Char(8192);
dcl-s MessageBackLength Int(10) Inz(%Size(MessageBuffer));
dcl-s ReturnMessageKey Char(4);
dcl-s CallStackEntry Char(10);
dcl-s Msg Char(1024);
If Not (InTriggerEvent = UTCALLS_TRIGGER_EVENT_INSERT Or
InTriggerEvent = UTCALLS_TRIGGER_EVENT_DELETE Or
InTriggerEvent = UTCALLS_TRIGGER_EVENT_UPDATE Or
InTriggerEvent = UTCALLS_TRIGGER_EVENT_READ);
Msg = 'Trigger event is not valid event. Must a UTCALLS_TRIGGER_EVENT
value';
XVERRH_Throw('CPF9898':
CPF_MESSAGE_FILE_NAME:
Msg);
EndIf;
If InTriggerEvent = UTCALLS_TRIGGER_EVENT_INSERT;
CallStackEntry = INSERT_PROGRAM;
Else;
CallStackEntry = UPDATE_DELETE_PROGRAM;
EndIf;
SendProgramMessage('CPF9898':
CPF_MESSAGE_FILE_NAME:
'Test': // Message to send
4: // Length of message
'*INFO': // Type of message
CallStackEntry: // Program name to search for
1: // Stack counter to go back
ReturnMessageKey: // Message key returned
ErrorReturn);
If ErrorReturn.BytesAvailable > 0;
Msg = 'Unknown error in Send Message API. Message Id = ' +
ErrorReturn.MessageId;
XVERRH_Throw('CPF9898':
CPF_MESSAGE_FILE_NAME:
Msg);
EndIf;
ReceiveProgramMessage(MessageBuffer: // Buffer to receive message into
MessageBackLength: // Length of buffer
'RCVM0200': // Message format
'*': // Use the current pgm queue
0: // Call stack counter
'*INFO': // Program type to receive
ReturnMessageKey: // Message key returned
0: // Wait Time
'*REMOVE': // How to handle message
ErrorReturn);
If ErrorReturn.BytesAvailable > 0;
Msg = 'Unknown error in Send Message API. Message Id = ' +
ErrorReturn.MessageId;
XVERRH_Throw('CPF9898':
CPF_MESSAGE_FILE_NAME:
Msg);
EndIf;
Return %Trim(ReturnMessage.ReceivingProgramName);
end-proc;
On Tue, Jun 19, 2018 at 11:04 AM Larenzo Alexander <
Larenzo.Alexander@xxxxxxx> wrote:
We recently upgraded from v7r1 to v7r3 and then my applications using
QMHRCVPM to retrieve the program that cause the database to fire the
trigger stop working. Any ideas why and the solution? Or if there is a
better way to retrieve the program name that cause the trigger to fire? My
variable is getting set to 'QDBPUT '
// ---Receive Pgm Message Format RCVM0200 data Layout---------------
D RCVM0200 DS
D RcvPgmNam 10a overlay(rcvm0200:111)
D TestNpgm 1a overlay(RcvPgmNam:2)
// ---aou error return code-----------------------------------------
D vApiErrDs DS
D vbytpv 10i 0 inz(%size(vApiErrDs))
D vbytav 10i 0 inz(0)
D vmsgid 7a
D vresvd 1a
D vrpldta 50a
// ---Send messages------------------------------------------------
D qmhsndpm PR ExtPgm('QMHSNDPM')
D 7a const
D 20a const
D 65a const
D 10i 0 const
D 10a const
D 10a const
D 10i 0 const
D 4a
Db like(vApiErrDS)
// ---Receive messages----------------------------------------------
D qmhrcvpm PR ExtPgm('QMHRCVPM')
Db like(rcvm0200)
D 10i 0 const
D 8a const
D 10a const
D 10i 0 const
D 10a const
D 4a
D 10i 0 const
D 10a const
Db like(vApiErrDS)
// ---------------------------------------------
// Get program's name that is updating the file.
// Send message to 3rd job in stack.
// Program name that replies, fired the trigger.
// ---------------------------------------------
callp QMHSNDPM(' ':'QCPFMSG QSYS ':
'Message Data':65:'*INFO ':'* ': 3:MsgKey:vApiErrDS);
callp QMHRCVPM(rcvm0200:%size(rcvm0200):'RCVM0200':'*':0:'*INFO '
MsgKey:0:'*REMOVE ':vApiErrDS);
ProcedureName1 = %proc();
// Only run for ATV Units Offline program
if RcvPgmNam = 'VIN020R';
--
This is the RPG programming on the IBM i (AS/400 and iSeries) (RPG400-L)
mailing list
To post a message email: RPG400-L@xxxxxxxxxxxx
To subscribe, unsubscribe, or change list options,
visit: https://lists.midrange.com/mailman/listinfo/rpg400-l
or email: RPG400-L-request@xxxxxxxxxxxx
Before posting, please take a moment to review the archives
at https://archive.midrange.com/rpg400-l.
Please contact support@xxxxxxxxxxxx for any subscription related
questions.
Help support midrange.com by shopping at amazon.com with our affiliate
link: http://amzn.to/2dEadiD
midrange.com
