|
|
(19 intermediate revisions by 2 users not shown) |
Line 87: |
Line 87: |
| [[#top]] | | [[#top]] |
| | | |
− | ===Examples===
| |
− | Subprocedure skeleton:
| |
− |
| |
− | [[Image:Lpex_snippet_rpg_subprocedure.JPG]]
| |
− |
| |
− |
| |
− | ====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 [http://wiki.midrange.com/index.php/SQLRPGLE]
| |
− | C/EXEC SQL
| |
− | C+ SELECT * FROM mylib/myfile
| |
− | C/END-EXEC
| |
− | free
| |
− | exec sql select * from mylib/myfile;
| |
− |
| |
− |
| |
− | ==== Open Cursor and Fetch Mainline ====
| |
− | ref [http://wiki.midrange.com/index.php/SQLRPGLE]
| |
− | 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 [http://wiki.midrange.com/index.php/SQLRPGLE]
| |
− | 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 [http://wiki.midrange.com/index.php/SQLRPGLE]
| |
− | 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 [http://wiki.midrange.com/index.php/SQLRPGLE]
| |
− | 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
| |
− |
| |
− |
| |
− | [[#top]]
| |
| | | |
| ===Exporting and importing snippets=== | | ===Exporting and importing snippets=== |
Line 280: |
Line 145: |
| [[#top]] | | [[#top]] |
| | | |
− | === DayOfWeek snippet===
| |
− | ref [[http://archive.midrange.com/rpg400-l/200105/msg00507.html]]
| |
| | | |
| + | ===Examples=== |
| + | [[Snippets/Examples]] |
| | | |
− | * // Procedure: DayOfWeek //
| |
− | * // Purpose: Determine the day of week for a particular date //
| |
− | * // Parameters: //
| |
− | * // I: dt -- date //
| |
− | *
| |
− | * // Returns: //
| |
− | * // 0..6 -- 0=Sunday, 1=Monday, 2=Tuesday, etc. //
| |
− | * // Notes: //
| |
− | * // January 5, 1800 is a Sunday. This procedure only works for //
| |
− | * // dates later than 1800-01-05. //
| |
− | * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
| |
− | P DayOfWeek b
| |
− | P
| |
− | D DayOfWeek pi 10i 0
| |
− | D
| |
− | D dt d value datfmt(*iso)
| |
− | /free
| |
− | return %rem (%diff (dt: d'1800-01-05': *days): 7);
| |
− | /end-free
| |
− | P DayOfWeek e
| |
− |
| |
| [[#top]] | | [[#top]] |
− |
| |
− | === FirstFriday snippet===
| |
− |
| |
− |
| |
− | H DFTACTGRP(*NO ) OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
| |
− |
| |
− |
| |
− | D WDATE S 10A
| |
− |
| |
− |
| |
− | D FirstFriday PR 1A
| |
− | D Wdate 10A
| |
− |
| |
− |
| |
− | /FREE
| |
− | *INLR = *on;
| |
− | WDATE = '2008-12-05';
| |
− | *IN01 = FirstFriday(WDATE);
| |
− | /END-FREE
| |
− |
| |
− | * // Procedure: FirstFriday //
| |
− | * // Purpose: Determine if the date is the First Friday //
| |
− | * // Parameters: //
| |
− | * // I: WDATE -- 10 character ISO delim date //
| |
− | *
| |
− | * // Returns: //
| |
− | * // 0..1 -- 0=NO, 1=YES //
| |
− | * // Notes: //
| |
− | * // January 5, 1800 is a Sunday. This procedure only works for //
| |
− | * // dates later than 1800-01-05. //
| |
− | * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
| |
− | P FirstFriday B
| |
− | P
| |
− | D FirstFriday PI 1A
| |
− | D WDATE 10A
| |
− |
| |
− | /free
| |
− |
| |
− | if %rem(%abs(%diff (%DATE(WDATE) : d'1800-01-05': *days)): 7) = 5
| |
− | and %subdt(%DATE(WDATE) :*D) <=7;
| |
− | // it is the first Friday of the month
| |
− | RETURN '1';
| |
− | endif;
| |
− | RETURN '0';
| |
− |
| |
− | /end-free
| |
− | P FirstFriday E
| |
| | | |
| | | |
| + | ===CodeGrabs=== |
| + | [[Snippets/CodeGrabs]] |
| | | |
| [[#top]] | | [[#top]] |
− | === System Date snippet===
| |
| | | |
− | ref [[http://archive.midrange.com/rpg400-l/200604/msg00457.html]]
| + | ===Templates=== |
| + | [[Snippets/Templates]] |
| | | |
− | Time also works Return %INT(%CHAR(%TIME():*ISO0)) set PI to 6S 0.
| |
− |
| |
− | * // Procedure: SysDate //
| |
− | * // Purpose: Gets the system date YYYYMMDD format 8S 0 //
| |
− | * // Parameters: //
| |
− | * // Returns: //
| |
− | * // int -- date in YYYYMMDD fmt //
| |
− | * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
| |
− | P SysDate B
| |
− | P
| |
− | D SysDate PI 8S 0
| |
− | D
| |
− | /free
| |
− | Return %INT(%CHAR(%DATE():*ISO0));
| |
− | /end-free
| |
− | P SysDate E
| |
| [[#top]] | | [[#top]] |
| | | |
− | === CLLE Subroutine=== | + | ===UDDS File Displayer=== |
− | | + | [[UDDS File Displayer]] |
− | ref [[http://archive.midrange.com/midrange-l/200605/msg01206.html]]
| |
− | | |
− | Sample code V5R4
| |
− | | |
− | START: PGM
| |
− | SAVLIB LIB( PVCPROD) DEV(TAP01) ENDOPT(*LEAVE) /* Daily library backup */
| |
− | MONMSG MSGID(PVC0001) EXEC(DO)
| |
− | CALLSUBR BADLIBSAVE
| |
− | ENDDO
| |
− | RETURN
| |
− | SUBR BADLIBSAVE
| |
− | /* test */
| |
− | ENDSUBR
| |
− | ENDPGM
| |
| | | |
| [[#top]] | | [[#top]] |
| | | |
− | === RPG SYSTEM NAME=== | + | ===UDDS File Display/Update=== |
− | | + | [[UDDS File Display/Update]] |
− | ref: [[http://archive.midrange.com/rpg400-l/200506/msg00326.html]]
| |
− | | |
− | | |
− | D RtvSysName PR 8A
| |
− | D MyName S 10A
| |
− | C eval *inlr = *on
| |
− | C EVAL MyName = RtvSysName()
| |
− | *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
| |
− | * Retrieve System Name
| |
− | P RtvSysName B Export
| |
− | D RtvSysName PI 8A
| |
− | D QWCRNETA PR ExtPgm('QWCRNETA')
| |
− | D RcvVar 32766A OPTIONS(*VARSIZE)
| |
− | D RcvVarLen 10I 0 const
| |
− | D NbrNetAtr 10I 0 const
| |
− | D AttrNames 10A const
| |
− | D ErrorCode 256A
| |
− | D* Error code structure
| |
− | D EC DS 256
| |
− | D* Receiver variable for QWCRNETA
| |
− | D DS ds
| |
− | D Filler 32A
| |
− | D RtnSystem 8A
| |
− | * Call API to get system name
| |
− | C callp QWCRNETA(DS: %size(DS): 1: 'SYSNAME': EC)
| |
− | C return RtnSystem
| |
− | P E
| |
− | | |
− | [[#top]]
| |
− | | |
− | | |
− | === MODS w/POINTERS===
| |
− | | |
− | ref: [[http://archive.midrange.com/rpg400-l/200812/msg00473.html]]
| |
− | | |
− | DEdtCstRtn PR ExtPgm('@EDTCSTRTN')
| |
− | D SubParm Like(MyStruct)
| |
− | D SubParm1 Like(Struct1)
| |
− |
| |
− | Dmystruct e ds ExtName(EDTCSTPF)
| |
− | D occurs(500)
| |
− | DStruct1 e ds ExtName(EDTCSTHDR)
| |
− | | |
− | I fill the structure and then call the second program
| |
− | | |
− | %occur(myStruct) = 1;
| |
− | Callp EdtCstRtn(MyStruct:Struct1);
| |
− | | |
− | Here is the code from the Called program:
| |
− | | |
− | DCstRtnParm PR ExtPgm('@EDTCSTRTN')
| |
− | DPlistPR Like(PlistParm)
| |
− | DPlist1PR Like(Plist1)
| |
− | DCstRtnParm PI
| |
− | DPlistPI Like(PlistParm)
| |
− | DPlist1PI Like(Plist1)
| |
− |
| |
− | DPlistParm e ds ExtName(EDTCSTPF)
| |
− | D occurs(500)
| |
− | D based(p_PlistParm)
| |
− | DPlist1 e ds ExtName(EDTCSTHDR)
| |
− | D based(p_Plist1)
| |
− |
| |
− | /free
| |
− | p_PlistParm = %addr(PlistPI);
| |
− | p_Plist1 = %addr(Plist1PI);
| |
− | | |
− | ... do NOT EVAL one to the other...
| |
− | ... simply access PlistParm as a normal MODS.
| |
− | | |
− | [[#top]]
| |
− | | |
− | | |
− | === QUSRSPLA CL with STG(*DEFINED) DEFVAR===
| |
− | | |
− | | |
− | ref: [[http://archive.midrange.com/rpg400-l/200902/msg00380.html]]
| |
− | | |
− | [[http://publib.boulder.ibm.com/iseries/v5r1/ic2924/index.htm?info/apis/QUSRSPLA.htm | See IBM defn of the SPLA0100 format for whatever attribute you need.]]
| |
− | | |
− | /* GET A SPOOL FILE ATTRIBUTE */
| |
− | PGM PARM(&SPLF &FULLJOB &RTNWID )
| |
− |
| |
− | DCL &SPLF *CHAR LEN(10)
| |
− | DCL &FULLJOB *CHAR LEN(26)
| |
− |
| |
− | DCL &SPLNBR *CHAR LEN(5)
| |
− | DCL &SPLNBRD *DEC LEN(9 0)
| |
− | DCL &SPLNBRB *CHAR LEN(4)
| |
− |
| |
− | DCL &DSLEND *DEC LEN(9 0)
| |
− | DCL &DSLENB *CHAR LEN(4)
| |
− |
| |
− | DCL &INTJOB *CHAR LEN(16)
| |
− | DCL &INTSPLF *CHAR LEN(16)
| |
− | DCL &RTNWID *DEC (15 5)
| |
− |
| |
− | DCL &DS *CHAR LEN(1000)
| |
− | DCL &RTNWIDTH *DEC (15 5) STG(*DEFINED) DEFVAR(&DS 889)
| |
− |
| |
− | /* GET LAST SPOOL FILE */
| |
− | CHGVAR &SPLNBRD -1
| |
− | CHGVAR %BIN(&SPLNBRB 1 4) &SPLNBRD
| |
− | /* USE 1000 BYTE DS */
| |
− | CHGVAR &DSLEND 1000
| |
− | CHGVAR %BIN(&DSLENB 1 4) &DSLEND
| |
− |
| |
− | /* CALL API TO GET SPLFA */
| |
− | /* OFFSET 888 CONTAINS THE WIDTH AS PACKED DECIMAL 15,5 */
| |
− | CALL QUSRSPLA PARM(&DS &DSLENB 'SPLA0100' +
| |
− | &FULLJOB &INTJOB &INTSPLF &SPLF &SPLNBRB)
| |
− | MONMSG CPF0000
| |
− |
| |
− | RTNWID: CHGVAR &RTNWID &RTNWIDTH
| |
− |
| |
− | RETURN
| |
− | ENDPGM
| |
| | | |
| [[#top]] | | [[#top]] |
| | | |
| | | |
− | === RPG WAIT sim DLYJOB === | + | ===RGP API QDFRTVFD === |
− | ref: [[http://archive.midrange.com/rpg400-l/200501/msg00399.html]]
| + | [[rQDFRTVFD]] |
| | | |
− | HBNDDIR('QC2LE') DFTACTGRP(*NO) ACTGRP(*NEW)
| |
− | * this uses the C sleep API
| |
− | * this is a sample program named 'PSLEEP' to demo the call to the sleep API
| |
− | * to test, call PSLEEP '0000000005'
| |
− | *
| |
− | D PSLEEP PR
| |
− | D SECSA 10A
| |
− | D PSLEEP PI
| |
− | D SECSA 10A
| |
− | *
| |
− | D WAIT PR 1A
| |
− | D SECS 10U 0
| |
− |
| |
− | D CURTIME S T
| |
− | D SECS S 10U 0
| |
− | D ANS S 20A
| |
− |
| |
− | D SECSDS DS 10
| |
− | D SECSN 10S 0
| |
− |
| |
− | /FREE
| |
− | *INLR = *ON;
| |
− |
| |
− | SECSDS = SECSA;
| |
− | SECS = SECSN;
| |
− |
| |
− | CURTIME = %TIME();
| |
− | DSPLY CURTIME;
| |
− |
| |
− | WAIT(SECS);
| |
− |
| |
− | CURTIME = %TIME();
| |
− | DSPLY CURTIME ' ' ANS;
| |
− | /END-FREE
| |
− |
| |
− | * // Procedure: Sleep //
| |
− | * // Purpose: Wait for a number of seconds //
| |
− | * // Parameters: //
| |
− | * // I: WSECS -- 10 int //
| |
− | *
| |
− | * // Returns: //
| |
− | * // 0..1 -- 0=NOT OK, 1=OK //
| |
− | * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
| |
− | P WAIT B
| |
− | P
| |
− | D WAIT PI 1A
| |
− | D WSECS 10U 0
| |
− |
| |
− | DSLEEP PR 1A EXTPROC(X'A293858597')
| |
− | D SECS 10U 0 VALUE
| |
− |
| |
− | /FREE
| |
− | RETURN SLEEP(WSECS);
| |
− | /END-FREE
| |
− | P WAIT E
| |
| [[#top]] | | [[#top]] |
| | | |
− | === GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC === | + | ===C API QDFRTVFD === |
− | ref: [[http://archive.midrange.com/rpg400-l/200602/msg00655.html]][[http://archive.midrange.com/rpg400-l/200601/msg01038.html]]
| + | [[cQDFRTVFD]] |
− | | |
− | | |
− | 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.
| |
− | | |
− | <pre>
| |
− | 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
| |
− | </pre>
| |
| | | |
| [[#top]] | | [[#top]] |
| | | |
− | === Format the date like "Wed, 12 Dec 2001 13:21:01 === | + | ===C version of DISPR === |
− | | + | [[C version of DISPR ]] |
− | ref [[http://archive.midrange.com/midrange-l/200112/msg01289.html]]
| |
− | | |
− | RFC2822 requires a date in the format "Wed, 12 Dec 2001 13:21:01 -0500".
| |
− | | |
− | ILE procedure that makes use of SQL
| |
− | | |
− | | |
− | h option(*nodebugio:*srcstmt) dftactgrp(*no) actgrp('QILE')
| |
− |
| |
− | d getWordyDate pr like(WordyDate)
| |
− |
| |
− | d WordyDate s 31
| |
− | d reply s 1
| |
− |
| |
− | c eval WordyDate = getWordyDate()
| |
− | c WordyDate dsply reply
| |
− | c eval *inlr = *on
| |
− |
| |
− | p getWordyDate b
| |
− | d getWordyDate pi like(WordyDate)
| |
− |
| |
− | d tz s 6 0
| |
− | d t s t
| |
− | d d s d
| |
− | d dn s 9
| |
− | d mn s 9
| |
− | d rtn ds
| |
− | d ShortDayName 3
| |
− | d 2 inz(', ')
| |
− | d DayNumeric 2 0
| |
− | d 1 inz(' ')
| |
− | d ShortMonthName 3
| |
− | d 1 inz(' ')
| |
− | d YearNumeric 4 0
| |
− | d 1 inz(' ')
| |
− | d TimeOut t timfmt(*hms)
| |
− | d 1 inz(' ')
| |
− | d TimeZone 5
| |
− |
| |
− | c/exec sql
| |
− | c+ set (:tz,:TimeOut,:d,:dn,:mn) = (current_timezone,
| |
− | c+ current_time, current_date, substr(dayname(current_date),1,9),
| |
− | c+ substr(monthname(current_date),1,9))
| |
− | c/end-exec
| |
− |
| |
− | c eval DayNumeric = %subdt(d:*d)
| |
− | c eval YearNumeric = %subdt(d:*y)
| |
− | c eval ShortDayName = dn
| |
− | c eval ShortMonthName = mn
| |
− | c eval TimeZone =
| |
− | c %trim(%editw(%dec(tz/100:4:0):'0- '))
| |
− |
| |
− | c return rtn
| |
− | p getWordyDate e
| |
− | | |
− | | |
− | USING the CEE APIs
| |
− | | |
− | ** Get local time API
| |
− | d CEELOCT PR opdesc
| |
− | d output_lil Like(discard1)
| |
− | d output_secs Like(cur_time)
| |
− | d output_greg Like(discard2)
| |
− | d output_fc Like(Fc) Options(*Nopass)
| |
− | ** Convert to arbitrary timestamp API
| |
− | d CEEDATM PR opdesc
| |
− | d input_secs Like(cur_time)
| |
− | d picture_str Like(Pictureds) const
| |
− | d output_ts Like(Pictureds)
| |
− | d output_fc Like(Fc) Options(*Nopass)
| |
− | * Get offset from UTC API
| |
− | d CEEUTCO PR
| |
− | d hours Like(hrs2utc)
| |
− | d minutes Like(mins2utc)
| |
− | d seconds Like(cur_time)
| |
− | d output_fc Like(Fc) Options(*Nopass)
| |
− |
| |
− | d discard1 S 10I 0
| |
− | d cur_time S 8F
| |
− | d discard2 S 23A
| |
− | d hrs2utc s 10I 0
| |
− | d mins2utc s Like(hrs2utc)
| |
− | d hh s 2A
| |
− | d mm s 2A
| |
− | d discard3 s Like(cur_time)
| |
− | d WDate s Like(Pictureds)
| |
− |
| |
− | d Fc ds
| |
− | d sev 5U 0
| |
− | d msgno 5U 0
| |
− | d flags 1A
| |
− | d facid 3A
| |
− | d isi 10U 0
| |
− | d Pictureds ds
| |
− | d Piclen1 1 2I 0
| |
− | d Picture 3 34A
| |
− | d Piclen2 1 4I 0
| |
− | d Picture2 5 36A
| |
− |
| |
− | * Get current local time from clock:
| |
− | c Callp CEELOCT(discard1 : cur_time : discard2)
| |
− | * Convert to e-mail format:
| |
− | c Callp CEEDATM(cur_time :
| |
− | c 'Www, DD Mmm YYYY HH:MI:SS' :
| |
− | c WDate)
| |
− | * Retrieve offset from UTC
| |
− | c Callp CEEUTCO(hrs2utc : mins2utc : discard3)
| |
− | * Format the UTC offset nicely
| |
− | * and tack it onto the string...
| |
− | c If hrs2utc < *Zero
| |
− | c Eval WDate = %trimr(WDate) + ' -'
| |
− | c Eval hrs2utc = 0 - hrs2utc
| |
− | c Else
| |
− | c Eval WDate = %trimr(WDate) + ' +'
| |
− | c EndIf
| |
− | c Move hrs2utc hh
| |
− | c Move mins2utc mm
| |
− | c Eval WDate = %TrimR(WDate) + hh + mm
| |
− | | |
− | | |
− | [[#top]] | |
− | | |
− | === RPG FTP TEMPLATE ===
| |
− | <pre>
| |
− | 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
| |
− | </pre>
| |
− | | |
− | [[#top]]
| |
− | | |
− | | |
− | === RPG IFS READ TEMPLATE ===
| |
− | <pre>
| |
− | 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
| |
− | | |
− | | |
− | </pre>
| |
− | | |
− | [[#top]]
| |
− | | |
− | | |
− | | |
− | === RPG SUBFILE TEMPLATE ===
| |
− | <pre>
| |
− |
| |
− | | |
− | 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.
| |
− | | |
− | | |
− | </pre>
| |
− | | |
− | | |
| | | |
| [[#top]] | | [[#top]] |
− |
| |
− | ==External links==
| |
− | The official WDSC web page [http://www-306.ibm.com/software/awdtools/wdt400/]
| |
− |
| |
− | The WDSC Developer blog [http://wdsc.wordpress.com/]
| |
− |
| |
− | WDSC tags on del.ici.ous [http://del.icio.us/tag/wdsc]
| |
| | | |
| ==Categories== | | ==Categories== |
| [[Category:WDSC]] | | [[Category:WDSC]] |