Snippets
From MidrangeWiki
Contents
- 1 SNIPPETS
- 1.1 Snippets View
- 1.2 Create a Snippets Category
- 1.3 Snippets RPG
- 1.4 Long Procedure Name
- 1.5 Examples
- 1.6 Exporting and importing snippets
- 1.7 DayOfWeek snippet
- 1.8 FirstFriday snippet
- 1.9 System Date snippet
- 1.10 CLLE Subroutine
- 1.11 RPG SYSTEM NAME
- 1.12 MODS w/POINTERS
- 1.13 QUSRSPLA CL with STG(*DEFINED) DEFVAR
- 1.14 RPG WAIT sim DLYJOB
- 1.15 GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC
- 1.16 Format the date like "Wed, 12 Dec 2001 13:21:01
- 1.17 RPG FTP TEMPLATE
- 1.18 RPG IFS READ TEMPLATE
- 1.19 RPG SUBFILE TEMPLATE
- 1.20 gettok not strtok()
- 2 External links
- 3 Categories
SNIPPETS
A snippet is a sort of code template or skeleton that allows you to quickly set up a commonly used code fragment like a subprocedure definition (in ILE RPG). Snippets are available from WDSC 7.0 up.
This differs from code templates because the code template is invoked by the code completion facility Ctrl+Space.
Code completion with templates requires you to start keying the 'trigger' (in RPG, usually the operation code.)
With snippets, you can have Lpex include anything at all, with no trigger needed aside from the double click on the selected snippet.
Snippets View
original post [1]
To open a snippets view:
- Enable XML Developer capability:
- Window → Preferences → General → Capabilities, and then check XML Developer.
- Window → Show view → Other → Basic → Snippets
Create a Snippets Category
original post [2]
- You only need to create a Category once, conceptually its like CRTSRCPF.
- Create as many Categories as you wish.
- -Right-click in the Snippets view and select Customize...
- -Click the New button and create a New Category
- -Click the New button and create a New Item
- -Click on the snippet and then click the New button that is adjacent to the Variables list
- -Enter your snippet and use the Insert Variable Placeholder button to add the variable
alternatively use the copy, right click process below, its easier.
Use snippets for RPGLE, CLLE, DSPF and PRTF source members.
Snippets RPG
original post [3]
You can use the snippets to insert stuff into your program.
To create your own RPG snippets,
- you can open the view in RSE or iSeries Editing perspective,
- select your source,
- then Right Click / Paste in the snippets view, into your Previously created Category.
It will then create a new template.
To use the snippet;
- Open a source member for editing.
- Place the cursor where you want the code.
- Go to the Snippets view, to the Category where the snippet is.
- Double click on the snippet and it appears in the source
original post [4]
Another method is to create a Snippet.
- Open the Snippets view.
- Create a new 'Drawer' for your snippets.
- Copy some source.
- Right-click in your snippet drawer, paste.
- This will bring up the snippet creation wizard.
Long Procedure Name
original post [5]
How do I get the PR to stay at the same column position, irrespective of what name I use for the procedure ?
Use:
D ${Procedure}...
PR
Otherwise the procedure name has to always be 12 characters in length. With the elipsis (...) it can be up to 60 odd characters in length.
Examples
Subprocedure skeleton:
Subprocedure skeleton
* ${proc_comment}
p ${proc_name} b
d ${proc_name} pi 10i 0
d ${parm_name} 1a
d rc 10i 0 inz
c/free
return rc;
/end-free
p e
EXEC SQL
ref [6]
C/EXEC SQL
C+ SELECT * FROM mylib/myfile
C/END-EXEC
free
exec sql select * from mylib/myfile;
Open Cursor and Fetch Mainline
ref [7]
H ActGrp(*CALLER)
H DftActGrp(*NO)
D OpenCursor PR n
D FetchCursor PR n
D CloseCursor PR n
D MyLib s 10a
D MyFile s 10a
/free
*inlr=*on;
if not OpenCursor();
// perform error routine to alert the troops
// ...
Else;
Dow FetchCursor();
// putting the fetchcursor on the do loop allows the user of
// iter, and thus iter will not perform an infinite loop
// normal processing here...
EndDo;
CloseCursor();
EndIf;
return;
/end-free
Open Cursor Procedure
ref [8]
P OpenCursor B
D OpenCursor PI like(ReturnVar)
D ReturnVar s n
// The immediately following /EXEC SQL is SQL's version of RPG's H Spec
// It is never executed. Just used at compile time.
C/EXEC SQL
C+ Set Option
C+ Naming = *Sys,
C+ Commit = *None,
C+ UsrPrf = *User,
C+ DynUsrPrf = *User,
C+ Datfmt = *iso,
C+ CloSqlCsr = *EndMod
C/END-EXEC
C/EXEC SQL
C+ Declare C1 cursor for
C+ Select System_Table_Schema as library,
C+ System_Table_Name as file
C+ from qsys2/systables
C/END-EXEC
C/EXEC SQL
C+ Open C1
C/END-EXEC
/free
Select;
When SqlStt='00000';
return *on;
Other;
return *off;
EndSl;
/end-free
P OpenCursor E
Fetch Cursor Procedure
ref [9]
P FetchCursor B
D FetchCursor PI like(ReturnVar)
D ReturnVar s n
C/EXEC SQL
C+ Fetch C1 into :MyLib, :MyFile
C/END-EXEC
/free
Select;
When sqlstt='00000';
// row was received, normal
ReturnVar=*on;
When sqlstt='02000';
// same as %eof, sooner or later this is normal
ReturnVar=*off;
Other;
// alert the troops!
ReturnVar=*off;
EndSl;
return ReturnVar;
/end-free
P FetchCursor E
Close Cursor Procedure
ref [10]
P CloseCursor B
D CloseCursor PI like(ReturnVar)
D ReturnVar s n
C/EXEC SQL
C+ Close C1
C/END-EXEC
/free
Select;
When sqlstt='00000';
// cursor was closed, normal
ReturnVar=*on;
Other;
// alert the troops!
ReturnVar=*off;
EndSl;
return ReturnVar;
/end-free
P CloseCursor E
Exporting and importing snippets
ref [[11]]
Snippets can be transferred to another PC by the process of exporting and importing.
You export on the PC you want to copy the snippets from, and import on the PC you want to copy them to.
Exporting
- In the Snippets view right click and select Customize
- Select your custom snippet category
- Select Export (top of the category list, left side)
- See the 'Save as...' dialogue box, remember the file name you chose!
- Copy/FTP/email that XML file to the target PC
Importing
- Get a snippets XML file some place where it's available to WDSC
- In the Snippets view right click and select Customize
- Select your custom snippet category
- Select Import (top of the category list, left side)
- See the 'Open...' dialogue box.
- Select the XML file to import
Snippets XML structure
<?xml version="1.0" encoding="UTF-16"?>
<snippets>
<category filters="*" id="category_1185380127750" initial_state="0" label="RPG" largeicon="" smallicon="">
<description/>
<item category="category_1185380127750" class="" editorclass="" id="item_1207666311828" label="subprocedure" largeicon="" smallicon="">
<description><![CDATA[Subprocedure skeleton]]></description>
<content><![CDATA[
* ${proc_comment}
p ${proc_name} b
d ${proc_name} pi 10i 0
d ${parm_name} 1a
d rc 10i 0 inz
c/free
return rc;
/end-free
p e]]></content>
<variable default="Description of procedure" id="name_3" name="proc_comment">
<description><![CDATA[Description]]></description>
</variable>
<variable default="new_parm" id="name_2" name="parm_name">
<description><![CDATA[Parameter name]]></description>
</variable>
<variable default="new_proc" id="name_1" name="proc_name">
<description><![CDATA[Procedure name]]></description>
</variable>
</item>
</category>
</snippets>
DayOfWeek snippet
ref [[12]]
* // 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 [[13]]
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 [[14]]
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: [[15]]
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: [[16]]
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: [[17]]
[| 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: [[18]]
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 [[21]]
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
RPG FTP TEMPLATE
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER)
H Bnddir('QC2LE')
//
//***************************************************************
// USE FTP TO GET OR PUT FILES TO THE IFS
// BIN(ARY) TRANSFERS ARE USED,DATA IS ASSUMED TO BE ASCII
// IT IS ASSUMED OTHER FUNCTIONS PUT OR GET FROM IFS TO DB FILES
// SENT FILES (PUT) ARE ARCHIVED TO ARCH SUBDIRECTORY IF IT EXISTS
//
// REQUIRES FILES FTPADDR AND FTPMSGLOG
// (LAYOUT CAN BE INFERRED FROM THIS PGM LOGIC)
//
// PARMS IN
// D ADDR 10A KEY TO FILE FOR USER PWORD AND FTP_ADDR
// D FDIR 40A LCD IFS DIRECTORY OF FILE TO PUT/GET
// D TDIR 40A CD IFS DIRECTORY OF FILE TO PUT/GET
// D FN 3A PUT OR GET
// D FFIL 40A NAME OF FILE
//
// PARMS OUT
// D FERR 1A FTP FAIL IF NOT ZERO
//***************************************************************
//
//
FFTPADDR IF E K DISK
D PROFILE S 25
D FROMDIR S 40
D TODIR S 40
D FNC S 3
D FNCFILE S 40
//
D RT S 10I 0
D SRCDTA S 100
D NOK C -1
D OK C 0
D TCK1 C 'TRANSFER COMPLETE'
// Program Status
D SDS
D PGM 1 10
D WSID 244 253A
D USER 254 263A
D NBR 264 269A
D DAT 276 281A
//
//
//-------------------- Prototypes
D FTPPGM PR
D 10A
D 40A
D 40A
D 3A
D 40A
D 1A
D FTPPGM PI
D ADDR 10A
D FDIR 40A
D TDIR 40A
D FN 3A
D FFIL 40A
D FERR 1A
// FOR RUNNING AS400 COMMANDS
D SYS PR 10I 0 Extproc('system')
D CmdString * Value
D Options(*String)
//
D MAIN PR
D WRKFILES PR
D LOADFTPS PR
D DOTHEFTP PR
D RMVWRKF PR
D CKTHEFTP PR
D MOVTOARCH PR
D LOGTHEFTP PR
/FREE
MAIN();
/END-FREE
//
//###################################################//
P MAIN B
//
//***************************************************************
D MAIN PI
/FREE
*INLR = *ON;
//
WRKFILES(); // SETUP FTP WORK FILES
//
LOADFTPS(); // SETUP FTP COMMANDS
//
DOTHEFTP(); // EXECUTE THE FTP
//
CKTHEFTP(); // CHECK THE TRANSFER
//
MOVTOARCH(); // MOVE TO ARCHIVE
//
LOGTHEFTP(); // LOG THE FTP OUTPUT
//
RMVWRKF (); // CLEANUP THE WORK FILES
RETURN;
//###################################################//
/END-FREE
P MAIN E
//
//###################################################//
P WRKFILES B
/FREE
RT = SYS('DLTF QTEMP/INPUT');
RT = SYS('DLTF QTEMP/OUTPUT');
RT = SYS('CRTSRCPF QTEMP/INPUT MBR(*FILE)');
RT = SYS('CRTSRCPF QTEMP/OUTPUT MBR(*FILE)');
RT = SYS('OVRDBF INPUT QTEMP/INPUT OVRSCOPE(*JOB)');
RT = SYS('OVRDBF OUTPUT QTEMP/OUTPUT OVRSCOPE(*JOB)');
/END-FREE
P WRKFILES E
//
//###################################################//
P LOADFTPS B
/FREE
FERR = '0';
CHAIN ADDR FTPADDR;
IF NOT %FOUND;
FERR = '1';
RETURN;
ENDIF;
//
PROFILE = FTUSER + ' ' + FTPASS;
FROMDIR = FDIR;
TODIR = TDIR;
FNCFILE = FFIL;
FNC = FN;
//
EXEC SQL SET OPTION COMMIT =*NONE;
//
EXEC SQL
INSERT INTO INPUT VALUES
(0,0 , :PROFILE ) ,
(0,0 , 'NAMEFMT 1 ' ) ,
(0,0 , 'LCD ' || :FROMDIR ) ,
(0,0 , 'CD ' || :TODIR ) ,
(0,0 , 'BIN ' ) ,
(0,0 , :FNC ||' ' || :FNCFILE ) ,
(0,0 , 'CLOSE ' ) ,
(0,0 , 'QUIT' ) ;
//
IF sqlstt <> '00000';
FERR = '2';
RETURN;
ENDIF;
/END-FREE
P LOADFTPS E
//
//###################################################//
P DOTHEFTP B
/FREE
IF FERR <> '0';
RETURN;
ENDIF;
RT = SYS('FTP ' + FTADDR );
/END-FREE
P DOTHEFTP E
//
//###################################################//
P CKTHEFTP B
/FREE
EXEC SQL
SELECT SRCDTA into :SRCDTA FROM OUTPUT WHERE
UPPER(SRCDTA) like '%TRANSFER COMPLETE%'
FETCH FIRST 1 ROW ONLY ;
//
IF sqlstt <> '00000';
FERR = '3';
RETURN;
ENDIF;
/END-FREE
P CKTHEFTP E
//
//###################################################//
P MOVTOARCH B
/FREE
IF FERR <> '0';
RETURN;
ENDIF;
// ONLY ARCHIVE THE SENT FILES (PUT)
IF FNC = 'GET';
RETURN;
ENDIF;
RT = SYS('MOV OBJ(''' + %TRIM(FROMDIR) +
%TRIM(FNCFILE) + ''') ' +
'TODIR('''+ %TRIM(FROMDIR) + 'ARCH'')') ;
/END-FREE
P MOVTOARCH E
//
//###################################################//
P LOGTHEFTP B
/FREE
EXEC SQL
INSERT INTO FTPMSGLOG
(SELECT :WSID, :USER,:NBR, :DAT, SRCDTA FROM OUTPUT) ;
/END-FREE
P LOGTHEFTP E
//
//###################################################//
P RMVWRKF B
/FREE
RT = SYS('DLTF QTEMP/INPUT');
RT = SYS('DLTF QTEMP/OUTPUT');
RT = SYS('DLTOVR INPUT LVL(*JOB)');
RT = SYS('DLTOVR OUTPUT LVL(*JOB)');
/END-FREE
P RMVWRKF E
RPG IFS READ TEMPLATE
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
H DFTACTGRP(*NO ) ACTGRP(*CALLER)
>
> * RPGLE IFSREADR CHECK the files in a directory
> * If the file exists it needs to be PROCESSED
> *
*
* PARMS IN
* prefix 10 chr 10 character prefix to find a file
* path 256 chr the path on the IFS to check
*
*
D p_old_dir s *
D old_dir s 256A
D p_new_dir s *
D new_dir s 256A
d* a few local variables...
D dh S *
D PathName S 256A
D Name S 256A
D cl S 10U 0
D @loop S 1A
D NameF S 64A
D Suff S 3A
D x S 9P 0
D prefixv S 10A varying
>
//-------------------- Prototypes
D MAIN PR
D WRKFILES PR
D IFSREADR PR
D 10A
D 256A
D IFSREADR PI
D prefix 10A
D PATH 256A
*
d**********************************************************************
d*
d* Directory Entry Structure (dirent)
d*
d* struct dirent {
d* char d_reserved1[16]; /* Reserved */
d* unsigned int d_reserved2; /* Reserved */
d* ino_t d_fileno; /* The file number of the file */
d* unsigned int d_reclen; /* Length of this directory entry
d* * in bytes */
d* int d_reserved3; /* Reserved */
d* char d_reserved4[8]; /* Reserved */
d* qlg_nls_t d_nlsinfo; /* National Language Information
d* * about d_name */
d* unsigned int d_namelen; /* Length of the name, in bytes
d* * excluding NULL terminator */
d* char d_name[_QP0L_DIR_NAME]; /* Name...null terminated */
d*
d* };
D p_dirent s *
D dirent ds based(p_dirent)
D d_reserv1 16A
D d_reserv2 10U 0
D d_fileno 10U 0
D d_reclen 10U 0
D d_reserv3 10I 0
D d_reserv4 8A
D d_nlsinfo 12A
D nls_ccsid 10I 0 OVERLAY(d_nlsinfo:1)
D nls_cntry 2A OVERLAY(d_nlsinfo:5)
D nls_lang 3A OVERLAY(d_nlsinfo:7)
D nls_reserv 3A OVERLAY(d_nlsinfo:10)
D d_namelen 10U 0
D d_name 640A
d*--------------------------------------------------------------------
d* Open a Directory
d* DIR *opendir(const char *dirname)
D opendir PR * EXTPROC('opendir')
D dirname * VALUE
d*--------------------------------------------------------------------
d* Read Directory Entry
d* struct dirent *readdir(DIR *dirp)
D readdir PR * EXTPROC('readdir')
D dirp * VALUE
d*--------------------------------------------------------------------
d* Close Directory
d* int closedir(DIR *dirp)
D closedir PR 10U 0 EXTPROC('closedir')
D cldirp * VALUE
/FREE
MAIN();
/END-FREE
//###################################################//
P MAIN B
/FREE
*inlr = '1' ;
prefixv = %trim(prefix);
// Step1: Open up the directory.
PathName= %trim(PATH)+ x'00';
dh = opendir(%addr(PathName));
// Step2: Read each entry from the directory
dow @loop = @loop;
p_dirent = readdir(dh);
if p_dirent = *NULL;
leave;
endif;
Name = %subst(d_name:1:d_namelen);
// not a file
If Name = '. ' or Name = '.. ' ;
Iter;
Endif;
// Strip the suffix
Namef = %subst(Name:1:10);
x = %scan('.':Name:1);
If x > 1;
NameF = %subst(Name:1:x-1);
EndIf;
// not a file (assume names without suff are not files)
If x < 2;
Iter;
Endif;
// Get the suffix
Suff = %trim(%subst(Name:x+1));
// PROCESS THE FILE
WRKFILES();
EndDo;
// Step3: Close the directory.
cl = closedir(dh);
/END-FREE
P MAIN E
//###################################################//
P WRKFILES B
D FTPPROC PR EXTPGM('FTPPGM')
D 10A CONST
D 40A CONST
D 40A CONST
D 3A CONST
D 40A CONST
D 1A
D WC011R PR EXTPGM('WC011R')
D 10A CONST
D 10A CONST
D 10A CONST
D 256A CONST
D 1A
D ADDR s 10A
D FDIR s 40A
D TDIR s 40A
D FFIL s 40A
D FERR s 1A
D CDATA s 256A
D ERR s 1A
D @@ENV S 4A
/FREE
x = %scan(prefixv:NameF:1);
If x = 1;
// Found a file matching the pre fix
ADDR = 'CAR';
FFIL = NAME;
// GET A DIR FOR A CONTROL FILE
WC011R ('INVC ':'COMPY1 ':'LOC ': CDATA: ERR) ;
TDIR = CDATA;
FDIR = %TRIM(PATH);
IF (ERR = 'N') ;
// FTP SEND THE FILE
FTPPROC ( ADDR : FDIR : TDIR :'PUT': FFIL : FERR );
ENDIF;
EndIf;
/END-FREE
P WRKFILES E
RPG SUBFILE TEMPLATE
This is a demo RPG subfile processing program.
It can be used as a template.
Except for the viewing SFL (S05),it uses the simplest subfile method where
number of SflRcds is limited to 9999.
SFL (S05) does a page at a time via a preloaded auto extending User Space.
For messages does NOT use message subfiles.
IMO message SFL are an overkill.
How often have you done or seen done, a position to the MSGSFL messages and scroll.
Users deal with one message at a time then press enter, hence the first error
encountered is sent to the user, and so on.
Indicators for positioning the cursor to the error are NOT used.
CSRLOC keywords are used. An API converts FIELD NAMES to the row/col which is
what IBM should have done in the first place, instead of forcing the hard
coding of row, col.
Indicators are used sparingly, mainly for Display file interaction F keys &
SFL CTL. Two indicators 88 89 are used to flag an error.
A trick with Cursor Positioning is used, because if an ERRMSG type keyword is
actioned IBM will not position the cursor, so 88 controls a write to pos the cur
then 89 is done to show the message.
This statement is at the heart of the logic.
One issue with multi screen processing is the way the program logic digs itself
into ever deeper layers. If you know what this means then it may be of interest
that this programs structure only goes down ONE level, even though the program
seems to drop through level after level.
This is achieved by a looping structure and an array that carries the 'logical'
level. F12 will seem to step backwards through many program levels.
Array SCN is dimmed at 99 but this can be whatever you need.
To get from one screen to another the logic MUST always drop back to the
controlling procedure (MAIN) and tell (MAIN) what is the next panel to display.
Each subfile needs 3 procedures, BLD PRC and PRS.
BLD loads the subfile. PRC drives the SFLCTL. PRS processes the SFL lines.
The SFL lines are never used as 'data entry/maintenance' rather an Option
brings up a Display Record panel for the actual data manipulation.
//***************************************************************
// THIS PROGRAM ONLY GOES 1 LEVEL DOWN IN ITS CALL STRUCTURE
// Each panel is precessed by its own procedure.
// A driving procdeure then calls the panels procedure.
// The user will see that there are many panels on top
// of each other by pressing CF12, but this is a LOGICAL
// structure ONLY, controlled by the levels array SCN.
// The TOP level in SCN will contain *END and when reached
// will cause the program to end.
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER)
H Bnddir('QC2LE')
//***************************************************************
//
// PROGRAM ID : USEDPRODRU
// Description: Entry of PRODUCT Usage
//
//***************************************************************
// MODIFICATIONS:
// MOD SR DATE MODIFICATION SUMMARY
//
//***************************************************************
//
//
FPCODES UF A E K DISK
FUSEDPROD UF A E K DISK
FUSEDPROD1 IF E K DISK
F RENAME(PUP100:PUP101)
//
FUSEDPRODFPCF E WORKSTN
F INFDS(SFINF)
F SFILE(S02:RS02)
F SFILE(S05:RS05)
F SFILE(S06:RS06)
F SFILE(S08:RS08)
F SFILE(S09:RS09)
D COMPANY S 3S 0 DTAARA
D DBLIB S 10 DTAARA
// SCREEN LEVELS
D @SCN S 6 DIM(99)
D @NSCN S 6
D @LV S 5 0
D @ERR S LIKE(@TRUE)
D @FILE S 10A INZ('USEDPRODFP')
D WRKSWS S 1
D L08KEY S LIKE(S08KEY)
D @TRUE S 1A INZ('1')
D @FALSE S 1A INZ('0')
D @LOOP S LIKE(@TRUE )
D @OK S LIKE(@TRUE )
//
D RS02 S 4S 0
D RS05 S 4S 0
D RS06 S 4S 0
D RS08 S 4S 0
D RS09 S 4S 0
//
// PARMS FOR SFL LOOPING
D SFC02 S LIKE(RS02)
D SFC05 S LIKE(RS05)
D SFC06 S LIKE(RS06)
D SFC08 S LIKE(RS08)
D SFC09 S LIKE(RS09)
D RCD05 S 12 0
// Program Status
D SDS
D PGM 1 10
D WSID 244 253
D USER 254 263
//
D PCSTKEY DS likerec(PCP100 : *key)
D PUSTKEY DS likerec(PUP100 : *key)
D PUSTKY1 DS likerec(PUP101 : *key)
//
D S05DTA DS likerec(S05 : *OUTPUT)
// MESSAGE DATA
D @DTA1 DS 80
D @DTA2 DS 500
//
D SFINF DS
D RRRN 376 377B 0
D SRN 378 379B 0
//
D WFLDS DS OCCURS(999)
D FNAME 10
D FTYP 1
D FLEN 10i 0
D FDEC 10i 0
D SDATA DS 80
D SFMT 17 17
D SNAME 19 28
D SLEN 32 34S 0
D STYP 35 35
D SDEC 36 37
// FOR RUNNING AS400 COMMANDS
D RT S 10I 0
D SYS PR 10I 0 Extproc('system')
D CmdString * Value
D Options(*String)
//
D MAIN PR
D @R01 PR
D @R03 PR
D @R04 PR
D @S02BLD PR
D @S02PRC PR
D @S02PRS PR
D @S05BLD PR
D @S05PRC PR
D @S06BLD PR
D @S06PRC PR
D @S06PRS PR
D @R07 PR
D @S08BLD PR
D @S08PRC PR
D @S08PRS PR
D @S09BLD PR
D @S09PRC PR
D
D @R9999 PR
D @OPADJ PR 2A
D OPT 2A
*-------------------------------------------------------------------
* QMHRTVM API (Retrieve Message text)
*-------------------------------------------------------------------
D RtvMsgTxt PR 1024
D RMsgId 7 Const
D RMsgFle 10 Const
D RMsgLib 10 Const
D RMsgLvl 1 Const
D GETROWCOL PR
D 10A const
D 10A const
D 10A const
D 32A const
D 3P 0
D 3P 0
D SysDate PR 8S 0
D SysTime PR 6S 0
D DayOfWeek PR 10I 0
D D value datfmt(*iso)
// Message file names
D cMsgLib C Const('*LIBL ')
D cMsgF1 C Const('MSGF1 ')
D cMsgF2 C Const('MSGF2 ')
D cMsgLvl1 C Const('1')
D cMsgLvl2 C Const('2')
/FREE
MAIN();
*INLR = *ON;
//--------------*INZSR-------------------------------//
BEGSR *INZSR;
// Get Company
CMPNO = 0;
IN COMPANY;
CMPNO = COMPANY;
@LOOP = @TRUE;
@OK = @TRUE;
@LV = 1;
@SCN(@LV) = '*END ';
@LV = @LV + 1;
@SCN(@LV) = 'R01 ';
ENDSR;
/END-FREE
//###################################################//
//###################################################//
//###################################################//
//*************************************************************
P MAIN B
D MAIN PI
/FREE
EXSR @INZSR;
//
DOW @LOOP = @LOOP;
@NSCN = @SCN(@LV);
SELECT;
// PROMPT FOR A DATE
// F6 TO MAINTAIN PRODUCT CODES
WHEN @NSCN = 'R01 ';
@R01();
// SFL TO MAINTAIN PRODUCT USAGE
WHEN @NSCN = 'S02BLD';
@S02BLD();
WHEN @NSCN = 'S02PRC';
@S02PRC();
WHEN @NSCN = 'S02PRS';
@S02PRS();
// RCD TO ADD PRODUCT USAGE
WHEN @NSCN = 'R03';
@R03();
// RCD TO CHG PRODUCT USAGE
WHEN @NSCN = 'R04';
@R04();
// SFL TO VIEW PRODUCT USAGE (WITH POSN)
WHEN @NSCN = 'S05BLD';
@S05BLD();
WHEN @NSCN = 'S05PRC';
@S05PRC();
// SFL TO MAINTAIN PRODUCT CODES
WHEN @NSCN = 'S06BLD';
@S06BLD();
WHEN @NSCN = 'S06PRC';
@S06PRC();
WHEN @NSCN = 'S06PRS';
@S06PRS();
// RCD TO ADD PRODUCT CODE
WHEN @NSCN = 'R07';
@R07();
// SFL WDW TO LOOKUP PRODUCT CODES
WHEN @NSCN = 'S08BLD';
@S08BLD();
WHEN @NSCN = 'S08PRC';
@S08PRC();
WHEN @NSCN = 'S08PRS';
@S08PRS();
// SFL FOR DEL PRODUCT CODES (WITH VALIDATION)
WHEN @NSCN = 'S09BLD';
@S09BLD();
WHEN @NSCN = 'S09PRC';
@S09PRC();
OTHER;
// CATCH ALL (NEVER USED)
@R9999();
LEAVE;
ENDSL;
// CF3 EXIT
IF *IN03 = *ON;
LEAVE;
ENDIF;
// CF12 PREVIOUS
IF *IN12 = *ON;
*IN12 = *OFF;
@LV = @LV -1;
@NSCN = @SCN(@LV);
ENDIF;
// Backed out to last level, Exit
IF @NSCN = '*END';
LEAVE;
ENDIF;
//
ENDDO;
//
RETURN;
//
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P MAIN E
//###################################################//
//###################################################//
//###################################################//
P @R01 B
*
D @R01 PI
D @DAYNO S 10I 0
D @FORMAT S 10 INZ('R01')
//
/free
EXSR @INZSR;
EXSR BLD;
DOW @LOOP = @LOOP;
EXFMT R01;
// setoff errors
@ERR = @FALSE;
*IN88 = *OFF;
*IN89 = *OFF;
ROW01 = 999;
COL01 = 999;
//Exit and Previous Screen
IF (*IN03 = *ON) or
(*IN12 = *ON);
Leave;
ENDIF;
// Create
IF (*IN06 = *ON) ;
@LV = @LV +1;
@SCN(@LV) = 'S06BLD';
LEAVE;
ENDIF;
// View
IF (*IN07 = *ON) ;
@LV = @LV +1;
@SCN(@LV) = 'S05BLD';
LEAVE;
ENDIF;
// Validate the data
EXSR VAL;
IF @Err = @True;
*IN88 = *ON ;
*IN89 = *OFF;
WRITE R01;
*IN89 = *ON;
ITER;
ELSE;
WRITE R01;
@LV = @LV +1;
@SCN(@LV) = 'S02BLD';
LEAVE;
ENDIF;
ENDDO;
//
RETURN;
//-------------- CLR -------------------------------//
BEGSR CLR;
CLEAR R01MTH ;
ENDSR;
//-------------- BLD -------------------------------//
BEGSR BLD;
ENDSR;
//-------------- VAL -------------------------------//
BEGSR VAL;
DOW @LOOP = @LOOP;
// VALID DATE
TEST(DE) *ISO R01MTH;
IF %error;
@ERR = @TRUE ;
GETROWCOL (@FILE :'*LIBL' : @FORMAT : 'R01MTH': ROW01:COL01);
R01MSG = RtvMsgTxt('MSG0001':cMsgF2:cMsgLib:cMsgLvl1);
LEAVE;
ENDIF;
// SATURDAY
@DAYNO = DayOfWeek(%DATE(R01MTH:*ISO));
IF @DAYNO <> 6;
@ERR = @TRUE ;
GETROWCOL (@FILE :'*LIBL' : @FORMAT : 'R01MTH': ROW01:COL01);
R01MSG = 'DATE MUST BE A SATURDAY';
LEAVE;
ENDIF;
LEAVE;
ENDDO;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
ENDSR;
/END-FREE
P @R01 E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S02BLD B
D @S02BLD PI
// LOAD PRODUCTS PANEL
//
// Build/Rebuild the subfile
/FREE
EXSR @INZSR;
// SAVKEY = *Blanks;
EXSR BLD;
// SFL IS BUILT, PROCESS CONTROL RCD
@LV = @LV + 1;
@SCN(@LV) = 'S02PRC ';
RETURN;
//-------------- BLD -------------------------------//
BEGSR BLD;
C02MTH = R01MTH;
EXSR CLR;
PUSTKEY.PUSDAT= %DATE(R01MTH:*ISO );
SETLL %kds(PUSTKEY:1) PUP100 ;
DOW @LOOP = @LOOP;
READE %kds(PUSTKEY:1) PUP100 ;
IF %EOF;
LEAVE;
ENDIF;
EXSR MOV;
//
RS02 = RS02 + 1;
WRITE S02;
ENDDO;
// Position to TOP of subfile
SRS02 = 1;
SFC02 = RS02;
ENDSR;
//-------------- CLR -------------------------------//
BEGSR CLR;
*IN51 = *OFF;
*IN52 = *OFF;
*IN53 = *ON;
WRITE C02;
*IN53 = *OFF;
RS02 =0;
SFC02=0;
S02OPT=*BLANK;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
// Load the subfile record
S02OPT = *BLANK;
S02KEY = PUSKY;
S02CT = PUSCT;
S02CT2 = PUSCT2;
S02QTY = PUSQTY;
PCSTKEY.PCSKY = PUSKY ;
CHAIN %kds(PCSTKEY) PCP100 ;
S02PRD = PCDSC;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S02BLD E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S02PRC B
D @S02PRC PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
WRITE R02;
//
DOW @LOOP = @LOOP;
//
// Write SFL Control
IF SFC02 > 0;
*IN51 = *ON;
ENDIF;
*IN52 = *ON;
EXFMT C02;
//
// Setoff errors
*IN89 = *OFF;
//
// Exit and Previous Screen
IF *IN03 = *ON;
LEAVE;
ENDIF;
IF *IN12 = *ON;
@LV = @LV -1;
LEAVE;
ENDIF;
IF *IN06 = *ON;
@LV = @LV +1;
@SCN(@LV) = 'R04 ';
LEAVE;
ENDIF;
// Process the subfile
@LV = @LV + 1;
@SCN(@LV) = 'S02PRS';
LEAVE;
ENDDO;
//
RETURN;
/space 3
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S02PRC E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S02PRS B
D @S02PRS PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
//
// Process the subfile
EXSR SFL;
//
RETURN;
//-------------- SFL -------------------------------//
BEGSR SFL;
// Process the subfile
FOR WRKRC = 1 TO SFC02+1;
CHAIN WRKRC S02;
IF NOT %FOUND;
// Finished with the subfile
// RETURN TO REBUILD LEVEL
@LV = @LV -2;
LEAVE;
ENDIF;
// RIGHT ADJUST OPTION
S02OPT = @OPADJ(S02OPT);
SELECT;
// WORK WITH
WHEN S02OPT = ' 2';
@LV = @LV +1;
@SCN(@LV) = 'R03';
S02OPT = *blank;
UPDATE S02;
LEAVE;
//
OTHER;
S02OPT = *blank;
UPDATE S02;
ENDSL;
//
ENDFOR;
//
ENDSR;
//---------------------------------------------------//
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S02PRS E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @R03 B
*
D @R03 PI
D @FORMAT S 10 INZ('R03')
//
/free
EXSR @INZSR;
EXSR BLD;
DOW @LOOP = @LOOP;
EXFMT R03;
// setoff errors
@ERR = @FALSE;
*IN88 = *OFF;
*IN89 = *OFF;
ROW03 = 999;
COL03 = 999;
//Exit and Previous Screen
IF (*IN03 = *ON) or
(*IN12 = *ON);
Leave;
ENDIF;
// Validate the data
EXSR VAL;
IF @Err = @True;
*IN88 = *ON ;
*IN89 = *OFF;
WRITE R03;
*IN89 = *ON;
ITER;
ELSE;
WRITE R03;
ENDIF;
//UPDATE Previous Screen
IF (*IN06 = *ON);
EXSR UPD;
@LV = @LV -1 ;
Leave;
ENDIF;
ENDDO;
//
RETURN;
//---------------------------------------------------//
//-------------- CLR -------------------------------//
BEGSR CLR;
CLEAR R03QTY ;
ENDSR;
//-------------- BLD -------------------------------//
BEGSR BLD;
R03KEY = S02KEY ;
R03MTH = C02MTH ;
R03PRD = S02PRD ;
R03QTY = S02QTY ;
R03CT = S02CT ;
R03CT2 = S02CT2 ;
ENDSR;
//-------------- VAL -------------------------------//
BEGSR VAL;
DOW @LOOP = @LOOP;
LEAVE;
ENDDO;
ENDSR;
//-------------- UPD -------------------------------//
BEGSR UPD;
PUSTKEY.PUSDAT= %DATE(R03MTH : *ISO);
PUSTKEY.PUSKY = R03KEY;
PUSTKEY.PUSCT = R03CT ;
PUSTKEY.PUSCT2= R03CT2;
CHAIN %kds(PUSTKEY) PUP100 ;
IF %FOUND;
PUSQTY = R03QTY;
UPDATE PUP100;
ELSE;
PUSDAT = %DATE(R03MTH : *ISO);
PUSCT = R03CT ;
PUSCT2 = R03CT2;
PUSKY = R03KEY;
PUSQTY = R03QTY;
WRITE PUP100;
ENDIF;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
ENDSR;
/END-FREE
P @R03 E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @R04 B
*
D @R04 PI
D @FORMAT S 10 INZ('R04')
//
/free
EXSR @INZSR;
EXSR BLD;
DOW @LOOP = @LOOP;
EXFMT R04;
// setoff errors
@ERR = @FALSE;
*IN88 = *OFF;
*IN89 = *OFF;
ROW04 = 999;
COL04 = 999;
//Exit and Previous Screen
IF (*IN03 = *ON) or
(*IN12 = *ON);
Leave;
ENDIF;
//Lookup Product
IF (*IN04 = *ON);
@LV = @LV +1;
@SCN(@LV) = 'S08BLD';
Leave;
ENDIF;
// Validate the data
EXSR VAL;
IF @Err = @True;
*IN88 = *ON ;
*IN89 = *OFF;
WRITE R04;
*IN89 = *ON;
ITER;
ELSE;
WRITE R04;
ENDIF;
//UPDATE Previous Screen
IF (*IN06 = *ON);
EXSR UPD;
@LV = @LV -2 ;
Leave;
ENDIF;
ENDDO;
//
RETURN;
//-------------- CLR -------------------------------//
BEGSR CLR;
ENDSR;
//-------------- BLD -------------------------------//
BEGSR BLD;
IN DBLIB;
R04CT = %subst(DBLIB:2:2);
R04PRD = *BLANK;
R04MTH = C02MTH;
// USE LOOKUP VALUE , IF ANY
IF L08KEY <> *BLANK;
R04KEY = L08KEY;
L08KEY = *BLANK;
ENDIF;
ENDSR;
//-------------- VAL -------------------------------//
BEGSR VAL;
@ERR = @FALSE;
DOW @LOOP = @LOOP;
// CHECK THE PRODUCT KEY
PCSTKEY.PCSKY = R04KEY ;
CHAIN %kds(PCSTKEY) PCP100 ;
R04PRD = *BLANK;
IF %found ;
R04PRD = PCDSC;
ELSE;
@ERR = @TRUE ;
GETROWCOL (@FILE :'*LIBL' : @FORMAT : 'R04KEY': ROW04:COL04);
R04MSG = RtvMsgTxt('MSG0002':cMsgF2:cMsgLib:cMsgLvl1);
LEAVE;
ENDIF;
IF R04QTY <= 0;
@ERR = @TRUE ;
GETROWCOL (@FILE :'*LIBL' : @FORMAT : 'R04QTY': ROW04:COL04);
R04MSG = RtvMsgTxt('MSG0003':cMsgF2:cMsgLib:cMsgLvl1);
LEAVE;
ENDIF;
PUSTKEY.PUSDAT= %DATE(R04MTH : *ISO);
PUSTKEY.PUSKY = R04KEY;
PUSTKEY.PUSCT = R04CT ;
PUSTKEY.PUSCT2= R04CT2;
CHAIN %kds(PUSTKEY) PUP100 ;
IF %FOUND;
@ERR = @TRUE ;
GETROWCOL (@FILE :'*LIBL' : @FORMAT : 'R04KEY': ROW04:COL04);
R04MSG = RtvMsgTxt('MSG0004':cMsgF2:cMsgLib:cMsgLvl1);
LEAVE;
ENDIF;
LEAVE;
ENDDO;
ENDSR;
//-------------- UPD -------------------------------//
BEGSR UPD;
PUSTKEY.PUSDAT= %DATE(R04MTH : *ISO);
PUSTKEY.PUSKY = R04KEY;
PUSTKEY.PUSCT = R04CT ;
PUSTKEY.PUSCT2= R04CT2;
CHAIN %kds(PUSTKEY) PUP100 ;
IF %FOUND;
PUSQTY = R04QTY;
UPDATE PUP100;
ELSE;
PUSDAT = %DATE(R04MTH : *ISO);
PUSCT = R04CT ;
PUSCT2 = R04CT2;
PUSKY = R04KEY;
PUSQTY = R04QTY;
WRITE PUP100;
ENDIF;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
ENDSR;
/END-FREE
P @R04 E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S05BLD B
D @S05BLD PI
// S05 IS A PAGE AT A TIME SFL
// A USER SPACE IS LOADED TO SUPPORT THE SFL
// ENABLE > 9999 DATA RECORDS
//
D X S 10i 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 QUSCUSAT PR ExtPgm('QUSCUSAT')
D ReturnLibrary 10A
D UserSpace 20A Const
D Attribute Const
D LikeDS(SpaceAttr)
D ErrorCode LikeDS(ErrorCode)
D SpaceAttr DS Qualified
D NumberRecs 10I 0
D ExtendRecord 12A
D Key 10I 0 Overlay(ExtendRecord)
D Length 10I 0 OverLay(ExtendRecord:*Next)
D Extend 1A OverLay(ExtendRecord:*Next)
D ErrorCode ds qualified
D BytesProv 10I 0 inz(0)
D BytesAvail 10I 0 inz(0)
D DataEntry S Based(DataPtr) Like(S05DTA)
D TEMPSPC DS 20
D SpaceName 10A Inz('SCROLL05 ')
D Library 10A Inz('QTEMP ')
* BasePtr will hold the base address of the User Space
* At the beginning of the space is a count (Count) of the entries
D BasePtr S *
D Count S 12P 0 Based(BasePtr)
D CountMessage S 30A
D RtnLib S 10A
D SpaceNotFound C 'User Space not found'
/FREE
EXSR @INZSR;
// SAVKEY = *Blanks;
EXSR BLD;
// USER SPC IS LOADED , RUN THE CONTROL
@LV = @LV + 1;
@SCN(@LV) = 'S05PRC ';
RETURN;
//-------------- BLD -------------------------------//
BEGSR BLD;
EXSR CLR;
*IN53 = *OFF;
PUSTKEY.PUSDAT= *LOVAL;
PUSTKEY.PUSKY = *LOVAL;
SETLL %kds(PUSTKEY) PUP100 ;
IF %FOUND;
DOW @LOOP = @LOOP;
READ PUP100 ;
IF %EOF;
LEAVE;
ENDIF;
EXSR MOV;
ENDDO;
ENDIF;
ENDSR;
//-------------- CLR -------------------------------//
BEGSR CLR;
RCD05 = 0;
// --------------------------------------------------
// 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 );
// Set the user space to Auto extend
SpaceAttr.NumberRecs = 1;
SpaceAttr.Key = 3; // 3 is auto extend key
SpaceAttr.Length = 1;
SpaceAttr.Extend = '1'; // 1 means auto extend
QUSCUSAT( Rtnlib : TEMPSPC
: SpaceAttr : ErrorCode );
// Get a pointer to the user space
QUSPTRUS( TEMPSPC: BasePtr );
If BasePtr <> *Null;
DataPtr = BasePtr + %Size(Count);
Eval Count = 0;
Endif;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
RCD05 = RCD05 + 1;
count = count + 1;
S05DTA.S05MTH = %CHAR(PUSDAT : *iso);
S05DTA.S05QTY = PUSQTY;
S05DTA.S05KEY = PUSKY;
S05DTA.S05CT2 = PUSCT2;
PCSTKEY.PCSKY = S05DTA.S05KEY ;
CHAIN %kds(PCSTKEY) PCP100 ;
S05DTA.S05PRD = PCDSC;
DataEntry = S05DTA;
DataPtr = DataPtr + %Size(S05DTA);
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S05BLD E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S05PRC B
D @S05PRC PI
D QUSPTRUS PR ExtPgm('QUSPTRUS')
D UserSpace 20A CONST
D Pointer *
D DataEntry S Based(DataPtr) Like(S05DTA)
D TEMPSPC DS 20
D SpaceName 10A Inz('SCROLL05 ')
D Library 10A Inz('QTEMP ')
* BasePtr will hold the base address of the User Space
* At the beginning of the space is a count (Count) of the entries
D BasePtr S *
D Count S 12P 0 Based(BasePtr)
D CountMessage S 30A
D SpaceNotFound C 'User Space not found'
//
//
D WRKRC S 4S 0
D X S 12S 0
D RECS S 4S 0 INZ(14)
D CURS S 12S 0
D TOPS S 12S 0
/FREE
EXSR @INZSR;
WRITE R05;
//
DOW @LOOP = @LOOP;
// Write SFL Control
IF SFC05 > 0;
*IN51 = *ON;
ENDIF;
*IN52 = *ON;
EXFMT C05;
//
// Setoff errors
*IN89 = *OFF;
// Setoff MORE
*IN99 = *OFF;
//
// Exit and Previous Screen
IF *IN03 = *ON;
LEAVE;
ENDIF;
IF *IN12 = *ON;
@LV = @LV -1;
LEAVE;
ENDIF;
// PAGE UP
IF *IN62 = *ON;
IF TOPS = 1;
ITER;
ENDIF;
EXSR PAGEUP;
ITER;
ENDIF;
// PAGE DOWN
IF *IN61 = *ON;
IF CURS = RCD05;
*IN99 = *ON;
ITER;
ENDIF;
EXSR PAGEDN;
ITER;
ENDIF;
IF C05MTH <> *BLANK;
EXSR POS;
ITER;
ENDIF;
ENDDO;
//
RETURN;
/space 3
//-------------- POS -------------------------------//
BEGSR POS;
FOR X = 1 TO RCD05 ;
CURS = X-1;
DataPtr = BasePtr + %Size(Count) +
+ CURS *%Size(S05DTA);
S05DTA = DataEntry ;
IF S05DTA.S05MTH >= C05MTH;
EXSR PAGEDN;
LEAVE;
ENDIF;
ENDFOR;
ENDSR;
/space 3
//-------------- PAGEUP ------------------------------//
BEGSR PAGEUP;
TOPS = TOPS - RECS;
IF TOPS < 1;
TOPS = 1;
ENDIF;
CURS = TOPS - 1;
DataPtr = BasePtr + %Size(Count) +
+ CURS *%Size(S05DTA);
EXSR PAGEDN;
ENDSR;
/space 3
//-------------- PAGEDN ------------------------------//
BEGSR PAGEDN;
EXSR CLR;
TOPS = CURS + 1;
FOR X = 1 TO RECS;
IF CURS = RCD05;
*IN99 = *ON;
LEAVE ;
ENDIF;
CURS = CURS + 1;
S05DTA = DataEntry ;
DataPtr = DataPtr + %Size(S05DTA);
EXSR MOV;
SFC05 = 1;
SRS05 = 1;
RS05 = X;
WRITE S05;
ENDFOR;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
S05MTH = S05DTA.S05MTH;
S05QTY = S05DTA.S05QTY;
S05KEY = S05DTA.S05KEY;
S05CT2 = S05DTA.S05CT2;
S05PRD = S05DTA.S05PRD;
ENDSR;
//-------------- CLR -------------------------------//
BEGSR CLR;
*IN51 = *OFF;
*IN52 = *OFF;
*IN53 = *ON;
WRITE C05;
*IN53 = *OFF;
RS05 =0;
SFC05=0;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
TOPS = 0;
CURS = 0;
// Get a pointer to the user space
QUSPTRUS( TEMPSPC: BasePtr );
If BasePtr <> *Null;
DataPtr = BasePtr + %Size(Count);
Eval RCD05 = Count ;
Endif;
EXSR PAGEDN;
ENDSR;
/END-FREE
P @S05PRC E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S06BLD B
D @S06BLD PI
// LOAD PRODUCTS PANEL
//
// Build/Rebuild the subfile
/FREE
EXSR @INZSR;
// SAVKEY = *Blanks;
EXSR BLD;
// SFL IS BUILT, PROCESS CONTROL RCD
@LV = @LV + 1;
@SCN(@LV) = 'S06PRC ';
RETURN;
//-------------- BLD -------------------------------//
BEGSR BLD;
EXSR CLR;
PCSTKEY.PCSKY = *LOVAL;
SETLL %kds(PCSTKEY) PCP100 ;
DOW @LOOP = @LOOP;
READ PCP100 ;
IF %EOF;
LEAVE;
ENDIF;
EXSR MOV;
//
RS06 = RS06 + 1;
WRITE S06;
ENDDO;
// Position to TOP of subfile
SRS06 = 1;
SFC06 = RS06;
ENDSR;
//-------------- CLR -------------------------------//
BEGSR CLR;
*IN51 = *OFF;
*IN52 = *OFF;
*IN53 = *ON;
WRITE C06;
*IN53 = *OFF;
RS06 =0;
SFC06=0;
S06OPT=*BLANK;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
S06OPT = *BLANK;
S06KEY = PCSKY;
S06PRD = PCDSC;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S06BLD E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S06PRC B
D @S06PRC PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
WRITE R06;
//
DOW @LOOP = @LOOP;
// Write SFL Control
IF SFC06 > 0;
*IN51 = *ON;
ENDIF;
*IN52 = *ON;
EXFMT C06;
//
// Setoff errors
*IN89 = *OFF;
//
// Exit and Previous Screen
IF *IN03 = *ON;
LEAVE;
ENDIF;
IF *IN12 = *ON;
@LV = @LV -1;
LEAVE;
ENDIF;
IF *IN06 = *ON;
@LV = @LV + 1;
@SCN(@LV) = 'R07';
LEAVE;
ENDIF;
// Process the subfile
@LV = @LV + 1;
@SCN(@LV) = 'S06PRS';
LEAVE;
ENDDO;
//
RETURN;
/space 3
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S06PRC E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S06PRS B
D @S06PRS PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
//
// Process the subfile
EXSR SFL;
//
RETURN;
//-------------- SFL -------------------------------//
BEGSR SFL;
FOR WRKRC = 1 TO SFC06+1;
CHAIN WRKRC S06;
IF NOT %FOUND;
// Finished with the subfile
// RETURN TO REBUILD LEVEL
@LV = @LV -2;
LEAVE;
ENDIF;
// RIGHT ADJUST OPTION
S06OPT = @OPADJ(S06OPT);
SELECT;
// WORK WITH
WHEN S06OPT = ' 4';
@LV = @LV +1;
@SCN(@LV) = 'S09BLD';
LEAVE;
//
OTHER;
S06OPT = *blank;
UPDATE S06;
ENDSL;
//
ENDFOR;
//
ENDSR;
//---------------------------------------------------//
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S06PRS E
/space 3
//###################################################//
//###################################################//
//###################################################//
P @R07 B
D @R07 PI
D @FORMAT S 10 INZ('R07')
//
/free
EXSR @INZSR;
EXSR BLD;
DOW @LOOP = @LOOP;
EXFMT R07;
// setoff errors
@ERR = @FALSE;
*IN88 = *OFF;
*IN89 = *OFF;
ROW07 = 999;
COL07 = 999;
//Exit and Previous Screen
IF (*IN03 = *ON) or
(*IN12 = *ON);
Leave;
ENDIF;
// Validate the data
EXSR VAL;
IF @Err = @True;
*IN88 = *ON ;
*IN89 = *OFF;
WRITE R07;
*IN88 = *OFF;
ROW07 = 999;
COL07 = 999;
*IN89 = *ON;
ITER;
ELSE;
WRITE R07;
ENDIF;
//UPDATE Previous Screen
IF (*IN06 = *ON);
EXSR UPD;
@LV = @LV -2 ;
Leave;
ENDIF;
ENDDO;
//
RETURN;
//-------------- CLR -------------------------------//
BEGSR CLR;
ENDSR;
//-------------- BLD -------------------------------//
BEGSR BLD;
R07KEY = *BLANK ;
R07PRD = *BLANK ;
ENDSR;
//-------------- VAL -------------------------------//
BEGSR VAL;
DOW @LOOP = @LOOP;
LEAVE;
ENDDO;
ENDSR;
//-------------- UPD -------------------------------//
BEGSR UPD;
PCSTKEY.PCSKY = R07KEY ;
CHAIN %kds(PCSTKEY) PCP100 ;
IF %FOUND;
PCDSC = R07PRD;
UPDATE PCP100;
ELSE;
PCSKY = R07KEY;
PCDSC = R07PRD;
WRITE PCP100;
ENDIF;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
ENDSR;
/END-FREE
P @R07 E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S08BLD B
D @S08BLD PI
// LOAD PRODUCTS PANEL
//
// Build/Rebuild the subfile
/FREE
EXSR @INZSR;
// SAVKEY = *Blanks;
EXSR BLD;
// SFL IS BUILT, PROCESS CONTROL RCD
@LV = @LV + 1;
@SCN(@LV) = 'S08PRC ';
RETURN;
//-------------- BLD -------------------------------//
BEGSR BLD;
EXSR CLR;
PCSTKEY.PCSKY = *LOVAL;
SETLL %kds(PCSTKEY) PCP100 ;
DOW @LOOP = @LOOP;
READ PCP100 ;
IF %EOF;
LEAVE;
ENDIF;
EXSR MOV;
//
RS08 = RS08 + 1;
WRITE S08;
ENDDO;
// Position to TOP of subfile
SRS08 = 1;
SFC08 = RS08;
ENDSR;
//-------------- CLR -------------------------------//
BEGSR CLR;
*IN51 = *OFF;
*IN52 = *OFF;
*IN53 = *ON;
WRITE C08;
*IN53 = *OFF;
RS08 =0;
SFC08=0;
S08OPT=*BLANK;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
S08OPT = *BLANK;
S08KEY = PCSKY;
S08PRD = PCDSC;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S08BLD E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S08PRC B
D @S08PRC PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
// WRITE R08;
//
DOW @LOOP = @LOOP;
//
// Write SFL Control
IF SFC08 > 0;
*IN51 = *ON;
ENDIF;
*IN52 = *ON;
EXFMT C08;
//
// Setoff errors
*IN89 = *OFF;
//
// Exit and Previous Screen
IF *IN03 = *ON;
LEAVE;
ENDIF;
IF *IN12 = *ON;
@LV = @LV -1;
LEAVE;
ENDIF;
// Process the subfile
@LV = @LV + 1;
@SCN(@LV) = 'S08PRS';
LEAVE;
ENDDO;
//
RETURN;
/space 3
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S08PRC E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S08PRS B
D @S08PRS PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
// Process the subfile
EXSR SFL;
//
RETURN;
//-------------- SFL -------------------------------//
BEGSR SFL;
FOR WRKRC = 1 TO SFC08+1;
CHAIN WRKRC S08;
IF NOT %FOUND;
// Finished with the subfile
// RETURN TO REBUILD LEVEL
@LV = @LV -2;
LEAVE;
ENDIF;
// RIGHT ADJUST OPTION
S08OPT = @OPADJ(S08OPT);
SELECT;
// SELECTED KEY
WHEN S08OPT = ' 1';
L08KEY = S08KEY;
@LV = @LV -3;
LEAVE;
//
OTHER;
S08OPT = *blank;
UPDATE S08;
ENDSL;
//
ENDFOR;
//
ENDSR;
//---------------------------------------------------//
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S08PRS E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S09BLD B
D @S09BLD PI
// LOAD PRODUCTS PANEL
//
// Build/Rebuild the subfile
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
// SAVKEY = *Blanks;
EXSR BLD;
// SFL IS BUILT, PROCESS CONTROL RCD
@LV = @LV + 1;
@SCN(@LV) = 'S09PRC ';
RETURN;
//-------------- BLD -------------------------------//
BEGSR BLD;
EXSR CLR;
*IN53 = *OFF;
FOR WRKRC = 1 TO SFC06;
CHAIN WRKRC S06;
IF @OPADJ(S06OPT) = ' 4';
EXSR MOV;
RS09 = RS09 + 1;
WRITE S09;
ENDIF;
ENDFOR;
// Position to TOP of subfile
SRS09 = 1;
SFC09 = RS09;
ENDSR;
//---------------------------------------------------//
//-------------- CLR -------------------------------//
BEGSR CLR;
*IN51 = *OFF;
*IN52 = *OFF;
*IN53 = *ON;
WRITE C09;
*IN53 = *OFF;
RS09 =0;
SFC09=0;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
S09KEY = S06KEY ;
S09PRD = S06PRD ;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S09BLD E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S09PRC B
D @S09PRC PI
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
WRITE R09;
//
DOW @LOOP = @LOOP;
// Write SFL Control
IF SFC09 > 0;
*IN51 = *ON;
ENDIF;
*IN52 = *ON;
EXFMT C09;
// Setoff errors
*IN89 = *OFF;
@ERR = @FALSE;
//
// Exit and Previous Screen
IF *IN03 = *ON;
LEAVE;
ENDIF;
IF *IN12 = *ON;
@LV = @LV -2;
LEAVE;
ENDIF;
EXSR CHKDEL;
IF @ERR = @TRUE;
*IN89 = *ON ;
ITER;
ENDIF;
EXSR DEL;
@LV = @LV -4;
LEAVE;
ENDDO;
//
RETURN;
//---------------------------------------------------//
BEGSR DEL;
FOR WRKRC = 1 TO SFC06 ;
CHAIN WRKRC S06;
IF @OPADJ(S06OPT) = ' 4';
S06OPT = ' ';
UPDATE S06;
PCSTKEY.PCSKY = S06KEY ;
DELETE %kds(PCSTKEY) PCP100 ;
ENDIF;
ENDFOR;
ENDSR;
//---------------------------------------------------//
BEGSR CHKDEL;
FOR WRKRC = 1 TO SFC06 ;
CHAIN WRKRC S06;
IF @OPADJ(S06OPT) = ' 4';
PUSTKY1.PUSKY = S06KEY;
SETLL %kds(PUSTKY1:1) PUP101 ;
IF %EQUAL;
@ERR = @TRUE;
C09MSG = 'CANNOT DELETE ' + S06KEY +
' AS IT IS IN USE.';
LEAVE;
ENDIF;
ENDIF;
ENDFOR;
ENDSR;
//---------------------------------------------------//
/space 3
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S09PRC E
//###################################################//
//###################################################//
//###################################################//
P @R9999 B
// Invalid Panel
D @R9999 PI
P @R9999 E
/space 3
//###################################################//
//###################################################//
//###################################################//
P @OPADJ B
// RIGHT ADJ OPTION , zero suppress
D @OPADJ PI 2A
D OPT 2A
/FREE
EVALR OPT = %trimr(OPT);
If %SubSt(OPT:1:1) = '0';
OPT = ' ' + %SubSt(OPT:2:1);
EndIf;
RETURN OPT;
/END-FREE
P @OPADJ E
//###################################################//
//###################################################//
//###################################################//
P RtvMsgTxt B
//************************************************************************
// API Call: QMHRTVM Retrieve Message text
//************************************************************************
// USAGE
// MsgTxt = RtvMsgTxt('MSG0005':cMsgF3:cMsgLib:cMsgLvl1);
D RtvMsgTxt PI 1024
D RMsgId 7 Const
D RMsgFle 10 Const
D RMsgLib 10 Const
D RMsgLvl 1 Const
// Retrieve Message Description API Prototype
D Get_Message PR ExtPgm('QMHRTVM')
D 4000 Options(*VarSize)
D 10I 0 Const
D 8 Const
D 7
D 20 Const
D 32765 Options(*VarSize)
D 10I 0 Const
D 10 Const
D 10 Const
D 8192 Options(*VarSize)
D 10
D 9B 0
D 9B 0
// Define Variables for QMHRTVM API call:
// --------------------------------------
// Return variables
D MessageInfo DS 4000
D Data 1 4000
D OSMSG 65 68B 0
D LMsgR 69 72B 0
D LMsgA 73 76B 0
D OSMSGH 77 80B 0
D LMsgHR 81 84B 0
D LMsgHA 85 88B 0
// Required input variables
D MessageLen S 10I 0
D MessageForm S 8
D MessageIden S 7
D MessageFile S 20
D Replacement S 32765
D ReplaceLen S 10I 0
D ReplaceSub S 10
D ReturnCtl S 10
D RetrieveOpt S 10
D ConvToCCSID S 9B 0
D ReplDtaCCSID S 9B 0
D Return_Text S 1024
D ErrorCode DS Qualified
D BytesProv 4B 0 Inz(0)
D BytesAvail 8B 0 Inz(0)
D ExceptionId 7
D Reserved 1
D ExceptionDta 512
/FREE
// Load API parameter fields
MessageInfo = *blanks;
MessageLen = 4000;
MessageForm = 'RTVM0300';
MessageIden = RMsgId;
MessageFile = RMsgFle + RMsgLib;
Replacement = *blanks;
ReplaceLen = %Len(Replacement);
ReplaceSub = '*YES';
ReturnCtl = '*YES';
RetrieveOpt = '*MSGID';
ConvToCCSID = 0;
ReplDtaCCSID = 0;
// Retrieve message description
Get_Message(MessageInfo :
MessageLen :
MessageForm :
MessageIden :
MessageFile :
Replacement :
ReplaceLen :
ReplaceSub :
ReturnCtl :
ErrorCode :
RetrieveOpt :
ConvToCCSID :
ReplDtaCCSID);
// Process Return variables
Return_Text = *blanks;
// If no errors, determine the correct portion of the message text
If ErrorCode.BytesProv = 0;
Select;
When RMsgLvl = '1';
Return_Text = %Subst(data:OSMSG+1:LMsgA); // Msg Lvl 1
When RMsgLvl = '2';
Return_Text = %Subst(data:OSMSGH+1:LMsgHA); // Msg Lvl 2
EndSl;
Else;
Return_Text = 'Get_Message failed.';
EndIf;
// Return to calling point
Return Return_Text;
/END-FREE
P E
//###################################################//
//###################################################//
//###################################################//
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 3P 0
D RtnCOL 3P 0
D GETROWCOL PI
D schFile 10A const
D schLib 10A const
D schFormat 10A const
D schString 32A const
D rtnROW 3P 0
D RtnCOL 3P 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 Type 1a
D Use 1a
D Obuff 10i 0
D Ibuff 10i 0
D Len 10i 0
D Digt 10i 0
D Dec 10i 0
D FILLER 416a
d DspRow 10i 0
d DspCol 10i 0
D TEMPSPC C 'GETROWCOL QTEMP'
D x s 10I 0
/free
rtnrow = 999;
rtnrow = 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
// Invaid data is ignored an 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 schString = '*ALL';
%OCCUR(WFLDS) =x+1;
rtnRow = x+1;
rtnCol = 0;
FNAME = Field.name;
FTYP = Field.Type;
FLEN = Field.Len ;
FDEC = Field.Dec ;
else;
if Field.Name = schString;
rtnRow = Field.DspRow;
rtnCol = Field.DspCol;
leave;
endif;
endif;
endfor;
// --------------------------------------------------
// Delete temp user space & end
QUSDLTUS( TEMPSPC: ErrorCode );
return;
/end-free
P E
//###################################################//
//###################################################//
//###################################################//
P SysDate B
* // Procedure: SysDate //
* // Purpose: Gets the system date YYYYMMDD format 8S 0 //
* // Parameters: //
* // Returns: //
* // int -- date in YYYYMMDD fmt //
* //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
P
D SysDate PI 8S 0
D
/free
Return %INT(%CHAR(%DATE():*ISO0));
/end-free
P SysDate E
//###################################################//
//###################################################//
//####################################################
P SysTime B
* // Procedure: SysTime //
* // Purpose: Gets the system time HHMMSS format 6S 0 //
* // Parameters: //
* // Returns: //
* // int -- TMIE in HHMMSS fmt //
* //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
P
D SysTime PI 6S 0
D
/free
Return %INT(%CHAR(%TIME():*ISO0));
/end-free
P SysTime E
//###################################################//
//###################################################//
//####################################################
P DayOfWeek B
* // 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
D DayOfWeek pi 10i 0
D dt d value datfmt(*iso)
/free
return %rem (%diff (dt: d'1800-01-05': *days): 7);
/end-free
P DayOfWeek e
//####################################################
//***************************************************************
// THIS PROGRAM ONLY GOES 1 LEVEL DOWN IN ITS CALL STRUCTURE
// Each panel is precessed by its own procedure.
// A driving procdeure then calls the panels procedure.
// The user will see that there are many panels on top
// of each other by pressing CF12, but this is a LOGICAL
// structure ONLY, controlled by the levels array SCN.
// The TOP level in SCN will contain *END and when reached
// will cause the program to end.
*****************************************************************
** OBJECT ID: PCODES
** TEXT: PRODUCT CODES
*****************************************************************
** MODIFICATIONS:
** MOD SCN DATE MODIFICATION SUMMARY
**
*****************************************************************
A R PCP100 TEXT('PRODUCT CODES ')
A PCSKY 15 TEXT('KEY ')
A PCDSC 30 TEXT('DESCRIPTION')
A K PCSKY
*****************************************************************
** OBJECT ID: USEDPROD
** TEXT: USED PRODUCTS
*****************************************************************
** MODIFICATIONS:
** MOD SCN DATE MODIFICATION SUMMARY
**
*****************************************************************
A R PUP100 TEXT('PRODUCT USAGE')
A PUSDAT L TEXT('DATE')
A PUSCT 2 TEXT('AREA ')
A PUSCT2 2 TEXT('SUBURB ')
A PUSKY 15 TEXT('KEY ')
A PUSQTY 5 0 TEXT('USED')
A
A K PUSDAT
A K PUSKY
A K PUSCT
A K PUSCT2
*****************************************************************
** OBJECT ID: USEDPROD
** TEXT: USED PRODUCTS
*****************************************************************
** MODIFICATIONS:
** MOD SCN DATE MODIFICATION SUMMARY
**
*****************************************************************
A R PUP100 TEXT('PRODUCT USAGE ')
A PFILE(USEDPROD)
A K PUSKY
A K PUSCT
A K PUSCT2
A*
A* File name : USEDPRODFM
A*
A* Description : Used Product Entry
A*
A* Written :
A*
A*==============================================================*
A* MODIFICATIONS:
A* MOD SCN DATE MODIFICATION SUMMARY
A*
A*
A*==============================================================*
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A CA03(03 'End of job')
A CA12(12 'Previous')
A*==============================================================*
A*
A*
A R R01
A CF06(06 'Create')
A*%%TS SD 20101013 125107
A CA07(07 'View')
A 88 CSRLOC(ROW01 COL01)
A 89 R01MSG 79 M
A ROW01 3S 0H
A COL01 3S 0H
A*
A 1 2'USEDPRODFM.01'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 28'USED PRODUCT REPORTING'
A 1 60TIME
A 1 70DATE
A EDTCDE(Y)
A 2 28'Used Product Entry'
A 5 3'Enter the Date :'
A R01MTH 8Y 0B 5 22EDTCDE(4)
A 5 32'(YYYYMMDD)'
A 24 2'F3=Exit F6=Maintain PROD F7=View-
A F12=Cancel'
A R S02 SFL
A*%%TS SD 20101013 130118
A S02OPT 2A B 10 2
A S02PRD 30A O 10 6
A S02QTY 6Y 0O 10 38EDTCDE(Z)
A S02CT2 2A O 10 46
A S02CT 2A H
A S02KEY 15A H
A*
A*==============================================================*
A R C02 SFLCTL(S02)
A CF06(06 'Create')
A*%%TS SD 20101013 130118
A SFLSIZ(0015)
A SFLPAG(0014)
A TEXT('Used Product Entry')
A OVERLAY
A 51 SFLDSP
A 52 SFLDSPCTL
A 53 SFLCLR
A 99 SFLEND
A 89 C02MSG 79 M
A SRS02 4S 0H SFLRCDNBR
A*
A 1 2'USEDPRODFM.02'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 28'USED PRODUCT REPORTING'
A 1 60TIME
A 1 70DATE
A EDTCDE(Y)
A 2 28'Used Product Entry'
A 4 2'Maintain the Number of Used Produc-
A ts'
A 5 3'For the Date :'
A C02MTH 8Y 0O 5 20EDTCDE(4)
A 6 2'Type options, press Enter'
A 7 2'2=Change '
A 9 2'Act Product -
A Quantity Area '
A DSPATR(UL)
A*==============================================================*
A R R02
A*%%TS SD 20100512 134524
A 24 2'F3=Exit F6=Add F12=Cancel'
A*
A R R03
A*%%TS SD 20101013 134924
A CF06(06 'UPDATE')
A 88 CSRLOC(ROW03 COL03)
A 89 R03MSG 79 M
A ROW03 3S 0H
A COL03 3S 0H
A R03KEY 15A H
A R03CT 2A H
A*
A 1 2'USEDPRODFM.03'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 28'USED PRODUCT REPORTING'
A 1 60TIME
A 1 70DATE
A EDTCDE(Y)
A 2 28'Used Product Entry'
A 5 3'For the Date . .:'
A R03MTH 8Y 0O 5 22EDTCDE(4)
A 5 32'(YYYYMMDD)'
A 6 3'PRODUCT Set .:'
A R03PRD 30A O 6 22
A 8 3'Quantity . . . .:'
A R03QTY 6S 0B 8 22
A 9 3'Suburb . . . . .:'
A R03CT2 2A B 9 22
A 24 2'F3=Exit F6=Accept F12=Cancel'
A R R04
A*%%TS SD 20101013 155830
A CF04(04 'lookup')
A CF06(06 'UPDATE')
A 88 CSRLOC(ROW04 COL04)
A 89 R04MSG 79 M
A ROW04 3S 0H
A COL04 3S 0H
A R04CT 2A H
A*
A 1 2'USEDPRODFM.04'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 28'USED PRODUCT REPORTING'
A 1 60TIME
A 1 70DATE
A EDTCDE(Y)
A 2 28'Used Product Entry'
A 5 3'For the Date . .:'
A R04MTH 8Y 0O 5 22EDTCDE(4)
A 5 32'(YYYYMMDD)'
A 6 3'PRODUCT Set .:'
A R04KEY 15 B 6 22
A R04PRD 30A O 6 42
A 8 3'Quantity . . . .:'
A R04QTY 6S 0B 8 22
A 9 3'Suburb . . . . .:'
A R04CT2 2A B 9 22VALUES(' ' 'HK')
A 24 2'F3=Exit F4=Lookup -
A F6=Accept F12=Cancel'
A**************
A R S05 SFL
A*%%TS SD 20101013 134924
A S05MTH 10A O 8 2
A S05KEY 15 O 8 13
A S05PRD 30A O 8 29
A S05CT2 2 O 8 60
A S05QTY 6Y 0O 8 63EDTCDE(Z)
A*
A*==============================================================*
A R C05 SFLCTL(S05)
A*%%TS SD 20101014 102330
A SFLSIZ(0014)
A SFLPAG(0014)
A TEXT('Used Product Entry')
A OVERLAY
A 51 SFLDSP
A 52 SFLDSPCTL
A ROLLUP(61)
A ROLLDOWN(62)
A 53 SFLCLR
A 99 SFLEND(*MORE)
A 89 C05MSG 79 M
A SRS05 4S 0H SFLRCDNBR
A*
A 1 2'USEDPRODFM.05'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 28'USED PRODUCT REPORTING'
A 1 60TIME
A 1 70DATE
A EDTCDE(Y)
A 2 28'Used Product '
A 4 2'View the Used Products '
A C05MTH 10 B 6 2
A 7 14'Product -
A Suburb Quantity'
A*==============================================================*
A R R05
A*%%TS SD 20100512 134524
A 24 2'F3=Exit F12=Cancel'
A R S06 SFL
A*%%TS SD 20101013 171041
A S06OPT 2A B 10 2
A S06KEY 15A O 10 6
A S06PRD 30A O 10 23
A*==============================================================*
A R C06 SFLCTL(S06)
A CF06(06 'Create')
A*%%TS SD 20101013 134924
A SFLSIZ(0015)
A SFLPAG(0014)
A TEXT('Used Product Entry')
A OVERLAY
A 51 SFLDSP
A 52 SFLDSPCTL
A 53 SFLCLR
A 99 SFLEND
A 89 C06MSG 79 M
A SRS06 4S 0H SFLRCDNBR
A 1 2'USEDPRODFM.06'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 28'USED PRODUCT REPORTING'
A 1 60TIME
A 1 70DATE
A EDTCDE(Y)
A 2 28'Used Product Entry'
A 4 2'Maintain PRODUCTS '
A 6 2'Type options, press Enter'
A 7 2'4=Delete'
A 9 2'Act Product '
A DSPATR(UL)
A R R06
A*%%TS SD 20101013 134924
A 24 2'F3=Exit F6=Create F12=Cancel'
A R R07
A*%%TS SD 20101013 173309
A CF06(06 'UPDATE')
A 88 CSRLOC(ROW07 COL07)
A 89 R07MSG 79 M
A ROW07 3S 0H
A COL07 3S 0H
A*
A 1 2'USEDPRODFM.07'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 28'USED PRODUCT REPORTING'
A 1 60TIME
A 1 70DATE
A EDTCDE(Y)
A 2 28'Used Product Entry'
A 5 3'Product Code .:'
A R07KEY 15A B 5 25
A 6 3'Description .:'
A R07PRD 30A B 6 25
A 24 2'F3=Exit F6=Accept F1-
A 2=Cancel'
A R S08 SFL
A*%%TS SD 20101013 172031
A S08OPT 2A B 7 4
A S08KEY 15A O 7 8
A S08PRD 30A O 7 25
A*==============================================================*
A R C08 SFLCTL(S08)
A*%%TS SD 20101013 172031
A WINDOW(7 8 14 60)
A WDWBORDER((*COLOR TRQ) +
A (*DSPATR RI))
A WDWTITLE((*TEXT ' PRDUCT+
A S ') +
A (*COLOR BLU))
A SFLSIZ(0015)
A SFLPAG(0007)
A TEXT('Used Product Entry')
A OVERLAY
A 51 SFLDSP
A 52 SFLDSPCTL
A 53 SFLCLR
A 99 SFLEND
A 89 C08MSG 79 M
A SRS08 4S 0H SFLRCDNBR
A*
A 1 2'USEDPRODFM.08'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 17'USED PRODUCT REPORTING'
A 1 38DATE
A EDTCDE(Y)
A 2 17'Used Product '
A 2 38TIME
A 3 4'Select the Product'
A 4 5'1=Select'
A C08KEY 15A B 5 8
A 6 8' Product '
A R S09 SFL
A*%%TS SD
A S09KEY 15A O 8 4
A S09PRD 30A O 8 20
A*
A*==============================================================*
A R C09 SFLCTL(S09)
A*%%TS SD
A SFLSIZ(0015)
A SFLPAG(0014)
A TEXT('Used Product Entry')
A OVERLAY
A 51 SFLDSP
A 52 SFLDSPCTL
A 53 SFLCLR
A 99 SFLEND
A 89 C09MSG 79 M
A SRS09 4S 0H SFLRCDNBR
A*
A 1 2'USEDPRODFM.09'
A CMPNO 3Y 0O 1 13EDTCDE(Z)
A 1 28'USED PRODUCT REPORTING'
A 1 60TIME
A 1 70DATE
A EDTCDE(Y)
A 2 28'Used Product '
A 7 6'Product '
A 4 3'Used Product selected for delet-
A ion.'
A 5 3'Press ENTER to DELETE or F12 to ca-
A ncel deletion.'
A*==============================================================*
A R R09
A*%%TS SD 20100512 134524
A 24 2'F3=Exit F12=Cancel'
gettok not strtok()
ref: [[22]]
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.
External links
The official WDSC web page [23]
The WDSC Developer blog [24]
WDSC tags on del.ici.ous [25]
