midrange.com code scratchpad
Name:
QWCRSSTS
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
01/18/2010 03:36:15 pm
IP:
Logged
Description:
RPG Call to retreive system name
Code:
  1. Caller :
  2.  
  3. If not RtrSysNm (gSysNm: AnErrMg);    
  4.   Return ;                            
  5. EndIf ;                               
  6.  
  7.  
  8.  
  9. External module containing one procedure :
  10.  
  11. P RtrSysNm        B                   EXPORT                            
  12.                                                                         
  13. D RtrSysNm        PI              N                                     
  14. D   aSysNm                            LIKE (DFN_SYSNM)                  
  15. D   aErrMg                            LIKE ( DFN_ERRMG)                 
  16.                                                                         
  17.  *  ******************************************************************* 
  18.  *  * API QWCRSSTS                                                    * 
  19.  *  ******************************************************************* 
  20.                                                                         
  21. D Qwcrssts        PR                  EXTPGM('QWCRSSTS')                
  22. D                               80A                                     
  23. D                               10I 0 CONST                             
  24. D                                8A   CONST                             
  25. D                               10A   CONST                             
  26. D                              512A   OPTIONS(*VARSIZE)                 
  27.                                                                         
  28. D  InfSysDS       DS            80                                      
  29. D    SysNm                       8A   OVERLAY (InfSysDS:17)             
  30.                                                                         
  31. D  ErrCdDS        DS                                                    
  32. D    ByteIn                     10I 0 INZ(%size(ErrCdDS))               
  33. D    ByteRet                    10I 0                                   
  34. D    ErrId                       7A   INZ                               
  35. D    ErrRsv                      1A                                     
  36. D    ErrData                   256A   INZ                               
  37.                                                                         
  38. D  InfSysLon      S             10I 0 INZ(%Len(InfSysDS))               
  39. D  InfSysFmt      S              8A   INZ('SSTS0100')                   
  40. D  InfSysReset    S             10A   INZ('*NO')                        
  41.                                                                         
  42.  /free                                                                  
  43.      callp(E) Qwcrssts (InfSysDS :                                      
  44.                         InfSysLon :                                     
  45.                         InfSysFmt :                                     
  46.                         InfSysReset :                                   
  47.                         ErrCdDS);                                       
  48.                                                                         
  49.      select;                                                            
  50.                                                                         
  51.      when ErrId <> *BLANKS;                                             
  52.        aErrMg = TrtErrInt ('0001' :                                     
  53.                             gTabErr :                                   
  54.                             'Code err.: ' +                             
  55.                             ErrId +                                     
  56.                             ' Données: ' +                              
  57.                             %trim(ErrData) :                            
  58.                             gPROCEDURE_ID) ;                            
  59.        return *OFF;                                                     
  60.                                                                         
  61.      when %error;                                                       
  62.        aErrMg = TrtErrInt ('0002' :                                     
  63.                             gTabErr :                                   
  64.                             ' ' :                                       
  65.                             gPROCEDURE_ID) ;                            
  66.        return *OFF;                                                     
  67.                                                                         
  68.      endsl;                                                             
  69.                                                                         
  70.    aSysNm = SysNm;                                                      
  71.                                                                         
  72.    return *ON;                                                          
  73.                                                                         
  74.  /end-free                                                              
  75.                                                                         
  76. P RtrSysNm        E                                                      
  77.  
© 2004-2019 by midrange.com generated in 0.007s valid xhtml & css