Snippets/CodeGrabs

From MidrangeWiki
Jump to: navigation, search

DayOfWeek snippet

ref [[1]]


     * // Procedure:  DayOfWeek                                           //
     * // Purpose:  Determine the day of week for a particular date       //
     * // Parameters:                                                     //
     * //    I: dt   -- date                                              //
     *
     * // Returns:                                                        //
     * //    0..6    -- 0=Sunday, 1=Monday, 2=Tuesday, etc.               //
     * // Notes:                                                          //
     * //    January 5, 1800 is a Sunday.  This procedure only works for  //
     * //    dates later than 1800-01-05.                                 //
     * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
    P DayOfWeek       b
    P
    D DayOfWeek       pi            10i 0
    D
    D   dt                            d   value datfmt(*iso)
     /free
        return %rem (%diff (dt: d'1800-01-05': *days): 7);
     /end-free
    P DayOfWeek       e
                                                                                          

#top

FirstFriday snippet

    H DFTACTGRP(*NO ) OPTIMIZE(*NONE) OPTION(*NODEBUGIO)                  
                                                                          
                          
    D WDATE           S             10A                                   
                                                                          
                             
    D FirstFriday     PR             1A                                   
    D  Wdate                        10A                                   
                                                                          
               
     /FREE                                                                
        *INLR = *on;                                         
        WDATE = '2008-12-05';                                                   
        *IN01 = FirstFriday(WDATE);                                             
     /END-FREE  
                                                               
     * // Procedure:  FirstFriday                                         //
     * // Purpose:  Determine if the date is the First Friday             //
     * // Parameters:                                                     //
     * //    I: WDATE  -- 10 character ISO delim date                     //
     *
     * // Returns:                                                        //
     * //    0..1    -- 0=NO, 1=YES                                       //
     * // Notes:                                                          //
     * //    January 5, 1800 is a Sunday.  This procedure only works for  //
     * //    dates later than 1800-01-05.                                 //
     * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
    P FirstFriday     B                                                         
    P                                                                           
    D FirstFriday     PI             1A                                         
    D  WDATE                        10A                                         
                                                                                
     /free                                                                      
                                                                                
       if %rem(%abs(%diff (%DATE(WDATE) : d'1800-01-05': *days)): 7) = 5        
         and %subdt(%DATE(WDATE)  :*D) <=7;                                     
           // it is the first Friday of the month                               
           RETURN '1';                                                          
      endif;                               
          RETURN '0';                      
                                           
    /end-free                              
   P FirstFriday     E                     


#top

System Date snippet

ref [[2]]

Time also works Return  %INT(%CHAR(%TIME():*ISO0)) set PI to 6S 0.

     * // Procedure:  SysDate                                             //
     * // Purpose:  Gets the system date YYYYMMDD format 8S 0              //
     * // Parameters:                                                     //
     * // Returns:                                                        //
     * //    int    -- date in YYYYMMDD fmt                               //
    * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
    P SysDate         B                         
    P                                           
    D SysDate         PI             8S 0       
    D                                           
     /free                                      
        Return     %INT(%CHAR(%DATE():*ISO0));  
     /end-free                                  
    P SysDate         E                         

#top

CLLE Subroutine

ref [[3]]

Sample code V5R4

START:      PGM
   SAVLIB     LIB( PVCPROD)  DEV(TAP01) ENDOPT(*LEAVE)   /* Daily library backup */
   MONMSG     MSGID(PVC0001)  EXEC(DO)
      CALLSUBR BADLIBSAVE
   ENDDO
RETURN
SUBR BADLIBSAVE
 /* test */
ENDSUBR
ENDPGM

#top

RPG SYSTEM NAME

ref: [[4]]


D RtvSysName      PR             8A                                       
D   MyName        S             10A                                       
C                   eval      *inlr = *on                                 
C                   EVAL      MyName =   RtvSysName()                     
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++    
*  Retrieve System Name                         
P RtvSysName      B                   Export                              
D RtvSysName      PI             8A                                       
D QWCRNETA        PR                  ExtPgm('QWCRNETA')                  
D   RcvVar                   32766A   OPTIONS(*VARSIZE)                   
D   RcvVarLen                   10I 0 const                                   
D   NbrNetAtr                   10I 0 const                                   
D   AttrNames                   10A   const                                   
D   ErrorCode                  256A                                           
D* Error code structure                                                       
D EC              DS           256                                            
D* Receiver variable for QWCRNETA                      
D DS              ds                                                          
D  Filler                       32A                                         
D  RtnSystem                     8A                                         
 * Call API to get system name                                                
C                   callp     QWCRNETA(DS: %size(DS): 1: 'SYSNAME': EC)       
C                   return    RtnSystem                  
P                 E                                                           

#top


MODS w/POINTERS

ref: [[5]]

DEdtCstRtn        PR                  ExtPgm('@EDTCSTRTN')
D SubParm                             Like(MyStruct)
D SubParm1                            Like(Struct1)

Dmystruct       e ds                  ExtName(EDTCSTPF)
D                                     occurs(500)
DStruct1        e ds                  ExtName(EDTCSTHDR)

I fill the structure and then call the second program

    %occur(myStruct) = 1;
    Callp EdtCstRtn(MyStruct:Struct1);

Here is the code from the Called program:

DCstRtnParm       PR                  ExtPgm('@EDTCSTRTN')
DPlistPR                              Like(PlistParm)
DPlist1PR                             Like(Plist1)
DCstRtnParm       PI
DPlistPI                              Like(PlistParm)
DPlist1PI                             Like(Plist1)

DPlistParm      e ds                  ExtName(EDTCSTPF)
D                                     occurs(500)
D                                     based(p_PlistParm)
DPlist1         e ds                  ExtName(EDTCSTHDR)
D                                     based(p_Plist1)

 /free
     p_PlistParm = %addr(PlistPI);
     p_Plist1    = %addr(Plist1PI);

... do NOT EVAL one to the other... ... simply access PlistParm as a normal MODS.

#top


QUSRSPLA CL with STG(*DEFINED) DEFVAR

ref: [[6]]

[| See IBM defn of the SPLA0100 format for whatever attribute you need.]

/*     GET A SPOOL FILE ATTRIBUTE                                   */     
            PGM        PARM(&SPLF &FULLJOB  &RTNWID   )                   
                                                                          
            DCL        &SPLF *CHAR LEN(10)                                
            DCL        &FULLJOB *CHAR LEN(26)                             
                                                                          
            DCL        &SPLNBR *CHAR LEN(5)                               
            DCL        &SPLNBRD *DEC LEN(9 0)                             
            DCL        &SPLNBRB *CHAR LEN(4)                              
                                                                          
            DCL        &DSLEND *DEC LEN(9 0)                              
            DCL        &DSLENB *CHAR LEN(4)                               
                                                                          
            DCL        &INTJOB *CHAR LEN(16)                              
            DCL        &INTSPLF *CHAR LEN(16)                             
            DCL        &RTNWID *DEC (15 5)                                
                                                                          
            DCL        &DS      *CHAR LEN(1000)                           
            DCL        &RTNWIDTH *DEC (15 5) STG(*DEFINED) DEFVAR(&DS 889)
                                                                     
     /* GET LAST SPOOL FILE */                                       
           CHGVAR     &SPLNBRD -1                                    
           CHGVAR     %BIN(&SPLNBRB 1 4) &SPLNBRD                    
     /* USE 1000 BYTE DS        */                                   
           CHGVAR     &DSLEND 1000                                   
           CHGVAR     %BIN(&DSLENB 1 4) &DSLEND                      
                                                                     
     /* CALL API TO GET SPLFA */                                     
     /* OFFSET 888 CONTAINS THE WIDTH AS PACKED DECIMAL 15,5 */      
           CALL       QUSRSPLA PARM(&DS &DSLENB 'SPLA0100' +         
                       &FULLJOB &INTJOB &INTSPLF &SPLF &SPLNBRB)     
           MONMSG  CPF0000                                           
                                                                     
RTNWID:     CHGVAR &RTNWID    &RTNWIDTH                               
                                                                     
           RETURN                                                    
           ENDPGM                                                    

#top


RPG WAIT sim DLYJOB

ref: [[7]]

    HBNDDIR('QC2LE') DFTACTGRP(*NO) ACTGRP(*NEW)
     * this uses the C sleep API 
     * this is a sample program named 'PSLEEP' to demo the call to the sleep API  
     * to test,  call  PSLEEP '0000000005'
     *
    D PSLEEP          PR
    D SECSA                         10A
    D PSLEEP          PI
    D SECSA                         10A
     *
    D WAIT            PR             1A
    D SECS                          10U 0
  
    D CURTIME         S               T
    D SECS            S             10U 0
    D ANS             S             20A
  
    D SECSDS          DS            10
    D SECSN                         10S 0
 
     /FREE
           *INLR = *ON;
    
           SECSDS = SECSA;
           SECS   = SECSN;
     
           CURTIME = %TIME();
           DSPLY CURTIME;
    
            WAIT(SECS);
    
           CURTIME = %TIME();
           DSPLY CURTIME ' ' ANS;
      /END-FREE
  
     * // Procedure:  Sleep                                               //
     * // Purpose:  Wait for a number of  seconds                         //
     * // Parameters:                                                     //
     * //    I: WSECS  -- 10 int                                          //
     *
     * // Returns:                                                        //
     * //    0..1    -- 0=NOT OK, 1=OK                                    //
     * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
    P WAIT            B
    P
    D WAIT            PI             1A
    D WSECS                         10U 0
 
    DSLEEP            PR             1A   EXTPROC(X'A293858597')
    D SECS                          10U 0 VALUE
 
     /FREE
          RETURN  SLEEP(WSECS);
     /END-FREE
    P WAIT            E      

#top

GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC

ref: [[8]][[9]]


This is an example program showing the usage of the GETROWCOL procedure.

Its purpose is to set up the ROW and COL for CSRLOC to position to a FIELD in error without the need for indicators.

You can use a ERRMSG or ERRMSGID on a dummy O field so you will still need to use one indicator for an error.

If you use ERRMSG or ERRMSGID you will need to position the cursor with a Write before you turn on the indicators for ERRMSG and ERRMSGID.

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)
      *
 
     D   FILE          S             10A   INZ('URFILE')
     D   FORMAT        S             10A   INZ('URFMT')
     D   FLDNAM        S             10A   INZ('URFLD')
     D   ROW           S              3S 0
     D   COL           S              3S 0
 
     D GETROWCOL       PR
     D                               10A   const
     D                               10A   const
     D                               10A   const
     D                               32A   const
     D                                3S 0
     D                                3S 0
      /free
           *INLR = *ON;
           GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL);
      /end-free
  
     P GETROWCOL       B
      *
      *    Retreive a DSPF FIELD  Row and Col
      *    Used for Setting  CSRLOC for cursor positioning
      *    USAGE
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
      *
     D GETROWCOL       PR
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
     D   rtnROW                       3S 0
     D   rtnCOL                       3S 0
 
     D GETROWCOL       PI
        //  PARMS  IN 
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
        //  PARMS  OUT
     D   rtnROW                       3S 0
     D   rtnCOL                       3S 0
 
     D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
     D   UserSpace                   20A   CONST
     D   ExtAttrib                   10A   CONST
     D   InitialSize                 10I 0 CONST
     D   InitialVal                   1A   CONST
     D   PublicAuth                  10A   CONST
     D   Text                        50A   CONST
     D   Replace                     10A   CONST options(*nopass)
     D   ErrorCode                32767A   options(*varsize:*nopass)
 
     D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
     D   UserSpace                   20A   CONST
     D   Pointer                       *
 
     D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
     D   UserSpace                   20A   CONST
     D   ErrorCode                32767A   options(*varsize)
 
     D QUSLFLD         PR                  ExtPgm('QUSLFLD')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   QualFile                    20A   const
     D   RcdFmt                      10A   const
     D   UseOvrd                      1A   const
     D   ErrorCode                32767A   options(*nopass:*varsize)
 
     D ErrorCode       ds                  qualified
     D   BytesProv                   10I 0 inz(0)
     D   BytesAvail                  10I 0 inz(0)
 
     D ListHeader      ds                  based(p_ListHeader)
     d   ListOffset                  10I 0 overlay(ListHeader:125)
     d   EntryCount                  10I 0 overlay(ListHeader:133)
     d   EntrySize                   10I 0 overlay(ListHeader:137)
 
     D Field           ds                  based(p_Field)
     D                                     qualified
     D  Name                         10a
     D  FILLER                      438a
     d  DspRow                       10i 0
     d  DspCol                       10i 0
 
     D TEMPSPC         C                   'GETROWCOL QTEMP'
 
     D x               s             10I 0
 
      /free

                  rtnROW =    999;
                  rtnCOL =    999;
           // --------------------------------------------------
           // Delete the user space if it exists (ignore errors)
           ErrorCode.BytesProv = %size(ErrorCode);
           QUSDLTUS( TEMPSPC: ErrorCode );
           ErrorCode.BytesProv = 0;
 
           // --------------------------------------------------
           // Create a new 128k user space
           QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024   : x'00'
                   : '*EXCLUDE' : 'List of fields in file' : '*NO'
                   : ErrorCode );
 
           // --------------------------------------------------
           // Dump list of fields in file to user space
           // Invalid data is ignored and is 999 returned for row and col
           monitor;
           QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
                  : SchFormat  : *OFF  : ErrorCode );
               on-Error;
                 RETURN;
            EndMon;
           // --------------------------------------------------
           // Get a pointer to the user space
           QUSPTRUS( TEMPSPC: p_ListHeader );
 
           // --------------------------------------------------
           // Loop through all fields in space, to get the field we need
           for x = 0 to (EntryCount - 1);
               p_Field = p_ListHeader + ListOffset + (EntrySize * x);
 
               if Field.Name = schString;
                  rtnRow =    Field.DspRow;
                  rtnCol =    Field.DspCol;
                 leave;
               endif;
           endfor;
 
           // --------------------------------------------------
           // Delete temp user space & end
           QUSDLTUS( TEMPSPC: ErrorCode );
 
            return;
 
      /end-free
     P                 E       

#top

Format the date like "Wed, 12 Dec 2001 13:21:01

ref [[10]]

RFC2822 requires a date in the format "Wed, 12 Dec 2001 13:21:01 -0500".

ILE procedure that makes use of SQL


h option(*nodebugio:*srcstmt) dftactgrp(*no) actgrp('QILE')
                                                           
d getWordyDate    pr                  like(WordyDate)      
                                                           
d WordyDate       s             31                         
d reply           s              1                         
                                                           
c                   eval      WordyDate = getWordyDate()   
c     WordyDate     dsply                   reply          
c                   eval      *inlr = *on                  
                                                           
p getWordyDate    b                                        
d getWordyDate    pi                  like(WordyDate)      
                                                          
d tz              s              6  0                      
d t               s               t                        
d d               s               d                        
d dn              s              9                         
d mn              s              9                         
d rtn             ds                                             
d  ShortDayName                  3                               
d                                2    inz(', ')                  
d  DayNumeric                    2  0                            
d                                1    inz(' ')                   
d  ShortMonthName                3                               
d                                1    inz(' ')                   
d  YearNumeric                   4  0                            
d                                1    inz(' ')                   
d  TimeOut                        t   timfmt(*hms)               
d                                1    inz(' ')                   
d  TimeZone                      5                               
                                                                 
c/exec sql                                                       
c+ set (:tz,:TimeOut,:d,:dn,:mn) = (current_timezone,            
c+ current_time, current_date, substr(dayname(current_date),1,9),
c+ substr(monthname(current_date),1,9))                          
c/end-exec                                                       
                                                                 
c                   eval      DayNumeric = %subdt(d:*d)               
c                   eval      YearNumeric = %subdt(d:*y)              
c                   eval      ShortDayName = dn                       
c                   eval      ShortMonthName = mn                     
c                   eval      TimeZone =                              
c                             %trim(%editw(%dec(tz/100:4:0):'0-    '))
                                                                      
c                   return    rtn                                     
p getWordyDate    e     


USING the CEE APIs

 ** Get local time API
d CEELOCT         PR                  opdesc
d   output_lil                        Like(discard1)
d   output_secs                       Like(cur_time)
d   output_greg                       Like(discard2)
d   output_fc                         Like(Fc) Options(*Nopass)
 ** Convert to arbitrary timestamp API
d CEEDATM         PR                  opdesc
d   input_secs                        Like(cur_time)
d   picture_str                       Like(Pictureds) const
d   output_ts                         Like(Pictureds)
d   output_fc                         Like(Fc) Options(*Nopass)
 * Get offset from UTC API
d CEEUTCO         PR
d  hours                              Like(hrs2utc)
d  minutes                            Like(mins2utc)
d  seconds                            Like(cur_time)
d  output_fc                          Like(Fc) Options(*Nopass)

d discard1        S             10I 0
d cur_time        S              8F
d discard2        S             23A
d hrs2utc         s             10I 0
d mins2utc        s                   Like(hrs2utc)
d hh              s              2A
d mm              s              2A
d discard3        s                   Like(cur_time)
d WDate           s                   Like(Pictureds) 

d Fc              ds
d  sev                           5U 0
d  msgno                         5U 0
d  flags                         1A
d  facid                         3A
d  isi                          10U 0
d Pictureds       ds
d  Piclen1                1      2I 0
d  Picture                3     34A
d  Piclen2                1      4I 0
d  Picture2               5     36A

 * Get current local time from clock:
c                   Callp     CEELOCT(discard1 : cur_time : discard2)
 * Convert to e-mail format:
c                   Callp     CEEDATM(cur_time :
c                                     'Www, DD Mmm YYYY HH:MI:SS' :
c                                     WDate)
 * Retrieve offset from UTC
c                   Callp     CEEUTCO(hrs2utc : mins2utc : discard3)
 * Format the UTC offset nicely
 *   and tack it onto the string...
c                   If        hrs2utc < *Zero
c                   Eval      WDate = %trimr(WDate) + ' -'
c                   Eval      hrs2utc = 0 - hrs2utc   
c                   Else
c                   Eval      WDate = %trimr(WDate) + ' +'
c                   EndIf
c                   Move      hrs2utc       hh
c                   Move      mins2utc      mm
c                   Eval      WDate = %TrimR(WDate) + hh + mm 


#top

gettok not strtok()

ref: [[11]]

From: Scott Klement

     H DFTACTGRP(*NO)

     D gettok          PR          1024A   varying
     D   string                   65535A   varying const options(*varsize)
     D   delims                      50A   varying const
     D   pos                         10I 0

     d blah            s            100A   varying
     D tokens          s            100A   varying dim(50)
     D x               s             10I 0
     D y               s             10I 0

     D msg             s             52A

      /free

          Blah = 'Test||||||123|x|||8900';
          x = 0;
          y = 0;

          //
          //  Get each token from the string and DSPLY it
          //

          dow ( x <= %len(blah) );
             y = y + 1;
             msg = 'token ' + %char(y) + '='
                 + gettok( blah : '|' : x );
             dsply msg;
          enddo;

          //
          // Or, perhaps just dump all tokens to an array
          //

          x = 0;
          tokens(*) = gettok( blah : '|' : x );

          for y = 1 to %elem(tokens);
             msg = 'elem ' + %char(y) + '=' + tokens(y);
             dsply msg;
          endfor;

          *inlr = *on;

      /end-free




      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      * gettok():  Get next token from string
      *
      *     string = (input) string to search
      *     delims = (input) delimiters
      *        pos = (i/o) next position to search.  At the start
      *                    of a string, set this to zero.  Pass
      *                    it on subsequent calls to remember where
      *                    you left off.
      *
      * Returns the token found.
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P gettok          B
     D gettok          PI          1024A   varying
     D   string                   65535A   varying const options(*varsize)
     D   delims                      50A   varying const
     D   pos                         10I 0

     D res             s           1024A   varying
     D start           s             10I 0
     D c               s              1A

      /free

          start = pos + 1;
          %len(res) = 0;

          for pos = start to %len(string);

             c = %subst(string:pos:1);

             if %check(delims:c) = 1;
                res = res + c;
             else;
                leave;
             endif;

          endfor;

          return res;

      /end-free
     P                 E

Thanks Scott. Without your work I would still be coding RPGIII.


#top