Snippets/CodeGrabs
From MidrangeWiki
< Snippets
Contents
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)
CALLSUBR BADLIBSAVE
ENDDO
RETURN
SUBR BADLIBSAVE
/* 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* 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
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.
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
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
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
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
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.
