# Snippets/CodeGrabs

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)

### 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

### 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

### 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

### CLLE Subroutine

ref [[3]]

Sample code V5R4

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

### 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 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

### 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

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

### QUSRSPLA CL with STG(*DEFINED) DEFVAR

ref: [[6]]

/*     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

### 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

### 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 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

// --------------------------------------------------
// 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

### 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

c                   eval      WordyDate = getWordyDate()
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_secs                       Like(cur_time)
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 cur_time        S              8F
d hrs2utc         s             10I 0
d mins2utc        s                   Like(hrs2utc)
d hh              s              2A
d mm              s              2A
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:
* 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