Followers
Friday, 9 October 2009
Converting from AS400 reports to HTML
src="http://pagead2.googlesyndication.com/pagead/show_ads.js">
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
src="http://pagead2.googlesyndication.com/pagead/show_ads.js">
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
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
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
Sunday, 4 October 2009
Email & SMS Error Notifications from an AS/400
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
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
Subscribe to:
Posts (Atom)