Diagnose

Summary

The following are the RPG/LE fully free-form definitions and instructions needed for using the Diagnose service procedure. This service procedure simply allows the caller to send a diagnostic message to a previous message queue in the call stack.

By Dave Clark

Service Prototype

Place the following in a separate copybook for inclusion in both the caller and the service program source members.

**free

//==============================================================================
// Send a diagnostic message to previous message queue in the caller's stack.
// The returned value is the internal message key in the destination message
// queue; else, high values in the case of an error situation.
//==============================================================================
dcl-pr GenUtl_Diagnose            char(4);
  MsgId                 char(7)   const     options(*omit);
  MsgData               varchar(3000) const options(*nopass:*omit);
  MsgFile               char(10)  const     options(*nopass:*omit);
  MsgLib                char(10)  const     options(*nopass:*omit);
  MsgCStkE              char(10)  const     options(*nopass);
  MsgCStkC              int(10:0) const     options(*nopass);
end-pr;

Service Procedure

Place the following in a service program source member.

**free
ctl-opt NoMain AlwNull(*UsrCtl) Debug Option(*SrcStmt:*NoDebugIo)
        DatFmt(*ISO) TimFmt(*ISO);

//==============================================================================
// Send a diagnostic message to previous message queue in the caller's stack.
// The returned value is the internal message key in the destination message
// queue; else, high values in the case of an error situation.
//==============================================================================
dcl-proc GenUtl_Diagnose          export;
  dcl-pi *n             char(4);
    MsgId               char(7)   const     options(*omit);
    MsgData             varchar(3000) const options(*nopass:*omit);
    MsgFile             char(10)  const     options(*nopass:*omit);
    MsgLib              char(10)  const     options(*nopass:*omit);
    MsgCStkE            char(10)  const     options(*nopass);
    MsgCStkC            int(10:0) const     options(*nopass);
  end-pi;

  dcl-s iMsgId          char(7)   inz('WSE9895'); // your default
  dcl-s iMsgFile        char(10)  inz('WSMSGF');  // your default
  dcl-s iMsgLib         char(10)  inz('*LIBL');   // your default
  dcl-s iMsgCStkE       char(10)  inz('*');
  dcl-s iMsgCStkC       int(10:0) inz(2);
  dcl-s iMsgKey         char(4)   inz(*hival);
  dcl-s iMsgCallStQ     char(10)  inz('*NONE');
  dcl-s iMsgData        varchar(3000) inz('');

  if  %parms() > *zero
  and %addr(MsgId) <> *null
  and MsgId > *blanks                  // message id required
  or  %parms() > 1                     // or
  and %addr(MsgData) <> *null
  and %len(MsgData) > *zero;           // message data required

    if %parms() < %parmnum(MsgId)      // if parm not passed
    or %addr(MsgId) = *null            // or parm was omitted
    or MsgId <= *blanks;               // or parm is blank
    else;                              // keep default, else
      iMsgId = MsgId;                  // use passed value
    endif;

    if %parms() < %parmnum(MsgData)    // if parm not passed
    or %addr(MsgData) = *null          // or parm was omitted
    or MsgData <= *blanks;             // or parm is blank
    else;                              // keep default, else
      iMsgData = MsgData;              // use passed value
    endif;

    if %parms() < %parmnum(MsgFile)    // if parm not passed
    or %addr(MsgFile) = *null          // or parm was omitted
    or MsgFile <= *blanks;             // or parm is blank
    else;                              // keep default, else
      iMsgFile = MsgFile;              // use passed value
    endif;

    if %parms() < %parmnum(MsgLib)     // if parm not passed
    or %addr(MsgLib) = *null           // or parm was omitted
    or MsgLib <= *blanks;              // or parm is blank
    else;                              // keep default, else
      iMsgLib = MsgLib;                // use passed value
    endif;

    if %parms() < %parmnum(MsgCStkE)   // if parm not passed
    or %addr(MsgCStkE) = *null         // or parm was omitted
    or MsgCStkE <= *blanks;            // or parm is blank
    else;                              // keep default, else
      iMsgCStkE = MsgCStkE;            // use passed value
      iMsgCStkC = *zero;
    endif;

    if %parms() < %parmnum(MsgCStkC)   // if parm not passed
    or %addr(MsgCStkC) = *null;        // or parm was omitted
    else;                              // keep default, else
      iMsgCStkC = MsgCStkC;            // use passed value
    endif;

    reset ApiErrC;                     // reset any error
    if (GenUtl_LeftString(iMsgCStkE: 1) = '*'); // if not a program name
      callp IBMAPI_SendPgmMsg( iMsgId : iMsgFile + iMsgLib
                             : iMsgData : %len(iMsgData)
                             : '*DIAG' : iMsgCStkE : iMsgCStkC
                             : iMsgKey : ApiErrC );
    else;                              // else, use extended format
      callp IBMAPI_SendPgmMsg( iMsgId : iMsgFile + iMsgLib
                             : iMsgData : %len(iMsgData)
                             : '*DIAG' : '*PGMNAME' : iMsgCStkC
                             : iMsgKey : ApiErrC
                             : 10: iMsgCallStQ + iMsgCStkE: 0 );
    endif;
  endif;

  return iMsgKey;                      // return to caller
end-proc;

References

• API Error Code Structure (ApiErrC)
• GenUtl_LeftString service procedure
• Send Program Message (QMHSNDPM) API