Tweet
Here is a skelton program that uses dynamic SQl to load up a
subfile. It also has some internal procedures defined
as well as uses the API's QMHSNDPM & QMHRMVPM to send and
clear message from the programs message subfile.
last but not least it uses the hex codes for the function
key pressed.
subfile. It also has some internal procedures defined
as well as uses the API's QMHSNDPM & QMHRMVPM to send and
clear message from the programs message subfile.
last but not least it uses the hex codes for the function
key pressed.
PHP Code:
*
* PROGRAM - LOR01
* PURPOSE - Laborout Transaction maintenance
* WRITTEN - 01/12/2007
* AUTHOR - jamie
* PROGRAM DESCRIPTION
* This program will allow maintenance of Laborout PO's
*
* INDICATOR USAGE
* 03 - subfile end indicator
* 30 - subfile clear
* 31 - subfile display
* 32 - subfile display control
* 33 - subfile end
*--------------------------------------------------------
fLOR01AD cf e workstn INFDS(INFDS)
f SFILE(SUB01:RRN1)
*
* Variable Definition
*
d CmdLength s 15 5 inz(0)
d CmdString s 14000 inz(*blanks)
d EndScreen1 s 1 inz('N')
d ISodate s d
d LenStr s 4 0
d Lo c CONST('abcdefghijklmnopqrstuvwxyz')
d messagecsc s 10i 0
d messagedata s 80A
d messagekey s 4A
d messagelen s 10i 0
d messagefile s 20 inz('LBIMSG *LIBL')
d messageid s 7
d pos s 3 0
d Q s 1 inz('''')
d RRN1 s like(SCRRN)
d s1error s 1
d Savrrn s like(SCRRN)
d ScreenError s 1 inz('N')
d sql s 512
d Title s 40
d Up c CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
*
* Program Info
*
d SDS
d @PGM 001 010
d @PARMS 037 039 0
d @MSGDTA 91 170
d @MSGID 171 174
d @JOB 244 253
d @USER 254 263
d @JOB# 264 269 0
* Command Keys
d Cmd01 c const(x'31') Cmd-1
d Cmd02 c const(x'32') Cmd-2
d LeaveProgram c const(x'33') Cmd-3
d Cmd04 c const(x'34') Cmd-4
d Cmd05 c const(x'35') Cmd-5
d Cmd06 c const(x'36') Cmd-6
d Cmd07 c const(x'37') Cmd-7
d Cmd08 c const(x'38') Cmd-8
d Cmd09 c const(x'39') Cmd-9
d Cmd10 c const(x'3A') Cmd-10
d Cmd11 c const(x'3B') Cmd-11
d Cmd12 c const(x'3C') Cmd-12
d Cmd13 c const(x'B1') Cmd-13
d Cmd14 c const(x'B2') Cmd-14
d Cmd15 c const(x'B3') Cmd-15
d Cmd16 c const(x'B4') Cmd-16
d Cmd17 c const(x'B5') Cmd-17
d Cmd18 c const(x'B6') Cmd-18
d Cmd19 c const(x'B7') Cmd-19
d Cmd20 c const(x'B8') Cmd-20
d Cmd21 c const(x'B9') Cmd-21
d Cmd22 c const(x'BA') Cmd-22
d Cmd23 c const(x'BB') Cmd-23
d Cmd24 c const(x'BC') Cmd-24
d EnterKey c const(x'F1')
d RollUp c const(x'F5') Roll Up
d RollDown c const(x'F4') Roll Down
*
*
d Infds ds INFDS data structure
d Choice 369 369
d Currec 378 379I 0
*
d APIError ds Qualified
d BytesP 1 4I 0 inz(%size(apiError))
d BytesA 5 8I 0 inz(0)
d Messageid 9 15
d Reserved 16 16
d messagedta 17 256
d SQLData ds qualified
d po# 7 0
d counter 3 0
d description 30
d etadate 7 0
//
// external calls
//
d $command pr extpgm('QCMDEXC')
d command 5000 options(*varsize)
d Length 15 5
d $sendmsg PR ExtPgm('QMHSNDPM')
d MessageID 7A Const
d QualMsgF 20A Const
d MsgData 256A Const
d MsgDtaLen 10I 0 Const
d MsgType 10A Const
d CallStkEnt 10A Const
d CallStkCnt 10I 0 Const
d Messagekey 4A
d ErrorCode 256A
d $clearmsg pr extpgm('QMHRMVPM')
d messageq 276a const
d CallStack 10i 0 const
d Messagekey 4a const
d messagermv 10a const
d ErrorCode 256
//Procedures to process dynamic SQL
d openOrderList pr
d FetchNextOrder pr n
d closeOrderList pr
d Titletext pr 512A
d thestring 512A const
/copy qpgmsrc,pch1ctrl
/Free
//--------------------------------------------------------
// MAIN PROGRAM
//--------------------------------------------------------
exsr Hskpg;
exsr $clearsfl;
exsr $loadsfl;
exsr $Screen1;
*inlr = *on;
//--------------------------------------------------------
// $Screen1 - parameter screen
//--------------------------------------------------------
begsr $Screen1;
reset EndScreen1;
dow EndScreen1 = 'N';
if ScreenError = 'N';
exsr $clrmsg;
endif;
monitor;
write MSGCTL;
on-error;
endmon;
write FKEY01;
exfmt SUB01CTL;
exsr $clrmsg;
reset ScreenError;
select;
//
// F3 pressed end the program F3 = LeaveProgram
//
when Choice = LeaveProgram;
eval EndScreen1 = 'Y';
//
// Enter Key pressed
//
when Choice = enterKey;
exsr $Validate;
endsl;
enddo;
endsr;
//--------------------------------------------------------
// $Validate - Validate screen entries
//--------------------------------------------------------
begsr $Validate;
reset screenerror;
endsr;
//----------------------------------------
// $clearSfl - clear the subfile
//----------------------------------------
begsr $clearSFL;
clear s1opt;
// clear the subfile first
*in31 = *Off;
*in32 = *Off;
*in30 = *On;
write SUB01CTL;
clear s1error;
*in31 = *On;
*in32 = *On;
*in30 = *Off;
clear RRN1;
clear SCRRN;
clear SavRrn;
sql = 'Select LPPO#, LICNTP ,LPSPI, LIETA ' +
' from ' +
' LOPLPCH A left join LOILPCH b on ' +
' (A.LPPO# = B.LIPO#) ';
endsr;
//--------------------------------------------------------
// $loadsfl- load up the entire subfile
//--------------------------------------------------------
begsr $loadsfl;
if SavRrn > *zeros;
RRN1 = SavRrn;
SCRRN = SavRrn;
endif;
openOrderList();
Dow fetchNextOrder();
// start populate the subfile fields
s1po# = sqldata.po#;
s1seq# = sqldata.counter;
s1poinfo = sqldata.description;
// end populate the subfile fields
RRN1 += 1;
SCRRN = RRN1;
write SUB01;
enddo;
closeOrderList();
*in33 = *on;
savrrn = SCRRN;
//
// If no records in subfile then do not disply the subfile.
//
if SavRrn = *zeros;
*in31 = *off;
else;
RRN1 = 1;
SCRRN = 1;
endif;
endsr;
//--------------------------------------------------------
// $sndmsg - send subfile message
//--------------------------------------------------------
begsr $sndmsg;
$sendmsg(messageID :
messageFile :
messagedata :
messageLen :
'*DIAG' :
@PGM :
messagecsc :
messagekey :
APIError
);
endsr;
//--------------------------------------------------------
// $clrmsg - clear all subfile message(s)
//--------------------------------------------------------
begsr $clrmsg;
$clearmsg('*' :
*zero :
*blanks :
'*ALL' :
APIError
);
endsr;
//--------------------------------------------------------
// Hskpg - one time run subroutine
//--------------------------------------------------------
begsr Hskpg;
/end-free
c/exec sql
c+ set option commit=*none,
c+ datfmt=*iso
c/end-exec
/free
in dactrl;
HDPROGRAM = @PGM;
PGMQ = @PGM;
HDCOMPANY = DACONM;
Title = 'Select Labor out PO';
LenStr = ((%len(Title) - %len(%trim(Title))) / 2) + 1;
%subst(HDTITLE:LenStr) = %trim(Title);
endsr;
/End-Free
*--------------------------------------------------------
* openOrderList - Open a cursor to read the Orders file
*--------------------------------------------------------
p openOrderList b
d openOrderList pi
c/exec sql
c+ declare Cursor cursor
c+ for wkStatement
c/end-exec
c/exec sql
c+ prepare wkStatement from :sql
c/end-exec
c/exec sql
c+ open Cursor
c/end-exec
p openOrderList e
*--------------------------------------------------------
* fetchNextOrder - read order one at a time
*--------------------------------------------------------
p fetchNextOrder b
d fetchNextOrder pi N
c/exec sql
c+ fetch next from Cursor
c+ into :SQLdata
c/end-exec
/free
if sqlstt < '02000';
return *on;
else;
return *off;
endif;
/end-free
p fetchNextOrder e
*--------------------------------------------------------
* closeOrderList - Close the OrderHdr cursor
*--------------------------------------------------------
p closeOrderList b
d closeOrderList pi
c/exec sql
c+ close Cursor
c/end-exec
p closeOrderList e
*--------------------------------------------------------
* TitleText - convert text string to title format
*--------------------------------------------------------
* Begin Procedure
P Titletext B
d TitleText Pi 512A
d TheString 512A const
* After below line of code is processed
* Thestring = my name is
* AfterString = My Name Is
*
d AfterString s 512A
d BeforeString s 512A
d Count s 4 0
d CurrentOne s 1
d LastOne s 1
*
d Up c CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
d Lo c CONST('abcdefghijklmnopqrstuvwxyz')
*
c clear AfterString
*
* Lower case the entire thing
*
c Eval BeforeString =
c %Xlate(Up:Lo:TheString)
*
c for count = 1 to %len(%trim(BeforeString))
c eval CurrentOne = %subst(BeforeString:count:1)
*
c select
*
c when count = 1
c eval AfterString = %Trim(
c %Xlate(Lo:Up:%Subst(
c BeforeString:1:1)))
*
c when %subst(BeforeString:count:4) = 'mfg ' or
c %subst(BeforeString:count:4) = 'inc ' or
c %subst(BeforeString:count:4) = 'inc.' or
c %subst(BeforeString:count:4) = 'ind ' or
c %subst(BeforeString:count:4) = 'co. ' or
c %subst(BeforeString:count:4) = 'co ' or
c %subst(BeforeString:count:4) = 'llc.' or
c %subst(BeforeString:count:4) = 'llc '
c eval %subst(AfterString:count:3)=
c %Trim(
c %Xlate(Lo:Up:%Subst(
c BeforeString:count:3)))
c eval count +=2
c iter
*
c when LastOne = *blanks or
c LastOne = '-' or
c LastOne = '.' or
c LastOne = '/'
c eval AfterString = %Subst(
c AfterString:1:count-1)
c + %Trim(
c %Xlate(Lo:Up:%Subst(
c BeforeString:count:1)) +
c %Subst(AfterString:count+1))
c other
c eval %subst(AfterString:count:1) =
c %subst(BeforeString:count:1)
c endsl
*
c eval LastOne = %subst(BeforeString:count:1)
c endfor
*
c return AfterString
p Titletext E
*--------------------------------------------------------
Comment