You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG186R4 (01 Oct 2014, UnknownUser)EditAttach
**********************************************************************************************
* DBG186R4: Work with user outqueue/spoolfile
* Copyright (C) 2000 Martin Rowe <martin@dbg400.net>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
**********************************************************************************************
H DATEDIT(*YMD) DEBUG(*YES) OPTIon(*NODEBUGIO : *SRCSTMT)
**************************************************************************
* WRKOUTQ outfile
FDBG1860W If E DISK INFDS(LISTDS)
* User *OUTQ list
FDBGUOL00 UF A E K DISK
* WRKUSROUTQ User settings
FDBGWUS00 UF A E K DISK
* Display screen
FDBG186DF CF E WORKSTN
F SFILE(SFL:RRN)
F SFILE(SFL2:RRN2)
F SFILE(SFL3:RRN3)
F SFILE(SFL4:RRN4)
F SFILE(SFL5:RRN5)
**********************************************************************************************
* PROGRAM NAME
D SDS
D PGM 10
D Usrprf 254 263
* Information Data Structure
D LISTDS DS
* Current relative record number
D ListRecNbr 397 400B 0
* ==List API structures==
* Standard error code DS for API error handling
D Error_Code DS
D BytesProvd 1 4B 0 INZ(0)
D BytesAvail 5 8B 0 INZ(0)
D Except_ID 9 15
D Reserved 16 16
D Exception 17 272
* Receiver value DS for user space header info (used in first call to QUSRTVUS)
D GenRcvrDS DS
D UserArea 1 64
D GenHdrSize 65 68B 0
D StrucLevel 69 72
D FormatName 73 80
D APIused 81 90
D CreateStamp 91 103
D InfoStatus 104 104
D SizeUSused 105 108B 0
D InpParmOff 109 112B 0
D InpParmSiz 113 116B 0
D HeadOffset 117 120B 0
D HeaderSize 121 124B 0
D ListOffset 125 128B 0
D ListSize 129 132B 0
D ListNumber 133 136B 0
D EntrySize 137 140B 0
* QUSLOBJ format OBJL0100 structure
D ObjL0100DS DS
D ObjL0100
D L_Object 10A OVERLAY( ObjL0100 : 1 )
D L_ObjectLib 10A OVERLAY( ObjL0100 : 11 )
D L_ObjectTyp 10A OVERLAY( ObjL0100 : 21 )
* QSPROUTQ format OUTQ0100 structure
D OutQ0100DS DS
D OutQ0100 2000A
D L_BytesRtrnd 9B 0 OVERLAY( OutQ0100 : 1 )
D L_BytesAvail 9B 0 OVERLAY( OutQ0100 : 5 )
D L_OutQName 10A OVERLAY( OutQ0100 : 9 )
D L_OutQLib 10A OVERLAY( OutQ0100 : 19 )
D L_FileOrder 10A OVERLAY( OutQ0100 : 29 )
D L_DisplayAny 10A OVERLAY( OutQ0100 : 39 )
D L_JobSeperat 9B 0 OVERLAY( OutQ0100 : 49 )
D L_OperatrCtl 10A OVERLAY( OutQ0100 : 53 )
D L_DataQName 10A OVERLAY( OutQ0100 : 63 )
D L_DataQLib 10A OVERLAY( OutQ0100 : 73 )
D L_CheckAuth 10A OVERLAY( OutQ0100 : 83 )
D L_NbrOfFiles 9B 0 OVERLAY( OutQ0100 : 93 )
D L_OutQStatus 10A OVERLAY( OutQ0100 : 97 )
D L_WtrJobName 10A OVERLAY( OutQ0100 : 107 )
D L_WtrJobUser 10A OVERLAY( OutQ0100 : 117 )
D L_WtrJobNbr 6A OVERLAY( OutQ0100 : 127 )
D L_WtrJobSts 10A OVERLAY( OutQ0100 : 133 )
D L_PrtDevName 10A OVERLAY( OutQ0100 : 143 )
D L_OutQText 10A OVERLAY( OutQ0100 : 153 )
D L_Reserved1 2A OVERLAY( OutQ0100 : 203 )
D L_NbrSplSpec 9B 0 OVERLAY( OutQ0100 : 205 )
D L_NbrWtrStrd 9B 0 OVERLAY( OutQ0100 : 209 )
D L_AutoStrWtr 9B 0 OVERLAY( OutQ0100 : 213 )
D L_RmtSysType 1A OVERLAY( OutQ0100 : 217 )
D L_RmtSysName 255A OVERLAY( OutQ0100 : 218 )
D L_RmtPrintQ 128A OVERLAY( OutQ0100 : 473 )
D L_MsgQName 10A OVERLAY( OutQ0100 : 601 )
D L_MsgQLib 10A OVERLAY( OutQ0100 : 611 )
D L_ConnectTyp 9B 0 OVERLAY( OutQ0100 : 621 )
D L_DestinType 9B 0 OVERLAY( OutQ0100 : 625 )
D L_VMMVSClass 1A OVERLAY( OutQ0100 : 629 )
D L_FormCtlBuf 8A OVERLAY( OutQ0100 : 630 )
D L_HostPrtTrf 1A OVERLAY( OutQ0100 : 638 )
D L_ManuTypMod 17A OVERLAY( OutQ0100 : 639 )
D L_WrkCustObj 10A OVERLAY( OutQ0100 : 656 )
D L_WrkCustLib 10A OVERLAY( OutQ0100 : 666 )
D L_SplAuxAttr 1A OVERLAY( OutQ0100 : 676 )
D L_MaxPagOffs 9B 0 OVERLAY( OutQ0100 : 677 )
D L_NbrPageRtn 9B 0 OVERLAY( OutQ0100 : 681 )
D L_LenSizeEnt 9B 0 OVERLAY( OutQ0100 : 685 )
D L_DestinOpts 128A OVERLAY( OutQ0100 : 689 )
D L_WtrTypStrd 1A OVERLAY( OutQ0100 : 817 )
D L_PrtSepPage 1A OVERLAY( OutQ0100 : 818 )
D L_LongRmtPrt 255A OVERLAY( OutQ0100 : 819 )
D L_ImgConfig 10A OVERLAY( OutQ0100 : 1074 )
D L_ImgConfLib 10A OVERLAY( OutQ0100 : 1084 )
D L_Reserved2 3A OVERLAY( OutQ0100 : 1094 )
D L_SplAuxID 9B 0 OVERLAY( OutQ0100 : 1097 )
*
D DspFTPLog DS
D DSPPFM 30A INZ('DSPPFM QTEMP/FTPSRC FTPOUT')
*
D PcDtaQData DS 7
D DtaQSflOpt 2
D DtaQRRN 9P 0
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D COMPNY S 40 DTAARA(DBGCOMP)
D Counter S 5 0
D CurrentEnt S 5P 0
D DataLength S 9B 0 INZ(140)
D DefaultDir S 100 DTAARA(DBG186DA)
D DtaLen S 5 0
D Errid S 7
D ExtendAttr S 10 INZ('USRSPC ')
D FileName S 50
D GreenProtect S 1 INZ(X'A0')
D GreenULine S 1 INZ(X'24')
D HTMLTitle S 50
D IgnoreCase S 1N
D InitialSiz S 9B 0 INZ(1024)
D InitialVal S 1 INZ(X'00')
D LastOptionLine S 3 0
D ListBuilt S 1
D ListFormat S 8 INZ('OBJL0100')
D MoreDtaQRcds S 1N
D MsgDta S 512
D MsgFil S 10
D MsgID S 7
D MsgLib S 10
D MsgTyp S 10
D Nb2Dlt S 4 0
D ObjectType S 10 INZ('*OUTQ ')
D OutQRcvrLen S 9B 0 INZ(2000)
D P_BatchFile S LIKE(BATCHFILE)
D PcDtaqKeyLen S 3 0 INZ(10)
D PcDtaqKeyOrd S 2 INZ('EQ')
D PcDtaqKey S 10
D PcDtaqLen S 5 0 INZ(7)
D PcDtaqLib S 10 INZ('QTEMP')
D PcDtaqName S 10 INZ('DBG186DQ')
D PcDtaqSndInf S 10
D PcDtaqSndLen S 3 0 INZ(0)
D PcDtaqWait S 5 0 INZ(0)
D P_CmdLength S 15 5
D P_CmdString S 256
D P_FileName S LIKE(FileName)
D P_Format S LIKE(FORMAT)
D P_Found S 1N
D P_FTPDir S LIKE(FTPDIR)
D Pgmq S 10
D PgmStk S 5 0
D P_HTMLTitle S LIKE(HTMLTitle)
D P_IgnoreCase S 1N
D P_LmtCpb S 10
D P_Mbropt S 10
D P_Outq S 20
D P_PCFileExt S LIKE(PCFILEEXT)
D P_Pgm S 10
D P_QualOutQ S 20
D P_RemoteMach S LIKE(REMOTEMACH)
D P_RemotePass S LIKE(REMOTEPASS)
D P_RemoteUser S LIKE(REMOTEUSER)
D P_SearchString S 25
D P_SplNbr S 4
D P_StmfDir S LIKE(STMFDIR)
D PublicAut S 10 INZ('*ALL ')
D P_User S 10
D P_Usrprf S 10
D QualifyObj S 20 INZ('*ALL *ALL')
D QualOutQ S 20
D RcdNbr S 4 0
D RcdsThisPage S 4 0
D ReadDtaQ S 1N
D RefreshRqd S 1
D Reload S 1
D ReplaceSpc S 10 INZ('*YES ')
D Rrn2 S 4 0
D Rrn3 S 4 0
D Rrn4 S 4 0
D Rrn5 S 4 0
D Rrn S 4 0
D RunAPI S 1
D SearchString S 25
D Selected S 1N
D SFLKey S 4 0
D ShowFtpLog S 1
D SpoolDlt S 1
D SpoolView S 1 0 INZ(1)
D StartPos S 9B 0 INZ(1)
D TextDescrp S 50 INZ('User space for API use')
D TopRRN S 5 0
D UserSpace S 20 INZ('DBG186US QTEMP ')
**********************************************************************************************
* CONSTANTS:
**********************************************************************************************
*
D OpText1 C CONST('1=Send 2=Change 3=Hold 4=D-
D elete 5=Display 6=Release 8=Attri-
D butes')
D OpText2 C CONST(' 9=Work print st-
D s F=FTP P=PC Open T=Text save V=V-
D iew formatted')
D Up C CONST(X'-
D 00010203040506070809-
D 0A0B0C0D0E0F10111213-
D 1415161718191A1B1C1D-
D 1E1F2021222324252627-
D 28292A2B2C2D2E2F3031-
D 32333435363738393A3B-
D 3C3D3E3F404142434445-
D 464748494A4B4C4D4E4F-
D 50515253545556575859-
D 5A5B5C5D5E5F60616263-
D 6465666768696A6B6C6D-
D 6E6F7071727374757677-
D 78797A7B7C7D7E7F8081-
D 82838485868788898A8B-
D 8C8D8E8F909192939495-
D 969798999A9B9C9D9E9F-
D A0A1A2A3A4A5A6A7A8A9-
D AAABACADAEAFB0B1B2B3-
D B4B5B6B7B8B9BABBBCBD-
D BEBFC0C1C2C3C4C5C6C7-
D C8C9CACBCCCDCECFD0D1-
D D2D3D4D5D6D7D8D9DADB-
D DCDDDEDFE0E1E2E3E4E5-
D E6E7E8E9EAEBECEDEEEF-
D F0F1F2F3F4F5F6F7F8F9-
D FAFBFCFDFEFF')
*
D Down C CONST(X'-
D FFFEFDFCFBFAF9F8F7F6-
D F5F4F3F2F1F0EFEEEDEC-
D EBEAE9E8E7E6E5E4E3E2-
D E1E0DFDEDDDCDBDAD9D8-
D D7D6D5D4D3D2D1D0CFCE-
D CDCCCBCAC9C8C7C6C5C4-
D C3C2C1C0BFBEBDBCBBBA-
D B9B8B7B6B5B4B3B2B1B0-
D AFAEADACABAAA9A8A7A6-
D A5A4A3A2A1A09F9E9D9C-
D 9B9A9998979695949392-
D 91908F8E8D8C8B8A8988-
D 87868584838281807F7E-
D 7D7C7B7A797877767574-
D 737271706F6E6D6C6B6A-
D 69686766656463626160-
D 5F5E5D5C5B5A59585756-
D 5554535251504F4E4D4C-
D 4B4A4948474645444342-
D 41403F3E3D3C3B3A3938-
D 37363534333231302F2E-
D 2D2C2B2A292827262524-
D 232221201F1E1D1C1B1A-
D 19181716151413121110-
D 0F0E0D0C0B0A09080706-
D 050403020100')
**********************************************************************************************
* INDICATOR USAGE
* Screen function keys
* 03 (F3) Exit (all screens)
* 05 (F5) Refresh
* 11 (F11) View 1/2 - toggle between the two views of spoolfile details
* 27 - ROLLUP
* 28 - ROLLDOWN
* Subfile control inds
* Main subfile (SFL)
* 35 - SFLEND
* 36 - SFLDSP
* N36 - SFLCLR
* Delete request subfile (SFL2)
* 37 - SFLEND
* 38 - SFLDSP
* N38 - SFLCLR
* Screen error/dspatr inds
* File access inds
* 80 81 82 83
* Error ind (for calls)
* 90
**************************************************************************
* ENTRY PARAMETERS
**************************************************************************
C *ENTRY PList
C Parm P_QualOutQ
C Parm P_LmtCpb
C Parm P_User
**************************************************************************
* KEY LIST DEFINITIONS
**************************************************************************
C PFUOLKey KList
C KFld Usrprf
C KFld AOQUE
C KFld AOQUEL
**************************************************************************
* MAINLINE
**************************************************************************
* Program initialisation
C ExSr Inits
* Build first page
C 1 SetLL DBG1860W
C ExSr PagUp
* Main Screen display loop
B001 C DoU *IN03
* Only display subfile if records to show
C Eval *IN36 = Rrn > 0
* Display command key text
C Write FOOTER1
C Write MSFLC MSG SUBFILE
C Write HEADER
C ExFmt SFLCTL
C Read HEADER 90
C Eval Reload = *off
C Eval RefreshRqd = *off
C Call 'DBG045CL' 90 REMove MSGS
* Process response
B002 C Select
* F1/Help pressed
S002 C When *IN01 = *on
* Call the Helptext Viewer
C Call 'DBG010R4' 90 Trap errors
C Parm PGM P_Pgm
* F3=Exit
S002 C When *IN03 = *on
C Leave
* Rollup
S002 C When *IN27 = *on
C ExSr PagUp
* Rolldown
S002 C When *IN28 = *on
C ExSr PagDwn
* F5=Refresh
S002 C When *IN05 = *on
C ExSr Refresh
C Eval TopRRN = 1
C Eval Reload = *on
* F8=PC Options
S002 C When *IN08 = *on
C ExSr PCSetup
* F11=View 1/2/3
S002 C When *IN11 = *on
C ExSr SaveSFLOpts
C Eval SpoolView = SpoolView + 1
B003 C If SpoolView > 3
C Eval SpoolView = 1
E003 C EndIf
C Move *on Reload
* F16=Find
S002 C When *IN16 = *on
C ExSr FindString
* F17=Outq list
S002 C When *IN17 = *on
C ExSr OutList
* F21=Command line
S002 C When *IN21 = *on
C ExSr SaveSFLOpts
C Call 'QUSCMDLN' 90
* If restriction fields changed, reload from top of list
S002 C When *IN55
C Eval TopRRN = 1
C Eval Reload = *on
* Otherwise proces any subfile record requests
S002 C Other
C ExSr ProcessOpts
C ExSr SetCursor
E002 C EndSl
* Reload subfile
B002 C If Reload = *on
C Eval *IN35 = *off SFLEND
C TopRRN SetLL DBG1860W
C ExSr PagUp
E002 C EndIf
E001 C EndDo
* Time to go...
C ENDPGM Tag
* ====== ===
C Eval *INLR = *on
C Return
**************************************************************************
* PagUp: DISPLAY NEXT PAGE
**************************************************************************
C PagUp BegSr
* If not at SFLEND
B001 C If *IN35 = *off
C ExSr SaveSFLOpts
* Reset the relative record number & clear the subfile
C Eval Rrn = 0
C Eval RcdsThisPage = 0
C Eval Counter = 0
C Eval *IN36 = *off
C Write SFLCTL
*
C Eval SSEL = ' '
C Eval *IN51 = *off
C Eval *IN52 = *off
C Eval *IN53 = *off
B002 C Select
S002 C When SpoolView = 1
C Eval *IN51 = *on
S002 C When SpoolView = 2
C Eval *IN52 = *on
S002 C When SpoolView = 3
C Eval *IN53 = *on
E002 C EndSl
* Load a page of entries
B002 C DoU Counter = 13
C Read DBG1860W 82
* If record found
B003 C If *IN82 = *off
C Eval SSEL = ' '
C Eval ReadDtaQ = *on
C Eval LISTRRN = ListRecNbr
C ExSr RcdSelect
B004 C If Selected
* Add this record to the subfile
C Eval Rrn = Rrn + 1
C Eval Counter = Rrn
C Eval RcdsThisPage = Rrn
C Write SFL
* Store first subfile record values for roll down key positioning
B005 C If Rrn = 1
C Eval TopRRN = LISTRRN
E005 C EndIf
E004 C EndIf
* Otherwise we've hit the end of the WRKOUTQ outfile
X003 C Else
C Eval *IN35 = *on SFLEND
C Eval Counter = 13
E003 C EndIf
E002 C EndDo
*
C ExSr SetCursor
* If not SFLEND
B002 C If *IN35 = *off
* Check ahead to see if there will be any more rcds next roll up - if
* not then set SFLEND
C LISTRRN SetGT DBG1860W 35
E002 C EndIf
E001 C EndIf
*
C EndSr
**********************************************************************************************
* PagDwn: DISPLAY PREVIOUS PAGE
**********************************************************************************************
C PagDwn BegSr
*
C ExSr SaveSFLOpts
C Eval *IN35 = *off SFLEND
C Eval Counter = 0
* Position file to first record on displayed page
C TopRRN SetLL DBG1860W
* Read back to equivalent of top of previous page
B001 C DoU Counter = 14
C ReadP DBG1860W 82 82
* If less than 'the page + a rcd' rcds exist, reset pointer to last read
B002 C If *IN82 = *on
* Cater for roll down before first record
B003 C If LISTRRN = 0
C Eval LISTRRN = 1
E003 C EndIf
* Cater for roll down after reading last record
B003 C If LISTRRN > TopRRN
C Eval LISTRRN = TopRRN
E003 C EndIf
C LISTRRN SetLL DBG1860W
C Leave
X002 C Else
C Eval LISTRRN = ListRecNbr
C Eval ReadDtaQ = *off
C ExSr RcdSelect
B003 C If Selected
C Eval Counter = Counter + 1
E003 C EndIf
E002 C EndIf
E001 C EndDo
* Rebuild the page from current point
C ExSr PagUp
*
C EndSr
**********************************************************************************************
* SetCursor: Set cursor position
**********************************************************************************************
C SetCursor BegSr
* Set cursor to appropriate line
B002 C Select
S002 C When LastOptionLine = 0
C Eval CSRLIN = 9
S002 C When LastOptionLine > RcdsThisPage + 8
C Eval CSRLIN = RcdsThisPage + 8
S002 C Other
C Eval CSRLIN = LastOptionLine
E002 C EndSl
C Eval CSRCOL = 3
C Eval LastOptionLine = 9
*
C EndSr
**********************************************************************************************
* ProcessOpts: Process subfile options
**********************************************************************************************
C ProcessOpts BegSr
*
C ExSr SaveSFLOpts
* Only process if subfile records to work with
C ExSr ReadDtaqRcd
* Do while more selected records
B001 C DoW MoreDtaQRcds
*
B002 C Select
* Delete requests are grouped for a delete confirmation screen later
S002 C When SSEL = '4'
C ExSr FlgDlt
S002 C Other
* Refresh the list if any options can change what's displayed
B003 C If SSEL = '2' or SSEL = '3' or SSEL = '4'
C or SSEL = '6'
C Eval RefreshRqd = *on
E003 C EndIf
*
C Eval RunAPI = *on
C Move SPLNBR P_SplNbr
* Set default file name
C Eval FileName = %TRIM(SPLNAME) + '-' +
C %TRIM(P_SplNbr) + '-' +
C %TRIM(SPLJOBNAME) + '-' +
C %TRIM(SPLUSERPRF) + '-' +
C %TRIM(SPLJOBNBR)
* Set default HTML title
C Eval HTMLTitle = SPLNAME
* Set default FTP log status
C Eval ShowFtpLog = FTPLOG
* Set screen values from defaults
C Eval FILENAME2 = FileName
C Eval PCFILEEXT2 = PCFILEEXT
C Eval STMFDIR2 = STMFDIR
C Eval FTPDIR2 = FTPDIR
C Eval BATCHFILE2 = BATCHFILE
C Eval FORMAT2 = FORMAT
C Eval RMTMACHINE = REMOTEMACH
C Eval RMTUSER = REMOTEUSER
C Eval RMTPASSWD = REMOTEPASS
C Eval HTMLTITLE2 = HTMLTitle
C Eval FTPLOG2 = FTPLOG
* Prompt for overrides if required
B003 C If OVERPROMPT = 'Y' and
C (SSEL = 'F' or SSEL = 'P' or SSEL = 'T')
* Display the prompt window
B004 C DoU not *IN01
C ExFmt WINDOW
C Call 'DBG045CL' 90 REMOVE MSGS
* F1/Help pressed
B005 C If *IN01
* Call the Helptext Viewer
C Call 'DBG010R4' 90 Trap errors
C Parm PGM P_Pgm
E005 C EndIf
E004 C EndDo
E003 C EndIf
* If F12 not pressed or prompt screen not displayed load API parms from window values
B003 C If not *IN12 or OVERPROMPT = 'N'
C Eval P_FileName = FILENAME2
C Eval P_PCFileExt = PCFILEEXT2
C Eval P_StmfDir = STMFDIR2
C Eval P_FTPDir = FTPDIR2
C Eval P_BatchFile = BATCHFILE2
C Eval P_Format = FORMAT2
C Eval P_RemoteMach = RMTMACHINE
C Eval P_RemoteUser = RMTUSER
C Eval P_RemotePass = RMTPASSWD
C Eval P_HTMLTitle = HTMLTITLE2
C Eval ShowFtpLog = FTPLOG2
* Otherwise cancel action
X003 C Else
C Eval RunAPI = *off
E003 C EndIf
*
B003 C If RunAPI = *on
C Call 'DBG187CL' 90
C Parm SPLNAME
C Parm SPLJOBNAME
C Parm SPLUSERPRF
C Parm SPLJOBNBR
C Parm P_SplNbr
C Parm SSEL
C Parm P_BatchFile
C Parm P_StmfDir
C Parm P_FTPDir
C Parm P_RemoteMach
C Parm P_RemoteUser
C Parm P_RemotePass
C Parm P_PCFileExt
C Parm P_Format
C Parm P_FileName
C Parm P_HTMLTitle
*
B004 C If ShowFtpLog = 'Y' and SSEL = 'F'
C Call 'QCMDEXC' 90
C Parm DSPPFM P_CmdString
C Parm 30 P_CmdLength
E004 C EndIf
E003 C EndIf
*
E002 C EndSl
*
* Next selected record
C ExSr ReadDtaqRcd
E001 C EndDo
* Process delete requests
B001 C If SpoolDlt = *on
C ExSr MassDelete
E001 C EndIf
* Set cursor back on line of last request, not where it actually was
C
*
B001 C If RefreshRqd = *on
C Call 'QCLRDTAQ'
C Parm PcDtaqName
C Parm PcDtaqLib
C ExSr Refresh
C Eval Reload = *on
E001 C EndIf
*
C EndSr
**********************************************************************************************
* RcdSelect: Record selection
**********************************************************************************************
C RcdSelect BegSr
*
C Eval Selected = *off
* If the restriction criteria are empty or match the starting characters of the target field
* File name & user data can be generic - user is an exact match
B001 C If (SELFILE = ' ' or %TRIM(SELFILE) =
C %SUBST(SPLNAME:1:%LEN(%TRIM(SELFILE))))
C and (SELUSER = ' ' or SELUSER = SPLUSERPRF)
C and (SELUSRDTA = ' ' or %TRIM(SELUSRDTA) =
C %SUBST(SPLUSRDTA:1:%LEN(%TRIM(SELUSRDTA))))
* Include search criteria
B002 C If SearchString <> *blanks
C ExSr SearchSpool
X002 C Else
C Eval Selected = *on
E002 C EndIf
* If record selected
B002 C If ReadDtaQ and Selected
C ExSr GetSFLOpt
E002 C EndIf
* Set subfile fields
C ExSr SetSFLFields
E001 C EndIf
*
C EndSr
**********************************************************************************************
* SetSFLFields: Set subfile fields from record
**********************************************************************************************
C SetSFLFields BegSr
*
C Eval SP_NAME = SPLNAME
C Eval SP_JOBNAME = SPLJOBNAME
C Eval SP_USRPRF1 = SPLUSERPRF
C Eval SP_USRPRF2 = SPLUSERPRF
C Eval SP_NBR = SPLNBR
C Eval SP_JOBNBR = SPLJOBNBR
C Eval SP_OUTQ = SPLOUTQ
C Eval SP_OUTQLIB = SPLOUTQLIB
C Eval SP_DEVICE = SPLDEVICE
C Eval SP_USRDTA = SPLUSRDTA
B001 C Select
S001 C When SPLSTATUS = '*READY'
C Eval SP_STS = 'RDY'
S001 C When SPLSTATUS = '*HELD'
C Eval SP_STS = 'HLD'
S001 C When SPLSTATUS = '*SAVED'
C Eval SP_STS = 'SAV'
S001 C When SPLSTATUS = '*WRITING'
C Eval SP_STS = 'WTR'
S001 C When SPLSTATUS = '*OPEN'
C Eval SP_STS = 'OPN'
S001 C When SPLSTATUS = '*CLOSED'
C Eval SP_STS = 'CLO'
S001 C When SPLSTATUS = '*SENDING'
C Eval SP_STS = 'SND'
S001 C When SPLSTATUS = '*DEFERRED'
C Eval SP_STS = 'DFR'
S001 C When SPLSTATUS = '*PENDING'
C Eval SP_STS = 'PND'
S001 C When SPLSTATUS = '*PRINTING'
C Eval SP_STS = 'PRT'
S001 C When SPLSTATUS = '*MESSAGE'
C Eval SP_STS = 'MSGW'
S001 C Other
C Eval SP_STS = SPLSTATUS
E001 C EndSl
C Eval SP_TOTPAGE = SPLTOTPAGE
C Eval SP_CURPAGE = SPLCURPAGE
C Eval SP_CPYLEFT = SPLCPYLEFT
C Eval SP_FORMTYP = SPLFORMTYP
C Eval SP_PRIORTY = SPLPRIORTY
C Eval SP_DATE = SPLDATE
C Eval SP_TIME = SPLTIME
*
C EndSr
**********************************************************************************************
* PCSetup: Setup PC options
**********************************************************************************************
C PCSetup BegSr
*
B001 C DoW not *IN03
B002 C If REMOTEPASS <> ' ' and REMOTEPASS = CONFRMPASS
C Eval PASSWRDSET = 'Password set'
X002 C Else
C Eval PASSWRDSET = 'Password rqd'
E002 C EndIf
* Display command key text
C Write MSFLC
C ExFmt SCREEN
C Call 'DBG045CL' 90 REMove MSGS
* Process response
B002 C Select
* F1/Help pressed
S002 C When *IN01
* Call the Helptext Viewer
C Call 'DBG010R4' 90 Trap errors
C Parm PGM P_Pgm
* F3=Exit
S002 C When *IN03
C Leave
* F12=Previous
S002 C When *IN12
C Eval *IN12 = *off
C Leave
* F20=Save settings
S002 C When *IN20
C Eval USUSER = Usrprf
C USUSER Chain DBGWUS00
C Eval USSDIR = STMFDIR
C Eval USFEXT = PCFILEEXT
C Eval USFMTO = FORMAT
C Eval USFTPL = FTPLOG
C Eval USOPMT = OVERPROMPT
C Eval USFDIR = FTPDIR
C Eval USRSCP = BATCHFILE
C Eval USRMCH = REMOTEMACH
C Eval USRUSR = REMOTEUSER
C Up:Down Xlate REMOTEPASS USRPWD
B003 C If %FOUND(DBGWUS00)
C Update PFWUS0
X003 C Else
C Write PFWUS0
E003 C EndIf
C Eval MsgID = 'GSM9999'
C Eval MsgDta = 'Settings saved for user ' +
C Usrprf
C Eval DtaLen = 512
C Eval PgmStk = 0
C ExSr SndMsg
E002 C EndSl
E001 C EndDo
*
C EndSr
**********************************************************************************************
* FindString: Find string in selected spoolfiles
**********************************************************************************************
C FindString BegSr
*
C Eval SearchString = *blanks
C Eval F16STS = 'Find subset *OFF*'
C Eval Reload = *on
C Eval TopRRN = 1
B001 C DoU not *IN01
* Display command key text
C Write MSFLC
C ExFmt WINDOW2
C Call 'DBG045CL' 90 REMove MSGS
* Process response
B002 C Select
* F1/Help pressed
S002 C When *IN01
* Call the Helptext Viewer
C Call 'DBG010R4' 90 Trap errors
C Parm PGM P_Pgm
* F12=Previous
S002 C When *IN12
* F16=Find
S002 C When *IN16
C Eval SearchString = SEARCH
C Eval IgnoreCase = IGNORE = 'Y'
C Eval F16STS = 'Find subset *ON*'
C Eval Reload = *on
C Eval TopRRN = 1
C Eval *IN16 = *off
E002 C EndSl
E001 C EndDo
*
C EndSr
**************************************************************************
* Refresh: Refresh output queue list
**************************************************************************
C Refresh BegSr
*
C Close DBG1860W
C Eval P_Mbropt = '*REPLACE'
B001 C If SELUSER <> *blanks
C Eval P_Usrprf = SELUSER
X001 C Else
C Eval P_Usrprf = '*ALL'
E001 C EndIf
*
B001 C Select
S001 C When OUTQUE = '*OUTQLIST'
C Usrprf Chain DBGUOL00 80
B002 C DoW not *IN80
C Eval %SUBST(P_Outq:1:10) = ULOUTQ
C Eval %SUBST(P_Outq:11:10) = ULOUTL
C Call 'DBG188R4'
C Parm P_Usrprf
C Parm P_Outq
C Parm P_Mbropt
C Eval P_Mbropt = '*ADD '
C Usrprf ReadE DBGUOL00 80
E002 C EndDo
*
S001 C When OUTQUE = '*USRSPLF'
C Eval P_Outq = '*ALL'
C Call 'DBG188R4'
C Parm P_Usrprf
C Parm P_Outq
C Parm P_Mbropt
*
S001 C Other
C Call 'DBG188R4'
C Parm P_Usrprf
C Parm P_QualOutQ P_Outq
C Parm P_Mbropt
E001 C EndSl
*
C Open DBG1860W
*
C EndSr
**********************************************************************************************
* FlgDlt: Flag spoolfile for deletion
**********************************************************************************************
C FlgDlt BegSr
*
C ExSr SetSFLFields
C Eval Rrn2 = Rrn2 + 1
C Write SFL2
C Eval Rrn4 = Rrn4 + 1
C Write SFL4
C Eval Rrn5 = Rrn5 + 1
C Write SFL5
C Move *on SpoolDlt
*
C EndSr
**********************************************************************************************
* OutList: Work with output queue list
**********************************************************************************************
C OutList BegSr
* Load all *OUTQ subfile
C ExSr LoadOutQ
C Call 'DBG045CL' 90 REMove MSGS
*
B001 C DoW not *IN03
* Only display subfile if records to show
C Eval *IN40 = Rrn3 > 0
C Write MSFLC
C Write FOOTER3
C Write HEADER3
C ExFmt SFLCTL3
C Call 'DBG045CL' 90 REMove MSGS
*
B002 C Select
* F1/Help pressed
S002 C When *IN01 = *on
* Call the Helptext Viewer
C Call 'DBG010R4' 90 Trap errors
C Parm PGM P_Pgm
* F3=Exit
S002 C When *IN03
C Leave
* F5=Refresh list
S002 C When *IN05
* Force display to *OUTQ list mode, if not already
C Eval P_QualOutQ = '*OUTQLIST'
C Eval OUTQUE = '*OUTQLIST'
* Load all *OUTQ subfile
C ExSr LoadOutQ
* F12=Previous
S002 C When *IN12
C Leave
* Update user list from subfile entries
S002 C Other
B003 C If Rrn3 > 0
C ReadC SFL3 81
B004 C DoW not *IN81
* If current *OUTQ selected
B005 C If SSEL3 = '1'
C PFUOLKey SetLL DBGUOL00 82
* Add it to the list if not already there
B006 C If not *IN82
C Eval ULUSER = Usrprf
C Eval ULOUTQ = AOQUE
C Eval ULOUTL = AOQUEL
C Write PFUOL
E006 C EndIf
* Otherwise remove it from the user's list
X005 C Else
C PFUOLKey Delete PFUOL 82
E005 C EndIf
C ReadC SFL3 81
E004 C EndDo
* Force display to *OUTQ list mode, if not already
C Eval P_QualOutQ = '*OUTQLIST'
C Eval OUTQUE = '*OUTQLIST'
* Rebuild the spool file list from scratch
C ExSr Refresh
* Set screen to load from the first spool file in the list
C Eval TopRRN = 1
C Move *on Reload
E003 C EndIf
C Leave
E002 C EndSl
*
E001 C EndDo
*
*
C EndSr
**********************************************************************************************
* LoadOutQ: Load all *OUTQs subfile
**********************************************************************************************
C LoadOutQ BegSr
* Create a user space to hold the format list entries
C Call 'QUSCRTUS'
C Parm UserSpace
C Parm ExtendAttr
C Parm InitialSiz
C Parm InitialVal
C Parm PublicAut
C Parm TextDescrp
C Parm ReplaceSpc
C Parm Error_Code
* List the outqueues on the system
C Call 'QUSLOBJ'
C Parm UserSpace
C Parm 'OBJL0100' ListFormat
C Parm QualifyObj
C Parm ObjectType
C Parm Error_Code
* Get the header info for this space
C Call 'QUSRTVUS'
C Parm UserSpace
C Parm StartPos
C Parm DataLength
C Parm GenRcvrDS
C Parm Error_Code
* Reset the relative record number & clear the subfile
C Eval Rrn3 = 0
C Move ' ' SSEL3
C Eval *IN40 = *off
C Write SFLCTL3
* Process returned entries
B001 C If ListNumber > 0
* Set the initial offset for the start of the list entries
C Eval ListOffset = ListOffset + 1
C Eval CurrentEnt = 1
* Loop through the entries held in the list section of the user space
B002 C DoW CurrentEnt <= ListNumber
* Get the header info for this space
C Call 'QUSRTVUS'
C Parm UserSpace
C Parm ListOffset
C Parm EntrySize
C Parm ObjL0100DS
C Parm Error_Code
* Retrieve Output Queue info for this entry
C Eval QualOutQ = L_Object + L_ObjectLib
C Call 'QSPROUTQ' 90
C Parm OutQ0100
C Parm OutQRcvrLen
C Parm 'OUTQ0100' FormatName
C Parm QualOutQ
C Parm Error_Code
* Include outque if API call successful
B003 C If not *IN90
C Eval AOQUE = L_OutQName
C Eval AOQUEL = L_OutQLib
C Eval AOFILS = L_NbrOfFiles
C Eval AOWTR = L_WtrJobName
C Eval AOSTS = L_OutQStatus
* Check if already in user's list - preselect if so
C PFUOLKey SetLL DBGUOL00 80
B004 C If *IN80
C Eval SSEL3 = '1'
X004 C Else
C Eval SSEL3 = ' '
E004 C EndIf
C Eval Rrn3 = Rrn3 + 1
C Write SFL3
E003 C EndIf
* Bump up the counter & offset for the next entry
C Eval ListOffset = ListOffset + EntrySize
C Eval CurrentEnt = CurrentEnt + 1
E002 C EndDo
E001 C EndIf
*
C EndSr
**********************************************************************************************
* MassDelete: Mass delete selected reports
**********************************************************************************************
C MassDelete BegSr
* Only display subfile if records to show
C Eval *IN38 = Rrn2 > 0
C Eval *IN37 = *on
C Eval CSRCOL = 2
C Eval CSRLIN = 1
* Display command key text
B001 C DoU *IN12
C Write FOOTER2
C Write MSFLC MSG SUBFILE
C Write HEADER2
B002 C Select
S002 C When SpoolView = 1
C ExFmt SFLCTL2
S002 C When SpoolView = 2
C ExFmt SFLCTL4
S002 C When SpoolView = 3
C ExFmt SFLCTL5
E002 C EndSl
C Call 'DBG045CL' 90 REMOVE MSGS
B002 C Select
* F1/Help pressed
S002 C When *IN01 = *on
* Call the Helptext Viewer
C Call 'GSRDDT10' 90 Trap errors
C Parm PGM P_Pgm
* F11=View 1/2/3 pressed
S002 C When *IN11 = *on
C Eval SpoolView = SpoolView + 1
B003 C If SpoolView > 3
C Eval SpoolView = 1
E003 C EndIf
* Enter=Confirm Delete pressed
S002 C When *IN12 = *off
C and Rrn2 > 0
C Eval Nb2Dlt = Rrn2
B003 C 1 Do Nb2Dlt RcdNbr
C RcdNbr Chain SFL2 80
B004 C If *IN80 = *off
C Move SPLNBR P_SplNbr
C Call 'DBG187CL' 90
C Parm SPLNAME
C Parm SPLJOBNAME
C Parm SPLUSERPRF
C Parm SPLJOBNBR
C Parm P_SplNbr
C Parm '4' SSEL
C Parm ' ' P_BatchFile
C Parm ' ' P_StmfDir
C Parm ' ' P_FTPDir
C Parm ' ' P_RemoteMach
C Parm ' ' P_RemoteUser
C Parm ' ' P_RemotePass
C Parm ' ' P_PCFileExt
C Parm ' ' P_Format
C Parm ' ' P_FileName
C Parm ' ' P_HTMLTitle
*
E004 C EndIf
*
E003 C EndDo
C Eval RefreshRqd = *on
C Leave
E002 C EndSl
E001 C EndDo
* Reset the relative record number & clear the subfiles
C Eval *IN38 = *off
C Eval Rrn2 = 0
C Write SFLCTL2
C Eval Rrn4 = 0
C Write SFLCTL4
C Eval Rrn5 = 0
C Write SFLCTL5
*
C Move *off SpoolDlt
C Move *on Reload
*
C EndSr
**********************************************************************************************
* SearchSpool: Search spoolfiles for a string
**********************************************************************************************
C SearchSpool BegSr
*
C Move SPLNBR P_SplNbr
C Call 'DBG195R4' 90
C Parm SPLNAME
C Parm SPLJOBNAME
C Parm SPLUSERPRF
C Parm SPLJOBNBR
C Parm P_SplNbr
C Parm SearchString P_SearchString
C Parm IgnoreCase P_IgnoreCase
C Parm *off P_Found
*
C Eval Selected = P_Found
*
C EndSr
**********************************************************************************************
* SaveSFLOpts: Save subfile options for current page
**********************************************************************************************
C SaveSFLOpts BegSr
*
B001 C If RcdsThisPage > 0
B002 C 1 Do RcdsThisPage SFLKey
C SFLKey Chain SFL 81
* Do while more selected records
B003 C If not *IN81 and SSEL <> *blanks
C Eval PcDtaqKey = %EDITC(LISTRRN : 'X')
C Eval LastOptionLine = SFLKey + 8
* Check if this record already has a dataqueue entry (read & ignore)
C Call (E) 'QRCVDTAQ'
C Parm PcDtaqName
C Parm PcDtaqLib
C Parm 7 PcDtaqLen
C Parm PcDtaQData
C Parm PcDtaqWait
C Parm 'EQ' PcDtaqKeyOrd
C Parm PcDtaqKeyLen
C Parm PcDtaqKey
C Parm PcDtaqSndLen
C Parm PcDtaqSndInf
* and post a new one on
C Eval DtaQSflOpt = SSEL
C Eval DtaQRRN = LISTRRN
C Eval PcDtaqKey = %EDITC(LISTRRN : 'X')
C Call (E) 'QSNDDTAQ'
C Parm PcDtaqName
C Parm PcDtaqLib
C Parm 7 PcDtaqLen
C Parm PcDtaQData
C Parm PcDtaqKeyLen
C Parm PcDtaqKey
C Eval SSEL = ' '
C Eval *IN51 = *off
C Eval *IN52 = *off
C Eval *IN53 = *off
*
B004 C Select
S004 C When SpoolView = 1
C Eval *IN51 = *on
S004 C When SpoolView = 2
C Eval *IN52 = *on
S004 C When SpoolView = 3
C Eval *IN53 = *on
E004 C EndSl
C Update SFL
E003 C EndIf
E002 C EndDo
E001 C EndIf
*
C EndSr
**********************************************************************************************
* GetSFLOpt: Get subfile option from dtaq
**********************************************************************************************
C GetSFLOpt BegSr
*
C Eval PcDtaqKey = %EDITC(ListRecNbr : 'X')
* Check if this record has a dataqueue entry
C Call (E) 'QRCVDTAQ'
C Parm PcDtaqName
C Parm PcDtaqLib
C Parm 7 PcDtaqLen
C Parm PcDtaQData
C Parm PcDtaqWait
C Parm 'EQ' PcDtaqKeyOrd
C Parm PcDtaqKeyLen
C Parm PcDtaqKey
C Parm PcDtaqSndLen
C Parm PcDtaqSndInf
* Set subfile option from returned data (if any)
B001 C If PcDtaqLen > 0
C Eval SSEL = DtaQSflOpt
X001 C Else
C Eval SSEL = *blanks
E001 C EndIf
*
C EndSr
**********************************************************************************************
* ReadDtaQRcd: Read Data queue entry & matching workfile record
**********************************************************************************************
C ReadDtaqRcd BegSr
* Get the next available record in RRN sequence
C Call (E) 'QRCVDTAQ'
C Parm PcDtaqName
C Parm PcDtaqLib
C Parm 7 PcDtaqLen
C Parm PcDtaQData
C Parm PcDtaqWait
C Parm 'GT' PcDtaqKeyOrd
C Parm PcDtaqKeyLen
C Parm *blanks PcDtaqKey
C Parm PcDtaqSndLen
C Parm PcDtaqSndInf
* Set subfile option from returned data (if any)
B001 C If PcDtaqLen > 0
C Eval MoreDtaQRcds = *on
C Eval SSEL = DtaQSflOpt
C DtaQRRN Chain DBG1860W
X001 C Else
C Eval MoreDtaQRcds = *off
E001 C EndIf
*
C EndSr
**********************************************************************************************
* Inits: Program initialisation
**********************************************************************************************
C Inits BegSr
* INITIALIZE
C In COMPNY
C In DefaultDir
C Eval STMFDIR = DefaultDir
* Clear the delete screen first time round
C Eval Rrn2 = 0
C Eval Rrn4 = 0
C Eval Rrn5 = 0
C Eval *IN54 = P_LmtCpb = '*NO'
B001 C If P_LmtCpb = '*NO'
C Eval DA_STMFDIR = GreenULine
X001 C Else
C Eval DA_STMFDIR = GreenProtect
E001 C EndIf
C Eval DA_SELUSER = GreenULine
C Eval *IN38 = *off
C Eval F16STS = 'Find subset *OFF*'
C Eval IGNORE = 'N'
C Eval OUTQUE = %SUBST(P_QualOutQ:1:10)
C Usrprf Chain (N) DBGWUS00
B001 C If %FOUND(DBGWUS00)
C Eval STMFDIR = USSDIR
C Eval PCFILEEXT = USFEXT
C Eval FORMAT = USFMTO
C Eval FTPLOG = USFTPL
C Eval OVERPROMPT = USOPMT
C Eval FTPDIR = USFDIR
C Eval BATCHFILE = USRSCP
C Eval REMOTEMACH = USRMCH
C Eval REMOTEUSER = USRUSR
C Down:Up Xlate USRPWD REMOTEPASS
C Eval CONFRMPASS = REMOTEPASS
X001 C Else
C Eval STMFDIR = DefaultDir
C Eval PCFILEEXT = '.txt'
C Eval FORMAT = 'Y'
C Eval FTPLOG = 'Y'
C Eval OVERPROMPT = 'Y'
E001 C EndIf
C Eval OPTXT1 = OpText1
C Eval OPTXT2 = OpText2
C Write SFLCTL2
C Eval SpoolDlt = *off
C Eval ListBuilt = *off
* Set user restrictor to current profile if in "WRKSPLF mode"
B001 C If OUTQUE = '*USRSPLF'
B002 C If P_LmtCpb = '*YES'
C Eval DA_SELUSER = GreenProtect
E002 C EndIf
C Eval SELUSER = P_User
E001 C EndIf
*
C Call 'DBG045CL' 90 Remove msgs
*
C EndSr
**********************************************************************************************
* SndMsg: Send Program message
**********************************************************************************************
C SndMsg BegSr
*
C Call 'DBG044R3'
C Parm MsgID
C Parm 'DBGMSGF' MsgFil
C Parm '*LIBL' MsgLib
C Parm MsgDta
C Parm DtaLen
C Parm '*INFO' MsgTyp
C Parm PGM Pgmq
C Parm PgmStk
C Parm ' ' Errid
*
C EndSr
**********************************************************************************************
Edit | Attach | Print version | History: r2 < r1 | Backlinks | View wiki text | Edit wiki text | More topic actions
Topic revision: r2 - 01 Oct 2014 - 19:37:01 - UnknownUser
Site Map
DBG400
Copyright © by the contributing authors. All material on this collaboration platform is the property of the contributing authors. Ideas, requests, problems regarding DBG/400? Send feedback