Tweet
H dftactgrp( *no ) OPTION(*NODEBUGIO)
H ALWNULL(*USRCTL)
H BNDDIR('HTTPAPI':'QC2LE')
//********************************************************************
fsyusers if e k disk usropn
fsywhses if e k disk usropn
fsyscontrolif e k disk usropn
// --------------------- Prototypes --------------------
*------------------------------------------------------------
* Close Directory
*------------------------------------------------------------
d closedir pr * EXTPROC('closedir')
d dirname * VALUE
d $command pr extpgm('QCMDEXC')
d command_ 5000
d Length_ 15 5
d Incoming pr
d rate_ 8F
d depth_ 10I 0 value
d name_ 1024A varying const
d path_ 24576A varying const
d value_ 65535A varying const
d attrs_ * dim(32767)
d const options(*varsize)
*------------------------------------------------------------
* Open a Directory
*------------------------------------------------------------
d opendir pr * EXTPROC('opendir')
d dirname * VALUE
*
* API - List spooled files
*
d QUSLSPL pr extpgm('QUSLSPL')
* required parameters
d UsrSpc_ 20A const
d Format_ 8A const
d UserName_ 10A const
d QualOutQ_ 20A const
d FormType_ 10A const
d UserData_ 10A const
* optional group 1:
d ErrorCode_ 32766A options(*nopass: *varsize)
* optional group 2:
d QualJob_ 26A options(*nopass) const
d FieldKeys_ 10I 0 options(*nopass: *varsize)
d dim(9999)
d NumFields_ 10I 0 options(*nopass) const
* optional group 3:
d AuxStgPool_ 10I 0 options(*nopass) const
* optional group 4:
d JobSysName_ 8A options(*nopass) const
d StartCrtDate_ 7A options(*nopass) const
d StartCrtTime_ 6A options(*nopass) const
d EndCrtDate_ 7A options(*nopass) const
d EndCrtTime_ 6A options(*nopass) const
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)
d QUSPTRUS pr extpgm('QUSPTRUS')
d UsrSpc_ 20A const
d Pointer_ *
d QUSDLTUS pr extpgm('QUSDLTUS')
d UsrSpc_ 20A const
d ErrorCode_ 32766A options(*varsize)
d $ReadDataq pr extpgm('QRCVDTAQ')
d queuename_ 10 const
d queuelibrary_ 10 const
d queuesize_ 5 0 const
d queuemessage_ 128 const
d queuewait_ 5 0 const
d $Rtvsplfa pr extpgm('QUSRSPLA')
d rcvvar_ const like(rcvvar)
d rcvlen_ const like(rcvlen)
d fmtnm_ 8 const
d jobid_ 26 const
d intjob_ 16 const
d intspl_ 16 const
d splf_ const like(splf)
d bsplf#_ const like(bsplf#)
*------------------------------------------------------------
* Read Directory Entry
*------------------------------------------------------------
d readdir pr * EXTPROC('readdir')
d dirname * VALUE
d $SendEmail pr ExtPgm('SETEMAILQ')
d DataDS_ Const LikeDS(EmailDS)
d SysCmd pr 10I 0 extproc('system')
d * value
d options(*string)
D unlink PR 10I 0 ExtProc('unlink')
D path * Value options(*string)
/copy httpapi_h
// ------------------Program Interface---------------------
// ----------------------- Arrays -------------------------
// ------------------- Data Structures --------------------
d dsEC ds qualified
d BytesProvided 10I 0 inz(%size(dsEC))
d BytesAvail 10I 0 inz(0)
d MessageID 7A
d Reserved 1A
d MessageData 240A
d dsLH DS based(p_UsrSpc)
d qualified
d Filler1 103A
d Status 1A
d Filler2 12A
d HdrOffset 10I 0
d HdrSize 10I 0
d ListOffset 10I 0
d ListSize 10I 0
d NumEntries 10I 0
d EntrySize 10I 0
d dsSF ds based(p_Entry)
d qualified
d JobName 10A
d UserName 10A
d JobNumber 6A
d SplfName 10A
d SplfNbr 10I 0
d SplfStatus 10I 0
d OpenDate 7A
d OpenTime 6A
d Schedule 1A
d SysName 10A
d UserData 10A
d FormType 10A
d OutQueue 10A
d OutQueueLib 10A
d AuxPool 10I 0
d SplfSize 10I 0
d SizeMult 10I 0
*
d TotalPages 10I 0
d CopiesLeft 10I 0
d Priority 1A
d Reserved 3A
d EmailDS ds Inz Qualified
d UserTrackingId...
d 15A
d FailureEmail 60A
d attachmentLocation...
d 120A
d EMailTo 120A
d EMailSubject 80A
d EMailFromAlias...
d 50A
d EMailCC 60A
d EMailBody 1024A
d p_dirent s *
d dirent ds based(p_dirent)
d d_reserv1 16A
d d_reserv2 10U 0
d d_fileno 10U 0
d d_reclen 10U 0
d d_reserv3 10I 0
d d_reserv4 8A
d d_nlsinfo 12A
d nls_ccsid 10I 0 OVERLAY(d_nlsinfo:1)
d nls_cntry 2A OVERLAY(d_nlsinfo:5)
d nls_lang 3A OVERLAY(d_nlsinfo:7)
d nls_reserv 3A OVERLAY(d_nlsinfo:10)
d d_namelen 10U 0
d d_name 640A
d SpoolInfo ds
d Function 10
d RecordType 2
d QualJobName 26
d JobName 10 Overlay(QualJobName:1)
d JobUser 10 Overlay(QualJobName:11)
d JobNumber 6 Overlay(QualJobName:21)
d FileName 10
d FileNumber 10i 0
d QualQueueName 20
d QueueName 10 Overlay(QualQueueName:1)
d QueueLibrary 10 Overlay(QualQueueName:11)
d Filler 56
d* QUSRSPLA - LIST SPOOL FILE ATRIBUTES API
d*
d RCVVAR ds INZ
d BYTRTN 1 4B 0
d BYTVAL 5 8B 0
d SPLFID 25 40
d JOBNAM 41 50
d USRNAM 51 60
d JOBNUM 61 66
d FILNAM 67 76
d FILNUM 77 80B 0
d FRMTYP 81 90
d USRDTA 91 100
d USRDFNDTA 1157 1411
* DEFINE BINANRY NUMBERS
d ds
d RCVLEN 1 4B 0
* DEFINE CONSTANTS
* DATA QUEUE LAYOUT
d QDATA DS 128 INZ
d RCDID 1 10
d* 11 12 ??
d JOBID 13 38
d JOBNM 13 22
d JOBUSR 23 32
d JOBNBR 33 38
d SPLF 39 48
d BSPLF# 49 52B 0
d OUTQ 53 62
d OTQLIB 63 72
// ---------------- Standalone Variables ------------------
d Cmdlength s 15 5 inz
d CmdString s 5000 inz
d emailaddress s 256a varying
d dh s *
d EmailUser s 10 inz
d folderpathkeyhex...
d s 256 inz
d folderpathkey s 256a inz
d foundit s 10i 0 inz
d ifsFileName s 256 varying
d wkFileName s 256 varying
d LwrSplFName s 10 inz
d myprogram s 10 inz('PDFOUTQ')
d mysaveoption s 10 inz
d myspoolpath s 256 inz
d MyUserName s 10 inz
d MyUserData s 10 inz
d p_Entry s *
d p_UsrSpc s *
d portalID s 10 inz
d rate s 8F
D rc s 10I 0
d size s 10I 0
d sf s 10I 0 inz(1)
d soap s 32767A varying
d IFSpath s like(SYVALUEC)
d Up c CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
d uprsplfname s 10a
d FMTNM s 8a
d INTJOB s 16a
d INTSPL s 16a
// ---------------------- Constants -----------------------
d Quote c Const('''')
d myspace c const('SPLFLIST QTEMP ')
// --------------------- Indicators -----------------------
d FileExists s n inz
d keeplooping s n inz('1')
/free
//********************************************************************
// Global SQL Set-Up *
//-------------------------------------------------------------------*
exec sql set option commit=*none,datfmt=*iso,
closqlcsr=*ENDMOD;
//********************************************************************
// M A I N L I N E *
//-------------------------------------------------------------------*
dow KeepLooping;
$ReadDataq('PDFOUTQ':'*LIBL':128: SpoolInfo: -1);
if not %open(syusers);
open syusers;
endif;
if not %open(sywhses);
open sywhses;
endif;
if not %open(syscontrol);
open syscontrol;
endif;
// get spool file information
clear emailuser;
clear myuserdata;
exsr $getspoolinfo;
// Create physical file
cmdstring = 'CRTPF FILE(QTEMP/MYSPOOL) RCDLEN(134)' +
' SIZE(2500000 10000)';
cmdlength = %len(cmdstring);
monitor;
$command(cmdstring: cmdlength);
on-error;
endmon;
// CPYSPLF FILE(NPOSCURJ) TOFILE(QTEMP/QPRINT)
// JOB(071655/xxxxxxxx/QPADEV000N) SPLNBR(2) CTLCHAR(*FCFC)
cmdstring = 'CPYSPLF FILE(' + %trim(FileName) +
') TOFILE(QTEMP/MYSPOOL)' + ' JOB(' +
%trim(JobNumber) + '/' + %trim(JobUser) + '/' +
%trim(JobName) + ') SPLNBR(' + %trim(%char(FileNumber)) +
') CTLCHAR(*FCFC)';
cmdlength = %len(cmdstring);
monitor;
$command(cmdstring: cmdlength);
on-error;
endmon;
exsr $usrfilnam;
if myspoolpath = *blanks;
myspoolpath = '/tmp/' + %trim(filename) + %trim(myusername)+
%trim(%char(%timestamp())) + '.pdf' ;
endif;
// OVRPRTF FILE(QPRINT) TOFILE(QPRINT) DEVTYPE(*AFPDS) TOSTMF(MYSTREAMFILE) WSC
cmdstring = 'OVRPRTF FILE(QPRINT) TOFILE(QPRINT) DEVTYPE(*AFPDS)' +
' TOSTMF(' + Quote + %trim(myspoolpath) + Quote + ') ' +
' WSCST(*PDF) OVRSCOPE(*JOB) CTLCHAR(*FCFC)' +
' PAGESIZE(*N 132) CPI(10)';
cmdlength = %len(cmdstring);
monitor;
$command(cmdstring: cmdlength);
on-error;
endmon;
// CPYF FROMFILE(QTEMP/MYSPOOL) TOFILE(QPRINT)
cmdstring = 'CPYF FROMFILE(QTEMP/MYSPOOL) TOFILE(QPRINT)';
cmdlength = %len(cmdstring);
monitor;
$command(cmdstring: cmdlength);
on-error;
endmon;
// DLTOVR FILE(QPRINT)
cmdstring = 'DLTOVR FILE(QPRINT) LVL(*JOB)';
cmdlength = %len(cmdstring);
monitor;
$command(cmdstring: cmdlength);
on-error;
endmon;
// Check for IFS path
exsr $ChkIFS;
// Send report in email
if IFSpath = *Blanks;
exsr $SendPDF;
endif;
// if here email sent or placed in IFS so lets delete the original spooled file
// DLTSPLF FILE(QPSRVDMP) JOB(074332/xxxxxxxx/QPADEV000B) SPLNBR(1)
SysCmd('DLTSPLF FILE(' + %trim(filename) + ') JOB(' +
%trim(jobnumber) + '/' + %trim(jobuser) + '/' + %trim(jobname) +
') SPLNBR(' + %char(filenumber) + ')' );
if %open(syusers);
close syusers;
endif;
if %open(sywhses);
close sywhses;
endif;
if %open(syscontrol);
close syscontrol;
endif;
enddo;
*inlr = *on;
//********************************************************************
// Get Destination file name from user *
//-------------------------------------------------------------------*
BegSr $usrfilnam;
clear rcvvar;
myspoolpath = *blanks;
wkfilename = *blanks;
RCVLEN = 1537;
FMTNM = 'SPLA0100';
JOBID = QualJobName;
INTJOB = *Blanks;
INTSPL = *Blanks;
SPLF = FileName;
BSPLF# = FileNumber;
$Rtvsplfa(RCVVAR:RCVLEN:FMTNM:JOBID:INTJOB:INTSPL:SPLF:BSPLF#);
wkfilename = %trim(usrdfndta);
if (wkfilename <> *Blanks and wkfilename <> '*NONE');
myspoolpath = '/tmp/' + %trim(wkfilename) +
'.pdf' ;
endif;
Endsr;
//********************************************************************
// Get Spool File Information *
//-------------------------------------------------------------------*
BegSr $GetSpoolInfo;
// set this to zero to let OS/400 handle errors
dsEC.BytesProvided = 0;
// Make space for (approx) 1000 spooled files to be listed
size = %size(dsLH) + 512 + (%size(dsSF) * 1000);
// Create a user space
// List spooled files to the user space
// Get a pointer to the returned user space
// Create a user space
QUSCRTUS(MYSPACE: 'USRSPC': size: x'00': '*ALL':
'Temp User Space for QUSLSPL API': '*YES': dsEC);
// List spooled files to the user space
QUSLSPL(MYSPACE: 'SPLF0300': jobuser : '*ALL':
'*ALL': '*ALL': dsEC);
// Get a pointer to the returned user space
QUSPTRUS(MYSPACE: p_UsrSpc);
// Loop through list, for each spooled file, display the
//Status: 1=RDY , 2=OPN, 3=CLO, 4=SAV, 5=WRT, 6=HLD,
// 7=MSGW, 8=PND, 9=PRT,10=FIN,11=SND,12=DFR
p_Entry = p_UsrSpc + dsLH.ListOffset;
sf = 1;
dow sf <= dsLH.NumEntries;
// currently only move status = 1 ready
clear myusername;
if dssf.jobnumber = jobnumber and
dssf.splfname = filename and
dssf.splfnbr = filenumber;
lwrsplfname = dssf.splfname;
exec sql values(lower(:lwrsplfname)) into :lwrsplfname;
exec sql values(upper(:lwrsplfname)) into :uprsplfname;
myusername = dssf.username;
myuserdata = dssf.userdata;
// grab the userdata and determine if this is valid user id
// if valid user ID then use this in place of spooled userid
// dssf.UserData
setll (dssf.UserData) syusers;
if %equal(syusers);
emailuser = dssf.UserData;
leave;
endif;
endif;
p_Entry = p_Entry + dsLH.EntrySize;
sf = (sf + 1);
enddo;
// delete user space
QUSDLTUS(MYSPACE: dsEC);
EndSr;
//********************************************************************
// Check if the PDF to be placed in IFS folder *
//-------------------------------------------------------------------*
BegSr $ChkIFS;
// Check for the IFS path to place the PDF file
IFSpath = *Blanks;
Setll (myprogram:myUserData) SYSCONTROL;
ReadE (myprogram:myUserData) SYSCONTROL;
Dow not %eof(SYSCONTROL);
IFSpath = %trim(SYVALUEC);
mysaveoption = 'DUPLICATE';
chain (uprsplfname:'SAVEOPTION') syscontrol;
if %found(syscontrol);
mysaveoption = syvaluec;
endif;
select;
when mysaveoption = 'KEEP';
// Add file if one does not exist already
exsr checkfile;
if not fileexists;
// CPY OBJ('/tmp/myspool.pdf') TODIR('/home');
cmdstring = 'CPY OBJ(' + Quote + %trim(myspoolpath) +
Quote + ') TODIR(' + Quote +
%trim(IFSpath) + Quote + ')';
cmdlength = %len(cmdstring);
monitor;
$command(cmdstring: cmdlength);
on-error;
endmon;
endif;
when mysaveoption = 'REPLACE';
// Delete old file if exist and add new one
exsr checkfile;
// CPY OBJ('/tmp/myspool.pdf') TODIR('/home');
cmdstring = 'CPY OBJ(' + Quote + %trim(myspoolpath) +
Quote + ') TODIR(' + Quote +
%trim(IFSpath) + Quote + ')';
cmdlength = %len(cmdstring);
monitor;
$command(cmdstring: cmdlength);
on-error;
endmon;
when mysaveoption = 'DUPLICATE';
// Add file
// CPY OBJ('/tmp/myspool.pdf') TODIR('/home');
cmdstring = 'CPY OBJ(' + Quote + %trim(myspoolpath) +
Quote + ') TODIR(' + Quote +
%trim(IFSpath) + Quote + ')';
cmdlength = %len(cmdstring);
monitor;
$command(cmdstring: cmdlength);
on-error;
endmon;
endsl;
ReadE (myprogram:myUserData) SYSCONTROL;
Enddo;
EndSr;
//********************************************************************
// Check for file. Delete when applicable.
//********************************************************************
BegSr checkfile;
folderpathkey = %trim(ifspath) + '/';
folderpathkeyhex = %trim(ifspath) + '/' + x'00';
// get the folder name -- this would be the 1 and only table in root
clear ifsfilename;
fileexists = *off;
// tables will hold all the names of the tables
// loop on the directory
// Step1: Open up the directory.
dh = opendir(%addr(folderpathkeyhex));
if dh <> *NULL;
// Step2: Read each entry from the directory (in a loop)
p_dirent = readdir(dh);
dow p_dirent <> *NULL;
if d_namelen < 256;
// set filename to lowercase
ifsFileName = %subst(d_name:1:d_namelen);
exec sql values(lower(:ifsfilename)) into :ifsfilename;
// Check for file. Delete when applicable.
if %scan(%trim(lwrsplfname):ifsFilename) > 0;
fileexists = *on;
if mysaveoption = 'REPLACE';
unlink(%trim(folderpathkey) + %trim(ifsfilename));
endif;
leave;
endif;
endif;
p_dirent = readdir(dh);
enddo;
endif;
endsr;
//********************************************************************
// Send PDF *
//-------------------------------------------------------------------*
BegSr $SendPDF;
if emailuser = *blanks;
emailuser = jobuser;
endif;
EMailDS.UserTrackingId = 'AutoGenPDF';
EMailDS.FailureEmail = *Blanks;
EMailDS.AttachmentLocation = myspoolpath;
// grab spooled file data to get userdata field
clear emailaddress;
exsr $getemailaddress;
if emailaddress = *blanks;
// grab branch and build email address
chain (emailuser) syusers;
if %found(syusers);
chain (tuwhse) sywhses;
if %found(sywhses);
emailaddress = 'MGR' + %EditC(swbrch : 'X') + '@XXXX.COM';
endif;
endif;
endif;
If emailaddress <> *Blanks;
// Set email addresses, subject, and body
EMailDS.EMailTo = emailaddress;
EMailDS.EMailSubject = 'XXXReport for ' + %trim(emailuser);
EMailDS.EMailFromAlias = 'XXX Supply';
EMailDS.EMailCC = *Blanks;
EMailDS.EMailBody = ' ' +
'' +
' ' +
'
Your spooled file is attached.' +
'';
monitor;
$sendemail(EmailDS);
on-error;
leavesr;
endmon;
Endif;
EndSr;
//********************************************************************
// Get Email Address *
//-------------------------------------------------------------------*
BegSr $GetEmailAddress;
http_debug(*ON);
http_XmlStripCRLF(*ON);
SOAP = *blanks;
If emailuser <> *Blanks;
PortalID = %trim(emailuser);
rc = http_url_post_xml(
'http://zzzzzz/' +
'yahoo_DirectoryServices/search/' +
'assoc?user_id=' + %trim(zzzzzzzzz) +
'&ldap=true'
: %addr(SOAP) + 2
: 0
: *NULL
: %paddr(Incoming)
: %addr(rate)
: HTTP_TIMEOUT
: HTTP_USERAGENT
: 'text/xml'
: ' ');
if (rc <> 1);
http_crash();
else;
endif;
endif;
EndSr;
/end-free
//********************************************************************
// P R O C E D U R E S *
//********************************************************************
p Incoming B
d Incoming PI
d rate 8F
d depth 10I 0 value
d name 1024A varying const
d path 24576A varying const
d value 65535A varying const
d attrs * dim(32767)
d const options(*varsize)
d atof PR 8F extproc('atof')
d string * value options(*string)
/free
if %scan('@':value ) > *zeros;
emailaddress = value;
endif;
/end-free
P E
Comment