How to identify caller program.

Tags:
AS/400
PGM
RPGLE
PGM A is calling PGM C and PGM B is calling PGM C. In PGM C how can I know which PGM called it without passing any parameter as PGM name or using data area etc. Suppose all these PGMs are RPGLE programs.
1

Answer Wiki

Thanks. We'll let you know when a new response is added.

Here are a couple of procedures to do this.  You would code 

field = getTrgPgm(); 
Here are the Prototypes
d getTrgPgm       pr            10a                         
                                                            
d exists          pr              n                         
d  object                       10a   const                 
d  objectType                   10a   const                 
d  objectILib                   10a   const options(*nopass)
Here are the procedures
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *  procedure name: getTrgPgm                                                                 
 *  procedure function: Return program name that caused trigger to fire.                      
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
p  getTrgPgm      b                                                                           
d  getTrgPgm      pi            10a                                                           
                                                                                              
d QMHSNDPM        pr                  extpgm('QMHSNDPM')                                      
d  MsgId                              like(MsgId)                                             
d  MsgFileLib                         like(MsgFileLib)                                        
d  MsgData                            like(MsgData)                                           
d  MsgDtaLen                          like(MsgDtaLen)                                         
d  MsgType                            like(MsgType)                                           
d  MsgQueue                           like(MsgQueue)                                          
d  MsgQueNbr                          like(MsgQueNbr)                                         
d  RcvKey                             like(RcvKey)                                            
d  ErrorDs                            like(ErrorDs)                                           
                                                                                              
d QMHRCVPM        pr                  extpgm('QMHRCVPM')                                      
d  RcvData                            like(RcvData)                                           
d  RcvDtaLen                          like(RcvDtaLen)      
d  RcvFormat                          like(RcvFormat)      
d  MsgQueue                           like(MsgQueue)       
d  MsgQueNbr                          like(MsgQueNbr)      
d  MsgType                            like(MsgType)        
d  MsgKey                             like(MsgKey)         
d  WaitTime                           like(WaitTime)       
d  MsgAction                          like(MsgAction)      
d  ErrorDs                            like(ErrorDs)        
                                                           
d msgAction       s             10a                        
d msgData         s              9a                        
d msgDtaLen       s              6p 0 inz(%size(MsgData))  
d msgFileLib      s             20a                        
d msgId           s             10a                        
d msgKey          s              9b 0                      
d msgQueue        s             10a                        
d msgQueNbr       s              9b 0                      
d msgType         s             10a                        
d rcvData         s           1000a                       
d rcvDtaLen       s              6p 0 inz(%size(RcvData)) 
d rcvFormat       s              8a                       
d rcvKey          s              9b 0 inz                 
d stackNbr        s              6p 0 inz(3)              
d testPgm         s             10a                       
d waitTime        s              9b 0                     
d whoCalled       s             10a                       
                                                          
d ErrorDs         ds                  inz                 
d  BytesProv              1      4B 0 inz(116)            
d  BytesAval              5      8B 0                     
d  MessageId              9     15a                       
d  Err###                16     16a                       
d  MessageDta            17    116a                       
 /free                                                    
   dou whoCalled <> ' ';                                  
      msgFileLib = 'QCPFMSG   QSYS      ';                
      msgType = '*RQS';                                   
      msgQueue = '*';                                                                     
      msgQueNbr = stackNbr;                                                               
      QMHSNDPM(MsgId:MsgFileLib:MsgData:MsgDtaLen:MsgType:MsgQueue:                       
               MsgQueNbr:RcvKey:ErrorDs); // send message to program queue                
      if MessageID = 'CPF2904'; // program queue call stack not found                     
         whoCalled = MessageId;                                                           
      endif;                                                                              
      if whoCalled = ' ';                                                                 
         msgKey = rcvKey;                                                                 
         rcvFormat = 'RCVM0200';                                                          
         msgQueue = '*';                                                                  
         msgQueNbr = stackNbr;                                                            
         msgType = '*RQS';                                                                
         waitTime = 0;                                                                    
         msgAction = '*REMOVE';                                                           
         QMHRCVPM(RcvData:RcvDtaLen:RcvFormat:MsgQueue:MsgQueNbr:MsgType:                 
                  MsgKey:WaitTime:MsgAction:ErrorDs); // receive message from program queu
         stackNbr += 1;                                                                   
         testPgm = %subst(RcvData:111:10);                                                
         if exists(TestPgm:'*PGM':'QSYS') or                                                  
            exists(TestPgm:'*MOD':'QSYS') or                                                  
            exists(TestPgm:'*PGM':'QPDA') or                                                  
            exists(TestPgm:'*MOD':'QPDA');                                                    
            iter;                                                                             
         endif;                                                                               
         whoCalled = TestPgm;                                                                 
      endif;                                                                                  
   enddo;                                                                                     
   return whoCalled;                                                                          
 /end-free                                                                                    
p getTrgPgm       e                                                                           
                                                                                              
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *  procedure name: exists                                                                    
 *  procedure function: Return Y/N field based on objects existence.                          
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
p exists          b                                                                           
d exists          pi              n                                
d  object                       10a   const                        
d  objectType                   10a   const                        
d  objectILib                   10a   const options(*nopass)       
                                                                   
d QUSROBJD        pr                  extpgm('QUSROBJD')           
d  ReceiveVar                         like(ReceiveVar)             
d  ReceiveLen                         like(ReceiveLen)             
d  ObjdFormat                         like(ObjdFormat)             
d  ObjectLib                          like(ObjectLib)              
d  ObjectTypF                         like(ObjectTypF)             
d  ErrorDs                            like(ErrorDs)                
                                                                   
d  ReceiveVar     s            100a                                
d  ReceiveLen     s              9b 0 inz(100)                     
d  ObjdFormat     s              8a   inz('OBJD0100')              
d  ObjectLib      s             20a   inz('          *LIBL     ')  
d  ObjectTypF     s             10a                                
d ErrorDs         ds           116    inz                          
d  BytesPrv               1      4B 0 inz(116)                               
d  BytesAvl               5      8B 0 inz(0)                                 
d  MessageId              9     15a                                          
d  ERR###                16     16a                                          
d  MessageDta            17    116a                                          
 /free                                                                       
   %subst(objectLib:1:10) = object;                                          
   ObjectTypF = ObjectType;                                                  
   if %parms() = 3;                                                          
      %subst(objectLib:11:10) = ObjectILib;                                  
   endif;                                                                    
   QUSROBJD(ReceiveVar:ReceiveLen:ObjdFormat:ObjectLib:ObjectTypF:ErrorDs);  
   select;                                                                   
   when MessageId = 'CPF9821';                                               
      return *on; // If not authorized, then object exists                   
   when MessageDta <> ' ';                                                   
      return *off; // error trying to get object description, means not valid
   other;                                                                    
      return *on;                                                            
   endsl;              
 /end-free             
p exists          e    

Discuss This Question: 4  Replies

 
There was an error processing your information. Please try again later.
Thanks. We'll let you know when a new response is added.
Send me notifications when members answer or reply to this question.
  • philpl1jb
    Easiest way. Have program a and program b pass their name as a parameter to program c.
    54,090 pointsBadges:
    report
  • BigKat
    Here are a couple of procedures to do this.  You would code 
    field = getTrgPgm(); 
    Here are the Prototypes
    d getTrgPgm       pr            10a                         
                                                                
    d exists          pr              n                         
    d  object                       10a   const                 
    d  objectType                   10a   const                 
    d  objectILib                   10a   const options(*nopass)
    
    Here are the procedures
     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     *  procedure name: getTrgPgm                                                                 
     *  procedure function: Return program name that caused trigger to fire.                      
     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
    p  getTrgPgm      b                                                                           
    d  getTrgPgm      pi            10a                                                           
                                                                                                  
    d QMHSNDPM        pr                  extpgm('QMHSNDPM')                                      
    d  MsgId                              like(MsgId)                                             
    d  MsgFileLib                         like(MsgFileLib)                                        
    d  MsgData                            like(MsgData)                                           
    d  MsgDtaLen                          like(MsgDtaLen)                                         
    d  MsgType                            like(MsgType)                                           
    d  MsgQueue                           like(MsgQueue)                                          
    d  MsgQueNbr                          like(MsgQueNbr)                                         
    d  RcvKey                             like(RcvKey)                                            
    d  ErrorDs                            like(ErrorDs)                                           
                                                                                                  
    d QMHRCVPM        pr                  extpgm('QMHRCVPM')                                      
    d  RcvData                            like(RcvData)                                           
    d  RcvDtaLen                          like(RcvDtaLen)      
    d  RcvFormat                          like(RcvFormat)      
    d  MsgQueue                           like(MsgQueue)       
    d  MsgQueNbr                          like(MsgQueNbr)      
    d  MsgType                            like(MsgType)        
    d  MsgKey                             like(MsgKey)         
    d  WaitTime                           like(WaitTime)       
    d  MsgAction                          like(MsgAction)      
    d  ErrorDs                            like(ErrorDs)        
                                                               
    d msgAction       s             10a                        
    d msgData         s              9a                        
    d msgDtaLen       s              6p 0 inz(%size(MsgData))  
    d msgFileLib      s             20a                        
    d msgId           s             10a                        
    d msgKey          s              9b 0                      
    d msgQueue        s             10a                        
    d msgQueNbr       s              9b 0                      
    d msgType         s             10a                        
    d rcvData         s           1000a                       
    d rcvDtaLen       s              6p 0 inz(%size(RcvData)) 
    d rcvFormat       s              8a                       
    d rcvKey          s              9b 0 inz                 
    d stackNbr        s              6p 0 inz(3)              
    d testPgm         s             10a                       
    d waitTime        s              9b 0                     
    d whoCalled       s             10a                       
                                                              
    d ErrorDs         ds                  inz                 
    d  BytesProv              1      4B 0 inz(116)            
    d  BytesAval              5      8B 0                     
    d  MessageId              9     15a                       
    d  Err###                16     16a                       
    d  MessageDta            17    116a                       
     /free                                                    
       dou whoCalled <> ' ';                                  
          msgFileLib = 'QCPFMSG   QSYS      ';                
          msgType = '*RQS';                                   
          msgQueue = '*';                                                                     
          msgQueNbr = stackNbr;                                                               
          QMHSNDPM(MsgId:MsgFileLib:MsgData:MsgDtaLen:MsgType:MsgQueue:                       
                   MsgQueNbr:RcvKey:ErrorDs); // send message to program queue                
          if MessageID = 'CPF2904'; // program queue call stack not found                     
             whoCalled = MessageId;                                                           
          endif;                                                                              
          if whoCalled = ' ';                                                                 
             msgKey = rcvKey;                                                                 
             rcvFormat = 'RCVM0200';                                                          
             msgQueue = '*';                                                                  
             msgQueNbr = stackNbr;                                                            
             msgType = '*RQS';                                                                
             waitTime = 0;                                                                    
             msgAction = '*REMOVE';                                                           
             QMHRCVPM(RcvData:RcvDtaLen:RcvFormat:MsgQueue:MsgQueNbr:MsgType:                 
                      MsgKey:WaitTime:MsgAction:ErrorDs); // receive message from program queu
             stackNbr += 1;                                                                   
             testPgm = %subst(RcvData:111:10);                                                
             if exists(TestPgm:'*PGM':'QSYS') or                                                  
                exists(TestPgm:'*MOD':'QSYS') or                                                  
                exists(TestPgm:'*PGM':'QPDA') or                                                  
                exists(TestPgm:'*MOD':'QPDA');                                                    
                iter;                                                                             
             endif;                                                                               
             whoCalled = TestPgm;                                                                 
          endif;                                                                                  
       enddo;                                                                                     
       return whoCalled;                                                                          
     /end-free                                                                                    
    p getTrgPgm       e                                                                           
                                                                                                  
     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     *  procedure name: exists                                                                    
     *  procedure function: Return Y/N field based on objects existence.                          
     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
    p exists          b                                                                           
    d exists          pi              n                                
    d  object                       10a   const                        
    d  objectType                   10a   const                        
    d  objectILib                   10a   const options(*nopass)       
                                                                       
    d QUSROBJD        pr                  extpgm('QUSROBJD')           
    d  ReceiveVar                         like(ReceiveVar)             
    d  ReceiveLen                         like(ReceiveLen)             
    d  ObjdFormat                         like(ObjdFormat)             
    d  ObjectLib                          like(ObjectLib)              
    d  ObjectTypF                         like(ObjectTypF)             
    d  ErrorDs                            like(ErrorDs)                
                                                                       
    d  ReceiveVar     s            100a                                
    d  ReceiveLen     s              9b 0 inz(100)                     
    d  ObjdFormat     s              8a   inz('OBJD0100')              
    d  ObjectLib      s             20a   inz('          *LIBL     ')  
    d  ObjectTypF     s             10a                                
    d ErrorDs         ds           116    inz                          
    d  BytesPrv               1      4B 0 inz(116)                               
    d  BytesAvl               5      8B 0 inz(0)                                 
    d  MessageId              9     15a                                          
    d  ERR###                16     16a                                          
    d  MessageDta            17    116a                                          
     /free                                                                       
       %subst(objectLib:1:10) = object;                                          
       ObjectTypF = ObjectType;                                                  
       if %parms() = 3;                                                          
          %subst(objectLib:11:10) = ObjectILib;                                  
       endif;                                                                    
       QUSROBJD(ReceiveVar:ReceiveLen:ObjdFormat:ObjectLib:ObjectTypF:ErrorDs);  
       select;                                                                   
       when MessageId = 'CPF9821';                                               
          return *on; // If not authorized, then object exists                   
       when MessageDta <> ' ';                                                   
          return *off; // error trying to get object description, means not valid
       other;                                                                    
          return *on;                                                            
       endsl;              
     /end-free             
    p exists          e    
    9,460 pointsBadges:
    report
  • BigKat
    these procedures were developed out of code in the article who pulled the trigger
    9,460 pointsBadges:
    report
  • Supriyoas400
    Thanks , i will definitely try this code.
    250 pointsBadges:
    report

Forgot Password

No problem! Submit your e-mail address below. We'll send you an e-mail containing your password.

Your password has been sent to:

To follow this tag...

There was an error processing your information. Please try again later.

Thanks! We'll email you when relevant content is added and updated.

Following

Share this item with your network: