Prabhat Mohapatra

Converting from AS400 reports to HTML

2009-10-09T02:54:00.000-07:00

Converting AS400 spool files to HTML.....

H

Fcvtwork02 IF F 382 DISK

Fcvtwork01 UF A F 378 DISK

* Standard HTML header lines

D aaHeader S 80A DIM(2) CTDATA PERRCD(1)

* Standard HTML footer line

D aaFooter S 80A DIM(1) CTDATA PERRCD(1)

* Input spooled file data including control characters

D InputData DS
D saSkipLine 3A
D ssSkipLine 3S 0 OVERLAY(saSkipLine:1)
D saSpceLine 1A
D ssSpceLine 1S 0 OVERLAY(saSpceLine:1)
D saInput 378A

* Output HTML-format data

D OutputData DS
D saOutput 378A

* Program parameters - title and page length in lines

D paTitle S 50A
D piPageLen S 10I 0

* Line counter variable

D wiLine S 10I 0

* Procedure prototypes

D HTMLHeader PR

D HTMLFooter PR

D Convert PR

D Merge PR LIKE(saOutput)
D iaOutput LIKE(saOutput)
D iaInput LIKE(saInput)

D SpceLines PR
D isSpceLine LIKE(ssSpceLine)

D SkipLines PR
D isSkipLine LIKE(ssSkipLine)

* Program parameters

C *ENTRY PLIST
C PARM paTitle
C PARM piPageLen

* Output HTML header lines

C CALLP HTMLHeader

* Convert spool file lines to HTML

C READ cvtwork02 InputData LR
C DOW *INLR = *OFF
C CALLP Convert
C READ cvtwork02 InputData LR
C ENDDO

* Output HTML footer lines

C CALLP HTMLFooter

C RETURN

**********************************************************************
* Procedure to create HTML header lines *
**********************************************************************

P HTMLHeader B

D HTMLHeader PI

C EVAL saOutput = aaHeader(1)
C WRITE cvtwork01 OutputData

C IF paTitle <> '*NONE'
C EVAL saOutput = ''
C WRITE cvtwork01 OutputData
C ENDIF

C EVAL saOutput = aaHeader(2)
C WRITE cvtwork01 OutputData

P HTMLHeader E

**********************************************************************
* Procedure to create HTML footer line *
**********************************************************************

P HTMLFooter B

D HTMLFooter PI

C EVAL saOutput = aaFooter(1)
C WRITE cvtwork01 OutputData

P HTMLFooter E

**********************************************************************
* Procedure to convert spooled file data to HTML text *
**********************************************************************

P Convert B

D Convert PI

* If 'space' position is zero, 'overprint' previous line

C IF saSpceLine = '0'

C *HIVAL SETGT cvtwork01
C READP cvtwork01 OutputData 99
C EVAL saOutput = Merge(saOutput:saInput)
C UPDATE cvtwork01 OutputData

C ELSE

* Skip to a line if specified

C IF saSkipLine <> *BLANKS
C CALLP SkipLines(ssSkipLine)
C ENDIF

* Space a number of lines if specified

C IF saSpceLine <> *BLANKS
C CALLP SpceLines(ssSpceLine)
C ENDIF

* 'Print' line

C EVAL saOutput = saInput
C WRITE cvtwork01 OutputData

C ENDIF

C RETURN

P Convert E

**********************************************************************
* Procedure to merge two overlaid lines of text *
**********************************************************************

P Merge B

D Merge PI LIKE(saOutput)
D iaOutput LIKE(saOutput)
D iaInput LIKE(saInput)

D laOutput S LIKE(saOutput)

D i S 5I 0

C EVAL i = 1
C DOW i <= %size(iaInput )
C and i <= %size(iaOutput)
C and i <= %size(laOutput)
C IF %subst(iaInput:i:1) = *BLANK
C EVAL %subst(laOutput:i:1) = %subst(iaOutput:i:1)
C ELSE
C EVAL %subst(laOutput:i:1) = %subst(iaInput :i:1)
C ENDIF
C EVAL i = i + 1
C ENDDO

C RETURN laOutput

P Merge E

**********************************************************************
* Procedure to skip to a given line number *
**********************************************************************

P SkipLines B

D SkipLines PI
D isSkipLine LIKE(ssSkipLine)

C EVAL saOutput = *BLANKS

C IF wiLine > isSkipLine

C DOW wiLine < piPageLen
C WRITE cvtwork01 OutputData
C EVAL wiLine = wiLine + 1
C ENDDO

C EVAL saOutput = '-------------------------'
C WRITE cvtwork01 OutputData
C EVAL saOutput = *BLANKS
C EVAL wiLine = 1

C ENDIF

C DOW wiLine < isSkipLine
C WRITE cvtwork01 OutputData
C EVAL wiLine = wiLine + 1
C ENDDO

C RETURN

P SkipLines E

**********************************************************************
* Procedure to space a number of lines *
**********************************************************************

P SpceLines B

D SpceLines PI
D isSpceLine LIKE(ssSpceLine)

D liCount S 5I 0

C EVAL wiLine = wiLine + 1
C EVAL saOutput = *BLANKS
C DOW liCount < isSpceLine - 1
C WRITE cvtwork01 OutputData
C EVAL wiLine = wiLine + 1
C EVAL liCount = liCount + 1
C ENDDO

C RETURN

P SpceLines E
**

Conversion of AS400 reports to PDF files

2009-10-09T02:52:00.000-07:00

Fcvtwork01 UF A F 378 DISK

* Program parameter - report title

D paTitle S 50A

* Program parameter - spooled file information returned by API

D SplInfo DS
D saReturned 10I 0
D saAvailabl 10I 0
D saIntJobId 16A
D saSplfId 16A
D saJobName 10A
D saUser 10A
D saJobNbr 6A
D saSplFile 10A
D saSplNbr 10I 0
D saFormType 10A
D saUsrDta 10A
D saStatus 10A
D saFilAvail 10A
D saHold 10A
D saSave 10A
D siPages 10I 0
D siCurrPage 10I 0
D siFromPage 10I 0
D siToPage 10I 0
D siLastPage 10I 0
D siRestart 10I 0
D siCopies 10I 0
D siCopyRem 10I 0
D siLPI 10I 0
D siCPI 10I 0
D siOutPty 2A
D saOutq 10A
D saOutqLib 10A
D saOpenDate 7A
D saOpenTime 6A
D saPrtFile 10A
D saPrtfLib 10A
D saPgmName 10A
D saPgmLib 10A
D saAcgCode 15A
D saPrtTxt 30A
D siRcdLen 10I 0
D siMaxRcds 10I 0
D saDevType 10A
D saPrtType 10A
D saDocName 12A
D saFlrName 64A
D saS36Proc 8A
D saFidelity 10A
D saRplUnprt 1A
D saRplChar 1A
D siPageLen 10I 0
D siPageWdth 10I 0
D siSepartrs 10I 0
D siOvrFlw 10I 0
D saDBCS 10A
D saDBCSExt 10A
D saDBCSSOSI 10A
D saDBCSRotn 10A
D saDBCSCPI 10I 0
D saGraphics 10A
D saCodePage 10A
D saFormDf 10A
D saFormDfLb 10A
D siDrawer 10I 0
D saFont 10A
D saS36SplId 6A
D siRotation 10I 0
D siJustify 10I 0
D saDuplex 10A
D saFoldRcds 10A
D saCtlChar 10A
D saAlign 10A
D saPrtQlty 10A
D saFormFeed 10A
D saVolumes 71A
D saLabels 17A
D saExchange 10A
D saCharCode 10A
D siTotRcds 10I 0
D siMultiUp 10I 0
D saFrontOvl 10A
D saFrtOvlLb 10A
D snFOOffDwn 15P 5
D snFOOffAcr 15P 5
D saBackOvl 10A
D saBckOvlLb 10A
D snBOOffDwn 15P 5
D snBOOffAcr 15P 5
D saUOM 10A
D saPagDfn 10A
D saPagDfnLb 10A
D saSpacing 10A
D snPointSiz 15P 5
D snFMOffDwn 15P 5
D snFMOffAcr 15P 5
D snBMOffDwn 15P 5
D snBMOffAcr 15P 5
D snPageLen 15P 5
D snPageWdth 15P 5
D saMethod 10A
D saAFP 1A
D saChrSet 10A
D saChrSetLb 10A
D saCdePagNm 10A
D saCdePgeLb 10A
D saCdeFnt 10A
D saCdeFntLb 10A
D saDBCSFnt 10A
D saDBCSFntL 10A
D saUserDef 10A
D saReduce 10A
D saReserv1 1A
D siOutBin 10I 0
D siCCSID 10I 0
D saUserText 100A
D saSystem 8A
D saOrigId 8A
D saCreator 10A

* Program parameter - bookmark option

D paBookmark S 7A

* Program parameter - bookmark *POS option parameters

D BMarkPos DS
D siPosCount 5I 0
D snPosLine 3P 0
D snPosChar 3P 0
D snPosLen 3P 0

* Program parameter - bookmark *KEY option parameters

D BMarkKey DS
D siKeyCount 5I 0
D siLen 5I 0
D saKeyStr 378A
D snKeyOccur 3P 0
D snKeyOff 3P 0
D snKeyLen 3P 0

* PDF 'object' array

D aiObject S 10I 0 DIM(32767)

* Start position of PDF options

D aaStart S 10A DIM(32767)

* Current object number

D wiObject S 10I 0

* Current count of bytes written

D wiChrCount S 10I 0

* Current page number

D wiPage S 10I 0

* Start position of text

D wiStart S 10I 0

* Bookmark text

D waBookmark S 378A

* Count of occurrences of the bookmark key

D wiOccurs S 5I 0

* Input spooled file data including control characters

D InputData DS
D saSkipLine 3A
D ssSkipLine 3S 0 OVERLAY(saSkipLine:1)
D saSpceLine 1A
D ssSpceLine 1S 0 OVERLAY(saSpceLine:1)
D saInput 378A

* Output PDF-format data

D OutputData DS
D saOutput 378A

* Procedure prototypes

D WritePDF PR
D iaOutput 378A CONST OPTIONS(*VARSIZE)

D AddEscape PR 378A
D iaInput 378A

D PDFHeader PR

D PDFPages PR

D PDFTrailer PR

D NewPage PR

D EndPage PR

D NumToText PR 10A
D iiNum 10I 0 CONST

D NewObject PR

* Program parameters

C *ENTRY PLIST
C PARM paTitle
C PARM SplInfo
C PARM paBookmark
C PARM BMarkPos
C PARM BMarkKey

* Output a PDF header

C CALLP PDFHeader

* Create PDF page 'objects'

C CALLP PDFPages

* Output a PDF trailer

C CALLP PDFTrailer

C RETURN

**********************************************************************
* Procedure to create a PDF 'header' *
**********************************************************************

P PDFHeader B

D PDFHeader PI

D liPage S 10I 0
D liPageObj S 10I 0

* Create catalog object

C CALLP WritePDF('%PDF-1.0')
C CALLP WritePDF('%âãÏÓ')
C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Type /Catalog')
C CALLP WritePDF('/Pages 5 0 R')
C CALLP WritePDF('/Outlines 2 0 R')
C CALLP WritePDF('/PageMode /UseOutlines')
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

* Create outlines object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Type /Outlines')
C CALLP WritePDF('/Count '+%trim(NumToText(siPages)))
C CALLP WritePDF( '/First 9 0 R')
C
C CALLP WritePDF( '/Last '
C + %trim(NumToText((siPages*4)+5))
C + ' 0 R')
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

* Create procedures object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('[/PDF /Text]')
C CALLP WritePDF('endobj')

* Create fonts object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF ('/Type /Font')
C CALLP WritePDF ('/Subtype /Type1')
C CALLP WritePDF ('/Name /F1')
C CALLP WritePDF ('/BaseFont /Courier')
C CALLP WritePDF ('/Encoding /WinAnsiEncoding')
C CALLP WritePDF ('>>')
C CALLP WritePDF ('endobj')

* Create pages object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF ('<<')
C CALLP WritePDF ('/Type /Pages')
C CALLP WritePDF('/Count '+%trim(NumToText(siPages)))

* Write list of child pages

C EVAL liPage = wiObject + 1
C EVAL liPageObj = liPage
C CALLP WritePDF ( '/Kids ['
C + %trim(NumToText(liPage))
C + ' 0 R')

C DOW liPage < siPages + wiObject
C EVAL liPage = liPage + 1
C EVAL liPageObj = liPageObj + 4
C CALLP WritePDF ( ' '
C + %trim(NumToText(liPageObj))
C + ' 0 R')
C ENDDO

C CALLP WritePDF (' ]')

C CALLP WritePDF ('>>')
C CALLP WritePDF ('endobj')

P PDFHeader E

**********************************************************************
* Procedure to create PDF pages *
**********************************************************************

P PDFPages B

D liLine S 10I 0
D liLength S 5I 0
D liChar S 5I 0
D liX S 5I 0
D liY S 5I 0

* Create page object for first page

C EVAL wiPage = 0
C EVAL liX = 0

* Read spooled file data from input work file

C READ cvtwork02 InputData LR

C DOW *INLR = *OFF

* Skip to a line if specified, handling page throw if it occurs

C IF saSkipLine <> *BLANKS
C IF ssSkipLine < liLine or liLine = 0
C IF wiPage <> 0
C CALLP EndPage
C ENDIF
C CALLP NewPage
C EVAL liLine = ssSkipLine
C EVAL liY
C = (612/siPageLen) * (siPagelen-liLine)
C ELSE
C EVAL liY
C = -((612/siPageLen) * (ssSkipLine-liLine))
C EVAL liLine = ssSkipLine
C ENDIF
C ENDIF

* Space a number of lines if specified

C IF saSpceLine <> *BLANKS
C EVAL liLine = liLine + ssSpceLine
C EVAL liY
C = -((612/siPageLen) * ssSpceLine)
C ENDIF

* Set up bookmark if position option specified

C IF paBookmark = '*POS'
C IF liLine = snPosLine and waBookmark = *BLANKS
C EVAL waBookmark = %trim(%subst(saInput :
C snPosChar:
C snPosLen ))
C ENDIF
C ENDIF

* Set up bookmark if key option specified

C IF paBookmark = '*KEY'
C saKeyStr:siLenSCAN saInput:1 liChar
C IF liChar > 0
C EVAL wiOccurs = wiOccurs + 1
C IF wiOccurs = snKeyOccur
C EVAL liChar = liChar + snKeyOff
C EVAL liLength = snKeyLen
C IF liChar + liLength > siPageWdth
C EVAL liLength = siPageWdth - liChar
C ENDIF
C IF liChar < 1
C EVAL liChar = 1
C ENDIF
C IF liChar + liLength <= siPageWdth
C EVAL waBookmark = %trim(%subst(saInput :
C liChar :
C liLength ))
C ENDIF
C ENDIF
C ENDIF
C ENDIF

* Add escape character before special characters \, ( and )

C EVAL saInput = AddEscape(saInput)

* Output the line of text

C CALLP WritePDF( %trim(NumToText(liX))
C + ' '
C + %trim(NumToText(liY))
C + ' Td ('
C + %trimr(saInput)
C + ') Tj')

C READ cvtwork02 InputData LR

C ENDDO

C CALLP EndPage

P PDFPages E

**********************************************************************
* Procedure to create a PDF trailer *
**********************************************************************

P PDFTrailer B

D PDFTrailer PI

D laDateTime S 14A
D i S 10I 0
D liXRef S 10I 0

* Create information object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF( '/Creator ('
C + %trim(saPgmLib)
C + '/'
C + %trim(saPgmName)
C + ')' )
C IF %subst(saOpenDate:1:1) = '0'
C EVAL laDateTime = '19' + %subst(saOpenDate:2:6)
C + saOpenTime
C ELSE
C EVAL laDateTime = '20' + %subst(saOpenDate:2:6)
C + saOpenTime
C ENDIF
C CALLP WritePDF( '/CreationDate (D:'
C + laDateTime + ')')
C CALLP WritePDF('/Title (' + %trim(paTitle) + ')')
C CALLP WritePDF('/Producer (CVTSPLPDF)')
C CALLP WritePDF('/Keywords ()')
C CALLP WritePDF( '/Author ('
C + %trim(saJobNbr)
C + '/'
C + %trim(saUser)
C + '/'
C + %trim(saJobName)
C + ')' )
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

* Create cross-reference

C EVAL liXref = wiChrCount - 1
C CALLP WritePDF('xref 0 '
C + %trim(NumToText(wiObject+1)) )
C CALLP WritePDF('0000000000 65535 f')

C DO wiObject i
C CALLP WritePDF(aaStart(i) + ' 00000 n')
C ENDDO

* Write trailer

C CALLP WritePDF('trailer')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Size '
C + %trim(NumToText(wiObject+1)))
C CALLP WritePDF('/Root 1 0 R')
C CALLP WritePDF('/Info '
C + %trim(NumToText(wiObject))
C + ' 0 R')
C CALLP WritePDF('>>')
C CALLP WritePDF('startxref')
C CALLP WritePDF(%trim(NumToText(liXref)))
C CALLP WritePDF('%%EOF')

P PDFTrailer E

**********************************************************************
* Procedure to create a new PDF 'object' *
**********************************************************************
P NewObject B

D NewObject PI

D lsDataLen S 10S 0
D i S 10I 0

C EVAL wiObject = wiObject + 1
C EVAL i = wiObject
C EVAL lsDataLen = wiChrCount
C MOVE lsDataLen aaStart(i)

P NewObject E

**********************************************************************
* Procedure to output PDF data
**********************************************************************

P WritePDF B

D WritePDF PI
D iaOutput 378A CONST OPTIONS(*VARSIZE)

D liLength S 5I 0

* Update byte count with length of data to be written

C ' ' CHECKR iaOutput liLength
C EVAL wiChrCount= wiChrCount + liLength + 2

* Output data to work file

C EVAL saOutput = %trimr(iaOutput)
C WRITE cvtwork01 OutputData

P WritePDF E

**********************************************************************
* Procedure to convert a number to text *
**********************************************************************

P NumToText B

D NumToText PI 10A
D iiNum 10I 0 CONST

D laSign S 1A
D laInput S 10A
D laOutput S 10A
D liIn S 5I 0
D liOut S 5I 0
D liNum S 10I 0

* Set up sign if and make number positive if number is negative

C IF iiNum < 0
C EVAL laSign = '-'
C EVAL liNum = -iiNum
C ELSE
C EVAL laSign = ' '
C EVAL liNum = iiNum
C ENDIF

* Number number to work character variable

C MOVE liNum laInput

* Skip over leading zeros

C EVAL liIn = 1
C EVAL liOut = 1
C DOW liIn < %size(laInput)
C and %subst(laInput:liIn:1) = '0'
C EVAL liIn = liIn + 1
C ENDDO

* Move digits to output area

C DOW liIn <= %size(laInput)
C and liOut <= %size(laOutput)
C EVAL %subst(laOutput:liOut:1)
C = %subst(laInput :liIn :1)
C EVAL liIn = liIn + 1
C EVAL liOut = liOut + 1
C ENDDO

* Add sign

C IF laSign = '-'
C EVAL laOutput = laSign + laOutput
C ENDIF

* Return number in text format

C RETURN laOutput

P NumToText E

**********************************************************************
* Procedure to add an escape character before special characters *
**********************************************************************

P AddEscape B

D AddEscape PI 378A
D iaInput 378A

D laOutput S 378A
D laChar S 1A
D i S 5I 0
D o S 5I 0
D liLength S 5I 0

* Determine length of input data

C ' ' CHECKR iaInput liLength

* Work through input data and prefix special characters with escape

C EVAL i = 1
C EVAL o = 0
C DOW i <= liLength

C EVAL laChar = %subst(iaInput:i:1)
C IF laChar = '\' or laChar = '(' or laChar = ')'
C EVAL o = o + 1
C EVAL %subst(laOutput:o:1) = '\'
C ENDIF
C EVAL o = o + 1
C EVAL %subst(laOutput:o:1) = laChar
C EVAL i = i + 1
C ENDDO

C RETURN laOutput

P AddEscape E

**********************************************************************
* Procedure to create a new page object *
**********************************************************************

P NewPage B

D NewPage PI

* Create a page object

C EVAL wiPage = wiPage + 1
C CALLP NewObject

C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Type /Page')
C CALLP WritePDF('/Parent 5 0 R')
C CALLP WritePDF( '/Resources << /Font <<'
C + ' /F1 4 0 R >>'
C + ' /ProcSet 3 0 R >>')
C CALLP WritePDF('/MediaBox [0 0 792 612]')
C CALLP WritePDF( '/Contents '
C + %trim(NumToText(wiObject+1))
C + ' 0 R')
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

* Set up bookmark if *PAGNBR option specified

C IF paBookmark = '*PAGNBR'
C EVAL waBookmark = 'Page '
C + %trim(NumToText(wiPage))
C ELSE
C EVAL waBookmark = *BLANKS
C EVAL wiOccurs = 0
C ENDIF

* Create a stream object

C CALLP NewObject

C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF( '<< /Length '
C + %trim(NumToText(wiObject+1))
C + ' 0 R >>')
C CALLP WritePDF('stream')
C EVAL wiStart = wiChrCount
C CALLP WritePDF('BT')

* Determine font size to use from Characters per inch setting

C SELECT
C WHEN siCPI = 50
C CALLP WritePDF('/F1 20 Tf')
C WHEN siCPI = 120
C CALLP WritePDF('/F1 9 Tf')
C WHEN siCPI = 150
C CALLP WritePDF('/F1 8 Tf')
C WHEN siCPI = 167
C CALLP WritePDF('/F1 6 Tf')
C OTHER
C CALLP WritePDF('/F1 10 Tf')
C ENDSL

P NewPage E

**********************************************************************
* Procedure to finish a page object *
**********************************************************************

P EndPage B

D EndPage PI

D liLength S 10I 0

* End text stream

C CALLP WritePDF('ET')
C EVAL liLength = wiChrCount- wiStart
C CALLP WritePDF('endstream')
C CALLP WritePDF('endobj')

* Create indirect length object for stream

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF(%trim(NumToText(liLength)))
C CALLP WritePDF('endobj')

* Create outline object

C EVAL waBookmark = AddEscape(waBookMark)
C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Parent 2 0 R')
C CALLP WritePDF( '/Title ('
C + %trimr(waBookmark) + ')')
C IF wiPage > 1
C CALLP WritePDF( '/Prev '
C + %trim(NumToText(wiObject-4))
C + ' 0 R')
C ENDIF
C IF wiPage < siPages
C CALLP WritePDF( '/Next '
C + %trim(NumToText(wiObject+4))
C + ' 0 R')
C ENDIF
C CALLP WritePDF('/Dest ['
C + %trim(NumToText(wiObject-3))
C + ' 0 R /XYZ 0 792 0]')
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

P EndPage E

Converting AS400 reports to PDF

2009-10-09T02:47:00.000-07:00

The way we can do aconversion of the spool files to PDF filesis not at all difficult task now in AS400.

Convert your spooled files to .HTML or .PDF to display on your intranet. Why put together inter-office packets of daily reports when you can email the reports to each user automatically every end-of-day in both .PDF and .HTML formats.

******************************************************************
H

* Work files

Fcvtwork02 IF F 382 DISK

Fcvtwork01 UF A F 378 DISK

* Program parameter - report title

D paTitle S 50A

* Program parameter - spooled file information returned by API

D SplInfo DS
D saReturned 10I 0
D saAvailabl 10I 0
D saIntJobId 16A
D saSplfId 16A
D saJobName 10A
D saUser 10A
D saJobNbr 6A
D saSplFile 10A
D saSplNbr 10I 0
D saFormType 10A
D saUsrDta 10A
D saStatus 10A
D saFilAvail 10A
D saHold 10A
D saSave 10A
D siPages 10I 0
D siCurrPage 10I 0
D siFromPage 10I 0
D siToPage 10I 0
D siLastPage 10I 0
D siRestart 10I 0
D siCopies 10I 0
D siCopyRem 10I 0
D siLPI 10I 0
D siCPI 10I 0
D siOutPty 2A
D saOutq 10A
D saOutqLib 10A
D saOpenDate 7A
D saOpenTime 6A
D saPrtFile 10A
D saPrtfLib 10A
D saPgmName 10A
D saPgmLib 10A
D saAcgCode 15A
D saPrtTxt 30A
D siRcdLen 10I 0
D siMaxRcds 10I 0
D saDevType 10A
D saPrtType 10A
D saDocName 12A
D saFlrName 64A
D saS36Proc 8A
D saFidelity 10A
D saRplUnprt 1A
D saRplChar 1A
D siPageLen 10I 0
D siPageWdth 10I 0
D siSepartrs 10I 0
D siOvrFlw 10I 0
D saDBCS 10A
D saDBCSExt 10A
D saDBCSSOSI 10A
D saDBCSRotn 10A
D saDBCSCPI 10I 0
D saGraphics 10A
D saCodePage 10A
D saFormDf 10A
D saFormDfLb 10A
D siDrawer 10I 0
D saFont 10A
D saS36SplId 6A
D siRotation 10I 0
D siJustify 10I 0
D saDuplex 10A
D saFoldRcds 10A
D saCtlChar 10A
D saAlign 10A
D saPrtQlty 10A
D saFormFeed 10A
D saVolumes 71A
D saLabels 17A
D saExchange 10A
D saCharCode 10A
D siTotRcds 10I 0
D siMultiUp 10I 0
D saFrontOvl 10A
D saFrtOvlLb 10A
D snFOOffDwn 15P 5
D snFOOffAcr 15P 5
D saBackOvl 10A
D saBckOvlLb 10A
D snBOOffDwn 15P 5
D snBOOffAcr 15P 5
D saUOM 10A
D saPagDfn 10A
D saPagDfnLb 10A
D saSpacing 10A
D snPointSiz 15P 5
D snFMOffDwn 15P 5
D snFMOffAcr 15P 5
D snBMOffDwn 15P 5
D snBMOffAcr 15P 5
D snPageLen 15P 5
D snPageWdth 15P 5
D saMethod 10A
D saAFP 1A
D saChrSet 10A
D saChrSetLb 10A
D saCdePagNm 10A
D saCdePgeLb 10A
D saCdeFnt 10A
D saCdeFntLb 10A
D saDBCSFnt 10A
D saDBCSFntL 10A
D saUserDef 10A
D saReduce 10A
D saReserv1 1A
D siOutBin 10I 0
D siCCSID 10I 0
D saUserText 100A
D saSystem 8A
D saOrigId 8A
D saCreator 10A

* Program parameter - bookmark option

D paBookmark S 7A

* Program parameter - bookmark *POS option parameters

D BMarkPos DS
D siPosCount 5I 0
D snPosLine 3P 0
D snPosChar 3P 0
D snPosLen 3P 0

* Program parameter - bookmark *KEY option parameters

D BMarkKey DS
D siKeyCount 5I 0
D siLen 5I 0
D saKeyStr 378A
D snKeyOccur 3P 0
D snKeyOff 3P 0
D snKeyLen 3P 0

* PDF 'object' array

D aiObject S 10I 0 DIM(32767)

* Start position of PDF options

D aaStart S 10A DIM(32767)

* Current object number

D wiObject S 10I 0

* Current count of bytes written

D wiChrCount S 10I 0

* Current page number

D wiPage S 10I 0

* Start position of text

D wiStart S 10I 0

* Bookmark text

D waBookmark S 378A

* Count of occurrences of the bookmark key

D wiOccurs S 5I 0

* Input spooled file data including control characters

D InputData DS
D saSkipLine 3A
D ssSkipLine 3S 0 OVERLAY(saSkipLine:1)
D saSpceLine 1A
D ssSpceLine 1S 0 OVERLAY(saSpceLine:1)
D saInput 378A

* Output PDF-format data

D OutputData DS
D saOutput 378A

* Procedure prototypes

D WritePDF PR
D iaOutput 378A CONST OPTIONS(*VARSIZE)

D AddEscape PR 378A
D iaInput 378A

D PDFHeader PR

D PDFPages PR

D PDFTrailer PR

D NewPage PR

D EndPage PR

D NumToText PR 10A
D iiNum 10I 0 CONST

D NewObject PR

* Program parameters

C *ENTRY PLIST
C PARM paTitle
C PARM SplInfo
C PARM paBookmark
C PARM BMarkPos
C PARM BMarkKey

* Output a PDF header

C CALLP PDFHeader

* Create PDF page 'objects'

C CALLP PDFPages

* Output a PDF trailer

C CALLP PDFTrailer

C RETURN

**********************************************************************
* Procedure to create a PDF 'header' *
**********************************************************************

P PDFHeader B

D PDFHeader PI

D liPage S 10I 0
D liPageObj S 10I 0

* Create catalog object

C CALLP WritePDF('%PDF-1.0')
C CALLP WritePDF('%âãÏÓ')
C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Type /Catalog')
C CALLP WritePDF('/Pages 5 0 R')
C CALLP WritePDF('/Outlines 2 0 R')
C CALLP WritePDF('/PageMode /UseOutlines')
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

* Create outlines object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Type /Outlines')
C CALLP WritePDF('/Count '+%trim(NumToText(siPages)))
C CALLP WritePDF( '/First 9 0 R')
C
C CALLP WritePDF( '/Last '
C + %trim(NumToText((siPages*4)+5))
C + ' 0 R')
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

* Create procedures object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('[/PDF /Text]')
C CALLP WritePDF('endobj')

* Create fonts object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF ('/Type /Font')
C CALLP WritePDF ('/Subtype /Type1')
C CALLP WritePDF ('/Name /F1')
C CALLP WritePDF ('/BaseFont /Courier')
C CALLP WritePDF ('/Encoding /WinAnsiEncoding')
C CALLP WritePDF ('>>')
C CALLP WritePDF ('endobj')

* Create pages object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF ('<<')
C CALLP WritePDF ('/Type /Pages')
C CALLP WritePDF('/Count '+%trim(NumToText(siPages)))

* Write list of child pages

C EVAL liPage = wiObject + 1
C EVAL liPageObj = liPage
C CALLP WritePDF ( '/Kids ['
C + %trim(NumToText(liPage))
C + ' 0 R')

C DOW liPage < siPages + wiObject
C EVAL liPage = liPage + 1
C EVAL liPageObj = liPageObj + 4
C CALLP WritePDF ( ' '
C + %trim(NumToText(liPageObj))
C + ' 0 R')
C ENDDO

C CALLP WritePDF (' ]')

C CALLP WritePDF ('>>')
C CALLP WritePDF ('endobj')

P PDFHeader E

**********************************************************************
* Procedure to create PDF pages *
**********************************************************************

P PDFPages B

D liLine S 10I 0
D liLength S 5I 0
D liChar S 5I 0
D liX S 5I 0
D liY S 5I 0

* Create page object for first page

C EVAL wiPage = 0
C EVAL liX = 0

* Read spooled file data from input work file

C READ cvtwork02 InputData LR

C DOW *INLR = *OFF

* Skip to a line if specified, handling page throw if it occurs

C IF saSkipLine <> *BLANKS
C IF ssSkipLine < liLine or liLine = 0
C IF wiPage <> 0
C CALLP EndPage
C ENDIF
C CALLP NewPage
C EVAL liLine = ssSkipLine
C EVAL liY
C = (612/siPageLen) * (siPagelen-liLine)
C ELSE
C EVAL liY
C = -((612/siPageLen) * (ssSkipLine-liLine))
C EVAL liLine = ssSkipLine
C ENDIF
C ENDIF

* Space a number of lines if specified

C IF saSpceLine <> *BLANKS
C EVAL liLine = liLine + ssSpceLine
C EVAL liY
C = -((612/siPageLen) * ssSpceLine)
C ENDIF

* Set up bookmark if position option specified

C IF paBookmark = '*POS'
C IF liLine = snPosLine and waBookmark = *BLANKS
C EVAL waBookmark = %trim(%subst(saInput :
C snPosChar:
C snPosLen ))
C ENDIF
C ENDIF

* Set up bookmark if key option specified

C IF paBookmark = '*KEY'
C saKeyStr:siLenSCAN saInput:1 liChar
C IF liChar > 0
C EVAL wiOccurs = wiOccurs + 1
C IF wiOccurs = snKeyOccur
C EVAL liChar = liChar + snKeyOff
C EVAL liLength = snKeyLen
C IF liChar + liLength > siPageWdth
C EVAL liLength = siPageWdth - liChar
C ENDIF
C IF liChar < 1
C EVAL liChar = 1
C ENDIF
C IF liChar + liLength <= siPageWdth
C EVAL waBookmark = %trim(%subst(saInput :
C liChar :
C liLength ))
C ENDIF
C ENDIF
C ENDIF
C ENDIF

* Add escape character before special characters \, ( and )

C EVAL saInput = AddEscape(saInput)

* Output the line of text

C CALLP WritePDF( %trim(NumToText(liX))
C + ' '
C + %trim(NumToText(liY))
C + ' Td ('
C + %trimr(saInput)
C + ') Tj')

C READ cvtwork02 InputData LR

C ENDDO

C CALLP EndPage

P PDFPages E

**********************************************************************
* Procedure to create a PDF trailer *
**********************************************************************

P PDFTrailer B

D PDFTrailer PI

D laDateTime S 14A
D i S 10I 0
D liXRef S 10I 0

* Create information object

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF( '/Creator ('
C + %trim(saPgmLib)
C + '/'
C + %trim(saPgmName)
C + ')' )
C IF %subst(saOpenDate:1:1) = '0'
C EVAL laDateTime = '19' + %subst(saOpenDate:2:6)
C + saOpenTime
C ELSE
C EVAL laDateTime = '20' + %subst(saOpenDate:2:6)
C + saOpenTime
C ENDIF
C CALLP WritePDF( '/CreationDate (D:'
C + laDateTime + ')')
C CALLP WritePDF('/Title (' + %trim(paTitle) + ')')
C CALLP WritePDF('/Producer (CVTSPLPDF)')
C CALLP WritePDF('/Keywords ()')
C CALLP WritePDF( '/Author ('
C + %trim(saJobNbr)
C + '/'
C + %trim(saUser)
C + '/'
C + %trim(saJobName)
C + ')' )
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

* Create cross-reference

C EVAL liXref = wiChrCount - 1
C CALLP WritePDF('xref 0 '
C + %trim(NumToText(wiObject+1)) )
C CALLP WritePDF('0000000000 65535 f')

C DO wiObject i
C CALLP WritePDF(aaStart(i) + ' 00000 n')
C ENDDO

* Write trailer

C CALLP WritePDF('trailer')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Size '
C + %trim(NumToText(wiObject+1)))
C CALLP WritePDF('/Root 1 0 R')
C CALLP WritePDF('/Info '
C + %trim(NumToText(wiObject))
C + ' 0 R')
C CALLP WritePDF('>>')
C CALLP WritePDF('startxref')
C CALLP WritePDF(%trim(NumToText(liXref)))
C CALLP WritePDF('%%EOF')

P PDFTrailer E

**********************************************************************
* Procedure to create a new PDF 'object' *
**********************************************************************
P NewObject B

D NewObject PI

D lsDataLen S 10S 0
D i S 10I 0

C EVAL wiObject = wiObject + 1
C EVAL i = wiObject
C EVAL lsDataLen = wiChrCount
C MOVE lsDataLen aaStart(i)

P NewObject E

**********************************************************************
* Procedure to output PDF data
**********************************************************************

P WritePDF B

D WritePDF PI
D iaOutput 378A CONST OPTIONS(*VARSIZE)

D liLength S 5I 0

* Update byte count with length of data to be written

C ' ' CHECKR iaOutput liLength
C EVAL wiChrCount= wiChrCount + liLength + 2

* Output data to work file

C EVAL saOutput = %trimr(iaOutput)
C WRITE cvtwork01 OutputData

P WritePDF E

**********************************************************************
* Procedure to convert a number to text *
**********************************************************************

P NumToText B

D NumToText PI 10A
D iiNum 10I 0 CONST

D laSign S 1A
D laInput S 10A
D laOutput S 10A
D liIn S 5I 0
D liOut S 5I 0
D liNum S 10I 0

* Set up sign if and make number positive if number is negative

C IF iiNum < 0
C EVAL laSign = '-'
C EVAL liNum = -iiNum
C ELSE
C EVAL laSign = ' '
C EVAL liNum = iiNum
C ENDIF

* Number number to work character variable

C MOVE liNum laInput

* Skip over leading zeros

C EVAL liIn = 1
C EVAL liOut = 1
C DOW liIn < %size(laInput)
C and %subst(laInput:liIn:1) = '0'
C EVAL liIn = liIn + 1
C ENDDO

* Move digits to output area

C DOW liIn <= %size(laInput)
C and liOut <= %size(laOutput)
C EVAL %subst(laOutput:liOut:1)
C = %subst(laInput :liIn :1)
C EVAL liIn = liIn + 1
C EVAL liOut = liOut + 1
C ENDDO

* Add sign

C IF laSign = '-'
C EVAL laOutput = laSign + laOutput
C ENDIF

* Return number in text format

C RETURN laOutput

P NumToText E

**********************************************************************
* Procedure to add an escape character before special characters *
**********************************************************************

P AddEscape B

D AddEscape PI 378A
D iaInput 378A

D laOutput S 378A
D laChar S 1A
D i S 5I 0
D o S 5I 0
D liLength S 5I 0

* Determine length of input data

C ' ' CHECKR iaInput liLength

* Work through input data and prefix special characters with escape

C EVAL i = 1
C EVAL o = 0
C DOW i <= liLength

C EVAL laChar = %subst(iaInput:i:1)
C IF laChar = '\' or laChar = '(' or laChar = ')'
C EVAL o = o + 1
C EVAL %subst(laOutput:o:1) = '\'
C ENDIF
C EVAL o = o + 1
C EVAL %subst(laOutput:o:1) = laChar
C EVAL i = i + 1
C ENDDO

C RETURN laOutput

P AddEscape E

**********************************************************************
* Procedure to create a new page object *
**********************************************************************

P NewPage B

D NewPage PI

* Create a page object

C EVAL wiPage = wiPage + 1
C CALLP NewObject

C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Type /Page')
C CALLP WritePDF('/Parent 5 0 R')
C CALLP WritePDF( '/Resources << /Font <<'
C + ' /F1 4 0 R >>'
C + ' /ProcSet 3 0 R >>')
C CALLP WritePDF('/MediaBox [0 0 792 612]')
C CALLP WritePDF( '/Contents '
C + %trim(NumToText(wiObject+1))
C + ' 0 R')
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

* Set up bookmark if *PAGNBR option specified

C IF paBookmark = '*PAGNBR'
C EVAL waBookmark = 'Page '
C + %trim(NumToText(wiPage))
C ELSE
C EVAL waBookmark = *BLANKS
C EVAL wiOccurs = 0
C ENDIF

* Create a stream object

C CALLP NewObject

C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF( '<< /Length '
C + %trim(NumToText(wiObject+1))
C + ' 0 R >>')
C CALLP WritePDF('stream')
C EVAL wiStart = wiChrCount
C CALLP WritePDF('BT')

* Determine font size to use from Characters per inch setting

C SELECT
C WHEN siCPI = 50
C CALLP WritePDF('/F1 20 Tf')
C WHEN siCPI = 120
C CALLP WritePDF('/F1 9 Tf')
C WHEN siCPI = 150
C CALLP WritePDF('/F1 8 Tf')
C WHEN siCPI = 167
C CALLP WritePDF('/F1 6 Tf')
C OTHER
C CALLP WritePDF('/F1 10 Tf')
C ENDSL

P NewPage E

**********************************************************************
* Procedure to finish a page object *
**********************************************************************

P EndPage B

D EndPage PI

D liLength S 10I 0

* End text stream

C CALLP WritePDF('ET')
C EVAL liLength = wiChrCount- wiStart
C CALLP WritePDF('endstream')
C CALLP WritePDF('endobj')

* Create indirect length object for stream

C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF(%trim(NumToText(liLength)))
C CALLP WritePDF('endobj')

* Create outline object

C EVAL waBookmark = AddEscape(waBookMark)
C CALLP NewObject
C CALLP WritePDF(%trim(NumToText(wiObject))+' 0 obj')
C CALLP WritePDF('<<')
C CALLP WritePDF('/Parent 2 0 R')
C CALLP WritePDF( '/Title ('
C + %trimr(waBookmark) + ')')
C IF wiPage > 1
C CALLP WritePDF( '/Prev '
C + %trim(NumToText(wiObject-4))
C + ' 0 R')
C ENDIF
C IF wiPage < siPages
C CALLP WritePDF( '/Next '
C + %trim(NumToText(wiObject+4))
C + ' 0 R')
C ENDIF
C CALLP WritePDF('/Dest ['
C + %trim(NumToText(wiObject-3))
C + ' 0 R /XYZ 0 792 0]')
C CALLP WritePDF('>>')
C CALLP WritePDF('endobj')

P EndPage E

Email & SMS Error Notifications from an AS/400

2009-10-04T20:04:00.000-07:00

An RPGLE program that uses the QUSLJOB API to list any job that is in *MSGW status and then send an email with the details of the job’s error using SNDDST. The program only has the capability to send to one email address yet I wanted to send it to an email distribution list on our Exchange server as well as send a text message to my phone for after hours support. The program also sent EVERY job in *MSGW, including any printer alignment messages. With my very basic knowledge of RPG I was able to add multiple email address variables and exclude any job that runs in the QSPL subsystem from being included.
Once the program ran to my liking I wrote a simple CL program that would call the program every 5 min and added the CL as an auto start job entry to my subsystem. I’ve had this configuration running for the past 6 months and it’s a great way to stay on top of any jobs that may be holding up QBATCH. Critical system jobs are usually fixed before end users even know something was broken.

* * CrtUsrSpc: Create User Space for OS/400 API's * d QUSCRTUS pr extpgm('QUSCRTUS') d UsrSpc 20A const d ExtAttr 10A const d InitialSize 10I 0 const d InitialVal 1A const d PublicAuth 10A const d Text 50A const d Replace 10A const d ErrorCode 32766A options(*nopass: *varsize) * * --- Prototype for API Retrive User Space * d QUSRTVUS pr extpgm( 'QUSRTVUS' ) d QRtvUserSpace... d 20 d QRtvStartingPosition... d 8b 0 d QRtvLengthOfData... d 8b 0 d QRtvReceiverVariable... d 32048 d QRtvError... d 256
* --- Prototype for API Retrive List Job * d QUSLJOB pr extpgm( 'QUSLJOB' ) d QJobUserSpace... d 20 d QJobFormatName... d 8 d QJobJobName... d 26 d QFldStatus... d 10 d QFldError... d 256 d QJobType... d 1 d QNbrFldRtn... d 8b 0 d QKeyFldRtn... d 8b 0 dim( 100 ) * d qcmdexc pr extpgm( 'QCMDEXC' ) d os400_cmd 2000A options( *varsize ) const d cmdlength 15P 5 const * * Defined variables * d emailaddress s 24 inz('podmaster@chemicalali.com') d size s 10I 0 d UsrSpcName s 20 inz( 'DSPJOB QTEMP ' )
* ******************************************************************
dQUSA0100 DS d QUsrSpcOffset... d 1 4B 0 d QUsrSpcEntries... d 9 12B 0 d QUsrSpcEntrieSize... d 13 16B 0
dLJOBINPUT ds qualified d JobName... d 1 10 d UserName... d 11 20 d JobNumber... d 21 26 d Status... d 27 36 d UserSpace... d 37 46 d UserSpaceLibrary... d 47 56 d Format... d 57 64 d JobType... d 65 65 d Reserved01... d 66 68 d Reserved02... d 69 72B 0 * dLJOB100 ds qualified d JobName... d 1 10 d UserName... d 11 20 d JobNumber... d 21 26 d InternalJobId... d 27 42 d Status... d 43 52 d JobType... d 53 53 d JobSubType... d 54 54 d Reserved01... d 55 56 * dLJOB200 ds qualified d JobName... d 1 10 d UserName... d 11 20 d JobNumber... d 21 26 d InternalJobId... d 27 42 d Status... d 43 52 d JobType... d 53 53 d JobSubType... d 54 54 d Reserved01... d 55 56 d JobInfoStatus... d 57 57 d Reserved02... d 58 60 d NumberOfFieldsReturned... d 61 64B 0 d ReturnedData... d 65 1064 * dLJOB200KEY ds qualified d KeyNumber01... d 1 4B 0 d NumberOfKeys... d 5 8B 0 * dLJOBKEYINFO ds qualified d LengthOfInformation... d 1 4b 0 d KeyField... d 5 8b 0 d TypeOfData... d 9 9 d Reserved01... d 10 12 d LengthOfData... d 13 16B 0 d KeyData... d 17 1016 * * APIErrDef Standard API error handling structure. * * dQUSEC DS d ErrorBytesProvided... d 1 4B 0 d ErrorBytesAvailble... d 5 8b 0 d ErrorExceptionId... d 9 15 d ErrorReserved... d 16 16 * dAPIError DS d APIErrorProvied... d LIKE( ErrorBytesProvided ) d INZ( %LEN( APIError ) ) d APIErrorAvailble... d LIKE( ErrorBytesAvailble ) d APIErrorMessageID... d LIKE( ErrorExceptionId ) d APIErrorReserved... d LIKE( ErrorReserved ) d APIErrorInformation... d 240A *----------------------------------------------------------------- * program status dataarea *----------------------------------------------------------------- d PgmSts SDS d P1User 254 263 d W1Program *PROC *--------------------------------------------------------------* * work fields * *--------------------------------------------------------------* d Variables ds d Q 1 inz( '''' ) d Count 15 0 inz( 0 ) d KeyCount 15 0 inz( 0 ) d EndPos 15 0 inz( 0 ) d JobbStatus 4 inz( ' ' ) d Subsystem 20 inz( ' ' ) d ReturnCode 1 inz( ' ' ) d FormatName 8 inz( ' ' ) d QualifedJobName... d 26 inz( ' ' ) d JobStatus 10 inz( ' ' ) d JobType 1 inz( ' ' ) d NbrOfFldRtn 8B 0 inz( 0 ) d KeyFldRtn 8B 0 inz( 0 ) dim( 100 ) d StartingPosition... d 8B 0 inz( 0 ) d LengthOfData... d 8B 0 inz( 0 ) d KeyStartingPosition... d 8B 0 inz( 0 ) d KeyLengthOfData... d 8B 0 inz( 0 ) d ReceiverVariable... d 32048 d OS400_Cmd 2000 inz( ' ' ) d CmdLength 15P 5 inz( %size( OS400_Cmd ) ) d True 1 inz( *on ) d False 1 inz( *off ) * /free
// // Create a user space // size = 10000;
// Create a user space QUSCRTUS(UsrSpcName: 'USRSPC': size: x'00': '*ALL': 'Temp User Space for QUSLJOB API': '*YES': APIError);
exsr CheckStatusOfJob;
*inlr = *on; // ************************************************************* // check status of an job // ------------------------------------------------------------- begsr CheckStatusOfJob;
// run API to fill user space with information about all iSeries job
FormatName = 'JOBL0200'; QualifedJobName = '*ALL ' + '*ALL ' + '*ALL '; JobStatus = '*ACTIVE'; JobType = '*'; NbrOfFldRtn = 2; KeyFldRtn( 1 ) = 0101; KeyFldRtn( 2 ) = 1906; callp QUSLJOB( UsrSpcName : FormatName : QualifedJobName : JobStatus : APIError : JobType : NbrOfFldRtn : KeyFldRtn );
// if error message from the retrieve job API then dump program
if APIErrorMessageID <> ' '; dump; ReturnCode = True; leavesr; endif;
// run API to get user space attribute
StartingPosition = 125; LengthOfData = 16; callp QUSRTVUS( UsrSpcName : StartingPosition : LengthOfData : ReceiverVariable : APIError ); QUSA0100 = ReceiverVariable;
// if error message from the retrieve user space API then dump program
if APIErrorMessageID <> ' '; dump; ReturnCode = True; leavesr; endif;
// preperation to read from user space
StartingPosition = QUsrSpcOffset + 1; LengthOfData = QUsrSpcEntrieSize;
// read from user space
for count = 1 to QUsrSpcEntries; callp QUSRTVUS( UsrSpcName : StartingPosition : LengthOfData : ReceiverVariable : APIError ); LJOB200 = ReceiverVariable; if APIErrorMessageID <> ' '; dump; ReturnCode = True; leavesr; endif;
// check status of job JobbStatus = ' '; Subsystem = ' '; LJobKeyInfo = LJob200.ReturnedData; KeyStartingPosition = 1; KeyLengthOfData = LJobKeyInfo.LengthOfInformation; for keycount = 1 to LJob200.NumberOfFieldsReturned; LJobKeyInfo = %subst( LJob200.ReturnedData : KeyStartingPosition : KeyLengthOfData ); KeyLengthOfData = LJobKeyInfo.LengthOfInformation; LJobKeyInfo = %subst( LJob200.ReturnedData : KeyStartingPosition : KeyLengthOfData ); Endpos = LJobKeyInfo.LengthOfData; if LJobKeyInfo.KeyField = 0101; JobbStatus = %subst( LJobKeyInfo.KeyData : 1 : Endpos ); elseif LJobKeyInfo.KeyField = 1906; Subsystem = %subst( LJobKeyInfo.KeyData : 1 : Endpos ); endif; KeyStartingPosition = KeyStartingPosition + KeyLengthOfData; endfor;
// if job in message wait then email message to address in // variable email address
if Jobbstatus = 'MSGW'; Subsystem = %trim( %subst( Subsystem : 11 : 10 ) ) + '/' + %trim( %subst( Subsystem : 1 : 10 ) ); os400_cmd = 'snddst type(*lmsg) ' + 'tointnet((' + Q + %trim(EmailAddress) + Q + ')) dstd(' + Q + 'Job is in *MSGW' + Q + ') longmsg(' + Q + 'Job (' + %trim( LJob200.JobName ) + '/' + %trim( LJob200.UserName ) + '/' + %trim( LJob200.JobNumber ) + ') subsystem ' + %trim( Subsystem ) + ' in status *MSGW' + Q + ')'; monitor; qcmdexc ( os400_cmd : %size ( os400_cmd ) ); on-error; dump; endmon; endif;
StartingPosition = StartingPosition + LengthOfData;
endfor;
endsr;

The two variables for email are ‘emailaddress’ and ‘emailaddress1'. Simply change the variables to the email addresses you would like the messages sent to and compile.

The below tool that you can submit to run daily. It searches through the WRKACTJOB and looks for jobs in message wait. It then takes a user ID and use API QUSLJOB to list all jobs, then it finds all interactive device that the user is signed-on and sends him/her a message that there is an error on the system.

fTEMP if e disk usropn rename(TEMP:TEMPR) f prefix(x) * * Program Info * d PgmInfo SDS d @PgmName 1 10 d @Parms 37 39 0 d @MsgID 40 46 d @JobName 244 253 d @UserId 254 263 d @JobNumber 264 269 0 * * constants * d Q c const('''') * * Field Definitions. * d EndLoop s n d CmdLength s 15 5 d CmdString s 256 d CurrentTime s 6 0 d EndTime s 06 0 inz(180000) d OutUser s 10 d InDevice s 10 d InUser s 10 d Jtypes s 1 inz('*') d KeyI s 10i 0 d ListFormat s 8 d NbrKeys s 10i 0 inz(3) d ObjType2 s 10 d OutDevice s 10 d SpacePtr s * d StartTime s 06 0 inz(070000) d Status s 10 d UserSpace s 20 inz('GETDEVICE QTEMP') d UseStatus s 10 inz('*ACTIVE') d X s 3 0 d Y s 3 0 d Z s 3 0 d Dup s 16 d Duplicate s 16 dim(9999) d lastStamp s z dim(9999) d TimeStamp s z d Minutes s 05 0 * d CrtUsrSpc PR * d CrtSpcName 20 const * dKeys DS d Key1 10i 0 inz(1004) d Key2 10i 0 inz(1501) d Key3 10i 0 inz(1603)
dQUSLH DS d QJobName 1 10 inz('*ALL') d QUserName 11 20 inz('*ALL') d QJobNumber 21 26 inz('*ALL') * dQUSLKF DS * Qus Ljob Key Fields d LenFldInfo 1 4B 0 d FieldKey 5 8B 0 d DataType 9 9 d Reserved6 10 12 d DataLength 13 16B 0 * dQUSL020001 DS based(ListPoint) * Qus JOBL0200 d JobName 1 10 d UserName 11 20 d JobNumber 21 26 d IntJobId 27 42 d JobStatus 43 52 d JobType 53 53 d JobSubType 54 54 d Reserved1 55 56 d JobInfoSts 57 57 d Reserved2 58 60 d NumFldsRet 61 64B 0 d KeyData 65 180
d QUSKFI DS 16 d QUSLFIR01 9B 0 OVERLAY(QUSKFI :00001) d QUSKF00 9B 0 OVERLAY(QUSKFI :00005) d QUSTOD01 1 OVERLAY(QUSKFI :00009) d QUSERVED33 3 OVERLAY(QUSKFI :00010) d QUSLD01 9B 0 OVERLAY(QUSKFI :00013) * * Varying length dQUSH0300 DS Based(GenDsPoint) * Qus Generic Header 0300 d UserArea 1 64 d SizeGenHdr 65 68B 0 d StrRelLvl 69 72 d FormatName 73 80 d ApiUsed 81 90 d TimeStampX 91 103 d InfoStatus 104 104 d SizeSpace 105 108B 0 d OffsetInpP 109 112B 0 d SizeInpPrm 113 116B 0 d OffsetHeadS 117 120B 0 d SizeHeadS 121 124B 0 d OffsetLstD 125 128B 0 d SizeLstD 129 132B 0 d Entries# 133 136B 0 d EntrySize 137 140B 0 d CCSIDEnt 141 144B 0 d CountryId 145 146 d LanguageID 147 149 d SubsetLstI 150 150 d Reserved3 151 192 d EntryPtName 193 448 d Reserved4 449 576
* Standard Error Code data structure d ErrorDs DS INZ d BytesProvd 1 4B 0 d BytesAvail 5 8B 0 d MessageId 9 15 d ERR### 16 16 d MessageDta 17 116

*========================================================== * MAIN LINE *========================================================== c Time CurrentTime c dow CurrentTime >= StartTime and c CurrentTime <= EndTime * c exsr Hskpg * c *Start setll TEMP c read TEMP c dow not%eof(TEMP) * c if %subst(XTEMP:111:04) = 'MSGW' c exsr $CheckandSend c endif * c read TEMP c enddo * * delete the spooled file * c eval cmdstring = 'DLTSPLF FILE(QPDSPAJB)' + c ' SPLNBR(*LAST)' c eval cmdlength = %len(%trim(cmdstring)) c call(e) 'QCMDEXC' c parm CmdString c parm CmdLength * * delay job 20 seconds * c eval cmdstring = 'DLYJOB 20' c eval cmdlength = %len(%trim(cmdstring)) c call(e) 'QCMDEXC' c parm CmdString c parm CmdLength * c Time CurrentTime c enddo * c eval *inlr = *on * *============================================================== * $CheckandSend - Check to see if MSGW is valid * if it is send messages *============================================================== c $checkandSend begsr * * Get the device (*ACTIVE) for the userid and send break message * c if %subst(XTEMP:4:10) <> 'MSC18#3' and c %subst(XTEMP:4:10) <> 'MSC18#4' * c do 2 x * c select c When X = 1. c Eval OutUSer = 'FLANARY' c When X = 2. c Eval OutUSer = 'LAMB' c endsl * c eval QUserName = OutUser * Create user space for file list information c Eval SpacePtr = CrtUsrSpc(UserSpace) * * List jobs to user space c Call 'QUSLJOB' c Parm UserSpace c Parm 'JOBL0200' ListFormat c Parm QusLH c Parm '*ALL' Status c Parm ErrorDs c Parm Jtypes c Parm NbrKeys c Parm Keys
* Load the general data structure c Eval GenDsPoint = SpacePtr
* If the list API was complete or partially complete c if InfoStatus = 'C' OR c InfoStatus = 'P' * Load the list data structure c Eval ListPoint = GenDsPoint + OffsetLstD
b01 c Do Entries#
c If UseStatus = *blanks OR c UseStatus = JobStatus
* Process keys returned c Eval KeyI = 1 c Do NumFldsRet c Eval QusKFI = %subst(KeyData:KeyI:16)
* * Call API to see if valid device * * * Jobq info * c if QUSKF00 = 1004 and c JobType = 'I' c eval OutDevice = JobName * * only send the same error to user every 5 minutes. * c eval TimeStamp = %TimeStamp() c eval Dup = %trim(%subst(XTEMP:29:06)) + c %trim(OutDevice) c eval Y = 1 c Dup lookup Duplicate(Y) 99 * c if Not%Found or c %found and c %diff(Timestamp:laststamp(Y):*Minutes) > 5 * c If %diff(TimeStamp:laststamp(Y):*Minutes) > 5 c clear Duplicate(Y) c clear Laststamp(Y) c endif * c eval Z = Z + 1 c eval Duplicate(Z) = Dup c eval laststamp(Z) = TimeStamp * * Send the message that there is an error * SNDBRKMSG MSG('hey big-o-problem') TOMSGQ(QPADEV003M) * c eval cmdstring = 'SNDBRKMSG MSG(' + c %trim(Q) + c %trim('Job:') + c %trim(%subst(XTEMP:4:10)) + c %trim('@User:') + c %trim(%subst(XTEMP:17:10)) + c %trim('@Number:')+ %subst(XTEMP:29:06) + c '@Is in Message wait.' + c %trim(Q) + %trim(') TOMSGQ(') + c %trim(OutDevice) + %trim(')') * c eval CmdString = c %Xlate('@':' ':CmdString) * c eval cmdlength = %len(%trim(cmdstring)) c call(e) 'QCMDEXC' c parm CmdString c parm CmdLength * * End Send Message * c endif c endif * c eval KeyI = KeyI + QusLFir01 c enddo c endif
c eval ListPoint = ListPoint + EntrySizee01 c enddo c endif * c enddo * c endif * c endsr *============================================================== * Hskpg - One time run House keeping subroutine *============================================================== c Hskpg begsr * * CLOSE the physical file * c if %open(TEMP) c close TEMP c endif * * Hold the wrkactjob spooled file so we can read it. * OVRPRTF FILE(QPDSPAJB) HOLD(*YES) * c eval cmdstring = 'OVRPRTF FILE(QPDSPAJ' + c %trim('B) HOLD(*YES)') c eval cmdlength = %len(%trim(cmdstring)) c call(e) 'QCMDEXC' c parm CmdString c parm CmdLength * * Now print WRKACTJOB * WRKACTJOB SBS(QBATCH QPGMR QINTER) OUTPUT(*PRINT) SEQ(*STS) * c eval cmdstring = 'WRKACTJOB SBS(QBATCH QPGMR' + c ' QINTER) OUTPUT(*PRINT)' + c ' SEQ(*STS)' c eval cmdlength = %len(%trim(cmdstring)) c call(e) 'QCMDEXC' c parm CmdString c parm CmdLength * * Create physical file in QTEMP to copy the spooled file to * CRTPF FILE(QTEMP/TEMP) RCDLEN(198) * c eval cmdstring = 'CRTPF FILE(QTEMP/TEMP' + c %trim(') RCDLEN(198)') c eval cmdlength = %len(%trim(cmdstring)) c call(e) 'QCMDEXC' c parm CmdString c parm CmdLength * * Copy the spooled file into out physical so we can read it * CPYSPLF FILE(QPDSPAJB) TOFILE(QTEMP/TEMP) SPLNBR(*LAST) * c eval cmdstring = 'CPYSPLF FILE(QPDSPAJB' + c %trim(') TOFILE(QTEMP/') + c %trim('TEMP) SPLNBR(*LAST)') c eval cmdlength = %len(%trim(cmdstring)) c call(e) 'QCMDEXC' c parm CmdString c parm CmdLength * * OPEN the physical file * c if not%open(TEMP) c open TEMP c endif * c endsr * *============================================================== * * Procedure to create extendable user space, return pointer to it. * P CrtUsrSpc B export d CrtUsrSpc PI * d CrtSpcName 20 const
* Local Variables d PasSpcName DS 20 d SLib 11 20 d ChgAttrDs DS 13 d NumberAttr 9B 0 inz(1) d KeyAttr 9B 0 inz(3) d DataSize 9B 0 inz(1) d AttrData 1 inz('1') d ListPtr S * d SpaceAttr S 10 inz d SpaceAuth S 10 INZ('*CHANGE') d SpaceLen S 9B 0 INZ(4096) d SpaceReplc S 10 INZ('*YES') d SpaceText S 50 d SpaceValue S 1
* Create the user space c move CrtSpcName PasSpcName c CALL 'QUSCRTUS' c PARM PasSpcName c PARM SpaceAttr c PARM SpaceLen c PARM SpaceValue c PARM SpaceAuth c PARM SpaceText c PARM '*YES' SpaceReplc c PARM ErrorDs * Get pointer to user space c CALL 'QUSPTRUS' c PARM PasSpcName c PARM ListPtr * Change user space to be extendable c CALL 'QUSCUSAT' c PARM Slib c PARM PasSpcName c PARM ChgAttrDs c PARM ErrorDs
c return ListPtr P CrtUsrSpc E

Enjoy with sending Emails and SMS through AS400

2009-09-21T23:13:00.001-07:00

1. Use of SBMJOB commandMost people use the OS/400 Submit Job (SBMJOB) command for batch processing.But SBMJOB has other powers that help to increase the capabilities of batch jobs.Command Example:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB)This way OS/400 submits the job for execution based on the configuration of the userrunning the command. The job runs under the user profile of the submitting user, ituses the job description assigned to the submitting user, it's submitted to the jobqueue associated with the assigned job description, and it uses the scheduling andoutput queue priorities assigned to its job description.There are lots of times when you need to change the defaults and modify theoperating parameters of a submitted job. For instance, you can submit your job to rununder another user profile by modifying the USER parameter of a SMBJOBstatement in the following manner:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TEST) USER(NEWUSER)For this command to work, the submitting user must be authorized to the user profileassigned to the batch job. When submitted this way, the submitted job also uses thejob description associated with the new user profile. The job queue, run priority, andoutput priority values then take their values from the new job description.You can also submit the job to a job queue other than that associated with the jobdescription.SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TEST) JOBQ(QSYS/QSYSNOMAX)USER(NEWUSER)In addition to changing user profiles and job queues, you can set SBMJOBparameters to change the system library list for the job (the SYSLIBL parameter onthe command), the current library for the job (the CURLIB parameter), and the job'sinitial library list (INLLIBL).If you want to log all the CL commands that are executed in your batch job to theTitle of the DocumentInternal Use 3job's job log, set the Log CL program (LOGCLPGM) command parameter to *YES,like this:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB) LOGCLPGM(*YES) If you want to submit the job so that it is held on the job queue, use the Hold on jobqueue (HOLD) parameter:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB) HOLD(*YES) If you want to use SBMJOB to schedule a job to start at a certain date and time, usethe Schedule date (SCDDATE) and Schedule time (SCDTIME) parameters.SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB)SCDDATE('11/01/03') SCDTIME('10:00:00') Another neat trick is that you can hide submitted jobs from the Work with SubmittedJobs (WRKSBMJOB) command. To do this, set the Allow Display by WRKSBMJOB(DSPSBMJOB) parameter to *NO, and submit your job in the following manner:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB) DSPSBMJOB(*NO) If a user tries to view the progress of this job by using the WRKSBMJOB command,he won't be able to see it. Note, however, that users can still see the running job byfinding it on the Work with Active Jobs (WRKACTJOB) command display or on theWork with Subsystem Jobs (WRKSBSJOB) command display.If you don't want operators to answer predefined inquiry messages that appearduring batch processing, you can set SBMJOB's Inquiry Message Reply(INQMSGRPY) parameter to tell the job how to answer messages. If you use thedefault, the job will use the inquiry message control value found in its correspondingjob description. However, if you want your batch job to use default reply values forinquiry messages, you can submit the job with its INQMSGRPY value set to *DFT,like this:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB) INQMSGRPY(*DFT) And the final SBMJOB trick is to change the message queue to which SBMJOBsends its job completion messages. You have three choices. By default, jobmessages are sent to the message queue that is specified in the user profile that thejob runs under. If you want to do it manually, you change the Message Queue(MSGQ) parameter of the SBMJOB statement, as follows:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB) MSGQ(*USRPRF) But if you want to change that message queue so that your messages go to themessage queue of the workstation the job was submitted from, you set MSGQ to*WRKSTN and your SBMJOB statement would look like this:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB) MSGQ(*WRKSTN) Title of the DocumentInternal Use And if you want to suppress the completion message altogether, change MSGQ to*NONE and the job won't send out completion messages at all:SBMJOB CMD(CALL PGM(PROGRAM)) JOB(TESTJOB) MSGQ(*NONE) 2. Job Logs and their UsefulnessA job log is invaluable in determining the cause of a problem when a job endsabnormally. If not properly managed, though, job logs can eat up huge amounts ofsystem storage. Understanding how job logs get generated is the first step tounderstanding how to managing them.The system program maintains the job log. Every job that runs on your server has anassociated job log that records its activities. A job log can contain the following:• The commands in the job• The commands in a control language (CL) program• All messages associated with that jobWhat determines when a job log will be created?There are several ways within OS/400 to specify the creation of or restrict thecreation of a job log.Job log for a Batch JobThe message logging parameters on the job description and for an active jobdetermine what kind of information will be collected:

Message logging: LOGLevel . . . . . . . . . . . . 4

Severity . . . . . . . . . . . 00

Text . . . . . . . . . . . . . *NOLIST

Log CL program commands . . . . LOGCLPGM *NO

I won't go into all the specifics related to those values at this time, but if the message logging 'TEXT' parameter is set to *NOLIST, a job log will be created only if the jobends abnormally. If the job completes normally, no job log will be created. This is thesame whether the job is an interactive or batch job.If any value other than *NOLIST is specified for the message logging 'TEXT'parameter in a batch job, a job log will always be produced -- whether the job endsnormally or abnormally.Job log for a Interactive JobThis works differently for interactive jobs, though. To conserve disk space consumedby job logs, the SIGNOFF command may be defined asSign Off (SIGNOFF)Type choices, press Enter.Title of the DocumentInternal Use 5

Job log . . . . . . . . . . . . LOG *NOLIST

Drop line . . . . . . . . . . . DROP *DEVD

End connection . . . . . . . . . ENDCNN *NO

So, by default, when an interactive job is ended normally, no job log will be producedas specified by the LOG(*NOLIST) parameter. However, if an interactive job endsabnormally, a job log will be produced.This job log is usually stored in the QEZJOBLOG output queue in library QUSRSYS.You can determine where your job log output goes with this command:DSPFD FILE(QPJOBLOG)Scroll down to the Spooling Description section of the Display File Description listingto see which output queue job log output will be directed to:Spooling Description

Spooled output queue . . . . . . . . . . . : OUTQ QEZJOBLOG

Library . . . . . . . . . . . . . . . . . : QUSRSYS

If you want to always force the creation of a job log from an interactive job, you cando it in one of two ways:1. When you sign off enter SIGNOFF LOG(*LIST) instead of using the default.2. Prior to signing off enter DSPJOBLOG OUTPUT(*PRINT). When one of those options is used, a job log will always be created from aninteractive job.View the JoblogNow that you understand how job logs are created on the iSeries, let's look at how toview one?To view a job log that has already been created, use one of the following commands:

DSPSPLF FILE(QPJOBLOG) JOB(job_number/Usrid/Job_name)DSPJOB JOB(job_number/Usrid/Job_name) OPTION(*SPLF)

To see ALL job log output on the system, use this command:WRKOUTQ OUTQ(QUSRSYS/QEZJOBLOG)For further information on how to create/display or modify job descriptions, review theHELP text associated with the following OS/400 commands:

CHGJOBD CRTJOBD DSPJOBD WRKJOBD

For further information on how to view/change a jobs message logging attributes andto display a job log, review the HELP text associated with these OS/400 commands:DSPJOB

CHGJOB DSPJOBLOG

SQL WorkingWhen you execute an SQL command, the system determines the best way to carryout your request. That is, you concentrate on the task that needs to be done, and thesystem figures out how to do your task.Various software components are involved in this process, and for this discussion,you need to know about three of them. First is the Query Dispatcher, whose job it isto decide which of the two query optimization engines it will call on to optimize andprocess a query. The second and third software components are the two queryengines--the Classic Query Engine (CQE) and the SQL Query Engine (SQE). SQE is newer and better than CQE, but there are certain tasks that it can't carry out.You can reference four types of files in SQL statements: DDS-defined physical files,DDS-defined logical files, SQL tables, and SQL views. SQE can't handle DDSdefinedlogical files. SQL views and indexes are also implemented as logical files, butthey are not applicable to this discussion.CQE handles all non-SQL queries, such as the Open Query File (OPNQRYF) command and Query/400. CQE also handles distributed queries via DB2multisystem.If you wish to query a logical file from an SQL statement, consider querying theunderlying physical file(s) instead. If the logical file has select/omit criteria, put thecriteria in the WHERE clause. Another approach would be to create a view over thephysical file and reference that view in your SQL query

AS400 ConstraintsConstraints are a function of Referential Integrity, where the database managerensures the logical consistency of data values between files and the validity of datarelationships, based on rules set by you.Impressive as that sounds, it is something you are already doing; except that you aredoing it in your application programs. For example you cannot delete the customer ifthere are dependant invoices on the invoice file, and you do not employ people underthe age of sixteen. Those constraints are implemented through logic in your RPG orCOBOL programs. As your applications expand and data becomes accessibleoutside of the traditional green screen, it becomes imperative that these rules areconsistent across all interfaces. What better way to implement them then through thedatabase manager?

are defined for physical files or tables. You can define three types ofConstraint: Key, Referential and Check. How do you define constraints?You can define constraints using the Add Physical File Constraint (ADDPFCST)command. You can also use the CHGPFCST, RMVPFCST, WRKPFCST,EDTCPCST and DSPCPCST commands.You can define them in SQL using the CREATE TABLE or ALTER TABLEcommands.Key constraintsKey constraints define unique keys for a table. The end result is an access path, butthere is no corresponding logical file. Since DB2 automatically shares access paths,there is no extra overhead if there is already a logical file that defines the accesspath.There are two types of Key constraints: unique and primary. A table may have onlyone primary Key constraint but may have many unique Key constraints.The same constraint could be defined on green screen using the following command:

ADDPFCST FILE(ALLTHAT1FL/CATEGOR) TYPE(*PRIKEY)KEY(CATCOD) CST(CategoryPrimaryKey)

Referential constraints : Referential constraints are where you define a constraint between two tables: aparent and a dependant. The parent file must have a primary constraint defined for it.In this example there is a dependency between the Category file and the Product file.Every product "belongs" to a category. Therefore, you should not be able to delete acategory if any products refer to it, and you should not be able to assign a nonexistentcategory to a product. Think how you would manage this in an application --a logical over the product file that you use to check for existing records in the Category maintenance program and the Product maintenance program checks the Category file to make sure the category code is valid. (But you can bypass all of thatwith DFU.)Referential Integrity is a powerful tool for us to use in our applications and provide ameans of ensuring data integrity outside of our application.Title of the DocumentInternal Use 85. Access path and Open data path for Data Access Open Data PathOpen Data Path provides a way for more than one program in the same job to share the same file status information (I/O feedback areas), file pointer positions, andstorage area. ODP's are quite useful as they can improve performance, reduce theamount of main storage needed by the job, and reduces file opens/closes.For native I/O access you can set up ODP's by specifying SHARE(*YES) on theCRTPF, CHGPF, or OVRDBF commands. However, SQL based I/O access is notinfluenced by the SHARE (*YES) setting. The DB2 SQL engine is solely responsiblefor creating and reusing ODP's for I/O performed from SQL-based interfaces (anddoes so automatically).Access PathAn access path (also known as a keyed logical file or an index in SQL terms) is datastructure that represents the order in which data will be retrieved from a file. Itprovides a quick way of locating data. Without an access path, a program would beforced to read every row in the table to find the particular rows of interest. Thistechnique (known as a full table scan), can be a lengthy process, depending on thesize of the table and how many rows are being retrieved. A scan using an accesspath tends to be more efficient than a full table scan when a small percentage ofrows are selected since the length of the access path key value is usually shorterthan the length of the table row6. Faster Query Access:Faster is better when accessing large volumes of data. There are many ways toimprove SQL performance, but here are four tips that are especially useful for highvolume, read-only database access.• Code a Set Option AlwCpyDta = *Optimize SQL statement (or theAlwCpyDta(*Optimize) parameter on the appropriate CL command). This lets theoptimizer choose whether to create a new index or use a sort for a temporary copy ofthe data.• Note that AlwCpyDta=*Yes actually means "use a copy only when it's required toperform the query." This allows the optimizer less latitude than the *Optimize optionprovides.• Code a Set Option AlwBlk = *AllRead SQL statement (or the AlwBlk(*AllRead)parameter on the appropriate CL command). This maximizes system blocking whenpossible.• Use a CL OvrDbF (Override with Database File) command with the SeqOnly (*Yes,Title of the DocumentInternal Use 9mm) and/or the NbrRcds (nn) parameter(s) to specify system blocking for batchsequential Fetch's.Use multi-row fetches to read a set of records with each Fetch statement.7. Prototype Calls in RPGLE:A lot of RPG programmers are under the misconception that the CALLP operationmeans Call Procedure. That is because most of them come across it when they startusing sub procedures. But CALLP means Call a Prototyped Procedure or Program,and it can be used in place of the CALL operation, as well as CALLB.What's wrong with CALL and PARM?In RPG all parameters are passed by reference. That means a pointer to theparameter is passed, not the actual value of the parameter. That, in turn, means boththe passed and receiving parameter fields share the same memory location, and thatis where the potential problem lies.Prototypes are defined on the D specifications, as shown in Figure 1. The format of aprototype is very similar to a data structure, except that the type is PR as opposed toDS. You can provide your own name for the CALLP (PromptProduct). The EXTPGMkeyword indicates that this is the equivalent of a CALL operation, and it identifies thename of the called program (PRP01R). The names of the subfields in the prototypeare irrelevant, what are important are the number of subfields (i.e. parameters) andthe definition of each. In the example in Figure 1 the compiler will ensure that twoparameters are passed, that Parm1 is a 30 character field and that Parm2 is a 1character field.D PromptProduct PR ExtPgm('PRP001R')D FirstParm 30D SecondParm 1C CallP PromptProduct(Parm1:Parm2)Other features of prototype like ‘CONST’, ‘*OMIT’, ‘*NOPASS’ easy the codingprocess.8. Recursive Call in RPGLE:RPG does not allow recursive calls. Actually ILE RPG does allow recursion. Aprogram cannot call itself, but it can call a sub procedure that calls itself.The procedure call should not use the CALLP opcode; rather it should use the EVALopcode and treat the procedure as a function. For example, a procedure nameTitle of the DocumentInternal Use 10CALCS would use the following code:RETURN CALCS (value02)The sample code calculates the nth number in a Fibonacci sequence. A Fibonaccisequence is a sequence whereby any number is equal to the previous two numbersin the sequence:Nbr(n) = Nbr(n-1) + Nbr(n-2).In the sequence, the first number is 1, preceded by an implied zero so that thesecond number has an "n-2" to use.The first few elements then calculate to:1 1 2 3 5 8 13 21 34It is an interesting exercise to run this procedure in DEBUG and observe its action.The sub procedure CALCS would be called from an ILE RPG program using astatement such as:EVAL RESULT = CALCS(Nbr)Note that if the recursion proceeds through too many recursive calls, thatperformance drastically slows down. In this example, anything over 30 calls really ranslowly. If the job ends abnormally while into a deep call stack, the end job processtakes a very long time.Code* Procedure PrototypeDCALCS PR 9P 0D 9P 0* * * * * * * * * * * * * * * * * * * Procedure DefinitionP CALCS B*D CALCS PI 9P 0D NBR 9P 0** Procedure variablesD NM1 S 9P 0D NM2 S 9P 0*C SELECT* Endpoint if inbound parm = 0C WHEN NBR = 0C RETURN 1* Endpoint if inbound parm = 1C WHEN NBR = 1C RETURN 1* Endpoint if inbound parm = 2C WHEN NBR = 2C RETURN 1* Recursive callTitle of the DocumentInternal Use 11C OTHERC EVAL NM1 = NBR - 1C EVAL NM2 = NBR - 2C RETURN CALCS(NM1)+ CALCS(NM2)C ENDSL9. Handle errors in RPG like CL:Any type of exception can be captured in the RPG program by using MONITORopcode, it is like the MONMSG of CLP. You can put any code between MONITORand ENDMON opcodes, so that whatever error occurred in this range will bemonitored.See the example below:Example:Declare an array like Arr with DIM(2) Declare 3 variables A, B and C with length 2,0.The below code shows how to monitor the runtime errors.The initial value of A and C is 0, initiate value of B is 11.MONITORB DIV AArr(B) DsplyON-ERROR 0102'Div by 0' DsplyON-ERROR 0121'Index Err' DsplyON-ERROR'Error' DsplyENDMONSimilar way specific errors can be captured and handled accordingly in RPG.10. Active User Description in AS400:Have you ever wanted to see the description of an active user on the system insteadof just seeing his or her user profile?Try this:Go ManagesysOption 12F113 User descriptionsThis will show you all active users, in username order, with their names shownbeside them. If you want to send a break message to them, press F10 and this willsend a message to all active users.Title of the DocumentInternal Use 1211. Find Data in a Multi-Member file:Ever have to look through a large multimember file for a particular record?It can be a time consuming task.Key in FNDSTRPDM + F4. Options are self-explanatory.Option member allow user to key in "*ALL" and will search through all members forthe strings keyed. Allows user to display, print, and edit records when string is found.12. Date Manipulation in CLUsing the code below you'll be able to do date manipulation in a CL program, andretrieving the system date.

DCL VAR(&SYSDATE) TYPE(*CHAR) LEN(6)

DCL VAR(&YESTERDAY) TYPE(*DEC) LEN(8 0)

DCL VAR(&LILIAN) TYPE(*CHAR) LEN(4)

DCL VAR(&JUNK1) TYPE(*CHAR) LEN(8)

DCL VAR(&JUNK2) TYPE(*CHAR) LEN(23)

DCL VAR(&WDATE) TYPE(*CHAR) LEN(8)

RTVSYSVAL SYSVAL(QDATE) RTNVAL(&SYSDATE)/* Get local time from system: When this call is complete, &LILIAN will contain thenumber of days between today and Oct 14, 1582. */

CALLPRC PRC(CEELOCT) PARM(&LILIAN &JUNK1 &JUNK2 *OMIT)/* Subtracting 1 from &LILIAN will produce yesterday's date */

CHGVAR VAR(%BIN(&LILIAN)) VALUE(%BIN(&LILIAN) - 1)/* Convert lillian to yyymmdd date */

CALLPRC PRC(CEEDATE) PARM(&LILIAN 'YYYYMMDD' &WDATE *OMIT)

CHGVAR VAR(&YESTERDAY) VALUE(&WDATE)

Note: CEELOCT and CEEDATE are APIs that exist on the system; you do not needto create them. In essence, what the CL that is supplied does is:1) Use the CEELOCT API to convert the current date to lillian.2) Then you add or subtract the number of days you need from the lillian date.3) Then you use CEEDATE to convert the new lillian date back to the date formatthat you wish, in this case, we have used YYYYMMDD.Title of the DocumentInternal Use 1313. Subfile Data SortingSorting data is something RPG programs often need to do. If it's just a simple singlefield array you're sorting in order to use the much faster binary search possible with%Lookup, for example, then SORTA works well and is simple. But what if it is a morecomplex task like sorting the data in a subfile on a user-selected column? Surely youneed some more involved techniques, such as retrieving the data from the databaseagain using a different ORDER BY on an SQL SELECT statement or using adifferent logical file or you could use the qsort C function for sorting the arrayelements in the program. Something as simple as SORTA can't be used for that,right? Maybe so. The circumstances where this is effective are limited, for sure, but if yourrequirements fit, then using SORTA with a group field can be the simplest way andoften a faster alternative than other methods you may have tried.First of all, what's a group field? It's a field in a data structure that is broken down intosmaller subfields. For example, group field SflData might be made up of informationabout products (name, price, quantity) by using the Overlay keyword, such as:

D SflDS Ds Inz

D SflData Like(SflRecData) Dim(999)

D Name Like(ProdDS)D Overlay(SflData)D Price Like(SellPr)

D Overlay(SflData:*Next)D Qty Like(STOH)D Overlay(SflData:*Next)

The effect is similar to nested data structures, except without the requirement to usequalified names. (Likewise, there are many limitations on group fields because of thelack of name qualification.) One additional thing that's nice about group fieldscompared to nested DSs is that we can use SORTA against any of the subfields in agroup field array.So this means if I wanted to sort the data in the SflData array by product name, Icould do that with the following statement: SortA Name;. Much simpler than any ofthose other options I mentioned above! Of course, in nearly all cases, it would requirethe use of the built-in function %SubArr (substring array) because I'm not likely tohave filled up all 999 elements of SflData. Even so, the entire bit of logic toaccomplish sorting this subfile data in the sequence of any of the three fields couldbe as simple as:If SortByName;S

ortA %SubArr(Name:1:Count);ElseIf SortByQty;Title of the DocumentInternal Use 14SortA %SubArr(Qty:1:Count);ElseIf SortByPrice;SortA %SubArr(Price:1:Count);EndIf;This technique is very simple and in most cases quite a fast way to sort subfile data(or any other kind of repeating data). It does have significant limitations. For example,you can only sort on one subfield at a time. (Of course, you could group two subfieldstogether if they happen to be adjacent in the subfile record.) Also, you must be ableto retrieve and store all the data destined for the subfile into an array so that you cansort it all together. For some very large subfiles, that won't be practical. But for thoseoccasions where it works, it couldn't get much simpler.14. User Spaces:Because quite a few of IBM's system-supplied APIs use a user space to storeinformation, it is important to understand what they are and how they work.Information is stored in a user space as a "stream," similar to a stream file in the IFS.This is different than the physical files we are used to dealing with in our everydayapplications. Instead of each set of data being stored in a physical record, eachrecord is a subsection of a stream of data.When using a user space with an IBM-supplied API, data is normally sectioned byusing a data structure. This data structure defines a record of data in the stream inthe user space. For example, let's assume that our user space contains informationabout a customer. The first nine characters contain the customer number, the next 10contain the last name, and the last 10 contain the customer's first name. The datamay appear in a user space as such:000012457Stone Brad001248945Johnson Jerry045542144Anderson LouisIn order to separate out each record from this stream of data, we will use a datastructure. The data structure would appear as shown in the following RPG snippet:D CustomerInfo DSD CstNumber 9D CstLName 10D CstFName 10In order to parse the data from the user space, we need to move the data structure tothe beginning of each record. The data structure then "overlays" the data so we areable to easily access the information. In RPG, this is done with a pointer. TheCustomerInfo data structure as shown above would be defined based on a pointer.Title of the DocumentInternal Use 15We then move the position of that pointer to the beginning of each set of data inorder to populate the subfields of the data structure with each customer's information.When doing this, we will also have to know the size of each structure of data. Weknow that IBM APIs return a "header" that defines, among other things, the start ofthe data and the length of each entry in the set of data contained within the userspace.The following piece of RPG code defines a standard header that deal with IBM APIsthat store information in a user space:D GenHeader DS BASED (HeaderPtr)D OffsetHdr 117 120B 0D OffsetLst 125 128B 0D NumLstEnt 133 136B 0D EntrySize 137 140B 0As we can see, there are four subfields defined in this data structure. The first,OffsetHdr, is used to define the offset to the header information. Next is the fieldOffsetLst. This defines the offset to the start of the list information. The listinformation is the data that we are interested in parsing from the user space.Next, the NumLstEnt field is used to define the number of entries in the list. This is animportant number to know so that as we parse through the list we know when to stop.Finally, the EntrySize field is used to define the size of each entry. This is used sothat we know where to reposition our pointer on the next "record" of data in the userspace.We start reading by setting our basing pointer to the OffsetLst value, entering a loopthat executes NumLstEnt times, and, for each subsequent iteration of the loop,repositioning our pointer by adding the value stored in EntrySize to our currentpointer position.

Application performance in AS400 Programming

2009-09-21T22:53:00.000-07:00

Reduce Disk I/O: Disk I/O operations consume some CPU processing time and can cause waits on the disk while disk I/O for other jobs completes. So it is recommended to minimize unnecessary database operations within the program. For interactive transactions, consider 20 database operations as an excessive number.
Use Odd Length Packed Fields For Numeric Data: The AS/400 system does packed decimal arithmetic. Extra SLIC instructions and extra CPU time is required to handle the extra half-byte for even-length fields. Defining numeric fields as packed decimal or moving numeric fields into a packed field within the program before calculations improves CPU utilization for frequently used fields.
Decimal Data Performance: For ILE RPG/400 and ILE COBOL/400, use packed decimal data for best performance.Move Passed Parameters To Local Work Fields Before Use:
This reduces compiler-generated code that must validate the parameter at each use.
Also, if a zoned decimal value has been passed, a local packed, odd length work field is more efficient. If you must return the value of the parameter, copy the local work field into the external parameter before returning control.
Minimize The Number Of Different Parameters Passed: If possible, place all of the data to be passed between programs into a single parameter and use only this single parameter area between programs. This becomes more important as the frequency of calls and returns between programs increases during job run time.
Call Program Name Considerations (Non-ILE Support): For non-ILE program calls, use a constant or literal to name the program being called. This ensures the overhead for security and resolution of the system pointer to the called program incurred on the first call to that program is minimized on all subsequent calls within a run unit. This saving of an already resolved pointer to a previously called program support also applies to variables containing program names when either RPG or COBOL performs the dynamic call. When a program reference is made with a variable, the current value of a variable is compared to the value used on the previous program reference. If the value did not change, no resolve is done to the target program. If a variable name is used in languages other than RPG and COBOL even if the same program is called again and again, the overhead to establish the pointer is incurred for each call.
Use Large Multifunction Programs (Non-ILE Support): For non-ILE applications, a larger program doing several functions uses less resource than calls to several programs. Good structured programming techniques are vital to the integrity and maintainability of large programs.
Reduce The Number Of File Opens And Closes: Full Opens and Closes are expensive activities, not just in terms of CPU but disk activity as well. As much as possible, open the most frequently used files in a higher program invocation and use shared files (file SHARE(*YES) parameter) within the job. The possibility of using SHARE(*YES) occurs when the application uses small modular programs where the most frequently called programs perform specific functions, and returns to a primary or driver program. In many cases, the called programs repetitively use the same database files and display record formats.
In this scenario, the primary program should open the most frequently used database files with the maximum processing possibilities (read, write, and update) with SHARE(*YES) on the files. The secondary program open file operations connect with the existing Open Data Path (ODP) those results in significant CPU savings and response time improvement.
All of the display formats used by the primary and secondary programs can be placed into a single display file that can be opened by the primary program with SHARE(*YES). This speed up the file open by the secondary programs and can be used to permit display data to be retained across calls to several programs.
There are some things to be aware of when using shared database and display files. The secondary programs must be written with the understanding that database file record (cursor) positioning and workstation display formatting are treated by the system as if one program were using the file. For example, program PGM1 may have positioned the file SHARE to record 107 and call program PGM2. PGM2 uses shared file SHARE and causes the file to be positioned to record 23 and returns to program PGM1. PGM1 must not assume the file SHARE is still positioned at record 107. Note that if a shared file is processed sequentially for output and the file parameter specified SEQONLY(*YES), the file must be closed or the Force End of Data (FEOD) operation used for the last buffer of added records to be written to the disk.
Similarly, assume programs PGM1 and PGM2 both use record formats in file SHARED. Programs PGM1 and PGM2 must be written with the understanding of which formats may have been written to the display by the other program.
In the case of shared display files, placing more than 50 record formats in a single file can result in large Process Access Group (PAG) sizes that, in turn, result in degraded performance on storage constrained systems where many jobs are using the same display file.
If you are using the same ODP for read and update, consider using two ODPs, one for input and one for output, if you are reading the file sequentially. One ODP for input loses blocking, two allows input blocking.

Increase Code Sharing: Sharing a single copy of a program by all active users is built into the AS/400 system. (All AS/400 programs are re-entrant.) Code sharing can be increased by working to ensure that as few different programs as possible are used in the system. An example of this is varying the output display or report titles for different locations within the same organization. This can be done as opposed to creating separate copies of the same program, one for each location.

Group Routines By Frequency Of Use: In general, most programs are paged into main storage in 4KB blocks. Keeping active code segments together can sharply reduce paging requirements.

Make Infrequently Called Routines Subroutines: Dead code can increase program paging requirements. Moving such code into subroutines can help to keep active code together in a minimum of 4KB blocks.

Consider Program Observability:Using RMVOBS(*ALL) on the CHGPGM command, CHGSRVPGM command, and CHGMOD command can release a significant amount of disk space that indirectly affects performance. For ILE programs, you have additional RMVOBS options for reducing storage (*DBGDTA (remove debug data) and *CRTDTA (remove re-create data)).
You may also use the Compress Object (CPROBJ) command to compress observability through the PGMOPT parameter (CPROBJ(*OBS)).

Communicate Between Jobs With Data Areas And Data Queues: When there is a need to communicate between jobs, the application design must make a choice between using a database file, a message queue, a data area, or a data queue. Much less disk resource is required to update a data area or add an entry to a data queue than is needed to update a database record. The same type of savings is also realized when the receiving job reads the data.
Data queues are also more efficient than message queues, but message queues provide a wider range of function.

Consider The Size Of A Data Area: When defining an external data area, define it as large as needed but do not make it overly large for future use.

Consider Use Of Query And Data File Utility Facilities: Understand what the various AS/400 query functions and Data File Utility can produce. Consider using them instead of writing a new program when the application is to select a subset of records from one or more files and complex logic is required. Some functions are part of OS/400 such as Open Query File (OPNQRYF).
Look out for any generic searches and multiple format logical files because these types of queries can adversely affect performance. In general, writing a program that must individually process a small set of records is more efficient than using one of the query capabilities. Sorting to select the subset may be better yet. However, when there is a large number of records to process and selection logic is quite complex, using the query interfaces should be considered.
Comparison of user programming versus the various query facilities is beyond the scope of this publication.

Handling images on AS400

2009-04-20T01:43:00.000-07:00

Being asked if it is possible to handle images on the as400. Because the guy, who asked me was in insurance company and want to store the pictures of the vehicles that his clients bring to get insurance. It is possible to do it in a green-screen environment, for example in a subfile? Or must he use websphere/hats/webfacing at all cost?
For example he wants to search a vehicle by its id and show its picture on the as400 to avoid the personnel looking for the physical file in a big cabinet. His company has grown too big and are having problems organizing the data.
His take is that a 5250 terminal cannot handle graphics, but he has seen some solutions that let you click on a "link" in the green screen program and it loads internet explorer.

Storing them on the IFS and/or a network server will certainly work. If you are using iSeries Access for your 5250 emulation, you can choose to have the emulator recognize URL's and link directly to them.

Another option is iSeries Access for Web, which runs the 5250 in a browser window, and you can do all sort of html stuff. However, I tried this and wasn't happy with the performance of the 5250 screens.

5250 can not handle graphics but the As/400 can send a PC command down so to open a graphics file stored on the IFS or PC server. The location/file name can be stored within a field in the green screen record, then when the user requests to "view" the PC type graphics image the green screen app sends the PC a command using strpccmd to open the file from the specified location.

I do just that within a document management system tying vendor/customer/item docs (pdf,word, or any other type of PC doc) to the record. Then when the greeen screen requests to view it we send a PC command down to open it using the PC default viewer (adobe reader, word, image viewer, etc)

STRPCO PCTA(*NO)
STRPCCMD PCCMD(NOTEPAD.EXE)

and it runs.

When displaying the screen and user presses a function to display image or using a subfile selection value, then send the pc command down.

The PC has default application hanlders, IE: If the user double clicks on a file with a PDF extension then the pc opens it with adobe.

If I issue the following:

Strpco
strpccmd pccmd("c:\SomeDirectory\MyResume.doc")

The pc will use the default applications to open MyResume.doc, if it exists in the given directory.

Now assuming your are on a network what would happen if I issued:

strpccmd pccmd("\\Yourserver\YourShare\MyResume.doc"). assumptions are that the windows user has the rights.

Guess what it would open MyResume.doc from the given location.

Try this one:
strpccmd pccmd("\\YourAs400NetworknameorIP\AShare\Yourexpenses.xls")

The PC would use the default application to open xls file.

Code snippet:

PHP Code:

* Strpccmd pccmd("\\ToDirectory\CurrentPicName")
c Eval File = %Trim(ToDirectory) + %Trim(CurPicNam)
c Eval Comm = StrPcCmd + %Trim(ToDirectory) +
c %Trim(CurPicNam) + Txt6
c Eval ComLgt = %Len(Comm)
*
C CALL 'QCMDEXC'
C PARM COMM
C PARM ComLgt

I have even added rundll parameters to as to not show the dos box.
__________________

"File" is a field name and so is "Comm". Value of Comm (aka command) when completely assembled will be like:

'strpccmd pccmd(\\Server\Directory\SelectedPictureName.xxx)'

"Todirectory" is a variable which contains the server and share to search for the file.

CurPicNam is the variable which contains the file name associated with the selected record.

Txt6 is a constant "')" (single quote and right bracket)

the %Trim is RPGLE built in function.
__________________
To see how to connect via URL from 5250, try this

GO MAIN (IBM main menu)
11. Information Assistant
1. Where to look for info
Click on the IBM URL - it takes you right to the web site

If it doesn't work, you need to enable URL. In the emulator, click Edit / Preferences / Hotspots / Execute URL

This works with iSeries Access.

Image Handling on AS400

2009-04-20T01:40:00.000-07:00

When we exceute the following command to retrieve a document from the PC

Strpco
strpccmd pccmd("c:\SomeDirectory\MyResume.doc")

A dos screen also pops up....

This is due to the Pause(*NO)

strpccmd pccmd("c:\SomeDirectory\MyResume.doc") pause(*NO)

strpccmd pccmd("c:\Somedirectory\MyResume.doc"), this will always popup a dos box, whether it remains open depends on the pause(*no)

If you want no dos box at all try this:

strpccmd pccmd('rundll32 Shell32,ShellExec_RunDLL c:\Somedirectory\MyResume.doc') pause(*no)

The computers on German Windows and US Windows all open a DOS popup box whether the PAUSE(*NO) is used or not.

The difference is that when PAUSE(*NO) is specified the Client Access session is not input inhibited and one need not "Type any key to continue" to close the popup box, this then happens automatically.

You must first issue the command STRPCO.

It is possible to save images to a database. The proper way is to define a field as a Binary Large Object or BLOB then you can save any binary file you like to the database. However, I don’t know what an RPG program would make of it and I don’t know if it’s possible if you’re using DDS to create your tables.

This is not right. I’ve done some more testing and I can now access files on the local PC and they do not have to be shared.

strpcCMD (‘”/b g.txt”’)
strpcCMD (‘”E:/My Documents/bg.txt”’)

STRPCCMD works on Bosanova not on ClientAccess, few questions like this also….

The following command to execute:

C:\Program Files\Microsoft Office\Office10\Excel:\Lacey.xls

running this with STRPCCMD works great under Bosanova 5250, but crashes under every version of Client Access we have with this error
Message in the DOS window:
'C:\Program' is not recognized as an internal or external command, executable program or batch file.

Tried using DOS naming convention, like
C:Progra~1\Micros~1\Office~1\Excel Y:Lacey.xls but that does not work under Client Access either.

Now a question, how to make this work under Client Access?

Presumably it was not the following being requests, so I would suggest to try quoting the request; optionally quote the parameter separately, e.g. if it had embedded blanks in its name:
STRPCCMD PCCMD('"C:\Program Files\Microsoft Office\Office10\Excel" Y:\Lacey.xls') PAUSE(*NO)

If the problem persists, note that the executable is probably named excel.exe versus excel, so that might make a difference as well, since the request is not a /start/ invocation. The shell for a start would look for any executable with the name, irrespective of extension. But
processing for the PCCMD may cause the PC to look for the named file. Thus the request suggested would be:

STRPCCMD PCCMD('"C:\Program Files\Microsoft
Office\Office10\Excel.exe" Y:\Lacey.xls') PAUSE(*NO)

An example and reference link:

STRPCCMD PCCMD('"C:\Program Files\Internet +
Explorer\iexplore.exe" +
http://www.google.com')
PAUSE(*NO)

http://archive.midrange.com/midrange.../msg01088.html

Note that calling out excel and iexplore in the above PCCMD requests forces the named application to be used, instead of allowing the default file handler application to be invoked according to the file extension.
http://archive.midrange.com/midrange.../msg01086.html

Per above link, a way to affect the user's choice of URL handler follows in an example and reference link:

STRPCCMD PCCMD('rundll32 url.dll,FileProtocolHandler +
http://www.mywebpage.com?&userid=My+Name') +
PAUSE(*NO)

http://archive.midrange.com/midrange.../msg01079.html

or this example and reference link:

STRPCCMD PCCMD('rundll32 Shell32,ShellExec_RunDLL +
"mysheet.xls"') PAUSE(*NO)

http://archive.midrange.com/rpg400-l.../msg00304.html

LinkIt is an integration tool that can link legacy systems such as System i or Mainframe with any PC application.

LinkIt is designed to supply a quick and easy method of integrating information based on data displayed on emulation screens.

LinkIt Abilities

Scan and catalog documents

Retrieve and display archived documents

Export sub-file data into Excel

Generate Word documents

Integrate fully with Outlook

Integrate any PC application

Declare the BINARY Data Type Using DDS

2009-04-20T01:39:00.000-07:00

We've all heard by now that defining tables using DDS is becoming outdated and that developers need to use SQL in order to access the relatively new data types, including DATALINK and Large Objects (BLOB, CLOB, and DBCLOB).
I recently ran into a situation where I wanted to change a field in an existing table to use the new (as of V5R3) BINARY data type for encrypting credit card data. (Recall that the BINARY data type is similar to character data tagged with a CCSID of 65535. However, data in a BINARY column will never be translated whereas the character data tagged with CCSID 65535 may still be translated depending on the environment settings.) Because it is a "new" SQL data type, I figured the BINARY data type wasn't available in DDS.
However, because of issues with the customer's source management software, I still wanted to re-define the table using the existing DDS rather than change the table definition and related indexes to SQL. It was at this time that I did a little snooping and found that the BINARY data type is definable using DDS. The trick to getting this to work is by specifying a data type of '5' in the data type column of the field definition. Here is an example:

R DATAFILER
CHARDATA 200A TEXT('EQUIV TO SQL CHAR(200)')
BINARYDATA 2005 TEXT('EQUIV TO SQL BINARY(200)')

To create a VARBINARY field instead of BINARY, just add the VARLEN keyword to the field definition.
The main stumbling block here is that this information is documented in the DDS manual but is not documented in the SEU help on V5R3 or V5R4. After checking the SEU help I almost gave up! I constantly need to remind myself to check multiple sources before giving up on a problem.
Incidentally, as far as converting an existing field, a character field can be converted to a binary field using the CHGPF command as long as the character field is tagged with CCSID 65535. If the character field is not tagged with CCSID 65535, you'll have to change the table definition twice: once to change the CCSID of the column to 65535 and then again in order to change the field type from character to binary. In case you're like me and assumed that BINARY isn't definable with DDS, remember to use data type '5'. While it is helpful to know SQL for using the new data types, for legacy files it is handy to be able to use binary columns in existing DDS definitions.

Convert PF to CSV file

2009-04-16T04:16:00.000-07:00

Convert PF to CSV file
CL Program:
CRTPF CSVFILE RCDLEN(whatever record length you need)
CPYTOIMPF FROMFILE(LBIFIL/ARACUST) + TOSTMF('/myfolder/myfile.csv') STMFCODPAG(*PCASCII) + RCDDLM(*CRLF)
OVRDBF INPUT MYLIB/MYSRC MBR(MYSCRIPT) SHARE(*YES)
OVRDBF OUTPUT MYLIB/MYSRC MBR(MYLOG) SHARE(*YES)
FTP XXX.XXX.XXX.XXX
DLTOVR *ALL

Create the empty source members for MYLIB/MYSRC

Wrklnk myfolder

ftp script

userprofile password
put csvfile targetfile.csv
quit

FTP your.ip.addr.ess
username password
NAMEFMT 1
LCD yourfolder/path/to/object
CD to/remote/target/folder
PUT filename.CSV
QUIT

Iseries To .CSV
Selected field convert to CSV

This utility will allow you to select specific fields for an Iseries table and convert the data to csv. It has a few examples of API usage. This program takes selections from a display panel and writes them to a dataqueue. It then submits itself to batch and receives the selected fields from the dataqueue.
It also creates a source physical file, adds a member, writes field data to the source then complies itself.
There may or may not be a good use for this example but it can be a building point for many other applications.

API’s used

QUSROBJD - Retrieve Object description
QUSLFLD - List fields
QUSCRTUS - Create userspace
QSNDDTAQ - Send data to a dataqueue

Display File
---------------------
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A ERRSFL
A CF03(03 'Exit')
A CF12(12 'Return')
A CF05(05 'Refresh')
A*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
A* SCRN01 : Criteria Screen
A*-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-
A R SCRN01
A OVERLAY
A CF04(04 'Prompt')
A RTNCSRLOC(&#REC &#FLD)
A #REC 10A H
A #FLD 10A H
A 1 2DATE
A EDTWRD('0 / / ')
A COLOR(BLU)
A 2 2TIME
A COLOR(BLU)
A 1 70USER
A COLOR(BLU)
A 2 70SYSNAME
A COLOR(BLU)
A C1CNAM 22A O 1 30
A C1DOW 3A O 1 11COLOR(BLU)
A 2 31'Convert iSeries File'
A C1PGMN 10A O 3 70
A 5 2'Type options, press Enter.'
A COLOR(BLU)
A 7 2'Input File:'
A 8 4'Library . . . . . . .'
A C1FLIB 10A B 8 27
A 30 DSPATR(PC)
A 30 DSPATR(RI)
A 9 4'File . . . . . . . .'
A C1FNAM 10A B 9 27
A 31 DSPATR(PC)
A 31 DSPATR(RI)
A 11 2'Output File:'
A 12 4'IFS File . . . . . .'
A C1FLDR 30A B 12 37
A 32 DSPATR(PC)
A 32 DSPATR(RI)
A CHECK(LC)
A 13 4'Extension Type . . .'
A C1FTYP 1A B 13 27
A 33 DSPATR(PC)
A 33 DSPATR(RI)
A 23 2'F3=Exit'
A COLOR(BLU)
A 23 22'F12=Return'
A COLOR(BLU)
A 3 2'SCRN01'
A 12 27'/code400/'
A COLOR(WHT)
A 23 11'F4=Prompt'
A COLOR(BLU)
A 13 31'C=CSV'
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* MSGSFL : Message Subfile
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
A R MSGSFL SFL
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A PGMQ SFLPGMQ(10)
*
A R MSGCTL SFLCTL(MSGSFL)
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N03 SFLEND
A SFLSIZ(0002)
A SFLPAG(0001)
A PGMQ SFLPGMQ(10)

RPG program

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* Program Name:
* Description : Convert iSeries File to CSV format.
* Written By :
* Written On :
*
* Modification:
* ~~~~~~~~~~~~
* Date Project Pgmr Description
* ~~~~~~~~ ~~~~~~~ ~~~~ ~~~~~~~~~~~
* Must create your own message file
* Must change worklibrary inz value to your library name
*
*
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* Display File
* ~~~~~~~~~~~~
FCVTPF01D cf e workstn usropn
*
* Work File
* ~~~~~~~~~
FCVTSRCPF uf a e k disk rename(CVTSRCPF : CVTPFR)
F usropn
F prefix(x)
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
* Program Information
* ~~~~~~~~~~~~~~~~~~~
D PgmInfo sds
D @PgmName 1 10
D @Parms 37 39 0
D @MsgID 40 46
D @JobName 244 253
D @UserId 254 263
D @JobNbr 264 269 0
*
* Message SFL Information
* ~~~~~~~~~~~~~~~~~~~~~~~
D ds inz
D STKCNT 1 4B 0
D DTALEN 5 8B 0
D ERRCOD 9 12B 0
*
* Subprocedure(s)
* ~~~~~~~~~~~~~~~
D $GetDOW pr 3a
D InpDate d value
D $RtvMbrd pr 1a
D MemberName 20a value
D $GetJobType pr 1a
D $ReceiveDataQ pr 1024a
D DataQ 20a value
*
* Field Definitions
* ~~~~~~~~~~~~~~~~~
D @Scrn1 s 1 inz('Y')
*
D MemberError s 1 inz('N')
D ScreenError s 1 inz('N')
*
D CorpName s 30 inz(*blanks)
D JobType s 1 inz(*blanks)
*
D InputLib s 10 inz(*blanks)
D InputName s 10 inz(*blanks)
D DataQName s 10 inz(*blanks)
D DataQLib s 10 inz(*blanks)
D DataQ s 20 inz(*blanks)
D InputFile s 20 inz(*blanks)
D IFSFileName s 50 inz(*blanks)
D FieldName s 10 inz(*blanks)
D FieldDesc s 50 inz(*blanks)
D DataQData s 1024 inz(*blanks)
D IFSFolder s 100 inz(*blanks)
D IFSFolders s 100 inz(*blanks)
D WorkLibrary s 10 inz('SOMELIB')
*
D pInputLib s 10
D pInputName s 10
D pFolders s 30
D pIFSFileType s 1
D pDataQLib s 10
D pDataQName s 10
D IFSFileType s 1 inz(*blanks)
*
D CmdString s 256 inz(*blanks)
D CmdLength s 15 5 inz(0)
*
D SQLSelect s 10000 inz(*blanks)
D SQLStmt s 10000 inz(*blanks)
D SQLResult s 10000 inz(*blanks)
*
D end s 5 0 inz(0)
D pos s 5 0 inz(0)
D str s 5 0 inz(0)
*
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* M A I N L I N E
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=
*
C eval PgmQ = @PgmName
C eval DtaLen = 60
*
C eval JobType = $GetJobType
C if JobType = 'I' and %parms = 0
C exsr $CreateDataQ
C exsr $DispScrn01
C else
C exsr $ConvertPF
C exsr $DeleteDataQ
C endif
*
C eval *inlr = *on
C return
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
* $DispScrn01 - Display Screen 1
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C $DispScrn01 begsr
*
C if not %open(CVTPF01D)
C open CVTPF01D
C endif
*
C exsr $LoadScrn01
C exsr $ClrMsg
*
C eval @Scrn1 = 'Y'
C dow @Scrn1 = 'Y'
*
C write MSGCTL 99
C exfmt SCRN01
*
C exsr $ClrMsg
*
C select
*
* F3=Exit
*
C when *in03
C eval @Scrn1 = 'N'
*
* F4=Prompt
*
C when *in04
C exsr $Process01
*
* F5=Refresh
*
C when *in05
C exsr $LoadScrn01
*
* F12=Return
*
C when *in12
C eval @Scrn1 = 'N'
*
C other
C exsr $Process01
C endsl
*
C enddo
*
C if %open(CVTPF01D)
C close CVTPF01D
C endif
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-==-=-=-=-=-=-==-
* $Process01 - Process Screen 1
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=-=-=-==-
C $Process01 begsr
*
C exsr $Validation01
*
C if ScreenError = 'N'
*
C eval InputLib = C1FLIB
C eval InputName = C1FNAM
*
C call 'SPTPFFDR'
C parm InputLib
C parm InputName
C parm DataQLib
C parm DataQName
*
C eval @Scrn1 = 'N'
C eval IFSFolders = %trim(C1FLDR)
C select
C when C1FTYP = 'C'
C eval pos = %scan('.csv' : %trim(IFSFolders))
C if pos <= 0
C eval IFSFolders = %trim(IFSFolders) +
C %trim('.csv')
C endif
C endsl
*
* Submit Job
*
C eval Cmdstring = %trim('SBMJOB') +
C %trim('~CMD(CALL PGM(CVTPF01R)') +
C %trim('~PARM(') + %trim('''') +
C %trim(InputLib) + %trim('''') +
C %trim('~') + %trim('''') +
C %trim(InputName) + %trim('''') +
C %trim('~') + %trim('''') +
C %trim(C1FTYP) + %trim('''') +
C %trim('~') + %trim('''') +
C %trim(DataQLib) + %trim('''') +
C %trim('~') + %trim('''') +
C %trim(DataQName) + %trim('''') +
C %trim('~') + %trim('''') +
C %trim(IFSFolders) +
C %trim('''') + %trim('))')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C endif
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-
* $LoadScrn01 - Load Screen 1
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-==-=-=-=-=-=-==-
C $LoadScrn01 begsr
*
C reset SCRN01
*
C eval C1PGMN = @PgmName
*
C eval C1CNAM = %trim(CorpName)
C eval C1DOW = $GetDOW(%date())
*
C eval C1FTYP = 'C'
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-==-
* $Validation01 - Validate Screen 1
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--==-=-=-=-=-=-==-
C $Validation01 begsr
*
* Reset Validation Variables
*
C eval *in30 = *off
C eval *in31 = *off
C eval *in32 = *off
C eval *in33 = *off
C eval ScreenError = 'N'
*
* Validation
*
C if C1FLIB = *blanks
C eval *in30 = *on
C eval ScreenError = 'Y'
C eval MSGDTA = *blanks
C eval MSGID = 'ROL0056'
C exsr $SndMsg
C endif
*
C if C1FNAM = *blanks
C eval *in31 = *on
C eval ScreenError = 'Y'
C eval MSGDTA = *blanks
C eval MSGID = 'ROL0057'
C exsr $SndMsg
C endif
*
C eval InputFile = C1FNAM + C1FLIB
C eval MemberError = $RtvMbrD(InputFile)
C if MemberError = 'Y'
C eval *in30 = *on
C eval *in31 = *on
C eval ScreenError = 'Y'
C eval MSGDTA = %trim(C1FNAM)+' in '+%trim(C1FLIB)
C eval MSGID = 'ROL0055'
C exsr $SndMsg
C endif
*
C eval IFSFolders = *blanks
C eval str = 1
C eval pos = %scan('/' : %trim(C1FLDR))
C dow pos > 0
C eval end = str
C if pos > 1
C eval end = pos - 1
C endif
C eval IFSFolders = %trim(IFSFolders) +
C %subst(%trim(C1FLDR) : str : end)
C eval str = end + 2
C eval pos = %scan('/' : %trim(C1FLDR) : str)
C enddo
*
C if C1FLDR <> *blanks and str > 0 and pos = 0
C eval IFSFileName = %subst(%trim(C1FLDR) : str)
C endif
C select
C when IFSFileName = *blanks
C eval *in32 = *on
C eval ScreenError = 'Y'
C eval MSGDTA = *blanks
C eval MSGID = 'ROL0051'
C exsr $SndMsg
C when IFSFileName <> *blanks
C eval pos = %scan('.' : %trim(IFSFileName))
C if pos > 0
C eval pos = %scan('.csv' : %trim(C1FLDR))
C if pos <= 0
C eval *in32 = *on
C eval ScreenError = 'Y'
C eval MSGDTA = *blanks
C eval MSGID = 'ROL0051'
C exsr $SndMsg
C endif
C endif
C endsl
*
C if C1FTYP <> 'C'
C eval *in33 = *on
C eval ScreenError = 'Y'
C eval MSGDTA = *blanks
C eval MSGID = 'ROL0009'
C exsr $SndMsg
C endif
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-
* $CreateFolder - Create IFS Directory.
* MD DIR('/shippingdocument/test') DTAAUT(*RWX) OBJAUT(*ALL).
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $CreateFolder begsr
*
C eval IFSFolder = '/' + %trim(WorkLibrary)
C exsr $CreateFldCmd
C eval IFSFolder = '/' + %trim(WorkLibrary) + '/'
*
C eval str = 1
C eval pos = %scan('/' : %trim(IFSFolders))
C dow pos > 0
C eval end = str
C if pos > 1
C eval end = pos - 1
C endif
C eval IFSFolder = %trim(IFSFolder) +
C %subst(%trim(IFSFolders) : str : end)
C exsr $CreateFldCmd
C eval str = end + 2
C eval pos = %scan('/' : %trim(IFSFolders) : str)
C enddo
*
C eval IFSFolders = '/' + %trim(WorkLibrary) + '/'+
C %trim(IFSFolders)
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=-=-=-==-
* $CreateFldCmd - Create Directory Command
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C $CreateFldCmd begsr
*
C eval CmdString = %trim('MD~') +
C %trim('~DIR(''') + %trim(IFSFolder) +
C %trim(''')') +
C %trim('~DTAAUT(*RWX)') +
C %trim('~OBJAUT(*ALL)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-==-=-=-=-=-=-==-
* $CloseTempPF
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-==-
C $CloseTempPF begsr
*
* Delete Create Physical File
*
C eval CmdString = %trim('~DLTF') +
C %trim('~FILE(QTEMP/CVTSRCPFF)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-
* $ConvertPF - Convert Physical File
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C $ConvertPF begsr
*
C eval DataQLib = pDataQLib
C eval DataQName = pDataQName
C eval InputLib = pInputLib
C eval InputName = pInputName
C eval IFSFolders = pFolders
C eval IFSFileType = pIFSFileType
C eval SQLSelect = *blanks
*
C exsr $CreateFolder
C exsr $CreateTempPF
*
C select
C when IFSFileType = 'C'
C exsr $CreateCSVF
C endsl
*
C exsr $CloseTempPF
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-
* Create/Copy Temporary Physical File
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $CreateTempPF begsr
*
* Create Source Physical File
*
C eval CmdString = %trim('~CRTSRCPF') +
C %trim('~FILE(QTEMP/CVTSRCPF)') +
C %trim('~RCDLEN(92)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
* Add Physical File Member
*
C eval CmdString = %trim('~ADDPFM') +
C %trim('~FILE(QTEMP/CVTSRCPF)') +
C %trim('~MBR(CVTSRCPFF)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
* Clear Physical File Member
*
C eval CmdString = %trim('~CLRPFM') +
C %trim('~FILE(QTEMP/CVTSRCPF)') +
C %trim('~MBR(CVTSRCPFF)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
* Override
*
C eval CmdString = %trim('~OVRDBF') +
C %trim('~FILE(CVTSRCPF)') +
C %trim('~TOFILE(QTEMP/CVTSRCPF)') +
C %trim('~MBR(CVTSRCPFF)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
* Open Source Physical File
*
C if not %open(CVTSRCPF)
C open CVTSRCPF
C endif
*
* Get Data from Data Queue and Write to Source Physical File
*
C eval DataQ = DataQLib + DataQName
*
C eval DataQData = $ReceiveDataQ(DataQ)
C if DataQData <> *blanks
C reset xSRCDTA
C eval %subst(xSRCDTA : 6) = 'A'
C eval %subst(xSRCDTA : 17) = 'R'
C eval %subst(xSRCDTA : 19) = 'RECNAMR'
C eval %subst(xSRCDTA : 45) =
C %trim('TEXT(''Temporary PF'')')
C write CVTPFR
*
C dow DataQData <> *blanks
C exsr $WriteSrcPF
C eval DataQData = $ReceiveDataQ(DataQ)
C enddo
*
* Close Source Physical File
*
C if %open(CVTSRCPF)
C close CVTSRCPF
C endif
*
* Create Physical File
*
C eval CmdString = %trim('CRTPF') +
C %trim('~FILE(QTEMP/CVTSRCPFF)') +
C %trim('~SRCFILE(QTEMP/CVTSRCPF)') +
C %trim('~SRCMBR(CVTSRCPFF)') +
C %trim('~OPTION(*NOSRC *NOLIST)') +
C %trim('~SIZE(*NOMAX)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
* Copy Selected Physical File to Created Physical File P)
*
C eval CmdString = %trim('CPYF') +
C %trim('~FROMFILE(') +
C %trim(InputLib) +
C %trim('/') +
C %trim(InputName) +
C %trim(')') +
C %trim('~TOFILE(QTEMP/CVTSRCPFF)') +
C %trim('~MBROPT(*ADD)') +
C %trim('~FMTOPT(*DROP)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C else
*
C eval CmdString = %trim('CPYF') +
C %trim('~FROMFILE(') +
C %trim(InputLib) +
C %trim('/') +
C %trim(InputName) +
C %trim(')') +
C %trim('~TOFILE(QTEMP/CVTSRCPFF)') +
C %trim('~MBROPT(*ADD)') +
C %trim('~CRTFILE(*YES)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C endif
*
* Delete Source Physical File
*
C eval CmdString = %trim('~DLTF') +
C %trim('~FILE(QTEMP/CVTSRCPF)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* Create CSV File
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $CreateCSVF begsr
*
* CPYTOIMPF FROMFILE(&FROMLIB/&FROMFILE) TOSTMF(&TOFILE) +
* MBROPT(*ADD) STMFCODPAG(*PCASCII) +
* RCDDLM(*CRLF)
*
C eval CmdString = %trim('CPYTOIMPF') +
C %trim('~FROMFILE(QTEMP/CVTSRCPFF)') +
C %trim('~TOSTMF(''') + %trim(IFSFolders) +
C %trim(''')') +
C %trim('~MBROPT(*REPLACE)') +
C %trim('~STMFCODPAG(*PCASCII)') +
C %trim('~RCDDLM(*CRLF)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* Write Record to Source Physical File
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $WriteSrcPF begsr
*
C reset xSRCDTA
C eval %subst(xSRCDTA:6) = 'A'
C eval %subst(xSRCDTA:19) = %subst(DataQData:1:10)
C eval %subst(xSRCDTA:30) = %subst(DataQData:11:5)
C eval %subst(xSRCDTA:35) = %subst(DataQData:16:1)
C eval %subst(xSRCDTA:36) = %subst(DataQData:17:2)
C eval %subst(xSRCDTA:45) = %trim('COLHDG(''') +
C %trim(%subst(DataQData:19:20)) +
C %trim(''')')
C write CVTPFR
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=
* Create Data Queue
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=
C $CreateDataQ begsr
*
C eval DataQLib = %trim(WorkLibrary)
C eval DataQName = %trim('DTAQ') +
C %trim(%char(%time() : *iso0))
*
C eval CmdString = %trim('CRTDTAQ') +
C %trim('~DTAQ(') + %trim(DataQLib) +
C %trim('/') + %trim(DataQName) + %trim(')') +
C %trim('~TYPE(*STD)') +
C %trim('~MAXLEN(1024)') +
C %trim('~SIZE(*MAX16MB)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-==-=-=-=-=-=-==-
* Delete Data Queue
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C $DeleteDataQ begsr
*
C eval CmdString = %trim('DLTDTAQ') +
C %trim('~DTAQ(') + %trim(DataQLib) +
C %trim('/') + %trim(DataQName) + %trim(')')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
* $SndMsg - Send a message to the message subfile
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C $SndMsg begsr
*****
C***** call 'QMHSNDPM'
C***** parm MSGID
C***** parm MSGF
C***** parm MSGDTA
C***** parm DTALEN
C***** parm MSGTYP
C***** parm PGMQ
C***** parm STKCNT
C***** parm MSGKEY
C***** parm ERRCOD
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
* $ClrMsg - clear the messages from the screen
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-==-=-=-=-=-=-==-
C $ClrMsg begsr
*
C call 'QMHRMVPM'
C parm PGMQ
C parm STKCNT
C parm MSGKY
C parm MSGRMV
C parm ERRCOD
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* Initialization
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C *inzsr begsr
*
C *entry plist
C parm pInputLib
C parm pInputName
C parm pIFSFileType
C parm pDataQLib
C parm pDataQName
C parm pFolders
*
* Initialize the message subfile fields
*
C movel 'MSGF ' MSGF 20
C movel '*LIBL' MSGLIB 10
C move 'MSGLIB' MSGF
C move *blanks MSGKY 04
C move *blanks MSGDTA 80
C movel '*DIAG' MSGTYP 10
C movel '*ALL' MSGRMV 10
C movel *blanks MSGID 07
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-===-=-=-=-=-=-=-=-=-
* $GetDOW - Get Day of Week
* 1=Sun, 2=Mon, etc.
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-====-=-=-=-=-=-=-=-=-
P$GetDOW b
D $GetDOW pi 3a
D InpDate d value
*
D DayOfWk s 11p 0
D AnySundayDate s d datfmt(*iso)
D inz(d'1998-08-01')
D WrkDate s d datfmt(*iso)
D dowDesc s 3 inz(*blanks)
*
C eval WrkDate = InpDate
C eval DayOfWk = %diff(InpDate:AnySundayDate:*days)
C div 7 DayOfWk
C mvr DayOfWk
*
C if DayOfWk <= 0
C eval DayOfWk = (DayOfWk + 7)
C endif
*
C select
C when DayOfWk = 1
C eval dowDesc = 'Sun'
C when DayOfWk = 2
C eval dowDesc = 'Mon'
C when DayOfWk = 3
C eval dowDesc = 'Tue'
C when DayOfWk = 4
C eval dowDesc = 'Wed'
C when DayOfWk = 5
C eval dowDesc = 'Thu'
C when DayOfWk = 6
C eval dowDesc = 'Fri'
C when DayOfWk = 7
C eval dowDesc = 'Sat'
C endsl
*
C return dowDesc
*
P$GetDOW e
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-===-=-=-=-=-=-=-=-=-
* $RtvMbrD - Retreive Member Description
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--===-=-=-=-=-=-=-=-=-
P$RtvMbrD b
D $RtvMbrD pi 1a
D InputFile 20a value
*
*
* API QUSRMBRD (Retreive Member Description)
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
D nBufLen s 10i 0
D ErrorCode s 32766A
*
* QUSRMBRD API return Struture
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
D Mbrd0100 ds inz
D nBytesRtn 10i 0
D nBytesAval 10i 0
D FileName 10a
D LibName 10a
D MbrName 10a
D FileAttr 10a
D SrcType 10a
D dtCrtDate 13a
D dtLstChg 13a
D MbrText 50a
D bIsSource 1a
D RmtFile 1a
D LglPhyFile 1a
D ODPSharing 1a
D filler2 2a
D RecCount 10i 0
D DltRecCnt 10i 0
D DataSpaceSz 10i 0
D AccpthSz 10i 0
D NbrBasedOnMbr 10i 0
*
* Input Parameters for the QUSRMBRD API
* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Format to be returned
*
D Fmt s 8a inz('MBRD0200')
*
* Source File Name
*
D MemberName s 10a inz('*FIRST')
*
* ignore overrides (0=Ignore, 1 = Apply)
*
D bOvr s 1a inz('0')
*
D MemberError s 1a inz('N')
*
C eval nBufLen = %size(MbrD0100)
*
C call(e) 'QUSRMBRD'
C parm MbrD0100
C parm nBufLen
C parm Fmt
C parm InputFile
C parm MemberName
C parm bOvr
C parm ErrorCode
*
C if %error or (FileAttr <> 'PF' and
C FileAttr <> 'LF')
C eval MemberError = 'Y'
C endif
*
C return MemberError
*
P$RtvMbrD e
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-===-=-=-=-=-=-=-=-=-
* $GetJobType - Get Job Type (I=Interactive, B=Batch)
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-===-=-=-=-=-=-=-=-=-
P$GetJobType b
D $GetJobType pi 1a
*
D RcvVar s 32766A
D RcvVarLen s 10i 0
D Format s 8A
D QualJob s 26A
D InternJob s 16A
D ErrorCode s 32766A
*
D dsJob ds
D dsJobBytesRtn 10I 0
D dsJobBytesAvl 10I 0
D dsJobName 10A
D dsJobUser 10A
D dsJobNumber 6A
D dsJobIntern 16A
D dsJobStatus 10A
D dsJobType 1A
D dsJobSubtype 1A
D dsJobReserv1 2A
D dsJobRunPty 10I 0
D dsJobTimeSlc 10I 0
D dsJobDftWait 10I 0
D dsJobPurge 10A
*
C eval RcvVarLen = %Size(DsJob)
*
C call 'QUSRJOBI'
C parm DsJob
C parm RcvVarLen
C parm 'JOBI0100' Format
C parm '*' QualJob
C parm *blanks InternJob
*
C return dsJobType
*
P$GetJobType e
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* Receive Data Queue
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=
P$ReceiveDataQ b
D $ReceiveDataQ pi 1024a
D DataQ 20a value
*
* DataQName = Name of Data Queue
* DataQLength = Length of Data Queue
* DataQWait = Time to wait for entry (-1 = forever)
* DataQData = Area to Store Retrived Data
*
D DataQLib s 10 inz(*blanks)
D DataQName s 10 inz(*blanks)
D DataQLength s 5 0 inz(1024)
D DataQWait s 5 0 inz(0)
D DataQData s 1024 inz(*blanks)
D ReturnCode s 1
*
C eval DataQLib = %subst(DataQ : 1 : 10)
C eval DataQName = %subst(DataQ : 11 : 10)
*
C call 'QRCVDTAQ' 99
C parm DataQName
C parm DataQlib
C parm DataQLength
C parm DataQData
C parm DataQWait
*
C if not %error
C return DataQData
C endif
*
P$ReceiveDataQ e
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=

Display File

A*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
A* Select Physical File Fields
A* ~~~~~~~~~~~~~~~~~~~~~~~~~~~
A* SUB01 - Subfile
A* SUB01CTL - Subfile Control
A* FORMAT1 - Window Format fo SUB01
A*
A*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A ERRSFL
A CF03(03 'Exit')
A CF12(12 'Return')
A*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
A* SUB01 - Subfile
A*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
A R SUB01 SFL
A*%%TS
A S1FLD 10A O 8 7
A S1DESC 30A O 8 18
A S1OPTN 1A B 8 4
A H1TYPE 1 H
A H1LEN 5 0H
A H1DEC 2 0H
A*
A R SUB01CTL SFLCTL(SUB01)
A*%%TS SD 20030926 112141 REYNOOM REL-V5R1M0 5722-WDS
A RTNCSRLOC(&#REC &#FLD)
A OVERLAY
A SFLCSRRRN(&WHERE)
A 50 SFLDSP
A 51 SFLDSPCTL
A 52 SFLCLR
A 89 SFLEND(*MORE)
A SFLSIZ(0011)
A SFLPAG(0010)
A WINDOW(FMT1)
A SCRRN 4S 0H SFLRCDNBR
A #REC 10A H
A #FLD 10A H
A WHERE 5S 0H
A 1 18'Fields Selection'
A DSPATR(HI)
A 7 3'Opt'
A DSPATR(HI)
A DSPATR(UL)
A 7 7'Field '
A DSPATR(HI)
A DSPATR(UL)
A 7 18'Description '
A DSPATR(HI)
A DSPATR(UL)
A C1FILE 21A O 5 9COLOR(WHT)
A 3 2'Type options, press Enter.'
A COLOR(BLU)
A 5 3'File'
A*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
A* FMT1
A*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
A R FMT1
A*%%TS SD 20030926 112141 REYNOOM REL-V5R1M0 5722-WDS
A OVERLAY
A WINDOW(*DFT 20 49)
A WDWBORDER((*COLOR BLU))
A 19 2'F3=Exit'
A COLOR(BLU)
A 19 11'F12=Return'
A COLOR(BLU)
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=
* DUMMY: Dummy Record
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=
A R DUMMY
A*%%TS
A ASSUME
A 1 3' '

Select Fields from Physical file – RPG Program

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
H dftactgrp(*no) option(*srcstmt : *nodebugio)
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* Program Name: SLTPFFDR
* Description : Select Fields from Specific Physical File.
* Written By :
* Written On :
*

* Display File
* ~~~~~~~~~~~~
FSPTPFFDD CF E WORKSTN
F SFILE(SUB01 : RRn)
*
*-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
*
* Field Definitions
* ~~~~~~~~~~~~~~~~~
D AR S 1 DIM(9999)
D AKEY S 10 DIM(9999)
D AK# S 2 0 DIM(9999)
D J S 2 0
D JJ S 2 0
D I S 7 0
D S S 7 0
D RelRecNbr S 4 0
D XX S 7 0
D I1 S 1
D I2 S 2
D pDataQLib s 10
D pDataQName s 10
D pFileLib S 20
D FileLib s 20 inz(*blanks)
D pInputLib s 10
D pInputName s 10
D InputLib s 10 inz(*blanks)
D InputName s 10 inz(*blanks)
D InFormat S 10
D EntryFmt S 10 inz('*FIRST')
D SFLRcdCnt S 04 0
D RRn S 04 0
D SavRRn S 04 0
D NbrofField S 04 0
D OutField S 10
D OutSize S 15 5
D OutDecimal S 01
D OutType2 S 01
D @Scrn1 S 01
*
D GENDS DS
D OffsetHdr 117 120B 0
D SizeHeader 121 124B 0
D OffsetList 125 128B 0
D NbrInList 133 136B 0
D SizeEntry 137 140B 0
D HeaderDs DS
D OutFileNam 1 10
D OutLibName 11 20
D OutType 21 25
D OutFormat 31 40
D RecordLen 41 44B 0
D InputDs DS
D UserSpace 1 20
D SpaceName 1 10
D SpaceLib 11 20
D InpFileLib 29 48
D InpFFilNam 29 38
D InpFFilLib 39 48
D InpRcdFmt 49 58
D ListDs DS
D FieldName 1 10
D FieldType 11 11
D BufferOut 13 16B 0
D FieldLen 21 24B 0
D Digits 25 28B 0
D Decimals 29 32B 0
D FieldDesc 33 82
D ErrorDs DS INZ
D BytesPrv 1 4B 0
D BytesAvl 5 8B 0
D MessageId 9 15
D ERR### 16 16
D MessageDta 17 116
D ReceiveVr2 S 100
D ReceiveVar DS 4096
D NbrOfFmts 62 63B 0
D DBFileOff 317 320B 0
D FindSelDs DS 150
D NbrOfKeys 117 118B 0
D KeyOffset 136 139B 0
D KeyDataDs DS
D DependKey 1 10
D DS
D StartPosit 1 4B 0
D StartLen 5 8B 0
D SpaceLen 9 12B 0
D ReceiveLen 13 16B 0
D MessageKey 17 20B 0
D MsgDtaLen 21 24B 0
D MsgQueNbr 25 28B 0
DGenSpcPtr *
DLstSpcPtr *
DHdrPtr *
*
* API
* ~~~
* Send Data Queue API
* ~~~~~~~~~~~~~~~~~~~
* DataQName = Name of Data Queue
* DataQLength = Length of Data Queue
* DataQData = Data to be placed onto DataQ
*
D DataQName s 10 inz('SAVFLDDTAQ')
D DataQLib s 10 inz('CODE400')
D DataQLength s 5 0 inz(512)
D DataQData s 1024 inz(*blanks)
*
D ReturnCode s 1
*
* Fields Definition
* ~~~~~~~~~~~~~~~~~
D CmdString s 500 inz(*blanks)
D CmdLength s 15 5 inz(0)
*
D LengthField s 5 0 inz(0)
D DecimalField s 2 0 inz(0)
*
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* M A I N L I N E
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
C eval SpaceName = 'FFDSPC'
C eval SpaceLib = 'QTEMP'
C eval InpFFilNam = InputName
C eval InpFFilLib = InputLib
C eval C1FILE = %trim(InpFFilLib) + '/' +
C %trim(InpFFilNam)
*
* Create the user space
*
C call 'QUSCRTUS'
C parm UserSpace
C parm *BLANKS SpaceAttr 10
C parm 4096 SpaceLen
C parm *BLANKS Spaceval 1
C parm '*CHANGE' SpaceAuth 10
C parm *BLANKS SpaceText 50
C parm '*YES' SpaceRepl 10
C parm ErrorDs
*
* Attemp to retrieve object description
*
C call 'QUSROBJD' 99
C parm ReceiveVr2
C parm 100 ReceiveLen
C parm 'OBJD0100' FileFormat 8
C parm FileLib
C parm '*FILE' ObjectType 10
C parm ErrorDs
*
C if *in99 = *off
*
* List fields to user space
*
C call 'QUSLFLD'
C parm UserSpace
C parm 'FLDL0100' ListFormat 8
C parm InpFileLib
C parm EntryFmt InpRcdFmt
C parm '1' OverRide 1
C eval StartPosit = 1
C eval StartLen = 140
*
C call 'QUSRTVUS'
C parm UserSpace
C parm StartPosit
C parm StartLen
C parm GENDS
C eval StartPosit = OffsetHdr + 1
C eval StartLen = SizeHeader
*
C call 'QUSRTVUS'
C parm UserSpace
C parm StartPosit
C parm StartLen
C parm HeaderDs
*
C eval StartPosit = OffsetList + 1
C eval StartLen = SizeEntry
C eval SpaceName = 'FFDSPC'
C eval SpaceLib = 'QTEMP'
*
* Load Subfile
*
C do NbrInList NbrOfField
C call 'QUSRTVUS'
C parm UserSpace
C parm StartPosit
C parm StartLen
C parm ListDs
C exsr $LoadSFL
C eval StartPosit = StartPosit + SizeEntry
C enddo
*
* Display Subfile
*
C exsr $DispSFL
*
C endif
*
C eval *inlr = *on
C return
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* $DispSFL - Display Fields to screen
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C $DispSFL begsr
*
C eval @Scrn1 = 'Y'
C dow @Scrn1 = 'Y'
*
C exfmt SUB01CTL
*
C select
*
C when *in03 Or *in12
C eval @Scrn1 = 'N'
*
C other
*
C do SavRRn SFLRcdCnt
C SFLRcdCnt chain SUB01
C if %found and S1OPTN <> *blanks
C eval %subst(DataQData : 1) = S1FLD
C eval %subst(DataQData : 11) =
C %editw(H1LEN : ' ')
C eval %subst(DataQData : 16) = H1TYPE
C if H1TYPE <> 'A'
C eval %subst(DataQData : 17) = %editw(H1DEC : '0 ')
C endif
C eval %subst(DataQData : 19) = S1DESC
C exsr $SendDataQ
C eval S1OPTN = *blanks
C update SUB01
C eval @Scrn1 = 'N'
C endif
C enddo
*
C endsl
*
C enddo
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=
* $LoadSFL - write Fields to screen
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=
C $LoadSFL begsr
*
C eval S1FLD = FieldName
C eval S1DESC = FieldDesc
C eval H1TYPE = FieldType
C if FieldType = 'A'
C eval H1LEN = FieldLen
C else
C eval H1LEN = Digits
C endif
C eval H1DEC = Decimals
*
C eval RRn = (RRn + 1)
C eval SavRRn = RRn
C write SUB01
*
C if NbrOfField = NbrInList
C eval *in89 = *on
C endif
*
C endsr
*
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=
* $ClearSFL - clear the Subfile
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=
C $ClearSFL begsr
*
C eval *in50 = *off
C eval *in51 = *off
C eval *in52 = *on
C write FMT1
C write SUB01CTL
C eval *in50 = *on
C eval *in51 = *on
C eval *in52 = *off
*
C eval SavRRn = 0
C eval SCRRn = 1
C eval RRn = 0
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=
* Send Data Queue
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C $SendDataQ begsr
*
C eval DataQLength = 1024
*
C call 'QSNDDTAQ'
C parm DataQName
C parm DataQLib
C parm DataQLength
C parm DataQData
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* Create Data Queue
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C $CreateDataQ begsr
*
C eval CmdString = %trim('CRTDTAQ') +
C %trim('~DTAQ(') + %trim(DataQLib) +
C %trim('/') + %trim(DataQName) +
C %trim(')') +
C %trim('~TYPE(*STD)') +
C %trim('~MAXLEN(1024)') +
C %trim('~SIZE(*MAX16MB)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=
* Check Data Queue
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C $CheckDataQ begsr
* CHKOBJ OBJ(QTEMP/&DTAQ) OBJTYPE(*DTAQ)
C eval CmdString = %trim('CHKOBJ') +
C %trim('~OBJ(') + %trim(DataQLib) +
C %trim('/') + %trim(DataQName) +
C %trim(')') +
C %trim('~OBJTYPE(*DTAQ)')
C eval CmdString = %xlate('~' : ' ' : CmdString)
C eval CmdLength = %size(CmdString)
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C if *in99
C exsr $CreateDataQ
C endif
C exsr $ClearDataQ
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=
* Clear Data Queue
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=
C $ClearDataQ begsr
*
C*****> call 'QCLRDTAQ'
C*****> NO NEED! parm DataQName
C*****> parm DataQLib
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=
* *inzsr - Initial one time run subroutine
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-=-=-=
C *inzsr begsr
*
C *entry plist
C parm pInputLib
C parm pInputName
C parm pDataQLib
C parm pDataQName
*
C eval InputLib = pInputLib
C eval InputName = pInputName
C eval FileLib = pInputName + pInputLib
C eval DataQLib = pDataQLib
C eval DataQName = pDataQName
C exsr $CheckDataQ
C exsr $ClearSFL
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

RPG & XML - RPGs XML Support

2009-04-16T02:44:00.000-07:00

Got an XML file and want to read and process it in AS400 through RPG

The simple thing is to create a data structure in your RPG program that maps to the XML schema. Then use the XML-INTO operation code to load the XML file into the data structure.

Mapping XML Attributes to RPG Data Structures

A brief review of the basics is in order. The following is a basic example; it demonstrated the parsing of a simple document similar to this:

Phones R Us
Company 2
Last One
...

Both the data definition and processing is quite straight forward and can essentially be handled by the following RPG code:

d customers DS
d company 32a Dim(999)

/Free
XML-INTO company %XML( XML_Input : 'case=any');

When we are able to use the above approach, we can even take advantage of the fact that the XML parser will supply a count of the number of company elements found and place it in xmlElements, an 8-byte integer (20i) at offset 372 in the program status data structure (PSDS).

Phones R Us
Company 2
Last One
…

The concern is how to handle the Location attribute of the Other Info element. The simple answer is that an attribute of an element is considered to be at the same hierarchical level as a child of that element.

And this:

25

are effectively the same thing and therefore we code for the first version the same way as if the XML looked like the second version. Look at the code sample below and you’ll see what we mean. otherInfo is coded as a nested data structure using the LikeDS keyword, and the location attribute is coded as a subfield of that DS.

d customers DS qualified
d otherInfo LikeDS(otherInfo)
d company 32a Dim(999)

d otherInfo DS
d location 2a

/Free
XML-INTO customers %XML( XML_Input : 'case=any');

Handling Nested Arrays and Other XML Issues
However, introducing another level into the DS causes a lot of problems. For one, the XML-INTO as shown above may not work. Also, because the array definition isn’t at the top level of the INTO target, the parser can’t populate the xmlElements value in the PSDS, so we won’t have an easy way to determine how many elements were retrieved. The reason is that there could be multiple groups of repeating elements in the XML document and therefore multiple arrays in the DS. The parser wouldn’t know which count we wanted it to place in the PDS.

The program as coded will only run to successful completion if there are exactly 999 customer elements present in the XML. If there are fewer than 999 elements, the program will fail with the error message RNQ0353 “XML document does not match RPG variable.” Since this message is issued under many circumstances, you’d need to drill down to the earlier messages in the job log to discover the real cause. In this case, it’ll be message RNX0353 “The XML document does not match the RPG variable; reason code 2.” The reason code identifies the problem as being too few elements to fill the array.

To handle this we would need to add the option "allowmissing=yes" to our %XML BIF--so our XML-INTO would look like this:

XML-INTO customers %XML( XML_Input : 'case=any allowmissing=yes');

This lets the program run, but how do we know how many customer elements we actually have? The easiest way to handle this is to initialize the entire data structure to a known value. Our personal preference is *HiVal since this value should never appear in the XML document. See Code Sample 1 for a demonstration. This processes the XML document shown in Code Sample 2. We initialize the DS at (A). Then in the FOR loop that processes the extracted data, we test for *HIVal in the customer ID entry (B) and exit the loop if it’s encountered (C).

allowmissing=yes = Danger!
The danger with specifying this option is it offers no way to specify what’s allowed to be missing. Once you’ve said that it’s OK for elements to be omitted you’ve opened the door for any element to be omitted from the document--and you’d have no warning if this were to occur. To deal with this, we can use the same approach that we used earlier to test for the end of the list. To demonstrate, we’ve included a test to determine if the contact information was present (D), and to handle the situation appropriately in the event that it wasn’t supplied.

How to deal with the handling of numeric data within an XML document. While XML-INTO supports the direct parsing of elements into numeric fields, it’s not a recommended practice unless you originated the XML document and can be certain that only valid numeric data is contained within the element. The reason for this is that if the XML parser encounters an invalid numeric value during the conversion, it’ll abort the XML-INTO process. A simple error in a (supposedly) numeric field can cause the whole operation to fail. IBM’s recommendation is that rather than define your fields as numeric in the target DS, you should define them as character and then manually convert them to numeric as part of your validation process. Depending on the type of data, you can then use %Dec or %Int wrapped up in a MONITOR group so any errors can be detected and handled. You can see an example of this at (E) in the program. Another advantage of having XML-INTO handle such fields as character data is that we can incorporate the value in any error messages.

RPG programs to the IFS (AS400)

2009-04-16T01:47:00.000-07:00

OK here we go for the benefit of IFS Files...........
There are lot of questions like....Question: Does anyone have a method to save a number of RPG programs to the IFS so can copy them over to CD for reference.

Answer is yes, there is a way we can do this.

By using the foloowing command

QSH CMD('cat qsys.lib/mylib.lib/qrpgsrc.file/mysource.mbr > /myifsdir/myrpg.txt')
Or......

You can write a CL program to do this

DCLF FILE(qtemp/MBRLIST) RCDFMT(QWHFDML)
CLRPFM qtemp/MBRLIST
MONMSG CPF0000
DSPFD FILE(mylib/mysource) TYPE(*MBRLIST) OUTPUT(*OUTFILE) OUTFILE(Qtemp/MBRLIST) NXTFIL: RCVF RCDFMT(QWHFDML)
MONMSG MSGID(CPF0864) EXEC(GOTO CMDLBL(ENDIT))
OVRDBF FILE(mysource) TOFILE(mylib/mysource) MBR(&MLname)
/* &MLname now contains the member name to be moved via */
/* ftp/cpytopcd/qsh etc */
GOTO CMDLBL(NXTFIL) endit: DLTOVR *ALL
endpgm

Also............You can share out source files to the network via Netserver. Then you merely open the share, drag and drop the folder to your desktop (or where ever), and all the source members in the folder become .txt files. Takes a while to run though, if your source file is big.

Another option is to use FTP. With a simple DOS batch file, you can pull down all of the members in a Source Physical File and drop them onto your hard drive individually (into a directory of your choice).

ANOTHER WAY OUT...............
FTP them from iSeries to your PC. In text mode the QRPGLESRC will ftp down the text only. I do it all the time and have tons of source on my notebook. I can even ftp from the iSieries to my ftp server on the web. I usr Seagull FTP Client does nicely attaching to iSeries FTP.just do a mget on the library/qrpglesrc *.* and the members will be named QRPGLESRC.yoursorucemembername.Then when you want to upload to iSeries do a put.Works like a charm.

IFS Folder

2009-04-16T01:24:00.000-07:00

Check object existence using IFS API

There is a simpler method to discover if your file, folder or other IFS object exists in the IFS, without getting into custom commands and system API's.
A more practical method to discover if your file, folder or other IFS object exists is to use the RENAME command. This is the same old DOS or UNIX command we used in the 1980's where you can rename the object to the same name it already has.
Typically, once you have navigated down the folder path of the IFS to the actual folder using the WRKLNK command -- like WRKLNK OBJ( '/folderA/folderB' ) or in batch work -- you would be using the CHGCURDIR or the shortcut commands CHDIR or CD, and then you can rename your object to the same name.

Read an IFS file

How to read an ifs file and populate a table on the iseries.You wont be able to use it directly cause of some specifics in our environment, but I have included all the "stuff" you will need to test. Debug !!!! so .........

1) create the file & logical ...

2) create a folder on the IFS under root called sigmanest.

3) compile the program and put in debug....

The format of the file extracted from a drawing program (sigmanest) as a .csv which is what makes it interesting it created without commas.....