Code
Find a File

Mbr: UF, Type: CMD, Text: Find a File: Command
CMD PROMPT('Find A File') /* CPP UFC */ PARM KWD(TXT) TYPE(*CHAR) LEN(50) PROMPT('File + Name') PARM KWD(LIB) TYPE(*CHAR) LEN(10) DFT(DTA_LIB) + PROMPT('Library Name')
Mbr: UFC, Type: CLLE, Text: Find a File: CL Program
pgm parm(&Txt &Lib) dcl &Txt *char ( 50 ) dcl &Lib *char ( 10 ) dcl &TxtQ *char ( 52 ) dcl &LibQ *char ( 14 ) chgvar &TxtQ ('''' *cat '%' *CAT &Txt *tcat '%' *CAT '''') chgvar &LibQ ('''' *cat &Lib *TCAT '''') strqmqry qmqry(QGPL/UFQ) + setvar( (TXT &TxtQ) + (LIB &LibQ) ) endpgm
Mbr: UFQ, Type: QMQRY, Text: Find a File: QM Query
select substr(TABLE_NAME,1,15) as TABLE_NAME , TABLE_TYPE , TABLE_TEXT , SYSTEM_TABLE_SCHEMA from QSYS2/SYSTABLES where upper(TABLE_TEXT) like upper(&TXT) and SYSTEM_TABLE_SCHEMA = &LIB and TABLE_TYPE = 'P' order by TABLE_NAME
Find a Field

Mbr: UFLD, Type: CMD, Text: Find a Field
CMD PROMPT('Find A Field') /* CPP UFLDC */ PARM KWD(FLD) TYPE(*CHAR) LEN(50) PROMPT('Field + Name') PARM KWD(LIB) TYPE(*CHAR) LEN(10) DFT(CKJEURO) + PROMPT('Library Name')
Mbr: UFLDC, Type: CLLE, Text: Find a Field
pgm parm(&Fld &Lib) dcl &Fld *char ( 10 ) dcl &Lib *char ( 10 ) dcl &FldQ *char ( 14 ) dcl &LibQ *char ( 14 ) chgvar &FldQ ('''' *cat &Fld *tcat '''') chgvar &LibQ ('''' *cat &Lib *TCAT '''') strqmqry qmqry(ANEWNS/UFLDQ) + setvar( (FLD &FldQ) + (LIB &LibQ) ) endpgm
Mbr: UFLDQ, Type: QMQRY, Text: Find a Field
/* Find a field name */ SELECT substr(c.COLUMN_NAME ,1 ,10) as COLUMN , substr(c.COLUMN_TEXT ,1 ,50) as COLUMN_TEXT , substr(c.TABLE_NAME ,1 ,10) as TABLE , substr(t.TABLE_TEXT ,1 ,50) as TABLE_TEXT , substr(c.TABLE_SCHEMA ,1 ,10) as SCHEMA FROM qsys2/syscolumns c join systables t on c.table_name = t.table_name and c.table_schema = t.table_schema WHERE c.COLUMN_NAME = &FLD and c.TABLE_SCHEMA = &LIB and t.TABLE_TYPE = 'P' order by c.TABLE_NAME
Set Source to Lowercase

Mbr: LO, Type: CMD, Text: Set Source to Lowercase
CMD PROMPT('Convert SRCDTA to lowercase') /* CONVERT SRCDTA TO LOWERCASE */ /* A.NEWNS 02/09/10 */ /* CPP LOC */ PARM KWD(MBR) TYPE(*CHAR) LEN(10) MIN(1) + PROMPT('Member') /* PARM KWD(FILE) TYPE(FIL) DFT(QSRC) SNGVAL((QSRC + QSRC)) MIN(0) PROMPT('Source File') */ PARM KWD(FILE) TYPE(FIL) MIN(1) PROMPT('Source + File') FIL: QUAL TYPE(*NAME) QUAL TYPE(*NAME) PROMPT('Library')
Mbr: LOC, Type: CLLE, Text: Set Source to Lowercase
pgm parm( &mbr + &fillib ) /*šconvert srcdta to lowercase €*/ /*ša.newns 02/09/10 €*/ dcl &mbr *char ( 10 ) dcl &fillib *char ( 20 ) dcl &lib *char ( 10 ) dcl &fil *char ( 10 ) dcl &libq *char ( 12 ) dcl &filq *char ( 12 ) dcl &msgdta *char ( 50 ) dcl &msgid *char ( 7 ) dcl &msgf *char ( 10 ) dcl &msgflib *char ( 10 ) monmsg (cpf0000 mch0000 rnx0000) exec(goto error) chgvar &fil (%sst(&fillib 1 10)) chgvar &lib (%sst(&fillib 11 10)) chkobj &lib/&fil *file &mbr monmsg cpf9801 exec(goto error) ovrdbf &fil tofile(&lib/&fil) mbr(&mbr) chgvar &libq ('"' *cat &lib *tcat '"') chgvar &filq ('"' *cat &fil *tcat '"') /*šset srcdat = lower(srcdat) €*/ strqmqry qmqry(anewns/loq) + setvar( (lib &libq) + (fil &filq) ) dltovr &fil /*šcompletion message */ chgvar &msgdta (&lib *tcat '/' *cat &fil *bcat &mbr *bcat 'updated') sndpgmmsg msgid(cpf9898) msgf(qcpfmsg) + msgdta(&msgdta) topgmq(*ext) msgtype(*status) dlyjob dly(2) goto endpgm /*ˆabnormal end ---------------------------------------------------------€*/ error: rcvmsg msgdta(&msgdta) msgid(&msgid) + msgf(&msgf) msgflib(&msgflib) monmsg cpf0001 sndpgmmsg msgid(&msgid) msgf(&msgflib/&msgf) + msgdta(&msgdta) monmsg cpf0001 endpgm: endpgm
Mbr: LOQ, Type: QMQRY, Text: Set Source to Lowercase
update &LIB/&FIL set srcdta = lower(srcdta), srcdat = 0
SQL Execute Immediate string

Mbr: SQL0_PR, Type: TXT, Text: Execute SQL string
d execute_sql_i pr extpgm('SQL0') d i_sql 5000a varying d o_return 7a
Mbr: SQL0, Type: SQLRPGLE, Text: SQL Execute Immediate string
/title Execute SQL Immediate /if defined (*CRTBNDRPG) h dftactgrp(*no) actgrp(*caller) /endif //‚::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: //šSystem //šTitle Execute SQL Immediate //šMember SQL0 SQLRPGLE //šPgmr Andrew Newns dd/mm/yy //šObjective //šThis program will perform an execute immediate on an sql string. //šParameters //šI i_sql sql string //šO o_return Blank if OK //‚....................................................................... //šChanges: //šdd/mm/yyyy xxnn name //š. //‚::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: //‚Prototypes //šPrototype: *ENTRY ------------------------------------------------------------------------- /copy qrpglesrc,sql0_pr d execute_sql_i pi d i_sql 5000 varying d o_return 7a //šPrototype: Test assertion ----------------------------------------------------------------- d assert pr d condition n value d message 80a value //šPrototype: SQL error trapping ------------------------------------------------------------- d sql_check pr //‚Data structues //šProgram Status ds dProgStatus sds d PsProgram *PROC d PsMsgPq *PROC d PsStatus *STATUS d PsRoutine *ROUTINE d PsParms *PARMS d PsMsgArea 30a overlay( progstatus:51 ) d PsJobName 10a overlay( progstatus:244 ) d PsUser 10a overlay( progstatus:254 ) d PsJobNbr 6s 0 overlay( progstatus:264 ) //šNull indicators d null ds qualified d col01 5i 0 //‚Constants d Yes c const( 'Y' ) d No c const( 'N' ) d SQ c const( x'7D' ) d true s n inz( '1' ) d false s n inz( '0' ) d #NULL c -1 //‚Workfields d screen s 10a d screrror s n d sqlstr s 5000a d w_errtxt s 120a d w_jobtxt s 100a d w_pgmtxt s 20a //‚Mainline /free monitor ; exsr inz_pgm ; exsr inz_sql ; exsr process ; exsr end_normal ; on-error 1211 ; assert (*off : 'File not open.' + w_errtxt) ; on-error *FILE ; assert (*off : 'Unexpected *FILE error' + w_errtxt) ; on-error *PROGRAM ; assert (*off : 'Unexpected *PROGRAM error' + w_errtxt) ; on-error ; assert (*off : 'Unexpected error' + w_errtxt) ; endmon ; //š---------------------------------------------------------------------- //šProcess begsr process ; exec sql EXECUTE IMMEDIATE : i_sql ; sql_check() ; endsr ; //š---------------------------------------------------------------------- //šInitialise program begsr inz_pgm ; o_return = 'INZ' ; w_pgmtxt = ' PGM: ' + psprogram ; w_jobtxt = ' JOB: ' + %char(psjobnbr) + '/' + %trimr(psuser) + '/' + psjobname ; w_errtxt = %trimr(w_pgmtxt) + w_jobtxt ; endsr ; //š---------------------------------------------------------------------- //šInitialise SQL begsr inz_SQL ; endsr ; //š---------------------------------------------------------------------- //šNormal end begsr end_normal ; o_return = *blank ; exsr end_pgm ; endsr ; //š---------------------------------------------------------------------- //šAbnormal end begsr end_abnormal ; assert (*off : 'Program has ended abnormally' + w_errtxt ) ; endsr ; //š---------------------------------------------------------------------- //šEnd the program begsr end_pgm ; *inlr = true ; return ; endsr ; /end-free //‚====================================================================== //‚Sub-Procedures //‚====================================================================== //š---------------------------------------------------------------------- //šSQL Error Check p sql_check b d sql_check pi d nbrofrows s 10u 0 d errtxt s 200a /free select; when %subst(SQLSTATE :1 :2) = '00' ; //šOK // exec sql get diagnostics :NbrOfRows = ROW_COUNT ; return ; when %subst(SQLSTATE :1 :2) = '01' ; //šWarning exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ; return ; when %subst(SQLSTATE :1 :2) = '02' ; //šNo more rows exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ; return ; when %subst(SQLSTATE :1 :2) >= '03' ; //šError exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ; o_return = 'ERR:SQL' ; assert (*off : %trimr(errtxt) + w_errtxt ) ; return ; endsl ; /end-free p e //š------------------------------------------------------------------- //šTest the assertion p assert b d assert pi d condition n value d message 80a value d sendescmsg pr extpgm('QMHSNDPM') d msgid 7 const d msgfile 20 const d msgdta 80 const d msgdtalen 10i 0 const d msgtype 10 const d msgq 10 const d msgqnbr 10i 0 const d msgkey 4 d errords 16 d d errords ds 16 d bytesprov 10i 0 inz( 16 ) d bytesavail 10i 0 d exceptionid 7 d msgdta s 80 d msgkey s 4 d msgtypeA s 7 /free if (not condition); dump(a) ; *inlr = *on; sendescmsg ('CPF9898' : 'QCPFMSG QSYS': message : %len(message) : '*ESCAPE' : '*PGMBDY' : 1 : msgkey : errords) ; endif; return ; /end-free p e
SQL Execute Immediate string and return a parameter

Mbr: SQL1_PR, Type: TXT, Text: Execute SQL string with return parm
d execute_sql pr extpgm('SQL1') d i_sql 5000a varying d o_nbr 15 5 d o_return 7a
Mbr: SQL1, Type: SQLRPGLE, Text: SQL Execute Immediate string with return parm
/title Execute SQL /if defined (*CRTBNDRPG) h dftactgrp(*no) actgrp(*caller) /endif //‚::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: //šSystem //šTitle Execute SQL //šMember SQL1 SQLRPGLE //šPgmr Andrew Newns dd/mm/yy //šObjective //šThis program will execute a sql string and then return a single //šnumeric output parameter. //šParameters //šI i_sql sql string //šI o_nbr numeric value //šO o_return Blank if OK //‚....................................................................... //šChanges: //šdd/mm/yyyy xxnn name //š. //‚::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: //‚Prototypes //šPrototype: *ENTRY ------------------------------------------------------------------------- /copy qrpglesrc,sql1_pr d execute_sql pi d i_sql 5000 varying d o_nbr 15 5 d o_return 7a //šPrototype: Test assertion ----------------------------------------------------------------- d assert pr d condition n value d message 80a value //šPrototype: SQL error trapping ------------------------------------------------------------- d sql_check pr //‚Data structues //šProgram Status ds dProgStatus sds d PsProgram *PROC d PsMsgPq *PROC d PsStatus *STATUS d PsRoutine *ROUTINE d PsParms *PARMS d PsMsgArea 30a overlay( progstatus:51 ) d PsJobName 10a overlay( progstatus:244 ) d PsUser 10a overlay( progstatus:254 ) d PsJobNbr 6s 0 overlay( progstatus:264 ) //šNull indicators d null ds qualified d col01 5i 0 //‚Constants d Yes c const( 'Y' ) d No c const( 'N' ) d SQ c const( x'7D' ) d true s n inz( '1' ) d false s n inz( '0' ) d #NULL c -1 //‚Workfields d screen s 10a d screrror s n d sqlstr s 5000a d w_errtxt s 120a d w_jobtxt s 100a d w_pgmtxt s 20a //‚Mainline /free monitor ; exsr inz_pgm ; exsr inz_sql ; exsr process ; exsr end_normal ; on-error 1211 ; assert (*off : 'File not open.' + w_errtxt) ; on-error *FILE ; assert (*off : 'Unexpected *FILE error' + w_errtxt) ; on-error *PROGRAM ; assert (*off : 'Unexpected *PROGRAM error' + w_errtxt) ; on-error ; assert (*off : 'Unexpected error' + w_errtxt) ; endmon ; //š---------------------------------------------------------------------- //šProcess begsr process ; exec sql FETCH c1 into :o_nbr : null.col01 ; sql_check() ; if null.col01 = #NULL ; o_nbr = 0 ; endif ; endsr ; //š---------------------------------------------------------------------- //šInitialise program begsr inz_pgm ; o_return = 'INZ' ; w_pgmtxt = ' PGM: ' + psprogram ; w_jobtxt = ' JOB: ' + %char(psjobnbr) + '/' + %trimr(psuser) + '/' + psjobname ; w_errtxt = %trimr(w_pgmtxt) + w_jobtxt ; endsr ; //š---------------------------------------------------------------------- //šInitialise SQL begsr inz_SQL ; exec sql PREPARE s1 from :i_sql ; sql_check() ; exec sql DECLARE c1 cursor for s1 ; sql_check() ; exec sql OPEN c1 ; sql_check() ; endsr ; //š---------------------------------------------------------------------- //šNormal end begsr end_normal ; exec sql CLOSE c1 ; sql_check() ; o_return = *blank ; exsr end_pgm ; endsr ; //š---------------------------------------------------------------------- //šAbnormal end begsr end_abnormal ; assert (*off : 'Program has ended abnormally' + w_errtxt ) ; endsr ; //š---------------------------------------------------------------------- //šEnd the program begsr end_pgm ; *inlr = true ; return ; endsr ; /end-free //‚====================================================================== //‚Sub-Procedures //‚====================================================================== //š---------------------------------------------------------------------- //šSQL Error Check p sql_check b d sql_check pi d nbrofrows s 10u 0 d errtxt s 200a /free select; when %subst(SQLSTATE :1 :2) = '00' ; //šOK // exec sql get diagnostics :NbrOfRows = ROW_COUNT ; return ; when %subst(SQLSTATE :1 :2) = '01' ; //šWarning exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ; return ; when %subst(SQLSTATE :1 :2) = '02' ; //šNo more rows exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ; return ; when %subst(SQLSTATE :1 :2) >= '03' ; //šError exec sql get diagnostics condition 1 :errtxt = MESSAGE_TEXT ; o_return = 'ERR:SQL' ; assert (*off : %trimr(errtxt) + w_errtxt ) ; return ; endsl ; /end-free p e //š------------------------------------------------------------------- //šTest the assertion p assert b d assert pi d condition n value d message 80a value d sendescmsg pr extpgm('QMHSNDPM') d msgid 7 const d msgfile 20 const d msgdta 80 const d msgdtalen 10i 0 const d msgtype 10 const d msgq 10 const d msgqnbr 10i 0 const d msgkey 4 d errords 16 d d errords ds 16 d bytesprov 10i 0 inz( 16 ) d bytesavail 10i 0 d exceptionid 7 d msgdta s 80 d msgkey s 4 d msgtypeA s 7 /free if (not condition); dump(a) ; *inlr = *on; sendescmsg ('CPF9898' : 'QCPFMSG QSYS': message : %len(message) : '*ESCAPE' : '*PGMBDY' : 1 : msgkey : errords) ; endif; return ; /end-free p e
Display EBCDIC character set

Mbr: SYM, Type: RPGLE, Text: Display EBCDIC character set
/title Display EBCDIC character set h copyright('Andrew Newns 2010') h option(*nodebugio:*srcstmt) /if defined (*CRTBNDRPG) h dftactgrp(*no) actgrp(*caller) /endif //š:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: //šAndrew Newns, dd/mm/yy //šDisplay EBCDIC character set //š:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: fsymd cf e workstn extdesc('ANEWNS/SYMD') compile time f extfile('ANEWNS/SYMD') run time f prefix(scr_) f sfile(sfl:scr_sflrrn) f indds(indds_1) d cvthex pr 2a d #i 10i 0 const d cvtbin pr 8a d #i 10i 0 const d cvtchr pr 1a d #c 3u 0 const d bin 8a const //šDisplay File Indicator Data Structure d indds_1 ds d ScrExit n overlay( indds_1 : 03 ) d SflClr n overlay( indds_1 : 30 ) d SflDsp n overlay( indds_1 : 31 ) d SflDspCtl n overlay( indds_1 : 32 ) d SflEnd n overlay( indds_1 : 33 ) d SflNxtChg n overlay( indds_1 : 34 ) d SflMsgInd n overlay( indds_1 : 35 ) d ScrVldCmd n overlay( indds_1 : 40 ) d true s n inz( *on ) d false s n inz( *off ) d #SCREEN01 c const( 'SCREEN01' ) d screen s 10a D #i s 10i 0 d hex s like(scr_hex ) d bin s like(scr_bin ) d chr s like(scr_chr ) d SQ c const(x'7D') Single Quote //š------------------------------------------------------------------------------------------- //šmainline /free //šClear sfl sflclr = true ; write sflctl ; sflclr = false ; sflend = false ; screen = #SCREEN01 ; //šFill sfl for #i = 0 to 255 ; scr_dec = #i ; scr_hex = cvthex( #i ); scr_bin = cvtbin( #i ); scr_chr = cvtchr( #i : scr_bin ) ; scr_sflrrn += 1 ; if #i < 64 ; //šhex codes lower than '40' are invalid, but can be used as display attributes scr_txt = 'AAA' ; scr_dspatr = %bitor( x'00' : scr_chr ) ; scr_chr = *blank ; else ; scr_txt = *blank ; scr_dspatr = x'20' ; endif ; write sfl ; endfor ; sflend = true ; //šDisplay sfl dow screen = #SCREEN01 ; write sflftr ; SflDsp = true ; SflDspCtl = true ; exfmt sflctl ; if screxit ; screen = *blank ; leave ; endif ; enddo ; //šEnd *inlr = *on ; return ; /end-free //š------------------------------------------------------------------------------------------- p cvthex b d cvthex pi 2a d #i 10i 0 const d hex_ds ds d 16a inz( '0123456789ABCDEF' ) d hex_a 1a dim( 16 ) overlay(hex_ds) d hex s 8a d div s 10u 0 d rem s 10u 0 /free div = %div(#i :16) ; rem = %rem(#i :16) ; return hex_a( div+1 ) + hex_a( rem+1 ) ; /end-free p cvthex e //š------------------------------------------------------------------------------------------- p cvtbin b d cvtbin pi 8a d #i 10i 0 const d bin ds 8 d bin_a 1a dim(8) overlay(bin:1) d rem s 10i 0 inz( 0 ) d #p s 10i 0 inz( 7 ) /free rem = #i ; bin = '00000000' ; for #p = 7 downto 0 by 1; if rem >= 2 ** #p ; bin_a( 8-#p ) = '1' ; rem -= 2 ** #p ; endif ; endfor ; return bin ; /end-free p cvtbin e //š------------------------------------------------------------------------------------------- p cvtchr b d cvtchr pi 1a d #c 3u 0 const d bin 8a const d #p s 10i 0 inz( 7 ) d chr s 1a d x00 s 1a inz(x'00') d x01 s 1a inz(x'01') 2[0 = 1 d x02 s 1a inz(x'02') 2[1 = 2 d x03 s 1a inz(x'04') 2[2 = 4 d x04 s 1a inz(x'08') 2[3 = 8 d x05 s 1a inz(x'10') 2[4 = 16 d x06 s 1a inz(x'20') 2[5 = 32 d x07 s 1a inz(x'40') 2[6 = 64 d x08 s 1a inz(x'80') 2[7 = 128 /free chr = x00 ; if %subst( bin : 1 : 1 ) = '1' ; chr = %bitor( chr : x08 ) ; endif ; if %subst( bin : 2 : 1 ) = '1' ; chr = %bitor( chr : x07 ) ; endif ; if %subst( bin : 3 : 1 ) = '1' ; chr = %bitor( chr : x06 ) ; endif ; if %subst( bin : 4 : 1 ) = '1' ; chr = %bitor( chr : x05 ) ; endif ; if %subst( bin : 5 : 1 ) = '1' ; chr = %bitor( chr : x04 ) ; endif ; if %subst( bin : 6 : 1 ) = '1' ; chr = %bitor( chr : x03 ) ; endif ; if %subst( bin : 7 : 1 ) = '1' ; chr = %bitor( chr : x02 ) ; endif ; if %subst( bin : 8 : 1 ) = '1' ; chr = %bitor( chr : x01 ) ; endif ; return chr ; /end-free p cvtchr e
Mbr: SYMD, Type: DDS, Text: Display EBCDIC character set
A*%%TS SD 20101216 022353 ANEWNS REL-V6R1M0 5761-WDS A*%%EC A DSPSIZ(24 80 *DS3) A INDARA A PRINT A CA03(03 'Exit') A*š================================================================= A R SFL SFL A*%%TS SD 20101216 022353 ANEWNS REL-V6R1M0 5761-WDS A TEXT('EBCDIC Subfile') A DSPATR 1A P TEXT('Display Attributes') A DEC 3S 0O 4 2 A HEX 2A O 4 7 A BIN 8A O 4 11 A CHR 1A O 4 21 A TXT 3A O 4 27DSPATR(&DSPATR) A*š................................................................. A R SFLCTL SFLCTL(SFL) A*%%TS SD 20101216 022353 ANEWNS REL-V6R1M0 5761-WDS A SFLSIZ(0999) A SFLPAG(0018) A TEXT('EBCDIC Subfile control') A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A 30 SFLCLR A 33 SFLEND(*MORE) A SFLRRN 4S 0H A 1 2'SYM' A DSPATR(HI) A 1 7'Display EBCDIC character set' A DSPATR(HI) A 3 2'Dec' A DSPATR(HI) A 3 7'Hex' A DSPATR(HI) A 3 11'Bin' A DSPATR(HI) A 3 21'Char' A DSPATR(HI) A 3 27'DspAtr' A DSPATR(HI) *š--------------------------------------------------------------- A R SFLFTR A*%%TS SD 20100823 100336 ANEWNS REL-V6R1M0 5761-WDS A SETCSR 1A B 23 2DSPATR(ND) A PUSHBTN 2Y 0B 23 4PSHBTNFLD((*GUTTER 1)) A PSHBTNCHC(1 'F3/Exit' CA03)
Backup IBM source on PC

Mbr: BACKUP_IBM, Type: TXT, Text: Backup IBM to PC
:http://forums.systeminetwork.com/isnetforums/showthread.php?t=106881 open SYSTEM USER_PROFILE PASSWORD ascii quote site namefmt 0 cd anewns lcd c:\data\source prompt off mget qsrc.* mget qsqlsrc.* mget qsrvsrc.* quit