|
 |
|
OTHER - Generate Random Number
Posted By: JimmyOctane Contact |
D C0Seed S 5I 0 Inz(0)
D C0RndNbr S 8F
**-- Random Number Conversion: ---------------------------------- **
D RndNbr S 10I 0
D MaxNbr S 10I 0 Inz(9000000)
D MinNbr S 10I 0 Inz(1000000)
**
**----------------------------------------------------------------**
**
C DoU RndNbr >= MinNbr
**
C CallB 'CEERAN0'
C Parm C0Seed
C Parm C0RndNbr
C Parm *OMIT
**
C Eval RndNbr = %DecH(C0RndNbr:30:29) * MaxNbr
C EndDo
**
C Return
| |
OTHER - using QSHELL
Posted By: Scott Klement Contact |
* This rather silly program reads STDIN and translates all of the
* spaces to periods, then writes it to STDOUT.
*
* You need to run this from QSHELL for it to be useful:
* /qsys.lib/yourlib.lib/this.pgm
H BNDDIR('QC2LE') DFTACTGRP(*NO)
D read PR 10I 0 extproc('read')
D fd 10I 0 value
D buf * value
D len 10I 0 value
D write PR 10I 0 extproc('write')
D fd 10I 0 value
D buf * value
D size 10I 0 value
D data S 80A
D len S 10I 0
c eval len = read(0: %addr(data): %size(data))
c dow len > 0
c ' ':'.' xlate data data
c callp write(1: %addr(data): len)
c eval len = read(0: %addr(data): %size(data))
c enddo
c eval *inlr = *on
To run this, you need to run it from QSHELL. Here's how I did it:
1) Type STRQSH
2) At the QSHELL prompt, I typed:
echo "I sure wish I had periods in this text!" | /qsys.lib/mylib.lib/test.pgm
(that should all be one line, if it gets wrapped)
And the result looked like this:
I.sure.wish.I.had.periods.in.this.text!
| |
OTHER - Calling RPG from JAVA
Posted By: JimmyOctane Contact |
import java.sql.*;
public class staticSqlCall
{
public static void main(String[] args) throws SQLException
{
// Check the input parameters.
if (args.length != 1) {
System.out.println("Try again! Enter an 8-byte Customer Number");
return;
}
/*****************************************************************/
Connection con = null;
String url = "jdbc:as400://Your IP address";
// Load the JDBC driver
DriverManager.registerDriver(new com.ibm.as400.access.AS400JDBCDriver());
// Connect to the database
System.out.println ("Connecting to AS/400...");
con = DriverManager.getConnection (url, "USERID", "PASSWORD");
/*****************************************************************/
CallableStatement sqlCall;
sqlCall = con.prepareCall("CALL YourLib.CUSTFOUND(?,?)");
// Run an SQL SELECT statement
sqlCall.setString(1, args[0]); //customer id
sqlCall.registerOutParameter(2, java.sql.Types.SMALLINT); //found
System.out.println ("Calling the RPG program...");
sqlCall.execute();
System.out.println ("Retrieving the out parms...");
boolean found = sqlCall.getBoolean(2);
if (found)
{
System.out.println ("Customer " + args[0] + " is valid");
}
else
{
System.out.println ("Customer " + args[0] + " is NOT valid");
}
sqlCall.close();
con.close();
}
}
| |
OTHER - convert HEX to decimal
Posted By: Mel Rothman Contact |
Below is a small RPG IV program that converts and displays the data properly. Create it with the CRTBNDRPG command.
It outputs:
DSPLY 97391129
H dftactgrp(*NO) ACTGRP(*NEW)
D ds ds 8
D hexvalue 8
D intvalue 20i 0 overlay(hexvalue)
D CharValue s 21
C eval hexvalue=x'0000000005CE1219'
C eval charvalue = %char(intvalue)
C charvalue dsply
C eval *inlr = *on
| |
OTHER - Utility to print sample of External Print File
Posted By: Denny Contact |
PRTPRTF Utility. This command reads a printer file DDS source member, creates a
RPG IV source member to print the DDS, compiles and executes the RPG program.
This is useful for documenting external printer files and producing prototypes
during the development phase.
*** PRTPRTF QCMDSRC ***
/* Print Sample of Ext Print File */
/* +-------------------------------------------------------------------+ */
/* | This program is the property of: | */
/* | ProMIS, R. D. Davis Copyright 2004 | */
/* | 1716 Cove Point | */
/* | Gainesville, GA 30501-1468 | */
/* | 770-297-9929 denny@techie.com | */
/* +-------------------------------------------------------------------+ */
/* | Date written: 04/05/04 Author: R. D. Davis | */
/* | Date modified: XX/XX/XX By: RDD | */
/* | | */
/* +-------------------------------------------------------------------+ */
CMD PROMPT('Print Sample of Ext Print File')
PARM KWD(MBR) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('Printer File Source Member')
PARM KWD(LIBRARY) TYPE(*NAME) LEN(10) +
SPCVAL((*LIBL)) PROMPT('Printer File & +
QDDSSRC library')
*** PRTPRTF QCLSRC ***
/* Print sample of External Printer File */
/* */
/* +-------------------------------------------------------------------+ */
/* | This program is the property of: | */
/* | ProMIS, R. D. Davis Copyright 2004 | */
/* | 1716 Cove Point | */
/* | Gainesville, GA 30501-1468 | */
/* | 770-297-9929 denny@techie.com | */
/* +-------------------------------------------------------------------+ */
/* | Date written: 04/05/04 Author: R. D. Davis | */
/* | Date modified: XX/XX/XX By: RDD | */
/* | | */
/* +-------------------------------------------------------------------+ */
PGM PARM(&DDSMBR &DDSLIB )
DCL &DDSMBR *CHAR 10
DCL &DDSLIB *CHAR 10
DCL &ABEND *LGL
DCL &MSGDTA *CHAR 132
DCL &MSGID *CHAR 7
DCL &MSGF *CHAR 10
DCL &MSGFLIB *CHAR 10
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ABEND))
CHKOBJ OBJ(QTEMP/QRPGLESRC) OBJTYPE(*FILE) MBR(PRTSAMPLE)
MONMSG CPF9801 EXEC(DO) /* FILE NOT FOUND */
RCVMSG MSGTYPE(*EXCP) RMV(*YES)
CRTSRCPF FILE(QTEMP/QRPGLESRC) RCDLEN(112) MBR(*NONE) +
MAXMBRS(*NOMAX) SIZE(*NOMAX) AUT(*ALL)
ADDPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE) +
SRCTYPE(RPGLE)
ENDDO
MONMSG CPF9815 EXEC(DO) /* MEMBER NOT FOUND */
RCVMSG MSGTYPE(*EXCP) RMV(*YES)
ADDPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE) +
SRCTYPE(RPGLE)
ENDDO
CLRPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE)
OVRDBF FILE(QRPGLESRC) TOFILE(QTEMP/QRPGLESRC) +
MBR(PRTSAMPLE)
OVRDBF FILE(QDDSSRC) TOFILE(&DDSLIB/QDDSSRC) +
MBR(&DDSMBR)
DSPFFD FILE(&DDSLIB/&DDSMBR) OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/DSPFFD)
OVRDBF FILE(QADSPFFD) TOFILE(QTEMP/DSPFFD)
CALL PRTPRTF1 &DDSMBR
CRTBNDRPG PGM(QTEMP/SAMPLE) SRCFILE(QTEMP/QRPGLESRC) +
DFTACTGRP(*NO) ACTGRP(*CALLER) OUTPUT(*NONE)
OVRPRTF FILE(&DDSMBR) PRTTXT(*BLANK)
CALL PGM(QTEMP/SAMPLE)
EXIT: RETURN /* NORMAL END OF JOB */
ABEND: IF COND(&ABEND) THEN(SNDPGMMSG MSGID(CPF9898) +
MSGF(QCPFMSG) MSGDTA('Function check.') +
MSGTYPE(*ESCAPE))
CHGVAR VAR(&ABEND) VALUE('1')
DMPCLPGM
/* Forward diagnostic messages from this program message queue to previous */
FORWARD: RCVMSG MSGTYPE(*DIAG) RMV(*NO) MSGDTA(&MSGDTA) +
MSGID(&MSGID) MSGF(&MSGF) MSGFLIB(&MSGFLIB)
IF (&MSGID ¬= ' ') DO
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*DIAG)
GOTO FORWARD
ENDDO
RCVMSG MSGTYPE(*EXCP) RMV(*NO) MSGDTA(&MSGDTA) +
MSGID(&MSGID) MSGF(&MSGF) MSGFLIB(&MSGFLIB)
IF (&MSGID ¬= ' ') DO
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
ENDDO
ENDPGM
*** PRTPRTF1 QRPGLESRC ***
H/TITLE Print sample of External Printer File
** +--------------------------------------------------------------+
** | This program is the property of: |
** | ProMIS, R. D. Davis Copyright 2004 |
** | 1716 Cove Point |
** | Gainesville, GA 30501-1468 |
** | 770-297-9929 denny@techie.com |
** +--------------------------------------------------------------+
** | Date written: 04/05/04 Author: R. D. Davis |
** | Date modified: XX/XX/XX |
** | |
** +--------------------------------------------------------------+
H bnddir('QC2LE')
Fqddssrc ip f 92 disk
Fqrpglesrc o f 112 disk
D f_spec ds 112
D f_seq 1 6 0 inz
D f_id 18 18 inz('F')
D f_file 19 28
D f_o 29 29 inz('o')
D f_f 34 34 inz('e')
D f_dev 48 57 inz('printer')
D c_spec ds 112
D c_seq 1 6 0 inz
D c_id 18 18 inz('C')
D factor_1 24 37
D oper 38 47
D Factor_2 48 61
D Factor2 48 92
D Result 62 75
D p_record_name s like(record_name)
D ffd e ds extname(qadspffd)
Iqddssrc ns 01 19 c*
I ns 02 29 cR
I 31 40 record_name
I ns 03 31nc
I 31 40 field_name
I 41 41 Ref_field
I 49 49 Dec_Pos
I ns 04
C if *in02
C and p_record_name <> record_name
C if p_record_name <> *blank
C eval oper = 'write'
C eval factor_2 = p_record_name
C eval f_seq = f_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endif
C eval p_record_name = record_name
C endif
C if *in03
C if ref_field = 'R'
C/Exec sql
C+ select *
C+ into :ffd
C+ from QTEMP/DSPFFD
C+ where Whflde = :field_name
C/end-exec
C select
C when whfldt = 'L'
C or whfldt = 'T'
C or whfldt = 'Z'
C eval oper = 'time'
C eval result = field_name
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C when whfldt = 'B'
C or whfldt = 'B'
C or whfldt = 'S'
C or whfldt = 'P'
C or whfldt = 'F'
C exsr number
C when whfldt = 'A'
C exsr character
C endsl
C else Not Reference Field
C if dec_pos = *blank Character
C exsr character
C else Not Reference Field
C exsr number
C endif not Character
C endif
C endif
Clr exsr lr
C *inzsr begsr
C *entry plist
C parm file 10
C move file f_file
C eval f_seq = f_seq + 100
C write qrpglesrc f_spec
C eval c_seq = f_seq
C endsr
C character begsr
C eval oper = 'move'
C eval factor_2 = '*all''X'''
C eval result = field_name
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endsr
C number begsr
C eval oper = 'z-sub'
C eval factor_2 = '*all''9'''
C eval result = field_name
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endsr
C lr begsr
C eval oper = 'write'
C eval factor_2 = p_record_name
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C eval oper = 'eval'
C eval factor2 = '*inlr = *on'
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endsr
*** END OF SOURCE ***
| |
OTHER - No degug on files
Posted By: JimmyOctane Contact |
h option(*srcstmt: *nodebugio) dftactgrp(*no)
| |
OTHER - Renaming fields
Posted By: JimmyOctane Contact |
F*
F* model description file.
F*
FBIMODELP IF E K DISK Prefix(B)
All fields in file BIMODELP will have an addition letter in their name "B" .
F@PRODUCT IF E K DISK rename(PRG:PRG2) prefix(@:1)
This example replaces the first letter of all fields in file @PRODUCT with "@".
| |
OTHER - %XLATE examples
Posted By: JimmyOctane Contact |
D*
D* Constants
D*
D Up C CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
D Lo C CONST('abcdefghijklmnopqrstuvwxyz')
D Inc C CONST('BCDEFGHIJKLMNOPQRSTUVWXYZ*')
D
D*
D* Field Definitions.
D*
D ISOdate S D
D BeforeString S 256 Inz('my name is jimmyoctane')
D AfterString S 256
D Fnd S 3 0
D Pos S 3 0
D Chr1 S 1
D StartChar S 1
D NextChar S 1
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C* M A I N L I N E
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C* After below line of code is processed
C* BeforeString = my name is jimmyoctane
C* AfterString = MY NAME IS JIMMYOCTANE
C Eval AfterString = %xlate(Lo:Up:BeforeString)
C* After below line of code is processed
C* BeforeString = my name is jimmyoctane
C* AfterString = my name is JIMMYOCTANE
C Eval AfterString = %xlate(Lo:Up:Beforestring:12)
C* After below line of code is processed
C* BeforeString = my name is jimmyoctane
C* AfterString = My Name Is Jimmyoctane
C Z-add 1. Pos
C Movel(p) BeforeString AfterString
C Eval AfterString = %Trim(
C %Xlate(Lo:Up:%Subst(
C AfterString:1:1)) +
C %Subst(AfterString:2))
C
C Dou %Subst(BeforeString:Pos) = *Blanks
C Eval fnd = %scan(' ':AfterString:Pos)
C Eval fnd = (fnd + 1)
C Eval AfterString = %Subst(
C AfterString:1:fnd-1)
C + %Trim(
C %Xlate(Lo:Up:%Subst(
C BeforeString:Fnd:1)) +
C %Subst(AfterString:Fnd+1))
C Eval Pos = (fnd)
C Enddo
C* Increment a character.
C Eval NextChar = 'A'
C Do 25
C Eval NextChar = %xlate( Up:Inc:NextChar)
C NextChar dsply
C Enddo
C Eval *IN01 = *On
C Eval *INLR = *On
C*
| |
OTHER - Sign-on message id's
Posted By: JimmyOctane Contact |
Hackers like to know when they are making progress toward breaking into a
system. When an error message on the Sign On display says Password not
correct, the hacker can assume that the user ID is correct. You can frustrate the
hacker by using the Change Message Description (CHGMSGD) command to
change the text for two sign-on error messages.
Sign-on error messages
Message ID
CPF1107 CPF1107 Shipped text: Password not correct for user profile.
Recommended text: Sign-on information is not correct
Note: Do not include the message ID in the message text.
CPF1120 CPF1120 Shipped text: User XXXXX does not exist.
Recommended text: Sign-on information is not correct.
Note: Do not include the message ID in the message text.
| |
OTHER - INZTAP to previous ID
Posted By: JimmyOctane Contact |
Subroutine to INZTAP
*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
* $Setup - Setup for the backup.
*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C $Setup Begsr
*
* End subsystems yes of no. if yes then read file and end them
*
C KeyListName Setll BCKLIB02P
C KeyListName Reade BCKLIB02P
C Dow Not%Eof(BCKLIB02P)
*
C eval CmdString = %trim('ENDSBS') +
C %trim('~SBS(') +
C %trim(Subsystem) + %trim(')') +
C %trim('~OPTION(*IMMED)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %len(%trim(CmdString))
*
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C KeyListName Reade BCKLIB02P
C Enddo
*
* Check the tape drive.
*
C eval BackUpError = 'N'
C Clear WorkTapeName
C*
C Call 'INZTAPC'
C Parm 'C' OutProcess
C Parm TAPEDRIVE OutTape
C Parm InMSGID
C Parm InMESSAGE
C*
C If InMSGID <> 'CPC6778'
C Eval BackUpError = 'Y'
C Else
C 'Volume' Scan InMESSAGE Str
C If %Found
C Eval Str = (Str + 7)
C 'found' Scan InMESSAGE End
C If %Found
C Eval End = (End - 1)
C Eval Len = (End - Str)
C Eval WorkTapeName = %Subst(InMESSAGE:Str:Len)
C Endif
C Endif
C Endif
*
C if *in99 = *off and InzTap = 'Y'
*
C eval NewVolNam = @MSGDTA
C eval CmdString = %trim('INZTAP') +
C %trim('~DEV(') + %trim(TapeDrive) +
C %trim(')') +
C %trim('~NEWVOL(') +
C %trim(WorkTapeName) +
C %trim(')') +
C %trim('~NEWOWNID(BACKUP)') +
C %trim('~CHECK(*NO)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %len(%trim(CmdString))
*
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C if *in99 = *on
C eval BackUpError = 'Y'
C endif
*
C endif
*
C Endsr
Start of CLLE INZTAPC
PGM PARM(&PROCESS &TAPE &MSGID &MESSAGE)
DCL VAR(&TAPE) TYPE(*CHAR) LEN(10)
DCL VAR(&ERROR) TYPE(*CHAR) LEN(1)
DCL VAR(&PROCESS) TYPE(*CHAR) LEN(1)
DCL VAR(&MESSAGE) TYPE(*CHAR) LEN(80)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(07)
DCL VAR(&JUNK) TYPE(*CHAR) LEN(80)
MONMSG MSGID(CPF0000)
/*************************/
/* Check tape processing */
/*************************/
IF COND(&PROCESS *EQ 'C') THEN(DO)
CHKTAP DEV(&TAPE)
RCVMSG PGMQ(*SAME) MSGQ(*PGMQ) MSG(&MESSAGE) +
MSGID(&MSGID)
CHGVAR VAR(&JUNK) VALUE(&MESSAGE)
ENDDO
/**************************/
/* InzTap tape processing */
/**************************/
IF COND(&PROCESS *EQ 'I') THEN(DO)
INZTAP DEV(&TAPE) NEWVOL(BACKUP) NEWOWNID(BACKUP) +
CHECK(*NO)
RCVMSG PGMQ(*SAME) MSGQ(*PGMQ) MSG(&MESSAGE) +
MSGID(&MSGID)
CHGVAR VAR(&JUNK) VALUE(&MESSAGE)
ENDDO
Exit: ENDPGM
| |
OTHER - Dynamic screen build QSNAPI
Posted By: JimmyOctane Contact |
*
* default activation group = DFTACTGRP *NO
h*
h option(*srcstmt: *nodebugio)
h*
h*
D CMP01 C CONST(01)
D Digits C CONST('0123456789')
D
D*
D* Program Info
D*
D SDS
D @PGM 001 010
D @PARMS 037 039 0
D @JOB 244 253
D @USER 254 263
D @JOB# 264 269 0
D*
D* Field Definitions.
D*
D ISOdate S D
D @Scrn1 S 1 Inz('Y')
D ScreenError S 1
D CmdString S 256
D CmdLength S 15 5
D DayOfWeek S 07 0
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C* M A I N L I N E
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
D F1 c x'31'
D F2 c x'32'
D F3 c x'33'
D sa_norm c x'20'
D txt s 128 inz('Press Enter to Roll, F3.')
D txtlen s 9b 0 inz(32)
D err s 8 inz(x'0000000000000000')
D aid s 1
D lines s 9b 0 inz(1)
D wf1 s 1
D wrtn s 9b 0
D ClrScr PR 9b 0 extproc('QsnClrScr')
D mode 1 options(*nopass) const
D cmdbuf 9b 0 options(*nopass) const
D env 9b 0 options(*nopass) const
D error 8 options(*nopass)
D WrtDta PR 9b 0 extproc('QsnWrtDta')
D data 128
D datalen 9b 0
D fldid 9b 0 options(*nopass) const
D row 9b 0 options(*nopass) const
D col 9b 0 options(*nopass) const
D strmatr 1 options(*nopass) const
D endmatr 1 options(*nopass) const
D strcatr 1 options(*nopass) const
D endcatr 1 options(*nopass) const
D cmdbuf 9b 0 options(*nopass) const
D env 9b 0 options(*nopass) const
D error 8 options(*nopass)
D GetAID PR 1 extproc('QsnGetAID')
D aid 1 options(*nopass)
D env 9b 0 options(*nopass) const
D error 8 options(*nopass)
D RollUp PR 9b 0 extproc('QsnRollUp')
D lines 9b 0 const
D top 9b 0 const
D bottom 9b 0 const
D cmdbuf 9b 0 options(*nopass) const
D env 9b 0 options(*nopass) const
D error 8 options(*nopass)
C*
C*
C* Screen build and display
C*
C DoW wrtn = 0
C*
C Eval wrtn = ClrScr('0' : 0 : 0 : err)
C*
C Eval txt = 'Code400.com'
C Eval wrtn = WrtDta (txt : txtlen : 0 : 02 :38 :
C sa_norm:sa_norm:sa_norm:sa_norm:0:0:err)
C*
C Eval txt = 'DYNAMIC SCREEN CREATION'
C Eval wrtn = WrtDta (txt : txtlen : 0 : 03 :33 :
C sa_norm:sa_norm:sa_norm:sa_norm:0:0:err)
C*
C Eval txt = ' F1=Some Function'
C Eval wrtn = WrtDta (txt : txtlen : 0 : 08 :10 :
C sa_norm:sa_norm:sa_norm:sa_norm:0:0:err)
C*
C Eval txt = ' F2=Another Function'
C Eval wrtn = WrtDta (txt : txtlen : 0 : 09 :10 :
C sa_norm:sa_norm:sa_norm:sa_norm:0:0:err)
C*
C*
C Eval txt = 'F3=Exit'
C Eval wrtn = WrtDta (txt : txtlen : 0 : 23 :02 :
C sa_norm:sa_norm:sa_norm:sa_norm:0:0:err)
C*
C* The line below ends the data Entry
C*
C Eval wf1 = GetAID (aid : 0 : err)
C*
C Select
C When aid = F1
C Eval txt = ' You Pressed F1'
C Eval wrtn = WrtDta (txt : txtlen : 0 : 08 :30 :
C sa_norm:sa_norm:sa_norm:sa_norm:0:0:err)
C When aid = F2
C Eval txt = ' You Pressed F2'
C Eval wrtn = WrtDta (txt : txtlen : 0 : 09 :30 :
C sa_norm:sa_norm:sa_norm:sa_norm:0:0:err)
C When aid = F3
C Leave
C Endsl
C*
C EndDo
C*
C SetOn Lr
C Return
| |
OTHER - Color source with HEX
Posted By: JimmyOctane Contact |
H dftactgrp(*no) option(*srcstmt : *nodebugio)
F*
F* I know this is the system table for DSPFD *MBRLIST
F* but I am just going to CRTDUPOBJ to QTEMP and Override
F* Could have used CLLE but I wanted it all in one place
F*
FQAFDMBRL if e disk usropn
FQRPGLESRC Uf e disk usropn
F Rename(QRPGLESRC:Src)
*
* Field Definitions
*
D ISODate s D
D ISOTime s T
D*
D InLibrary s 10
D InSourceFile s 10
D*
D CmdString s 256
D CmdLength s 15 5
D*
D* Colors
D*
D Normal C X'20'
D Red C X'28'
D White C X'22'
D Blue C X'3A'
D Pink C X'38'
D NonDisplay C 'Hmm what could I do with this?'
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* M A I N L I N E
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C Exsr $GetSourceMbrs
C Exsr $ReadMembers
C Exsr $Process
C eval *inlr = *on
C return
C*----------------------------------------------------
C* $GetSourceMbrs - Load up the work file with members
C* from the source file
C* I assume RPGLE so when you mod
C* you will have to be much more
C* flexable.
C* DSPFD FILE(JJFLIB/QRPGLESRC) TYPE(*MBRLIST)
C* OUTPUT(*OUTFILE) OUTFILE(QTEMP/QAFDMBRL)
C*----------------------------------------------------
CSR $GetSourceMbrsbegsr
C*
C Eval CmdString = 'DSPFD FILE('
C + %Trim(InLibrary) + %Trim('/')
C + %trim(InSourceFile) + %Trim(')')
C + %trim('@@')
C + %trim('TYPE(*MBRLIST) OUTPUT(')
C + %trim('*OUTFILE) OUTFILE(QTEMP/')
C + %trim('*QAFDMBRL)')
C eval CmdString = %Xlate('@':' ': Cmdstring)
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C*
C* OVRDBF FILE(QAFDMBRL) TOFILE(QTEMP/QAFDMBRL)
C*
C Eval CmdString = 'OVRDBF FILE('
C + %Trim('QAFDMBRL) TOFILE(QTEMP/')
C + %trim('QAFDMBRL)')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C If Not%Open(QAFDMBRL)
C Open QAFDMBRL
C Endif
C*
C endsr
C*----------------------------------------------------
C* $ReadMembers - Read through the members overriding
C* to each.. to color the lines of code
C*----------------------------------------------------
CSR $ReadMembers begsr
C*
C *Start Setll QAFDMBRL
C Read QAFDMBRL
C Dow Not%Eof(QAFDMBRL)
C*
C Exsr $SetupMember
C Exsr $Process
C*
C Read QAFDMBRL
C Enddo
C*
C endsr
C*----------------------------------------------------
C* $SetupMember - Do the override thing and color some
C* source.
C* I used similar technique for Y2K
C* there I created copy of source
C* and inserted code into members.
C* no insertion here just updates.
C*----------------------------------------------------
CSR $SetUpMember begsr
C*
C If MLSEU2 = 'RPGLE'
C*
C If %Open(QRPGLESRC)
C Close QRPGLESRC
C Endif
C*
C* DLTOVR QRPGLESRC *ALL
C*
C Eval CmdString = 'DLTOVR QRPGL'
C + %Trim('ESRC *ALL')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C*
C* OVRDBF FILE(QRPGLESRC) TOFILE(JJFLIB/QRPGLESRC) MBR(&MEMBER)
C*
C Eval CmdString = 'OVRDBF FILE(QRPGLESRC'
C + %Trim(') TOFILE(')
C + %Trim(InLibrary )
C + %Trim('/')
C + %Trim(InSourceFile)
C + %Trim(') MBR(')
C + %Trim(MLNAME)
C + %Trim(')')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C If Not%Open(QRPGLESRC)
C Open QRPGLESRC
C Endif
C Endif
C endsr
C*----------------------------------------------------
C* $Process - Lets do it This is all hard coded
C* should be table driven dont shoot
C* just example.
C*----------------------------------------------------
CSR $Process begsr
C *Start setll QRPGLESRC
C read QRPGLESRC
C Dow Not%Eof(QRPGLESRC)
C*
C* make comments white
C*
C If %Subst(SRCDTA:7:1) = '*'
C And %Subst(SRCDTA:1:1) <> white
C And %Subst(SRCDTA:6:1) <> pink
C Eval %Subst(SRCDTA:1:1) = white
C Eval %Subst(SRCDTA:100:1) = normal
C Update Src
C Endif
C*
C* make headings pink - Stop with the jokes
C*
C If %Subst(SRCDTA:6:1) = 'H'
C And %Subst(SRCDTA:1:1) <> pink
C Eval %Subst(SRCDTA:1:1) = pink
C Eval %Subst(SRCDTA:100:1) = normal
C Update Src
C Endif
C read QRPGLESRC
C enddo
C endsr
C*----------------------------------------------------
C* *Inzsr - One time run subroutine.
C*----------------------------------------------------
CSR *Inzsr begsr
C*
C *Entry plist
C parm InLibrary
C parm InSourceFile
C*
C* Okay I would use api to verify that this is truely a source file
C* but because I want to complete this in the next few minutes
C* I am going to skip that. Please if you add in send source back
C* to me so that I can post for others.
C*
C endsr
| |
OTHER - RUNSQLSTM example
Posted By: JimmyOctane Contact |
H dftactgrp(*no) option(*srcstmt : *nodebugio)
FFIELDSP IF E DISK usropn
FSOURCE UF A E DISK rename(SOURCE:src)
F usropn
*
* Fields Definition
* ~~~~~~~~~~~~~~~~~
D CmdString s 500 inz(*blanks)
D CmdLength s 15 5 inz(0)
D Q s 01 inz('''')
*
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* M A I N L I N E
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
* CLRPFM FILE(JJFLIB/SOURCE) MBR(GENSQL)
*
C Eval CmdString = 'CLRPFM FILE(JJFLIB/'
C + %trim('SOURCE) MBR(GENSQL')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C*
C If Not%Open(FIELDSP)
C Open FIELDSP
C Endif
C*
C *Start Setll FIELDSP
C Read FIELDSP
C Dow Not%Eof(FIELDSP)
*
* OVRDBF FILE(ZSOURCE) TOFILE(JJFLIB/SOURCE) MBR(SOMEMEMBER)
*
C Eval CmdString = 'OVRDBF FILE(SOURCE) T'
C + %trim('OFILE(JJFLIB/SOURCE) M')
C + %trim('BR(GENSQL)')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C If Not%Open(SOURCE)
C Open SOURCE
C Endif
C If RECORDS > *Zeros
C And LENGTH = 33.
C Exsr $SQLWrite
C Endif
C Read FIELDSP
C Enddo
C Eval CmdString = 'DLTOVR *ALL'
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C*
C If %Open(FIELDSP)
C Close FIELDSP
C Endif
C*
C*RUNSQLSTM SRCFILE(JJFLIB/SOURCE) SRCMBR(GENSQL) OUTPUT(*PRINT)
C*
C Eval CmdString = 'RUNSQLSTM SRCFILE('
C + %Trim('JJFLIB/SOURCE) SRCMBR(GENSQL')
C + %Trim(') COMMIT(*NONE) OUTPUT(*PRINT) ')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C Eval *INLR = *On
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* $SQLWrite - Write the SQL stuff.
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C $SQLWrite begsr
*
C Clear SRCDTA
C Write SRC
C Eval SRCDTA = %Trim('UPDATE')
C +%Trim('!RC1380BFR1/') + %Trim(FILE)
C +%Trim('!!') + %Trim('SET')
C +%Trim('!!') + %Trim(FIELD)
C +%Trim('!!') + %Trim('=')
C +%Trim('!!')
C +%Trim(Q) + %Trim('ASB AT-5OLD')
C +%Trim(Q) +%TRIM('!!')
C Eval SRCDTA = %Xlate('!':' ':SRCDTA)
C Write SRC
C Eval SRCDTA =
C %Trim('WHERE')
C +%Trim('!!') + %Trim(FIELD)
C +%Trim('!!') + %Trim('=') + %Trim('!!')
C +%Trim(Q) + %Trim('ASB AT-5') + %Trim(Q)
C +%TRIM('!!;')
C Eval SRCDTA = %Xlate('!':' ':SRCDTA)
C Write SRC
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* *inzsr - Initial one time run subroutine
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C *inzsr begsr
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
| |
OTHER - EDITC & EDITW examples
Posted By: JimmyOctane Contact |
* Misc. income amount
C EVAL %SUBST(RPAY$:1:13) =
C %EDITC(RPYPMT:'3')
* Payee's state number
C EVAL %SUBST(RSTATD:1:10) =
C %EDITW(RPSTAT:' - - ')
C EVAL %SUBST(RECPID:1:10) =
C %EDITW(AVIDNO:'0 - ')
C ELSE
C EVAL %SUBST(RECPID:1:11) =
C %EDITW(AVIDNO:'0 - - ')
C END
C IF %SUBST(RECPID:1:1) = ' '
C EVAL %SUBST(RECPID:1:1) = '0'
C END
C EVAL %SUBST(DSMKEY(Q):4:4) =
C %EDITC(CUR_OCUR:'X')
C EVAL @BEG_DATE = %EDITC(*YEAR:'X') +
C %EDITC(UMONTH:'X') + '01'
| |
OTHER - Iseries what version
Posted By: JimmyOctane Contact |
Call QSZRTVPR ( +
&RcvVar +
x'00000100' +
'PRDR0100' +
'*OPSYS *CUR 0000*CODE ' +
x'00000000' +
)
ChgVar &CurRls %sst( &RcvVar 20 6 )
OR
dspdtaara QSS1MRI
OR
Retrieve ILE Version and Platform ID
D VerRelMod S 10I 0
D OSPlatform S 10I 0
C CallB 'CEEGPID'
C Parm VerRelMod
C Parm OSPlatform
C If VerRelMod >= 510
* Insert V5R1 and later code here
C endif
| |
OTHER - Free form %LOOKUP
Posted By: jimmy octane Contact |
Use Array for list of parts for lookup
/free
If %lookup(Input_Part:Part_Array) = *zero;
Message = ‘Part entered, ‘ + Input_Part
+ ‘ is invalid.’;
Endif;
/end-free
If you're searching for multiple occurrences of an argument in an array, use a
starting index of one. Then, after a successful "hit," add one to the returned
index to set the starting index before the next search. Otherwise, you will
keep finding the same element.
An example of using a starting index of 100 is as follows:
/free
Res_Index = %lookup(Input_Part:Part_Array:100);
If Res_Index > *zero;
Part_Desc = Descr_Array(Res_Index);
Part_ID = Input_Part;
Else;
Message = ‘Part number entered, ‘ + Input_Part
+ ‘ is invalid.’;
Endif;
/End-free
D Search S 10
D Array S 10 Dim(32000) Based(Ptr)
D Thous_Elem C 1000
D Res_Index S 5 0
D Increment S 2 0 Inz(1)
/free
// Allocate storage for 1000 elements
Ptr = %alloc(Thous_Elem * %size(Array));
// Load 1000 elements here, then to do a look-up
Res_Index = %lookup(Search:Array:1:Thous_Elem);
// Later, when more storage is needed
Increment += 1; // New increment operator as of V5R2
Ptr = %realloc(Ptr:Thous_Elem * Increment * %size(Array));
// After loading the next 1000 elements, the next (and following)
// look-ups would be:
Res_Index = %lookup(Search:Array:1:Thous_Elem * Increment);
/end-free
| |
OTHER - Print Report on Time Spent in IPL Phases/Steps
Posted By: Leif Guldbrand Contact |
There is a tool/program that may be used (not available on releases prior to R310) that
generates a spool file which shows how long the system spent in each of the IPL phases.
To generate the spool file, type the following on the OS/400 command line:
CALL QWCCRTEC
Press the Enter key.
It is rather handy for customers to run this occasionally or at least after IPLs following
abnormal system ending (which forces the 2C40 cleanup) to provide data regarding how long
the IPL stays in each phase. There are major differences between doing an IPL on a fast
newer processor and doing an IPL on an older and much slower box. Major changes have been
made during the various Version 4 releases to speed up the IPL process.
| |
OTHER - List ILE Builtin Functions
Posted By: Leif Guldbrand Contact |
Here's a REXX program that lists ILE builtin functions.
Run it with STRREXPRC. It reveals interesting things.
Data = ''
Get = Copies('00'x, 512)
Obj = 'QWXHTSPC QSYS '
"CALL QUSRUSAT (&Get X'00000200' SPCA0100 &Obj X'00000000')"
Do X = 1 By 512 For C2D(Substr(Get,9,4))/512
"CALL QUSRTVUS (&Obj X'"D2X(X,8)"' X'00000200' &Get)"
Data = Insert(Get, Data, X-1, 512); End X
"OVRPRTF STDOUT QSYSPRT"
Do X = 173 By 20 While X < Int(5)+1
Line = Left(Substr(Data, Int(5)+Int(X)+1, Int(X+4)), 23)
If Int(X+12) = 0 Then Do
Line = ' ' Line
Do Y = Int(9)+Int(X+16)+1 By 4 For Int(X+20)/4
Line = Line Format(Int(Y), 5); End Y
X = X + 4; End
Else Line = Format(Int(X+12), 5) Format(Int(X+16), 5) ' ' Line
Say Line; End
Return
INT: Return C2D(Substr(Data, Arg(1), 4), 4)
| |
OTHER - iSeries (AS/400) Front Panel Keys Configuration
Posted By: Leif Guldbrand Contact |
The IPL types and modes are:
A M Performs a Manual IPL from the A side of the disk. This mode may be
used when applying or removing Licensed Internal Code (LIC) PTFs.
It can also be used to power off the system.
Use this type and mode only under the direction of your support
representative.
A N Performs a Normal IPL from the A side of the disk.
This mode should only be used when B N does not work and you are
told to do so by your support representative.
B M Performs a Manual IPL from the B side of the disk. This mode should
only be used when an attended IPL must be performed or you need to
power off the system. This type of IPL is used when you need to change
the system date and time permanently.
B N Performs a normal IPL from the B side of the disk. This is the type
and mode used most of the time. It is also the mode the system must
be in if you want to do an unattended IPL.
C M Allows service representatives to perform a special IPL. This mode
is for use only by service representatives. Never IPL in this type
and mode.
C N Allows service representatives to perform a special IPL. This mode
is for use only by service representatives. Never IPL in this type
and mode.
D M Performs a manual IPL from either CD-ROM or tape. This mode is used
to install Licensed Internal Code and the OS/400 operating system in
attended mode. This is the most often used IPL type and mode for
installation.
D N Performs a normal IPL from either CD-ROM or tape. This mode is used
to install Licensed Internal Code and the OS/400 operating system in
unattended mode.
Manual When the mode is set to Manual (M), the system allows you to do all
manual IPLs, such as an operator-attended IPL from disk, CD-ROM or tape.
Manual mode also allows you to do some manual control functions, such
as selecting an IPL type and mode or displaying the kind of IPL that
the system is set to run. However, in manual mode, you cannot do a
remote IPL, an IPL by date and time, or an IPL after a power failure.
Note: You should set the mode to Manual only when it is necessary.
This ensures that no one accidentally presses the Power pushbutton
and causes the system to stop.
Normal The Normal mode allows you to turn the power on and then automatically
start the system in any of the following ways:
IPL remotely
IPL by date and time
IPL after a power failure
Note: Your system should be in Normal mode most of the time.
| |
OTHER - V5R2 GUI web configuration
Posted By: JimmyOctane Contact |
Note: This article contains details on the HTTP Server Administration
enhancements made available on V5R2.
The IBM HTTP Server for iSeries product can be differentiated from other Web
server products in many ways. One of the key differentiators is the graphical
user interface (GUI) provided for setting up and managing your servers. The HTTP Server for iSeries
Administration interface is rich in function, examples, error-checking, and
ease-of-use. Administration is made significantly easier through the
use of forms, wizards, tasks and tools.
With the HTTP Server for iSeries, it's no longer necessary to memorize directive
names and their proper usage/syntax. Directives are
represented in the interface by meaningful and descriptive field names,
along with help text for every field. For Apache users, it's no longer
necessary to memorize the context(s) supported for a given directive. The
administration interface enforces supported context for the directives.
The HTTP Server Administration interface can be started by issuing the
following CL command on your iSeries command line:
STRTCPSVR SERVER(*HTTP) HTTPSVR(*ADMIN)
After starting the server, bring up a browser window and enter the following
URL: http://[your_iSeries]:2001
what IBM says
| |
OTHER - Date Formats - CVTDAT
Posted By: JimmyOctane Contact |
PGM
DCL VAR(&WORKDATE) TYPE(*CHAR) LEN(6)
DCL VAR(&FORMAT) TYPE(*CHAR) LEN(3)
DCL VAR(&XFORMAT) TYPE(*CHAR) LEN(4)
DCL VAR(&OUTDATE6) TYPE(*CHAR) LEN(6)
DCL VAR(&OUTDATE8) TYPE(*CHAR) LEN(8)
DCL VAR(&OUTDATED8) TYPE(*dec) LEN(8 0)
DCL VAR(&OUTDATE10) TYPE(*CHAR) LEN(10)
DCL VAR(&DATE8) TYPE(*DEC) LEN(8 0)
/*YMD, MDY, DMY, JUL */
RTVSYSVAL SYSVAL(QDATFMT) RTNVAR(&FORMAT)
CHGVAR VAR(&XFORMAT) VALUE('*' *TCAT &FORMAT)
RTVSYSVAL SYSVAL(QDATE) RTNVAR(&WORKDATE)
CVTDAT DATE(&WORKDATE) TOVAR(&OUTDATE6) +
FROMFMT(&XFORMAT) TOFMT(*MDY) TOSEP(*NONE)
CVTDAT DATE(&WORKDATE) TOVAR(&OUTDATE6) +
FROMFMT(&XFORMAT) TOFMT(*YMD) TOSEP(*NONE)
CVTDAT DATE(&WORKDATE) TOVAR(&OUTDATE6) +
FROMFMT(&XFORMAT) TOFMT(*DMY) TOSEP(*NONE)
CVTDAT DATE(&WORKDATE) TOVAR(&OUTDATE10) +
FROMFMT(&XFORMAT) TOFMT(*ISO) TOSEP(*NONE)
CVTDAT DATE(&WORKDATE) TOVAR(&OUTDATE10) +
FROMFMT(&XFORMAT) TOFMT(*ISO) TOSEP(*NONE)
EXIT: ENDPGM
------------------------------------------------------
*JOB
The date format is converted to the format specified by the job
attribute, DATFMT.
*SYSVAL
The date format is converted to the format specified by the system
value, QDATFMT.
*MDY
The date format is converted to the month, day, year format,
mmddyy.
*MDYY
The date format is converted to the month, day, year format,
mmddyyyy.
*DMY
The date format is converted to the day, month, year format,
ddmmyy.
*DMYY
The date format is converted to the day, month, year format,
ddmmyyyy.
*YMD
The date format is converted to the year, month, day format,
yymmdd.
*YYMD
The date format is converted to the year, month, day format,
yyyymmdd.
*CYMD
The date format is converted to the century, year, month, day
format, cyymmdd, where c is 0 for years 1928 through 1999 and is 1
for years 2000 through 2071. If the year in the current format is
only 2 digits, c will be set to 0 for years 40 through 99 and to 1
for years 00 through 39.
*JUL
The date format is converted to the Julian format, yyddd.
*ISO
The date format is converted to the International Organization for
Standardization (ISO) date format, yyyy-mm-dd.
*USA
The date format is converted to the United States date format,
mm/dd/yyyy.
*EUR
The date format is converted to the European date format,
dd.mm.yyyy.
*JIS
The date format is converted to the Japanese Industrial Standard
date format, yyyy-mm-dd.
*LONGJUL
The date has the long Julian format, yyyyddd.
| |
OTHER - Change command default
Posted By: JimmyOctane Contact |
CHGCMDDFT CMD(STRDBG) NEWDFT('UPDPROD(*YES)')
CHGCMDDFT CMD(CRTBNDRPG) NEWDFT('DBGVIEW(*SOURCE)')
| |
OTHER - Command Source
Posted By: JimmyOctane Contact |
/*===============================================================*/
/* CRTCMD CMD(LIBRARY/FFD) PGM(LIBRARY/FFDILE) */
/*===============================================================*/
CMD PROMPT('List Fields')
PARM KWD(FILE) TYPE(QUAL) MIN(1) PROMPT('File')
PARM KWD(RCDFMT) TYPE(*NAME) DFT(*FIRST) +
SPCVAL((*FIRST)) PROMPT('Record format')
QUAL: QUAL TYPE(*NAME) LEN(10)
QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
SPCVAL((*LIBL)) PROMPT('Library')
| |
OTHER - Calling PC.exe from Iseries STRPCO
Posted By: JimmyOctane Contact |
PGM
MONMSG CPF0000
STRPCO
STRPCCMD 'Q:\AS400CMD\BAD_DAY.EXE'
ENDPGM
| |
OTHER - Find Commands changed with CHGCMDDFT
Posted By: JimmyOctane Contact |
Run the following command:
DSPOBJD OBJ(QSYS/*ALL)
OBJTYPE(*CMD)
OUTPUT(*OUTFILE)
OUTFILE('filename')
- and then, using query or sql, select all records in 'filename' with an Apar Id (field ODAPAR)
equal 'CHGDFT'.
| |
OTHER - Hex codes for Color attributes
Posted By: JimmyOctane Contact |
D White C CONST( X'22' )
D White_UL C CONST( X'26' )
D White_RI C CONST( X'23' )
D White_RI_CS C CONST( X'33' )
D PR_White C CONST( X'A2' )
D PR_White_UL C CONST( X'A6' )
D PR_White_RI C CONST( X'A3' )
D PR_White_RI_CS C CONST( X'B3' )
D Green C CONST( X'20' )
D Green_RI C CONST( X'21' )
D Green_UL C CONST( X'24' )
D Green_UL_RI C CONST( X'25' )
D PR_Green C CONST( X'A0' )
D PR_Green_RI C CONST( X'A1' )
D PR_Green_UL C CONST( X'A4' )
D PR_Green_UL_RI C CONST( X'A5' )
D Red C CONST( X'28' )
D Red_RI C CONST( X'29' )
D Red_HI C CONST( X'2A' )
D Red_HI_RI C CONST( X'2B' )
D Red_UL C CONST( X'2C' )
D Red_UL_RI C CONST( X'2D' )
D Red_UL_BL C CONST( X'2E' )
D PR_Red C CONST( X'A8' )
D PR_Red_RI C CONST( X'A9' )
D PR_Red_HI C CONST( X'AA' )
D PR_Red_HI_RI C CONST( X'AB' )
D PR_Red_UL C CONST( X'AC' )
D PR_Red_UL_RI C CONST( X'AD' )
D PR_Red_UL_BL C CONST( X'AE' )
D Turq_CS C CONST( X'30' )
D Turq_CS_RI C CONST( X'31' )
D Turq_UL_CS C CONST( X'34' )
D Turq_UL_RI_CS C CONST( X'35' )
D PR_Turq_CS C CONST( X'B0' )
D PR_Turq_CS_RI C CONST( X'B1' )
D PR_Turq_CS_UL C CONST( X'B4' )
D PR_Turq_CSULRI C CONST( X'B5' )
D Yellow_CS C CONST( X'32' )
D Yellow_CS_UL C CONST( X'36' )
D PR_Yellow_CS C CONST( X'B2' )
D PR_Yellow_CSUL C CONST( X'B6' )
D Pink C CONST( X'38' )
D Pink_RI C CONST( X'39' )
D Pink_UL C CONST( X'3C' )
D Pink_UL_RI C CONST( X'3D' )
D PR_Pink C CONST( X'B8' )
D PR_Pink_RI C CONST( X'B9' )
D PR_Pink_UL C CONST( X'BC' )
D PR_Pink_UL_RI C CONST( X'BD' )
D Blue C CONST( X'3A' )
D Blue_RI C CONST( X'3B' )
D Blue_UL C CONST( X'3E' )
D PR_Blue C CONST( X'BA' )
D PR_Blue_RI C CONST( X'BB' )
D PR_Blue_UL C CONST( X'BE' )
| |
OTHER - Last IPL date
Posted By: JimmyOctane Contact |
PGM
DCL VAR(&DATA) TYPE(*CHAR) LEN(150)
DCL VAR(&BIN) TYPE(*CHAR) LEN(4) VALUE(X'00000096')
DCL VAR(&CEN) TYPE(*CHAR) LEN(1)
DCL VAR(&YY) TYPE(*CHAR) LEN(2)
DCL VAR(&MM) TYPE(*CHAR) LEN(2)
DCL VAR(&DD) TYPE(*CHAR) LEN(2)
DCL VAR(&HH) TYPE(*CHAR) LEN(2)
DCL VAR(&M) TYPE(*CHAR) LEN(2)
DCL VAR(&SS) TYPE(*CHAR) LEN(2)
DCL VAR(&FMT) TYPE(*CHAR) LEN(8) VALUE('JOBI0400')
DCL VAR(&JOB) TYPE(*CHAR) LEN(26) +
VALUE('SCPF QSYS 000000')
DCL VAR(&JOBI) TYPE(*CHAR) LEN(16)
CALL PGM(QUSRJOBI) PARM(&DATA &BIN &FMT &JOB &JOBI)
CHGVAR VAR(&CEN) VALUE(%SST(&DATA 63 1))
CHGVAR VAR(&YY) VALUE(%SST(&DATA 64 2))
CHGVAR VAR(&MM) VALUE(%SST(&DATA 66 2))
CHGVAR VAR(&DD) VALUE(%SST(&DATA 68 2))
CHGVAR VAR(&HH) VALUE(%SST(&DATA 70 2))
CHGVAR VAR(&M) VALUE(%SST(&DATA 72 2))
CHGVAR VAR(&SS) VALUE(%SST(&DATA 74 2))
SNDPGMMSG MSG('The system was last IPL''d on ' || &MM +
|| '/' || &DD || '/' || &YY || ' at ' || +
&HH || ':' || &M || ':' || &SS || '.')
END: ENDPGM
| |
OTHER - Creating an outq for PDF files
Posted By: Dieter Hokannsdotter Contact |
You can create with v510 one virtuell "pdf printer"
that you allow create pdf files. You only send the spoolfiles to one printer!
BUT YOU MUST HAVE THE LICPGRM 5722ip1
Here a example:
===> CRTPSFCFG PSFCFG(QGPL/PDFOUT) PDFGEN(*STMF) PDFDEVTYPE(*IP40300)
PDFPPRDWR1(*A4) PDFPPRDWR2(*A4) PDFDIR('/hdho')
CRTDEVPRT DEVD(HDHOPDF) DEVCLS(*LAN) TYPE(*IPDS MODEL(0)
LANATTACH(*IP) AFP(*YES) PORT(5003) ONLINE(*YES)
FONT(011 *NONE) FORMFEED(*CONT)
SEPDRAWER(*FILE) PRTERRMSG(*INFO) MSGQ(*CTLD) ACTTMR(170)
IMGCFG(*NONE) MAXPNDRQS(6) PRTCVT(*YES) PRTRQSTMR(*NOMAX)
FORMDF(*LIBL/F1C10110) CHRID(*SYSVAL) RMTLOCNAME'127.0.0.1')
USRDFNOBJ(QGPL/HDHOPDF *PSFCFG) TEXT('HDHO PDF Dateien in + das IFS schreiben')
| |
OTHER - Check FTP log for error
Posted By: Don Freeman Contact |
Not a problem, please be sure to post the caveat that I tagged on
as it is a stripped down version of what I use (removed non-pertinent code)
and renamed the fields and records so that they would be more generic and
descriptive. Besides the file and data descriptions were not posted and will
have to be inserted by whomever wishes to use it. So as it stands it has
not been re-tested. I posted it as a general idea of how to do this and don't
want to be held responsible if it does not work perfectly for someone else's
purposes. Other then that feel free to post, use, criticize, etc...
To solve for this I call the FTP session from a CL program and after the ftp session
is finished, the CL calls an RPG program that reads the FTP output file.
It tests for relevant errors and if it finds any it reports on them and executes
the appropriate action. The RPG only tests for the first error it finds as that is
enough to cancel the process that called it. You may want to keep testing for other
errors if your situation calls for it.
Something like this:
c *Entry PList
c Parm RtnCode
C Parm RtnText
*
* Reads reponse file line by line until an error is detected.
* At that time program exits passing back the Error code and the
* corresponding text message.
* Created 900 series of error message numbers to represent local errors.
/Free
RtnCode = ' ';
RtnText = ' ';
Read FTPOutRec;
DoU %EOF(FTPOutFile);
If not %EOF(FTPOutFile);
//Rsp1 is the one and only field in FTPOutRec
FTPErr# = %subst(Rsp1:1:3);
Pos4 = %subst(Rsp1:4:1);
ErrText = %subst(Rsp1:5:80);
Select;
//There may be other exeptions (non-errors that look like errors)
// that you may have to trap for, as this works for the situation
//it was developed for.
When %subst(Rsp1:1:29) = 'No response from remote host;';
RtnCode = '902'; //Local error message
RtnText = 'The connection between host/client was dropped.';
Leave;
When %subst(Rsp1:1:5) = 'Error'; //Local error message
RtnCode = '901';
RtnText = PrevRec; //Previous response has line that caused error
Leave;
When (FTPErr# > '399') and (FTPErr# < '600')
and ((Pos4 = ' ') or (Pos4 = '-'));
//Any number > 3 digits is not error msg
Select;
//transfer status for a small file: ok
When %subst(Rsp1:5:5) = 'bytes';
FTPErr# = ' ';
//no error
Other; //true error.
RtnCode = FTPErr#;
RtnText = ErrText;
Leave;
EndSl;
Other; //and Bob's yer uncle!
FTPErr# = ' '; //(no errors so far...)
EndSl;
EndIf;
PrevRec = Rsp1;
//Save record we just read before reading the next one
Read FTPOutRec;
EndDo;
*inlr = *on;
Return;
/End-Free
| |
OTHER - Use SQL to delete duplicate records
Posted By: JimmyOctane Contact |
Maybe you found a mistake in your application and impacted to the
duplicate key found in file that you don't need. Now what?
Here is a short command in SQL that will delete
duplicate keys. In this example, FILEA = File name,
LIBA=Library name, and INVNO=key field.
DELETE FROM LIBA/FILEA F1 WHERE RRN(F1) > (select MIN(RRN(F2))
FROM FILEA F2 WHERE F2.INVNO=F1.INVNO)
| |
OTHER - Logical files in different library than physical files
Posted By: JimmyOctane Contact |
Here's a simple way to list logical files where the logical
are in a different library than its associated physical file.
File QSYS/QADBFDEP contains a current cross reference of all file
dependencies between physical and logical files.
Other "interesting" files of a similar nature also exist in QSYS. Do WRKOBJ
QSYS/QADB* *FILE for a complete list.
Must have *ALLOBJ authority because file QADBFDEP is shipped with
*PUBLIC *EXCLUDE.
Note that the list that comes up will likely include some QADB* files that
exist in QSYS have LF in library QSYS2 and possibly other libraries as well.
OS/400 treats these files as system domain and does not allow user updates
to the files. Do not create your own logicals over any of these physicals at the risk
of causing IPL or system
recovery problems.
These files have been available on the since about V3R1.
This is an ad hoc SQL statement to run from an Interactive SQL Session
(Command is STRSQL)
Select * from qadbfdep
Where DBflib <> DBfldp
Order by DBfldp, DBffdp
| |
OTHER - QADBIFLD - IBM table with field information
Posted By: JimmyOctane Contact |
File QSYS/QADBIFLD holds field data on all files in the system.
This selection looks for a customer number in all tables on the
iseries. The customer number is a *CHAR field with a length of
11. The field in the customer file is:
NANUM Customer Number
I could also use a like for the field DBIREM which is long field
description and look for "%CUST%' or '%NUMBER%'
SELECT dbilib, dbifil, dbipos, dbifld, dbityp, dbifln, dbinsc,
dbitxt FROM qadbifld WHERE dbifld LIKE '%NUM%' and dbifln = 11
and dbilib = 'RC1380BFR1'
The views contained in a DB2 UDB for AS/400 catalog are described
in this section. The database manager maintains a set of tables
containing information about the data in the database. These tables
are collectively known as the catalog. The catalog tables contain
information about tables, user-defined functions, user-defined
types, parameters, procedures, packages, views, indexes, aliases,
constraints and languages supported by DB2 UDB for AS/400. The catalog tables
include the following files in the QSYS library:
QADBXREF
QADBPKG
QADBFDEP
QADBXRDBD
QADBFCST
QADBCCST
QADBIFLD
QADBKFLD
| |
OTHER - Print from CL, REXX ...
Posted By: Denny Contact |
PRINTER command/utility. This command allows you to print reports, job details, summary stats or error logs
from a CL or any language that supports executing a command.
I found mysyelf writting a lot of CL programs to process outfiles and needed some way to report what the job
did. For example I have a CL that processes all the objects in a library (DSPOBJD to outfile) and then changes
the ownership and and sets the correct object authorities. It uses the PRINTER command to generate a summary
of the objects processed and a detail listing of objects that it had problems with (object was in use and
ownership could not be changed or whatever).
There is no warranty expressed, implied or even hinted at. It is free so you will get exactly what you paid
for. Denny
*** CMD Source ***
/******************************************************************************/
/* TO COMPILE: */
/* CRTCMD CMD(XXX/PRINTER) PGM(PRINTER) + */
/* SRCFILE(XXX/QCMDSRC) HLPPNLGRP(PRINTERH) + */
/* HLPID(*CMD) PRDLIB(XXX) */
/******************************************************************************/
/* PRINT FROM CL PROGRAM */
CMD PROMPT('Print character string')
PARM KWD(DATA) TYPE(*CHAR) LEN(132) EXPR(*YES) +
PROMPT('Character data to print')
PARM KWD(SPACEB) TYPE(*CHAR) LEN(1) RANGE(0 3) +
SPCVAL((' ' 0)) PROMPT('Space before')
PARM KWD(SPACEA) TYPE(*CHAR) LEN(1) DFT(1) RANGE(0 +
3) SPCVAL((' ' 0)) PROMPT('Space after')
PARM KWD(SKIPB) TYPE(*CHAR) LEN(2) RANGE(01 99) +
SPCVAL((' ')) FULL(*YES) PROMPT('Skip to +
line before')
PARM KWD(SKIPA) TYPE(*CHAR) LEN(2) RANGE(01 99) +
SPCVAL((' ')) FULL(*YES) PROMPT('Skip to +
line after')
PARM KWD(CLOSE) TYPE(*LGL) RSTD(*YES) DFT(*NO) +
SPCVAL((*NO '0') (NO '0') (N '0') (*YES +
'1') (YES '1') (Y '1')) PROMPT('Close +
printer file')
PARM KWD(HEADER) TYPE(*CHAR) LEN(1) RSTD(*YES) +
DFT(*NO) SPCVAL((*NO '0') (NO '0') (N '0') +
('1') ('2') ('3') ('4')) PROMPT('Data is +
heading line 1-4')
PARM KWD(HEADERID1) TYPE(*CHAR) LEN(10) +
PROMPT('Header id 1st on left')
PARM KWD(HEADERID2) TYPE(*CHAR) LEN(10) +
PROMPT('Header id 2nd on left')
PARM KWD(HEADERID3) TYPE(*CHAR) LEN(10) +
PROMPT('Header id 3rd on left')
PARM KWD(CENTER) TYPE(*LGL) RSTD(*YES) DFT(*NO) +
SPCVAL((*NO '0') (NO '0') (N '0') (*YES +
'1') (YES '1') (Y '1')) PROMPT('Center data +
on page')
PARM KWD(STAMP) TYPE(*LGL) RSTD(*YES) DFT(*NO) +
SPCVAL((*NO '0') (NO '0') (N '0') (*YES +
'1') (YES '1') (Y '1')) PROMPT('Print +
date/time left of page #')
PARM KWD(PAGE) TYPE(*LGL) RSTD(*YES) DFT(*NO) +
SPCVAL((*NO '0') (NO '0') (N '0') (*YES +
'1') (YES '1') (Y '1')) PROMPT('Print PAGE +
# on right margin')
PARM KWD(PRTF) TYPE(*CHAR) LEN(1) RANGE('1' +
'8') MAX(8) PROMPT('Printer file number 1-8')
*** CL Source ***
/* +-------------------------------------------------------------------+ */
/* | This program is the property of: | */
/* | ProMIS, R. D. Davis Copyright 1999 | */
/* | 1716 Cove Point | */
/* | Gainesville, GA 30501-1468 | */
/* | 770-297-9929 | */
/* +-------------------------------------------------------------------+ */
/* | Date written: 05/12/99 Author: R. D. Davis | */
/* | Date modified: 12/10/02 By: RDD | */
/* | Reformat header line and add id fields. | */
/* | | */
/* +-------------------------------------------------------------------+ */
PGM PARM(&PLINE &SPACEB &SPACEA &SKIPB &SKIPA +
&CLOSE &HEADER &HEADERID1 &HEADERID2 +
&HEADERID3 &CENTER &STAMP &PAGE# &PRINTLST)
DCL &PLINE *CHAR 132
DCL &SPACEB *CHAR 1
DCL &SPACEA *CHAR 1
DCL &SKIPB *CHAR 2
DCL &SKIPA *CHAR 2
DCL &CLOSE *CHAR 1
DCL &HEADER *CHAR 1
DCL &HEADERID1 *CHAR 10
DCL &HEADERID2 *CHAR 10
DCL &HEADERID3 *CHAR 10
DCL &CENTER *CHAR 1
DCL &STAMP *CHAR 1
DCL &PAGE# *CHAR 1
DCL &PRINTLST *CHAR 10
DCL &PRINTLST# *DEC 3
DCL &X *DEC 3
DCL &PRINT# *CHAR 1
DCL &PGM *CHAR 10
CHGVAR &X 3
CHGVAR &PRINTLST# %BIN(&PRINTLST 1 2)
LOOP:
IF (&PRINTLST# *EQ 0) CHGVAR &PRINT# '1'
ELSE CHGVAR &PRINT# %SST(&PRINTLST &X 1)
IF (&PRINT# *EQ '1') DO
CHGVAR &PGM 'PRINT'
ENDDO
ELSE DO
CHGVAR &PGM ('PRINT' || &PRINT#)
CHKOBJ OBJ(QTEMP/&PGM) OBJTYPE(*PGM)
MONMSG CPF9801 EXEC(DO)
RCVMSG MSGTYPE(*EXCP) RMV(*YES) /* /WIP */
CRTDUPOBJ OBJ(PRINT) FROMLIB(*LIBL) OBJTYPE(*PGM) +
TOLIB(QTEMP) NEWOBJ(&PGM)
ENDDO
ENDDO
CALL PGM(&PGM) PARM(&PLINE &SPACEA &SPACEB &SKIPA +
&SKIPB &CLOSE &HEADER &HEADERID1 +
&HEADERID2 &HEADERID3 &CENTER &STAMP &PAGE#)
CHGVAR &PRINTLST# (&PRINTLST# - 1)
CHGVAR &X (&X + 1)
IF (&PRINTLST# *GT 0) GOTO LOOP
ENDPGM
*** RPGLE Source ***
H/TITLE PRINT FROM CL PROGRAM
H/SPACE 2
‚* +--------------------------------------------------------------+
‚* | This program is the property of: |
‚* | ProMIS, R. D. Davis Copyright 1999 |
‚* | 1716 Cove Point |
‚* | Gainesville, GA 30501-1468 |
‚* | 770-297-9929 |
‚* +--------------------------------------------------------------+
‚* | Date written: 03/10/93 Author: R. D. Davis |
‚* | Date modified: 07/23/02 by RDD |
‚* | Replaced call to external CENTER program with expression. |
‚* | Date modified: 12/10/02 by RDD |
‚* | Reformated header constants. |
‚* | Added ID fields to Left. |
‚* | |
‚* +--------------------------------------------------------------+
H/SPACE 2
‚*------- 07/17/00 ---------------------------------------------------*/
‚* - RPG Indicator Usage */
‚* = DDS Indicator Usage */
‚*--------------------------------------------------------------------*/
‚* */
‚* LR - *INLR is set to ON */
‚* OF - Over flow indicator for PROMIS */
‚* OF - *INOF is set to OFF */
‚* 01 - STAMP is equal to ON on COMP operation */
‚* 01 - STP1 is equal to ON on COMP operation */
‚* 01 - STP2 is equal to ON on COMP operation */
‚* 01 - STP3 is equal to ON on COMP operation */
‚* 01 - STP4 is equal to ON on COMP operation */
‚* 02 - PAGE# is equal to ON on COMP operation */
‚* 02 - PG1 is equal to ON on COMP operation */
‚* 02 - PG2 is equal to ON on COMP operation */
‚* 02 - PG3 is equal to ON on COMP operation */
‚* 02 - PG4 is equal to ON on COMP operation */
‚*--------------------------------------------------------------------*/
F/SPACE 2
Fpromisprt o f 132 printer prtctl(prtctl:*compat)
F oflind(*inof)
D prtctl ds
D spaceb 1 1
D spacea 2 2
D skipb 3 4
D skipa 5 6
D curlin 7 9 0
D dtime s 12 0
D hdr s 132
D hdrc1 s 9
D hdrc2 s 9
D hdrc3 s 9
D hdrc4 s 9
D hdr1 s 132
D hdr2 s 132
D hdr3 s 132
D hdr4 s 132
D id1 s 10
D id2 s 10
D id3 s 10
D id4 s 10
D hdrid11 s 132
D hdrid12 s 132
D hdrid13 s 132
D hdrid21 s 132
D hdrid22 s 132
D hdrid23 s 132
D hdrid31 s 132
D hdrid32 s 132
D hdrid33 s 132
D hdrid41 s 132
D hdrid42 s 132
D hdrid43 s 132
D off s 1
D on s 1
D pageno s 4 0
D pg1 s 1
D pg2 s 1
D pg3 s 1
D pg4 s 1
D savctl s 9
D stp1 s 1
D stp2 s 1
D stp3 s 1
D stp4 s 1
D pline_work s like(pline)
C *entry plist
C parm pline 132
C spacea parm spa 1
C spaceb parm spb 1
C skipa parm ska 2
C skipb parm skb 2
C parm close 1
C parm header 1
C parm headerid1 10
C parm headerid2 10
C parm headerid3 10
C parm center 1
C parm stamp 1
C parm page# 1
‚*
1B C if on = off
C eval on = *on
C eval off = *off
C time dtime
C eval pageno = 1
2B C if skipa = ' '
3B C if skipb = ' '
C eval skipb = '01'
3E C endif
2E C endif
1E C endif
‚*
1B C if center = on
C eval pline_work = pline
C eval pline = *blank
C EVAL %SUBST(pline:
C %INTH((%SIZE(pline_work) -
C %LEN(%TRIM(pline_work))) / 2 + 1):
C %LEN(%TRIM(pline_work))) =
C %TRIM(pline_work)
1E C endif
‚*
‚* HEADER CAN BE '0', '1', '2', '3' OR '4'
1B C if header <> off
2B C if header = '1'
C eval hdr1 = pline
C eval hdrid11 = headerid1
C eval hdrid12 = headerid2
C eval hdrid13 = headerid3
C eval hdrc1 = prtctl
C eval stp1 = stamp
C eval pg1 = page#
2X C else
3B C if header = '2'
C eval hdr2 = pline
C eval hdrid21 = headerid1
C eval hdrid22 = headerid2
C eval hdrid23 = headerid3
C eval hdrc2 = prtctl
C eval stp2 = stamp
C eval pg2 = page#
3X C else
4B C if header = '3'
C eval hdr3 = pline
C eval hdrid31 = headerid1
C eval hdrid32 = headerid2
C eval hdrid33 = headerid3
C eval hdrc3 = prtctl
C eval stp3 = stamp
C eval pg3 = page#
4X C else
5B C if header = '4'
C eval hdr4 = pline
C eval hdrid41 = headerid1
C eval hdrid42 = headerid2
C eval hdrid43 = headerid3
C eval hdrc4 = prtctl
C eval stp4 = stamp
C eval pg4 = page#
5E C endif
4E C endif
3E C endif
2E C endif
1E C endif
‚*
1B C if *inof = on
C eval savctl = prtctl
C add 1 pageno
‚*
C eval prtctl = hdrc1
C eval hdr = hdr1
C eval id1 = hdrid11
C eval id2 = hdrid12
C eval id3 = hdrid13
C stp1 comp on 01
C pg1 comp on 02
C exsr prtof
‚*
C eval prtctl = hdrc2
C eval hdr = hdr2
C eval id1 = hdrid21
C eval id2 = hdrid22
C eval id3 = hdrid23
C stp2 comp on 01
C pg2 comp on 02
C exsr prtof
‚*
C eval prtctl = hdrc3
C eval hdr = hdr3
C eval id1 = hdrid31
C eval id2 = hdrid32
C eval id3 = hdrid33
C stp3 comp on 01
C pg3 comp on 02
C exsr prtof
‚*
C eval prtctl = hdrc4
C eval hdr = hdr4
C eval id1 = hdrid41
C eval id2 = hdrid42
C eval id3 = hdrid43
C stp4 comp on 01
C pg4 comp on 02
C exsr prtof
‚*
2B C if *inof = on DEFAULT OF
C eval skipb = '01'
C except head
C eval *inof = off
2E C endif
‚*
C eval prtctl = savctl
1E C endif
‚*
C stamp comp on 01
C page# comp on 02
C eval id1 = headerid1
C eval id2 = headerid2
C eval id3 = headerid3
C id1 comp *blank 0303
C id2 comp *blank 0404
C id3 comp *blank 0505
‚*
1B C if close = on
C time dtime
C eval *inlr = on
1E C endif
‚*
C except line
‚*
C return
C/SPACE 2
‚*----------*---------*----*---------*-----*--**hiloeq
‚* PRINT OVERFLOW
‚*----------*---------*----*---------*-----*--**hiloeq
C prtof begsr
1B C if prtctl <> *blank or
C hdr <> *blank or
C id1 <> *blank or
C id2 <> *blank or
C id3 <> *blank or
C *in01 = on or
C *in02 = on
C id1 comp *blank 0303
C id2 comp *blank 0404
C id3 comp *blank 0505
C except head
C eval *inof = off
1E C endif
C endsr
Opromisprt e head
O hdr 132
O 03 id1 10
O 04 id2 21
O 05 id3 32
O 01 dtime 119 ' : : && / / '
O 02 125 'PAGE'
O 02 pageno z 130
Opromisprt e line
O pline 132
O 03 id1 10
O 04 id2 21
O 05 id3 32
O 01 dtime 119 ' : : && / / '
O 02 125 'PAGE'
O 02 pageno z 130
*** QPNLSRC PDM Option 14 will compile ***
.******************************************************************
.*
.* Panel Group: PRINTERH
.*
.* Function:
.* Used as the help text for command PRINTER
.*
.******************************************************************
:PNLGRP.
.******************************************************************
.*
.* Primary help text for the command.
.*
.******************************************************************
:HELP NAME='PRINTER'.
Print character string - Help
:P.
This command can print up to eight reports from a CL, REXX or even from
the command line.
:P.
It evokes a separate RPG IV program for each printer file. Each program remains
open until the command is executed with CLOSE(*YES) for that printer file.
:P.
This function us useful for CL program that process outfiles, need to print
execution detail, summary or errors.
:EHELP.
.*******************************************************************
.*
.* Help text for the command parameters.
.*
.******************************************************************
:HELP NAME='PRINTER/DATA'.
Character data to print (DATA) - Help
:XH3.Character data to print (DATA)
:P.
This is the print line for the printer. It can be a character variable
of up to 132 bytes. It can also be a character expression.
:LINES.
Examples:
DCL &DATALINE *CHAR 132
CHGVAR &DATALINE ('Report printed by ' *CAT &USRPRF)
PRINTER &DATALINE
PRINTER DATA('DATE' *BCAT &DATE *BCAT 'TIME' *BCAT &TIME)
:ELINES.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/SPACEB'.
Space before (SPACEB) - Help
:XH3.Space before (SPACEB)
:P.
Number of lines to space before printing data. Valid values are
blank, 1, 2 or 3.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/SPACEA'.
Space after (SPACEA) - Help
:XH3.Space after (SPACEA)
:P.
Number of lines to space after printing data. Valid values are
blank, 1, 2 or 3. Default is 1.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/SKIPB'.
Skip to line before (SKIPB) - Help
:XH3.Skip to line before (SKIPB)
:P.
Line number to skip to before printing data. Valid values are
blank or 01 through 99. Leading zero is required.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/SKIPA'.
Skip to line after (SKIPA) - Help
:XH3.Skip to line after (SKIPA)
:P.
Line number to skip to after printing data. Valid values are
blank or 01 through 99. Leading zero is required.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/CLOSE'.
Close printer file (CLOSE) - Help
:XH3.Close printer file (CLOSE)
:P.
Close the printer file after printing the line.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/HEADER'.
Data is heading line 1-4 (HEADER) - Help
:XH3.Data is heading line 1-4 (HEADER)
:P.
This identifies the data as a heading line of the report.
It will be reprinted when page overflow occurs. Valid values are *NO, 1,
2, 3 or 4.
:LINES.
Example:
PRINTER DATA('The name of the company') SKIPB(03) HEADER(1)
PRINTER DATA('The title of this report') SPACEA(2) HEADER(2)
PRINTER DATA('Column Column Column') HEADER(3)
PRINTER DATA('Hdr 1 Hdr 2 Hdr 3 ') SPACEA(2) HEADER(4)
:ELINES.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/HEADERID1'.
Header id 1st on left (HEADERID1) - Help
:XH3.Header id 1st on left (HEADERID1)
:P.
Header id 1 is a ten character field that will be printed in
position 1 of the ouput line. Be careful that the data value
does not cause over printing.
:P.
See help in header id 3 for examples.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/HEADERID2'.
Header id 2nd on left (HEADERID2) - Help
:XH3.Header id 2nd on left (HEADERID2)
:P.
Header id 2 is a ten character field that will be printed in
position 12 of the ouput line. Be careful that the data value
does not cause over printing.
:P.
See help in header id 3 for examples.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/HEADERID3'.
Header id 3rd on left (HEADERID3) - Help
:XH3.Header id 3rd on left (HEADERID3)
:P.
Header id 3 is a ten character field that will be printed in
position 23 of the ouput line. Be careful that the data value
does not cause over printing.
:LINES.
Example:
PRINTER DATA('Report Title') SKIPB(03) HEADER(1)
HEADERID1(&USER) HEADERID2(&PROGRAMID) HEADERID3(&WORKSTN)
CENTER(*YES) STAMP(*YES) PAGE(*YES)
:ELINES.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/CENTER'.
Center data on page (CENTER) - Help
:XH3.Center data on page (CENTER)
:P.
A value of *YES causes the data line to be centerd on the 132 column line.
Note that if there are too many characters in the data paramater that
overprinting can occur if values are specified in the header id fields,
the date/time stamp or the page number.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/STAMP'.
Print date/time left of page # (STAMP) - Help
:XH3.Print date/time left of page # (STAMP)
:P.
A value of *YES causes the time an date to be printed in columns
102 through 119.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/PAGE'.
Print PAGE # right on margin (PAGE) - Help
:XH3.Print PAGE # on right margin (PAGE)
:P.
A value of *YES causes PAGE #### to be to be printed in columns
122 through 130.
:EHELP.
.******************************************************************
:HELP NAME='PRINTER/PRTF'.
Printer file number 1...8 (PRTF#) - Help
:XH3.Printer file number 1...8 (PRTF#)
:P.
This indicates the printer file to be used. If the entire parameter is
left blank, printer file
1 is assumed. Multiple values can be specifie which allows printing the
same data line on multiple reports.
:P.
Valid values are blank and 1 through 8.
:EHELP.
.******************************************************************
:EPNLGRP.
| |
OTHER - New version of PRTPRTF1
Posted By: Denny Contact |
*** PRTPRTF1 QRPGLESRC ***
H/TITLE Print sample of External Printer File
** +--------------------------------------------------------------+
** | This program is the property of: |
** | ProMIS, R. D. Davis Copyright 2004 |
** | 1716 Cove Point |
** | Gainesville, GA 30501-1468 |
** | 770-297-9929 denny@techie.com |
** +--------------------------------------------------------------+
** | Date written: 04/05/04 Author: R. D. Davis |
** | Date modified: XX/XX/XX |
** | |
** +--------------------------------------------------------------+
H bnddir('QC2LE')
Fqddssrc ip f 92 disk
Fqrpglesrc o f 112 disk
D f_spec ds 112
D f_seq 1 6 0 inz
D f_id 18 18 inz('F')
D f_file 19 28
D f_o 29 29 inz('o')
D f_f 34 34 inz('e')
D f_dev 48 57 inz('printer')
D d_spec ds 112
D d_seq 1 6 0 inz
D d_id 18 18 inz('D')
D d_name 19 33
D d_External 34 34
D d_Type_ds 35 35
D d_DefType 36 37
D d_From 38 44
D d_To 45 61
D d_datatype 52 52
D d_decimals 53 54
D d_keywords 56 92
D c_spec ds 112
D c_seq 1 6 0 inz
D c_id 18 18 inz('C')
D factor_1 24 37
D oper 38 47
D Factor_2 48 61
D Factor_2x 48 92
D Result 62 75
D p_record_name s like(record_name)
D ffd e ds extname(qadspffd)
D do_once s n
Iqddssrc ns 01 19 c*
I ns 02 29 cR
I 31 40 record_name
I ns 03 31nc
I 31 40 field_name
I 41 41 Ref_field
I 49 49 Dec_Pos
I ns 04
C if not do_once
C exsr once
C endif
C if *in02
C and p_record_name <> record_name
C if p_record_name <> *blank
C eval oper = 'write'
C eval factor_2 = p_record_name
C eval f_seq = f_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endif
C eval p_record_name = record_name
C endif
C if *in03
C if ref_field = 'R'
C/Exec sql
C+ select *
C+ into :ffd
C+ from QTEMP/DSPFFD
C+ where Whflde = :field_name
C/end-exec
C select
C when whfldt = 'L'
C or whfldt = 'T'
C or whfldt = 'Z'
C eval oper = 'time'
C eval result = field_name
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C when whfldt = 'B'
C or whfldt = 'B'
C or whfldt = 'S'
C or whfldt = 'P'
C or whfldt = 'F'
C exsr number
C when whfldt = 'A'
C exsr character
C endsl
C else Not Reference Field
C if dec_pos = *blank Character
C exsr character
C else Not Reference Field
C exsr number
C endif not Character
C endif
C endif
Clr exsr lr
C once begsr
C eval do_once = *on
C* Once subroutine is used because reset op code is needed
C *entry plist
C parm file 10
C move file f_file
C eval f_seq = f_seq + 100
C write qrpglesrc f_spec
C eval d_seq = f_seq
C eval c_seq = d_seq
C eval oper = 'movea'
C eval Factor_2 = '*off'
C eval Result = '*in'
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C eval oper = 'exsr'
C eval Factor_2 = 'print'
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C eval oper = 'movea'
C eval Factor_2 = '*on'
C eval Result = '*in'
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C eval oper = 'exsr'
C eval Factor_2 = 'print'
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C eval oper = 'eval'
C eval Factor_2x = '*inlr = *on'
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C eval factor_1 = 'print'
C eval oper = 'begsr'
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endsr
C character begsr
C eval oper = 'move'
C eval factor_2 = '*all''X'''
C eval result = field_name
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endsr
C number begsr
C eval oper = 'z-sub'
C eval factor_2 = '*all''9'''
C eval result = field_name
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endsr
C lr begsr
C eval oper = 'write'
C eval factor_2 = p_record_name
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C eval oper = 'endsr'
C eval c_seq = c_seq + 100
C write qrpglesrc c_spec
C reset c_spec
C endsr
*** END OF SOURCE ***
*** PRTPRTF QCMDSRC ***
/* Print Sample of Ext Print File */
/* +-------------------------------------------------------------------+ */
/* | This program is the property of: | */
/* | ProMIS, R. D. Davis Copyright 2004 | */
/* | 1716 Cove Point | */
/* | Gainesville, GA 30501-1468 | */
/* | 770-297-9929 promis@att.net denny@techie.com
/* +-------------------------------------------------------------------+ */
/* | Date written: 04/05/04 Author: R. D. Davis | */
/* | Date modified: XX/XX/XX By: RDD | */
/* | | */
/* +-------------------------------------------------------------------+ */
CMD PROMPT('Print Sample of Ext Print File')
PARM KWD(MBR) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('Printer File Source Member')
PARM KWD(LIBRARY) TYPE(*NAME) LEN(10) +
SPCVAL((*LIBL)) PROMPT('Printer File & +
QDDSSRC library')
*** PRTPRTF QCLSRC ***
/* Print sample of External Printer File */
/* */
/* +-------------------------------------------------------------------+ */
/* | This program is the property of: | */
/* | ProMIS, R. D. Davis Copyright 2004 | */
/* | 1716 Cove Point | */
/* | Gainesville, GA 30501-1468 | */
/* | 770-297-9929 promis@att.net denny@techie.com
/* +-------------------------------------------------------------------+ */
/* | Date written: 04/05/04 Author: R. D. Davis | */
/* | Date modified: XX/XX/XX By: RDD | */
/* | | */
/* +-------------------------------------------------------------------+ */
PGM PARM(&DDSMBR &DDSLIB )
DCL &DDSMBR *CHAR 10
DCL &DDSLIB *CHAR 10
DCL &ABEND *LGL
DCL &MSGDTA *CHAR 132
DCL &MSGID *CHAR 7
DCL &MSGF *CHAR 10
DCL &MSGFLIB *CHAR 10
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ABEND))
CHKOBJ OBJ(QTEMP/QRPGLESRC) OBJTYPE(*FILE) MBR(PRTSAMPLE)
MONMSG CPF9801 EXEC(DO) /* FILE NOT FOUND */
RCVMSG MSGTYPE(*EXCP) RMV(*YES)
CRTSRCPF FILE(QTEMP/QRPGLESRC) RCDLEN(112) MBR(*NONE) +
MAXMBRS(*NOMAX) SIZE(*NOMAX) AUT(*ALL)
ADDPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE) +
SRCTYPE(RPGLE)
ENDDO
MONMSG CPF9815 EXEC(DO) /* MEMBER NOT FOUND */
RCVMSG MSGTYPE(*EXCP) RMV(*YES)
ADDPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE) +
SRCTYPE(RPGLE)
ENDDO
CLRPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE)
OVRDBF FILE(QRPGLESRC) TOFILE(QTEMP/QRPGLESRC) +
MBR(PRTSAMPLE)
OVRDBF FILE(QDDSSRC) TOFILE(&DDSLIB/QDDSSRC) +
MBR(&DDSMBR)
DSPFFD FILE(&DDSLIB/&DDSMBR) OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/DSPFFD)
OVRDBF FILE(QADSPFFD) TOFILE(QTEMP/DSPFFD)
CALL PRTPRTF1 &DDSMBR
CRTBNDRPG PGM(QTEMP/SAMPLE) SRCFILE(QTEMP/QRPGLESRC) +
DFTACTGRP(*NO) ACTGRP(*CALLER) OUTPUT(*NONE)
OVRPRTF FILE(&DDSMBR) PRTTXT(*BLANK)
CALL PGM(QTEMP/SAMPLE)
EXIT: RETURN /* NORMAL END OF JOB */
ABEND: IF COND(&ABEND) THEN(SNDPGMMSG MSGID(CPF9898) +
MSGF(QCPFMSG) MSGDTA('Function check.') +
MSGTYPE(*ESCAPE))
CHGVAR VAR(&ABEND) VALUE('1')
DMPCLPGM
/* Forward diagnostic messages from this program message queue to previous */
FORWARD: RCVMSG MSGTYPE(*DIAG) RMV(*NO) MSGDTA(&MSGDTA) +
MSGID(&MSGID) MSGF(&MSGF) MSGFLIB(&MSGFLIB)
IF (&MSGID ¬= ' ') DO
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*DIAG)
GOTO FORWARD
ENDDO
RCVMSG MSGTYPE(*EXCP) RMV(*NO) MSGDTA(&MSGDTA) +
MSGID(&MSGID) MSGF(&MSGF) MSGFLIB(&MSGFLIB)
IF (&MSGID ¬= ' ') DO
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
ENDDO
ENDPGM
| |
OTHER - Matching against a list of values
Posted By: Mel Rothman Contact |
I have used the following technique:
if %scan(%trim(ST_RP):'NB PE NS GA KS ') > 0;
true actions;
else;
not true actions;
endif;
Note: there is blank after each of the values in %scan's factor 2.
This prevents the problem of AK resulting in a hit from the A in GA
and the K in KS. If ST_RP is mixed case, I use uppify() from CGIDEV2:
if %scan(%uppify(%trim(ST_RP)):'NB PE NS GA KS ') > 0;
Mel Rothman
Mel Rothman, Inc.
| |
OTHER - occurance of a character in a string
Posted By: Bob Cozzi Contact |
D FieldName S 75A Inz('That, that is, is that that +
D is not. Is that not it? It is!')
D pos S 10U 0 Dim(%size(FieldName))
D
C 'T' scan FieldName pos
All occurrences of the letter “T” are located and each location is stored in
one of the array elements of the POS array.
If POS(1) = 0, then the value was not found.
-Bob Cozzi
| |
OTHER - RPGIV: record lock V5R2
Posted By: Larry Moore Contact |
Use chain(e) and check for status 1218.
You might consider shortening the timeout period on the file.
I believe the default is 60 seconds which is too long for a
user to wait for a timeout message.
D sds
D Record_Lock 91 170
chain(e) %kds(DR0100F_Key) dr0100f;
if %error and %status = 1218; // The record is locked
Error_Msg = Record_Lock;
exfmt Lock_Dsp;
exsr End_Program;
| |
OTHER - Color in SEU with Client Access version 2
Posted By: Ken McKinney Contact |
Client Access Colors
Descriptions and Hex codes from JimmyOctane's chart
White = 22
White_UL = 26
White_RI = 23
Green = 20
Green_RI = 21
Green_UL = 24
Green_UL_RI = 25
Red = 28
Red_RI = 29
Red_HI = 2a
Red_HI_RI = 2b
Red_UL = 2c
Red_UL_RI = 2d
Red_UL_BL = 2e
Turq_CS = 30
Turq_CS_RI = 31
Turq_UL_CS = 34
Turq_UL_RI_CS = 35
Yellow_CS = 32
Yellow_CS_RI = 33
Yellow_CS_UL = 36
Pink = 38
Pink_RI = 39
Pink_UL = 3c
Pink_UL_RI = 3d
Blue = 3a
Blue_RI = 3b
Blue_UL = 3e
From your AS/400 Client Access session:
Edit/Preferences/Keyboard
Click on Customize button.
From Customize Keyboard screen:
File/Save As
Remember the name and location the file is at.
Exit program and click OK
Close the CA session.
Using notepad, open the keyboard map file (extension .kmp)
Using the HEX codes above, assign the colors to the control or
shift-control keys using the 'apl' code. Here is an example.
--- BEGIN EXAMPLE ---
[Profile]
id=KMP
Description=
[KEYBOARD]
C-KEY2=apl 22
C-KEY3=apl 32
C-KEY4=apl 3a
C-KEY5=apl 28
C-KEY6=apl 38
C-KEY7=apl 30
C-KEY8=apl 26
C-KEY9=apl 36
C-KEY10=apl 3e
C-KEY11=apl 2e
CS-KEY2=apl 24
CS-KEY3=apl 34
CS-KEY4=apl 3c
CS-KEY5=apl 21
CS-KEY6=apl 23
CS-KEY7=apl 33
CS-KEY8=apl 3b
CS-KEY9=apl 29
CS-KEY10=apl 2a
CS-KEY11=apl 25
--- END EXAMPLE ---
The above configuration assigns colors to CTL 1 to 0 and SHIFT-
CTL 1 to 0
CTL 1 = C-KEY2
SHIFT-CTL 1 = CS-KEY2
Save the file and open your CA session again. Check the keyboard
configuration. You may need to load it and save you CA session
so that it will always load when the session starts.
Once assigned, you can use the control/shift-control keys to put
colors in your source while within SEU. On instruction lines
this can be between positions 1 and 4 or in the comment section
of the line. For comment lines, they can be used in any position
and in any combination.
| |
OTHER - Using PMTCTL parameters based on others in *CMD
Posted By: john Key Contact |
CMD PROMPT('Convert Spooled File to STMF')
PARM KWD(FROMFILE) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('From spooled file name')
PARM KWD(TOSTMF) TYPE(*NAME) LEN(64) MIN(1) +
PROMPT('To stream file name')
PARM KWD(TODIR) TYPE(*PNAME) LEN(256) MIN(1) +
PROMPT('To directory')
PARM KWD(JOB) TYPE(JOB) DFT(*) SNGVAL((*)) +
PROMPT('Job name')
JOB: QUAL TYPE(*NAME) LEN(10) MIN(1)
QUAL TYPE(*NAME) LEN(10) MIN(1) PROMPT('User')
QUAL TYPE(*CHAR) LEN(6) RANGE(000000 999999) +
MIN(1) PROMPT('Number')
PARM KWD(SPLNBR) TYPE(*DEC) LEN(4) DFT(*ONLY) +
RANGE(1 9999) SPCVAL((*LAST -2) (*ONLY +
-3)) PROMPT('Spooled file number')
PARM KWD(TOFMT) TYPE(*CHAR) LEN(5) RSTD(*YES) +
DFT(*TEXT) VALUES(*TEXT *HTML *PDF) +
PROMPT('Stream file format')
PARM KWD(STMFOPT) TYPE(*CHAR) LEN(8) RSTD(*YES) +
DFT(*NONE) VALUES(*NONE *ADD *REPLACE) +
PROMPT('Stream file option')
PARM KWD(STMFCODPAG) TYPE(*DEC) LEN(5 0) +
DFT(*PCASCII) RANGE(1 32767) +
SPCVAL((*PCASCII -1) (*STMF -2)) +
PMTCTL(*PMTRQS) PROMPT('Stream file code +
page')
PARM KWD(TITLE) TYPE(*CHAR) LEN(50) RSTD(*NO) +
DFT(*NONE) SPCVAL((*NONE) (*STMFILE)) +
PMTCTL(HTML) PROMPT('Title for HTML or PDF')
PARM KWD(BOOKMARK) TYPE(*CHAR) LEN(7) RSTD(*YES) +
DFT(*PAGNBR) VALUES(*PAGNBR *POS *KEY) +
PMTCTL(PDF) PROMPT('Type of PDF bookmarks')
PARM KWD(BMARKPOS) TYPE(LIST1) PMTCTL(POS) +
PROMPT('PDF bookmark string position')
LIST1: ELEM TYPE(*DEC) LEN(3 0) DFT(1) RANGE(1 300) +
PROMPT('Line number')
ELEM TYPE(*DEC) LEN(3 0) DFT(1) RANGE(1 378) +
PROMPT('Character position')
ELEM TYPE(*DEC) LEN(3 0) DFT(1) RANGE(1 378) +
PROMPT('Length')
PARM KWD(BMARKKEY) TYPE(LIST2) PMTCTL(KEY) +
PROMPT('PDF bookmark string key')
LIST2: ELEM TYPE(*CHAR) LEN(378) DFT(' ') VARY(*YES +
*INT2) PROMPT('Key string')
ELEM TYPE(*DEC) LEN(3 0) DFT(1) RANGE(1 999) +
PROMPT('Occurrence')
ELEM TYPE(*DEC) LEN(3 0) DFT(0) RANGE(-378 378) +
PROMPT('Offset')
ELEM TYPE(*DEC) LEN(3 0) DFT(1) RANGE(1 378) +
PROMPT('Length')
HTML: PMTCTL CTL(TOFMT) COND((*EQ *HTML) (*EQ *PDF)) +
NBRTRUE(*EQ 1) LGLREL(*OR)
PDF: PMTCTL CTL(TOFMT) COND((*EQ *PDF)) NBRTRUE(*EQ 1)
POS: PMTCTL CTL(BOOKMARK) COND((*EQ *POS)) NBRTRUE(*EQ 1)
KEY: PMTCTL CTL(BOOKMARK) COND((*EQ *KEY)) NBRTRUE(*EQ 1)
| |
OTHER - strip leading zeros from decimal field
Posted By: jimmy octane Contact |
EvalR MyCharField = %TrimR(%Char(MyCharField)); // strip leading zeros
| |
OTHER - Define jobs running in subsystem QSYSWORK
Posted By: jimmy octane Contact |
IDENTIFYING JOBS IN QSYSWRK
Ever wonder what all those jobs are in subsystem QSYSWRK?
Here are descriptions of some of the more common ones
(a * indicates additional characters that vary from job to job):
a. TCP/IP server jobs
ADMIN Administrative Web server
DEFAULT Default Web server
QMSF Mail server framework
QRWTLSTN Distributed Data Management
(DDM)/Distributed Relational Database Architecture (DRDA) TCP/IP server, daemon
QRWTSRVR DDM/DRDA TCP/IP server
QTBOOTP Bootstrap Protocol (BOOTP) server
QTCPIP TCP/IP interface, daemon
QTFTP* File Transfer Protocol (FTP) server
QTGTELNETS Telnet server
QTLPD* Line Printer Daemon (LPD) server
QTOBDNS Domain Name System (DNS) server
QTODDHCPS Dynamic Host Configuration Protocol (DHCP) server
QTPP* Point-to-point session
QTRTD* Routing daemon (RouteD) server
QTRXC* Remote Execution (REXEC) server
QTSMTPSVSR Simple Mail Transfer Protocol (SMTP) server
QTTFT* Trivial FTP server
b. Client Access host server jobs
QNPSERVD Network print server for TCP/IP, daemon
QNPSERVS Network print server for TCP/IP
QZHQSRVD Data queue server for TCP/IP, daemon
QZHQSSRV Data queue server for TCP/IP
QZRCSRVS Remote command server for TCP/IP
QZSCSRVS Central server for TCP/IP
QZRCSRVSD Remote command server for TCP/IP, daemon
QZSCSRVSD Central server for TCP/IP, daemon
QZSOSGND Sign-on server for TCP/IP, daemon
QZSOSIGN Sign-on server for TCP/IP
QZSOSMAPD Server port mapper for TCP/IP
c. 5250 Display Station Passthrough jobs
QPASVRP Primary passthrough server
QPASVRS Secondary passthrough server
| |
OTHER - DSPDEVU (1/8): DISPLAY LIST OF USER'S ACTIVE SCREEN
Posted By: bossé yvain Contact |
/* ***************************************************************************+
** LISTE DES SOURCES : *+
** DSPDEVU CMD *+
** DSPDEVUC CLP *+
** DSPDEVUD CLP *+
** DSPDEVUE DSPF *+
** DSPDEVUM CLP *+
** DSPDEVUS RPGLE *+
** QPDSPAJBL1 LF *+
** QPDSPAJBP PF *+
** *+
** COMMANDE : DSPDEVU *+
** PROGRAMME EXECUTION : DSPDEVUC *+
** CREER LE : XX/09/04 PAR Yvain Bossé *+
** EMAIL : ybosse@wanadoo.fr *+
** ybosse@free.fr *+
** ***************************************************************************/
CMD PROMPT('ECRANS ACTIFS USER')
PARM KWD(USER) TYPE(*CHAR) LEN(10) MIN(1) +
KEYPARM(*NO) PROMPT('UTILISATEUR' 1)
PARM KWD(SBSJOB) TYPE(*CHAR) LEN(10) DFT(QINTER) +
SPCVAL((*ALL)) PMTCTL(*PMTRQS) +
KEYPARM(*NO) PROMPT('SOUS SYSTEME ' 3)
PARM KWD(OUTFILE) TYPE(*CHAR) LEN(10) DFT(*DFT) +
SPCVAL((*DFT)) PMTCTL(*PMTRQS) +
KEYPARM(*NO) PROMPT('FICHIER RECEPTEUR' 5)
PARM KWD(BIBOUT) TYPE(*CHAR) LEN(10) DFT(*DFT) +
SPCVAL((*DFT)) PMTCTL(*PMTRQS) +
KEYPARM(*NO) PROMPT('BIBLIOTHEQUE DU FICHIER' 4)
PARM KWD(REPLACE) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*REP) VALUES(*REP *ADD *NEW) +
PMTCTL(*PMTRQS) KEYPARM(*NO) PROMPT('MODE +
SUR FICHIER ? ' 6)
| |
OTHER - TCP/IP Printing
Posted By: jimmy octane Contact |
CRTDEVPRT DEVD(CCPRT1) DEVCLS(*LAN) TYPE(3812) MODEL(1)
LANATTACH(*IP) PORT(9100) ATTACH(*DIRECT) ONLINE(*YES)
FONT(11 *NONE) FORMFEED(*AUTOCUT) SEPDRAWER(*FILE)
PRTERRMSG(*INFO) MSGQ(*LIBL/QSYSOPR) ACTTMR(1700)
INACTTMR(*SEC15) LINESPEED(19200) WORDLEN(8)
PARITY(*NONE) STOPBITS(1) TRANSFORM(*YES) MFRTYPMDL(*HP4)
PPRSRC1(*LETTER) PPRSRC2(*LETTER) ENVELOPE(*NUMBER10)
ASCII899(*NO) IMGCFG(*NONE) CHRID(*SYSVAL)
RMTLOCNAME('kim170ohp5m')
SYSDRVPGM(*HPPJLDRV) TEXT('HP4 In Hall of KIM170-o')
| |
OTHER - Free Form monitor
Posted By: jimmy octane Contact |
/Free
Monitor;
Dou %EOF(TimeRecord);
Read TimeRecord;
If %EOF(TimeRecord);
Leave;
Else;
TotalPay = (RegHours * Rate)
+ (OvtHours * Rate * 1.5)
+ (DblHours * Rate * 2);
Update TimeRecord;
Endif;
Enddo;
On-error 1218; // Record locked
Dsply 'TimeRecord record locked.';
Leave;
On-error 1011:1211:*FILE; // File error
Dsply 'Unexpected file error occurred.';
Leave;
On-error *PROGRAM; // Non-file error
Dsply 'Unexpected program error occurred.';
Leave;
Endmon;
*INLR = *ON;
Return;
/End-Free
| |
OTHER - Example of using Data Queues DTAQ
Posted By: jimmy octane Contact |
**
d TimeStamp s Z
d IsOdate s D
d Count s 4 0
d Count2 s 4 0
d CmdString s 256
d CmdLength s 15 5
d Reply s 1
d Chr26 s 26
**
* The defined fields for the QRCVDTAQ
**
d DtaqName s 10A inz('TEST')
d DtaqLib s 10A inz('QTEMP')
d DtaqLen s 5P 0 inz(1000)
d Data s 40A
d WaitTime s 5P 0 inz(-1)
d KeyOrder s 2A
d KeyLen s 3P 0
d KeyData s 32766A
d SenderLen s 3P 0
d SenderInfo s 32766A
d RmvMsg s 10A inz('*YES')
d RcvVarSize s 5P 0
d ErrorCode s 32766A
*
* constants
*
d Q c const('''')
*
**
** Delete the message queue
**
c eval cmdstring = 'DLTDTAQ QTEMP/TEST'
c eval cmdlength = %len(%trim(cmdstring))
*
c call(e) 'QCMDEXC'
c parm cmdstring
c parm cmdlength
**
** CRTDTAQ DTAQ(QTEMP/TEST) MAXLEN(1000) SEQ(*KEYED)
** KEYLEN(05) SENDERID(*YES)
**
c eval cmdstring = 'CRTDTAQ DTAQ(QTEMP/TEST) ' +
c 'MAXLEN(1000) SENDERID(*YES)' +
c ' TEXT(' + Q + 'test dataq'+ Q + ')'
c eval cmdlength = %len(%trim(cmdstring))
c call(e) 'QCMDEXC'
c parm cmdstring
c parm cmdlength
**
** Clear data queue
**
c call(e) 'QCLRDTAQ'
c parm DtaqName
c parm DtaqLib
**
c for Count = 1 to 5
**
c eval Data = 'Test entry' + %char(Count) +
c '-' + %char(%time())
**
c call(e) 'QSNDDTAQ'
c parm DtaqName Data queue name
c parm DtaqLib Data queue library
c parm DtaqLen Data queue length
c parm Data Queued data
c****> parm KeyLen Key length
c****> parm KeyData Key value
**
c endfor
**
c do 5
**
c call 'QRCVDTAQ'
c parm DtaqName Data queue name
c parm DtaqLib Data queue library
c parm DtaqLen Data queue length
c parm Data Queued data
c parm WaitTime Seconds to wait
c****> parm KeyOrder Key selection
c****> parm KeyLen Key length
c****> parm KeyData Key valueh
c****> parm SenderLen Senderninfo length
c****> parm SenderInfo Senderninfo
c****> parm RmvMsg RemovenMsg *NO or *YES
c****> parm RcvVarSize Sizelofgdata receiver
c****> parm ErrorCode Errorength
**
c data dsply reply
**
c enddo
**
c eval *INLR = *on
**
| |
OTHER - Subfile fold documentation
Posted By: Reynoo Moore Contact |
Preventing subfiles from folding back up
Sometimes when a subfile that has a fold/unfold feature is filled
a page at a time, the subfile will revert back to the default
fold/unfold status when the roll keys are pressed.
There is a way to stop this.
You can control the way the subfile is filled with an indicator,
but the trick is letting the program know if the user pressed the
command key to fold or unfold.
The answer to this problem is using the SFLMODE keyword in the
control format of the subfile. The keyword is used like this
SFLMODE(&FOLD). The &FOLD can be any variable you want to use,
but this field name is easy to remember, so we'll use it.
You also have to define FOLD as a hidden field in your record.
Notice that when using it with the keyword, there is an &
in front of it.
Put both the SFLDROP and SFLFOLD keywords in the control format
and and condition them with indicators. For this example,
we'll use indicator 88.
So if 88 is on SFLDROP(CF06), if N88 then SFLFOLD(CF06).
This allows the user to toggle by pressing the F6 key.
Now to the RPG Code.
Initialize the FOLD variable with a 1 or 0, depending on
if you want the default mode to be folded or unfolded on the
subfile, then right before you WRITE the subfile, move FOLD to *IN88.
This will allow the user to toggle back and forth, roll, and still
maintain the view the way they left it.
| |
OTHER - Sort Array (SORTA)
Posted By: Mike Haston Contact |
Question: I've two arrays.
One is an array of dates and the other an arrays of
quantities. I want to sort by the date array and
keep the quantities with the right date.
Answer:
Here's an example with a few arrays ...
d ds
d customers 59 dim( 99 ) inz( *HIVAL )
d custNumber 5a overlay( customers )
d weekEndDate d overlay( customers : *next )
d custName 25a overlay( customers : *next )
d salesCount 9s 0 overlay( customers : *next )
d inventCount 9s 0 overlay( customers : *next )
d sendsWeekly n overlay( customers : *next )
d cust_date_key 15a overlay( customers : 1)
// sort by a fake key that covers the custNumber & weekEndDate subfields
sorta cust_date_key;
// sort by any of the subfields .. the rest of the fields come with it
sorta weekEndData;
sorta salesCount;
| |
OTHER - CLRPFM UTILITY FOR THE IFS
Posted By: Jimmy Octane Contact |
CLRPFM UTILITY FOR THE IFS
Although IBM has not provided a CLRPFM-like utility for the IFS, it's easy
to write one with the open() API. When you open a file with the O_TRUNC flag
specified, the open() API will clear that file.
The following source code implements a CLRF command that you can use in your
CL programs. When this command is run, it will clear a stream file in the
IFS.
File QCMDSRC, member CLRF:
CMD PROMPT('Clear file in IFS')
PARM KWD(STMF) TYPE(*PNAME) MIN(1) VARY(*YES +
*INT2) INLPMTLEN(80) PROMPT('Stream file +
to clear')
File QRPGLESRC, member CLRFR4:
* Clear a stream file or member in the IFS.
* Scott Klement, April 8, 2004
*
* To Compile:
* CRTBNDRPG CLRFR4 SRCFILE(xxxxxx/QRPGLESRC) DBGVIEW(*LIST)
* CRTCMD CLRF PGM(xxxxxx/CLRFR4) SRCFILE(xxxxxx/QCMDSRC)
*
H DFTACTGRP(*NO)
H BNDDIR('QC2LE')
*********************************************************
* Prototypes & constants for the UNIX-type APIs
*********************************************************
D open PR 10I 0 extproc('open')
D path * value options(*string)
D oflag 10I 0 value
D mode 10U 0 value options(*nopass)
D codepage 10U 0 value options(*nopass)
D close PR 10I 0 extproc('close')
D fildes 10I 0 value
D O_WRONLY C 2
D O_TRUNC C 64
*********************************************************
* Local definitions
*********************************************************
D ReportError PR
D CLRFR4 PR ExtPgm('CLRFR4')
D stream_file 5000A varying
D CLRFR4 PI
D stream_file 5000A varying
D fd s 10I 0
c eval fd = open( stream_file
c : O_WRONLY + O_TRUNC )
c if fd < 0
c callp ReportError
c endif
c if close(fd) < 0
c callp ReportError
c endif
c eval *inlr = *on
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* ReportError(): Send an escape message explaining any errors
* that occurred.
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P ReportError B
D ReportError PI
D sys_errno PR * ExtProc('__errno')
D p_errno s *
D errno s 10I 0 based(p_errno)
D QMHSNDPM PR ExtPgm('QMHSNDPM')
D MessageID 7A Const
D QualMsgF 20A Const
D MsgData 1A Const
D MsgDtaLen 10I 0 Const
D MsgType 10A Const
D CallStkEnt 10A Const
D CallStkCnt 10I 0 Const
D MessageKey 4A
D ErrorCode 8192A options(*varsize)
D dsEC DS
D BytesProv 1 4I 0 inz(0)
D BytesAvail 5 8I 0 inz(0)
D MsgKey S 4A
D MsgNo s 4P 0
c eval p_errno = sys_errno
c eval msgno = errno
c callp QMHSNDPM( 'CPE' + %editc(msgno:'X')
c : 'QCPFMSG *LIBL'
c : ' ': 0: '*ESCAPE': '*': 3
c : MsgKey: dsEC)
P E
| |
OTHER - CNTFLD - DDS one long field centered
Posted By: Jamie Contact |
Use this field-level keyword to define a field as a continued
entry field. Continued-entry fields are sets of associated
entry fields that are treated by the work station controller
as a single field during field-data entry and editing.
If the display device is not attached to a controller
that supports an enhanced interface for nonprogrammable
work stations, each segment of the continued entry field
is treated separately when editing is performed on the field.
Figure 126 illustrates the use of continued fields to create
a rectangular text entry field.
Figure 126. Continued-Entry Field in Rectangular Arrangement
Enter Text . . . ________________________________________
________________________________________
________________________________________
________________________________________
________________________________________
The text input format is more appealing to the end user than
a single input field that wraps across multiple display lines.
Even though the last line does not occupy the full width of
the column, no other field is allowed in the rectangle. A
continued-entry field allows a multiple-row entry field to
be defined inside a window.
The format of the keyword is:
CNTFLD(width of column)
One parameter must be specified.
The width of the column parameter specifies the number of
columns to be used for this continued field. This value
must fit within the width of the display or window. This
value must be less than the length of the field.
The field containing the CNTFLD keyword must be defined
as an input-capable field with the data type A.
It cannot be defined in a subfile.
The following keywords cannot be specified on a
field with the CNTFLD keyword:
AUTO (RAB, RAZ)
CHECK(AB, MF, RB, RZ, RLTB)
CHOICE
DSPATR(OID SP)
EDTMSK
The CNTFLD keyword must be defined with at least 2
spaces separating it from other fields.
Option indicators are not valid for this keyword.
The CNTFLD keyword reduces the number of available input fields by
the total number of segments that are used to compose that particular
field. For example, a 60-character input field CNTFLD(10) keyword is
displayed with 6 lines of 10 characters. Each line or segment is
counted as an input-capable field by the controller. Thus, this
field reduces the available input field count by 6.
| |
OTHER - Initial time zone setting - Daylight savings
Posted By: jimmy octane Contact |
Initial time zone setting
During the initial startup, the operating system will set the initial time
zone according to the following steps. There is no shipped default value
for the time zone (QTIMZON) system value. The time zone (QTIMZON) system
value can be set in iSeries Navigator and from the IPL Options display
during an attended IPL.
To determine the initial value for the time zone (QTIMZON) system value,
the operating system does the following:
Step 1: Attempts to retrieve time zone from the QWCTIMZON data area
During the IPL of an OS/400 software upgrade, the operating system will
look for a data area named QWCTIMZON in the QSYS library. To create the
data area before installation, see Setting the time zone before upgrading
to V5R3. If the data area is found, the following steps are taken:
a.
Attempts to find a time zone description object whose name matches the
time zone description object named in the data area. If this step fails,
proceed to step b.
b.
Attempts to find a time zone description object whose name is derived
from the offset specified in the data area. This name will consist of
the letter Q, followed by an N if the offset is negative or a P if the
offset is positive, followed by the offset hours and minutes, and
finally by the letters UTCS. For example, if the offset specified in
the data area is -06:00, the operating system will attempt to find a
time zone description named QN0600UTCS. Note that if the offset is
zero, the character representing the sign ('N' or 'P') will be
omitted, and the name used is Q0000UTC. If this step fails,
proceed to step c.
c.
Attempts to create a new time zone description whose name and offset
match the information specified in the data area. This time zone
description will not support Daylight Saving Time. For example,
if the data area specified is -05:15MYTIMEZONE the operating system
would attempt to create a time zone description named MYTIMEZONE
with an offset of negative five hours and 15 minutes.
If this step fails, proceed to Step 2.
Step 2: Attempts to retrieve time zone from the offset
from UTC (QUTCOFFSET) system value
If the data area QWCTIMZON does not exist, or the above steps fail,
the operating system will attempt to use the value specified in the
offset from UTC (QUTCOFFSET) system value. The following steps
are performed:
a.
Attempts to find a time zone description object whose name is
derived from the offset specified in the offset from UTC (QUTCOFFSET)
system value. See Step 1 - b for information on how this name is
derived. If this step fails, proceed to step b.
b.
Attempts to create a new time zone description whose name was
derived in the previous step (Step 2 - a) and whose offset
matches the information specified in the offset from UTC (QUTCOFFSET)
system value. This time zone description will not support Daylight
Saving Time.
If all of the above steps fail, the time zone (QTIMZON) system value
will not be set. In iSeries Navigator, the time zone field is blank,
and in the character-based interface, the time zone parameter is set
to *N (not available). In addition, the offset from coordinated
universal time (UTC) is set to 0. Then, the system's local system
time is set to the current coordinated universal time (UTC).
| |
OTHER - Universal Unique Identifier UUID
Posted By: Steve Brazzell Contact |
> Here is something that I’ve saved….not sure if it will fit your
> need….I’ve never had a chance to play with it….
>
> The solution to finding a unique identifier is to use a Universal
> Unique Identifier (UUID), a 128-bit value that is guaranteed to be
> unique. The following RPG IV template is for OS/400's GENUUID() MI
> instruction, which generates a UUID:
>
> H Option( *NoSrcStmt ) DftActGrp( *No )
> **
> D UUID_template Ds
> D UtBytPrv 10u 0 Inz( %Size( UUID_template ))
> D UtBytAvl 10u 0
> D 8a Inz( *Allx'00' )
> D UUID 16a
> **
> D GenUuid PR ExtProc('_GENUUID')
> D UUID_template * Value
> **
> C Callp GenUuid( %Addr( UUID_template ))
> **
> C Return
>
>
| |
OTHER - locking/unlocking system values
Posted By: jimmy octane Contact |
Lock and unlock security-related system values
To prevent users from changing security-related system values during normal operation,
system service tools (SST) and dedicated service tools (DST) provide an option to lock
these security values. You must use DST if you are in recovery mode because SST is
not available during this mode. Otherwise, use SST to lock or unlock the
security-related system values.
To lock or unlock security-related system values with the Start System Service Tools
(STRSST) command, follow these steps:
- Open a character-based interface.
- On the command line, type STRSST.
- Type your service tools user name and password.
- Select option 7 (Work with system security).
- Type 1 to unlock security-related system values or 2 to lock security-related system values
in the Allow security-related system values changes parameter.
Note: You must have a service tool profile and password to lock or unlock the
security-related system values.
To lock or unlock security-related system values using dedicated service tools (DST)
during an attended IPL of a system recovery, follow these steps:
From the IPL or Install the System display, select option 3 to Use Dedicated Service Tools.
Note: This step assumes that you are in recovery mode and are performing an attended IPL.
Sign on to DST using your service tools user name and password.
Select option 13 (Work with system security).
Type 1 to unlock security-related system values or 2 to lock security-related system
values in the Allow security-related system values changes parameter.
| |
OTHER - POSITION (Position) keyword in printer files
Posted By: jimmy octane Contact |
http://publib.boulder.ibm.com/infocenter/iseries/v5r3/ic2924/index.htm?info/rzakd/rzakdmst02.htm
POSITION (Position) keyword in printer files
Use this field-level keyword to define the location of a named field on the page.
The format of the keyword is:
POSITION(position-down | &position-down-fieldposition-across | &position-across-field)
The position-down parameter is required and defines the vertical starting point of the
field relative to the margins specified on the FRONTMGN or BACKMGN parameter on the
CRTPRTF command. Valid values are 0 to 57.790 cm (0 to 22.750 in.).
The position-across parameter is required and defines the horizontal starting
point of the field relative to the margins specified on the FRONTMGN or BACKMGN
parameter on the CRTPRTF command. Valid values are 0 to 57.790 cm (0 to 22.750 in.).
You can specify the position-down and position-across parameters as constants,
program-to-system fields, or a combination of both, as shown in the following:
POSITION(3.56 6.24)
POSITION(&field1 9.625)
POSITION(0.5 &field2)
POSITION(&field3 &field4)
Field1, field2, field3, and field4 are the names of program-to-system fields.
The fields must exist in the same record format as the POSITION keyword and be
defined as having length 5 with 3 decimal positions, data type S (zoned decimal),
and usage P (program-to-system).
Note:
The UOM parameter on the CRTPRTF command determines the units of measure for the
position-down and position-across parameter values. If the value specified for
a parameter is outside the valid range, it is flagged when the spooled file is created.
An error message is issued at print time if the field does not fit on the page.
An error message is issued at create time if line and position values, columns 39
through 44, are also specified.
Because the POSITION keyword allows a field to be positioned anywhere on the page,
a new page is not generated by the use of the position keyword. The ENDPAGE keyword
should be used to end the current page and proceed to the next page.
If the POSITION keyword is specified for a field, all fields in the record format
must also have the POSITION keyword specified. Location entries in positions 39
through 44 are not allowed.
An error message is issued if a constant field is specified in a record format where
the POSITION keyword is also specified.
Specify DEVTYPE(*AFPDS) on the CRTPRTF command when POSITION is specified in the file.
If DEVTYPE is changed to anything other than *AFPDS, the keyword is ignored and a
warning message is issued at print time.
You cannot specify POSITION with the following keywords:
SPACEA
SPACEB
SKIPA
SKIPB
Note:
Feature PSF/400 is required for use of this keyword. If PSF/400 is not installed,
you will not be able to print files using this keyword and specifying DEVTYPE(*AFPDS).
Option indicators are valid for this keyword.
Example:
The following example shows how to specify the POSITION keyword.
|...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 A* A R
REC1 A FLD1 6S 2 POSITION(2.0 1.983) A* A FLD2
42A POSITION(&FLD2A &FLD2B)
A FLD2A 5S 3P A FLD2B 5S 3P A*
Note:
The UOM parameter on the CRTPRTF command determines the units of measure for the parameter
values. In REC1, FLD1 prints 2.0 units down and 1.983 units across from the margins
specified on the FRONTMGN or BACKMGN parameter on the CRTPRTF command.
The application program determines the position of FLD2 by assigning values to
program-to-system variables FLD2A and FLD2B.
| |
OTHER - Changing the CCSID of a Stream File
Posted By: Changing the CCSID of a Stream File Contact |
Changing the CCSID of a Stream File
by Scott Klement
From time to time, you'll find a stream file in your IFS that's marked with
the wrong CCSID. I recently had a problem where a file in my IFS was full of
ASCII data but was marked as CCSID 37 (US EBCDIC). This was a problem because
the IBM-supplied commands didn't convert the data, since they thought
it was already in EBCDIC.
The CHGATR command can be used to change the CCSID of a stream file.
Here's an example:
CHGATR OBJ('/path/to/myfile.txt') ATR(*CCSID) VALUE(819)
Another way to do the same thing is with the SETCCSID command in QShell.
Here's an example of that command:
STRQSH CMD('setccsid 819 /path/to/myfile.txt')
If the data in the stream file also needs to be converted, you can use QShell's
ICONV command to convert it. This does not set the CCSID of the resulting file
properly, but we already know how to fix that!
The following command converts the data in MYFILE.TXT from
CCSID 37 to CCSID 819 and writes the output to YOURFILE.TXT:
STRQSH CMD('iconv -f 37 -t 819 /path/to/myfile.txt > /path/to/yourfile.txt
&& setccsid 819 /path/to/yourfile.txt')
Another way to convert the data in the file is with the CPY CL command.
Here's an example of that:
CPY OBJ('/path/to/myfile.txt') TOOBJ('/path/to/yourfile.txt') +
FROMCCSID(37) TOCCSID(819) DTAFMT(*TEXT)
| |
OTHER - Print PDF from IFS
Posted By: jimmy octane Contact |
I just read your article, "How Do I Print a PDF File in the IFS?", and I have an alternate solution that uses
FTP instead of an RPG program.
Create a printer file with *USERASCII specified. Of course, the *Outq and any other miscellaneous parms can be
filled in. In the FTP script, put in BINary and CD PrtfLib (the library containing the *PRTF). Then do a PUT
from the IFS to the printer file.
The reason for the CD PrtfLib (and this seems to be a key element) is that you should not fully qualify the
target of the PUT. If you do qualify the *PRTF, FTP behaves differently. The result is that the *PRTF gets
overlaid with the ASCII data, which isn't what's wanted in this case.
For example, the following FTP commands should work like a champ:
...
BIN
CD PRTFLIB
PUT /MYFOLDER/MyStreamFile MyPDFPrtf
| |
OTHER - How to use Graphical data type
Posted By: Abhay Sharma Contact |
Sir/s
I have no knowledge to use Graphical variable.
Please help me to clearfy that if i scane any image from scanner then can i save this in field .
If yes then please create a sample field and also method to access them.
My objective is to create a Physical File Which hold Graphics(Image) along with Other Fields.
I use this file in my program so that when user run Program Graphics(Immage) is also disply with other data .
Please help me on that, i am very thank ful to you .
With Regards
Abha Sharma
| |
OTHER - SAVEANDIPL combined source
Posted By: BrianDolinar Contact |
and the end
* tag into any member name (your choice)
* in file QRPGLESRC member type RPGLE. CRTBNDRPG to compile.
* NOTE: You need extract the install program only once, this same program
* will install any upload on this page.
*
* 3. Call the install program (or execute XmlPrevew) passing these 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=srcSeqno+1;
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='';
// crtsrcpf
bldexc = 'CRTSRCPF FILE(' +
%trimr(ParseSrcLib)+'/'+
%trimr(srcfile) + ') RCDLEN(' +
srclen + ') CCSID(' +
srccssid + ')';
callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)));
// addpfm
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;
// chgpfm
bldexc = 'CHGPFM FILE(' +
%trimr(ParseSrcLib)+'/'+
%trimr(srcfile) + ') MBR(' +
%trimr(mbrname) + ') TEXT(' +
qs+%trimr(mbrtext)+qs + ')';
callp qcmdexc(bldexc:%len(%trimr(bldexc)));
// clr mbr
bldexc = 'CLRPFM FILE(' +
%trimr(ParseSrcLib)+'/'+
%trimr(srcfile) + ') MBR(' +
%trimr(mbrname) + ')';
callp qcmdexc(bldexc:%len(%trimr(bldexc)));
3e endif;
// ovr 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=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(vrcvar:145:'MBRD0100':
ParseSrcFile + ParseSrcLib:ParseSrcMbr:
'0':vapierrds);
// ------------------------------------------------------
// If error occurred on call, send appropriate message back to user.
1b if vBytav>0; //error occurred
2b if vmsgid = 'CPF9810'; // lib not found
qm_msgtxt = '0000 Library ' +
%trimr(ParseSrcLib) + ' was not found.';
2x elseif vmsgid = 'CPF9812'; // src file not found
qm_msgtxt = '0000 Source file ' +
%trimr(ParseSrcFile)+' was not found in ' +
%trimr(ParseSrcLib) + '.';
2x elseif vmsgid = 'CPF9815'; // member not found
qm_msgtxt = '0000 Member ' +
%trimr(ParseSrcMbr)+' was not found in ' +
%trimr(ParseSrcLib)+'/'+ %trimr(ParseSrcFile);
2x else; // unexpected
qm_msgtxt = '0000 Unexpected message ' +
vmsgid + ' 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:' ': vApiErrDS);
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 ********** ///
]]>
| |
|
|
|
