RPG IV Source, SPR201



RPG IV Source, SPR201

H dftactgrp(*no)

H actgrp(*CALLER)

H option(*NODEBUGIO:*SrcStmt)

F****************************************************************

F* SPR201 - Display outq, allow email/fax/print of spool files *

F****************************************************************

FSPF201 CF E Workstn

F Sfile(Detail:rrn1)

F Sfile(EmlDtl:rrn2)

D******************

D* Work fields *

D******************

D Msg S 75 Dim(12) CtData PerRcd(1)

D CmdMsg S 50 Dim(2) CtData PerRcd(1)

D Cmd S 256

D CmdLen S 15 5

D Count S 5 0

D EmailFlag S 1 Inz('N')

D IpNewOutq S 10

D Ix S 3 0

D JobInfo S 26

D OpFile S 10

D OpFax# S 15

D OpFaxExtn S 4

D OpOutq S 20

D OpSpoolNbr S 6

D Rrn1 S 4 0

D Rrn2 S 4 0

D MoveFmtLen S 10I 0

D MoveFmtName S 8

D SpoolAttLen S 10I 0

D SpoolFmtNam1 S 8

D SpoolFmtNam2 S 8

D SpoolFName S 10

D SpoolFNbr S 10I 0

D SpaceAuth S 10 Inz('*ALL ')

D SpaceDomain S 10 Inz('*USER ')

D SpaceExtAtt S 10

D SpaceInit S 1 inz(x'00')

D SpaceName S 20 Inz('MOVSPLF QTEMP ')

D SpaceRepl S 10 Inz('*YES ')

D SpaceRtvLen S 10I 0

D SpaceSize S 10I 0

D SpaceStrPos S 10I 0

D SpaceText S 50 Inz('MOVE SPOOL FILES')

D SpoolsMax S 1350

D UsersName S 10

D UserFormTyp S 10

D UserData S 10

D Subject S 70

D SenderName S 50

D SenderAddr S 50

D EdtFMbr S 4

D ImportNc S 4 Inz('*MED')

D Priority S 4 Inz('*NRM')

D Sensitiv S 4 Inz('*NRM')

D ReplyTo S 50 Inz('*FROMADDR')

D Receipt S 4 Inz('*NO')

D Savedir S 60 Inz('*NONE')

D PDFSavedir S 60 Inz('*NONE')

D******************

D* Data structures*

D******************

D ToList DS

D NbrTo 1 2b 0

D ToArr 104a Dim(50)

D DS

D ToElem 1 104a

D toccbcc 1 1a

D toname 5 54a

D toaddr 55 104a

D*

D SplFList DS

D NbrSplF 1 2b 0

D SplFArr 44a Dim(50)

D DS

D SplFElem 1 44a

D SplF 1 10a

D JobNam 11 20a

D JobUsr 21 30a

D JobNbr 31 36a

D SplFNbrX 37 40b 0

D CvtPdf 41 44a

D MsgM ds

D MsgMMbr 1 10a

D MsgMFil 11 20a

D MsgMLib 21 30a

D*

D/Include QSYSINC/QRPGLESRC,QUSGEN

D/Include QSYSINC/QRPGLESRC,QUSLSPL

D/Include QSYSINC/QRPGLESRC,QUSRSPLA

D/Include QSYSINC/QRPGLESRC,QSPMOVSP

D****************************************************************

D*RECORD STRUCTURE FOR ERROR CODE PARAMETER *

D*NOTE: THE FOLLOWING TYPE DEFINITION ONLY DEFINES THE FIXED *

D* PORTION OF THE FORMAT. VARYING LENGTH FIELD EXCEPTION *

D* DATA WILL NOT BE DEFINED HERE. *

D****************************************************************

DQUSEC DS

D* Qus EC

D QUSBPRV 1 4B 0

D* Bytes Provided

D QUSBAVL 5 8B 0

D* Bytes Available

D QUSEI 9 15

D* Exception Id

D QUSERVED 16 16

D* Varying length

D ERRDTA 17 116

C******************

C* Entry parameters

C******************

C *Entry Plist

C Parm IpNewOutq

C******************

C* Initialization *

C******************

C Emails Plist

C Parm Subject

C Parm SenderName

C Parm SenderAddr

C Parm ToList

C Parm SplFList

C Parm MsgM

C Parm EdtFMbr

C Parm ImportNc

C Parm Priority

C Parm Sensitiv

C Parm ReplyTo

C Parm Receipt

C Parm Savedir

C Parm PDFSavedir

C*

C Eval WNOUTQ = IpNewOutq

C Eval *IN(*) = '0'

C Eval *IN32 = '1'

C Eval Rrn1 = 0

C Exsr Build

C****************************************************************

C* Mainline processing *

C****************************************************************

C Dow *IN03 = '0'

C Write FOOTER

C Exfmt HEADER

C Eval ERRMSG = *Blanks

C*

C Select

C* Exit....

C When *IN03 = '1'

C* Any moves...

C When Rrn1 > 0

C Exsr Check

C If ERRMSG = *Blanks

C Exsr Build

C Endif

C* Reload data...

C Other

C Exsr Build

C Endsl

C Enddo

C* Finished...

C Eval *INLR = '1'

C****************************************************************

C* Build - Load anything in the selected outq. *

C****************************************************************

C Build Begsr

C If ERRMSG = *Blanks

C*

C Eval WCPICK = *Blanks

C Eval *IN31 = '0'

C Eval *IN32 = '0'

C Eval *IN38 = '0'

C Write Header

C Eval Rrn1 = 0

C Eval *IN32 = '1'

C Clear QUSEC

C Eval Qusbprv = 100

C Eval Qusbavl = 100

C* Create user space...

C Call 'QUSCRTUS'

C Parm SpaceName

C Parm *Blanks SpaceExtAtt

C Parm 1024 SpaceSize

C Parm SpaceInit

C Parm SpaceAuth

C Parm SpaceText

C Parm SpaceRepl

C Parm QUSEC

C Parm SpaceDomain

C* Fill with outq data...

C Call 'QUSLSPL '

C Parm SpaceName

C Parm 'SPLF0100' SpoolFmtNam1

C Parm '*CURRENT' UsersName

C Parm '*ALL ' opoutq

C Parm '*ALL ' UserFormTyp

C Parm '*ALL ' UserData

C Parm QUSEC

C* Get data from user space....

C Eval SpaceRtvLen = 140

C Eval SpaceStrPos = 1

C Call 'QUSRTVUS'

C Parm SpaceName

C Parm SpaceStrPos

C Parm SpaceRtvLen

C Parm Qush0100

C Parm QUSEC

C* Setup extract parms...

C Eval SpaceStrPos = (Qusold + 1)

C Eval SpaceRtvLen = Qussee

C Eval SpoolAttLen = 209

C Eval Count = 1

C* Pull out info loop....

C Dow COUNT 0

C Eval NbrSplf= Ix

C* Use validity checker...

C Call(e) 'EMLSPLVCKR' Emails

C* Ok?...

C If Not %ERROR

C Call 'EMLSPL ' Emails

C Leave

C Else

C Eval ERRMSG2 = Msg(11)

C Endif

C Endif

C Endif

C*

C Enddo

C Endsr

C****************************************************************

C* SendFax - Take selection to Fax. *

C****************************************************************

C SendFax Begsr

C Dow *IN03 = '0'

C Exfmt FAXPMT

C Eval ERRMSG2 = *Blanks

C*

C Select

C When *IN03 = '1'

C Eval *IN03 = '0'

C Leave

C*

C When WBFAX# = 0

C Eval ERRMSG2 = Msg(10)

C Other

C Eval OpFax# = %Trim(%Editc(WBFAX#:'4'))

C If WBFEXT > 0

C Eval OpFaxExtn = %Char(WBFEXT)

C Endif

C Eval OpSpoolNbr = %Char(FLENBR)

C Call 'SPC200F '

C Parm OpFax#

C Parm OpFaxExtn

C Parm WBLDIST

C Parm REPORT OpFile

C Parm JOB

C Parm JOBNBR

C Parm USER

C Parm OpSpoolNbr

C Leave

C Endsl

C Enddo

C Endsr

C****************************************************************

C* Show - Display theo spool file. *

C****************************************************************

C Show Begsr

C Eval Cmd = 'DSPSPLF FILE(' + %Trim(REPORT) +

C ') JOB(' + JOBNBR + '/' +

C %Trim(USER) + '/' + %Trim(JOB) +

C ') SPLNBR(' + %Editc(FLENBR:'X') + ')'

C Eval CmdLen = %Checkr(' ':Cmd)

C Call 'QCMDEXC ' 99

C Parm Cmd

C Parm CmdLen

C Endsr

C****************************************************************

** Msg

1 - Missing or Invalid From Outq Name. Please correct and try again.

2 - Missing or Invalid New Outq Name. Please correct and try again.

3 - Email subject is required.

4 - Email FROM name is required.

5 - Email FROM address is required.

6 - Invalid FROM email account. Must contain the @ sign.

7 - Email TO name is required.

8 - Email TO address is required.

9 - Invalid TO email account. Must contain the @ sign.

10 - Fax number is 0 or missing.

11 - Email Info failed validity check. See job log.

12 - Type of Delivery must be *TO, *CC, *BCC.

** CmdMsg

CHKOBJ OBJ(*LIBL/

OBJTYPE(*OUTQ)

DDS for display file SPF201

A

A DSPSIZ(24 80 *DS3)

A REF(*LIBL/OIFREF)

A CHGINPDFT(HI UL)

A PRINT

A ENTFLDATR((*COLOR YLW) (*DSPATR UL))

A CA03(03)

A R DETAIL SFL

A 38 SFLNXTCHG

A WCPICK 1A B 9 3

A 31 DSPATR(PC)

A REPORT 10 O 9 5

A 41 COLOR(TRQ)

A 42 COLOR(YLW)

A 43 COLOR(RED)

A JOB 10A O 9 16

A USER 10A O 9 27

A JOBNBR 6A O 9 38

A FLENBR 6Y 0O 9 45EDTCDE(4)

A FORMTP 10A O 9 52

A USRDTA 10A O 9 63

A PAGES 5Y 0O 9 74EDTCDE(4)

A R HEADER SFLCTL(DETAIL)

A SFLSIZ(0100)

A SFLPAG(0012)

A OVERLAY

A 31 SFLDSP

A 32 SFLDSPCTL

A N32 SFLCLR

A N34 SFLEND(*MORE)

A 1 2USER

A 1 22'List of Spool Files to Print/Fax/E-

A mail'

A DSPATR(HI)

A DSPATR(UL)

A 1 71DATE

A EDTCDE(Y)

A 2 71TIME

A 4 12'Move Selected to New Outq:'

A WNOUTQ 10A B 4 39

A 6 5'Options:'

A 6 15'1=Move to Outq'

A COLOR(BLU)

A DSPATR(UL)

A 6 33'2=Email'

A COLOR(BLU)

A DSPATR(UL)

A 6 44'3=Fax'

A COLOR(BLU)

A DSPATR(UL)

A 6 53'5=Display'

A DSPATR(UL)

A COLOR(BLU)

A 8 2'Opt Report Nm Job Name User Name-

A Job # Splf # Form Type User Dat-

A a Pages'

A DSPATR(HI)

A DSPATR(UL)

A*

A R FOOTER

A 23 4'F3=Exit'

A 23 38'Press enter to Process Selections'

A ERRMSG 75A O 24 3DSPATR(HI)

A R EMLDTL SFL

A 68 SFLNXTCHG

A 9 4'Type of Email..:'

A WBTYPE 4A B 9 21

A 9 27'(*TO *CC *BCC)'

A 10 4'To User Name:..:'

A WBTONME 30A B 10 21

A 11 4'To User Address:'

A WBMAIL 40A B 11 21CHECK(LC)

A R EMLHDR SFLCTL(EMLDTL)

A SFLSIZ(0020)

A SFLPAG(0001)

A WINDOW(EMLFTR)

A OVERLAY

A 61 SFLDSP

A 62 SFLDSPCTL

A N61 SFLINZ

A N64 SFLEND(*MORE)

A 1 2USER

A 1 20'Enter Email Addressing Information'

A DSPATR(UL)

A DSPATR(HI)

A 1 57'(SPR201)'

A 3 2'From:'

A DSPATR(UL)

A 4 2'Email Subject.:'

A WBSUBJ 40A B 4 18

A 5 2'From User Name:'

A WBFRMNME 30A B 5 18

A 6 2'From User Addr:'

A WBFRMADR 40A B 6 18CHECK(LC)

A 8 2'To:'

A DSPATR(UL)

A 8 7'(Page down for More...)'

A DSPATR(HI)

A R EMLFTR

A OVERLAY

A WINDOW(3 8 18 65 *NOMSGLIN)

A WDWBORDER((*COLOR BLU) (*DSPATR RI)-

A (*CHAR ' '))

A 13 2'Message Body Source Member:'

A WBMBNM 10 B 13 30

A 13 41'(*TEMP, *NONE, Name)'

A 14 2'Message Body Source File Name:'

A WBFNAM 10 B 14 33

A 14 44'Library:'

A WBLNAM 10 B 14 53

A 15 2'Edit Message Source Member:'

A WBEDIT 1 B 15 30

A 15 33'( Y or N)'

A 17 2'F3=Exit'

A 17 14'Press Enter to Send Email'

A 17 45'Page Down for More'

A ERRMSG2 58A O 18 1DSPATR(HI)

A R FAXPMT

A WINDOW(5 8 15 60 *NOMSGLIN)

A WDWBORDER((*COLOR BLU) (*DSPATR RI)-

A (*CHAR ' '))

A 1 16'Enter Fax Number Information'

A DSPATR(UL)

A DSPATR(HI)

A 1 52'(SPF201)'

A 5 3'Number to Fax to:'

A WBFAX# 15Y 0B 5 21EDTCDE(4)

A 5 38'Extension:'

A WBFEXT 4Y 0B 5 49EDTCDE(4)

A 5 54'(Opt.)'

A 7 4'Is this Long Distance?'

A WBLDIST 1A B 7 28VALUES('Y' 'N')

A 13 20'Press Enter to Send Fax'

A 14 2'F3=Exit'

A ERRMSG2 58A O 15 1DSPATR(HI)

CMD source for SPR201

CMD PROMPT('Spool File Utilities Prompt')

PARM KWD(NEWOUTQ) TYPE(*CHAR) LEN(10) +

CHOICE('Valid Outq Name') +

PROMPT('Destination Outq Name . . . .:')

CL source for external fax processing

PGM PARM(&FAX# &EXTN &LONGD &FILE &JOBNAME +

&JOBNBR &USERNAME &SPLNBR)

DCL VAR(&DIAL#) TYPE(*CHAR) LEN(25)

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

DCL VAR(&FAX#) TYPE(*CHAR) LEN(15)

DCL VAR(&FILE) TYPE(*CHAR) LEN(10)

DCL VAR(&LONGD) TYPE(*CHAR) LEN(1)

DCL VAR(&JOBNAME) TYPE(*CHAR) LEN(10)

DCL VAR(&USERNAME) TYPE(*CHAR) LEN(10)

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

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

DCL VAR(&PIN#) TYPE(*CHAR) LEN(4) VALUE('0517')

/* IS LONG DISTANCE..... */

IF COND(&LONGD = 'Y') THEN(DO)

IF COND(&EXTN = ' ') THEN(DO)

CHGVAR VAR(&DIAL#) VALUE('+1' *CAT &Fax# *TCAT +

'?' *TCAT &PIN#)

ENDDO

ELSE CMD(DO)

CHGVAR VAR(&DIAL#) VALUE('+1' *CAT &Fax# *TCAT +

'?' *TCAT &PIN# *TCAT '%%' *TCAT &EXTN)

ENDDO

ENDDO

/* NOT LONG DISTANCE..... */

ELSE CMD(DO)

IF COND(&EXTN = ' ') THEN(DO)

CHGVAR VAR(&DIAL#) VALUE('+' *CAT &Fax#)

ENDDO

ELSE CMD(DO)

CHGVAR VAR(&DIAL#) VALUE('+' *CAT &Fax# *TCAT +

'%%' *TCAT &EXTN)

ENDDO

ENDDO

SNDFAX TO((&DIAL#)) FILE(&FILE) +

JOB(&JOBNBR/&USERNAME/&JOBNAME) +

SPLNBR(&SPLNBR) MODE(*NORMAL)

DLYJOB DLY(3)

ENDPGM

................
................

In order to avoid copyright disputes, this page is only a partial summary.

Google Online Preview   Download