and the end * tag into any member name (your choice) * in file QRPGLESRC member type RPGLE. CRTBNDRPG to compile. * Example copy command (if you named the member A in step 1) * CPYF FROMFILE(mylib/JCRCMDS) TOFILE(mylib/JCRCMDS) FROMMBR(a) + * TOMBR(parser) MBROPT(*REPLACE) FROMRCD(393) TORCD(724) * * 3. Call the install program (or execute XMLPREVIEW) passing 3 Parms. * 'your-member-name you uploaded this text into' * 'your-source-file-name the member is in' * 'your-library-name the source file is in' * * The various source members will be extracted and the objects required * for the application will be created in your-library-name. * * Members in this install: (to view or manually extract members, scan ''; srcSeqno += 1; // if /copy AND user has selected custom install file, // change statements to find copybooks in new file. 4b if %Parms = 4; UpSlash = %xlate(lo: up: SlashCopy); 5b if UpSlash = '/COPY' or UpSlash = '/INCL'; exsr srRedirectCopy; 5e endif; 4e endif; except write_one; 3x else; IsWrite = *off; close qxxxsrc; 3e endif; // Extract values based on XML tags. 2x elseif xmltag1 = 'mbrname ='; mbrname = %subst(xmlcode: 13: 10); 2x elseif xmltag1 = 'mbrtype ='; mbrtype = %subst(xmlcode: 13: 10); 2x elseif xmltag1 = 'mbrtext ='; mbrtext = %subst(xmlcode: 13: 50); 2x elseif xmltag1 = 'srcfile ='; 3b if %Parms = 4; //xmlpreview override srcfile = OvrSrcFile; 3x else; srcfile = %subst(xmlcode: 13: 10); 3e endif; 2x elseif xmltag1 = 'srclen ='; 3b if %Parms = 4; //xmlpreview override srclen='00112'; 3x else; srclen = %subst(xmlcode: 13: 5); 3e endif; 2x elseif xmltag1 = 'srccssid='; srccssid = %subst(xmlcode: 13: 5); // Start of data to copy. Create source files/mbrs as required. 2x elseif xmltag1 = ''; bldexc = 'CRTSRCPF FILE(' + %trimr(ParseSrcLib) + '/'+ %trimr(srcfile) + ') RCDLEN(' + srclen + ') CCSID(' + srccssid + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'ADDPFM FILE(' + %trimr(ParseSrcLib) + '/'+ %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ') SRCTYPE(' + %trimr(mbrtype) + ') TEXT(' + qs + %trimr(mbrtext) + qs + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); 3b if %error; bldexc = 'CHGPFM FILE(' + %trimr(ParseSrcLib) + '/'+ %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ') TEXT(' + qs + %trimr(mbrtext) + qs + ')'; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'CLRPFM FILE(' + %trimr(ParseSrcLib) + '/'+ %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ')'; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); 3e endif; // override to outfile mbr extOfile = %trimr(ParseSrcLib) +'/' + srcfile; clear srcSeqno; open qxxxsrc; IsWrite = *on; //--------------------------------------------------------- // Compile statement. Read next record and execute it. // The subroutine srTolibToken will replace &tolib with the // library the user has selected at run time. //--------------------------------------------------------- 2x elseif xmltag1 = ''; read xmlinput; bldexc = %trimr(xmlcode); exsr srTolibToken; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); //--------------------------------------------------------- // qcmdexc statement. Build statement from each record between start // and stop tags. When stop tag is found, execute statement. // if dltxxx command, allow errors to be ignored. //--------------------------------------------------------- 2x elseif xmltag1 = ''; clear bldexc; aa = 1; read xmlinput; 3b dow xmltag2 <> ''; %subst(bldexc: aa: 100) = xmlcode; aa += 100; read xmlinput; 3e enddo; exsr srTolibToken; 3b if %subst(bldexc: 1: 3) = 'DLT'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); 3x else; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); 3e endif; //--------------------------------------------------------- // Send messages to user as program executes // Extract message ID, Message Type, from // read a record and get the single line of message text. //--------------------------------------------------------- 2x elseif xmltag1 = ' 0; bldexc = %replace(%trimr(ParseSrcLib): bldexc: aa: 6); aa = %scan('&tolib': bldexc); 1e enddo; // user has selected to override source, reset SRCFILE parm in bldexcs. 1b if %Parms = 4; //xmlpreview override aa = %scan('SRCFILE(': bldexc); 2b if aa > 0; aa = %scan('/': bldexc: aa); 3b if aa > 0; ll = %scan(')': bldexc: aa); bldexc = %replace(%trimr(OvrSrcFile): bldexc: aa + 1: ll-(aa + 1)); 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Check of file, lib, member exist. begsr srValidate; callp Qusrmbrd(ReceiverVar: 145:'MBRD0100': ParseSrcFile + ParseSrcLib: ParseSrcMbr: '0': ApiErrDS); //--------------------------------------------------------- // If error occurred on call, send appropriate message back to user. 1b if ApiErrDS.BytesReturned > 0; //error occurred 2b if ApiErrDS.ErrMsgId = 'CPF9810'; //lib not found Qm_msgtxt = '0000 Library ' + %trimr(ParseSrcLib) + ' was not found.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9812'; //src file not found Qm_msgtxt = '0000 Source file ' + %trimr(ParseSrcFile) + ' was not found in ' + %trimr(ParseSrcLib) + '.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9815'; //member not found Qm_msgtxt = '0000 Member ' + %trimr(ParseSrcMbr) + ' was not found in ' + %trimr(ParseSrcLib) + '/'+ %trimr(ParseSrcFile); 2x else; Qm_msgtxt = '0000 Unexpected message ' + ApiErrDS.ErrMsgId + ' received. '; 2e endif; // send message Qm_msgid = 'CPD0006'; Qm_msgtyp = '*DIAG'; Qm_msgq = '*CTLBDY'; exsr srSndMessage; Qm_msgtxt = *blanks; Qm_msgid = 'CPF0002'; Qm_msgtyp = '*ESCAPE'; exsr srSndMessage; *inlr = *on; return; 1e endif; endsr; //--------------------------------------------------------- begsr srSndMessage; callp QMHSNDPM( Qm_msgid: 'QCPFMSG *LIBL ': Qm_msgtxt: %size(Qm_msgtxt): Qm_msgtyp: Qm_msgq: 1: ' ': ApiErrDS); endsr; //--------------------------------------------------------- begsr srRedirectCopy; Start = 12; 1b if UpSlash = '/INCL'; Start = 15; 1e endif; aa = %scan(',': xmlcode: Start); //find start of member 1b if aa = 0; aa = %check(' ': xmlcode: Start) - 1; 1e endif; xmlcode = %subst(xmlcode: 1: Start) + %trimr(ParseSrcLib) + '/'+ %trimr(OvrSrcFile) + ',' + %subst(xmlcode: (aa + 1)); endsr; /end-free Oqxxxsrc e write_one O srcSeqno 6 O 12 '000000' O xmlcode 112 * /// END OF INSTALL PGM HERE /// do not copy past this point ********** /// ]]> //--------------------------------------------------------- // JCRAMORT - Amortization schedule print/display. // Craig Rutledge 1984 // // Formula found in OLD RPGII text book to calculate payments. // Added option to allow you to pick desired payments to see how much you can borrow. //--------------------------------------------------------- // Note: There is some interesting cursor stuff in here as I was trying to come up with a // neat way to get around no position cursor hex value (PC) with a field-name attribute. The // easiest way would have been to hard code the row/column of various fields, but that would // not have been flexible if the display file was recompiled. Use the list fields API to // retrieve row/columns, then use CURFLD to look up row/column of that field. Slick. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRAMORTD cf e workstn sfile(data: rrn) infds(infds) F indds(Ind) FJCRAMORTP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D xx s 5i 0 inz D bott s 15p 9 inz D first s 15p 9 inz D ii s 9p 9 inz D in s 15p 9 inz D left s 3p 2 inz D mid s 15p 9 inz D PrincipleSave s 9p 2 inz(0) D MaxPaySave s 9p 2 inz(0) D top s 15p 9 inz D ForCounter s 5u 0 inz D rrn s 5u 0 inz D ToRrn s 5u 0 inz D IsOverFlow s n inz(*off) D UserSpaceName s 20a inz('JCRCMDS QTEMP ') //--*COPY DEFINES------------------------------------------ /Define Sds /Define Ind /Define Infds /Define Dspatr /Define FunctionKeys /Define f_OvrPrtf /Define f_DltOvr /Define f_RmvSflMsg /Define f_SndSflMsg /Define f_GetRowColumn /Define f_GetLastSplfInfo /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- /free f_RmvSflMsg(ProgId); aBegPrif = %bitor(Green:UL); aInRatef = %bitor(Green:UL); aDurationf = %bitor(Green:UL); aPaymentf = %bitor(Green:UL); aMaxLoanf = ND; aMaxLoanh = ND; 1b dow not (InfdsFkey = f03); sBegPrinci = PrincipleSave; sPayment = MaxPaySave; write msgctl; exfmt AmortOpt; 2b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; 2e endif; f_RmvSflMsg(ProgId); aBegPrif = %bitor(Green:UL); aInRatef = %bitor(Green:UL); aDurationf = %bitor(Green:UL); aPaymentf = %bitor(Green:UL); aMaxLoanf = ND; aMaxLoanh = ND; PrincipleSave = sBegPrinci; MaxPaySave = sPayment; 2b if sIntRate = 0; CsrRowColDS = f_GetRowColumn('SINTRATE':InfdsFile:InfdsLib:InfdsRcdfmt); f_SndSflMsg(ProgId: 'Please enter a valid Interest Rate.'); aInRatef = %bitor(White: RI); 1i iter; 2x elseif sDuration = 0; CsrRowColDS = f_GetRowColumn('SDURATION':InfdsFile:InfdsLib:InfdsRcdfmt); f_SndSflMsg(ProgId: 'Please enter a valid Number Of Months.'); aDurationf = %bitor(White: RI); 1i iter; 2x elseif sBegPrinci = 0 and sPayment = 0 or (sBegPrinci > 0 and sPayment > 0); CsrRowColDS = f_GetRowColumn('SBEGPRINCI':InfdsFile:InfdsLib:InfdsRcdfmt); f_SndSflMsg(ProgId: 'Please enter a Loan Amount or Max Payments.'); aBegPrif = %bitor(White: RI); aPaymentf = %bitor(White: RI); 1i iter; 2e endif; //--------------------------------------------------------- Ind.sfldsp = *off; Ind.sfldspctl = *off; write contrl; rrn = 0; //--------------------------------------------------------- // calculate the amortization schedule. //--------------------------------------------------------- pIntRate = sIntRate/100; 2b if sPayment > 0; aMaxLoanf = %bitor(White:ul); aMaxLoanh = %bitor(White:ul); exsr srGetLoanAmount; 2e endif; sLoanAmt = sBegPrinci; sMaxLoan = sBegPrinci; eval(h) ii = pIntRate/12; xx = sDuration - 1; first = 1 + ii; bott = first; 2b for ForCounter = 1 to xx; eval(h) first *= bott; 2e endfor; top = first - 1; eval(h) mid = top/first; eval(h) in = mid/ii; sPayment = sBegPrinci/in; sMonthCnt = 0; 2b for ForCounter = 1 to sDuration; eval(h) sIntresPay = sBegPrinci * ii; sMonthCnt += 1; sPrinciPay = sPayment - sIntresPay; 3b if sDuration = sMonthCnt; left = sPrinciPay - sBegPrinci; sPayment -= left; sPrinciPay = sPayment - sIntresPay; 3e endif; sNewPrinci = sBegPrinci - sPrinciPay; rrn += 1; write data; sBegPrinci = sNewPrinci; 2e endfor; //--------------------------------------------------------- // display the amortization schedule. //--------------------------------------------------------- Ind.sfldsp = *on; Ind.sfldspctl = *on; write contrl; exfmt keys; 2b if InfdsFkey = f12; 1i iter; 2x elseif InfdsFkey = f03; *inlr = *on; return; 2x elseif InfdsFkey = f06; //Print f_OvrPrtf('JCRAMORTP': *OMIT: 'JCRAMORT'); open JCRAMORTP; write Heading1; write Heading2; ToRrn = Rrn; 3b for ForCounter = 1 to ToRrn; chain ForCounter Data; 4b if IsOverFlow; write Heading1; IsOverFlow = *off; 4e endif; write detail; 3e endfor; close JCRAMORTP; f_DltOvr('JCRAMORTP '); // Send print completed message LastSplfInfoDS = f_GetLastSplfInfo(); f_SndSflMsg(ProgId: 'Splf ' + %trimr(LastSplfInfoDS.SplfName) + ' number ' + %char(LastSplfInfoDS.SplfNum) + ' generated by JCRAMORT.'); 2e endif; 1e enddo; //--------------------------------------------------------- // calculates maximum loan value based on payment. //--------------------------------------------------------- begsr srGetLoanAmount; eval(h) ii = pIntRate/12; xx = sDuration - 1; first = 1 + ii; bott = first; 1b for ForCounter = 1 to xx; eval(h) first *= bott; 1e endfor; top = first - 1; eval(h) mid = top/first; eval(h) in = mid/ii; sBegPrinci = in * sPayment; endsr; ]]> *------------------------------------------------------------------------- * JCRAMORTD - Amortization Schedule Print/Display - DSPF * Craig Rutledge *------------------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT A CA03 A CA12 A INDARA *---------------------------------------------- A R AMORTOPT A OVERLAY A CSRLOC(CSRROW CSRCOL) A CSRROW 3S 0H A CSRCOL 3S 0H A ABEGPRIF 1A P A AINRATEF 1A P A ADURATIONF 1A P A APAYMENTF 1A P A AMAXLOANH 1A P A AMAXLOANF 1A P A 1 3'JCRAMORT' A COLOR(BLU) A 1 23'Amortization Schedule' A 1 66'jcr' A COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A 3 3'Interest rate:' A DSPATR(HI) A SINTRATE 4Y 2B 3 21CHECK(FE) A CHECK(RB) A EDTCDE(4) A DSPATR(&AINRATEF) A 3 30'NOTE: Key 12.5% as 12.5' A 5 3'Number of months:' A DSPATR(HI) A SDURATION 3Y 0B 5 23EDTCDE(4) A CHECK(FE) A CHECK(RB) A DSPATR(&ADURATIONF) A 7 3'Enter Loan Amount for' A 7 31'OR' A 7 36'Enter Maximum Payment you can affo- A rd' A 8 3'Amortization Schedule.' A 8 36'to see how much you can borrow.' A 10 3'Loan amount:' A DSPATR(HI) A SBEGPRINCI 9Y 2B 10 16EDTCDE(4) A CHECK(FE) A CHECK(RB) A DSPATR(&ABEGPRIF) A 10 32'Max Payment Amount:' A DSPATR(HI) A SPAYMENT 9Y 2B 10 52EDTCDE(4) A CHECK(FE) A CHECK(RB) A DSPATR(&APAYMENTF) A 12 3'Optional for print' A 12 32'Max Loan Amount:' A DSPATR(&AMAXLOANH) A SMAXLOAN 9Y 2B 12 52EDTCDE(4) A CHECK(FE) A CHECK(RB) A DSPATR(&AMAXLOANF) A 13 3'Account #:' A SACCOUNT 5Y 0B 13 14EDTCDE(4) A CHECK(FE) A CHECK(RZ) A 14 3'Name:' A SCUSTNAME 20A B 14 9CHECK(LC) A 22 2'F3=Exit' A COLOR(BLU) *---------------------------------------------- A R DATA SFL A SMONTHCNT 5Y 0O 7 7EDTCDE(4) A SBEGPRINCI 9Y 2O 7 14EDTCDE(4) A SPAYMENT 9Y 2O 7 27EDTCDE(4) A DSPATR(UL) A SINTRESPAY 9Y 2O 7 40EDTCDE(4) A SPRINCIPAY 9Y 2O 7 53EDTCDE(4) A SNEWPRINCI 9Y 2O 7 66EDTCDE(4) *---------------------------------------------- A R CONTRL SFLCTL(DATA) A SFLSIZ(0360) A SFLPAG(0015) A 31 SFLDSP A 32 SFLDSPCTL A N31 SFLCLR A N34 SFLEND(*MORE) A 1 3'JCRAMORT' A COLOR(BLU) A 1 30'Amortization Schedule' A DSPATR(HI) A 1 66'jcr' A COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A 3 12'Loan amount:' A DSPATR(HI) A SLOANAMT 9Y 2O 3 26DSPATR(UL) A EDTCDE(4) A 3 48'Interest rate:' A DSPATR(HI) A PINTRATE 4Y 4O 3 64DSPATR(UL) A EDTCDE(4) A 5 15'Beginning' A DSPATR(HI) A 5 29'Payment' A DSPATR(HI) A 5 42'Interest' A DSPATR(HI) A 5 54'Principal' A DSPATR(HI) A 5 69'New' A DSPATR(HI) A 6 7'Month' A DSPATR(HI) A 6 15'Principal' A DSPATR(HI) A 6 29'Amounts' A DSPATR(HI) A 6 42'Payments' A DSPATR(HI) A 6 54'Payments' A DSPATR(HI) A 6 67'Principal' A DSPATR(HI) *---------------------------------------------- A R KEYS A OVERLAY A CA06 A 23 2'F3=Exit' A COLOR(BLU) A 23 13'F6=Print' A COLOR(BLU) A 23 69'F12=Cancel' A COLOR(BLU) *---------------------------------------------- A R MSGSFL SFL A SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) *---------------------------------------------- A R MSGCTL SFLCTL(MSGSFL) A SFLDSP A SFLDSPCTL A SFLINZ A N14 SFLEND A SFLSIZ(0002) A SFLPAG(0001) A PROGID SFLPGMQ(10) ]]> *---------------------------------------------------------------- * JCRAMORTP- Amortization schedule print/display - PRTF * Craig Rutledge *---------------------------------------------------------------- *--- PAGESIZE(66 132) *--- OVRFLW(60) A R HEADING1 A 2'JCRAMORT' A SKIPB(2) A 20'Amortization Schedule' A 74'jcr' A 82DATE A EDTWRD(' / / ') A 92TIME A EDTWRD(' : : ') A 104'Page' A +1PAGNBR A EDTCDE(4) A SPACEA(2) *--- A 1'ACCOUNT' A 16'CLIENT' A 31'INTEREST' A 42'LOAN' A 59'BEGINNING' A 72'PAYMENTS' A 84'INTEREST' A 96'PRINCIPAL' A 111'NEW' A SPACEA(1) *--- A 1'NUMBER' A 17'NAME' A 33'RATE' A 41'AMOUNT' A 52'MONTH' A 60'PRINCIPAL' A 73'AMOUNT' A 87'DUE' A 97'PAYMENT' A 108'PRINCIPAL' A SPACEA(2) *---------------------------------------------- A R HEADING2 A SACCOUNT 5 0 2 A SPACEB(1) A EDTCDE(Z) A SCUSTNAME 20 10 A PINTRATE 4 4 30 A EDTCDE(1) A SLOANAMT 9 2 37 A EDTCDE(1) *---------------------------------------------- A R DETAIL A SMONTHCNT 5 0 51 A EDTCDE(Z) A SBEGPRINCI 9 2 57 A EDTCDE(1) A SPAYMENT 9 2 69 A EDTCDE(1) A SINTRESPAY 9 2 81 A EDTCDE(1) A SPRINCIPAY 9 2 93 A EDTCDE(1) A SNEWPRINCI 9 2 105 A EDTCDE(1) A SPACEA(1) ]]> */ /*--------------------------------------------------------------------------*/ /* JCRANZD - Print DSPF layout with field names - CMD */ /* Craig Rutledge */ /* */ /* Execute QDFRTVFD API then extract dspf layout from receiver variable */ /* showing the DSPF field names in their actual starting positions. */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print DSPF Field Layout') PARM KWD(DSPF) TYPE(QUAL1) MIN(1) PGM(*YES) + PROMPT('DSPF Object Name:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) + CONSTANT('*FILE ') /*--------------------------------------------------------------------------*/ QUAL1: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library:') ]]> * .*-------------------------------------------------------------------* .* JCRANZDH - Print DSPF layout with field names - HELP * .* Craig Rutledge * .*-------------------------------------------------------------------* :PNLGRP. :HELP NAME='JCRANZD'. Print DSPF Field Layout (JCRANZD) - Help :P.This JCR command uses the insanely complicated QDFRTVFD Retrieve display file description API to generate a layout report with the field names printed under the data. This is a very easy way to determine which fields are what without having to dig through source or SDA. :P.If a field or constant is wrap-around (longer than the line in DSPF), it will be truncated to fit on one line. :P.Numeric fields longer than 14 will be edited with Z edit code due to restrictions of Float numbers. :P.The printout list the record formats in the sequence they appear in the source. .*-------------------------------------------------------------------- :LINES. The objects used by this command are: JCRANZD *CMD Command Prompt JCRANZD *PGM CLLE Command processing program JCRANZDR *PGM RPGLE Print fields in a print file JCRANZDH *PNLGRP Help Text JCRVALMBRV *PGM RPGLE Validity Checking :ELINES. :P.Craig Rutledge :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZD/DSPF'. DSPF Object Name - Help :XH3.DSPF Object Name (DSPF) :P.Specifies the name and library of the display file to be analyzed. :EHELP. :EPNLGRP. ]]> *---------------------------------------------------------------- * JCRANZDP - Print DSPF layout with field names - PRTF * Craig Rutledge *---------------------------------------------------------------- *--- PAGESIZE(66 132) *--- OVRFLW(60) A R HEADING A 2'JCRNEWD File:' A SKIPB(01) A P_FILE 10 25 A 45'Library:' A P_LIB 10 54 A 98'jcr' A 125DATE A EDTCDE(Y) A SPACEA(2) A R RULERPRINT A RULERS 132 1 A SPACEA(1) A R NEWLINE A RECFMTLINE 80 1 A SPACEB(1) A SPACEA(1) A R PRINTLINE1 A DISPLAYROW 132 1 A SPACEA(1) A R PRINTLINE2 A FLDNAMEROW 132 1 A SPACEA(1) ]]> //--------------------------------------------------------- // JCRANZDR - Print DSPF layout with field names // Craig Rutledge // // Bugs, Pointers to pointers to pointers, Difficult documentation. The retrieve display // file info API (QDFRTVFD) is WAY to much trouble to fool with. This program will be // impossible to follow without looking at the 97 page API documentation at the same time. It // may be impossible to follow with the documentation:-) I will admit this is the first time // I ran down 27 related pointers and offsets to get the edit codes!! // There is a bug in the API. If a character value starts in position 1, then the API // returns (row-1) with (col = Display size + 1). Beats the heck outta me. // // The receiver variable returned by this API can be larger than the largest allowed field // size of a RPG variable. Going to have to do the 'allocate memory thing and point to it' // then call again so all the data will fit. // Note: numeric fields longer than 14 digits exceed the max Float Size so I have to load // all 9's for those fields instead of showing edited. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRANZDP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D ww s 5u 0 inz D dd s 5u 0 inz D xx s 5u 0 inz D yy s 5u 0 inz D zz s 5u 0 inz D rr s 3u 0 inz D FillChar s 3000a D FieldNam s 10a D alpha2 s 2a D Row s 3u 0 inz D PrintRow s 3u 0 inz D Col s 3u 0 inz D MaxCol s 3u 0 inz D NumberDec s 3u 0 inz D NameSpace s 3u 0 inz D pConst s 132a inz D ReceiverVar s 256a inz D ReceiverVarLen s 10i 0 inz D EditMask s 256a inz D Char63 s 63a inz D CharParm s 256a D EditMaskLen s 10i 0 inz D FloatError s 10i 0 inz D ZeroSuppress s 1a D ProgramLen s 10i 0 inz D FldNameRowArry s 132a dim(6) D IsOverFlow s n inz(*off) D IsEdit s n inz(*off) //--*COPY DEFINES------------------------------------------ /Define ApiErrds /Define Tstbts /Define Cvthc /Define f_OvrPrtf /Define f_SndCompMsg /Define GetAllocSizeDS /Define f_GetLastSplfInfo /Define f_OvrPrtf /Define f_DltOvr /Define f_Qusrobjd /Define atof /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_CvtHexToInt PR 3u 0 D 1a Const D Qecedt PR extpgm('QECEDT') Apply Edit Mask D 256a Receiver D 10i 0 Mask Length D 256a To Be Edited D 10a const Type D 10i 0 const Field Length D 256a Edit Mask D 10i 0 Mask Length D 1a const 0 Balance File Db like(ApiErrDS) Error Parm // Floating Point to Packed D qxxdtop PR extproc('QXXDTOP') D i_pptr * value d i_digits 10I 0 value D i_fraction 10I 0 value D i_double 8F value //--*DATA STRUCTURES--------------------------------------- D QDFFBASEds ds based(QDFFBASEptr) Qualified D OffsetToQDFFINFO... D 5i 0 overlay(QDFFBASEds:9) D NumRecFmts 5i 0 overlay(QDFFBASEds:11) D NumScreenSizes 5i 0 overlay(QDFFBASEds:14) //--------------- D QDFFSCRAds ds based(QDFFSCRAptr) Qualified D ScreenID 1a overlay(QDFFSCRAds:1) //--------------- D QDFFINFOds ds based(QDFFINFOptr) Qualified File Header D LengthFileHeaderSection... D 10i 0 overlay(QDFFINFOds:1) D OffsetToQDFWFLEI... D 10i 0 overlay(QDFFINFOds:5) //--------------- D QDFARFTEds ds based(QDFARFTEptr) Qualified Record Format D RecordFormatName... D 10a overlay(QDFARFTEds:1) D OffsetToQDFFRINF... D 10i 0 overlay(QDFARFTEds:13) //--------------- D QDFFRINFds ds based(QDFFRINFptr) Qualified Record Header D LengthRecordHeaderSection... D 10i 0 overlay(QDFFRINFds:1) D OffsetToQDFFFITB... D 10i 0 overlay(QDFFRINFds:5) D NumFields 5i 0 overlay(QDFFRINFds:17) D OffsetToQDFFRDPD... D 5i 0 overlay(QDFFRINFds:29) //--------------- D QDFFFITBds ds based(QDFFFITBptr) Qualified Field Indexing Table D OffsetToQDFFFINF... D 10i 0 overlay(QDFFFITBds:1) D DisplayLength 5i 0 overlay(QDFFFITBds:7) //--------------- D QDFFFINFds ds based(QDFFFINFptr) Qualified Field Header D FieldAttribut 1a overlay(QDFFFINFds:3) D DateTimeBits 1a overlay(QDFFFINFds:4) D SystemUserBits 1a overlay(QDFFFINFds:5) //--------------- D QDFFFNAMds ds based(QDFFFNAMptr) Qualified Named Field Header D ProgramLen 5i 0 overlay(QDFFFNAMds:5) D NumberDec 1a overlay(QDFFFNAMds:7) D DataType 1a overlay(QDFFFNAMds:8) D NamedOffsetToQDFFFDPD... D 5i 0 overlay(QDFFFNAMds:11) //--------------- D QDFFFCONds ds based(QDFFFCONptr) Qualified Constant Header D ConstantOffsetToQDFFFDPD... D 5i 0 overlay(QDFFFCONds:3) //--------------- D QDFFRDPDds ds based(QDFFRDPDptr) Qualified Rec Level Dependent D OffsetToQDFFRCTB... D 10i 0 overlay(QDFFRDPDds:1) //--------------- D QDFFRCTBds ds based(QDFFRCTBptr) Qualified Row Column Table D QDFFRCTEds 2a overlay(QDFFRCTBds:7) dim(1000) //--------------- D QDFWFLEIds ds based(QDFWFLEIptr) Qualified Where Used File D OffsetToQDFWRCDI... D 5i 0 overlay(QDFWFLEIds:1) D OffsetToQDFFNTBL... D 10i 0 overlay(QDFWFLEIds:9) //--------------- D QDFWRCDIds ds based(QDFWRCDIptr) Qualified Where Used Rec D OffsetToQDFWFLDI... D 5i 0 overlay(QDFWRCDIds:1) D LengthOfWhereUsedSectionForThisRecord... D 10i 0 overlay(QDFWRCDIds:5) //--------------- D QDFWFLDIds ds based(QDFWFLDIptr) Qualified Where Used Field D LengthOfWhereUsedsectionForThisField... D 5i 0 overlay(QDFWFLDIds:1) D IndexOfFieldNameTable... D 10i 0 overlay(QDFWFLDIds:7) D FieldLength 5i 0 overlay(QDFWFLDIds:11) //--------------- D QDFFNTBLds ds based(QDFFNTBLptr) Qualified Field Name Table D NumberOfEntries... D 10i 0 overlay(QDFFNTBLds:1) D FieldNameArry 10a overlay(QDFFNTBLds:5) dim(1000) //--------------- D QDFFFDPDds ds based(QDFFFDPDptr) Qualified Device Field Depen D OffsetToQDFFCOSA... D 5i 0 overlay(QDFFFDPDds:5) //--------------- D QDFFCOSAds ds based(QDFFCOSAptr) Qualified Constant Keywords D NumberEntries 5i 0 overlay(QDFFCOSAds:1) //--------------- D QDFFCCOAds ds based(QDFFCCOAptr) Qualified Keyword Entries D Category 1A overlay(QDFFCCOAds:1) D OffsetToCategory... D 5i 0 overlay(QDFFCCOAds:2) //--------------- D QDFKEDTRds ds based(QDFKEDTRptr) Qualified Keyword 24 Structur D NumberOfKeys 5i 0 overlay(QDFKEDTRds:1) //--------------- D QDFKEDTPds ds based(QDFKEDTPptr) Qualified Keyword Parameters D KeyWord 1a overlay(QDFKEDTPds:1) D ZeroSuppress 1a overlay(QDFKEDTPds:2) D LenEditMask 5i 0 overlay(QDFKEDTPds:3) D EditMask 256a overlay(QDFKEDTPds:6) //--------------- D QDFKDFTds ds based(QDFKDFTptr) Qualified Keyword 23 Structure D NumberOfKeys 5i 0 overlay(QDFKDFTds:1) //--------------- D QDFKDFPMds ds based(QDFKDFPMptr) Qualified Keyword Parameters D LengthOfData 5i 0 overlay(QDFKDFPMds:5) D MscgonData 4000a overlay(QDFKDFPMds:7) //--*CALL PROTOTYPES--------------------------------------- D QDFRTVFD PR extpgm('QDFRTVFD') Retrieve dspf Descri D 8a options(*varsize) Receiver D 10i 0 const Receiver Length D 8a const Api Format D 20a const Qualified File Name Db like(ApiErrds) Error Parm //--*ENTRY PARMS------------------------------------------- D p_JCRANZDR PR extpgm('JCRANZDR') D 20a D p_JCRANZDR PI D i_FileQual 20a //----------------------------------------------------------- /free p_File = %subst(i_FileQual:1:10); p_Lib = %subst(i_FileQual:11:10); 1b if p_Lib = '*LIBL '; QusrObjDS = f_QUSROBJD(i_FileQual: '*FILE ': 'OBJD0100'); p_Lib = QusrObjDS.ReturnLib; 1e endif; f_OvrPrtf('JCRANZDP ': *OMIT: p_File); open JCRANZDP; exsr srLoadPrintRulers; // retrieve display file callp QDFRTVFD( GetAllocSizeDS: %len(GetAllocSizeDS): 'DSPF0100': i_FileQual: ApiErrds); QDFFBASEptr = %alloc(GetAllocSizeDS.SizeReturned); callp QDFRTVFD( QDFFBASEds: GetAllocSizeDS.SizeReturned: 'DSPF0100': i_FileQual: ApiErrds); // set pointer to Screen Size IDs QDFFSCRAptr = QDFFBASEptr + 19; // screen sizes ID 1b if QDFFSCRAds.ScreenID = x'03'; MaxCol = 80; 1x else; MaxCol =132; 1e endif; // set pointer to File Header Section QDFFINFOds QDFFINFOptr = %addr(QDFFBASEds) + QDFFBASEds.OffsetToQDFFINFO; // Where Used File Information pointer QDFWFLEIptr = QDFFINFOptr + QDFFINFOds.OffsetToQDFWFLEI; // Field Name table pointer QDFFNTBLptr = QDFWFLEIptr + QDFWFLEIds.OffsetToQDFFNTBL; // Where Used Record information starting pointer QDFWRCDIptr = QDFWFLEIptr + QDFWFLEIds.OffsetToQDFWRCDI; //----------------------------------------------------------- // Spin through the record formats, ignoring any internally generated formats //----------------------------------------------------------- // set pointer to record format section QDFARFTEds QDFARFTEptr = QDFFINFOptr + QDFFINFOds.LengthFileHeaderSection; 1b for xx = 1 to QDFFBASEds.NumRecFmts; 2b if %subst(QDFARFTEds.RecordFormatName:1 :1) <> '*'; 3b If xx > 1; // Next record format exsr srPrintLine; 3e endif; RecFmtLine = '-R-' + %trimr(QDFARFTEds.RecordFormatName) + Rulers; write NewLine; exsr srGetFieldsForRecordFormat; 2e endif; QDFARFTEptr += %len(QDFARFTEds); 1e endfor; exsr srPrintLine; DisplayRow = *all'_'; write PrintLine1; dealloc QDFFBASEptr; close JCRANZDP; f_DltOvr('JCRANZDP '); // Send print completed message LastSplfInfoDS = f_GetLastSplfInfo(); f_SndCompMsg('Splf ' +%trimr(LastSplfInfoDS.SplfName) + ' number ' + %char(LastSplfInfoDS.SplfNum) + ' generated by JCRANZD.'); *inlr = *on; return; //----------------------------------------------------------- // Print display line and field names. //----------------------------------------------------------- begsr srPrintLine; write PrintLine1; 1b for rr = 1 to 6; 2b if FldNameRowArry(rr) > *blanks; FldNameRow = FldNameRowArry(rr); write PrintLine2; 2e endif; 1e endfor; DisplayRow = *blanks; FldNameRowArry(*) = *blanks; endsr; //----------------------------------------------------------- // The deal here is there are a WHOLE bunch of arrays in // a WHOLE bunch of different sections. The trick is to // keep track of all the different pointers as you spin through // these multiple arrays. //----------------------------------------------------------- begsr srGetFieldsForRecordFormat; // set pointer to record header section QDFFRINF to get number of fields QDFFRINFptr = QDFFINFOptr + QDFARFTEds.OffsetToQDFFRINF; // set pointer to Field Indexing Table QDFFFITBptr = QDFFRINFptr + QDFFRINFds.OffsetToQDFFFITB; // set pointer to Field Header QDFFFINF // set pointer to named field and constant headers QDFFFINFptr = QDFFRINFptr + QDFFFITBds.OffsetToQDFFFINF; QDFFFNAMptr = QDFFFINFptr + 6; QDFFFCONptr = QDFFFINFptr + 6; // set pointer to Record Level Device Dependent Section QDFFRDPD QDFFRDPDptr = QDFFRINFptr + QDFFRINFds.OffsetToQDFFRDPD; // set pointer to Row Column Table QDFFRCTB QDFFRCTBptr = QDFFRINFptr + QDFFRDPDds.OffsetToQDFFRCTB; // set offset to Where Used Field Information QDFWFLDIptr = QDFWRCDIptr + QDFWRCDIds.OffsetToQDFWFLDI; 1b for yy = 1 to QDFFRINFds.NumFields; FieldNam = *blanks; 2b if QDFFFINFds.FieldAttribut = x'06' // hidden or QDFFFINFds.FieldAttribut = x'07'; // program communication 2x else; row = f_CvtHexToInt(%subst(QDFFRCTBds.QDFFRCTEds(yy):1:1)); col = f_CvtHexToInt(%subst(QDFFRCTBds.QDFFRCTEds(yy):2:1)); col += 1; // goofy API. 3b if col > MaxCol; Col -= MaxCol; Row += 1; 3e endif; //----------------------------------------------------------- // If Row number changes, print current buffers and start // loading buffers for next row //----------------------------------------------------------- 3b if yy = 1; PrintRow = Row; 3e endif; 3b if PrintRow <> Row; // new row exsr srPrintLine; PrintRow = Row; 3e endif; //----------------------------------------------------------- // CONSTANTS //----------------------------------------------------------- 3b if QDFFFINFds.FieldAttribut = x'01'; FieldNam = *blanks; 4b if tstbts(QDFFFINFds.DateTimeBits: 0) = 1 or tstbts(QDFFFINFds.DateTimeBits: 1) = 1; FieldNam = 'DATE '; pConst = 'DD/DD/DD'; 4x elseif tstbts(QDFFFINFds.DateTimeBits: 2) = 1; FieldNam = 'TIME '; pConst = 'TT:TT:TT'; 4x elseif tstbts(QDFFFINFds.SystemUserBits: 4) = 1; FieldNam = 'USER '; pConst = 'UUUUUUUUUU'; 4x elseif tstbts(QDFFFINFds.SystemUserBits: 5) = 1; FieldNam = 'SYSNAME'; pConst = 'SSSSSSSS'; 4x else; QDFFFDPDptr = QDFFFINFptr + QDFFFCONds.ConstantOffsetToQDFFFDPD; exsr srCategoryKeys; 4e endif; 4b if Col < %len(DisplayRow); %subst(DisplayRow:Col) = pConst; 5b if FieldNam <> *blanks; exsr srStagger; 5e endif; 4e endif; 3x else; //----------------------------------------------------------- // FIELDS //----------------------------------------------------------- ProgramLen = QDFFFNAMds.ProgramLen; NumberDec =f_CvtHexToInt(QDFFFNAMds.NumberDec); 4b if QDFWFLDIds.IndexOfFieldNameTable > 0; FieldNam = QDFFNTBLds.FieldNameArry(QDFWFLDIds.IndexOfFieldNameTable); QDFFFDPDptr = QDFFFINFptr + QDFFFNAMds.NamedOffsetToQDFFFDPD; //----------------------------------------------------------------------- // if the field has a edit code or edit word then it will have keywords // Note: Float numbers will only work for 14 or less length numeric, so // if field is longer than that, give it a Z edit code //----------------------------------------------------------------------- 5b if QDFFFNAMds.DataType = x'00' or QDFFFNAMds.DataType = x'01'; // Alpha FillChar = *all'X'; 5x else; FillChar = *all'9'; 6b if QDFFFDPDds.OffsetToQDFFCOSA > 0 and ProgramLen < 15; IsEdit = *off; exsr srCategoryKeys; 7b if IsEdit; FillChar = ReceiverVar; 7e endif; 6e endif; 5e endif; 5b if Col < %len(DisplayRow); %subst(DisplayRow:Col) = %subst(FillChar:1:QDFFFITBds.DisplayLength); 6b if FieldNam <> *blanks; exsr srStagger; 6e endif; 5e endif; 4e endif; 3e endif; 2e endif; 2b if yy < QDFFRINFds.NumFields; QDFWFLDIptr += QDFWFLDIds.LengthOfWhereUsedsectionForThisField; QDFFFITBptr += %len(QDFFFITBds); // next Field Index Table QDFFFINFptr = QDFFRINFptr + QDFFFITBds.OffsetToQDFFFINF; QDFFFNAMptr = QDFFFINFptr + 6; QDFFFCONptr = QDFFFINFptr + 6; 2e endif; 1e endfor; // set offset to next Where Used Record Information QDFWRCDIptr += QDFWRCDIds.LengthOfWhereUsedSectionForThisRecord; endsr; //--------------------------------------------------------- // Stagger field names if short length fields. // 9 99 666 // Fieldname1 // Fieldname2 // Fieldname3 //--------------------------------------------------------- begsr srStagger; NameSpace = Col; // no contiguous names Field1Field2 1b if Col =1; NameSpace = 2; 1e endif; 1b for rr = 1 to 6; 2b if %subst(FldNameRowArry(rr): NameSpace - 1: 1) = *blanks; %subst(FldNameRowArry(rr): Col) = FieldNam; 1v leave; 2e endif; 1e endfor; endsr; //------------------------------------------------- begsr srCategoryKeys; 1b if QDFFFDPDds.OffsetToQDFFCOSA > 0; // has keywords //------------------------------------------------- // Get Keyword Category Displacement String (QDFFCOSA) //------------------------------------------------- QDFFCOSAptr = QDFFFINFptr + QDFFFDPDds.OffsetToQDFFCOSA; QDFFCCOAptr = QDFFCOSAptr + 2; 2b for zz = 1 to QDFFCOSAds.NumberEntries; //------------------------------------------------- // Get the editing for a field. //------------------------------------------------- 3b if QDFFCCOAds.Category = x'24'; // edit field IsEdit = *on; QDFKEDTRptr = QDFFFINFptr + QDFFCCOAds.OffsetToCategory; QDFKEDTPptr = QDFKEDTRptr + 2; ZeroSuppress = QDFKEDTPds.ZeroSuppress; EditMaskLen = QDFKEDTPds.LenEditMask; EditMask = %subst(QDFKEDTPds.EditMask:1:EditMaskLen); exsr srEditMask; 2v leave; //------------------------------------------------- // If a constant has attributes (RI, PC , colors or stuff) // then I have to spin through the Keyword Category Displacement String // until I find the category 23 //------------------------------------------------- 3x elseif QDFFCCOAds.Category = x'23'; // constant QDFKDFTptr = QDFFFINFptr + QDFFCCOAds.OffsetToCategory; QDFKDFPMptr = QDFKDFTptr + 2; 4b for zz = 1 to QDFKDFTds.NumberOfKeys; pConst = %subst(QDFKDFPMds.MscgonData:1: QDFKDFPMds.LengthOfData); QDFKDFPMptr += QDFKDFPMds.LengthOfData; 4e endfor; 2v leave; 3e endif; QDFFCCOAptr += %len(QDFFCCOAds); 2e endfor; 1e endif; endsr; //------------------------------------------------- // What I have to do here is get the description // of the field into a decimal value so the editing // mask can be applied. // Way cool 'virtual decimal' number created by the // Alpha to Float C++ function combined with the Float to Packed C++ function. //------------------------------------------------- begsr srEditMask; ReceiverVar = *blanks; ReceiverVarLen = %len(ReceiverVar); clear Char63; 1b for ww = 1 to (ProgramLen - NumberDec); %subst(Char63: ww : 1) = '9'; 1e endfor; 1b if NumberDec > 0; %subst(Char63: ww : 1) = '.'; 2b for dd = 1 to NumberDec; ww += 1; %subst(Char63: ww : 1) = '9'; 2e endfor; 1e endif; qxxdtop(%addr(CharParm) : ProgramLen: NumberDec: -atof(Char63)); callp QECEDT( ReceiverVar: ReceiverVarLen: CharParm: '*PACKED': ProgramLen: EditMask: EditMaskLen: ZeroSuppress: ApiErrDS ); endsr; //--------------------------------------------------------- // Print headings. Load print position 'rulers' //--------------------------------------------------------- begsr srLoadPrintRulers; write Heading; 1b for zz = 1 to 13; %subst(Rulers: zz*10: 1) = %subst(%editc(zz: '3'): 5: 1); 1e endfor; write RulerPrint; Rulers = *blanks; 1b for zz = 1 to 132; %subst(Rulers: zz: 1) = %subst(%editc(zz: '3'): 5: 1); 1e endfor; write RulerPrint; Rulers = *all'-'; endsr; /end-free //--*FUNCTIONS START HERE-------------------------------------- //------------------------------------------------- // There is no single 'convert hex to integer' so I // going to convert hex to a character, then the char to a Int. //------------------------------------------------- P f_CvtHexToInt b D f_CvtHexToInt PI 3u 0 D CharIn 1a Const D HexVal s 1a D Char2 s 2a D Integer s 3u 0 inz D cvtch PR ExtProc('cvtch') Character to Hex D * value Receiver Pointer D * value Source Pointer D 10i 0 value Length of Receiver /free HexVal = CharIn; 1b if HexVal = x'FF'; // no location return 0; 1e endif; cvthc( %addr(char2): %addr(HexVal): 2); cvtch( %addr(Integer): %addr(char2): %size(Integer) * 2); return Integer; /end-free P f_CvtHexToInt e ]]> */ /*--------------------------------------------------------------------------*/ /* JCRANZO - Print O spec report layout with field names - CMD */ /* Craig Rutledge */ /* */ /* Reads selected RPGLE source then creates a report showing the O spec */ /* field names in their actual starting positions. */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print OSPEC Layout Report') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('RPG source member name:') PARM KWD(SRCFILE) TYPE(QUAL1) PROMPT('Source + file:') PARM KWD(LAYOUTONLY) TYPE(*CHAR) LEN(4) + RSTD(*YES) DFT(*YES) VALUES(*YES *NO) + PROMPT('Include rcdfmts & fld names:') /*--------------------------------------------------------------------------*/ QUAL1: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) + SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library:') ]]> * .*-------------------------------------------------------------------* .* JCRANZOH - Print O spec report layout with field names - HELP * .* Craig Rutledge * .*-------------------------------------------------------------------* :PNLGRP. :HELP NAME='JCRANZO'. Print OSPEC Layout Report (JCRANZO) - Help :P.This JCR command reads your RPG4 source O specs to provide a representational report with the field name printed under the data. This is a very easy way to determine which fields are positioned where on the report without having to dig through source code. :P.The LayoutOnly keyword was added to allow printing of a layout without the print line data and field names. This option could be used to generate a prototype layout to show a user what the report will look like. .*------------------------------------------------------------------- :LINES. The objects used by this command are: JCRANZO *CMD Command Prompt JCRANZOR *PGM RPGLE Report layout from RPG4 O specs JCRFLDGETR *PGM RPGLE Get attributes of RPG4 fields. JCRFLDCPYR *PGM RPGLE Process through /copy statements JCRRECGETR *PGM RPGLE Get attributes of data files. JCRANZOH *PNLGRP Help Text JCRANZORV *PGM RPGLE Validity Checking :ELINES. :P.Craig Rutledge :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZO/PGM'. PGM source member name (PGM) - Help :XH3.PGM source member name (PGM) :P.Specifies the name of the source member for which the field list is to be printed. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZO/SRCFILE'. Source file - Help :XH3.Source file (SRCFILE) :P.Specifies the name of the source file that contains the source PGM member. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZO/LAYOUTONLY'. Include Record Formats & Field Names - Help :XH3.Include Record Formats & Field Names (LAYOUTONLY) :P.Specifies whether to include the print line names and field names on the layout report. :EHELP. :EPNLGRP. ]]> //--------------------------------------------------------- // JCRANZOR - Print O spec report layout with field names // Craig Rutledge // // call program to process fields in /copy books. // call program to load field names & attributes into IMPORTED array. // read Rpg source code specs. // load output arrays with positional field data and field names. // print. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs Fqrpgsc if f 112 disk Extfile(i_Extfile) ExtMbr(i_SrcMbr) F usropn Fqsysprt o f 198 printer oflind(*inof) usropn //--*STAND ALONE------------------------------------------- D AllNines s 30a inz(*all'9') build pseudo number D AllZeros s 30a inz(*all'0') D ArryOfRcdFmt s 1a dim(84) inz D ArryRuler1 s 10a dim(19) inz D ArryRuler2 s 1a dim(198) inz D DecimalPart s 9a inz D EditMask s 256a inz D FileError s 10a inz D FirstTime s 2a inz('XX') D FloatDollar s 3a inz('''$''') D FormatLine s 1a inz(*all'_') dim(198) h,t,d,e lines D Formatted1 s 1a dim(198) inz D Formatted2 s 198a inz D Formatted3 s 198a inz D i_ExtFile s 21a inz D i_SrcFile s 10a inz D i_SrcLib s 10a inz D IPPfield s 12a inz D LoadNamFlg s 14a inz('Load Name Flag') D LookupName s 15a inz D ReceiverVar s 256a inz D UnderLine s 198a inz(*all'_') D WholePart s 21a inz D EditMaskLen s 10i 0 inz edit Mask Length D ReceiverVarLen s 10i 0 inz D xa s 5i 0 inz D xe s 5i 0 inz D xm s 5i 0 inz D DecimalPos s 1p 0 inz D v30_9Dec s 30p 9 inz D oEndPosN s 5s 0 based(oEndPtr) D ForCounter s 5u 0 inz D IntegerLength s 5u 0 inz D LastEndPos s 5u 0 inz D xb s 5u 0 inz D xd s 3u 0 inz ) D xf s 3u 0 inz ) D xg s 3u 0 inz ( D xh s 3u 0 inz ( D xi s 5u 0 inz D xj s 5u 0 inz D xk s 5u 0 inz(0) D xo s 5u 0 inz D oEndPtr s * inz(%addr(SourceDS.oEndPos)) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define ArryOfFields /Define Constants /Define FieldAttrbDS /Define Qeccvtec /Define Qecedt /Define SourceDS /Define f_FakeEditWord /Define f_GetQual /Define f_SndCompMsg /Define f_SndEscapeMsg /Define f_System /Define f_GetLastSplfInfo /Define p_JCRFLDCPYR /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D MapStartPosDS ds Qualified D MapStartPosN 3s 0 inz D v30_9DS ds Qualified D v30_9Zoned 30s 9 inz D EditedDS ds Qualified D ArryOfEdited 1a dim(40) inz D DimSizeDS ds Qualified D DimSizeNum 5s 0 inz numeric dim size D plusSignDS ds Qualified D PlusSignNum 5s 0 inz //--*ENTRY PARMS------------------------------------------- D p_JCRANZOR PR extpgm('JCRANZOR') D 10a Source Member D 20a Source File and Lib D 4a Layout D p_JCRANZOR PI D i_SrcMbr 10a D i_SrcFileQual 20a D i_Layout 4a //--*INPUT SPECS------------------------------------------- Iqrpgsc ns I a 1 112 SourceDS I a 19 102 ArryOfRcdFmt //--------------------------------------------------------- /free exsr srGetProgramFieldAttributes; open qrpgsc; f_System('OVRPRTF FILE(QSYSPRT) ' + 'PAGESIZE(66 198) CPI(15) SPLFNAME(' + %trimr(i_SrcMbr) + ') OVRSCOPE(*JOB)'); open qsysprt; exsr srLoadPrintRulers; exsr srReadSource; // Send print completed message LastSplfInfoDS = f_GetLastSplfInfo(); f_SndCompMsg('Splf ' +%trimr(LastSplfInfoDS.SplfName) + ' number ' + %char(LastSplfInfoDS.SplfNum) + ' generated by JCRANZO.'); close qrpgsc; close qsysprt; f_System('DLTOVR FILE(QSYSPRT) LVL(*JOB)'); *inlr = *on; return; //--------------------------------------------------------- // get all field definitions begsr srGetProgramFieldAttributes; i_ExtFile = f_GetQual(i_SrcFileQual); callp p_JCRFLDCPYR( i_ExtFile: i_SrcMbr: 'JCRANZO ': FileError); // if file-not-found error, send message 1b if FileError <> *blanks; f_SndEscapeMsg('*ERROR* External file ' + %trimr(FileError) + ' not found in *Libl.'); 1e endif; endsr; //--------------------------------------------------------- begsr srLoadPrintRulers; i_SrcFile = %subst(i_SrcFileQual: 1: 10); i_SrcLib = %subst(i_SrcFileQual: 11: 10); *in50 = (i_LayOut = '*NO '); except Heading; // load ruler to print positions 1b for xa = 1 to 198; ArryRuler2(xa) = %subst(%editc(xa: '3'): 5: 1); 1e endfor; 1b for xa = 1 to 19; evalr ArryRuler1(xa) = %subst(%editc(xa: '3'): 5: 1); 1e endfor; except RulerPrint; endsr; //--------------------------------------------------------- begsr srReadSource; read qrpgsc; 1b dow not %eof; 2b if SourceDS.CompileArray = '**' //COMPILE TIME ARRAY or SourceDS.SpecType = 'P' or SourceDS.SpecType = 'p'; 1v leave; 2e endif; 2b if (SourceDS.SpecType = 'O' or SourceDS.SpecType = 'o') and (not (SourceDS.oComment = '*' or SourceDS.oComment = '/')); // Determine type of Ospec and print. SourceDS.oAndOr = %xlate(lo: up: SourceDS.oAndOr); 3b if SourceDS.oLineType <> *blanks and SourceDS.oAndOr <> 'OR ' and SourceDS.oAndOr <> 'AND'; exsr srIPOLine; 3x else; clear IPPfield; exsr srGetFieldAttr; exsr srFieldLoad; 3e endif; 2e endif; read qrpgsc; 1e enddo; // all processed. except PrintLine; endsr; //--------------------------------------------------------- // First, print field data for previous line. // Format the line data. Any space is loaded with a '_' // then it is loaded into an array for printing. //--------------------------------------------------------- begsr srIPOLine; 1b if FirstTime = 'NO'; except PrintLine; clear formatted1; clear formatted2; clear formatted3; clear xj; clear LastEndPos; 1e endif; FirstTime = 'NO'; //--------------------------------------------------------- 1b for xm = 1 to 84; 2b if ArryOfRcdFmt(xm) = ' '; ArryOfRcdFmt(xm) = '_'; 2e endif; FormatLine(xm + 1) = ArryOfRcdFmt(xm); 1e endfor; except NewLine; endsr; //--------------------------------------------------------- // Load the data into the print array. //--------------------------------------------------------- begsr srFieldLoad; //--------------------------------------------------------- // end position = blank Load from the Left to right //--------------------------------------------------------- 1b if SourceDS.oEndPos = *blank; xj = LastEndPos; 2b if IPPfield = 'Constant '; exsr srDoConstLeft; 2x elseif IPPfield = 'Alpha Field '; exsr srDoAlphaLeft; 2x elseif IPPfield = 'Num EditWord'; exsr srDoConstLeft; 2x elseif IPPfield = 'Num EditCode'; exsr srDoEditCodeLeft; 2e endif; 1x else; //--------------------------------------------------------- // end position = + and some value load from left to right // check for - in EndPosition //--------------------------------------------------------- clear xb; xe = %scan('+': SourceDS.oEndPos: 1); 2b if xe = 0; xb = %scan('-': SourceDS.oEndPos: 1); 2e endif; 2b if xe > 0 //plus or xb > 0; //minus clear plusSignDS; 3b if xe > 0; //plus %subst(plusSignDS: xe + 1) = %subst(SourceDS.oEndPos: xe + 1); //drop plus sign 3x else; %subst(plusSignDS: xb + 1) = %subst(SourceDS.oEndPos: xb + 1); //drop minus sign 3e endif; 3b if plusSignDS = *blanks; xj = 0; 3x else; xj = PlusSignDS.PlusSignNum; 3e endif; 3b if xe > 0; //plus xj = LastEndPos + xj; 3x else; xj = LastEndPos - xj; 3e endif; 3b if IPPfield = 'Constant '; exsr srDoConstLeft; 3x elseif IPPfield = 'Alpha Field '; exsr srDoAlphaLeft; 3x elseif IPPfield = 'Num EditWord'; exsr srDoConstLeft; 3x elseif IPPfield = 'Num EditCode'; exsr srDoEditCodeLeft; 3e endif; //--------------------------------------------------------- // end position is given, load from right to left //--------------------------------------------------------- 2x else; 3b if SourceDS.oEndPos = *blanks; xj = 0; 3x else; xj = oEndPosN; 3e endif; 3b if IPPfield = 'Constant '; exsr srDoConstRight; 3x elseif IPPfield = 'Alpha Field '; exsr srAlphaRight; 3x elseif IPPfield = 'Num EditWord'; exsr srDoConstRight; 3x elseif IPPfield = 'Num EditCode'; exsr srDoEditCodeRight; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // load edit coded field with no EndPos or + EndPos. // The EditedDS field is the end result of an API edit mask apply. // Blanks and zeros are filtered out. Also, filter the // a decimal point '.' from zero decimal numbers. //--------------------------------------------------------- begsr srDoEditCodeLeft; exsr srGetEditCode; LoadNamFlg = 'Start FldNam'; 1b for xm = 1 to 40; 2b if (EditedDS.ArryOfEdited(xm) > ' ' and EditedDS.ArryOfEdited(xm) <> '0'); 3b if (DecimalPos = 0 and EditedDS.ArryOfEdited(xm) = '.'); 3x else; xj += 1; 4b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 4e endif; formatted1(xj) = EditedDS.ArryOfEdited(xm); 3e endif; 2e endif; 1e endfor; LastEndPos = xj; //reset last end pos endsr; //--------------------------------------------------------- // load edit coded field with end positions. // Start at end position and work backwards. //--------------------------------------------------------- begsr srDoEditCodeRight; exsr srGetEditCode; LastEndPos = xj; xj += 1; 1b for xa = 40 downto 1 by 1; 2b if (EditedDS.ArryOfEdited(xa) > ' ' and EditedDS.ArryOfEdited(xa) <> '0'); 3b if (DecimalPos = 0 and EditedDS.ArryOfEdited(xa) = '.'); 3x else; xj -= 1; formatted1(xj) = EditedDS.ArryOfEdited(xa); //load edited field 3e endif; 2e endif; 1e endfor; //--------------------------------------------------------- // set variables to load field name into print arrays //--------------------------------------------------------- xi = xj - 1; 1b if xi <= 0; xi = 1; 1e endif; xk = xj; exsr srStagger; endsr; //--------------------------------------------------------- // Process numeric fields that have edit words or constants. // The only difference is Edtwords have ' ' replaced with '9'. //--------------------------------------------------------- begsr srDoConstLeft; LoadNamFlg = 'Start FldNam'; 1b for xm = 2 to 28; 2b if %subst(SourceDS.oConstant: xm: 1) = qs; 1v leave; 2e endif; xj += 1; 2b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 2e endif; 2b if %subst(SourceDS.oConstant: xm: 1) = ' ' and IPPfield = 'Num EditWord'; 3b if FieldAttrbDS.DataType = 'D'; formatted1(xj) = 'D'; 3x elseif FieldAttrbDS.DataType = 'Z'; formatted1(xj) = 'Z'; 3x elseif FieldAttrbDS.DataType = 'T'; formatted1(xj) = 'T'; 3x else; formatted1(xj) = '9'; //load edited field 3e endif; 2x else; formatted1(xj) = %subst(SourceDS.oConstant: xm: 1); //load constants 2e endif; 1e endfor; LastEndPos = xj; endsr; //--------------------------------------------------------- // Constants or Edit worded fields. // Start at end position and work backwards. //--------------------------------------------------------- begsr srDoConstRight; // RPG output constant uses two single // Quotes to specify that one single Quote should be printed. // Replace the two single Quotes with one single // Quote before calculating the length of the constant. xe = %scan(qs + qs: SourceDS.oConstant: 2); 1b dow xe > 0; SourceDS.oConstant = %replace(qs: SourceDS.oConstant: xe: 2); xe = %scan(qs + qs: SourceDS.oConstant: xe + 1); 1e enddo; //--------------------------------------------------------- xe = %checkr(' ': SourceDS.oConstant); LastEndPos = xj; xj += 1; 1b for xa = (xe - 1) downto 2 by 1; xj -= 1; 2b if %subst(SourceDS.oConstant: xa: 1) = ' ' and IPPfield = 'Num EditWord'; 3b if FieldAttrbDS.DataType = 'D'; formatted1(xj) = 'D'; 3x elseif FieldAttrbDS.DataType = 'Z'; formatted1(xj) = 'Z'; 3x elseif FieldAttrbDS.DataType = 'T'; formatted1(xj) = 'T'; 3x else; formatted1(xj) = '9'; //load edited field 3e endif; 2x else; formatted1(xj) = %subst(SourceDS.oConstant: xa: 1); //load constants 2e endif; 1e endfor; //--------------------------------------------------------- // set variable to load field name. //--------------------------------------------------------- 1b if SourceDS.oEname <> *blanks; xi = xj - 1; 2b if xi <= 0; xi = 1; 2e endif; xk = xj; exsr srStagger; 1e endif; endsr; //--------------------------------------------------------- // load edit coded field with end positions. //--------------------------------------------------------- begsr srAlphaRight; LastEndPos = xj; xj += 1; 1b for ForCounter = 1 to FieldAttrbDS.Length; xj -= 1; formatted1(xj) = 'X'; //load edited field 1e endfor; //--------------------------------------------------------- // set variables to load field name. //--------------------------------------------------------- xi = xj - 1; 1b if xi <= 0; xi = 1; 1e endif; xk = xj; exsr srStagger; endsr; //--------------------------------------------------------- // Process alpha fields with no end positions or // + positioning. load from front //--------------------------------------------------------- begsr srDoAlphaLeft; //--------------------------------------------------------- // set variables to load field name. //--------------------------------------------------------- xk = xj + 1; xi = xk - 1; 1b if xi <= 0; xi = 1; 1e endif; exsr srStagger; //--------------------------------------------------------- // Load 'X's to positionally represent alpha field. //--------------------------------------------------------- 1b for ForCounter = 1 to FieldAttrbDS.Length; xj += 1; formatted1(xj) = 'X'; 2b if xj = 198; 1v leave; 2e endif; 1e endfor; LastEndPos = xj; endsr; //--------------------------------------------------------- // Set values to load field name for this time variable. //--------------------------------------------------------- begsr srLoadFieldName; xi = xj - 1; 1b if xi <= 0; xi = 1; 1e endif; xk = xj; exsr srStagger; LoadNamFlg = 'Reset '; endsr; //--------------------------------------------------------- // The Formatted2 & Formatted3 business is to stagger field // field names if short length fields. // 9 99 // Fieldname 1 // Fieldname 2 // Also need to be careful of fields names that extend past 198. // example: Field a123456789 is in position 197.. there is not // enough room to load the entire field name. //--------------------------------------------------------- begsr srStagger; xo = %len(%trimr(SourceDS.oEname)); 1b if(m) (198 - (xk - 1)) < xo; xo = (198 - (xk - 1)); 1e endif; 1b if %subst(Formatted2: xi: xo + 1) = *blanks; %subst(Formatted2: xk: xo) = SourceDS.oEname; 1x else; %subst(Formatted3: xk: xo) = SourceDS.oEname; 1e endif; endsr; //--------------------------------------------------------- // Get field name attributes. // If a field name, then look up array to get attributes. //--------------------------------------------------------- begsr srGetFieldAttr; 1b if SourceDS.oConstant <> *blanks and SourceDS.oEname = *blanks; IPPfield = 'Constant '; 1x else; SourceDS.oEname = %xlate(lo: up: SourceDS.oEname); //--------------------------------------------------------- // There could be an indexed array name as an output field. // Do a lookup with the array name to get the attributes. //--------------------------------------------------------- LookupName = SourceDS.oEname; xa = %scan('(': LookupName: 1); 2b if xa <> 0; LookupName = %subst(LookupName: 1: xa - 1); 2e endif; //--------------------------------------------------------- xa = %lookup(LookupName: ArryFieldNames: 1: ArryOfFields_NumberOfEntries); 2b if xa > 0; FieldAttrbDS = ArryFieldAttrb(xa); 3b if FieldAttrbDS.DecimalPos = *blanks; DecimalPos = 0; 3x else; DecimalPos = FieldAttrbDS.DecimalPosN; 3e endif; //--------------------------------------------------------- // Back to the array fun! It could be that an // that an un-indexed array name was coded on output. // The JCRFLDCPYR program brings in the array definitions // in two parts. Multiply element length by num elements. //--------------------------------------------------------- xg = %scan('DIM(': FieldAttrbDS.Text: 1); 3b if xg <> 0 and LookupName = SourceDS.oEname; //not indexed xf = %scan(')': FieldAttrbDS.Text: xg); 4b if xf <> 0; //end of ) xd = (xf - 1) - 4; xh = (6 - xd); DimSizeDS = *blanks; %subst(DimSizeDS: xh: xd) = %subst(FieldAttrbDS.Text: 5: xd); 5b if DimSizeDS = *blanks; DimSizeDS.DimSizeNum = 0; 5e endif; // make numeric FieldAttrbDS.Length = FieldAttrbDS.Length * DimSizeDS.DimSizeNum; //array size 4e endif; 3e endif; //--------------------------------------------------------- 3b if FieldAttrbDS.DataType = 'A'; IPPfield = 'Alpha Field '; //--------------------------------------------------------- // New to O specs is the ability to format date, time and // and timestamp fields. I have decided the best way to // handle it would be to dummy up the field length // and create a fake edit word based on type field and // and type formatting selected. //--------------------------------------------------------- 3x elseif FieldAttrbDS.DataType = 'D' or FieldAttrbDS.DataType = 'T' or FieldAttrbDS.DataType = 'Z'; IPPfield = 'Num EditWord'; SourceDS.oConstant = f_FakeEditWord(SourceDS.oConstant: FieldAttrbDS.DataType); //--------------------------------------------------------- 3x else; 4b if SourceDS.oConstant <> *blanks and SourceDS.oEditCode = ' '; IPPfield = 'Num EditWord'; 4x else; IPPfield = 'Num EditCode'; 4e endif; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Fill the whole number part of the number. // Number of decimals is subtracted from field length to get number // of digits in whole number. The correct amount of zeros and nines // are loaded into the field // The end result for a 9,2 field would be 000000000000009999999 // NOTE: Y editcodes are always 99/99/99. //--------------------------------------------------------- begsr srGetEditCode; 1b if SourceDS.oEditCode = 'Y' or SourceDS.oEditCode = 'y'; EditedDS = ' 99/99/99 '; 2b if FieldAttrbDS.Length = 8; EditedDS = ' 99/99/9999 '; 2e endif; 1x else; IntegerLength = FieldAttrbDS.Length - DecimalPos; WholePart = %subst(AllZeros: 1: (%size(WholePart) - IntegerLength)) + %subst(AllNines: 1: IntegerLength); //--------------------------------------------------------- // this expression is used to load the decimal part. // The number of decimal places is used to load up left side // side of field with 9's and fill out the remainder with zeros. // The end result for a 9,2 field would be 990000000 //--------------------------------------------------------- 2b if DecimalPos = 0; DecimalPart = *all'0'; 2x else; DecimalPart = %subst(AllNines: 1: DecimalPos) + %subst(AllZeros: DecimalPos + 1: %SIZE(DecimalPart) - DecimalPos); 2e endif; //--------------------------------------------------------- // Make a negative numeric so the edit code application // can generate max size. //--------------------------------------------------------- v30_9DS = WholePart + DecimalPart; v30_9Dec = -(v30_9DS.v30_9Zoned); //make negative packed 2b if SourceDS.oEditCode = ' '; //Use 'Z' so mapper will work SourceDS.oEditCode = 'Z'; 2x else; SourceDS.oEditCode = %xlate(lo: up: SourceDS.oEditCode); 2e endif; exsr srBuildEditMask; //--------------------------------------------------------- // If API doesn't apply user defined edit codes, it returns blank. // The next 3 lines will at least load the length of the field // so it will show on the report. //--------------------------------------------------------- 2b if ReceiverVar = *blanks; //could not apply ReceiverVar = %subst(AllNines: 2: FieldAttrbDS.Length); 2e endif; EditedDS = ReceiverVar; //--------------------------------------------------------- // Load if field has a floating $ sign. //--------------------------------------------------------- 2b if SourceDS.oConstant = FloatDollar; xe = %scan('9': EditedDS: 1); 3b if xe > 1; xe -= 1; %subst(EditedDS: xe: 1) = '$'; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Create the edit mask required to apply the edit code. //--------------------------------------------------------- begsr srBuildEditMask; callp QECCVTEC( ReceiverVar: EditMaskLen: ReceiverVarLen: ' ': SourceDS.oEditCode: ' ': 30 : 9 : ApiErrDS); EditMask = ReceiverVar; //--------------------------------------------------------- // Apply the edit mask generated by the edit code // note: if you are using a leading 0 suppress in front of a // constant, then you must make the field length parm 1 // bigger than the actual value of the field. //--------------------------------------------------------- clear ReceiverVar; callp QECEDT( ReceiverVar: ReceiverVarLen: v30_9Dec : '*PACKED': 30 : EditMask: EditMaskLen: ' ': ApiErrDS); endsr; /end-free Oqsysprt e Heading 2 01 O 23 'JCRANZO4R Member:' O i_SrcMbr 34 O 52 ' Source File:' O i_SrcFile 63 O 85 'Source Library:' O i_SrcLib 96 O udate y 132 // O e RulerPrint 1 O ArryRuler1 190 O e RulerPrint 1 O ArryRuler2 198 O e RulerPrint 2 O underLine 198 // O e NewLine 1 1 O n50 FormatLine 198 O e PrintLine 1 O formatted1 198 O e n50 PrintLine 1 O formatted2 198 O e n50 PrintLine 1 O formatted3 198 ]]> //--------------------------------------------------------- // JCRANZORV - Validity checking program for lib/file/member // Craig Rutledge //--------------------------------------------------------- //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_IsValidMemberType /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRANZORV PR extpgm('JCRANZORV ') D 10a Source Member D 20a Source File and Lib D p_JCRANZORV PI D i_SrcMbr 10a D i_SrcFileQual 20a //--------------------------------------------------------- /free 1b if not f_IsValidMemberType( i_SrcFileQual: i_SrcMbr: 'RPGLE ': 'SQLRPGLE '); f_SndEscapeMsg('*ERROR* Member ' + %trimr(i_SrcMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ /* JCRANZP - Print PRTF layout with field names - CMD */ /* Craig Rutledge */ /* */ /* Reads a generated compile listing of your PRTF then creates a report */ /* showing the PRTF field names in their actual starting positions. */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print PRTF Field Report Layout') PARM KWD(PRTF) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('PRTF source member name:') PARM KWD(SRCFILE) TYPE(QUAL1) PROMPT('Source file:') PARM KWD(LAYOUTONLY) TYPE(*CHAR) LEN(4) + RSTD(*YES) DFT(*YES) VALUES(*YES *NO) + PROMPT('Include rcdfmts & fld names:') /*--------------------------------------------------------------------------*/ QUAL1: QUAL TYPE(*NAME) LEN(10) DFT(QDDSSRC) + SPCVAL((QDDSSRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library:') ]]> */ /*--------------------------------------------------------------------------*/ /* JCRANZPC - Print PRTF layout with field names - CMDPGM */ /* Craig Rutledge */ /* */ /* Target prtf is compiled to get the expanded section. */ /* Spooled file generated by the compile is copied to a data file */ /* File is read by a RPG program to generate report layout */ /*--------------------------------------------------------------------------*/ PGM PARM(&MBR &FILE_LIB &LAYOUTONLY) DCL VAR(&MBR) TYPE(*CHAR) LEN(10) DCL VAR(&FILE_LIB) TYPE(*CHAR) LEN(20) DCL VAR(&LAYOUTONLY) TYPE(*CHAR) LEN(4) DCL VAR(&FILE) TYPE(*CHAR) LEN(10) DCL VAR(&LIB) TYPE(*CHAR) LEN(10) CHGVAR VAR(&FILE) VALUE(%SST(&FILE_LIB 1 10)) CHGVAR VAR(&LIB) VALUE(%SST(&FILE_LIB 11 10)) IF COND(&LIB = '*LIBL ') THEN(RTVOBJD + OBJ(&FILE) OBJTYPE(*FILE) RTNLIB(&LIB)) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) + MSGDTA('Expanded source list generation + for ' *CAT &MBR *TCAT ' ' *CAT &LIB *TCAT + '/' *CAT &FILE *TCAT ' - in progress') + TOPGMQ(*EXT) MSGTYPE(*STATUS) DLTF FILE(QTEMP/&FILE) MONMSG MSGID(CPF0000) OVRPRTF FILE(&FILE) HOLD(*YES) CRTPRTF FILE(QTEMP/&FILE) SRCFILE(&LIB/&FILE) + SRCMBR(&MBR) PAGESIZE(66 198) CPI(15) MONMSG MSGID(CPF7302) EXEC(DO) /* NO COMPILE */ SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Compile + of original source code failed - Please + correct errors and re-execute command') + TOPGMQ(*EXT) RETURN ENDDO SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Field + Position print - in progress') + TOPGMQ(*EXT) MSGTYPE(*STATUS) CRTPF FILE(QTEMP/DDSLIST) RCDLEN(132) SIZE(*NOMAX) MONMSG MSGID(CPF0000) CPYSPLF FILE(&FILE) TOFILE(QTEMP/DDSLIST) + SPLNBR(*LAST) MBROPT(*REPLACE) DLTSPLF FILE(&FILE) SPLNBR(*LAST) DLTOVR FILE(&FILE) OVRPRTF FILE(QSYSPRT) PAGESIZE(*N 198) CPI(15) + SPLFNAME(&MBR) CALL PGM(JCRANZPR) PARM(&MBR &FILE &LIB &LAYOUTONLY) DLTOVR FILE(QSYSPRT) DLTF FILE(QTEMP/&FILE) ENDPGM ]]> * .*-------------------------------------------------------------------* .* JCRANZPH - Print PRTF layout with field names - HELP * .* Craig Rutledge * .*-------------------------------------------------------------------* :PNLGRP. :HELP NAME='JCRANZP'. Print PRTF Field Report Layout (JCRANZP) - Help :P.This JCR command reads your PRTF source to provide a representational report with the field name printed under the data. This is a very easy way to determine which fields are positioned where on the report without having to dig through source code. :P.The LayoutOnly keyword was added to allow printing of a layout without the print line data and field names. This could be used to generate a prototype layout to show a user what the report will look like. :P.The command generates a Expanded Data listing by compiling the selected source member. A RPG program then uses this expanded listing to generate the field name report. :NT.You must have all reference files used by the print file in your library list to execute the command.:ENT. .*-------------------------------------------------------------------- :LINES. The objects used by this command are: JCRANZP *CMD Command Prompt JCRANZP *PGM CLLE Command processing program JCRANZPR *PGM RPGLE Print fields in a print file JCRANZPH *PNLGRP Help Text JCRVALMBRV *PGM RPGLE Validity Checking :ELINES. :P.Craig Rutledge :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZP/PRTF'. PRTF source member name (PRTF) - Help :XH3.PRTF source member name (PRTF) :P.Specifies the name of the PRTF for which the field list is to be printed. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZP/SRCFILE'. Source file - Help :XH3.Source file (SRCFILE) :P.Specifies the name of the source file that contains the source PRTF member. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZP/LAYOUTONLY'. Include Record Formats & Field Names - Help :XH3.Exclude Record Formats & Field Names (LAYOUTONLY) :P.Specifies whether to include the record format names and field names on the generated report. :EHELP. :EPNLGRP. ]]> //--------------------------------------------------------- // JCRANZPR - Print PRTF layout with field names // Craig Rutledge // // read dds extended source code listing. // extract source information from spooled file. // load output arrays with positional field data and field names. // print. // // On the extended listing, all printable fields have a counter number on the right side of // of the listing. The program uses this number OR the R (format) to determine when all // information about a field has been extracted. // // The DDS keywords found in a group, (SPACEx, EDTCDE, etc) are used to determine how to // to process the field. As the program is reading a group ( // // MSGCON support. The msgdta will be retrieved from the message file and printed // as a normal constant. // // Just for fun added call to QDBBRCDS to asynchronously bring the file records into memory. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs Fddslist if f 132 disk ExtFile('QTEMP/DDSLIST') F infds(Infds) Fqsysprt o f 198 printer oflind(*inof) //--*STAND ALONE------------------------------------------- D AllNines s 30a inz(*all'9') build pseudo number D AllZeros s 30a inz(*all'0') D ArryOfCont s 1a dim(288) based(BlocPtr) D ArryOfRcdFmt s 1a dim(12) inz D ArryRuler1 s 10a dim(19) inz D ArryRuler2 s 1a dim(198) inz D BlocDta s 288a inz all field assoc data D Ctl_BlkTyp s 19a inz('Record Format Block') D DecimalPart s 9a inz D EditMask s 256a inz D FieldName s 10a inz D FirstField s 3a inz('YES') D FirstRecFm s 23a inz('YES') D FlushBuffr s 3a inz('NO ') D FormatLine s 1a inz(*all'_') dim(198) D Formatted1 s 1a dim(198) inz D Formatted2 s 198a inz D Formatted3 s 198a inz D IPPfield s 12a inz IPP prompt data D LoadNamFlg s 14a inz('Load Name Flag') D O_EditCode s 1a inz extracted edit code D PrvLineNum s 3a inz sav line numbr D Quote s 1a inz('''') D ReceiverVar s 256a inz D UnderLine s 198a inz(*all'_') D WholePart s 21a inz D EditMaskLen s 10i 0 inz D ReceiverVarLen s 10i 0 inz D WholeLength s 5i 0 inz length of whole D xa s 10i 0 inz D xb s 5i 0 inz D xd s 5i 0 inz D xe s 5i 0 inz D xf s 5i 0 inz D xg s 10i 0 inz D xh s 5i 0 inz D DecimalPos s 1p 0 inz D v30_9Dec s 30p 9 inz D aFldLenNUM s 3s 0 based(aPtr) D ForCounter s 5u 0 inz D aPtr s * inz(%addr(aFldLen)) D BlocPtr s * inz(%addr(BlocDta)) D IsExpanded s n inz(*off) D IsFloatDollar s n inz(*off) //--*DATA STRUCTURES--------------------------------------- D MapStartPosDS ds Qualified D MapStartPosN 3s 0 inz D v30_9DS ds Qualified D v30_9Zoned 30s 9 inz D EditedDS ds Qualified D ArryOfEdited 1a dim(40) inz //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Infds /Define Constants /Define f_RtvMsgApi /Define FieldAttrbDS /Define Qeccvtec /Define Qecedt /Define f_BringDataBaseRecords /Define f_FakeEditWord /Define f_GetLastSplfInfo /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- // Return attributes for DDS reserved words // Note: This function changes the value of parameters //--------------------------------------------------------- D f_DDsReservedWords... D PR D 288a block data D 10a field name D 5u 0 field length D 2a decimal positions D 1a data type D f_MsgCon PR 288a process MSGCON D 288a //--*ENTRY PARMS------------------------------------------- D p_JCRANZPR PR extpgm('JCRANZPR') D 10a const Source Member D 10a const Source File D 10a const Source Lib D 4a const layout D p_JCRANZPR PI D i_SrcMbr 10a const D i_SrcFile 10a const D i_SrcLib 10a const D i_Layout 4a const //--*INPUT SPECS------------------------------------------- Iddslist ns I a 2 2 aAsterick I a 2 7 aSeqno I a 26 26 aNameType I a 26 37 ArryOfRcdFmt load into format I a 28 37 aFldName I a 41 43 aFldLen I a 44 44 aFldType I a 45 46 aDecimalPos I a 47 47 aUsage I a 48 50 aLineNumb I a 51 53 aStartPos I a 54 89 aConstant I a 89 89 aMinusSgn I a 30 37 aEndOfSrc I a 42 49 aHeading I a 43 50 aExpanded I a 95 95 aCompNumb //--------------------------------------------------------- /free f_BringDataBaseRecords( InfdsFile: InfdsLib: InfdsMbr: InfdsNumRcds); // Print headings. Load print position 'rulers' *in50 = (i_Layout = '*NO '); except Heading; 1b for xa = 1 to 198; ArryRuler2(xa) = %subst(%editc(xa: '3'): 10: 1); 1e endfor; 1b for xa = 1 to 19; evalr ArryRuler1(xa) = %subst(%editc(xa: '3'): 10: 1); 1e endfor; except RulerPrint; //--------------------------------------------------------- read ddslist; 1b dow not(%eof(ddslist)); 2b if aExpanded = 'Expanded'; IsExpanded = *on; 2e endif; 2b if IsExpanded and aHeading <> 'Data Des' and aSeqno > ' 0' and aSeqno < '999900' and aSeqno <> 'SEQNBR' and aAsterick <> '*'; //--------------------------------------------------------- // 'R' or compnumb determine either a new record format or a new // field has started. // 'R' print of previous block and start of new block //--------------------------------------------------------- 3b if aNameType = 'R'; Ctl_BlkTyp = ('Record Format Block'); FirstField = 'YES'; 4b if FirstRecFm = 'Not first record format'; FlushBuffr = 'YES'; 5b if FieldName > *blanks or BlocDta > *blanks; exsr srChkPrevBlk; //Flush existing buffr 5e endif; FlushBuffr = 'NO '; 4e endif; exsr srIPOLine; //print this record FirstRecFm = 'Not first record format'; //--------------------------------------------------------- // A printable field or constant is detected if there // is a value in aCompNumb. It 1) signals all records have // been read for previous field and should be processed. // 2) load the field data for current field. //--------------------------------------------------------- 3x elseif aCompNumb <> *blanks; 4b if FirstField = 'NO '; exsr srChkPrevBlk; 4e endif; FirstField = 'NO '; Ctl_BlkTyp = ('Field Data Block '); //reset exsr srLoadFieldData; 4b if aMinusSgn = '-'; //continuation sign %subst(aConstant: 36: 1) = ' '; //remove 4e endif; BlocDta = aConstant; 3x else; //--------------------------------------------------------- // load constant data between fields. // Multiple records can be applicable to one field. //--------------------------------------------------------- 4b if Ctl_BlkTyp = ('Field Data Block '); 5b if aMinusSgn = '-'; %subst(aConstant: 36: 1) = ' '; //remove 5e endif; 5b if FieldName <> *blanks or BlocDta = 'PAGNBR ' or BlocDta = 'DATE ' or BlocDta = 'DATE(*SYS)' or BlocDta = 'DATE(*JOB)' or BlocDta = 'DATE(*YY)' or BlocDta = 'DATE(*Y)' or BlocDta = 'DATE(*SYS)' or BlocDta = 'TIME '; BlocDta = %trimr(BlocDta) + ' ' + aConstant; 5x else; BlocDta = %trimr(BlocDta) + aConstant; 5e endif; 4e endif; 3e endif; 2e endif; read ddslist; //--------------------------------------------------------- // 'E N D' signifies the end of the listing. Print last line. //--------------------------------------------------------- 2b if aEndOfSrc = 'E N D '; FlushBuffr = 'YES'; exsr srChkPrevBlk; 1v leave; 2e endif; 1e enddo; // Send print completed message LastSplfInfoDS = f_GetLastSplfInfo(); f_SndCompMsg('Splf ' +%trimr(LastSplfInfoDS.SplfName) + ' number ' + %char(LastSplfInfoDS.SplfNum) + ' generated by JCRANZP.'); *inlr = *on; return; //--------------------------------------------------------- // Determine if a LINE SPACING event is about to occur. // If No SpaceB or SkipB, then load // the field into the current field line. If there is a // Space/Skip before, print the current // line, reset all values. Start with this field on a new line. //--------------------------------------------------------- begsr srChkPrevBlk; 1b if %scan('SPACEB(': BlocDta) > 0 or %scan('SKIPB(': BlocDta) > 0; except PrintLine; //print data for previous line clear formatted1; clear formatted2; clear formatted3; clear xe; 1e endif; // Determine what type of field. clear IPPfield; clear xb; clear O_EditCode; // check for reserved word 1b if FieldName = *blanks; f_DDsReservedWords( BlocDta: FieldName: FieldAttrbDS.Length: FieldAttrbDS.DecimalPos: FieldAttrbDS.DataType); 1e endif; 1b if FieldName = *blanks; IPPfield = 'Constant '; xb = %scan(Quote: BlocDta); xb += 1; 1x elseif FieldAttrbDS.DataType = 'A'; IPPfield = 'Alpha Field '; 1x else; //--------------------------------------------------------- // Extract either starting position to edit word/edit code. // I have decided the best way to handle date,time,stamp // type data is to create a fake edit word based on type // field and type formatting selected. //--------------------------------------------------------- 2b if FieldAttrbDS.DataType = 'L' or FieldAttrbDS.DataType = 'T' or FieldAttrbDS.DataType = 'Z'; blocdta = 'EDTWRD(' + %trimr(f_FakeEditWord(blocdta: FieldAttrbDS.DataType)) + ')'; 2e endif; xb = %scan('EDTWRD(': BlocDta); 2b if xb > 0 ; IPPfield = 'Num EditWord'; xb = 9; 2x else; //--------------------------------------------------------- // extract edit code. Check for floating dollar sign. //--------------------------------------------------------- clear O_EditCode; IsFloatDollar = *off; xb = %scan('EDTCDE(': BlocDta); 3b if xb > 0; O_EditCode = %subst(BlocDta: xb + 7: 1); xb = %scan('$': BlocDta: xb + 8); 4b if xb > 0; IsFloatDollar = *on; 4e endif; 3e endif; IPPfield = 'Num EditCode'; 2e endif; 1e endif; //--------------------------------------------------------- // load data into print array //--------------------------------------------------------- exsr srFieldLoad; //--------------------------------------------------------- // If there is a space after, print, then reset all values // Or if current Line number does not equal previous line number. //--------------------------------------------------------- 1b if FlushBuffr = 'YES' or FlushBuffr = 'NO ' AND (PrvLineNum <> aLineNumb or %scan('SPACEA(': BlocDta) > 0 or %scan('SKIPA(': BlocDta) > 0); except PrintLine; clear formatted1; clear formatted2; clear formatted3; clear xe; 1e endif; endsr; //--------------------------------------------------------- // load field name data. //--------------------------------------------------------- begsr srLoadFieldData; clear FieldAttrbDS; clear FieldName; clear DecimalPos; 1b if aFldName <> *blanks; FieldName = aFldName; FieldAttrbDS.Length = aFldLenNum; FieldAttrbDS.DecimalPos = aDecimalPos; FieldAttrbDS.DataType = aFldType; 2b if FieldAttrbDS.DecimalPos = *blanks; DecimalPos = 0; 2x else; DecimalPos = FieldAttrbDS.DecimalPosN; 2e endif; 1e endif; MapStartPosDS = aStartPos; PrvLineNum = aLineNumb; endsr; //--------------------------------------------------------- // First, print field data for previous line. // Format the line data. Any space is loaded with a '_' // then it is loaded into an array for printing. //--------------------------------------------------------- begsr srIPOLine; 1b for xg = 1 to 12; 2b if ArryOfRcdFmt(xg) = ' '; ArryOfRcdFmt(xg) = '_'; 2e endif; FormatLine(xg + 1) = ArryOfRcdFmt(xg); 1e endfor; except NewLine; endsr; //--------------------------------------------------------- // load data into print array //--------------------------------------------------------- begsr srFieldLoad; 1b if MapStartPosDS = *blanks; xe = 0; 1x else; xe = MapStartPosDS.MapStartPosN; 1e endif; xe -= 1; 1b if IPPfield = 'Constant '; exsr srDoConstLeft; 1x elseif IPPfield = 'Alpha Field '; exsr srDoAlphaLeft; 1x elseif IPPfield = 'Num EditWord'; exsr srDoConstLeft; 1x elseif IPPfield = 'Num EditCode'; exsr srDoEditCodeLeft; 1e endif; endsr; //--------------------------------------------------------- // The EditedDS field is the end result of an API edit mask apply. // Blanks and zeros are filtered out. Also, filter the // a decimal point '.' from zero decimal numbers. //--------------------------------------------------------- begsr srDoEditCodeLeft; exsr srGetEditCode; //build edited field LoadNamFlg = 'Start FldNam'; 1b for xg = 1 to 40; 2b if (EditedDS.ArryOfEdited(xg) > ' ' and EditedDS.ArryOfEdited(xg) <> '0'); 3b if (DecimalPos = 0 and EditedDS.ArryOfEdited(xg) = '.'); 3x else; xe += 1; 4b if xe > 198; xe = 198; 4e endif; 4b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 4e endif; formatted1(xe) = EditedDS.ArryOfEdited(xg); 3e endif; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // Process numeric fields that have edit words or constants. // The only difference is Edtwords have ' ' replaced with '9'. //--------------------------------------------------------- begsr srDoConstLeft; LoadNamFlg = 'Start FldNam'; //--------------------------------------------------------- // Add support for MSGCON keyword. BLOCDTA could contain // MSGCON(len msgid msgf). If it does, call function to // extract message from the msgf and load into arryofCont. //--------------------------------------------------------- 1b if %subst(BlocDta: 1: 6) = 'MSGCON'; BlocDta = f_MSGCON(BlocDta); xb = 1; 1e endif; //--------------------------------------------------------- 1b for xg = xb to 198; 2b if ArryOfCont(xg) = Quote; //end of edit word 1v leave; 2e endif; xe += 1; 2b if xe > 198; xe = 198; 2e endif; 2b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 2e endif; 2b if ArryOfCont(xg) = ' ' and IPPfield = 'Num EditWord'; 3b if FieldAttrbDS.DataType = 'L'; formatted1(xe) = 'D'; 3x elseif FieldAttrbDS.DataType = 'Z'; formatted1(xe) = 'Z'; 3x elseif FieldAttrbDS.DataType = 'T'; formatted1(xe) = 'T'; 3x else; formatted1(xe) = '9'; //load edited field 3e endif; 2x else; formatted1(xe) = ArryOfCont(xg); 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // Process alpha fields with no end positions or + positioning. //--------------------------------------------------------- begsr srDoAlphaLeft; //--------------------------------------------------------- // Load the field NAME into the second array starting at the // first position of the field. //--------------------------------------------------------- xh = xe - 1; 1b if xh <= 0; xh = 1; 1e endif; xf = xe + 1; exsr srStagger; //--------------------------------------------------------- // Load 'X's to positionally represent the alpha field. //--------------------------------------------------------- 1b for ForCounter = 1 to FieldAttrbDS.Length; xe += 1; formatted1(xe) = 'X'; 1e endfor; endsr; //--------------------------------------------------------- // Load field names under data representations. //--------------------------------------------------------- begsr srLoadFieldName; xh = xe - 1; 1b if xh <= 0; xh = 1; 1e endif; xf = xe; exsr srStagger; LoadNamFlg = 'Reset '; endsr; //--------------------------------------------------------- // The Formatted2 & Formatted3 business is to stagger field // field names if short length fields. // 9 99 // Fieldname 1 // Fieldname 2 // Also need to be careful of fields names that extend past 132. // example: Field a123456789 is in position 131.. there is not // enough room to load the entire field name. //--------------------------------------------------------- begsr srStagger; xd = %len(%trimr(FieldName)); 1b if xf <= 0; xf = 1; 1e endif; 1b if (198 - (xf - 1)) < xd; xd = (198 - (xf - 1)); 1e endif; 1b if %subst(Formatted2: xh: xd + 1) = *blanks; %subst(Formatted2: xf: xd) = FieldName; 1x else; %subst(Formatted3: xf: xd) = FieldName; 1e endif; endsr; //--------------------------------------------------------- // Fill the whole number part of the number. // Number of decimals is subtracted from field length to get number // of digits in whole number. The correct amount of zeros and nines // are loaded into the field // The end result for a 9,2 field would be 000000000000009999999 // NOTE: Y editcodes are always 99/99/99. //--------------------------------------------------------- begsr srGetEditCode; 1b if O_EditCode = 'Y'; EditedDS = ' 99/99/99 '; 2b if FieldAttrbDS.Length = 8; EditedDS = ' 99/99/9999 '; 2e endif; 1x else; WholeLength = FieldAttrbDS.Length - DecimalPos; WholePart = %subst(AllZeros: 1: (%size(WholePart) - WholeLength)) + %subst(AllNines: 1: WholeLength); //--------------------------------------------------------- // this expression is used to load the decimal part. // The number of decimal places is used to load up left side // side of field with 9's and fill out the remainder with zeros. // The end result for a 9,2 field would be 990000000 //--------------------------------------------------------- 2b if DecimalPos = 0; DecimalPart = *all'0'; 2x else; DecimalPart = %subst(AllNines: 1: DecimalPos) + %subst(AllZeros: DecimalPos + 1: %SIZE(DecimalPart) - DecimalPos); 2e endif; //--------------------------------------------------------- // Make a negative numeric so the edit code application // can generate max size. //--------------------------------------------------------- v30_9DS = WholePart + DecimalPart; v30_9Dec = -(v30_9DS.V30_9Zoned); //make packed negative 2b if O_EditCode = ' '; //Use 'Z' so mapper will work O_EditCode = 'Z'; 2x else; 2e endif; exsr srBuildEditMask; //apply edit code //--------------------------------------------------------- // If API doesn't apply user defined edit codes, it returns blank. // The next 3 lines will at least load the length of the field // so it will show on the report. //--------------------------------------------------------- 2b if ReceiverVar = *blanks; ReceiverVar = %subst(AllNines: 2: FieldAttrbDS.Length); 2e endif; EditedDS = ReceiverVar; //load edited field //--------------------------------------------------------- // Load if field has a floating $ sign. //--------------------------------------------------------- 2b if IsFloatDollar; xb = %scan('9': EditedDS: 1); 3b if xb > 1; xb -= 1; %subst(EditedDS: xb: 1) = '$'; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Create the edit mask required to apply the edit code. //--------------------------------------------------------- begsr srBuildEditMask; callp QECCVTEC( ReceiverVar: EditMaskLen: ReceiverVarLen: ' ': O_EditCode: ' ': 30 : 9 : ApiErrDS); EditMask = ReceiverVar; //--------------------------------------------------------- // Apply the edit mask generated by the edit code // see programmer interface reference // note: if you are using a leading 0 suppress in front of a // constant, then you must make the field length parm 1 // bigger than the actual value of the field. //--------------------------------------------------------- clear ReceiverVar; callp QECEDT( ReceiverVar: ReceiverVarLen: v30_9Dec : '*PACKED': 30 : EditMask: EditMaskLen: ' ': ApiErrDS); endsr; /end-free Oqsysprt e Heading 2 01 O 23 'JCRANZPR Member:' O i_SrcMbr 34 O 52 ' Source File:' O i_SrcFile 63 O 85 'Source Library:' O i_SrcLib 96 O udate y 132 // O e RulerPrint 1 O ArryRuler1 190 O e RulerPrint 1 O ArryRuler2 198 O e RulerPrint 2 O underLine 198 // O e NewLine 1 1 O n50 FormatLine 198 O e PrintLine 1 O formatted1 198 O e n50 PrintLine 1 O formatted2 198 O e n50 PrintLine 1 O formatted3 198 //--------------------------------------------------------- // f_DDsReservedWords // Changes parms to match attributes of DDS reserved field names //--------------------------------------------------------- P f_DDsReservedWords... P B export D f_DDsReservedWords... D PI D BlocDta 288a block data D FieldName 10a field name D MapFldLength 5u 0 field length D MapDecPos 2a decimal positions D MapDtaTyp 1a data type D QuotePos1 s 5u 0 inz D QuotePos2 s 5u 0 inz D xg s 10i 0 inz D Quote c const('''') single Quote //--------------------------------------------------------- // I don't know why IBM did not make reserved words // (PAGE DATE PAGNBR) to be field names. It makes them difficult to // extract. The real problem is when the words are part of a constant. // ('Work DATE') // The method I used is to see if either a reserved word is in the // first position or not between two ' '. //--------------------------------------------------------- /free 1b if %subst(BlocDta: 1: 7) = 'PAGNBR '; FieldName = 'PAGNBR '; MapFldLength = 4; MapDecPos = '00'; MapDtaTyp = 'S'; exsr srMoveEditWord; 1x elseif %subst(BlocDta: 1: 5) = 'USER '; FieldName = 'USER '; MapFldLength = 10; MapDecPos = '00'; MapDtaTyp = 'S'; 1x elseif %subst(BlocDta: 1: 8) = 'SYSNAME '; FieldName = 'SYSNAME'; MapFldLength = 8; MapDecPos = '00'; MapDtaTyp = 'S'; 1x elseif %subst(BlocDta: 1: 5) = 'DATE ' or %subst(BlocDta: 1: 10) = 'DATE(*SYS)' or %subst(BlocDta: 1: 10) = 'DATE(*JOB)' or %subst(BlocDta: 1: 8) = 'DATE(*Y)'; FieldName = 'DATE '; MapFldLength = 6; MapDecPos = '00'; MapDtaTyp = 'P'; exsr srMoveEditWord; 1x elseif %subst(BlocDta: 1: 9) = 'DATE(*YY)'; FieldName = 'DATE '; MapFldLength = 8; MapDecPos = '00'; MapDtaTyp = 'P'; exsr srMoveEditWord; 1x elseif %subst(BlocDta: 1: 5) = 'TIME '; FieldName = 'TIME '; MapFldLength = 6; MapDecPos = '00'; MapDtaTyp = 'P'; exsr srMoveEditWord; 1x else; //--------------------------------------------------------- // Find the position of Quotes (if any) //--------------------------------------------------------- QuotePos2 = 0; QuotePos1 = %scan(Quote: BlocDta); 2b if QuotePos1 > 0; QuotePos2 = %scan(Quote: BlocDta: QuotePos1 + 1); 2e endif; xg = %scan(' PAGNBR ': BlocDta); 2b if xg > 0; 3b if (QuotePos1 = 0 and QuotePos2 = 0) OR (xg < QuotePos1 or xg > QuotePos2); FieldName = 'PAGNBR '; MapFldLength = 4; MapDecPos = '00'; MapDtaTyp = 'S'; 3e endif; 2e endif; xg = %scan(' TIME ': BlocDta); 2b if xg > 0; 3b if (QuotePos1 = 0 and QuotePos2 = 0) OR (xg < QuotePos1 or xg > QuotePos2); FieldName = 'TIME '; MapFldLength = 6; MapDecPos = '00'; MapDtaTyp = 'P'; 3e endif; 2e endif; xg = %scan(' DATE ': BlocDta); 2b if xg > 0; 3b if (QuotePos1 = 0 and QuotePos2 = 0) OR (xg < QuotePos1 or xg > QuotePos2); FieldName = 'DATE '; MapFldLength = 6; MapDecPos = '00'; MapDtaTyp = 'P'; 3e endif; 2e endif; 1e endif; return; //--------------------------------------------------------- begsr srMoveEditWord; xg = %scan(' ': BlocDta: 5); 1b if xg > 0; BlocDta = %subst(BlocDta: xg + 1); 1e endif; endsr; /End-Free P f_DDsReservedWords... P E //--------------------------------------------------------- // f_MsgCon // returns text from dds MSGCON keyword. //--------------------------------------------------------- p f_MsgCon B D f_MsgCon PI 288a D BlocDta 288a // variables for processing MSGCON keywords. D mWork s like(BlocDta) inz alpha work field D xx s 10i 0 inz numeric work field D yy s 10i 0 inz numeric work field D m_Msgid s 7a inz D m_msgFile s 10a inz D m_msgLib s 10a inz D m_LengthDS ds Qualified inz D m_Length 7s 0 /free //--------------------------------------------------------- // BLOCDTA could contain MSGCON(len msgid msgf) // I assume all msgcon data will be on one line. // get Length. skip the MSGCON( section and compress out spaces // placed after the ( and before the number starts. // Extract the value and right justify it into m_LengthDS. //--------------------------------------------------------- mWork = %triml(%subst(BlocDta: 8)); //left justify xx = %scan(' ': mWork: 1); //find 1st blank %subst(m_LengthDS: 7-(xx - 2): xx - 1) = %subst(mWork: 1: xx - 1); 1b if m_LengthDS = *blanks; m_LengthDS.m_Length = 0; 1e endif; 1b if m_LengthDS.m_Length > 130; //force validity m_LengthDS.m_Length = 130; 1e endif; //--------------------------------------------------------- // get MSGID. We know where LEN ends. // use that as a starting place to extract the MSGID. // This will fairly easy as we know the ID is 7 long. //--------------------------------------------------------- mWork = %triml(%subst(mWork: xx)); m_Msgid = %subst(mWork: 1: 7); //--------------------------------------------------------- // get MSGF. the msgf could be Qualified LIB/MSGF or not. // We know where MSGID ends, start at that point and compress // over to the MSGF value. // Determine where the string ends. It could be either // MSGF) and it would end at the ) or // MSGF ) and it would end at the first ' '. // yy (end string) is set to where MSGF actually ends. //--------------------------------------------------------- mWork = %triml(%subst(mWork: 8)); //start at msgf yy = %scan(')': mWork); //find closing ) xx = %scan(' ': (%subst(mWork: 1: yy))); //find last ' ' 1b if xx <> 0; //didn't find one 2b if xx < yy; //find lowest yy = xx; 2e endif; 1e endif; yy -= 1; //last pos of string //--------------------------------------------------------- // Now determine if the string is a Qualified (lib/File) name // or just a msgf name. //--------------------------------------------------------- xx = %scan('/': mWork); //Qualified? 1b if xx = 0; //is not Qualified m_msgFile = %subst(mWork: 1: yy); m_msgLib = '*LIBL'; 1x else; //--------------------------------------------------------- // if it is Qualified, extract the Qualified (lib/file) names. //--------------------------------------------------------- m_msgFile = %subst(mWork: xx + 1: yy - xx); m_msgLib = %subst(mWork: 1: xx - 1); 1e endif; //--------------------------------------------------------- return %trimr(f_RtvMsgApi(m_Msgid:' ': m_msgFile + m_msgLib)) + qs; /end-free p f_MsgCon E ]]> //--------------------------------------------------------- // JCRANZPRV - Validity checking program for lib/file/member // Craig Rutledge //--------------------------------------------------------- //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_IsValidMemberType /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRANZPRV PR extpgm('JCRANZPRV ') D 10a Source Member D 20a Source File and Lib D p_JCRANZPRV PI D i_SrcMbr 10a D i_SrcFileQual 20a //--------------------------------------------------------- /free 1b if not f_IsValidMemberType( i_SrcFileQual: i_SrcMbr: 'PRTF '); f_SndEscapeMsg('*ERROR* Member ' + %trimr(i_SrcMbr) + ' is not type PRTF.'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ /* JCRBND - List Procedure Names - CMD */ /* Craig Rutledge */ /* */ /* Output list of procedures from a bnddir, service program, or module) */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Procedure Names') PARM KWD(BINDING) TYPE(QUAL1) MIN(1) PROMPT('Binding + Object:') PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) + DFT(*BNDDIR) VALUES(*BNDDIR *SRVPGM + *MODULE) MIN(0) PGM(*YES) PROMPT('Object + type:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *OUTFILE) + PROMPT('Output:') PARM KWD(OUTFILE) TYPE(QUAL2) + PMTCTL(PMTCTL1) + PROMPT('Outfile:') PARM KWD(OUTMBR) TYPE(ELEM2) + PMTCTL(PMTCTL1) + PROMPT('Output member options:') /*--------------------------------------------------------------------------*/ QUAL1: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library:') /*--------------------------------------------------------------------------*/ QUAL2: QUAL TYPE(*NAME) LEN(10) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library:') /*--------------------------------------------------------------------------*/ ELEM2: ELEM TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST)) PROMPT('Member to + receive output') ELEM TYPE(*CHAR) LEN(10) RSTD(*YES) DFT(*REPLACE) + VALUES(*REPLACE *ADD) PROMPT('Replace or + add records') /*--------------------------------------------------------------------------*/ PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ '*OUTFILE')) + NBRTRUE(*EQ 1) ]]> * .*-------------------------------------------------------------------* .* JCRBNDH - List Procedure Names - HELP * .* Craig Rutledge * .*-------------------------------------------------------------------* :PNLGRP. :HELP NAME='JCRBND'. List Procedure Names (JCRBND) - Help :P.This JCR command outputs a list of procedures/symbols that are exported by a selected *BNDDIR, *SRVPGM, or *MODULE. .*-------------------------------------------------------------------- :LINES. The objects used by this command are: JCRBND *CMD Command Prompt JCRBNDR *PGM RPGLE List procedure names extract JCRBNDRV *PGM RPGLE Validity Checking JCRBNDRP *FILE PRTF Print file for JCRBND command JCRBNDPF *FILE PF Outfile for JCRBND JCRBNDPFB *FILE PF Outfile for DSPDNDDIR command JCRBNDH *PNLGRP Help Text :ELINES. :P.Craig Rutledge :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRBND/BINDING'. Binding Object - Help :XH3.Binding Object (BINDING) :P.Specifies the name/generic*/*ALL and library of the binding object (binding directory, service program, or module) for which the procedures are to be listed. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRBND/OBJTYPE'. Object Type - Help :XH3.Object Type (OBJTYPE) :P.Specifies the object type of the binding object selected. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRBND/OUTPUT'. Output - Help :XH3.OutPut (OUTPUT) :P.Specifies whether to print the results or load into outfile. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRBND/OUTFILE'. OutFile - Help :XH3.File (OUTFILE) :P.Specifies the name and library of the file where the procedure names are to be loaded. :EHELP. .*--------------------------------------------------------------------- :HELP name='JCRBND/OUTMBR'. :H3.Output (OUTMBR) :P.Specifies the name of the database file member that receives the output of the command. :P.The possible name values are: :P.:PARML. :PT.:PK def.*FIRST:EPK. :PD.The first member in the file receives the output. If it does not exist, the system creates a member with the name of the file specified in the :HP2.File to receive output:EHP2. prompt (OUTFILE parameter). :PT.member-name :PD.Specify the name of the file member that receives the output. If it does not exist, the system creates it. :EPARML. :P.The possible values for how information is stored are: :P.:PARML. :PT.:PK def.*REPLACE:EPK. :PD.The system clears the existing member and adds the new records. :PT.*ADD :PD.The system adds the new records to the end of the existing records. :EPARML. :EHELP. :EPNLGRP. ]]> *---------------------------------------------------------------- * JCRBNDPF - List procedure names-outfile - PF * Craig Rutledge *---------------------------------------------------------------- A R JCRBNDPFR A JCRDATE L TEXT('Display Date *ISO') A JCRTIME T TEXT('Display Time *ISO') A JCRBNDDIR 10A A JCRBNDDIRL 10A A JCRSRVPGM 10A A JCRSRVPGML 10A A JCRMODULE 10A A JCRMODULEL 10A A JCRPROC 256A ]]> *---------------------------------------------------------------- * JCRBNDPFB - List procedure names-bnddir names - PF * This file matches the *OUTFILE of the DSPBNDDIR command. * There was no other way to get bnddir entries. * Craig Rutledge *---------------------------------------------------------------- A R QBNDSPBD A BNDCEN 1A A BNDDAT 6A A BNDTIM 6A A BNOLNM 10A A BNOBNM 10A A BNOBTP 7A A BNOCEN 1A A BNODAT 6A A BNOTIM 6A A BNDRLB 10A A BNDRNM 10A A BNMOSY 8A ]]> //--------------------------------------------------------- // JCRBNDR - list procedures from bnddir/svcpgm/mod // Craig Rutledge // // determine type selected on input (bnddir,svcpgm, or module). // call API to load Object names to user space. // // If object is BNDDIR, must execute CL command. // dspbnddir to outfile to get info. Wish there was an API for that! // // call Qbnlspgm API to extract proc exports from service programs. // call Qbnlmodi API to extract symbols from modules information. // // Output to either print or outfile. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRbndpfb if e disk usropn FJCRbndpf o e disk ExtFile(extOFile) ExtMbr(extOmbr) F usropn FJCRbndrp o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D extOFile s 21a inz D extOmbr s 10a inz D Lib_Obj s 21a inz D ListSpace s 20a inz('JCRBNDLST QTEMP ') D ModuleSpace s 20a inz('JCRMODULE QTEMP ') D SrvPgmSpace s 20a inz('JCRSRVPGM QTEMP ') D ForCount s 10i 0 inz D IsOverFlow s n inz(*off) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Qbnlmodi /Define Qbnlspgm /Define Quslobj /Define Qusptrus /Define UserSpaceHeaderDS /Define f_BuildString /Define f_GetQual /Define f_OvrPrtf /Define f_Quscrtus /Define f_Qusrobjd /Define f_SndCompMsg /Define f_SndStatMsg /Define f_System /Define f_GetLastSplfInfo /Define p_JCRBNDR /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_GetBndDir PR D 10a Object D 10a Lib D f_GetSrvPgm PR D 10a Object D 10a Lib D f_GetModule PR D 10a Object D 10a Lib D f_FormatHeadings... D PR 195a Returned Headings D 10a Object Type D f_GetObjDesc PR 50a D 20a Object and Lib D 10a Object type D f_PutPrint PR D 10a Binding Directory D 10a Lib D 10a Service Program D 10a Lib D 10a Module D 10a Lib D 256a Procedure Name //--*ENTRY PARMS------------------------------------------- D p_JCRBNDR PI D i_ObjectQual 20a D i_ObjTyp 10a D i_Output 8a D i_OutFileQual 20a D i_OutMbrOpt 22a //--------------------------------------------------------- /free Lib_Obj = f_GetQual(i_ObjectQual); f_SndStatMsg( f_BuildString( 'List procedures for & type & - in progress': %trimr(Lib_Obj): %trimr(i_ObjTyp))); // load various output fields JCRdate = %date(); JCRtime = %time(); HeadLib = %subst(i_ObjectQual: 11: 10); HeadObj = %subst(i_ObjectQual: 1: 10); HeadTyp = i_ObjTyp; HeadDesc = f_GetObjDesc(i_ObjectQual: i_ObjTyp); // depending on output selection 1b if i_Output = '*PRINT '; f_OvrPrtf('JCRBNDRP ': *OMIT: %subst(i_ObjectQual: 1: 10)); open JCRbndrp ; HeadVar = f_FormatHeadings(i_ObjTyp); write prthead; 1x elseif i_Output = '*OUTFILE'; extOmbr = %subst(i_OutMbrOpt: 3: 10); extOFile = f_GetQual(i_OutFileQual); open JCRbndpf; 1e endif; // Create user spaces GenericHeaderPtr = f_Quscrtus(ListSpace); f_Quscrtus(ModuleSpace); f_Quscrtus(SrvPgmSpace); // call API to load object names into user space. callp QUSLOBJ( ListSpace: 'OBJL0100': i_ObjectQual: i_ObjTyp: ApiErrDS); // Process objects in user space by moving the pointer. QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if QuslobjDS.ObjectType = '*BNDDIR'; f_GetBndDir(QuslobjDS.ObjectName: QuslobjDS.ObjectLib); 2x elseif QuslobjDS.ObjectType = '*SRVPGM'; f_GetSrvPgm(QuslobjDS.ObjectName: QuslobjDS.ObjectLib); 2x elseif QuslobjDS.ObjectType = '*MODULE'; f_GetModule(QuslobjDS.ObjectName: QuslobjDS.ObjectLib); 2e endif; QuslobjPtr += GenericHeader.ListEntrySize; 1e endfor; f_System('CLRPFM JCRBNDPF'); // Send print completed message 1b if i_Output = '*PRINT '; LastSplfInfoDS = f_GetLastSplfInfo(); f_SndCompMsg('Splf ' +%trimr(LastSplfInfoDS.SplfName) + ' number ' + %char(LastSplfInfoDS.SplfNum) + ' generated by JCRBND.'); 1x elseif i_Output = '*OUTFILE'; f_SndCompMsg('File ' +%trimr(extOFile) + ' member ' + %trimr(extOmbr) + ' generated by JCRBND.'); 1e endif; *inlr = *on; return; /end-free //--------------------------------------------------------- // There is no system API to get bind directory // entries. (I can't imagine why not!) Anyway, // execute the DSPBNDDIR command to *OUTFILE // then process the outfile. //--------------------------------------------------------- P f_GetBndDir B D f_GetBndDir PI D ObjectName 10a D ObjectLib 10a D CmdString s 160a varying /free CmdString = 'DSPBNDDIR BNDDIR(' + %trimr(f_GetQual(ObjectName + ObjectLib)) + ') OUTPUT(*OUTFILE) ' + ' OUTFILE(JCRBNDPFB) OUTMBR(*FIRST *REPLACE)'; f_System(CmdString); JCRBndDir = ObjectName; JCRBndDirL = ObjectLib; open JCRbndpfb; read JCRbndpfb; 1b dow not %eof; 2b if bnobtp = '*SRVPGM'; f_GetSrvPgm(bnobnm: bnolnm); 2x elseif bnobtp = '*MODULE'; f_GetModule(bnobnm: bnolnm); 2e endif; read JCRbndpfb; 1e enddo; close JCRbndpfb; return; /end-free P f_GetBndDir E //--------------------------------------------------------- P f_GetSrvPgm B D f_GetSrvPgm PI D ObjectName 10a D ObjectLib 10a D GenericHeaderPtr... D s * inz(*null) D ForCount s 10i 0 D GenericHeader ds Qualified based(GenericHeaderPtr) D OffSetToList 10i 0 overlay(GenericHeader: 125) D ListEntryCount 10i 0 overlay(GenericHeader: 133) D ListEntrySize 10i 0 overlay(GenericHeader: 137) D ListEntryDS ds Qualified based(ListEntryPtr) D LengthOfName 10i 0 overlay(ListEntryDS:25) D BigProcName 256a overlay(ListEntryDS:29) /free JCRSrvPgm = ObjectName; JCRSrvPgmL = ObjectLib; JCRModule = *blanks; JCRModuleL = *blanks; callp QUSPTRUS( SrvPgmSpace: GenericHeaderPtr: ApiErrDS); callp QBNLSPGM( SrvPgmSpace: 'SPGL0600': ObjectName + ObjectLib: ApiErrDS); ListEntryPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; JCRProc = %subst(ListEntryDS.BigProcName: 1: ListEntryDS.LengthOfName); f_PutPrint( JCRBNDDIR: JCRBNDDIRL: JCRSRVPGM: JCRSRVPGML: JCRMODULE: JCRMODULEL: JCRPROC); ListEntryPtr += GenericHeader.ListEntrySize; 1e endfor; JCRSrvPgm = *blanks; JCRSrvPgmL = *blanks; return; /end-free P f_GetSrvPgm E //--------------------------------------------------------- P f_GetModule B D f_GetModule PI D ObjectName 10a D ObjectLib 10a D ForCount s 10i 0 D ProcNameRaw s 256a based(RawNamePtr) D GenericHeader ds Qualified based(mhPtr) D OffSetToList 10i 0 overlay(GenericHeader: 125) offset to list D ListEntryCount 10i 0 overlay(GenericHeader: 133) number list entries D ListEntrySize 10i 0 overlay(GenericHeader: 137) list entry size D ListEntryDS ds Qualified based(ListEntryPtr) D SizeOfThisEnt 10i 0 overlay(ListEntryDS: 1) D OffsetToProc 10i 0 overlay(ListEntryDS:29) D LengthOfName 10i 0 overlay(ListEntryDS:33) /free JCRModule = ObjectName; JCRModuleL = ObjectLib; callp QBNLMODI( ModuleSpace: 'MODL0300': ObjectName + ObjectLib: ApiErrDS); callp QUSPTRUS(ModuleSpace: mHPtr: ApiErrDS); ListEntryPtr = mHPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if ListEntryDS.LengthOfName > %size(JCRProc); ListEntryDS.LengthOfName = %size(JCRProc); 2e endif; RawNamePtr = mHPtr + ListEntryDS.OffsetToProc; JCRProc = %subst(procNameRaw: 1: ListEntryDS.LengthOfName); 2b if %subst(JCRProc: 1: 2) <> '_Q'; f_PutPrint( JCRBNDDIR: JCRBNDDIRL: JCRSRVPGM: JCRSRVPGML: JCRMODULE: JCRMODULEL: JCRPROC); 2e endif; ListEntryPtr += ListEntryDS.SizeOfThisEnt; 1e endfor; JCRModule = *blanks; JCRModule = *blanks; return; /end-free P f_GetModule E //--------------------------------------------------------- P f_GetObjDesc B D PI 50a D vObjLib 20a D ObjectType 10a /free QusrObjDS = f_QUSROBJD(vObjLib: ObjectType); return QusrObjDS.Text; /end-free P f_GetObjDesc E //--------------------------------------------------------- P f_FormatHeadings... P B D PI 195a D ObjectType 10a /free 1b if ObjectType = '*BNDDIR'; return 'Bnddir Srv Pgm Lib Module ' + ' Lib Procedure Name'; 1x elseif ObjectType = '*SRVPGM'; return 'Srv Pgm Procedure Name'; 1x elseif ObjectType = '*MODULE'; return 'Module Procedure Name'; 1e endif; /end-free P f_FormatHeadings... P E //--------------------------------------------------------- P f_PutPrint B D f_PutPrint PI D JCRBNDDIR 10a D JCRBNDDIRL 10a D JCRSRVPGM 10a D JCRSRVPGML 10a D JCRMODULE 10a D JCRMODULEL 10a D JCRPROC 256a /free 1b if i_Output = '*PRINT '; 2b if QuslobjDS.ObjectType = '*BNDDIR'; DetailVar = JCRBNDDIR + ' ' + JCRSRVPGM + ' ' + JCRSRVPGML + ' ' + JCRMODULE + ' ' + JCRMODULEL + ' ' + JCRPROC; 2x elseif QuslobjDS.ObjectType = '*SRVPGM'; DetailVar = JCRSRVPGM + ' ' + JCRPROC; 2x elseif QuslobjDS.ObjectType = '*MODULE'; DetailVar = JCRMODULE + ' ' + JCRProc; 2e endif; write prtdetail; 2b if IsOverFlow; write prthead; IsOverFlow = *off; 2e endif; 1x elseif i_Output = '*OUTFILE'; write JCRbndpfr; 1e endif; /end-free P f_PutPrint E ]]> *---------------------------------------------------------------- * JCRBNDRP - List Procedure Names - PRTF * Craig Rutledge *---------------------------------------------------------------- *--- PAGESIZE(66 198) *--- CPI(15) A R PRTHEAD A SKIPB(1) A 2'JCRBNDR' A 22'List Procedure Names' A 110'jcr' A 120DATE A EDTWRD(' / / ') A 130TIME A EDTWRD(' : : ') A 140'Page' A +1PAGNBR A EDTCDE(4) A SPACEA(2) A HEADOBJ 10A O 3 A HEADLIB 10A O 16 A HEADTYP 10A O 29 A HEADDESC 50A O 42 A SPACEA(2) A HEADVAR 195A O 2 A SPACEA(2) *---------------------------------------------- A R PRTDETAIL A DETAILVAR 195A O 2 A SPACEA(1) ]]> //--------------------------------------------------------- // JCRBNDRV - Object validity checking program with create outfile // Craig Rutledge //--------------------------------------------------------- //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckObject /Define f_OutFileCrtDupObj /Define p_JCRBNDR /Define p_JCRBNDRV /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRBNDRV PI D i_ObjectQual 20a D i_ObjTyp 10a D i_Output 8a D i_OutFileQual 20a D i_MbrOpt 22a //--------------------------------------------------------- /free f_CheckObject(i_ObjectQual: i_ObjTyp); //--------------------------------------------------------- // Check OUTFILE parameter //--------------------------------------------------------- 1b if i_Output = '*OUTFILE '; f_OutFileCrtDupObj( i_OutFileQual: i_MbrOpt: 'JCRBNDPF '); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ /* JCRCALL - Command prompt entry parms - CMD */ /* Craig Rutledge */ /* */ /* Generate and optionally execute a command that will prompt for a RPG or */ /* CL programs input parameters. */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Command Prompt Entry Parms') PARM KWD(PGM) TYPE(QUAL1) MIN(1) KEYPARM(*YES) + PROMPT('Program to call:') PARM KWD(SRCFIL) TYPE(*CHAR) LEN(10) KEYPARM(*NO) + PROMPT('Source File:') PARM KWD(SRCLIB) TYPE(*CHAR) LEN(10) KEYPARM(*NO) + PROMPT('Source Lib:') PARM KWD(SRCMBR) TYPE(*CHAR) LEN(10) KEYPARM(*NO) + PROMPT('Source Mbr:') PARM KWD(PGMATR) TYPE(*CHAR) LEN(10) KEYPARM(*NO) + PROMPT('Program Attribute:') PARM KWD(RTVCLS) TYPE(*CHAR) LEN(1) KEYPARM(*NO) + PROMPT('CL Only. Allow RTVSRC:') /*--------------------------------------------------------------------------*/ QUAL1: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library:') ]]> * .*-------------------------------------------------------------------* .* JCRCALLH - Command prompt entry parms - HELP * .* Craig Rutledge * .*-------------------------------------------------------------------* :PNLGRP. :HELP NAME='JCRCALL'. Command Prompt Entry Parms (JCRCALL) - Help :P.This JCR command generates/prompts a command definition created from the entry field names and attributes required by selected program. :P.The generated command designates the selected program as the command processing program, so you can enter the parm values and execute the program if you wish. :P.After execution, the generated command source is available in QTEMP/CMDSRC member JCRCALLX. :P.Conditions: :ul compact. :li.If RPG4, the source code must exist. :li.IF CLP, the program must be compiled with RTVCLSRC(*YES). :EUL. :P.This command uses a prompt override program (pop) to retrieve where the source code was that compiled your program. This is info is required for RPG programs but is not important for CL programs as the command will do a RTVCLSRC to get the proper source code. It then reads the source code and builds a command in QTEMP with keywords matching the parms in your program and that specifies your program as the command processing program. :P.The generated command is executed, allowing you to key the input parameters in command format. :NT.You must prompt the JCRCALL command for the POP to work properly.:ENT. .*-------------------------------------------------------------------- :LINES. The objects used by this command are: JCRCALL *CMD Command Prompt JCRCALLC *PGM CLLE Command processing program JCRCALLRC *PGM RPGLE Generate CMD source code for CLP JCRCALLRR *PGM RPGLE Generate CMD source code for RPG4 JCRCALLRV *PGM RPGLE Validity Checking JCRCALLRO *PGM RPGLE Source location Prompt override program JCRFLDCPYR *PGM RPGLE Get /copy sources JCRFLDGETR *PGM RPGLE Get field attributes from rpg4 code JCRCALLH *PNLGRP Help Text :ELINES. :P.Craig Rutledge :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCALL/PGM'. Program to call - Help :XH3.Program to call (PGM) :P.Specifies the name and library of the program to be called. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCALL/SRCFIL'. Source file - Help :XH3.Source file (SRCFIL) :P.Specifies the name of the source file that contains the source. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCALL/SRCLIB'. Source Library - Help :XH3.Source library (SRCLIB) :P.Specifies the name of the library where the source file is located. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCALL/SRCMBR'. Source Member - Help :XH3.Source Member (SRCMBR) :P.Specifies the name of the source member. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCALL/PGMATR'. Program attribute - Help :XH3.Program Attribute (PGMATR) :P.Specifies the type of program object. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCALL/RTVCLS'. CL Only. Allow RTVSRC - Help :XH3.CL Only. Allow RTVCLSRC (RTVCLS) :P.Specifies if RTVCLSRC is available for this source. :EHELP. :EPNLGRP. ]]> //--------------------------------------------------------- // JCRCALLR - Generate CMD to provide parms to called program // Craig Rutledge // // This program is used to generate and optionally execute a command that will prompt for // parms in a RPG or CL program. // Get program attributes from the prompt override program. // If CLP, // RTVCLSRC // read program source and generate command source. // If RPGLE, // read program source and generate command source. // Compile command with selected program as Command Processing Pgm //--------------------------------------------------------- //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_GetQual /Define f_SndCompMsg /Define f_SndEscapeMsg /Define f_System /Define p_JCRCALLR /Define p_JCRCALLRC /Define p_JCRCALLRR /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D Command s 200a inz D FileError s 10a inz D i_ExtFile s 21a inz D i_Generation s 1a inz('Y') D i_Lib s 10a inz D i_Pgm s 10a inz //--*ENTRY PARMS------------------------------------------- D p_JCRCALLR PI D i_PgmQual 20a D i_SrcFil 10a D i_SrcLib 10a D i_SrcMbr 10a D i_Pgmatr 10a D i_RtvCLSource 1a //--------------------------------------------------------- /free i_Pgm = %subst(i_PgmQual: 1: 10); i_Lib = %subst(i_PgmQual: 11: 10); i_ExtFile = f_GetQual(i_SrcFil + i_SrcLib); // clear create source file for temp command member f_System('DLTF FILE(QTEMP/CMDSRC)'); Command = ('CRTSRCPF FILE(QTEMP/CMDSRC) MBR(JCRCALLX)'); f_System(Command); // For CL program types, attempt to retrieve CL source. 1b if %subst(i_Pgmatr: 1: 2) = 'CL'; Command = ('RTVCLSRC PGM(' + f_GetQual(i_Pgm + i_Lib) + ') SRCFILE(QTEMP/CMDSRC) SRCMBR(RTVCLSRC)'); f_System(Command); // error occurred 2b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg('*ERROR* Unable to RTVCLSRC for ' + %trimr(i_Pgm) + '.'); 2e endif; callp p_JCRCALLRC( i_Pgm: i_Generation); //--------------------------------------------------------- // For RPGLE programs 1x elseif i_Pgmatr = 'RPGLE ' or i_Pgmatr = 'SQLRPGLE '; callp p_JCRCALLRR( i_ExtFile: i_SrcMbr: i_Pgm: i_Generation : FileError); // if file-not-found error, send message 2b if FileError <> *blanks; f_SndEscapeMsg('*ERROR* External file ' + %trimr(FileError) + ' not found in *Libl.'); 2e endif; 1e endif; // called program was unable to generate command definition 1b if i_Generation = 'N'; f_SndEscapeMsg('*ERROR* Unable to create definition ' + 'for ' + %trimr(i_Pgm) + '.'); 1x else; // create command object and execute f_System('DLTCMD CMD(QTEMP/JCRCALLX)'); f_System('CRTCMD CMD(QTEMP/JCRCALLX) ' + 'PGM(' + f_GetQual(i_Pgm + i_Lib) + ') SRCFILE(QTEMP/CMDSRC) SRCMBR(JCRCALLX)' ); // error occurred 2b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg('CrtCmd Failed. Check source JCRCALLX + in QTEMP/CMDSRC.'); 2e endif; f_System('?QTEMP/JCRCALLX'); 1e endif; // send completion message f_SndCompMsg('JCRCALL parm processing for ' + %trimr(f_GetQual(i_Pgm + i_Lib)) + ' - completed'); *inlr = *on; return; ]]> //--------------------------------------------------------- // JCRCALLRC - Command prompt entry parms - read CL source // Craig Rutledge // // read CLP source code. // load parm variable names into an array. // extract parm attributes from dcl statements. // after all parms defined, generate cmd source code. // // Note: If parm is not defined in program, // check DCLF for parm being defined in file. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs Fclpsrc if f 92 disk ExtFile('QTEMP/CMDSRC') F ExtMbr('RTVCLSRC') FcmdSrc o f 92 disk ExtFile('QTEMP/CMDSRC') F ExtMbr('JCRCALLX') //--*STAND ALONE------------------------------------------- D dclfFieldName s 11a inz D DecimalPos s 2a inz D FieldTypeName s 5a inz *CHAR or *DEC D Filename s 10a inz D Length s 10a inz D SaveSourceCode s 65a dim(50) inz D SourceOut s 65a inz D UserSpacename1 s 20a inz('JCRCMDS QTEMP ') D UserSpacename2 s 20a inz('JCRCMDS2 QTEMP ') D vf s 11a dim(50) inz Variable Names D WorkField s 11a inz Extract Left D FldLen s 5p 0 inz D Seqnum s 6p 0 inz D BeginVar s 5u 0 inz D dd s 5u 0 inz D EndBlank s 5u 0 inz D EndMinus s 5u 0 inz D EndParenth s 5u 0 inz D EndPos s 5u 0 inz D ForCounter1 s 5u 0 inz D ForCounter2 s 5u 0 inz D gg s 5u 0 inz D StartDCL s 5u 0 inz DCL? D xx s 5u 0 inz D zz s 5u 0 inz D IsFoundDCLF s n inz(*off) D IsFoundVar s n inz(*off) //--*COPY DEFINES------------------------------------------ /Define Quslrcd /Define Quslfld /Define Constants /Define ApiErrDS /Define ListHeaderDS /Define UserSpaceHeaderDS /Define UserSpaceHeaderDS2 /Define f_Quscrtus /Define f_SndEscapeMsg /Define p_JCRCALLRC /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRCALLRC PI D i_CPPname 10a D i_Generation 1a //--*INPUT SPECS------------------------------------------- Iclpsrc ns I a 13 92 clp_Src //--------------------------------------------------------- /free i_Generation = 'Y'; SourceOut = 'CMD PROMPT(' + qs + 'Entry Parms - ' + %triml(i_CPPname) + qs +')'; Seqnum += 10; except WriteCode; //--------------------------------------------------------- // Check for variables. If one is not found, only the cmd prompt is generated. //--------------------------------------------------------- chain 20 clpsrc; read clpsrc; 1b dow not %eof; // skip beginning TAG: statement if any 2b if %scan(': +': Clp_Src) > 0; read clpsrc; 2e endif; // check for any parms in program BeginVar = %scan('&': Clp_Src); 2b if BeginVar = 0; *inlr = *on; return; 2e endif; EndParenth = %scan(')': Clp_Src); // note there could be a continuation minus sign in the string. EndMinus = %scan('-': Clp_Src: BeginVar + 2); // Run down the string and extract the variable names loading // them into a holding array. 2b dou BeginVar = 0; EndBlank = %scan(' ': Clp_Src: BeginVar + 2); // three possible variable ending positions. // 1. use the closing parenthesis // 2. use the continuation minus sign // 3. use the next blank space 3b if EndParenth > 0 and EndParenth < EndBlank; EndPos = EndParenth; 3x elseif EndMinus > 0 and EndMinus < EndBlank; EndPos = EndMinus; 3x else; EndPos = EndBlank; 3e endif; zz += 1; vf(zz) = %subst(clp_Src: BeginVar: Endpos - BeginVar); IsFoundVar = *on; BeginVar = %scan('&': Clp_Src: Endpos + 1); 2e enddo; 2b if EndParenth > 0; 1v leave; 2e endif; read clpsrc; 1e enddo; //--------------------------------------------------------- // extract the field type and length from // the dcl statement. the variable name and type extract are // easy due to the & and * characters that precede them. //--------------------------------------------------------- 1b if IsFoundVar; read clpsrc; 2b dow not %eof; StartDCL = %scan('DCL VAR': Clp_Src); 3b if StartDCL > 0; // extract the variable name gg = %scan('&': Clp_Src: StartDCL); EndPos = %scan(')': Clp_Src: gg + 1); WorkField = %subst(clp_Src: gg: Endpos - gg); // lookup to determine if this field is a parameter. xx = %lookup(WorkField: vf); 4b if xx > 0; SourceOut = 'PARM KWD(' + %trimr(%subst(WorkField: 2)) + ')'; // extract the variable type & length (2nd ')') gg = %scan('TYPE(': Clp_Src: Endpos + 1); EndPos = %scan(')': Clp_Src: gg + 1); EndPos = %scan(')': Clp_Src: Endpos + 2); SourceOut = %trimr(SourceOut) + ' ' + %subst(clp_Src: gg: (EndPos - gg)) + ') +'; SaveSourceCode(xx) = SourceOut; 4e endif; 3e endif; aa = %scan(' DCLF F': Clp_Src); 3b if aa > 0; bb = %scan(')': Clp_Src: aa); cc = %scan('(': Clp_Src: aa); dd = %scan('/': Clp_Src: aa); 4b if dd > 0; Filename = %subst(clp_Src: dd + 1: bb - (dd + 1)); 4x else; Filename = %subst(clp_Src: cc + 1: bb - (cc + 1)); 4e endif; IsFoundDCLF = *on; 2v leave; 3e endif; read clpsrc; 2e enddo; 1e endif; //--------------------------------------------------------- // This GRIM little section is to make sure all parms were // defined by the declare statements. Unfortunately, the parms could // also be defined in a display or data file. // Spin through the definitions and see if all are defined. // This happens rarely so I am not going to worry about // heavy duty coding for efficiency. //--------------------------------------------------------- 1b if IsFoundDCLF; 2b for xx = 1 to zz; 3b if SaveSourceCode(xx) = *blanks; dclfFieldName = %subst(vf(xx): 2); exsr srFileLoad; 3e endif; 2e endfor; 1e endif; //--------------------------------------------------------- // After all records have been processed // generate the source code in the proper Sequence. 1b if IsFoundVar; 2b for xx = 1 to zz; SourceOut = SaveSourceCode(xx); Seqnum += 10; except WriteCode; gg = %scan('LEN(': SourceOut); EndPos = %scan(')': SourceOut: gg + 1); gg += 4; Length = %subst(SourceOut: gg: Endpos - gg); // It would help visually if a comma was placed // between the len and number of decimals. 3b if %scan(' ': Length) < %len(%trimr(Length)); %subst(Length: %scan(' ': Length): 1) = ','; 3e endif; SourceOut = 'PROMPT('+ qs +vf(xx) + ' ' + %trimr(Length) + qs +')'; except WriteCode; 2e endfor; 1e endif; *inlr = *on; return; //--------------------------------------------------------- // load the fields from either externally described files or a ds. //--------------------------------------------------------- begsr srFileLoad; GenericHeaderPtr = f_Quscrtus(UserSpacename1); GenericHeaderPtr2 = f_Quscrtus(UserSpacename2); //--------------------------------------------------------- // load the user space with information similar to the *basatr // option on the dspfd command. Pointers are used to load the // data structures. //--------------------------------------------------------- callp QUSLRCD( UserSpacename1: 'RCDL0200' : Filename + '*LIBL ': '1' : ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg('*ERROR* External file ' + %trimr(Filename) + ' not found in *Libl.'); 1x else; ListHeaderPtr = GenericHeaderPtr + GenericHeader.OffSetToHeader; //--------------------------------------------------------- // Process the data from the user space. // GenericHeader.ListEntryCount contains the number of data blocks to // retrieve. Move pointer through user space to 'retrieve' entries. //--------------------------------------------------------- QuslrcdPTR = GenericHeaderPtr + GenericHeader.OffSetToList; 2b for ForCounter1 = 1 to GenericHeader.ListEntryCount; //--------------------------------------------------------- // API to load Field Descriptions to user space. //--------------------------------------------------------- callp QUSLFLD( UserSpacename2: 'FLDL0100': ListHeaderDS.FileActual + ListHeaderDS.LibActual: QuslrcdDS.RecordFormat: '1': ApiErrDS); //--------------------------------------------------------- // Process list entries in user space //--------------------------------------------------------- QuslfldPTR = GenericHeaderPtr2 + GenericHeader2.OffsetToList; 3b for ForCounter2 = 1 to GenericHeader2.ListEntryCount; // map data out in to fields 4b if %subst(QuslfldDS.FieldName: 1: 3) <> '*IN'; 5b if QuslfldDS.FieldType = 'A' or QuslfldDS.FieldType = 'Z' or QuslfldDS.FieldType = 'T' or QuslfldDS.FieldType = 'L'; FieldTypeName = '*CHAR'; FldLen = QuslfldDS.FieldLengthA; DecimalPos = *blanks; 5x else; FieldTypeName = '*DEC '; FldLen = QuslfldDS.FieldLengthN; DecimalPos = %subst(%editc(QuslfldDS.DecimalPos:'3'): 8: 2); 6b if %subst(DecimalPos: 1: 1) = '0'; %subst(DecimalPos: 1: 1) = ' '; 6e endif; 5e endif; // Oh goody, I found that sucker. // dummy up the length values to look like DCL statements. 5b if dclfFieldName = QuslfldDS.FieldName; SaveSourceCode(xx) = 'PARM KWD(' + %trimr(QuslfldDS.FieldName) + ') TYPE(' + FieldTypeName + ') LEN(' + %char(FldLen) + ' ' + DecimalPos + ') +'; LV leavesr; 5e endif; 4e endif; QuslfldPTR += GenericHeader2.ListEntrySize; 3e endfor; QuslrcdPTR += GenericHeader.ListEntrySize; 2e endfor; 1e endif; endsr; /end-free OcmdSrc e WriteCode O Seqnum 6 O SourceOut 80 ]]> //--------------------------------------------------------- // JCRCALLRO - prompt override program // Craig Rutledge // // Use the object parm to call APIs Qclrpgmi-Retrieve Pgm Info or Qbnlpgmi-List ILE Pgm Info // to retrieve where the Src file was located when the program was compiled. Original Source // File, Lib and Mbr are returned to the command. //--------------------------------------------------------- //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define Qbnlpgmi /Define Qclrpgmi /Define UserSpaceHeaderDS /Define UserSpaceHeaderDS2 /Define f_Quscrtus /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D UserSpaceName s 20a inz('JCRCMDS2 QTEMP ') //--*DATA STRUCTURES--------------------------------------- D QclrpgmiDS ds 528 Qualified D SourceAttrb 10a overlay(QclrpgmiDS:39) D SourceFile 10a overlay(QclrpgmiDS:62) D SourceLib 10a overlay(QclrpgmiDS:72) D SourceMember 10a overlay(QclrpgmiDS:82) D IsRetrieveCL 1a overlay(QclrpgmiDS:109) D QbnlpgmiDS ds Qualified based(QbnlpgmiPTR) D SourceFile 10a overlay(QbnlpgmiDS:41) D SourceLib 10a overlay(QbnlpgmiDS:51) D SourceMember 10a overlay(QbnlpgmiDS:61) D SourceAttrb 10a overlay(QbnlpgmiDS:71) D AlphaBin ds Qualified D ShortBin 1 2b 0 inz(5700) //--*ENTRY PARMS------------------------------------------- D p_JCRCALLRO PR extpgm('JCRCALLRO') D 20a Command Name and Lib D 20a Program Name and Lib D 5700a Return String D p_JCRCALLRO PI D i_CmdQual 20a D i_PgmQual 20a D i_RtnString 5700a //--------------------------------------------------------- /free // call retrieve program information API to get attribute callp QCLRPGMI( QclrpgmiDS: 528: 'PGMI0100': i_PgmQual: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; QclrpgmiDS.SourceFile = 'OBJECTxxxx'; QclrpgmiDS.SourceLib = 'NOTxxxxxxx'; QclrpgmiDS.SourceMember = 'FOUNDxxxxx'; QclrpgmiDS.SourceAttrb = 'xxxxxxxxxx'; QclrpgmiDS.IsRetrieveCL = 'x'; 1x else; // If ILE, create / get pointer ILE user space 2b if QclrpgmiDS.SourceAttrb = 'RPGLE ' or QclrpgmiDS.SourceAttrb = 'SQLRPGLE ' or QclrpgmiDS.SourceAttrb = 'CLLE '; GenericHeaderPtr2 = f_Quscrtus(UserSpaceName); // if ILE, call API to get Src callp QBNLPGMI( UserSpaceName: 'PGML0100': i_PgmQual: ApiErrDS); 3b if ApiErrDS.BytesReturned > 0; //Src not available QclrpgmiDS.SourceFile = 'SOURCExxxx'; QclrpgmiDS.SourceLib = 'NOTxxxxxxx'; QclrpgmiDS.SourceMember = 'FOUNDxxxxx'; QclrpgmiDS.SourceAttrb = 'xxxxxxxxxx'; QclrpgmiDS.IsRetrieveCL = 'x'; 3x else; QbnlpgmiPTR = GenericHeaderPtr2 + GenericHeader2.OffsetToList; QclrpgmiDS.SourceFile = QbnlpgmiDS.SourceFile; QclrpgmiDS.SourceLib = QbnlpgmiDS.SourceLib; QclrpgmiDS.SourceMember = QbnlpgmiDS.SourceMember; QclrpgmiDS.SourceAttrb = QbnlpgmiDS.SourceAttrb; QclrpgmiDS.IsRetrieveCL = 'Y'; 3e endif; 2e endif; 1e endif; // build prompt string to return to command i_RtnString = AlphaBin + '??SRCFIL(' + %trimr(QclrpgmiDS.SourceFile) + ')' + ' ??SRCLIB(' + %trimr(QclrpgmiDS.SourceLib) + ')' + ' ??SRCMBR(' + %trimr(QclrpgmiDS.SourceMember) + ')' + ' ??PGMATR(' + %trimr(QclrpgmiDS.SourceAttrb) +')' + ' ??RTVCLS(' + %trimr(QclrpgmiDS.IsRetrieveCL) +')'; *inlr = *on; return; ]]> //--------------------------------------------------------- // JCRCALLRR - Command prompt entry parms - read RPG source // Craig Rutledge // // Get field attributes from JCRFLDCPYR // Read RPG source code // Find *ENTRY factor 1 or MAIN procedure // Extract parm field names and get attributes from IMPORTed arrays. // Generate CMD source code. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs Frpgsrc if f 112 disk ExtFile(i_ExtFile) ExtMbr(i_SrcMbr) Fcmdsrc o f 92 disk ExtFile('QTEMP/CMDSRC') F ExtMbr('JCRCALLX') //--*STAND ALONE------------------------------------------- D dFieldNameSav s like(SourceDS.dFieldName) inz D ExtendedName s like(SourceDS.Source57) inz D Alpha6 s 6a inz D ExtractTypeFlg s 6a inz D FileError s 10a inz D SourceOut s 65a inz D Seqnum s 6s 2 inz D IsAllDone s n inz(*off) D IsExtractParm s n inz(*off) D IsProcIntFace s n inz(*off) //--*COPY DEFINES------------------------------------------ /Define ArryOfFields /Define Constants /Define FieldAttrbDS /Define SourceDS /Define p_JCRCALLRR /Define p_JCRFLDCPYR /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRCALLRR PI D i_ExtFile 21a D i_SrcMbr 10a D i_CPPname 10a D i_Generation 1a D i_Err_File 10a //--*INPUT SPECS------------------------------------------- Irpgsrc ns I a 1 112 SourceDS //--------------------------------------------------------- /free exsr srGetProgramFieldAttributes; // Generate CMD keyword source code. SourceOut = 'CMD PROMPT(' + qs + 'Entry Parms - ' + %triml(i_CPPname) + qs +')'; Seqnum += 10; except WriteCode; //--------------------------------------------------------- read rpgsrc; 1b dow not %eof; 2b if not(SourceDS.Asterisk = '/' or SourceDS.Asterisk = '+' or SourceDS.Asterisk = '*'); SourceDS = %xlate(lo: up: SourceDS); exsr srCheckAllDone; 3b if IsAllDone; 1v leave; 3e endif; 3b if not IsExtractParm; exsr srDeterminePEP; 3x else; exsr srDoParmFields; 3e endif; 2e endif; read rpgsrc; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // Check for conditions that indicate all parms are processed. begsr srCheckAllDone; IsAllDone = *off; // compile time array or 1st Ospec will exit program. 1b if SourceDS.CompileArray = '**' or SourceDS.SpecType = 'O'; IsAllDone = *on; 1e endif; 1b if ExtractTypeFlg = 'MAIN ' and (SourceDS.SpecType = 'C' or SourceDS.SpecType = 'I' or (SourceDS.SpecType = 'D ' and SourceDS.dProtoProcedur <> *blanks)); IsAllDone = *on; 1e endif; 1b if ExtractTypeFlg = '*ENTRY' and ((SourceDS.SpecType = 'C' and SourceDS.OpCode <> 'PARM ') or SourceDS.SpecType = 'O '); IsAllDone = *on; 1e endif; //if IsExtractParm = *on // and SourceDS.OpCode <> 'PARM '; // IsAllDone = *on; // endif; endsr; //--------------------------------------------------------- // Process parms //--------------------------------------------------------- begsr srDoParmFields; 1b if ExtractTypeFlg = 'MAIN ' and SourceDS.SpecType = 'D'; aa = %scan(' ': %triml(SourceDS.Source57): 1); SourceDS.ResultField = %subst(%triml(SourceDS.Source57): 1: aa - 1); SourceDS.OpCode = 'PARM '; 1e endif; 1b if SourceDS.OpCode = 'PARM '; aa = %lookup(SourceDS.ResultField: ArryFieldNames: 1: ArryOfFields_NumberOfEntries); 2b if aa = 0; i_Generation = 'N'; *inlr = *on; return; 2e endif; FieldAttrbDS = ArryFieldAttrb(aa); exsr srWriteCmdSource; 1e endif; endsr; //--------------------------------------------------------- // Determine PEP or Procedure Entry Point. // 1. Check for *ENTRY or // 2. Prototype with same EXTPGM name as program // 3. Prototype with same name as program. //--------------------------------------------------------- begsr srDeterminePEP; // search for prototype definition with same name // as source member. 1b if SourceDS.SpecType = 'D'; IsProcIntFace = *off; aa = %scan('...': SourceDS.Source57); 2b if aa > 0; %subst(SourceDS.Source57: aa + 3) = *blanks; ExtendedName = %triml(SourceDS.Source57); // see if same as program name aa = %scan('...': Extendedname); 3b if aa > 0 and %triml(%subst(ExtendedName: 1: aa - 1)) = i_SrcMbr; IsProcIntFace = *on; 3e endif; read rpgsrc; SourceDS = %xlate(lo: up: SourceDS); 2x else; 3b if %triml(SourceDS.dFieldName) = i_SrcMbr; IsProcIntFace = *on; dFieldNameSav = %triml(SourceDS.dFieldName); 3e endif; 2e endif; Alpha6 = %triml(SourceDS.dKeyWord); 2b if Alpha6 = 'EXTPGM'; aa = %scan(qs: SourceDS.dKeyWord); bb = %scan(qs: SourceDS.dKeyWord: aa + 1); 3b if i_SrcMbr = %subst(SourceDS.dKeyWord: aa + 1: bb - (aa + 1)); IsProcIntFace = *on; dFieldNameSav = %triml(SourceDS.dFieldName); 3e endif; 2e endif; 2b if IsProcIntFace; // read through source until find // a PI procedure interface with the // same name as Prototype read rpgsrc; 3b dow not %eof; SourceDS = %xlate(lo: up: SourceDS); aa = %scan('...': SourceDS.Source57); //drop any comments 4b if aa > 0; %subst(SourceDS.Source57: aa + 3) = *blanks; 4e endif; 4b if %triml(SourceDS.dFieldName) = dFieldNameSav or ExtendedName = %triml(SourceDS.Source57); 5b if SourceDS.dProtoProcedur = ' PI '; IsExtractParm = *on; ExtractTypeFlg = 'MAIN '; LV leavesr; 5x else; read rpgsrc; SourceDS = %xlate(lo: up: SourceDS); 6b if SourceDS.dProtoProcedur = ' PI '; IsExtractParm = *on; ExtractTypeFlg = 'MAIN '; LV leavesr; 6e endif; 5e endif; 4e endif; read rpgsrc; 3e enddo; 2e endif; 1x elseif SourceDS.SpecType = 'C' and SourceDS.Factor1 = '*ENTRY '; IsExtractParm = *on; ExtractTypeFlg = '*ENTRY'; 1e endif; endsr; //--------------------------------------------------------- // Generate KEYWORD text. //--------------------------------------------------------- begsr srWriteCmdSource; SourceOut = 'PARM KWD(' + %subst(SourceDS.ResultField: 1: 10) +') TYPE('; 1b if FieldAttrbDS.DecimalPos > ' '; SourceOut = %trimr(SourceOut) + '*DEC) LEN('; 1x else; SourceOut = %trimr(SourceOut) + '*CHAR) LEN('; 1e endif; SourceOut = %trimr(SourceOut) + %char(FieldAttrbDS.Length) + FieldAttrbDS.DecimalPos + ') +'; Seqnum += 10; except WriteCode; //--------------------------------------------------------- // Generate PROMPT text. //--------------------------------------------------------- SourceOut = 'PROMPT(' + qs + SourceDS.ResultField + ' ' + %char(FieldAttrbDS.Length); 1b if FieldAttrbDS.DecimalPos > ' '; SourceOut = %trimr(SourceOut) + ',' + FieldAttrbDS.DecimalPos; 1e endif; SourceOut = %trimr(SourceOut) + qs +')'; Seqnum += 10; except WriteCode; endsr; //--------------------------------------------------------- begsr srGetProgramFieldAttributes; i_Generation = 'Y'; // load field names and attributes to IMPORTed array callp p_JCRFLDCPYR( i_ExtFile: i_SrcMbr: 'JCRCALL ': FileError); // if File-not-found error, send message 1b if FileError <> *blanks; i_Err_File = FileError; *inlr = *on; return; 1e endif; endsr; /end-free Ocmdsrc e WriteCode O Seqnum 6 O SourceOut 80 ]]> //--------------------------------------------------------- // JCRCALLRV - Object and source mbr validity checking program // Craig Rutledge //--------------------------------------------------------- //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMember /Define f_CheckObject /Define f_SndEscapeMsg /Define p_JCRCALLR /Define p_JCRCALLRV /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRCALLRV PI D i_PgmQual 20a D i_SrcFil 10a D i_SrcLib 10a D i_SrcMbr 10a D i_Pgmatr 10a D i_RtvCLSource 1a //--------------------------------------------------------- /free f_CheckObject(i_PgmQual : '*PGM '); 1b if i_Pgmatr = 'RPGLE ' or i_Pgmatr = 'SQLRPGLE '; f_CheckMember(i_SrcFil + i_SrcLib : i_SrcMbr); 1x elseif i_Pgmatr = 'CLP ' or i_Pgmatr = 'CLLE '; 2b if i_RtvCLSource = 'N'; f_SndEscapeMsg('RTVCLSRC not allowed for program ' + %trimr(%subst(i_PgmQual: 1: 10)) + '.'); 2e endif; // invalid program type 1x else; f_SndEscapeMsg('Program type ' + %trimr(i_Pgmatr) + ' not supported by JCRCALL.'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ /* JCRCDENT - Print indented CL source listing - CMD */ /* Craig Rutledge */ /* */ /* Reads selected CL source member and prints a logically indented report. */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Indented CL Source Listing') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('CLP program name:') PARM KWD(SRCFILE) TYPE(QUAL1) PROMPT('Source + file:') /*--------------------------------------------------------------------------*/ QUAL1: QUAL TYPE(*NAME) LEN(10) DFT(QCLSRC) + SPCVAL((QCLSRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library:') ]]> * .*-------------------------------------------------------------------* .* JCRCDENTH - Print indented CL source listing - HELP * .* Craig Rutledge * .*-------------------------------------------------------------------* :PNLGRP. :HELP NAME='JCRCDENT'. Indented CL Source Listing (JCRCDENT) - Help :P.This JCR command prints a CL source listing with DO, DOWHILE, DOUNTIL, DOFOR, SELECT and ENDDO operations indented for improved readability. .*-------------------------------------------------------------------- :LINES. The objects used by this command are: JCRCDENT *CMD Command Prompt JCRCDENTR *PGM RPGLE Indent Do/Enddo cl source code print JCRCDENTP *PRTF Print JCRCDENTH *PNLGRP Help Text JCRVALMBRV *PGM RPGLE Validity Checking :ELINES. :P.Craig Rutledge :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCDENT/PGM'. CLP program name (PGM) - Help :XH3.CLP program name (PGM) :P.Specifies the name of the program for which the indented list is to be printed. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCDENT/SRCFILE'. Source file - Help :XH3.Source file (SRCFILE) :P.Specifies the name of the source file that contains the source program member. :EHELP. :EPNLGRP. ]]> *---------------------------------------------------------------- * JCRCDENTP - Print indented CL source listing - PRTF * Craig Rutledge *---------------------------------------------------------------- *--- PAGESIZE(66 132) *--- OVRFLW(60) A INDARA A R HEAD1 A SKIPB(1) A 2'JCRCDENT' A PRINTTITLE 42A O 20 A 74'jcr' A 82DATE A EDTWRD(' / / ') A 92TIME A EDTWRD(' : : ') A SPACEA(2) *--- A 2'Seqno' A 8'Source Code' A 124'Chg YMD ' A SPACEA(1) *--- A 2'-----' A 8'----------------------------------- A ------------------------------------ A -----' A 124'--------' A SPACEA(1) *---------------------------------------------- A R DETAIL A SEQNO 6S 0O 1 A EDTCDE(4) A LINEOFCODE 114A O 8 A 10 LASTCHGDAT 6 0 123 A EDTWRD('0 / / ') A 132' ' A SPACEA(1) ]]> //--------------------------------------------------------- // JCRCDENTR - Print indented CL source listing // Craig Rutledge // // Read CLP source code // Scan for logic codes // Print indented source code listing //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FQclpmbr if f 112 disk ExtFile(ExtFile) ExtMbr(i_SrcMbr) F usropn infds(Infds) FJCRCDENTP o e printer oflind(IsOverFlow) usropn F indds(Ind) //--*STAND ALONE------------------------------------------- D Upper s like(SourceData) D ExtFile s 21a inz D DoCnt s 5u 0 inz D ForCounter s 5u 0 inz D RecLen s 5u 0 inz D Start s 5u 0 inz D IsDo s n inz(*off) D IsDoEnd s n inz(*off) D IsOverFlow s n inz(*off) D IsPreviousLineEndedinPlus... D s n inz(*off) D IsComment s n inz(*off) D IsBlanked s n inz(*off) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Ind /Define Infds /Define f_BuildString /Define f_GetLastSplfInfo /Define f_GetQual /Define f_Qusrmbrd /Define f_SndCompMsg /Define f_System /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRCDENTR PR extpgm('JCRCDENTR') D 10a Source Member D 20a Source File and Lib D p_JCRCDENTR PI D i_SrcMbr 10a D i_SrcFileQual 20a //--*INPUT SPECS------------------------------------------- IQclpmbr ns I s 1 6 0Seqno I s 7 12 0LastChgDat I a 13 112 SourceData //--------------------------------------------------------- /free // override print file f_System( f_BuildString( 'OVRPRTF FILE(JCRCDENTP) PRTTXT(&Q&&Q) USRDFNOPT(*NONE) + SPLFNAME(&) OVRSCOPE(*JOB)': ' ': i_SrcMbr)); // Get actual source lib QusrmbrdDS = f_Qusrmbrd( i_SrcFileQual: i_SrcMbr: 'MBRD0100'); PrintTitle = %trimr(i_srcMbr) + ' - Indented ' + %trimr(QusrmbrdDS.MbrType) + ' Source Listing'; open JCRCDENTp; write head1; ExtFile = f_GetQual(QusrmbrdDS.File + QusrmbrdDS.Lib); open Qclpmbr; //--------------------------------------------------------- read Qclpmbr; 1b dow not %eof; //------------------------------------------------ // If 92 record length, blank out any garbage from 93 to 112 //------------------------------------------------ 2b if InfdsRecLen = 92; %subst(SourceData:81) = *all' '; 2e endif; //------------------------------------------------ // slam everything to the left for indentation // upper case to facilitate scanning //------------------------------------------------ SourceData = ' ' + %triml(SourceData); Upper = %xlate(lo: up: SourceData); //--------------------------------------------------------- // It is easier to blank out all comments before scanning. //--------------------------------------------------------- 2b Dou IsBlanked; IsComment = *off; 3b if IsPreviousLineEndedinPlus; aa = 1; IsComment = *on; 3x else; //--------------------------------------------------------- // Rules for when a comment actually starts in a CL program // 1) if the /* starts in the 1st position of the source // 2) if _/* is found (blank space preceding /*) // 3) if a /*_ is found (/* followed by blank space) //--------------------------------------------------------- aa = %scan('/*':Upper); 4b if aa >0; 5b if aa = 1 or %subst(Upper:aa-1:1) = ' ' or %subst(Upper:aa+1:1) = ' '; IsComment = *on; 5e endif; 4e endif; 3e endif; //-------------------------------------------- // after a comment is started, // It can end with a */ or a '+'. //-------------------------------------------- 3b if not IsComment; IsPreviousLineEndedinPlus = *off; IsBlanked = *on; 3x else; bb = %scan('*/':Upper); 4b if bb > 0; IsComment = *off; IsPreviousLineEndedinPlus = *off; IsBlanked = *off; // check for second comment on same line %subst(Upper:aa: (bb-aa) + 2) = *blanks; 4x else; %subst(Upper:aa) = *blanks; IsPreviousLineEndedinPlus = *on; IsBlanked = *on; 4e endif; 3e endif; 2e enddo; //--------------------------------------------------------- // Check for indent start and end commands. //--------------------------------------------------------- SourceData = SourceData; 2b if Upper > *blanks; IsDo = (%scan(' DO ': Upper) > 0 or %scan('(DO': Upper) > 0 or %scan('DOUNTIL': Upper) > 0 or %scan('DOWHILE': Upper) > 0 or %scan('DOFOR': Upper) > 0 or %scan(' SELECT ': Upper) > 0 or %scan('(SELECT ': Upper) > 0); IsDoEnd = (%scan('ENDDO ': Upper) > 0 or %scan('ENDSELECT': Upper) > 0); 2x else; IsDo = *off; IsDoEnd = *off; 2e endif; //--------------------------------------------------------- // If ENDDO is found, sub one from counter. // Spin though number of DO levels deep and load ' |' char. // If DO, increment counter by one for next time. //--------------------------------------------------------- 2b if IsDoEnd; DoCnt -= 1; 2e endif; clear LineOfCode; 2b for ForCounter = 1 to DoCnt; LineOfCode = %trimr(LineOfCode) + ' |'; 2e endfor; LineOfCode = %trimr(LineOfCode) + SourceData; //--------------------------------------------------------- 2b if IsDo; DoCnt += 1; 2e endif; //--------------------------------------------------------- Ind.IsChangedDate = (LastChgDat > 0); write detail; read Qclpmbr; 1e enddo; //--------------------------------------------------------- close JCRCDENTp; close Qclpmbr; f_System('DLTOVR FILE(JCRCDENTP) LVL(*JOB)'); // Send print completed message LastSplfInfoDS = f_GetLastSplfInfo(); f_SndCompMsg('Splf ' +%trimr(LastSplfInfoDS.SplfName) + ' number ' + %char(LastSplfInfoDS.SplfNum) + ' generated by JCRCDENT.'); *inlr = *on; return; ]]> //--------------------------------------------------------- // JCRCDENTRV - Validity checking program for lib/file/member // Craig Rutledge //--------------------------------------------------------- //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_IsValidMemberType /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRCDENTRV PR extpgm('JCRCDENTRV') D 10a Source Member D 20a Source File and Lib D p_JCRCDENTRV PI D i_SrcMbr 10a D i_SrcFileQual 20a //--------------------------------------------------------- /free 1b if not f_IsValidMemberType( i_SrcFileQual: i_SrcMbr: 'CLP ': 'CLLE '); f_SndEscapeMsg('*ERROR* Member ' + %trimr(i_SrcMbr) + ' is not type CLLE or CLP.'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ /* JCRCMDSBND - Binder source for JCRCMDSSRV service program */ /* Craig Rutledge */ /* */ /* Note: Add entries to the end. Do not resequence! */ /*--------------------------------------------------------------------------*/ STRPGMEXP SIGNATURE('JCRCMDS') EXPORT SYMBOL(Apierrds) EXPORT SYMBOL(f_AddSortKey) EXPORT SYMBOL(f_BringDataBaseRecords) EXPORT SYMBOL(f_BuildString) EXPORT SYMBOL(f_CenterText) EXPORT SYMBOL(f_CheckMember) EXPORT SYMBOL(f_CheckObject) EXPORT SYMBOL(f_DayName) EXPORT SYMBOL(f_DayOfWeekNumber) EXPORT SYMBOL(f_DecodeApiTimeStamp) EXPORT SYMBOL(f_DelayJobSeconds) EXPORT SYMBOL(f_DltOvr) EXPORT SYMBOL(f_DupFileToQtemp) EXPORT SYMBOL(f_ExecuteFileOptions) EXPORT SYMBOL(f_ExecuteJobOptions) EXPORT SYMBOL(f_ExecuteObjectOptions) EXPORT SYMBOL(f_ExecuteSplfOptions) EXPORT SYMBOL(f_FakeEditWord) EXPORT SYMBOL(f_GetCardFace) EXPORT SYMBOL(f_GetCardColor) EXPORT SYMBOL(f_GetRowColumn) EXPORT SYMBOL(f_GetDate13) EXPORT SYMBOL(f_GetFileUtil) EXPORT SYMBOL(f_GetLastSplfInfo) EXPORT SYMBOL(f_GetQual) EXPORT SYMBOL(f_GetRandom) EXPORT SYMBOL(f_GetTime13) EXPORT SYMBOL(f_IsValidFile) EXPORT SYMBOL(f_IsValidMbr) EXPORT SYMBOL(f_IsValidMemberType) EXPORT SYMBOL(f_IsValidObj) EXPORT SYMBOL(f_KQJCount10) EXPORT SYMBOL(f_MondaysDate) EXPORT SYMBOL(f_OutFileAddPfm) EXPORT SYMBOL(f_OutFileCrtDupObj) EXPORT SYMBOL(f_OvrPrtf) EXPORT SYMBOL(f_Parm) EXPORT SYMBOL(f_ParmListCount) EXPORT SYMBOL(f_Pgm) EXPORT SYMBOL(f_QgyolObjSortKey) EXPORT SYMBOL(f_Quscrtus) EXPORT SYMBOL(f_Qusrmbrd) EXPORT SYMBOL(f_Qusrobjd) EXPORT SYMBOL(f_RmvSflMsg) EXPORT SYMBOL(f_RtvMsgApi) EXPORT SYMBOL(f_Sbmjob) EXPORT SYMBOL(f_ShuffleDeck) EXPORT SYMBOL(f_SndCompMsg) EXPORT SYMBOL(f_SndEscapeMsg) EXPORT SYMBOL(f_SndSflMsg) EXPORT SYMBOL(f_SndStatMsg) EXPORT SYMBOL(f_System) ENDPGMEXP ]]> //--------------------------------------------------------- // JCRCMDSCPY - Copy Book for JCRCMDS // Craig Rutledge //--------------------------------------------------------- /Endif /If defined(ServiceProgramHeaderSpecs) H NOMAIN H DATFMT(*ISO) H TIMFMT(*ISO) H OPTION(*NODEBUGIO) H EXPROPTS(*RESDECPOS) H BNDDIR('QC2LE') /Endif /If Defined(ProgramHeaderSpecs) H DFTACTGRP(*NO) H ACTGRP(*CALLER) H DATFMT(*ISO) H TIMFMT(*ISO) H OPTION(*NODEBUGIO) H EXPROPTS(*RESDECPOS) H BNDDIR('JCRCMDSDIR':'QC2LE') /Endif /If Defined(ApiErrDS) //--------------------------------------------------------- // Error return code parm for APIs. D ApiErrDS ds Qualified import D BytesProvided 10i 0 D BytesReturned 10i 0 D ErrMsgId 7a D ReservedSpace 1a D MsgReplaceVal 112a /Endif /If Defined(ApiStampDS) //--------------------------------------------------------- D ApiStampDS ds 16 Qualified inz extract C YYMMDD D Century 1a overlay(ApiStampDS:1) 0=19 1=20 D MMDD 4a overlay(ApiStampDS:2) D YY 2a overlay(ApiStampDS:6) D HHMMSS 6a overlay(ApiStampDS:8) /Endif /If Defined(Atof) //--------------------------------------------------------- D atof PR 8f extproc('atof') String to Float D * value options(*string) /Endif /If Defined(Atoi) //--------------------------------------------------------- D atoi PR 10i 0 extproc('atoi') String to Integer D * value options(*string) /Endif /If Defined(Ceegsi) // Parameters for CEEGSI - Get String Information D ceegsi PR extproc('CEEGSI') D 10i 0 const position D 10i 0 data type D 10i 0 parm length D 10i 0 max length D 12a options(*omit) feedback // CEEGSI values used in multiple functions D MaxLength s 10i 0 inz D DataType s 10i 0 inz D LengthOfParm s 10i 0 inz /Endif /If Defined(Ceeran0) //--------------------------------------------------------- D ceeran0 PR extproc('CEERAN0') Get random number D 10i 0 RandInt4 D 8f RandFloat8 D 8a RandAlpha8 /Endif /If Defined(Constants) //--------------------------------------------------------- D rrn s 5u 0 inz D aa s 5u 0 inz D bb s 5u 0 inz D cc s 5u 0 inz D qs c const('''') single Quote D qd c const('"') double Quote D up c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ') D lo c const('abcdefghijklmnopqrstuvwxyz') D IsExitPgm s n inz(*off) /Endif /If Defined(Cvthc) //--------------------------------------------------------- D cvthc PR ExtProc('cvthc') Convert Hex to Char D * value Receiver Pointer D * value Source Pointer D 10i 0 value Number of Nibbles /Endif /If Defined(Infds) //--------------------------------------------------------- // File information Data Structure // Note: I cannot make this a qualified DS due to sflrecnbr // fields being used in display files. D Infds ds D InfdsFile 10a overlay(Infds:83) D InfdsLib 10a overlay(Infds:93) D InfdsRecLen 5i 0 overlay(Infds:125) D InfdsMbr 10a overlay(Infds:129) D InfdsNumRcds 10i 0 overlay(Infds:156) D InfdsMiscFlag 1a overlay(Infds:196) D InfdsCcsid 5i 0 overlay(Infds:218) D InfdsRcdfmt 10a overlay(Infds:261) D InfdsFkey 1a overlay(Infds:369) D SflRecNbrX 5i 0 overlay(Infds:376) D SflRecNbr 5i 0 overlay(Infds:378) /Endif /If Defined(Dspatr) //--------------------------------------------------------- D Green c const(x'20') D White c const(x'22') D Red c const(x'28') D Turq c const(x'30') D Yellow c const(x'32') D Pink c const(x'38') D Blue c const(x'3A') D ND c const(x'27') D RI c const(x'01') D HI c const(x'02') D UL c const(x'04') D PR c const(x'80') /Endif /If Defined(FieldAttrbDS) //--------------------------------------------------------- D FieldAttrbDS ds Qualified inz D Length 5u 0 D DecimalPos 2a D DecimalPosN 2s 0 overlay(DecimalPos) D DataType 1a D FromFile 10a D BasedOnField 15a D Text 25a /If Defined(ArryOfFields) D ArryOfFields_NumberOfEntries... D s 5u 0 IMPORT D ArryOfFields s 70a dim(5000) IMPORT D ds based(FieldPtr) D ArryOfFieldsDS 70a dim(%elem(ArryOfFields)) D ArryFieldNames 15a overlay(ArryOfFieldsDS:1) D ArryFieldAttrb overlay(ArryOfFieldsDS:16) D like(FieldAttrbDS) D FieldPtr s * inz(%addr(ArryOfFields)) /Endif /Endif /If Defined(GetAllocSizeDS) //--------------------------------------------------------- D GetAllocSizeDS ds Qualified D SizeReturned 10i 0 overlay(GetAllocSizeDS:5) /Endif /If Defined(Fild0100DS) //--------------------------------------------------------- // file header offsets D Fild0100ds ds Qualified based(Fild0100ptr) D BytesReturned 10i 0 overlay(Fild0100ds:001) D TypeBits 1a overlay(Fild0100ds:009) D NumOfBasedPf 5i 0 overlay(Fild0100ds:015) based on PFs D MaxMbrs 5i 0 overlay(Fild0100ds:042) max members allowed D NumMbrs 5i 0 overlay(Fild0100ds:048) actual num of mbrs D NumRcdFmts 5i 0 overlay(Fild0100ds:062) record formats D FileText 50a overlay(Fild0100ds:085) file text D NumOfFlds 5i 0 overlay(Fild0100ds:207) number of fields D FileRecLen 5i 0 overlay(Fild0100ds:305) file length D OffsFileScope 10i 0 overlay(Fild0100ds:317) offset to file scope D AccessType 2a overlay(Fild0100ds:337) KU = unique D OffsPFAttr 10i 0 overlay(Fild0100ds:365) offset to PF spec D OffsLfAttr 10i 0 overlay(Fild0100ds:369) offset to LF spec // file scope array D FileScopeArry ds 160 Qualified based(fscopePtr) D BasedOnPf 10a overlay(FileScopeArry:049) D BasedOnPfLib 10a overlay(FileScopeArry:059) D RecordFormat 10a overlay(FileScopeArry:069) D NumOfKeys 5i 0 overlay(FileScopeArry:116) D NumSelectOmit 5i 0 overlay(FileScopeArry:129) D OffsSelectOmit 10i 0 overlay(FileScopeArry:131) D OffsKeySpecs 10i 0 overlay(FileScopeArry:135) // key specification array D KeySpecsDS ds Qualified based(KeySpecsPtr) D KeyFieldName 10a overlay(KeySpecsDS:1) D KeySequenBits 1a overlay(KeySpecsDS:14) // select/omit specification array. D SelectOmitSpec ds Qualified based(SelectOmitSpecPtr) D StatementRule 1a overlay(SelectOmitSpec:3) D CompRelation 2a overlay(SelectOmitSpec:4) D FieldName 10a overlay(SelectOmitSpec:6) D NumberOfParms 5i 0 overlay(SelectOmitSpec:16) D OffsToParms 10i 0 overlay(SelectOmitSpec:29) // select/omit parameters. D SelectOmitParm ds Qualified based(SelectOmitParmPtr) D OffsToNext 10i 0 overlay(SelectOmitParm:1) D ParmLength 5i 0 overlay(SelectOmitParm:5) D ParmValue 30a overlay(SelectOmitParm:21) // Logical file specific attributes section. D LfSpecific ds 48 Qualified based(lfSpecificPtr) D JoinOffset 10i 0 overlay(LfSpecific:1) D AttrBits 1a overlay(LfSpecific:31) // join specifications linked list section. D JoinSpecDS ds 48 Qualified based(JoinSpecPtr) D NextLink 10i 0 overlay(JoinSpecDs:1) D NumJFlds 5i 0 overlay(JoinspecDS:9) D JoinFileNum 5i 0 overlay(JoinspecDS:13) D OffsToJSA 10i 0 overlay(JoinspecDS:41) // join specification array. (JSA) D JoinSpecArryDS ds 48 Qualified based(JoinSpecArryPtr ) D FromField 10a overlay(JoinSpecArryDS:1) D FromNumber 5i 0 overlay(JoinSpecArryDS:11) D ToField 10a overlay(JoinSpecArryDS:17) D ToNumber 5i 0 overlay(JoinSpecArryDS:27) // physical file attributes D PfAttrDS ds based(PfAttrPtr) Qualified D OffsTriggers 10i 0 overlay(PfAttrDS:25) D NumOfTriggers 5i 0 overlay(PfAttrDS:29) // trigger information array D TriggerDS ds based(TriggerPtr) Qualified D TTime 1a overlay(TriggerDS:1) D TEvent 1a overlay(TriggerDS:2) D TPrgNam 10a overlay(TriggerDS:3) D TPrgLib 10a overlay(TriggerDS:13) /Endif /If Defined(FunctionKeys) //--------------------------------------------------------- // Define hexadecimal characters for function keys //--------------------------------------------------------- D F01 c const(X'31') D F02 c const(X'32') D F03 c const(X'33') D F04 c const(X'34') D F05 c const(X'35') D F06 c const(X'36') D F07 c const(X'37') D F08 c const(X'38') D F09 c const(X'39') D F10 c const(X'3A') D F11 c const(X'3B') D F12 c const(X'3C') D F13 c const(X'B1') D F14 c const(X'B2') D F15 c const(X'B3') D F16 c const(X'B4') D F17 c const(X'B5') D F18 c const(X'B6') D F19 c const(X'B7') D F20 c const(X'B8') D F21 c const(X'B9') D F22 c const(X'BA') D F23 c const(X'BB') D F24 c const(X'BC') D FClear c const(X'BD') D FEnter c const(X'F1') D FHelp c const(X'F3') D FPageup c const(X'F4') D FPageDown c const(X'F5') D FPrint c const(X'F6') /Endif /If Defined(Ind) //--------------------------------------------------------- // name screen indicators D ind ds Qualified D IsActivateF14 n overlay(ind:04) inz(*off) D IsKeysMode n overlay(ind:05) inz(*off) D sfldrop n overlay(ind:06) inz(*off) D IsMoreScreens n overlay(ind:08) inz(*off) D IsShowViewPFs n overlay(ind:09) inz(*off) D HeadingSwitch n overlay(ind:10) inz(*off) D sflnxtchg n overlay(ind:11) inz(*off) D IsChangedDate n overlay(ind:20) inz(*off) D ShowSourceData n overlay(ind:27) inz(*off) D sfldsp n overlay(ind:31) inz(*off) D sfldspctl n overlay(ind:32) inz(*off) D sflclr n overlay(ind:33) inz(*off) D sflend n overlay(ind:34) inz(*off) D sfldsp2 n overlay(ind:41) inz(*off) D sfldspctl2 n overlay(ind:42) inz(*off) D sflclr2 n overlay(ind:43) inz(*off) D sflend2 n overlay(ind:44) inz(*off) D HeadingCtl n overlay(ind:50) inz(*off) D sfldsp3 n overlay(ind:51) inz(*off) D sfldspctl3 n overlay(ind:52) inz(*off) D sfldsp4 n overlay(ind:61) inz(*off) D sfldspctl4 n overlay(ind:62) inz(*off) /Endif /If Defined(ListHeaderDS) //--------------------------------------------------------- // Get user header info from list user space D ListHeaderDS ds Qualified based(ListHeaderPtr) D FileActual 10a D LibActual 10a D FileType 10a D FileText 50a /Endif /If Defined(ParseElemDS) //--------------------------------------------------------- // Data structure out fields from FilesParm. D ParseElemDS ds Qualified /If Defined(ParseElemDS_Based) D based(ParseElemDsPtr) /Endif D SortSequence 1a D FileName 10a D FormatName 10a D FormatReName 10a D BasedOnPF 10a D HowUsed 1a D FileText 29a D IsDataStruct 1a D Prefix 10a D Prefix_chr 1s 0 D DSname 15a /Endif /If Defined(Qbnlmodi) //--------------------------------------------------------- D Qbnlmodi PR extpgm('QBNLMODI') List Module Info D 20a Space Name and Lib D 8a const Api Format D 20a const Object and Lib Db like(ApiErrDS) Error Parm /Endif /If Defined(Qbnlpgmi) //--------------------------------------------------------- D Qbnlpgmi PR extpgm('QBNLPGMI') List ILE Pgm Info D 20a Space Name and Lib D 8a const Api Format D 20a const Object and Lib Db like(ApiErrDS) Error Parm /Endif /If Defined(Qbnlspgm) //--------------------------------------------------------- D Qbnlspgm PR extpgm('QBNLSPGM') List ServicePgm Info D 20a Space Name and Lib D 8a const API format D 20a const Object and Lib Db like(ApiErrDS) Error Parm /Endif /If Defined(Qbnrmodi) //--------------------------------------------------------- D Qbnrmodi PR extpgm('QBNRMODI') Retrieve Module Info Db 200a Receiver D 10i 0 const Length Of Receiver D 8a const Api Format D 20a const Object and Lib Db like(ApiErrDS) Error Parm /Endif /If Defined(Qcdrcmdi) //--------------------------------------------------------- D Qcdrcmdi PR extpgm('QCDRCMDI') Command Definitions Db like(cmdi0100DS ) Receiver D 10i 0 const Length of Receiver D 8a const Api Format D 20a const File and Lib Db like(ApiErrDS) Error Parm // extracted command definition fields D cmdi0100DS ds 400 Qualified D CMD 10a overlay(cmdi0100DS:9) D CMDLIB 10a overlay(cmdi0100DS:19) D CPGM 10a overlay(cmdi0100DS:29) D CLIB 10a overlay(cmdi0100DS:39) D SFILE 10a overlay(cmdi0100DS:49) D SLIB 10a overlay(cmdi0100DS:59) D SMBR 10a overlay(cmdi0100DS:69) D VPGM 10a overlay(cmdi0100DS:79) D VLIB 10a overlay(cmdi0100DS:89) D MODE 3a overlay(cmdi0100DS:99) D MODE_PROD 1a overlay(cmdi0100DS:99) D MODE_DEBUG 1a overlay(cmdi0100DS:100) D MODE_SERVICE 1a overlay(cmdi0100DS:101) D ALW 9a overlay(cmdi0100DS:109) D ALW_BPGM 1a overlay(cmdi0100DS:109) D ALW_IPGM 1a overlay(cmdi0100DS:110) D ALW_EXEC 1a overlay(cmdi0100DS:111) D ALW_INTERACT 1a overlay(cmdi0100DS:112) D ALW_BATCH 1a overlay(cmdi0100DS:113) D ALW_BREXX 1a overlay(cmdi0100DS:114) D ALW_IREXX 1a overlay(cmdi0100DS:115) D ALW_BMOD 1a overlay(cmdi0100DS:116) D ALW_IMOD 1a overlay(cmdi0100DS:117) D LIMIT 1a overlay(cmdi0100DS:124) D PMFIL 10a overlay(cmdi0100DS:129) D PMLIB 10a overlay(cmdi0100DS:139) D MSFIL 10a overlay(cmdi0100DS:149) D MSLIB 10a overlay(cmdi0100DS:159) D HLPNL 10a overlay(cmdi0100DS:169) D HLIB 10a overlay(cmdi0100DS:179) D HLPID 10a overlay(cmdi0100DS:189) D OVPGM 10a overlay(cmdi0100DS:239) D OVLIB 10a overlay(cmdi0100DS:249) D TEXT 50a overlay(cmdi0100DS:265) /Endif /If Defined(Qclrpgmi) //--------------------------------------------------------- D Qclrpgmi PR extpgm('QCLRPGMI') Retrieve Pgm Info D 528a Receiver D 10i 0 const Length of Receiver D 8a const Api Format D 20a const File and Lib Db like(ApiErrDS) Error Parm /Endif /If Defined(Qcmdchk) //--------------------------------------------------------- D Qcmdchk PR extpgm('QCMDCHK') CL Syntax Checking D 500a D 15p 5 Const /Endif //--------------------------------------------------------- /If Defined(Qcapcmd) D QCAPCMD PR extpgm('QCAPCMD') Process Commands Db 500a Source command D 10i 0 const Length of source Db Like(cpop0100DS) Options block D 10i 0 const Options block len D 8a const Options format Db 500a Changed command D 10i 0 const Length available D 10i 0 Length of changed Db like(ApiErrDS) Error Parm D cpop0100DS ds qualified D TypeProcess 10i 0 overlay(cpop0100DS:1) inz(0) command running D DBCShandling 1a overlay(cpop0100DS:5) inz('0') ignore D PrompterAct 1a overlay(cpop0100DS:6) inz('2') prompt if ? D CmdSyntax 1a overlay(cpop0100DS:7) inz('0') use system syntax D MessageKey 4a overlay(cpop0100DS:8) request message D inz(x'00000000') D CCSID 10i 0 overlay(cpop0100DS:12) inz(0) job ccsid D Reserved 5a overlay(cpop0100DS:16) reserved D inz(x'0000000000') /Endif /If Defined(Qcmdexc) //--------------------------------------------------------- D Qcmdexc PR extpgm('QCMDEXC') CL Command Processor D 125a options(*VarSize) D 15p 5 const /Endif /If Defined(Qdbbrcds) //--------------------------------------------------------- D Qdbbrcds PR extpgm('QDBBRCDS') Bring db records D 20a const File and Lib D 10a const Member D 10i 0 dim(1000) rrn array D 10i 0 number rrn Db like(ApiErrDS) Error Parm /Endif /If Defined(QDFRPRTA) //--------------------------------------------------------- D QDFRPRTA PR extpgm('QDFRPRTA') Print File Attribute D 4000a Receiver D 10i 0 const Length D 8a const Format D 20a File name and Lib Db like(ApiErrDS) Error Parm D qdfrprtaDS ds 4000 qualified Print File Attribute D BytesReturned 10i 0 overlay(qdfrprtaDS:1) D BytesAvail 10i 0 overlay(qdfrprtaDS:5) D PrintFileName 10a overlay(qdfrprtaDS:9) D Lib 10a overlay(qdfrprtaDS:19) D Device 10a overlay(qdfrprtaDS:29) D DeviceType 10a overlay(qdfrprtaDS:39) D PageSizeLen 15p 5 overlay(qdfrprtaDS:49) D PageSizeWidth 15p 5 overlay(qdfrprtaDS:57) D LPI 15p 5 overlay(qdfrprtaDS:77) D CPI 15p 5 overlay(qdfrprtaDS:85) D OverFlow 10i 0 overlay(qdfrprtaDS:93) D Text 50a overlay(qdfrprtaDS:98) D FMarginDown 15p 5 overlay(qdfrprtaDS:149) D FMarginAccros 15p 5 overlay(qdfrprtaDS:157) D PrintQuality 10a overlay(qdfrprtaDS:219) D FontIdentifier 10a overlay(qdfrprtaDS:249) D CharIdSet 10i 0 overlay(qdfrprtaDS:269) D CharIdCodePage 10i 0 overlay(qdfrprtaDS:273) D DecimalFormat 10a overlay(qdfrprtaDS:277) D PageRotation 10i 0 overlay(qdfrprtaDS:417) D PrtTxt 30a overlay(qdfrprtaDS:435) D PrintBothSides 10a overlay(qdfrprtaDS:469) D FrontOvlFile 8a overlay(qdfrprtaDS:490) D FrontOvlLib 10a overlay(qdfrprtaDS:498) D FrontOvlDown 15p 5 overlay(qdfrprtaDS:509) D FrontOvlAccros 15p 5 overlay(qdfrprtaDS:517) D BackOvlFile 10a overlay(qdfrprtaDS:525) D BackOvlLib 10a overlay(qdfrprtaDS:535) D BackOvlDown 15p 5 overlay(qdfrprtaDS:545) D BackOvlAccros 15p 5 overlay(qdfrprtaDS:553) DBackOvlConstant 1a overlay(qdfrprtaDS:561) D IPDSPASTHR 10a overlay(qdfrprtaDS:563) D UsrRscLiblOff 10i 0 overlay(qdfrprtaDS:573) D UsrRscLiblCnt 10i 0 overlay(qdfrprtaDS:577) D UsrRscLiblLen 10i 0 overlay(qdfrprtaDS:581) D FormType 10a overlay(qdfrprtaDS:688) D MaxRecords 10i 0 overlay(qdfrprtaDS:725) D Hold 1a overlay(qdfrprtaDS:743) D Save 1a overlay(qdfrprtaDS:744) D UsrDBCSdata 1a overlay(qdfrprtaDS:1066) D DBCSextension 1a overlay(qdfrprtaDS:1067) D UsrRscLiblEnt s 10a based(UsrRscLiblPtr) User Resource Libl D UsrRscLiblPtr s * /Endif /If Defined(Qdbldbr) //--------------------------------------------------------- D Qdbldbr PR extpgm('QDBLDBR ') Data Base Relations D 20a Space Name and Lib D 8a const Api Format D 20a const File and Lib D 10a const Member D 10a const Record Format Db like(ApiErrDS) Error Parm //-DBRL0100 format- D QdbldbrDS ds Qualified based(QdbldbrPtr) D DependentLF 10a overlay(QdbldbrDS:21) D DependentFile 20a overlay(QdbldbrDS:21) /Endif /If Defined(Qdbrtvfd) //--------------------------------------------------------- D Qdbrtvfd PR extpgm('QDBRTVFD') Retrieve File Desc D 16000a options(*varsize) Receiver D 10i 0 const Receiver Length D 20a Return File and Lib D 8a const Api Format D 20a const File and Lib D 10a const Record Format D 1a const Overrides D 10a const System D 10a const Format Type Db like(ApiErrDS) Error Parm /Endif /If Defined(Qeccvtec) //--------------------------------------------------------- D Qeccvtec PR extpgm('QECCVTEC') Generate Edit Mask D 256a Receiver D 10i 0 Mask Length D 10i 0 Receiver Length D 1a const 0 Balance File D 1a const Edit Code D 1a const Blank Fill D 10i 0 const Field Length D 10i 0 const Decimal Location Db like(ApiErrDS) Error Parm /Endif /If Defined(Qecedt) //--------------------------------------------------------- D Qecedt PR extpgm('QECEDT') Apply Edit Mask D 256a Receiver D 10i 0 Mask Length D 30p 9 To Be Edited D 10a const Type D 10i 0 const Field Length D 256a Edit Mask D 10i 0 Mask Length D 1a const 0 Balance File Db like(ApiErrDS) Error Parm /Endif /If Defined(Qlgsort) //--------------------------------------------------------- // QLGSORT Sort Control Block D qlgSortDS DS 1024 Qualified inz D BlockLength 10i 0 overlay(qlgSortDS:1) D TypeRequest 10i 0 overlay(qlgSortDS:5) inz(5) D Reserved1 10i 0 overlay(qlgSortDS:9) D Options 10i 0 overlay(qlgSortDS:13) D RecordLength 10i 0 overlay(qlgSortDS:17) D RecordCount 10i 0 overlay(qlgSortDS:21) D OffToKeyList 10i 0 overlay(qlgSortDS:25) inz(80) D NumOfKeys 10i 0 overlay(qlgSortDS:29) D OffNatLangInf 10i 0 overlay(qlgSortDS:33) D OffInpFileList 10i 0 overlay(qlgSortDS:37) D NumOfInpFiles 10i 0 overlay(qlgSortDS:41) D OffOutFileList 10i 0 overlay(qlgSortDS:45) D NumofOutFiles 10i 0 overlay(qlgSortDS:49) D KeyEntryLength 10i 0 overlay(qlgSortDS:53) inz(16) D SortSeqLength 10i 0 overlay(qlgSortDS:57) D LenInFileEntry 10i 0 overlay(qlgSortDS:61) DLenOutFileEntry 10i 0 overlay(qlgSortDS:65) D OffToNullMap 10i 0 overlay(qlgSortDS:69) D OffToVarRecInf 10i 0 overlay(qlgSortDS:73) D Reserved2 10i 0 overlay(qlgSortDS:77) //--*CALL PROTOTYPES------------------------------------ D qlgsort PR extpgm('QLGSORT') D qlgsortDS 1024a options(*varsize) D inBuffer 20a dim(10) D OutBuffer 20a dim(10) D LengthIBuffer 10i 0 const D LengthOBuffer 10i 0 const D ErrDS like(ApiErrDS) /Endif /If Defined(Qmhqrdqd) //--------------------------------------------------------- D Qmhqrdqd PR extpgm('QMHQRDQD') Data q Description Db like(QmhqrdqdDS) Receiver D 10i 0 const Length D 8a const Api Format Dd 20a Dtaq and Lib D QmhqrdqdDS ds Qualified inz D MsgLength 10i 0 overlay(QmhqrdqdDS:9) D KeyLength 10i 0 overlay(QmhqrdqdDS:13) D Sequence 1a overlay(QmhqrdqdDS:17) D SenderID 1a overlay(QmhqrdqdDS:18) D Text 50a overlay(QmhqrdqdDS:20) D LocalOrDDM 1a overlay(QmhqrdqdDS:70) D EntryCount 10i 0 overlay(QmhqrdqdDS:73) D CurrAllocated 10i 0 overlay(QmhqrdqdDS:77) D DtaqName 10a overlay(QmhqrdqdDS:81) D DtaqLib 10a overlay(QmhqrdqdDS:91) D MaxAllowed 10i 0 overlay(QmhqrdqdDS:101) D CreateSize 10i 0 overlay(QmhqrdqdDS:109) /Endif /If Defined(Qmhrcvpm) //--------------------------------------------------------- D Qmhrcvpm PR ExtPgm('QMHRCVPM') receive pgm messages Db like(rcvm0100DS) D 10i 0 const D 8a const D 10a const D 10i 0 const D 10a const D 4a const D 10i 0 const D 10a const Db like(ApiErrDS) D rcvm0100DS ds Qualified D BytesReturned 10i 0 overlay(rcvm0100DS:1) D BytesAvail 10i 0 overlay(rcvm0100DS:5) D LenOfMsg 10i 0 overlay(rcvm0100DS:41) D MessageText 100a overlay(rcvm0100DS:49) /Endif /If Defined(Qmhrcvm) //--------------------------------------------------------- D Qmhrcvm PR extpgm('QMHRCVM') receive non-pgm msg Db like(QmhrcvmDS) options(*varsize) message info D 10i 0 const Length D 8a const Format name D 20a const Queue and Lib D 10a const Type D 4a const Key D 10i 0 const Wait Time D 10a const Message action Db like(ApiErrDS) Options(*varsize) Error Parm // parms for QMHRCVM retrieve non program messages D QmhrcvmDS ds Qualified D BytesReturned 10i 0 overlay(QmhrcvmDS:1) D BytesAvail 10i 0 overlay(QmhrcvmDS:5) D MsgSeverity 10i 0 overlay(QmhrcvmDS:9) D MsgID 7a overlay(QmhrcvmDS:13) D MsgType 2a overlay(QmhrcvmDS:20) D MsgKey 4a overlay(QmhrcvmDS:22) D Reserved 7a overlay(QmhrcvmDS:26) D CCSIDConvStat 10i 0 overlay(QmhrcvmDS:33) conversion status D CSSID 10i 0 overlay(QmhrcvmDS:37) D MsgLenReturn 10i 0 overlay(QmhrcvmDS:41) D MsgLenAvail 10i 0 overlay(QmhrcvmDS:45) D ReplaceData 100a overlay(QmhrcvmDS:49) /Endif /If Defined(QmhrdQm) //--------------------------------------------------------- D QmhrdQm PR extpgm('QMHRDQM ') Get q Entry Db like(QmhrdQmDS) Receiver D Options(*varsize) D 10i 0 const Length D 8a const Api Format D 20a Dtaq and Lib Db like(RDQS0200DS) Options(*varsize) Key Information D const D 10i 0 const Key Info Length D 8a const Information Db like(ApiErrDS) Options(*varsize) Error Parm // parms for QMHRDQM retrieve dataq entries D QmhrdQmDS ds Qualified based(QMHRDQMPtr) D BytesReturned 10i 0 overlay(QmhrdQmDS:1) D BytesAvail 10i 0 overlay(QmhrdQmDS:5) D MsgRtnCount 10i 0 overlay(QmhrdQmDS:9) D MsgAvlCount 10i 0 overlay(QmhrdQmDS:13) D KeyLenRtn 10i 0 overlay(QmhrdQmDS:17) D KeyLenAvl 10i 0 overlay(QmhrdQmDS:21) D MsgTxtRtn 10i 0 overlay(QmhrdQmDS:25) D MsgTxtAvl 10i 0 overlay(QmhrdQmDS:29) D EntryLenRtn 10i 0 overlay(QmhrdQmDS:33) D EntryLenAvl 10i 0 overlay(QmhrdQmDS:37) D OffsetToEntry 10i 0 overlay(QmhrdQmDS:41) D DtaqLib 10a overlay(QmhrdQmDS:45) /Endif /If Defined(Qmhrmvpm) //--------------------------------------------------------- D Qmhrmvpm PR ExtPgm('QMHRMVPM') D 10a const D 10i 0 const D 4a const D 10a const Ds like(ApiErrDS) /Endif /If Defined(Qmhrtvm) //--------------------------------------------------------- D mMsgLen s 10i 0 inz(%len(QmhrtvmDS)) D QmhrtvmDS ds Qualified inz D MessageRtvLen 10i 0 overlay(QmhrtvmDS:9) length msg retrieved D MessageRtv 232a overlay(QmhrtvmDS:25) message retrieved D Qmhrtvm PR extpgm('QMHRTVM') Retrieve Messages D 256a Message Retrieved D 10i 0 Length Of Message D 8a const Api Format D 7a const Message Indentifier D 20a const Msgf and Lib D 100a const Replacement Data D 10i 0 const Len Of Replace Data D 10a const Substitution Char D 10a const Format Control Char Db like(ApiErrDS) Error Parm /Endif /If Defined(Qmhrtvrq) //--------------------------------------------------------- D Qmhrtvrq PR extpgm('QMHRTVRQ') Retrieve Request Msg Dd like(rtvq0100DS) message information D 10i 0 const length D 8a const format name Db 10a const message type D 4a message key Db like(ApiErrDS) Error Parm D rtvq0100DS ds Qualified D BytesReturned 10i 0 overlay(rtvq0100DS:1) D BytesAvail 10i 0 overlay(rtvq0100DS:5) D MsgKey 4a overlay(rtvq0100DS:9) D Reserved 20a overlay(rtvq0100DS:13) D MsgLenReturn 10i 0 overlay(rtvq0100DS:33) D MsgLenAvail 10i 0 overlay(rtvq0100DS:37) D MsgText 500a overlay(rtvq0100DS:41) D MsgText2 2a overlay(MsgText:1) D MsgText6 6a overlay(Msgtext:1) D MsgKey s 4a D MsgType s 10a /Endif /If Defined(Qmhsndbm) //--------------------------------------------------------- D Qmhsndbm PR extpgm('QMHSNDBM') Send Break Message D 70a Text D 10i 0 const Length D 10a const Type D 20a dim(50) Msgq Array D 10i 0 const Msg Length D 20a const Msg Reply Queue Db like(ApiErrDS) Error Parm /Endif /If Defined(Qmhsndpm) //--------------------------------------------------------- D QM_msgid s 7a inz D QM_msgtxt s 75a inz D QM_msgtyp s 10a inz D Qmhsndpm PR extpgm('QMHSNDPM') Send Program Message D 7a const Message ID D 20a const File and Lib D 75a const Text D 10i 0 const Length D 10a const Type D 10a const Queue D 10i 0 const Stack Entry D 4a const Key Db like(ApiErrDS) Error Parm /Endif /If Defined(Qp0zGetEnv) //--------------------------------------------------------- D Qp0zGetEnv PR * ExtProc('Qp0zGetEnv') Get Environment Var D * value options(*string) Environment Var Name D 10i 0 cssid /Endif /If Defined(Qp0zPutEnv) D Qp0zPutEnv PR 10i 0 ExtProc('Qp0zPutEnv') Put Environment Var D * value options(*string) Environment Var Name D 10i 0 cssid /Endif /If Defined(Qp0zDltEnv) D Qp0zDltEnv PR 10i 0 ExtProc('Qp0zDltEnv') Delete Environ Var D * value options(*string) Environment Var Name /Endif /If Defined(QsnGetCsrAdr) //--------------------------------------------------------- D QsnCursorRow s 10i 0 inz D QsnCursorCol s 10i 0 inz //get cursor Row and Column D QsnGetCsrAdr PR 10i 0 extproc('QsnGetCsrAdr') get cursor Row,Colum D QsnCursorRow 10i 0 const D QsnCursorColum 10i 0 const D QsnLowLevelHan 10i 0 const Db like(ApiErrDS) Error Parm /Endif /If Defined(Qspclosp) //--------------------------------------------------------- D Qspclosp PR extpgm('QSPCLOSP') Close Spooled File D 10i 0 Splf Handle Db like(ApiErrDS) Error Parm /Endif /If Defined(Qspcrtsp) //--------------------------------------------------------- D Qspcrtsp PR extpgm('QSPCRTSP') Create Spooled File D 10i 0 Splf Handle Db like(QusrsplaDS) Attributes Db like(ApiErrDS) Error Parm /Endif /If Defined(Qspgetsp) //--------------------------------------------------------- D Qspgetsp PR extpgm('QSPGETSP') Get Spooled Data D 10i 0 Splf Handle D 20a Space Name and Lib D 8a const Api Format D 10i 0 Ordinal Number D 10a const End Of Open Db like(ApiErrDS) Error Parm /Endif /If Defined(Qspopnsp) //--------------------------------------------------------- D Qspopnsp PR extpgm('QSPOPNSP') Open Spool File D 10i 0 Splf Handle D 26a const Qualified Job D 16a Internal Job ID D 16a Internal Spool Num D 10a const Spool File Name D 10i 0 const Spool File Num D 10i 0 const Number Of Buffers Db like(ApiErrDS) Error Parm /Endif /If Defined(Qspputsp) //--------------------------------------------------------- D Qspputsp PR extpgm('QSPPUTSP') Put Splf Data D 10i 0 Splf Handle D 20a Space Name and lib Db like(ApiErrDS) Error Parm /Endif /If Defined(Qsprilsp) //--------------------------------------------------------- D Qsprilsp PR extpgm('QSPRILSP') Get Last Splf Attrib Db like(LastSplfInfoDS) Return Variable D 10i 0 const Return Length D 8a const Api Format Db like(ApiErrDS) Error Parm /Endif /If Defined(QsQchks) //--------------------------------------------------------- // Execute QSQCHKS sql API to verify sql statement syntax. D qsQchks PR extpgm('QSQCHKS') D i_SqlStmt 32767a Const options(*varsize) D i_SqlStmtLen 10i 0 Const D i_NumRcds 10i 0 Const D i_Language 10a Const D i_Options 32767a Const options(*varsize) D o_stmtInf 32767a options(*varsize) D i_StmtInfLen 10i 0 Const D o_numRcdsPrc 10i 0 Db like(ApiErrDS) D SqlOptionDS ds Qualified D NumberOfKeys 10i 0 inz(1) D KeyValue 10i 0 inz(1) D LengthOfData 10i 0 inz(10) D Data 10a inz('*SYS') D SqlStmtInfoDS ds Qualified inz D MsgFile 10a D MsgFileLib 10a D NumberOfStmt 10i 0 D BytesReturned 10i 0 DFirstByteRecNum 10i 0 DFirstByteColNum 10i 0 D LastByteRecNum 10i 0 D LastByteColNum 10i 0 D ErrorRecNum 10i 0 D ErrorColNum 10i 0 D MessageID 7a D SqlState 5a D LenMsgRplTxt 10i 0 D MsgReplaceText 128a /Endif /If Defined(Quscmdln) //--------------------------------------------------------- D Quscmdln PR extpgm('QUSCMDLN') Command Line /Endif /If Defined(Quscrtus) //--------------------------------------------------------- D Quscrtus PR extpgm('QUSCRTUS') Create User Space D 20a Space Name and Lib D 10a const Extended Attribute D 10i 0 const Length Of Space D 1a const Hex0 Initialize D 10a const Use Authority D 50a const Text D 10a const Replace Object Db like(ApiErrDS) Error Parm D 10a const Domain D 10i 0 const Transfer Size D 1a const Optimum Space /Endif /If Defined(Quscusat) //--------------------------------------------------------- D Quscusat PR extpgm('QUSCUSAT') Change Space Attrib D 10a Return Library D 20a Space Name and Lib Db like(QuscusatDS) Key to change Db like(ApiErrDS) Error Parm D QuscusatDS ds qualified D NumberRecs 10i 0 overlay(QuscusatDS:1) inz(1) D Key 10i 0 overlay(QuscusatDS:5) inz(3) D LengthOfData 10i 0 overlay(QuscusatDS:9) inz(1) D AutoExtend 1a overlay(QuscusatDS:13) inz('1') Auto Extensibility /Endif /If Defined(Qusdltus) //--------------------------------------------------------- D Qusdltus PR extpgm('QUSDLTUS') Delete User Space D 20a Space Name and Lib Db like(ApiErrDS) Error Parm /Endif /If Defined(Qlidlto) //--------------------------------------------------------- D Qlidlto PR extpgm('QLIDLTO') Delete Object D 20a const Name and Lib D 10a const Type D 10a const Auxillary Stg D 1a const Remove Message Db like(ApiErrDS) Error Parm /Endif /If Defined(Quslfld) //--------------------------------------------------------- D Quslfld PR extpgm('QUSLFLD') Field Descriptions D 20a Space Name and Lib D 8a const Api Format D 20a const File and Lib D 10a const Record Format D 1a const Overrides Db like(ApiErrDS) Error Parm // data structure for Quslfld user space list entries D QuslfldDS ds Qualified based(QuslfldPtr) D FieldName 10a overlay(QuslfldDS:1) D FieldType 1a overlay(QuslfldDS:11) D OutputPosition 10i 0 overlay(QuslfldDS:13) D InputPosition 10i 0 overlay(QuslfldDS:17) D FieldLengthA 10i 0 overlay(QuslfldDS:21) D FieldLengthN 10i 0 overlay(QuslfldDS:25) D DecimalPos 10i 0 overlay(QuslfldDS:29) D FieldText 50a overlay(QuslfldDS:33) D AliasName 10a overlay(QuslfldDS:223) D ScreenFieldRow 10i 0 overlay(QuslfldDS:449) D ScreenFieldCol 10i 0 overlay(QuslfldDS:453) /Endif /If Defined(Qusljob) //--------------------------------------------------------- D Qusljob PR extpgm('QUSLJOB ') List Jobs D 20a Space Name and Lib D 8a const Api Format D 26a Qualified Job Name D 10a Status Db like(ApiErrDS) Error Parm D 1a const Type Jobs D 10i 0 Number of keys D 16a integer key array // data structure to retrieve job list entries D QusljobDS ds Qualified based(QusljobPtr) D JobName 10a overlay(QusljobDS:1) D UserName 10a overlay(QusljobDS:11) D JobNumber 6a overlay(QusljobDS:21) D IntJobID 16a overlay(QusljobDS:27) D JobStatus 8a overlay(QusljobDS:43) D JobType 1a overlay(QusljobDS:53) D KeyReturnCtn 10i 0 overlay(QusljobDS:61) D CurrUser 10a overlay(QusljobDS:101) /Endif /If Defined(Quslmbr) //--------------------------------------------------------- D Quslmbr PR extpgm('QUSLMBR') List Members D 20a Space Name and Lib D 8a const Api Format D 20a const File and Lib D 10a const Member Name D 1a const Override Db like(ApiErrDS) Error Parm // list members information. D QuslmbrDS ds Qualified based(QuslmbrPtr) D MemberName 10a overlay(QuslmbrDS:1) D MbrType 10a overlay(QuslmbrDS:11) D CreateDateTime 13a overlay(QuslmbrDS:21) D ChangeDateTime 13a overlay(QuslmbrDS:34) D Text 50a overlay(QuslmbrDS:47) D ccsid 10i 0 overlay(QuslmbrDS:97) /Endif /If Defined(Quslobj) //--------------------------------------------------------- D Quslobj PR extpgm('QUSLOBJ') List Objects D 20a Space Name and Lib D 8a const Api Format D 20a const Object and Lib D 10a const Object Type Db like(ApiErrDS) Error Parm D QuslobjDS ds Qualified based(QuslobjPtr) D ObjectName 10a overlay(QuslobjDS:1) D ObjectLib 10a overlay(QuslobjDS:11) D ObjectType 10a overlay(QuslobjDS:21) D ObjectAttrb 10a overlay(QuslobjDS:32) D ObjectText 50a overlay(QuslobjDS:42) D CreateStamp 8a overlay(QuslobjDS:125) D CreatedByUser 10a overlay(QuslobjDS:216) D LastUseStamp 8a overlay(QuslobjDS:533) D NumDaysUsed 10i 0 overlay(QuslobjDS:549) D ObjectSize 10i 0 overlay(QuslobjDS:577) D MultiplySize 10i 0 overlay(QuslobjDS:581) /Endif /If Defined(Quslrcd) //--------------------------------------------------------- D Quslrcd PR extpgm('QUSLRCD') List Record Formats D 20a Space Name and Lib D 8a const Api Format D 20a const File and Lib D 1a const Overrides Db like(ApiErrDS) Error Parm D QuslrcdDS ds Qualified based(QuslrcdPtr) D RecordFormat 10a overlay(QuslrcdDS:1) D FormatText 50a overlay(QuslrcdDS:33) /Endif /If Defined(Quslspl) //--------------------------------------------------------- D Quslspl PR extpgm('QUSLSPL') List Spooled Files D 20a Space Name and Lib D 8a const Api Format D 10a const User Profile D 20a Outq and Lib D 10a const Form Type D 10a const User Data Db like(ApiErrDS) Error Parm D QuslsplDS ds Qualified based(QuslsplPtr) D InternalJobID 16a overlay(QuslsplDS:51) D InternalSplfID 16a overlay(QuslsplDS:67) //--------------------------------------------------------- // DS of the spooled file attributes return variable. D splf0300DS ds Qualified based(splf0300Ptr) D JobName 10a overlay(splf0300DS:1) D UserID 10a overlay(splf0300DS:11) D JobNo 6a overlay(splf0300DS:21) D SplfName 10a overlay(splf0300DS:27) D SplfNum 10i 0 overlay(splf0300DS:37) D Status 10i 0 overlay(splf0300DS:41) D CreateYYMMDD 6a overlay(splf0300DS:46) D CreateHHMMSS 6a overlay(splf0300DS:52) D UsrDta 10a overlay(splf0300DS:69) D FormType 10a overlay(splf0300DS:79) D Outq 10a overlay(splf0300DS:89) D OutqLib 10a overlay(splf0300DS:99) D ASP 10i 0 overlay(splf0300DS:109) D SplfSize 10i 0 overlay(splf0300DS:113) D MultiplySize 10i 0 overlay(splf0300DS:117) D PageNum 10i 0 overlay(splf0300DS:121) D Copies 10i 0 overlay(splf0300DS:125) D Priority 1a overlay(splf0300DS:129) /Endif /If Defined(Quslspl0200) //--------------------------------------------------------- D Quslspl PR ExtPgm('QUSLSPL ') List Spooled Files D 20a Space Name and Lib D 8a const Type Format D 10a const User D 20a Outq and Lib D 10a const Form Type D 10a const User Data Db like(ApiErrDS) Error parm D 26a const not used job info Db like(KeysToReturn) D 10i 0 Number of keys D QuslsplDS ds Qualified based(QuslsplPtr) D NumFieldRtn 10i 0 overlay(QuslsplDS:1) 0200 format only // Define ds to extract repeating key value fields. D splf0200DS ds Qualified based(splf0200Ptr) D LenghtOfInfo 10i 0 overlay(splf0200DS:1) D KeyReturned 10i 0 overlay(splf0200DS:5) D TypeOfData 1a overlay(splf0200DS:9) D Reserved 3a overlay(splf0200DS:10) D LenOfData 10i 0 overlay(splf0200DS:13) D KeyData 17a overlay(splf0200DS:17) /Endif /If Defined(Qusptrus) //--------------------------------------------------------- D Qusptrus PR extpgm('QUSPTRUS') Retrieve Pointer D 20a Space Name and Lib D * Pointer Db like(ApiErrDS) Error Parm /Endif /If Defined(Qusrjobi) //--------------------------------------------------------- D Qusrjobi PR extpgm('QUSRJOBI') Retrieve Job Info Db 200a options(*varsize) Receiver D 10i 0 const Receiver Length D 8a const Api Format D 26a const Qualified Job Name D 16a const Internal Job Num Db like(ApiErrDS) Error Parm /Endif /If Defined(Qusrmbrd) //--------------------------------------------------------- D Qusrmbrd PR extpgm('QUSRMBRD') Retrieve Mbr Desc D 500a options(*varsize) Receiver D 10i 0 const Length Of Receiver D 8a const Api Format D 20a const File and Lib D 10a const Member Name D 1a const Overrides Db like(ApiErrDS) Error Parm /Endif /If Defined(Qusrobjd) //--------------------------------------------------------- D Qusrobjd PR extpgm('QUSROBJD') Object Description Db 467a options(*varsize) Receiver D 10i 0 const Length Of Receiver D 8a const Api Format D 20a const Object and Lib D 10a const Object Type Db like(ApiErrDS) Error Parm /Endif /If Defined(Qusrspla) //--------------------------------------------------------- D Qusrspla PR extpgm('QUSRSPLA') Get Splf Attributes Db like(QusrsplaDS) Return Variable D 10i 0 const Return Length D 8a const Api Format D 26a const Qualified Job D 16a const Internal Job ID D 16a const Internal Spool Num D 10a const Spool File Name D 10i 0 const Spooled File Num Db like(ApiErrDS) Error Parm //--------------------------------------------------------- // DS of the spooled file attributes return variable. D QusrsplaDS ds Qualified inz D IntJobId 16a overlay(QusrsplaDS:17) Internal Job Identif D IntSplfId 16a overlay(QusrsplaDS:33) Internal Splf Ident D JobName 10a overlay(QusrsplaDS:49) D UserID 10a overlay(QusrsplaDS:59) D JobNo 6a overlay(QusrsplaDS:69) D SplfName 10a overlay(QusrsplaDS:75) D SplfNum 10i 0 overlay(QusrsplaDS:85) D FormType 10a overlay(QusrsplaDS:89) D UsrDta 10a overlay(QusrsplaDS:99) D Status 10a overlay(QusrsplaDS:109) D Hold 10a overlay(QusrsplaDS:129) Hold before write D Save 10a overlay(QusrsplaDS:139) Save After write D PageNum 10i 0 overlay(QusrsplaDS:149) D CurPage 10i 0 overlay(QusrsplaDS:153) D Copies 10i 0 overlay(QusrsplaDS:173) D LinesPerInch 10i 0 overlay(QusrsplaDS:181) D CharPerInch 10i 0 overlay(QusrsplaDS:185) D Priority 2a overlay(QusrsplaDS:189) D Outq 10a overlay(QusrsplaDS:191) D OutqLib 10a overlay(QusrsplaDS:201) D CreateYY 2a overlay(QusrsplaDS:212) D CreateMM 2a overlay(QusrsplaDS:214) D CreateDD 2a overlay(QusrsplaDS:216) D CreateTimeHH 2a overlay(QusrsplaDS:218) D CreateTimeMM 2a overlay(QusrsplaDS:220) D CreateTimeSS 2a overlay(QusrsplaDS:222) D PageRotate 10i 0 overlay(QusrsplaDS:553) Page rotation D Duplex 10a overlay(QusrsplaDS:561) Print Both Sides D FrontOverlay 10a overlay(QusrsplaDS:737) D FrontOverLib 10a overlay(QusrsplaDS:747) D LastUsedYY 2a overlay(QusrsplaDS:2871) D LastUSedMM 2a overlay(QusrsplaDS:2873) D LastUsedDD 2a overlay(QusrsplaDS:2875) D ASP 10i 0 overlay(QusrsplaDS:3773) D SplfSize 10i 0 overlay(QusrsplaDS:3777) D MultiplySize 10i 0 overlay(QusrsplaDS:3781) /Endif /If Defined(Qusrusat) //--------------------------------------------------------- // Retrieve User Space Attributes D Qusrusat PR extpgm('QUSRUSAT') User Space Attrib Db like(QusrusatDS) Receiver D 10i 0 const Length D 8a const Api Format D 20a Space Name and Lib Db like(ApiErrDS) Error Parm // --return values for user space attributes-- D QusrusatDS ds Qualified inz D BytesReturned 10i 0 overlay(QusrusatDS:1) D BytesAvailable 10i 0 overlay(QusrusatDS:5) D SpaceSize 10i 0 overlay(QusrusatDS:9) D Extendability 1a overlay(QusrusatDS:13) D InitialValue 1a overlay(QusrusatDS:14) D SpaceLibrary 10a overlay(QusrusatDS:15) /Endif /If Defined(Qwccvtdt) //---------------------------------------------------------- D Qwccvtdt PR extpgm('QWCCVTDT') Api Date Converter D 10a const From Format D 8a Api Date Stamp D 10a const To Format Db 16a To Date Dd like(ApiErrDS) Error Parm /Endif /If Defined(Qwclobjl) //--------------------------------------------------------- D Qwclobjl PR extpgm('QWCLOBJL') Object Locks D 20a Space Name and Lib D 8a const Api Format D 20a Object and Lib D 10a Object Type D 10a Member Name Db like(ApiErrDS) Error Parm // ds out the information returned from the user space D QwclobjlDS ds Qualified based(QwclobjlPtr) D JobName 10a overlay(QwclobjlDS:1) D JobUser 10a overlay(QwclobjlDS:11) D JobNumb 6a overlay(QwclobjlDS:21) D LockState 10a overlay(QwclobjlDS:27) D LockStatus 10i 0 overlay(QwclobjlDS:37) D LockType 10i 0 overlay(QwclobjlDS:41) D MemberName 10a overlay(QwclobjlDS:45) D Share 1a overlay(QwclobjlDS:55) D LockScope 1a overlay(QwclobjlDS:56) D ThreadID 8a overlay(QwclobjlDS:57) /Endif /If Defined(Qwcrtvca) //--------------------------------------------------------- D Qwcrtvca PR extpgm('QWCRTVCA') Retrieve Current Atr D 150a Receiver D 10i 0 const Length Of Receiver D 8a const Api Format D 10i 0 const Number Of Keys D 12a List Of Keys Db like(ApiErrDS) Error Parm /Endif /If Defined(Qwdrjobd) //--------------------------------------------------------- D Qwdrjobd PR extpgm('QWDRJOBD') Load Jobd Data Dd 1000a options(*varsize) Receiver D 10i 0 const Receiver Length D 8 const Api Format D 20 const Jobd and Lib Db like(ApiErrDS) Error Parm /Endif /If Defined(Qwtchgjb) //--------------------------------------------------------- D Qwtchgjb PR extpgm('QWTCHGJB') Change Current Job D 26a const Job Name *=current D 16a const Internal Identifier D 8a const Api Format D 150a Receiver Db like(ApiErrDS) Error Parm /Endif /If defined(Sds) //--------------------------------------------------------- D Sds D ProgId 10a /Endif /If defined(Setbts) //--------------------------------------------------------- D SetBts PR extproc('_SETBTS') MI Set Bits D 1a Bit String D 10u 0 value Bit Offset /Endif /If defined(SourceDS) //--------------------------------------------------------- // Define fields from the different spec types. D SourceDS ds Qualified inz D SeqNum4A 1 4a D SeqNum6 1 6s 2 D SrcChgDat 7 12s 0 D CompileArray 13 14a D SpecType 18 18a D Asterisk 19 19a D SlashComment 19 20a D FreeForm 19 27a D FreeSource 19 92a D Source112 13 112a // F specs // rpg 4 locations D fFileName 19 28a D fUsage 29 29a I U O D fEorF 34 34a E or F D fDevice 48 55a DISK, PRINTER, etc // rpg 3 locations D fFileName3 19 26a z D fUsage3 27 27a I U O D fEorF3 31 31a E or F D fDevice3 52 58a DISK, PRINTER, etc D fBeingRenamed3 31 40a KRENAME D fKeyWord3 65 71a KRENAME D fRenamed3 72 81a KRENAME // D specs D dFieldName 19 33a D dDSext 34 34a D dDS 36 37a D dStandAlone 36 36a D dProtoProcedur 35 38a D dAttribute 52 52a D dFromPos 40 44a D dFromPosN 40 44s 0 D dStatusWords 38 45a D dToPos 47 51a D dToPosN 47 51s 0 D dDecimalPos 53 54a D dKeyWord 56 92a // I specs D iAttribute 48 48a D iFromPos 49 53a D iToPos 54 58a D iDecimalPos 59 60a D iExternalFld 33 42a D iFieldName 61 74a // C specs D Conditioning 22 23a D Factor1 24 37a D OpCode 38 47a D Opcode1 1a overlay(OpCode:1) D Opcode2 2a overlay(OpCode:1) D Opcode3 3a overlay(OpCode:1) D Opcode4 4a overlay(OpCode:1) D Opcode6 6a overlay(OpCode:1) D Factor2 48 61a D ExtendFactor2 48 92a D ResultField 62 75a D FieldLength 76 80a D FieldLengthN 76 80s 0 D DecimalPos 81 82a D ResultingInd 83 88a D HIind 2a overlay(ResultingInd:1) D LOind 2a overlay(ResultingInd:3) D EQind 2a overlay(ResultingInd:5) D SrcComment 93 112a // 0 specs D oComment 19 19a D oAndOr 28 31a D oLineType 29 29a D oIndicator 33 41a D oSpaceB 52 54a D oSpaceA 55 57a D oSkipB 58 60a D oSkipA 61 63a D oEname 42 55a D oEditCode 56 56a D oEndPos 59 63a D oConstant 65 92a D CopyStatement 25 60a D Source57 19 75a D Source63 13 75a // DDS specs D ddsCondIn1 21 22a D ddsCondIn2 24 25a D ddsCondIn3 27 28a D ddsParenthesis 61 61a D ddsField 57 68a D ddsField2 57 58a D ddsField4 57 60a D ddsField5 57 61a D ddsField6 57 62a D ddsField7 57 63a D ddsField9 57 65a D ddsField10 57 66a /Endif /If defined(SqlCLI) //--------------------------------------------------------- // SQL Column types D Sql_C_CHAR c const( 1) D Sql_C_NUMERIC c const( 2) D Sql_C_DECIMAL c const( 3) D Sql_C_LONG c const( 4) D Sql_C_SHORT c const( 5) D Sql_C_FLOAT c const( 6) D Sql_C_REAL c const( 7) D Sql_C_DOUBLE c const( 8) D Sql_C_DATE c const( 91) D Sql_C_TIME c const( 92) D Sql_C_TIMESTAMP... D c const( 93) // SQl constants D SQLNTS c const(-3) D SQLTRUE c const( 1) D SQLDROP c const( 1) D COMMIT_NONE c const( 1) D SYS_NAMING c const(10002) D ATTR_COMMIT c const( 0) D sqlNumRcd s 10i 0 inz D retCode s 10i 0 inz D henv s 10i 0 inz D hdbc s 10i 0 inz D server s 10a inz('*LOCAL') D hstmt s 10i 0 inz D cOptVal s 10i 0 inz // Retrieve Error Information D sqlState s 5a inz D pfNativeErr s 10i 0 inz D szErrMsg s 256a inz D cbErrMsg s 5i 0 inz // Set environment attribute D envAttr s 10i 0 inz //--------------------------------------------------------- // Allocate Environment Handle D SQLAllocEnv PR 10i 0 extproc('SQLAllocEnv') D o_phenv * value D SQLBindCol PR 10i 0 extproc('SQLBindCol') D i_hstmt 10i 0 value D i_iCol 5i 0 value D i_FcType 5i 0 value D o_rgbValue * value VOID * D i_cbValueMax 10i 0 value D o_pcbValue * value SQLINTEGER * D SQLSetEnvAttr PR 10i 0 extproc('SQLSetEnvAttr') D i_henv 10i 0 value D i_attr 10i 0 value D i_PValue * value D i_StrLen 10i 0 value // Allocate Connection Handle DSQLAllocConnect PR 10i 0 extproc('SQLAllocConnect') D i_henv 10i 0 value D o_phdbc * value // Connect to a Data Source D SQLConnect PR 10i 0 extproc('SQLConnect') D i_hdbc 10i 0 value D i_szDSN * value options(*string) D i_cbDSN 5i 0 value D i_szUID * value options(*string) D i_cbUID 5i 0 value D i_szAuthStr * value options(*string) D i_cbAuthStr 5i 0 value D SQLSetConnectOption... D PR 10i 0 extproc('SQLSetConnectOption') D i_hdbc 10i 0 value D i_FOption 5i 0 value D i_vParam * value // Allocate a Statement Handle D SQLAllocStmt PR 10i 0 extproc('SQLAllocStmt') D i_hdbc 10i 0 value D o_phstmt * value D SQLFetch PR 10i 0 extproc('SQLFetch') D i_hstmt 10i 0 value D SQLExecDirect PR 10i 0 extproc('SQLExecDirect') D i_hstmt 10i 0 value D i_szSqlStr * value options(*string) D i_cbSqlStr 10i 0 value // Free (or Reset) a Statement Handle D SQLFreeStmt PR 10i 0 extproc('SQLFreeStmt') D i_hstmt 10i 0 value D i_FOption 5i 0 value D SQLDisconnect PR 10i 0 extproc('SQLDisconnect') D i_hdbc 10i 0 value D SQLFreeConnect PR 10i 0 extproc('SQLFreeConnect') D i_hdbc 10i 0 value D SQLFreeEnv PR 10i 0 extproc('SQLFreeEnv') D i_henv 10i 0 value // Retrieve Error Information D SQLError PR 10i 0 extproc('SQLError') D i_henv 10i 0 value D i_hdbc 10i 0 value D i_hstmt 10i 0 value D o_szSqlState * value D o_pfNativeErr * value D o_szErrMsg * value D o_cbErrMsgMax 5i 0 value D o_pcbErrMsg * value D SQLPrepare PR 10i 0 extproc('SQLPrepare') D i_hstmt 10i 0 value D i_szSqlStr * value options(*string) SQLCHAR * D i_cbSqlStr 5i 0 value => SQLNTS /Endif /If defined(System) //--------------------------------------------------------- D System PR 10i 0 extproc('system') CL Command Processor D * value options(*string) /Endif /If defined(Tstbts) //--------------------------------------------------------- D tstbts PR 10i 0 extproc('_TSTBTS') MI Test Bits D * value options(*string) Bit String D 10u 0 value Bit Offset /Endif /If Defined(UserSpaceHeaderDS) //--------------------------------------------------------- // Get user space list info from header section. D GenericHeader ds Qualified based(GenericHeaderPtr) D SizeOfUsrSpc 10i 0 overlay(GenericHeader:105) D OffSetToHeader 10i 0 overlay(GenericHeader:117) D OffSetToList 10i 0 overlay(GenericHeader:125) D ListEntryCount 10i 0 overlay(GenericHeader:133) D ListEntrySize 10i 0 overlay(GenericHeader:137) /Endif /If Defined(UserSpaceHeaderDS2) //--------------------------------------------------------- // Get second user space list info from header section. D GenericHeader2 ds likeds(GenericHeader) D based(GenericHeaderPtr2) /Endif /If Defined(f_AddSortKey) //--------------------------------------------------------- Df_AddSortKey PR 16a D KeyStartPos 10i 0 const D KeyStringSize 10i 0 const D KeyDataType 10i 0 const options(*nopass) D KeySortOrder 10i 0 const options(*nopass) /Endif /If Defined(f_BringDataBaseRecords) //--------------------------------------------------------- D f_BringDataBaseRecords... D PR D i_File 10a const D i_Lib 10a const D i_Member 10a const D i_NumRecs 10i 0 /Endif /If Defined(f_BuildString) //--------------------------------------------------------- D f_BuildString... D PR 2048a opdesc D String 2048a const options(*varsize) D Parm1 100a const options(*nopass:*varsize) D Parm2 100a const options(*nopass:*varsize) D Parm3 100a const options(*nopass:*varsize) D Parm4 100a const options(*nopass:*varsize) D Parm5 100a const options(*nopass:*varsize) D Parm6 100a const options(*nopass:*varsize) D Parm7 100a const options(*nopass:*varsize) D Parm8 100a const options(*nopass:*varsize) D Parm9 100a const options(*nopass:*varsize) D Parm10 100a const options(*nopass:*varsize) D Parm11 100a const options(*nopass:*varsize) D Parm12 100a const options(*nopass:*varsize) D Parm13 100a const options(*nopass:*varsize) D Parm14 100a const options(*nopass:*varsize) D Parm15 100a const options(*nopass:*varsize) D Parm16 100a const options(*nopass:*varsize) D Parm17 100a const options(*nopass:*varsize) D Parm18 100a const options(*nopass:*varsize) D Parm19 100a const options(*nopass:*varsize) D Parm20 100a const options(*nopass:*varsize) D Parm21 100a const options(*nopass:*varsize) D Parm22 100a const options(*nopass:*varsize) D Parm23 100a const options(*nopass:*varsize) D Parm24 100a const options(*nopass:*varsize) D Parm25 100a const options(*nopass:*varsize) D Parm26 100a const options(*nopass:*varsize) D Parm27 100a const options(*nopass:*varsize) D Parm28 100a const options(*nopass:*varsize) D Parm29 100a const options(*nopass:*varsize) D Parm30 100a const options(*nopass:*varsize) /Endif /If Defined(f_Centertext) //--------------------------------------------------------- D f_CenterText... D PR 100a opdesc D 100a const options(*varsize) D 3u 0 const options(*nopass) /Endif /If Defined(f_CheckMember) //--------------------------------------------------------- // validate member exists D f_CheckMember... D PR D 20a const File and Lib D 10a const member /Endif /If Defined(f_CheckObject) //--------------------------------------------------------- // validate Object exists D f_CheckObject... D PR D 20a const Object and Lib D 10a const Object type /Endif /If Defined(f_DayName) //--------------------------------------------------------- D f_DayName PR 9a D D Const Options(*NoPass) /Endif /If Defined(f_DayOfWeekNumber) //--------------------------------------------------------- D f_DayOfWeekNumber... D PR 3u 0 D D Const Options(*NoPass) /Endif /If Defined(f_DecodeApiTimeStamp) //--------------------------------------------------------- D f_DecodeApiTimeStamp... D PR 16a API time stamp DS D 8a API Date Stamp /Endif /If Defined(f_DelayJobSeconds) //--------------------------------------------------------- D f_DelayJobSeconds... D PR DelayJobNumberofSec D 5u 0 const seconds to delay /Endif /If Defined(f_DltOvr) //--------------------------------------------------------- D f_DltOvr PR D SpooledFile 10a const /Endif /If Defined(f_DupFileToQtemp) //--------------------------------------------------------- D f_DupFileToQtemp... D PR D 10a const file name D 10a const library name D 1a const options(*nopass) override (Y N) /Endif /If Defined(f_ExecuteFileOptions) //--------------------------------------------------------- D f_ExecuteFileOptions... D PR D 1p 0 Option Selected D 10a File D 10a const Lib D 10a const Record Format D 10a program id /Endif /If Defined(f_ExecuteJobOptions) //--------------------------------------------------------- D f_ExecuteJobOptions... D PR D 1p 0 Option Selected D 10a Job Name D 10a User Name D 6a Job Number D 10a program id /Endif /If Defined(f_ExecuteObjectOptions) //--------------------------------------------------------- D f_ExecuteObjectOptions... D PR D 1p 0 Option Selected D 10a Object Name D 10a Object Lib D 10a Object Type D 10a program id /Endif /If Defined(f_ExecuteSplfOptions) //--------------------------------------------------------- D f_ExecuteSplfOptions... D PR D 1a Option Selected D 10a Spool File Name D 6a Spool File Number D 10a Job Name D 10a User Name D 6a Job Number D 10a program id /Endif /If Defined(f_FakeEditWord) //--------------------------------------------------------- D f_FakeEditWord... D PR 28a opdesc D 288a options(*varsize) date/time format D 1a const date or time /Endif /If Defined(f_GetCardFace) //--------------------------------------------------------- D f_GetCardFace PR 2a D gnumber 3u 0 /Endif /If Defined(f_GetCardColor) //--------------------------------------------------------- D f_GetCardColor PR 1a hex color attribute D 1a suite (H D C S) /Endif /If Defined(f_GetRowColumn) //--------------------------------------------------------- D f_GetRowColumn PR 6a D 10a const field name D 10a file D 10a lib D 10a RcdFmt D CsrRowColDS ds D CsrRow 3s 0 inz(0) D CsrCol 3s 0 inz(0) /Endif /If Defined(f_GetDate13) //--------------------------------------------------------- D f_GetDate13 PR 8p 0 From 13 Digit API D 13a const /Endif /If Defined(f_GetFileUtil) //--------------------------------------------------------- D f_GetFileUtil... D PR 6a Set DBU,DFU,WRKDB /Endif /If Defined(f_GetLastSplfInfo) //--------------------------------------------------------- D f_GetLastSplfInfo... D PR 70a return DS // DS of the spooled file attributes return variable. D LastSplfInfoDS... D ds Qualified inz D SplfName 10a overlay(LastSplfInfoDS:9) D JobName 10a overlay(LastSplfInfoDS:19) D UserID 10a overlay(LastSplfInfoDS:29) D JobNo 6a overlay(LastSplfInfoDS:39) D SplfNum 10i 0 overlay(LastSplfInfoDS:45) D JobSysName 8a overlay(LastSplfInfoDS:49) D CreateCYYMMDD 7a overlay(LastSplfInfoDS:57) D CreateHHMMSS 6a overlay(LastSplfInfoDS:65) /Endif /If Defined(f_GetQual) //--------------------------------------------------------- D f_GetQual PR 21a D input20 20a const Object and Lib /Endif /If Defined(f_GetRandom) //--------------------------------------------------------- D f_GetRandom PR 3u 0 D 3u 0 const upper limit value /Endif /If Defined(f_GetTime13) //--------------------------------------------------------- D f_GetTime13 PR 6p 0 From 13 Digit API D 13a /Endif /If Defined(f_IsValidFile) //--------------------------------------------------------- // validate file exists Df_IsValidFile PR n D 10a const file D 10a const lib /Endif /If Defined(f_IsValidMbr) //--------------------------------------------------------- // validate member exists D f_IsValidMbr PR n D 10a const file D 10a const lib D 10a const options(*nopass) member /Endif /If Defined(f_IsValidMemberType) //--------------------------------------------------------- // validate member exists D f_IsValidMemberType... D PR n D 20a File and Lib D 10a const member D 10a const member type 1 D 10a const options(*nopass) member type 2 D 10a const options(*nopass) member type 3 D 10a const options(*nopass) member type 4 /Endif /If Defined(f_IsValidObj) //--------------------------------------------------------- // validate object exists D f_IsValidObj PR n D 10a const Object D 10a const Library D 10a const object type /Endif /If Defined(f_KQJcount10) //--------------------------------------------------------- D f_KQJcount10 PR 3u 0 D 3u 0 const /Endif /If Defined(f_MondaysDate) //--------------------------------------------------------- D f_MondaysDate... D PR D D D Const Options(*NoPass) /Endif /If Defined(f_OutFileAddPfm) //--------------------------------------------------------- D f_OutFileAddPfm... D PR D i_NewFileQual 20a const D i_NewMbr 10a const D i_MbrType 8a const D i_MbrText 50a const options(*nopass) D i_OrgFileQual 20a const options(*nopass) Org File and Lib D i_OrgMbr 10a const options(*nopass) /Endif /If Defined(f_OutFileCrtDupObj) //--------------------------------------------------------- D f_OutFileCrtDupObj... D PR D 20a const Out File and Lib D 22a const Member options D 10a const From object /Endif /If Defined(f_OvrPrtf) //--------------------------------------------------------- D f_OvrPrtf PR D SpooledFile 10a const D Outq 10a const options(*omit) D UsrDta 10a const options(*nopass) /Endif /If Defined(f_Parm) //--------------------------------------------------------- D f_Parm PR 256a opdesc D Parm 256a const options(*varsize) D SizeBif 3u 0 const options(*nopass) /Endif /If Defined(f_ParmListCount) //--------------------------------------------------------- D f_ParmListCount... D PR 5u 0 D 2a parm string /Endif /If Defined(f_Pgm) //--------------------------------------------------------- D f_Pgm PR 4096a D Program 10a const D Lib 10a const D Parm1 256a const options(*nopass) D Parm2 256a const options(*nopass) D Parm3 256a const options(*nopass) D Parm4 256a const options(*nopass) D Parm5 256a const options(*nopass) D Parm6 256a const options(*nopass) D Parm7 256a const options(*nopass) D Parm8 256a const options(*nopass) D Parm9 256a const options(*nopass) D Parm10 256a const options(*nopass) /Endif /If Defined(f_QgyolObjSortKey) //--------------------------------------------------------- Df_QgyolObjSortKey... D PR 12a D StartPos 10i 0 const options(*nopass) D KeyLength 10i 0 const options(*nopass) D DataType 5i 0 const options(*nopass) D SortOrder 1a const options(*nopass) /Endif /If Defined(f_Quscrtus) //--------------------------------------------------------- D f_Quscrtus PR * D 20a Space Name and Lib /Endif /If Defined(f_Qusrmbrd) //--------------------------------------------------------- D f_Qusrmbrd PR 256 Retrieve Mbr Desc D 20a const File and Lib D 10a const Member Name D 8a const Api Format // Extract member information. D QusrmbrdDS ds 256 Qualified inz D File 10a overlay(QusrmbrdDS:9) D Lib 10a overlay(QusrmbrdDS:19) D Member 10a overlay(QusrmbrdDS:29) D Attribute 10a overlay(QusrmbrdDS:39) D MbrType 10a overlay(QusrmbrdDS:49) D CreateDateTime 13a overlay(QusrmbrdDS:59) D Text 50a overlay(QusrmbrdDS:85) D IsSourcePF n overlay(QusrmbrdDS:135) D CurrNumberRecs 10i 0 overlay(QusrmbrdDS:141) D DeletedRecs 10i 0 overlay(QusrmbrdDS:145) D SizeOfData 10i 0 overlay(QusrmbrdDS:149) D SizeOfPath 10i 0 overlay(QusrmbrdDS:153) D ChangeDateTime 13a overlay(QusrmbrdDS:161) D SaveDateTime 13a overlay(QusrmbrdDS:174) DRestoreDateTime 13a overlay(QusrmbrdDS:187) D LastUseCount 10i 0 overlay(QusrmbrdDS:213) DLastUseDateTime 13a overlay(QusrmbrdDS:217) D SizeOfDataMLT 10i 0 overlay(QusrmbrdDS:233) D SizeOfPathMLT 10i 0 overlay(QusrmbrdDS:237) D CCSID 10i 0 overlay(QusrmbrdDS:241) /Endif /If Defined(f_Qusrobjd) //--------------------------------------------------------- D f_Qusrobjd PR 467 Retrieve Object desc D 20a const Object and Lib D 10a const Oblect Type D 8a const options(*nopass) Api Format // Extract Object information. D QusrObjDS ds Qualified inz D Object 10a overlay(QusrObjDS:9) D Lib 10a overlay(QusrObjDS:19) D ReturnLib 10a overlay(QusrObjDS:39) D ExtendedAttr 10a overlay(QusrObjDS:91) D CreateDateTime 13a overlay(QusrObjDS:65) D ChangeDateTime 13a overlay(QusrObjDS:78) D Text 50a overlay(QusrObjDS:101) D SourceFile 10a overlay(QusrObjDS:151) D SourceLib 10a overlay(QusrObjDS:161) D SourceMbr 10a overlay(QusrObjDS:171) D CreatedByUser 10a overlay(QusrObjDS:220) D LastUsedDate 7a overlay(QusrObjDS:461) CYYMMDD format /Endif /If Defined(f_RmvSflMsg) //----Remove messages from error message subfile------- D f_RmvSflMsg PR D 10a const program name /Endif /If Defined(f_RtvMsgAPI) //--------------------------------------------------------- D f_RtvMsgAPI PR 232a Retrieve messages D ErrMsgid 7a const D MsgReplaceVal 112a const D MsgFileQual 20a const options(*nopass) /Endif /If Defined(f_SbmJob) //--------------------------------------------------------- D f_SbmJob PR D ProgramInfo 4096a options(*varsize) const D jobq 10a const options(*nopass) D jobdesc 10a const options(*nopass) /Endif /If Defined(f_ShuffleDeck) //--------------------------------------------------------- D f_ShuffleDeck PR 2a dim(52) /Endif /If Defined(f_SndCompMsg) //--------------------------------------------------------- D f_SndCompMsg... D PR D 75a const message text /Endif /If Defined(f_SndEscapeMsg) //--------------------------------------------------------- D f_SndEscapeMsg PR Send error messag D 75a value /Endif /If Defined(f_SndSflMsg) //--------------------------------------------------------- D f_SndSflMsg PR D programName 10a const program name D MsgText 75a const message text D pMsgId 7a const options(*nopass) D pMsgFile 10a const options(*nopass) D pMsgLib 10a const options(*nopass) /Endif /If Defined(f_SndStatMsg) //--------------------------------------------------------- D f_SndStatMsg... D PR D 75a const message text /Endif /If Defined(f_System) //--------------------------------------------------------- D f_System PR opdesc CL Command Processor D 2048a const options(*varsize) /Endif //--------------------------------------------------------- /If Defined(p_JCRBNDR) /If Defined(p_JCRBNDRV) D p_JCRBNDRV PR extpgm('JCRBNDRV') /else D p_JCRBNDR PR extpgm('JCRBNDR') /Endif D 20a Object and Lib D 10a Object Type D 8a output type D 20a Outfile and Lib D 22a mbropt /Endif /If Defined(p_JCRCALLR) //--------------------------------------------------------- /If Defined(p_JCRCALLRV) D p_JCRCALLRV PR extpgm('JCRCALLRV') /else D p_JCRCALLR PR extpgm('JCRCALLR') /Endif D 20a Program and Lib D 10a Source File D 10a Source Lib D 10a Source Member D 10a Program Attributes D 1a Retrieve CL source /Endif /If Defined(p_JCRCALLRC) //--------------------------------------------------------- D p_JCRCALLRC PR extpgm('JCRCALLRC') D 10a Program Name D 1a Error Status /Endif /If Defined(p_JCRCALLRR) //--------------------------------------------------------- D p_JCRCALLRR PR extpgm('JCRCALLRR') D 21a Source Lib/File D 10a Source Member D 10a Program Name D 1a Error Status D 10a File in Error /Endif /If Defined(p_JCRDBRR) //--------------------------------------------------------- D p_JCRDBRR PR extpgm('JCRDBRR ') Data Base Relations D 10a const For Validity Checker D 20a const File and Lib D 6a const * or *PRINT D 10a const switch D 57a options(*nopass) from JCRLKEY /Endif /If Defined(p_JCRDUMPR1) //--------------------------------------------------------- D p_JCRDUMPR1 PR extpgm('JCRDUMPR1') D 20a Outq Name and Lib D 10a Object Type D 7a Date D 6a Output D 20a Program Name and Lib /Endif /If Defined(p_JCRDUMPR2) //--------------------------------------------------------- D p_JCRDUMPR2 PR extpgm('JCRDUMPR2') Print Report /Endif /If Defined(p_JCRDUMPR3) //--------------------------------------------------------- D p_JCRDUMPR3 PR extpgm('JCRDUMPR3') Display Program D 10a const Program D 10a const Library D 10a const Outq D n Refresh /Endif //--------------------------------------------------------- /If Defined(p_JCRFDR) /If Defined(p_JCRFDRV) D p_JCRFDRV PR extpgm('JCRFDRV') /else D p_JCRFDR PR extpgm('JCRFDR ') File Information /Endif D 20a File and Lib D 10a Member /Endif /If Defined(p_JCRFFDR) //--------------------------------------------------------- /If Defined(p_JCRFFDRV) D p_JCRFFDRV PR extpgm('JCRFFDRV') /else D p_JCRFFDR PR extpgm('JCRFFDR') /Endif D 20a File and Lib D 10a Record Format Name D 4a Unpack Format? D 8a *print or *outfile D 20a Outfile and Lib D 22a Member Option /Endif /If Defined(p_JCRFLDCPYR) //--------------------------------------------------------- D p_JCRFLDCPYR PR extpgm('JCRFLDCPYR') Get Field Attributes D 21a Source File and Lib D 10a Source Member D 10a const Calling Command Name D 10a Error Return /Endif /If Defined(p_JCRFLDGETR) //--------------------------------------------------------- D p_JCRFLDGETR PR extpgm('JCRFLDGETR') D 21a Source File and Lib D 10a Source Member D 10a Error Return D 10a const Run By Command /Endif /If Defined(p_JCRGENPRR) //--------------------------------------------------------- D p_JCRGENPRR PR extpgm('JCRGENPRR ') D 10a Called Source Mbr D 20a Source File and Lib D 10a If CL, Then Objlib D 10a Output Source Mbr D 20a Output File and Lib /Endif /If Defined(p_JCRGENPRRC) //--------------------------------------------------------- D p_JCRGENPRRC PR extpgm('JCRGENPRRC') Read CL source D 21a Lib/Source D 10a Member Name D 50a Text D 21a To Update Lib/File D 10a Update Member D 1a Error Flag /Endif /If Defined(p_JCRGENPRRR) //--------------------------------------------------------- D p_JCRGENPRRR PR extpgm('JCRGENPRRR') Read RPG source D 21a Lib/Source D 10a Member Name D 50a Text D 21a To Update Lib/File D 10a Update Member D 1a Error Flag D 10a Error File /Endif /If Defined(p_JCRJOBR) //--------------------------------------------------------- D p_JCRJOBR PR extpgm('JCRJOBR') D 26a Qualified Job ID D 7a Job Status D 10a selected jobq /Endif /If Defined(p_JCRJOB2R) //--------------------------------------------------------- D p_JCRJOB2R PR extpgm('JCRJOB2R') D 10a D 10a D 6a /Endif /If Defined(p_JCRRECGETR) //--------------------------------------------------------- D p_JCRRECGETR PR extpgm('JCRRECGETR') Get RPG file info D 21a Source File and Lib D 10a Source Member D 10a const Called From Command D 4a const Rpg3 or Rpg4 D 30000a Returned File Array /Endif //--------------------------------------------------------- /If Defined(p_JCRRFLDR) /If Defined(p_JCRRFLDRV) D p_JCRRFLDRV PR extpgm('JCRRFLDRV') /else D p_JCRRFLDR PR extpgm('JCRRFLDR ') /Endif D 10a Source Member D 20a Source File and Lib D 8a output type D 20a Outfile and Lib D 22a mbropt /Endif /If Defined(p_JCRSUBRR2) //--------------------------------------------------------- D p_JCRSUBRR2 PR extpgm('JCRSUBRR2') D 10a Source Member D 20a Source File and Lib /Endif ]]> //--------------------------------------------------------- // JCRCMDSSRV - Service program for JCRCMDS // Craig Rutledge //--------------------------------------------------------- // Functions: // f_AddSortKey - concate on sort key blocks for qlgsort // f_BringDataBaseRecords - pull X number of records into memory // f_BuildString - build string with replacement values // f_CenterText - returns centered text for any length parm. // f_CheckMember - check if member exists // f_CheckObject - check if object exists // f_DayName - returns 'Monday ' if today or parm date is a Monday date. // f_DayOfWeekNumber - returns 1 if Sunday, 2 if Monday, etc.. // f_DecodeApiTimeStamp - accept API time stamp and return data structure. // f_DelayJobSeconds - delay job X number of seconds // f_DltOvr - delete file overrides // f_DupFileToQtemp - create duplicate file into Qtemp library with override. // f_ExecuteFileOptions - execute subfile options related to files // f_ExecuteJobOptions - execute subfile options related to jobs // f_ExecuteObjectOptions - execute subfile options related to objects // f_ExecuteSplfOptions - execute subfile options related to Spooled Files // f_FakeEditWord - return edit for for date/time format printing // f_GetCardFace - return A,K,Q,J,10 downto 1 for numeric values passed in. // f_GetRowColumn - return csrrow and csrcol for passed in display file field // f_GetCardColor - return hex value for Color attribute. // f_GetDate13 - return MMDDYYYY from 13 digit API date/time // f_GetFileUtil - return if DBU, WRKDBF, or STRDFU is data base utility // f_GetLastSplfInfo - return last generated spooled file attributes // f_GetQual - return lib/Obj for 20 long input // f_GetRandom - returns random number within a range // f_GetTime13 - return HHMMSS time from 13 digit API date/time // f_IsValidFile - returns *on if selected file exists // f_IsValidMbr - returns *on if member exists in selected file // f_IsValidMemberType - validate member type against parameters // f_IsValidObj - returns *on if object exists // f_KQJcount10 - Set values for King, Queen, and Jack to 10. // f_MondaysDate - returns Mondays iso date for week of passed date. // f_OutFileAddPfm - addpfm to select lib/file // f_OutFileCrtDupObj - valid check / creat OutFiles // f_OvrPrtf - override prtf with outq and/or usrdta // f_Parm - accept variable parms (f_SbmJob) // f_ParmListCount - number entries in cmd list // f_Pgm - program to submit (f_SbmJob) // f_QgyolObjSortKey - concate on sort key blocks for f_QgyolObjSortKey // f_Quscrtus - create user space in qtemp, return pointer to that space // f_Qusrmbrd - retrieve member description data structure // f_Qusrobjd - retrieve object description data structure // f_RmvSflMsg - remove message from errmsg subfile. // f_RtvMsgAPI - retrieves messages with substitution values loaded // f_Sbmjob - submit program with variable names as parms! // f_ShuffleDeck - load / random shuffle / cut new deck of cards. // f_SndCompMsg - send completion message // f_SndEscapeMsg - Send error messages for validity checking programs. // f_SndSflMsg - send message to error message subfile. // f_SndStatMsg - send status message // f_System - execute system (Qcmdexec replacement) with error monitoring //--------------------------------------------------------- //--*COPY DEFINES------------------------------------------ /Define ServiceProgramHeaderSpecs /Define Atof /Define Ceegsi /Define Ceeran0 /Define Cvthc /Define Dspatr /Define Qdbbrcds /Define Qdbrtvfd /Define Qmhrmvpm /Define Qmhrtvm /Define Qmhsndpm /Define Qp0zDltEnv /Define Qp0zGetEnv /Define Qp0zPutEnv /Define Qlidlto /Define Qsprilsp /Define Quscrtus /Define Quscusat /Define Quslfld /Define Qusptrus /Define Qusrmbrd /Define Qusrobjd /Define Qwccvtdt /Define System /Define f_AddSortKey /Define f_BringDataBaseRecords /Define f_BuildString /Define f_CenterText /Define f_CheckMember /Define f_CheckObject /Define f_DayName /Define f_DayOfWeekNumber /Define f_DecodeApiTimeStamp /Define f_DelayJobSeconds /Define f_DltOvr /Define f_DupFileToQtemp /Define f_ExecuteFileOptions /Define f_ExecuteJobOptions /Define f_ExecuteObjectOptions /Define f_ExecuteSplfOptions /Define f_FakeEditWord /Define f_GetCardFace /Define f_GetRowColumn /Define f_GetCardColor /Define f_GetDate13 /Define f_GetFileUtil /Define f_GetLastSplfInfo /Define f_GetQual /Define f_GetRandom /Define f_GetTime13 /Define f_IsValidFile /Define f_IsValidMbr /Define f_IsValidMemberType /Define f_IsValidObj /Define f_KQJcount10 /Define f_MondaysDate /Define f_OutFileAddPfm /Define f_OutFileCrtDupObj /Define f_OvrPrtf /Define f_Parm /Define f_ParmListCount /Define f_Pgm /Define f_QgyolObjSortKey /Define f_Quscrtus /Define f_Qusrmbrd /Define f_Qusrobjd /Define f_RmvSflMsg /Define f_RtvMsgAPI /Define f_SbmJob /Define f_ShuffleDeck /Define f_SndCompMsg /Define f_SndEscapeMsg /Define f_SndSflMsg /Define f_SndStatMsg /Define f_System /Define UserSpaceHeaderDS /Define Qmhrcvpm /Define Constants /Define p_JCRJOB2R /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // The ApiErrDS is exported to make it available to every program using this service. //--------------------------------------------------------- // Error return code parm for APIs. D ApiErrDS ds qualified export D BytesProvided 10i 0 inz(%size(ApiErrDS)) D BytesReturned 10i 0 inz D ErrMsgId 7a D ReservedSpace 1a D MsgReplaceVal 112a //--*STAND ALONE------------------------------------------- D GlobalProgramName... D s 10a varying // Import C/C++ global variable D EXCP_MSGID s 7a import('_EXCP_MSGID') //--------------------------------------------------------- // f_AddSortKey // This function returns a 16 character field with the integer values for a qlgsort key // block. If 3rd and fourth parms are not passed, load defaults. //--------------------------------------------------------- Pf_AddSortKey B export Df_AddSortKey PI 16a D KeyStartPos 10i 0 const D KeyStringSize 10i 0 const D KeyDataType 10i 0 const options(*nopass) D KeySortOrder 10i 0 const options(*nopass) D KeyBlock ds 16 qualified D aa 10i 0 D bb 10i 0 D cc 10i 0 D dd 10i 0 /free KeyBlock.aa = KeyStartPos; keyBlock.bb = KeyStringSize; 1b if %Parms > 2; KeyBlock.cc = KeyDataType; KeyBlock.dd = KeySortOrder; 1x else; KeyBlock.cc = 6; KeyBlock.dd = 1; 1e endif; return KeyBlock; /end-free Pf_AddSortKey E //--------------------------------------------------------- // f_BringDataBaseRecords // not sure how effective this is, but.. asynchronously bring records into memory //--------------------------------------------------------- p f_BringDataBaseRecords... p B export D f_BringDataBaseRecords... D PI D i_file 10a const D i_lib 10a const D i_mbr 10a const D i_numrecs 10i 0 D ArryOfRRN s 10i 0 dim(1000) D xx s 10i 0 D yy s 10i 0 /free 1b if i_Numrecs > 1000; yy = 1000; 1x else; yy = i_NumRecs; 1e endif; 1b for xx = 1 to yy; ArryOfRRN(xx) = xx; 1e endfor; callp QDBBRCDS( i_file + i_lib: i_mbr: ArryOfRRN: yy: ApiErrDS); return; /end-free p f_BringDataBaseRecords... p E //--------------------------------------------------------- // f_BuildString // returns a string with replacement values loaded from parms. Accepts a base string with // replacement values noted by & sign then accepts parms to replace the & characters. // Special value &q is arbitrarily used to signify a single Quote. You can check the // ApiErrDs data structure if your string was returned as an error. // NOTE: all character strings passed to this function should be %TRIMR( ) //--------------------------------------------------------- P f_BuildString B export D f_BuildString PI 2048a opdesc D inString 2048a const options(*varsize) D Parm1 100a const options(*nopass:*varsize) D Parm2 100a const options(*nopass:*varsize) D Parm3 100a const options(*nopass:*varsize) D Parm4 100a const options(*nopass:*varsize) D Parm5 100a const options(*nopass:*varsize) D Parm6 100a const options(*nopass:*varsize) D Parm7 100a const options(*nopass:*varsize) D Parm8 100a const options(*nopass:*varsize) D Parm9 100a const options(*nopass:*varsize) D Parm10 100a const options(*nopass:*varsize) D Parm11 100a const options(*nopass:*varsize) D Parm12 100a const options(*nopass:*varsize) D Parm13 100a const options(*nopass:*varsize) D Parm14 100a const options(*nopass:*varsize) D Parm15 100a const options(*nopass:*varsize) D Parm16 100a const options(*nopass:*varsize) D Parm17 100a const options(*nopass:*varsize) D Parm18 100a const options(*nopass:*varsize) D Parm19 100a const options(*nopass:*varsize) D Parm20 100a const options(*nopass:*varsize) D Parm21 100a const options(*nopass:*varsize) D Parm22 100a const options(*nopass:*varsize) D Parm23 100a const options(*nopass:*varsize) D Parm24 100a const options(*nopass:*varsize) D Parm25 100a const options(*nopass:*varsize) D Parm26 100a const options(*nopass:*varsize) D Parm27 100a const options(*nopass:*varsize) D Parm28 100a const options(*nopass:*varsize) D Parm29 100a const options(*nopass:*varsize) D Parm30 100a const options(*nopass:*varsize) D xx s 3u 0 inz D QuoteCount s 5i 0 inz D ParmCount s 5i 0 inz D cc s 5u 0 inz D String s 2048a D ParmArry s 100a dim(30) /Free ApiErrDS.BytesReturned = 0; //default error handler String = %trimr(inString); //--------------------------------------------------------- // make Quotes uppercase for remainder of function //--------------------------------------------------------- cc = %scan('&q': String); 1b dow cc > 0; String = %replace('&Q': String: cc: 2); cc = %scan('&q': String: cc + 1); 1e enddo; //--------------------------------------------------------- // There should be an even number of Quote characters. //--------------------------------------------------------- QuoteCount = 0; cc = %scan('&Q': String); 1b dow cc > 0; QuoteCount += 1; cc = %scan('&Q': String: cc + 1); 1e enddo; 1b If %rem(QuoteCount: 2) <> 0; ApiErrDS.ErrMsgId = 'CPF9898'; ApiErrDS.MsgReplaceVal = 'Odd number of single Quotes detected.'; ApiErrDS.BytesReturned = %len(%trimr(ApiErrDS.MsgReplaceVal)); return '**ERROR - see field ApiErrDS.MsgReplaceVal**'; 1e endif; //--------------------------------------------------------- // Number of parms should equal number of replacement values // (minus number of single Quotes.) //--------------------------------------------------------- ParmCount = 0; cc = %scan('&': String); 1b dow cc > 0; ParmCount += 1; cc = %scan('&': String: cc + 1); 1e enddo; 1b If (%Parms + QuoteCount) <> (ParmCount + 1); 2b If (%Parms + QuoteCount) > (ParmCount + 1); ApiErrDS.MsgReplaceVal = 'Too many replacement values passed.'; 2x else; ApiErrDS.MsgReplaceVal = 'Not enough replacement values passed.'; 2e endif; ApiErrDS.ErrMsgId = 'CPF9898'; ApiErrDS.BytesReturned = %len(%trimr(ApiErrDS.MsgReplaceVal)); return '**ERROR - see field ApiErrDS.MsgReplaceVal**'; 1e endif; //--------------------------------------------------------- // Spin through and replace all single Quotes. //--------------------------------------------------------- cc = %scan('&Q': String); 1b dow cc > 0; String = %replace(qs: String: cc: 2); cc = %scan('&Q': String: cc + 1); 1e enddo; //--------------------------------------------------------- // Load the replacement value parms into an array // so it will be easier to process in the next step. //--------------------------------------------------------- ParmCount = %Parms - 1; 1b if ParmCount >= 1; ParmArry(1) = Parm1; 1e endif; 1b if ParmCount >= 2; ParmArry(2) = Parm2; 1e endif; 1b if ParmCount >= 3; ParmArry(3) = Parm3; 1e endif; 1b if ParmCount >= 4; ParmArry(4) = Parm4; 1e endif; 1b if ParmCount >= 5; ParmArry(5) = Parm5; 1e endif; 1b if ParmCount >= 6; ParmArry(6) = Parm6; 1e endif; 1b if ParmCount >= 7; ParmArry(7) = Parm7; 1e endif; 1b if ParmCount >= 8; ParmArry(8) = Parm8; 1e endif; 1b if ParmCount >= 9; ParmArry(9) = Parm9; 1e endif; 1b if ParmCount >= 10; ParmArry(10) = Parm10; 1e endif; 1b if ParmCount >= 11; ParmArry(11) = Parm11; 1e endif; 1b if ParmCount >= 12; ParmArry(12) = Parm12; 1e endif; 1b if ParmCount >= 13; ParmArry(13) = Parm13; 1e endif; 1b if ParmCount >= 14; ParmArry(14) = Parm14; 1e endif; 1b if ParmCount >= 15; ParmArry(15) = Parm15; 1e endif; 1b if ParmCount >= 16; ParmArry(16) = Parm16; 1e endif; 1b if ParmCount >= 17; ParmArry(17) = Parm17; 1e endif; 1b if ParmCount >= 18; ParmArry(18) = Parm18; 1e endif; 1b if ParmCount >= 19; ParmArry(19) = Parm19; 1e endif; 1b if ParmCount >= 20; ParmArry(20) = Parm20; 1e endif; 1b if ParmCount >= 21; ParmArry(21) = Parm21; 1e endif; 1b if ParmCount >= 22; ParmArry(22) = Parm22; 1e endif; 1b if ParmCount >= 23; ParmArry(23) = Parm23; 1e endif; 1b if ParmCount >= 24; ParmArry(24) = Parm24; 1e endif; 1b if ParmCount >= 25; ParmArry(25) = Parm25; 1e endif; 1b if ParmCount >= 26; ParmArry(26) = Parm26; 1e endif; 1b if ParmCount >= 27; ParmArry(27) = Parm27; 1e endif; 1b if ParmCount >= 28; ParmArry(28) = Parm28; 1e endif; 1b if ParmCount >= 29; ParmArry(29) = Parm29; 1e endif; 1b if ParmCount = 30; ParmArry(30) = Parm30; 1e endif; //--------------------------------------------------------- // Load all the replacement values into the string. // use ceegsi to get actual length of parms. // unload parm array into replace statement. //--------------------------------------------------------- cc = %scan('&': String); 1b for xx = 1 to ParmCount; CEEGSI(xx + 1: datatype: LengthOfParm : MaxLength : *omit); String = %replace(%trimr( %subst(ParmArry(xx): 1: LengthOfParm)): String: cc: 1); cc = %scan('&': String: cc + LengthOfParm); 1e endfor; return String; /End-Free P f_BuildString E //--------------------------------------------------------- // f_CenterText // Return centered text for any length Parm < 101 //--------------------------------------------------------- P f_CenterText B export D f_CenterText PI 100a opdesc D i_String 100a const options(*varsize) D i_Length 3u 0 const options(*nopass) D xx s 3u 0 inz D CenteredString s 100a inz /free ApiErrDS.BytesReturned = 0; //default error handler 1b if %Parms() < 2; CEEGSI(1: datatype: LengthOfParm : MaxLength : *omit); 1x else; LengthOfParm = i_Length; 1e endif; xx = %int((LengthOfParm - %len(%trimr(%subst(i_String: 1: LengthOfParm)))) / 2) + 1; %subst(CenteredString: xx) = %subst(i_String: 1: LengthOfParm); Return CenteredString; /end-free Pf_CenterText E //--------------------------------------------------------- // f_CheckMember // Check member exists. If not, // call retrieve message API to pull in the substitution variables // and send escape message //--------------------------------------------------------- P f_CheckMember B export D f_CheckMember PI D FileQual 20a const D Member 10a const /free f_Qusrmbrd(FileQual: Member: 'MBRD0100'); 1b if ApiErrDS.BytesReturned > 0; //error occurred f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; return; /end-free P f_CheckMember E //--------------------------------------------------------- // f_CheckObject // Check object exists. If not, // call retrieve message API to pull in the substitution variables // and send escape message //--------------------------------------------------------- P f_CheckObject B export D f_CheckObject PI D ObjectQual 20a const D ObjectType 10a const /free f_QUSROBJD(ObjectQual: ObjectType: 'OBJD0100'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; return; /end-free P f_CheckObject E //--------------------------------------------------------- // f_DayName // Accepts an ISO real date field and returns the day name. If no date is passed, the // function will return the name of todays date. //--------------------------------------------------------- P f_DayName B export D f_DayName PI 9a Day Name D ipDateISO D Const Options(*NoPass) ISO Date D xx s 3u 0 /Free ApiErrDS.BytesReturned = 0; //default error handler 1b If %Parms = 0; xx = f_DayOfWeekNumber(%date()); 1x Else; xx = f_DayOfWeekNumber(ipDateIso); 1e Endif; 1b if xx = 1; return 'Sunday '; 1x elseif xx = 2; return 'Monday '; 1x elseif xx = 3; return 'Tuesday '; 1x elseif xx = 4; return 'Wednesday'; 1x elseif xx = 5; return 'Thursday '; 1x elseif xx = 6; return 'Friday '; 1x elseif xx = 7; return 'Saturday '; 1e endif; /End-Free P f_DayName E //--------------------------------------------------------- // f_DayOfWeekNumber // Accepts an ISO real date field and returns an integer value representing the offset from // Saturday. 1=Sunday, 2 = Monday, etc... //--------------------------------------------------------- P f_DayOfWeekNumber... P B export D f_DayOfWeekNumber... D PI 3u 0 Day Of Week D ipDate D Const Options(*NoPass) ISO Date D xx s 3u 0 inz /Free ApiErrDS.BytesReturned = 0; //default error handler 1b If %Parms = 0; xx = %Rem(%Diff(%date(): d'0001-01-06': *Days): 7); 1x Else; xx = %Rem(%Diff(ipdate: d'0001-01-06': *Days): 7); 1e Endif; 1b if xx = 0; xx = 7; 1e endif; return xx; /End-Free P f_DayOfWeekNumber... P E //--------------------------------------------------------- // f_DecodeApiTimeStamp // accept API time stamp and return data structure. //--------------------------------------------------------- p f_DecodeApiTimeStamp... p B export D f_DecodeApiTimeStamp... D PI 16a D ApiStamp 8a D char16 s 16a /free callp QWCCVTDT( '*DTS ': ApiStamp : '*MDY ': Char16 : ApiErrDS); return Char16; /end-free p f_DecodeApiTimeStamp... p E //--------------------------------------------------------- // f_DelayJobSeconds // Delays job for parm number of seconds. //--------------------------------------------------------- p f_DelayJobSeconds... p B export D f_DelayJobSeconds... D PI D Seconds 5u 0 const /free ApiErrDS.BytesReturned = 0; SYSTEM('DLYJOB DLY(' + %char(Seconds) + ')'); return; /end-free p f_DelayJobSeconds... p E //--------------------------------------------------------- // f_DltOvr // Delete file overrides. //--------------------------------------------------------- P f_DltOvr B export D f_DltOvr PI D SpooledFile 10a const /free system('DLTOVR FILE(' + SpooledFile + ') LVL(*JOB)'); return; /end-free P f_DltOvr E //--------------------------------------------------------- // f_DupFileToQtemp // create duplicate file into Qtemp library with override. //--------------------------------------------------------- P f_DupFileToQtemp... P B export D f_DupFileToQtemp... D PI D File 10a const D Lib 10a const D OvrDbf 1a const options(*nopass) D IsOvrDbf s n inz(*off) /free ApiErrDS.BytesReturned = 0; //default error handler 1b If not f_IsValidFile(File: Lib); return; 1x else; 2b if f_IsValidFile(File:'QTEMP '); system('CLRPFM QTEMP/' + FILE); return; 2x else; f_System('CRTDUPOBJ OBJ(' + %trimr(File) + ') FROMLIB(' + %trimr(Lib) + ') OBJTYPE(*FILE) TOLIB(QTEMP) DATA(*NO)'); system('RMVPFTRG FILE(QTEMP/' + %trimr(File) + ')'); IsOvrDbf = *on; 3b if %Parms = 3 and Ovrdbf = 'N'; IsOvrDbf = *off; 3e endif; 3b if IsOvrDbf; system('OVRDBF FILE(' + %trimr(File) + ') TOFILE(QTEMP/' + %trimr(File) + ') OVRSCOPE(*JOB)'); 3e endif; 2e endif; 1e endif; Return; /end-free P f_DupFileToQtemp... P E //--------------------------------------------------------- // f_ExecuteFileOptions // Execute system command depending on option selected. //--------------------------------------------------------- P f_ExecuteFileOptions... P B export D f_ExecuteFileOptions... D PI D options 1p 0 Option Selected D File 10a File D Lib 10a const Lib D RcdFmt 10a const Record Format D ProgId 10a program id D cmdString s 75a varying D LibFile s 21a varying /free LibFile = %trimr(f_GetQual(File + Lib)); 1b if Options = 1; cmdString = %trimr( f_BuildString('JCRFFD file(&) RcdFmt(&) output(*)': %trimr(LibFile): %trimr(RcdFmt))); //--------------------------------------------------------- // load string for whichever db utility is installed //--------------------------------------------------------- 1x elseif Options = 2; 2b if f_GetFileUtil() = 'DBU '; cmdString = 'DBU ' + LibFile; 2x elseif f_GetFileUtil() = 'WRKDBF'; cmdString = 'WRKDBF ' + LibFile; 2x elseif f_GetFileUtil() = 'STRDFU'; cmdString = 'STRDFU OPTION(5) FILE(' + LibFile + ') MBR(*FIRST)'; 2e endif; 1x elseif Options = 3; cmdString = 'JCRFD ' + LibFile; 1x elseif Options = 5 and ProgId <> 'JCRSOR '; cmdString = 'JCRSO ' + LibFile; 1x elseif Options = 7; cmdString = 'WRKOBJ *ALL/' + File + 'OBJTYPE(*FILE)'; 1x elseif Options = 8 and ProgId <> 'JCRDBRR '; cmdString = 'JCRDBR ' + LibFile; 1x else; f_SndSflMsg(ProgId: 'Option ' + %char(options) + ' is not available.'); return; 1e endif; f_System(cmdString); f_SndSflMsg(ProgId: CmdString +' - completed.'); return; /end-free P f_ExecuteFileOptions... P E //--------------------------------------------------------- // f_ExecuteJobOptions // Execute system command depending on option selected. //--------------------------------------------------------- P f_ExecuteJobOptions... P B export D f_ExecuteJobOptions... D PI D i_Options 1p 0 D i_JobName 10a D i_JobUser 10a D i_JobNum 6a D ProgId 10a D JobString s 33a varying //--------------------------------------------------------- /free JobString = %trimr(f_BuildString('JOB(&/&/&)': i_JobNum: %trimr(i_JobUser): %trimr(i_JobName))); 1b if i_Options = 2; f_System('?CHGJOB ' + JobString); f_SndSflMsg(ProgId: 'CHGJOB for ' +JobString+ ' - completed.'); 1x elseif i_Options = 3; f_System('STRSRVJOB ' + JobString ); f_SndSflMsg(ProgId: 'STRSRVJOB for '+JobString+' - completed.'); 1x elseif i_Options = 4; f_System('ENDJOB ' + JobString + ' OPTION(*IMMED)'); f_SndSflMsg(ProgId: 'ENDJOB for '+JobString+' - completed.'); 1x elseif i_Options = 5; f_System('DSPJOB ' + JobString ); f_SndSflMsg(ProgId: 'DSPJOB for '+JobString+' - completed.'); 1x elseif i_Options = 8; f_System('DSPJOB ' + JobString + ' OPTION(*SPLF)'); f_SndSflMsg(ProgId: 'WRKSPLF for '+JobString+' - completed.'); // file i/o monitor 1x elseif i_Options = 9; callp(e) p_JCRJOB2R( i_JobName: i_JobUser: i_JobNum); f_SndSflMsg(ProgId: 'File I/O for '+JobString+' - completed.'); 1x else; f_SndSflMsg(ProgId: 'Option ' + %char(i_Options) + ' is not available.'); 1e endif; return; /end-free P f_ExecuteJobOptions... P E //--------------------------------------------------------- // f_ExecuteObjectOptions // Execute system command depending on option selected. //--------------------------------------------------------- P f_ExecuteObjectOptions... P B export D f_ExecuteObjectOptions... D PI D Options 1p 0 D o_name 10a D o_Lib 10a D o_type 10a D ProgId 10a D ObjLibAndName s 23a varying /free ObjLibAndName = '(' + %trimr(f_GetQual(o_name + o_Lib)) + ')'; 1b if Options = 1; f_System(f_BuildString('WRKOBJ OBJ(&) OBJTYPE(&)': %trimr(ObjLibAndName): o_type)); 1x elseif Options = 2; f_System(f_BuildString('DSPOBJD OBJ(&) OBJTYPE(&)': %trimr(ObjLibAndName): o_type)); 1x elseif Options = 3; f_System(f_BuildString('WRKOBJLCK OBJ(&) OBJTYPE(&)': %trimr(ObjLibAndName): o_type)); //--------------------------------------------------------- // call v6r1 delete object APi //--------------------------------------------------------- 1x elseif Options = 4; callp Qlidlto( o_name + o_lib: o_type: '* ': '0': ApiErrDS); 1x elseif Options = 5; f_System('CLRPFM FILE' + ObjLibAndName); 1x elseif Options = 6; f_System('DBU ' + ObjLibAndName); 1x elseif Options = 7; f_System('JCRDQE DTAQ' + ObjLibAndName); 1x elseif Options = 8; f_System(f_BuildString('WRKOBJ OBJ(*ALLUSR/&) OBJTYPE(&)': %trimr(o_name): o_type)); 1x else; f_SndSflMsg(ProgId: 'Option ' + %char(options) + ' is not available.'); return; 1e endif; return; /end-free P f_ExecuteObjectOptions... P E //--------------------------------------------------------- // f_ExecuteSplfOptions // Execute system command depending on option selected. //--------------------------------------------------------- P f_ExecuteSplfOptions... P B export D f_ExecuteSplfOptions... D PI D i_Options 1a D i_SplfName 10a D i_SplfNum 6a D i_JobName 10a D i_JobUser 10a D i_JobNum 6a D ProgId 10a D UserID s 10a inz(*user) D CatUserEmail s 50a inz D SpoolString s 100a varying D Alpha6 ds qualified D num6 6s 0 inz D p_JCRSPLFR2 PR extpgm('JCRSPLFR2') D 10a Job Name D 10a User Name D 6a Job Number D 10a Spooled File Name D 6s 0 Spooled File Number /free SpoolString = %trimr(f_BuildString('FILE(&) JOB(&/&/&) SPLNBR(&)': %trimr(i_SplfName): %trimr(i_JobNum): %trimr(i_JobUser): %trimr(i_JobName): %trimr(i_SplfNum))); 1b if i_Options = '1'; //--------------------------------------------------- // if command SNDSPLF is on system, do it instead of sndnetsplf //--------------------------------------------------- 2b if f_IsValidObj('SNDSPLF ': '*LIBL ': '*CMD'); SpoolString = %trimr( f_BuildString('SPLF(&) JOB(&/&/&) SPLFN(&)': %trimr(i_SplfName): %trimr(i_JobNum): %trimr(i_JobUser): %trimr(i_JobName): %trimr(i_SplfNum))); 3b if UserID = 'YourUsrprf'; CatUserEmail = 'A@B.C'; 3x elseif UserID = 'YourUsrprf '; CatUserEmail = 'A@B.C'; 3x else; CatUserEmail = *blanks; 3e endif; f_System('?SNDSPLF ' + SpoolString + ' ??TOLIST('+ %trimr(CatUserEmail) + ') ' + ' ??FRADR('+ %trimr(CatUserEmail) + ') ' + ' ??SUBJECT(' + %trimr(i_SplfName) + ') ' + ' ??MSGTXT(' + %trimr(i_SplfName) + ') ' + ' ??TOFMT(*PDF) ??TITLE('+ %trimr(i_SplfName) +')'); //--------------------------------------------------- 2x else; f_System('?SNDNETSPLF ' + SpoolString + ' ??TOUSRID(( ))'); 2e endif; 2b if ApiErrDS.BytesReturned = 0; f_SndSflMsg(ProgId: 'Send ' + %trimr(i_SplfName) + ' - Completed.'); 2x else; f_SndSflMsg(ProgId: 'Send ' + %trimr(i_SplfName) + ' - Canceled.'); 2e endif; 1x elseif i_Options = '2'; f_System('?CHGSPLFA ' + SpoolString); 2b if ApiErrDS.BytesReturned = 0; f_SndSflMsg(ProgId: 'Change ' + %trimr(i_SplfName) + ' - Completed.'); 2x else; f_SndSflMsg(ProgId: 'Change ' + %trimr(i_SplfName) + ' - Canceled.'); 2e endif; 1x elseif i_Options = '3'; f_System('HLDSPLF ' + SpoolString); f_SndSflMsg(ProgId: 'Hold Spooled File ' + %trimr(i_SplfName) + ' - Completed.'); 1x elseif i_Options = '4'; f_System('DLTSPLF ' + SpoolString); f_SndSflMsg(ProgId: 'Delete Spooled File ' + %trimr(i_SplfName) + ' - Completed.'); 1x elseif i_Options = '5'; f_System('DSPSPLF ' + SpoolString); f_SndSflMsg(ProgId: 'Display Spooled File ' + %trimr(i_SplfName) + ' - Completed.'); 1x elseif i_Options = '6'; f_System('RLSSPLF ' + SpoolString); f_SndSflMsg(ProgId: 'Release Spooled File ' + %trimr(i_SplfName) + ' - Completed.'); 1x elseif i_Options = '7'; //duplicate spooled file Alpha6 = i_SplfNum; callp p_JCRSPLFR2( i_JobName: i_JobUser: i_JobNum: i_SplfName: Alpha6.num6); f_SndSflMsg(ProgId: 'Duplicate Spooled File ' + %trimr(i_SplfName) + ' - Completed.'); 1x elseif i_Options = '8'; f_System('WRKSPLFA ' + SpoolString); f_SndSflMsg(ProgId: 'Work Spooled File Attributes ' + %trimr(i_SplfName) + ' - Completed.'); 1x elseif i_Options = '9'; f_System('?CPYSPLF ' + SpoolString + ' ??TOFILE( )'); 2b if ApiErrDS.BytesReturned = 0; f_SndSflMsg(ProgId: 'Copy ' + %trimr(i_SplfName) + ' - Completed.'); 2x else; f_SndSflMsg(ProgId: 'Copy ' + %trimr(i_SplfName) + ' - Canceled.'); 2e endif; 1x elseif i_Options = 'S'; f_System('?SPLF2HTML ' + SpoolString + ' ??TODOC(' + qs + '/kpiReports/' + qs + ') STMFOPT(*REPLACE) FONTSIZE(2)'); 2b if ApiErrDS.BytesReturned = 0; f_SndSflMsg(ProgId: 'SPLF2HTML ' + %trimr(i_SplfName) + ' - Completed.'); 2x else; f_SndSflMsg(ProgId: 'SPLF2HTML ' + %trimr(i_SplfName) + ' - Canceled.'); 2e endif; 1x else; f_SndSflMsg(ProgId: 'Invalid Option Selected.'); 1e endif; return; /end-free P f_ExecuteSplfOptions... P E //--------------------------------------------------------- // f_FakeEditWord // return edit for for date/time format printing //--------------------------------------------------------- P f_FakeEditWord... P B export D f_FakeEditWord... D PI 28a opdesc D inString 288a options(*varsize) D i_DateType 1a const D wrkString s 288a varying /free 1b if i_DateType = 'Z'; return qs + ' - - - . . . ' + qs; 1x elseif i_DateType = 'T'; CEEGSI(1: datatype: LengthOfParm : MaxLength : *omit); wrkString = %xlate(lo: up: %subst(inString: 1: LengthOfParm)); 2b if wrkString = 'TIMFMT(*USA)' or wrkString = '*USA'; return qs + ' . XM' + qs; 2x elseif wrkString = 'TIMFMT(*HMS)' or wrkString = 'TIMFMT(*JIS)' or wrkString = '*HMS' or wrkString = '*JIS'; return qs + ' : : ' + qs; 2x elseif wrkString = 'TIMFMT(*ISO)' or wrkString = 'TIMFMT(*EUR)' or wrkString = '*ISO' or wrkString = '*EUR'; return qs + ' . . ' + qs; 2x else; return qs + ' : : ' + qs; 2e endif; 1x elseif i_DateType = 'L' or i_DateType = 'D'; CEEGSI(1: datatype: LengthOfParm : MaxLength : *omit); wrkString = %xlate(lo: up: %subst(inString: 1: LengthOfParm)); 2b if wrkString = 'DATFMT(*MDY)' or wrkString = 'DATFMT(*YMD)' or wrkString = 'DATFMT(*DMY)' or wrkString = '*MDY' or wrkString = '*YMD' or wrkString = '*DMY'; return qs + ' / / ' + qs; 2x elseif wrkString = 'DATFMT(*JUL)' or wrkString = '*JUL'; return qs + ' / ' + qs; 2x elseif wrkString = 'DATFMT(*ISO)' or wrkString = 'DATFMT(*JIS)' or wrkString = '*ISO' or wrkString = '*JIS'; return qs + ' - - ' + qs; 2x elseif wrkString = 'DATFMT(*USA)' or wrkString = '*USA' or wrkString = ' '; return qs + ' / / ' + qs; 2x elseif wrkString = 'DATFMT(*EUR)' or wrkString = '*EUR'; return qs + ' . . ' + qs; 2e endif; 1e endif; return inString; /end-free P f_FakeEditWord... P E //--------------------------------------------------------- // f_GetCardFace // return A,K,Q,J,10 for numeric values passed in. //--------------------------------------------------------- Pf_GetCardFace B export Df_GetCardFace PI 2a D CardNumVal 3u 0 D FaceOfCard s 2a inz /free 1b if CardNumVal = 01; FaceOfCard = 'A '; 1x elseif CardNumVal = 11; FaceOfCard = 'J '; 1x elseif CardNumVal = 12; FaceOfCard = 'Q '; 1x elseif CardNumVal = 13; FaceOfCard = 'K '; 1x else; FaceOfCard = %char(CardNumVal); 1e endif; return FaceOfCard; /end-free Pf_GetCardFace E //--------------------------------------------------------- // f_GetCardColor // Load Color attributes for cards. //--------------------------------------------------------- P f_GetCardColor B export D f_GetCardColor PI 1a hex value D gsuite 1a H S C D D Color s 1a inz /free 1b if gsuite = 'H'; Color = %bitor(RED: RI); 1x elseif gsuite = 'S'; Color = %bitor(BLUE: RI); 1x elseif gsuite = 'C'; Color = %bitor(YELLOW: RI); 1x elseif gsuite = 'D'; Color = %bitor(WHITE: RI); 1e endif; return Color; /end-free P f_GetCardColor E //--------------------------------------------------------- // f_GetRowColumn // Spin though user space return field names row and column in DSPF //--------------------------------------------------------- P f_GetRowColumn b export D f_GetRowColumn PI 6a D Field 10a const D File 10a D Lib 10a D RcdFmt 10a D xx s 5u 0 inz D UserSpaceName s 20a inz('JCRCMDSSRVQTEMP ') D PreviousFile s 10a static D PreviousLib s 10a static D CsrRowColDS ds D CsrRow 3s 0 D CsrCol 3s 0 /free 1b if not(File = PreviousFile and Lib = PreviousLib); PreviousFile = File; PreviousLib = Lib; GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLFLD( UserSpaceName: 'FLDL0100': file + lib: rcdfmt: '0': ApiErrDS); 1e endif; QuslfldPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for xx = 1 to GenericHeader.ListEntryCount; 2b if Field = QuslfldDS.FieldName; csrrow = QuslfldDS.ScreenFieldRow; csrcol = QuslfldDS.ScreenFieldCol; 1v leave; 2e endif; QuslfldPtr += GenericHeader.ListEntrySize; 1e endfor; return CsrRowColDS; /end-free P f_GetRowColumn e //--------------------------------------------------------- // f_GetDate13 // return MMDDYYYY from 13 digit API date/time //--------------------------------------------------------- P f_GetDate13 B export D f_GetDate13 PI 8p 0 D datetime 13a const D Alpha8 s 8a /free 1b if %subst(datetime: 1: 1) = ' ' or %subst(datetime: 1: 1) = x'00'; return 01010001; 1x else; %subst(Alpha8: 1: 2) = %subst(datetime: 4: 2); %subst(Alpha8: 3: 2) = %subst(datetime: 6: 2); 2b if %subst(datetime: 1: 1) = '1'; %subst(Alpha8: 5: 2) = '20'; 2x else; %subst(Alpha8: 5: 2) = '19'; 2e endif; %subst(Alpha8: 7: 2) = %subst(datetime: 2: 2); return %dec(Alpha8: 8: 0); 1e endif; /end-free P f_GetDate13 E //--------------------------------------------------------- // f_GetFileUtil // Return screen field for type data base utility installed // If neither DBU or WRKDBF is installed, default to STRDFU //--------------------------------------------------------- P f_GetFileUtil B export D f_GetFileUtil PI 6a D xx s 10i 0 inz /free ApiErrDS.BytesReturned = 0; //default error handler xx = system('CHKOBJ dbu *cmd'); 1b if xx = 0; return 'DBU '; 1e endif; xx = system('CHKOBJ wrkdbf *cmd'); 1b if xx = 0; return 'WRKDBF'; 1e endif; return 'STRDFU'; /end-free P f_GetFileUtil E //--------------------------------------------------------- // f_GetLastSplfInfo // Should have done this years ago! Return identity // for the last spooled file created by this job. //--------------------------------------------------------- p f_GetLastSplfInfo... p B export D f_GetLastSplfInfo... D PI 70a /free callp QSPRILSP( LastSplfInfoDS: %len(LastSplfInfoDS): 'SPRL0100': ApiErrDS); return LastSplfInfoDS; /end-free p f_GetLastSplfInfo... p E //--------------------------------------------------------- // f_GetQual // return lib/Obj for 20 long input parm //--------------------------------------------------------- Pf_GetQual B export Df_GetQual PI 21a D Parm 20a const /free return %trimr(%subst(Parm: 11: 10)) + '/' + %subst(Parm: 1: 10); /end-free Pf_GetQual E //--------------------------------------------------------- // f_GetRandom // Input parm is upper range limiter. // Return value is a random number between 1 and upper range //--------------------------------------------------------- P f_GetRandom B export D f_GetRandom PI 3u 0 D RandUpperLim 3u 0 const D RandFloat8 s 8f inz double precision D RandInt4 s 10i 0 inz STATIC unsigned integer D RandAlpha8 s 8a inz feed back /free callp CEERAN0( RandInt4: RandFloat8: RandAlpha8); return (RandUpperLim * RandFloat8) + 1; /end-free P f_GetRandom E //--------------------------------------------------------- // f_GetTime13 // return HHMMSS time from 13 digit API date/time //--------------------------------------------------------- P f_GetTime13 B export D f_GetTime13 PI 6p 0 D datetime 13a /free 1b if %subst(datetime: 8: 1) = ' ' or %subst(datetime: 8: 1) = x'00'; return 000000; 1x else; return %dec(%subst(datetime: 8: 6): 6: 0); 1e endif; /end-free P f_GetTime13 E //--------------------------------------------------------- // f_IsValidFile // If File exists, return *on; The check member API returns // more file specific information than the object API. //--------------------------------------------------------- P f_IsValidFile B export D f_IsValidFile PI n D ipFile 10a const D ipLib 10a const /free return f_IsValidMbr(ipFile : ipLib); /end-free P f_IsValidFile E //--------------------------------------------------------- // f_IsValidMbr // If member exists, return *on; //--------------------------------------------------------- P f_IsValidMbr B export D f_IsValidMbr PI n D ipFile 10a const D ipLib 10a const D ipMember 10a const options(*nopass) D alpha8 s 8a D MemberVar s 10a /free 1b if %Parms = 2; MemberVar = '*FIRST '; 1x else; MemberVar = ipMember; 1e endif; // check to see if member exists. callp Qusrmbrd( alpha8: 8: 'MBRD0100': ipFile + ipLib: MemberVar: '0': ApiErrDS); return (ApiErrDS.BytesReturned = 0); /end-free P f_IsValidMbr E //--------------------------------------------------------- // f_IsValidMemberType // Validate extracted member type against (up to) 4 types passed in as parms. You must pass // in at least one type. Note: I usually forbid a function changing a parameter, but in this // case all programs using this function would benefit from having the actual library // returned if the library is '*LIBL '. //--------------------------------------------------------- P f_IsValidMemberType... P B export D f_IsValidMemberType... D PI n D FileQual 20a D Member 10a const D Type1 10a const member type 1 D Type2 10a const options(*nopass) member type 2 D Type3 10a const options(*nopass) member type 3 D Type4 10a const options(*nopass) member type 4 /free clear QusrmbrdDS.MbrType; QusrmbrdDS = f_Qusrmbrd(FileQual: Member: 'MBRD0100'); 1b if ApiErrDS.BytesReturned > 0; //error occurred f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; 1b If %subst(FileQual: 11: 10) = '*LIBL '; %subst(FileQual: 11: 10) = QusrmbrdDS.Lib; 1e endif; 1b if QusrmbrdDS.MbrType = Type1 or %Parms >= 4 and QusrmbrdDS.MbrType = Type2 or %Parms >= 5 and QusrmbrdDS.MbrType = Type3 or %Parms = 6 and QusrmbrdDS.MbrType = Type4; return *on; 1x else; return *off; 1e endif; /end-free P f_IsValidMemberType... P E //--------------------------------------------------------- // f_IsValidObj // If object exists, return *on; //--------------------------------------------------------- P f_IsValidObj B export D f_IsValidObj PI n D ipObject 10a const D ipLib 10a const D ipObjectType 10a const D alpha8 s 8a /free ApiErrDS.BytesReturned=0; //default error handler callp QUSROBJD( alpha8: 8: 'OBJD0100': ipObject + ipLib: ipObjectType: ApiErrDS); return (ApiErrDS.BytesReturned = 0); /end-free P f_IsValidObj E //--------------------------------------------------------- // f_KQJcount10 // in some games, King, Queen and Jack count as 10. //--------------------------------------------------------- P f_KQJcount10 B export D f_KQJcount10 PI 3u 0 D Num1to13 3u 0 const D CardValue s 3u 0 /free 1b if Num1to13 > 10; CardValue = 10; 1x else; CardValue = %int(Num1to13); 1e endif; return CardValue; /end-free P f_KQJcount10 E //--------------------------------------------------------- // f_MondaysDate // Accepts an ISO real date field and returns an the iso Mondays date for whatever week the // parm date was in. If no date is passed, it gets the current weeks Monday. If a Sunday date // is past, it returns the next days date. //--------------------------------------------------------- P f_MondaysDate B export D f_MondaysDate PI d D ipDate d Const Options(*NoPass) ISO Date D xx s 3i 0 inz D date s d inz /Free ApiErrDS.BytesReturned = 0; //default error handler 1b If %Parms = 0; date = %date(); 1x Else; date = ipDate; 1e Endif; xx = f_DayOfWeekNumber(date); 1b if xx = 1; //sunday return date + %days(1); 1x else; return date - %days(%abs(2 - xx)); 1e endif; /End-Free P f_MondaysDate E //--------------------------------------------------------- // f_OutFileAddPfm // add member to existing file //--------------------------------------------------------- p f_OutFileAddPfm... p B export D f_OutFileAddPfm... D PI D i_NewFileQual 20a const D i_NewMbr 10a const D i_MbrType 8a const D i_MbrText 50a const options(*nopass) D i_OrgFileQual 20a const options(*nopass) D i_OrgMbr 10a const options(*nopass) /free // get original member text 1b If %Parms = 6; QusrmbrdDS = f_Qusrmbrd(i_OrgFileQual: i_OrgMbr: 'MBRD0100'); QusrmbrdDS.Text = %xlate(qd + qs +'<&%':' ': QusrmbrdDS.Text); 1x else; QusrmbrdDS.Text = %xlate(qd + qs +'<&%':' ': i_MbrText); QusrmbrdDS.MbrType = i_MbrType; 1e endif; // If out member does not exists, create one. 1b if Not f_IsValidMbr(%subst(i_NewFileQual: 1: 10): %subst(i_NewFileQual: 11: 10): i_NewMbr); f_system(f_BuildString('ADDPFM FILE(&) MBR(&) SRCTYPE(&) TEXT(&q&&q)': %trimr(f_GetQual(i_NewFileQual)): %trimr(i_NewMbr): %trimr(QusrmbrdDS.MbrType): %trimr(QusrmbrdDS.Text))); 1x else; f_System(f_BuildString( 'CHGPFM FILE(&) MBR(&) SRCTYPE(&) TEXT(&q&&q)': %trimr(f_GetQual(i_NewFileQual)): %trimr(i_NewMbr): %trimr(QusrmbrdDS.MbrType): %trimr(QusrmbrdDS.Text))); f_system( f_BuildString('CLRPFM FILE(&) MBR(&)': %trimr(f_GetQual(i_NewFileQual)): %trimr(i_NewMbr))); 1e endif; return; /end-free p f_OutFileAddPfm... p E //--------------------------------------------------------- // f_OutFileCrtDupObj // validity check / create OutFile //--------------------------------------------------------- p f_OutFileCrtDupObj... p B export D f_OutFileCrtDupObj... D PI D i_FileQual 20a const D i_MbrOpt 22a const D FromObject 10a const D ReturnFileQual s 20a D DataFileQual s 20a D RealMbr s 10a D IsMemberAdded s n inz(*off) D LevelIDFrom s like(fild0200DS.LevelID) //--*DATA STRUCTURES--------------------------------------- // file header for fild0200 format D fild0200DS ds qualified inz D LevelID 13a overlay(fild0200DS:81) D OutFileDS ds D OutFile 10a D OutLib 10a D MbrOptDS ds D NumEntries 5i 0 D OutMbr 10a D OutMbrOpt 10a /free OutFileDS = i_FileQual; MbrOptDS = i_MbrOpt; 1b if OutFile = *blanks; f_SndEscapeMsg('Must select an OutFile name'); 1e endif; //--------------------------------------------------------- // cannot use JCRcmds from-object as OutFile. //--------------------------------------------------------- 1b if OutFile = FromObject; f_SndEscapeMsg('Select OutFile name other than ' + %trimr(FromObject) + '.'); 1e endif; //--------------------------------------------------------- 1b if (OutLib <> '*LIBL') and (OutLib <> '*CURLIB') and not f_IsValidObj(OutLib: 'QSYS ': '*LIB '); f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; ApiErrDS.ErrMsgId = *blanks; f_IsValidMbr(OutFile: OutLib: OutMbr); //--------------------------------------------------------- 1b if ApiErrDS.ErrMsgId = 'CPF9812'; 2b if OutLib = '*LIBL '; f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 2x else; f_system( f_BuildString('CRTDUPOBJ OBJ(&) FROMLIB(*LIBL) + OBJTYPE(*FILE) TOLIB(&) NEWOBJ(&) DATA(*NO)': %trimr(FromObject): %trimr(OutLib): %trimr(OutFile))); 3b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId +': Error occurred on CRTPF'); 3e endif; f_system( f_BuildString('RMVM FILE(&/&) MBR(*ALL)': %trimr(OutLib): %trimr(OutFile))); exsr srAddPfm; 2e endif; //--------------------------------------------------------- // if File exists but member does not, // make sure member can be added to File. //--------------------------------------------------------- 1x elseif ApiErrDS.ErrMsgId = 'CPF9815'; exsr srAddPfm; //--------------------------------------------------------- 1x elseif ApiErrDS.ErrMsgId <> *blanks; f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; 1b if OutMbrOpt = '*REPLACE '; f_system( f_BuildString('CLRPFM FILE(&/&) MBR(&)': %trimr(OutLib): %trimr(OutFile): %trimr(RealMbr))); 1e endif; // compare record format ID for level check issues DataFileQual = FromObject + '*LIBL '; exsr srQDBRTVFD; LevelIDFrom = fild0200DS.LevelID; DataFileQual = OutFile + OutLib; exsr srQDBRTVFD; 1b If LevelIDFrom <> fild0200DS.LevelID; f_SndEscapeMsg('Level Check on OutFile ' + %trimr(OutLib) + '/' +%trimr(OutFile) + '.'); 1e endif; return; //--------------------------------------------------------- begsr srQDBRTVFD; callp QDBRTVFD( fild0200DS: %size(fild0200DS): ReturnFileQual: 'FILD0200' : DataFileQual: '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS ); 1b If ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; endsr; //--------------------------------------------------------- begsr srAddPfm; clear ApiErrDS.ErrMsgId; RealMbr = OutMbr; 1b if OutMbr = '*FIRST '; RealMbr = OutFile; 1e endif; f_system( f_BuildString('ADDPFM &/& &': %trimr(OutLib): %trimr(OutFile): %trimr(realMbr))); 1b if (ApiErrDS.ErrMsgId = 'CPF7306'); f_SndEscapeMsg('Members for OutFile more than MAX allowed.'); 1e endif; endsr; /end-free p f_OutFileCrtDupObj... p E //--------------------------------------------------------- // f_OvrPrtf // Override prtf with outq and/or user data. //--------------------------------------------------------- P f_OvrPrtf B export D f_OvrPrtf PI D SpooledFile 10a const D Outq 10a const options(*omit) D UsrDta 10a const options(*nopass) /free f_DltOvr(SpooledFile); 1b if %Parms = 2; f_System('OVRPRTF FILE(' + SpooledFile + ') OUTQ(' + outq + ') OVRSCOPE(*JOB)'); 1e endif; 1b if %Parms = 3; 2b if %addr(outq) = *null; f_System('OVRPRTF FILE(' + SpooledFile + ') USRDTA(' + usrdta + ') OVRSCOPE(*JOB)'); 2x else; f_System('OVRPRTF FILE(' + SpooledFile + ') OUTQ(' + outq + ') USRDTA(' + usrdta + ') OVRSCOPE(*JOB)'); 2e endif; 1e endif; return; /end-free P f_OvrPrtf E //--------------------------------------------------------- // f_Parm // Used as a parm on the f_Pgm function. This function converts variable value into Quote // delimited string. If a second parm is passed, it indicates this is is a numeric parm. The // Hex value is returned for those. Do not pass the second parm for alpha field. pass // %size(NumberVariable) for second parm if number. if passing constant number, pass packed // size L/2 + 1. //--------------------------------------------------------- P f_Parm B export D f_Parm PI 256a opdesc D Parm 256a const options(*varsize) D SizeBif 3u 0 const options(*nopass) D NumChar s 30a varying D xx s 3u 0 inz D IsNegative s n D LastHex s 1a D BigHex s 30a D AllZero s 30a inz(*all'0') /free CEEGSI(1: datatype: LengthOfParm : MaxLength : *omit); 1b if %Parms = 1; return qs + %trimr(%subst(Parm: 1: LengthOfParm)) + qs; 1x else; NumChar = %trimr(%subst(parm: 1: LengthOfParm)); // determine if negative; // If is negative, compress out - sign. IsNegative = (%subst(NumChar: 1: 1) = '-'); 2b if IsNegative; NumChar = %subst(NumChar: 2); LastHex = 'D'; 2x else; LastHex = 'F'; 2e endif; // compress out the decimal point xx = %scan('.': Numchar); 2b if xx > 0; 3b if xx = 1; NumChar = %subst(NumChar: 2); 3x else; NumChar = %subst(NumChar: 1: xx - 1) + %subst(NumChar: xx + 1); 3e endif; 2e endif; // load required leading 0's evalr BigHex = AllZero + NumChar + LastHex; return 'X' + qs + %subst(BigHex: (31 - (SizeBif*2))) + qs; 1e endif; /end-free P f_Parm E //--------------------------------------------------------- // f_ParmListCount // return the number of elements passed in a parameter list. //--------------------------------------------------------- p f_ParmListCount... p B export D f_ParmListCount... D PI 5u 0 D ListParm 2a D ExtractDS ds qualified D bin 1 2b 0 /free ApiErrDS.BytesReturned = 0; //default error handler ExtractDS = ListParm; return %int(ExtractDS.bin); /end-free p f_ParmListCount... p E //--------------------------------------------------------- // f_Pgm // Used as a parm on the f_SbmJob function. This function returns the SBMJOB string with the // parms converted from variable names to the variables values. //--------------------------------------------------------- P f_Pgm B export D f_Pgm PI 4096a D Pgm 10a const D Lib 10a const D Parm1 256a const options(*nopass) D Parm2 256a const options(*nopass) D Parm3 256a const options(*nopass) D Parm4 256a const options(*nopass) D Parm5 256a const options(*nopass) D Parm6 256a const options(*nopass) D Parm7 256a const options(*nopass) D Parm8 256a const options(*nopass) D Parm9 256a const options(*nopass) D Parm10 256a const options(*nopass) d String s 4096a varying /free GlobalProgramName = pgm; %len(String) = 0; String = 'CALL PGM(' + %trimr(Lib) + '/' + %trimr(pgm) +')'; 1b if %Parms = 2 ; return String; 1x else; // start loading the parm fields 2b if %Parms >= 3; String += ' PARM(' + %trimr(Parm1); 2e endif; 2b if %Parms >= 4; String += ' ' + %trimr(Parm2); 2e endif; 2b if %Parms >= 5; String += ' ' + %trimr(Parm3); 2e endif; 2b if %Parms >= 6; String += ' ' + %trimr(Parm4); 2e endif; 2b if %Parms >= 7; String += ' ' + %trimr(Parm5); 2e endif; 2b if %Parms >= 8; String += ' ' + %trimr(Parm6); 2e endif; 2b if %Parms >= 9; String += ' ' + %trimr(Parm7); 2e endif; 2b if %Parms >= 10; String += ' ' + %trimr(Parm8); 2e endif; 2b if %Parms >= 11; String += ' ' + %trimr(Parm9); 2e endif; 2b if %Parms = 12; String += ' ' + %trimr(Parm10); 2e endif; 1e endif; String += ')'; return String; /end-free P f_Pgm E //--------------------------------------------------------- // f_QgyolObjSortKey // This function returns a 12 character field with the values for a QGYOLOBJ key block. If // no parms passed, load defaults. //--------------------------------------------------------- Pf_QgyolObjSortKey... P B export Df_QgyolObjSortKey... D PI 12a D StartPos 10i 0 const options(*nopass) D KeyLength 10i 0 const options(*nopass) D DataType 5i 0 const options(*nopass) D SortOrder 1a const options(*nopass) D ads ds 12 D aa 10i 0 D bb 10i 0 D cc 5i 0 D dd 1a D ee 1a /free ee = x'00'; 1b if %Parms > 0; aa = StartPos; bb = KeyLength; cc = DataType; dd = SortOrder; 1x else; aa = 0; bb = 0; cc = x'00'; dd = x'00'; 1e endif; return ads; /end-free Pf_QgyolObjSortKey... P E //--------------------------------------------------------- // f_Quscrtus // Create user space, change attributes to allow automatic extendibility, // and return pointer to the user space. //--------------------------------------------------------- P f_Quscrtus B export D f_Quscrtus PI * D UserSpaceName 20a D uPointer s * D ReturnLib s 10a /free callp QUSCRTUS( UserSpaceName: 'JCRCMDS': 8192: x'00': '*ALL': 'User Space JCRCMDS ': '*NO': ApiErrDS: '*DEFAULT': 32: '1'); callp QUSCUSAT( ReturnLib: UserSpaceName: QuscusatDS: ApiErrDS); callp QUSPTRUS( UserSpaceName: uPointer: ApiErrDS ); return uPointer; /end-free P f_Quscrtus E //--------------------------------------------------------- // f_Qusrmbrd // return member information //--------------------------------------------------------- P f_Qusrmbrd B export D f_Qusrmbrd PI 256a D FileQual 20a const D Member 10a const D Format 8a const /free callp Qusrmbrd( QusrmbrdDS: 256: Format: FileQual: Member: '0': ApiErrDS); return QusrmbrdDS; /end-free P f_Qusrmbrd E //--------------------------------------------------------- // f_Qusrobjd // execute Qusrobjd API, included in copy is DS to extract values. // If format not passed, OBJD0200 is used as default. //--------------------------------------------------------- P f_Qusrobjd B export D f_Qusrobjd PI 467a D ObjectQual 20a const D ObjectType 10a const D ApiFormat 8a const options(*nopass) D LocalApiFormat... D s 8a /free 1b if %Parms = 2; LocalApiFormat = 'OBJD0200'; 1x else; LocalApiFormat = ApiFormat; 1e endif; callp QUSROBJD( QUSROBJDS: 467: LocalApiFormat: ObjectQual: ObjectType: ApiErrDS); return QUSROBJDS; /end-free p f_Qusrobjd E //--------------------------------------------------------- // f_RmvSflMsg // Remove all messages from error message subfile //--------------------------------------------------------- P f_RmvSflMsg B export D f_RmvSflMsg PI D ProgramName 10a const /free callp Qmhrmvpm( ProgramName: 0: ' ': '*ALL': ApiErrDs); return; /end-free P f_RmvSflMsg E //--------------------------------------------------------- // f_RtvMsgAPI // Retrieve error message replacement values. //--------------------------------------------------------- P f_RtvMsgAPI B export D f_RtvMsgAPI PI 232a D ErrMsgid 7a const D MsgReplaceVal 112a const D MsgFileQual 20a const options(*nopass) D msgf s 20a /free 1b if %Parms = 2; msgf = 'QCPFMSG *LIBL'; 2b if %subst(ErrMsgid: 1: 2) = 'RN'; msgf = 'QRPGLEMSG QDEVTOOLS'; 2e endif; 1x else; msgf = MsgFileQual; 1e endif; // call retrieve message API to pull in the substitution variables callp QMHRTVM( QmhrtvmDS : mMsgLen : 'RTVM0100': ErrMsgId: msgf: MsgReplaceVal: %size(MsgReplaceVal): '*YES ': '*NO ': ApiErrDS); // If too long, set length to size of return value 1b if QmhrtvmDS.MessageRtvLen > %size(QmhrtvmDS.MessageRtv); QmhrtvmDS.MessageRtvLen = %size(QmhrtvmDS.MessageRtv); 1e endif; // Only return populated message length Return %subst(QmhrtvmDS.MessageRtv: 1: QmhrtvmDS.MessageRtvLen); /end-free P f_RtvMsgAPI E //--------------------------------------------------------- // f_SbmJob // Use in conjunction with the f_Pgm and f_Parm functions to allow submit jobs with variable // names as parms instead of having to build string. //--------------------------------------------------------- P f_SbmJob B export D f_SbmJob PI D ProgramInfo 4096a options(*varsize) const D jobq 10a const options(*nopass) D jobd 10a const options(*nopass) D jobqLocal s 10a D jobdLocal s 10a D String s 4096a D Qcmdexc PR extpgm('QCMDEXC') CL Command Processor D 4096a options(*varsize) D 15p 5 Const /free ApiErrDS.BytesReturned = 0; jobqLocal = jobq; jobdLocal = jobd; 1b if %Parms < 2; JobqLocal = '*JOBD '; JobdLocal = '*USRPRF '; 1x elseif %Parms = 2; JobdLocal = '*USRPRF '; 1e endif; String = 'SBMJOB CMD(' + %trimr(ProgramInfo) + ') JOB(' + GlobalProgramName + ') JOBQ(' + %trimr(jobqLocal) + ') JOBD(' + %trimr(jobdLocal) + ')'; callp QCMDEXC(string : %len(%trimr(string))); callp QMHRCVPM( rcvm0100DS: %len(rcvm0100DS): 'RCVM0100': '*': 0: '*LAST ': ' ': 10: '*REMOVE ': ApiErrDS); 1b if ApiErrDS.BytesReturned = 0; ApiErrDS.MsgReplaceVal = RCVM0100DS.MESSAGETEXT; 1e endif; return; /end-free P f_SbmJob E //--------------------------------------------------------- // f_ShuffleDeck // Return shuffled deck //--------------------------------------------------------- P f_ShuffleDeck B export D f_ShuffleDeck PI 2a dim(52) D aa s 3u 0 inz D bb s 3u 0 inz D cc s 3u 0 inz D NewDS ds D NewDeck 2a dim(52) inz D NewCard 3u 0 overlay(newdeck:1) D NewSuite 1a overlay(newdeck:*next) D RandomDS ds D RandomDeck 2a dim(52) /free // load fresh deck 1b for aa = 1 to 4; 2b for bb = 1 to 13; cc += 1; NewSuite(cc) = %subst('HSCD': aa: 1); NewCard(cc) = bb; 2e endfor; 1e endfor; // Use random function to pull cards from newdeck. 1b for aa = 52 downto 1; bb = f_GetRandom(aa); RandomDeck(aa) = NewDeck(bb); // shift left over picked card so it will not be repicked 2b if aa <> bb; %subst(NewDS: (2 * bb) - 1) = %subst(NewDS: (2 * bb) + 1); 2e endif; 1e endfor; // 'Cut' the cards by swapping the deck around using a // random number between 2-51 as the pivot. bb = (2 * (f_GetRandom(50) + 1)) - 1; NewDS = %subst(RandomDS: bb: 105 - bb) + RandomDS; return NewDeck; /end-free P f_ShuffleDeck E //--------------------------------------------------------- // f_SndCompMsg // Send completion messages. //--------------------------------------------------------- P f_SndCompMsg B export D f_SndCompMsg PI D msgtxt 75a const /free callp QMHSNDPM( ' ': ' ': msgtxt: 75: '*INFO ': '*CTLBDY ': 1: ' ': ApiErrDS); return; /end-free P f_SndCompMsg E //--------------------------------------------------------- // f_SndEscapeMsg // Send error messages for validity checking programs. //--------------------------------------------------------- P f_SndEscapeMsg B export D f_SndEscapeMsg PI D msgtxt 75a value /free msgtxt='0000'+msgtxt; callp QMHSNDPM( 'CPD0006 ': 'QCPFMSG *LIBL ': msgtxt: %size(msgtxt): '*DIAG' : '*CTLBDY': 1: ' ': ApiErrDS); clear msgtxt; callp QMHSNDPM( 'CPF0002 ': 'QCPFMSG *LIBL ': msgtxt: %size(msgtxt): '*ESCAPE ': '*CTLBDY': 1: ' ': ApiErrDS); return; /end-free P f_SndEscapeMsg E //--------------------------------------------------------- // f_SndSflMsg // Send message to error message subfile //--------------------------------------------------------- P f_SndSflMsg B export D f_SndSflMsg PI D ProgramName 10a const D MessageText 75a const D pMsgId 7a const options(*nopass) D pMsgFile 10a const options(*nopass) D pMsgLib 10a const options(*nopass) D MsgID s 7a D MsgFileQual s 20a /free 1b If %Parms < 3; clear msgid; clear MsgFileQual; 1x else; msgid = pMsgid; 2b if %Parms < 5; msgFileQual = pMsgFile + '*LIBL '; 2x else; msgFileQual = pMsgFile + pMsgLib; 2e endif; 1e endif; callp Qmhsndpm( msgid: msgFileQual: MessageText: %len(MessageText): '*INFO': ProgramName: 0: ' ': ApiErrDs); return; /end-free P f_SndSflMsg E //--------------------------------------------------------- // f_SndStatMsg // Send Status messages. //--------------------------------------------------------- P f_SndStatMsg B export D f_SndStatMsg PI D msgtxt 75a const /free callp QMHSNDPM( 'CPF9898': 'QCPFMSG *LIBL ': msgtxt: 75: '*STATUS': '*EXT': 1: ' ': ApiErrDS); return; /end-free P f_SndStatMsg E //--------------------------------------------------------- // f_System // execute C function system using global exception variable //--------------------------------------------------------- p f_System B export D f_System PI opdesc D String 2048a const options(*varsize) /free CEEGSI(1: datatype: LengthOfParm : MaxLength : *omit); EXCP_MSGID = *blanks; callp(e) system(%subst(String: 1: LengthOfParm)); 1b if EXCP_MSGID > *blanks; ApiErrDS.ErrMsgId = EXCP_MSGID; ApiErrDS.MsgReplaceVal = *blanks; ApiErrDS.BytesReturned = 7; 1x else; ApiErrDS.BytesReturned = 0; 1e endif; return; /end-free p f_System E ]]>