SQLRPGLE
***************************************************************************
* *
* Program : DSPFLGTRN *
* Description : Dsiplay Message Transaction Screen *
* Author : *
* *
***************************************************************************
*--------------------------------------------------------------------------
* M o d i f i c a t i o n J o u r n a l
*--------------------------------------------------------------------------
* Date Name WO# Description
*--------------------------------------------------------------------------
* 05/23/2017 GXXX GXXX
* Message Viewer Screen
*--------------------------------------------------------------------------
H Option(*NoDebugIO:*SrcStmt)
H DftActGrp(*No) ActGrp(*Caller)
FFlgTrnDs CF E WorkStn InfDs(##$FDS)
F Sfile(sflDsp1:$rrn1)
*--------------------------------------------------------------------*
* P R O C E D U R E P R O T O T Y P E S *
*--------------------------------------------------------------------*
D DspFlTrDtl PR ExtPgm('DSPFLTRDTL')
D prOrd 9 0
D prRls 2 0
D prAPI 10A
D prSndTsmp 26A
D prRtnflg 10A
*--------------------------------------------------------------------*
* D A T A S T R U C T U R E S *
*--------------------------------------------------------------------*
* Program Status Data Structure
D stdPgmSds ESDS
* File Information Data Structure
D ##$FDS DS
D ##$Sts 11 15S 0
D ##$Fmt 261 270
D ##$Key 369 369
D ##$Line 1
D ##$Colmn 1
D ##$RR# 378 379B 0
* Local Data Area
D ldaDs UDS Dtaara(*Lda)
D ldaCmpName 40
D ldaBld 1
*--------------------------------------------------------------------*
* D E C L A R E C O N S T A N T S *
*--------------------------------------------------------------------*
D #INITSFL1 C Const('INIT SUBFILE1')
D #CLRSFL1 C Const('CLEAR SUBFILE1')
D #BUILDSFL1 C Const('BUILD SUBFILE1')
D #DISPLAYSFL1 C Const('DISPLAY THE SUBFILE1')
D #VALIDSCR1 C Const('VALIDATE SCREEN1')
D #PROCESSSFL1 C Const('PROCESS THE SUBFILE1')
D #CMDKEYSFL1 C Const('COMMAND KEY SUBFILE1')
D #ENDPGM C Const('ENDPGM')
D #MAXELEMENT C Const(9999)
*-------------------------------------------------------------------------
* Define Binary Work Fields
*-------------------------------------------------------------------------
D DS
D g$MsgPsc 9B 0 Inz(0)
D g$MsgLen 9B 0 Inz(132)
*-------------------------------------------------------------------------
* Internally Described Data Structure For Handling Errors
*-------------------------------------------------------------------------
D z$ApiErr DS
D z$ApiBytp 9B 0 Inz(64)
D z$ApiByta 9B 0 Inz(0)
D z$ApiErr# 7
D z$ApiRsrv 1
D z$ApiEDta 65
* Prototype for 'QMHRMVPM'
D QMhRmvPM PR ExtPgm('QMHRMVPM')
D g$Pgnm_ Like(psdPgm) Program Queue
D g$MsgPsc_ Like(g$MsgPsc) Pgm Stack Cntr
D g$MsgKey_ Like(g$MsgKey) Msg Key
D g$MsgRMV_ Like(g$MsgRmv) Msg To Remove
D g$ApiErr_ Like(z$ApiErr) Error Code D/S
* Prototype for 'QMHSNDPM'
D QMHSNDPM PR ExtPgm('QMHSNDPM') Send Pgm Message
D g$Msg#_ Like(g$Msg#) Message Id
D g$MsgFIL_ Like(g$MsgFil) Message File
D g$MsgDta_ Like(g$MsgDta) Message Data
D g$MsgLen_ Like(g$MsgLen) Msg Data Length
D g$MsgTYP_ Like(g$MsgTYP) Message Type
D g$Pgnm_ Like(psdPgm) Program Queue
D g$MsgPsc_ Like(g$MsgPsc) Pgm Stack Cntr
D g$MsgKey_ Like(g$MsgKey) Msg Key
D g$ApiErr_ Like(z$ApiErr) Error Code D/S
*-------------------------------------------------------------------------
* Message Fields
*-------------------------------------------------------------------------
D g$ErrCnt S 5 0
D g$Msg# S 7
D g$MsgCnt S 5 0
D g$MsgDta S 132
D g$MsgFil S 20
D g$MsgKey S 4
D g$MsgRmv S 10
D g$MsgTyp S 10
D g$Mvr S 5 0
D g$MsgID S 7
*--------------------------------------------------------------------*
* D E C L A R E C O P Y B O O K *
*--------------------------------------------------------------------*
* Function Keys Constants
/COPY PRDCOMSRC/QCPYSRCILE,CO_FKEYS
*--------------------------------------------------------------------*
* D E C L A R E V A R I A B L E S *
*--------------------------------------------------------------------*
D pgmCtl S 25A Inz(*Blanks)
D wkOrdRls S 11A Inz(*Blanks)
D $error S 1A Inz('N')
D $exit S N Inz(*Off)
D $rrn1 S 4S 0 Inz(*Zeros)
D $rrn1Sv S 4S 0 Inz(*Zeros)
D $index S 4S 0 Inz(*Zeros)
D $ohdDtd S 10A Inz(*Blanks)
D $ohdDtd1 S 8A Inz(*Blanks)
D $sflActRrn S 4S 0 Inz(*Zeros)
D $count S 1S 0 Inz(*Zeros)
D $returnflg S 10A Inz('00')
D wrkDate S 8A Inz(*Blanks)
D wrkOrd S 9S 0 Inz(*Zeros)
D wrkRls S 2S 0 Inz(*Zeros)
D wrkApi S 10A Inz(*Blanks)
*--------------------------------------------------------------------*
* M A I N L I N E C O D E *
*--------------------------------------------------------------------*
/free
Exec Sql
Set Option Commit = *NONE, CloSqlCsr = *ENDMOD;
pgmCtl = #INITSFL1;
Dow Not $Exit;
Select;
When pgmCtl = #INITSFL1;
Exsr $Init;
When pgmCtl = #CLRSFL1;
Exsr $ClrSfl1;
When pgmCtl = #BUILDSFL1;
Exsr $BuildSfl1;
When pgmCtl = #DISPLAYSFL1;
Exsr $DisplaySfl1;
When pgmCtl = #VALIDSCR1;
Exsr $ValidCtl1;
When pgmCtl = #PROCESSSFL1;
Exsr $ProcessSfl1;
When pgmCtl = #CMDKEYSFL1;
Exsr $CmdKeySfl1;
Other;
Exsr $EndPgm;
EndSl;
EndDo;
*InLr = *On;
*--------------------------------------------------------------------*
* S U B R O U T I N E : $init - To Initialize Program Variables *
*--------------------------------------------------------------------*
BegSr $Init;
pgmCtl = #CLRSFL1;
*InLr = *Off;
*In25 = *Off; // Command Key pressed
*In80 = *Off; // SflClr indicator
*In81 = *Off; // SflDspCtl indicator
*In82 = *Off; // SflDsp indicator
*In83 = *Off; // SflEnd indicator
*In41 = *Off; // Order Error indicator
*In42 = *Off; // Release Error indicator
*In43 = *Off; // API Error indicator
*In44 = *Off; // Option Error indicator
s1RcdNbr = *Zeros; // Subfile Record Number variable
s1Ord =0;
s1Rls =0;
s1Api ='';
In ldaDs;
s$CmpName = ldaCmpName;
If s$CmpName ='';
s$CmpName=' Oriental Trading Company';
EndIf;
Clear g$MsgKey;
g$MsgRmv = '*ALL';
g$MsgFil = 'ILCMSGF *LIBL';
g$MsgTyp = '*INFO';
QMhRmvPM ( psdPgm : g$MsgPsc : g$MsgKey :
g$MsgRmv : z$ApiErr );
Clear g$MsgCnt;
Exec Sql
Select codAm1 into :s1Days
From ILCCOD Where codSys ='FLAGSHIP' And codFil='MSGVIEWER'
And codRcd ='DAYS' Fetch First 1 Row Only;
EndSr;
*--------------------------------------------------------------------*
* S U B R O U T I N E : $ClrSfl1 - To clear subfile1 *
*--------------------------------------------------------------------*
BegSr $ClrSfl1;
pgmCtl = #BUILDSFL1;
*In25 = *Off;
$rrn1 = *Zeros;
$rrn1Sv = *Zeros;
*In80 = *On; // SflClr indicator
Clear sf1Opt;
Write sflCtl1;
*In80 = *Off;
EndSr;
*--------------------------------------------------------------------*
* S U B R O U T I N E : $ValidCtl1 - Validate the Control *
*--------------------------------------------------------------------*
BegSr $ValidCtl1;
pgmCtl = #BUILDSFL1;
$error = 'N';
$count = 0;
$ohdDtd = '';
If s1Ord = 0;
g$MsgDta = 'Enter Order.';
g$Msg# = 'ERF9999';
*In41 = *On;
ExSr $SndMsg;
$error = 'Y';
ElseIf s1Rls = 0;
g$MsgDta = 'Enter Release.';
g$Msg# = 'ERF9999';
*In42 = *On;
$error = 'Y';
ExSr $SndMsg;
EndIf;
If $error = 'N' And s1Ord <> 0 And s1Rls <> 0;
Exec sql
Select ohdDtd into :$ohdDtd
From ILCOHD Where ohdOrd =:s1Ord And ohdRnm =:s1Rls
Fetch First 1 Row Only;
If $ohdDtd = '';
Exec sql
Select ohdDtd into :$ohdDtd
From ILCOHDT Where ohdOrd =:s1Ord And ohdRnm =:s1Rls
Fetch First 1 Row Only;
If $ohdDtd = '';
g$MsgDta = 'Order/Release does not exist.';
g$Msg# = 'ERF9999';
*In41 = *On;
*In42 = *On;
ExSr $SndMsg;
$error = 'Y';
EndIf;
EndIf;
EndIf;
If $error = 'N' And s1Days <> 0;
wrkDate = %Char(%Date - %Days(s1Days) : *ISO0);
If $ohdDtd < wrkDate;
g$MsgDta = 'Order older than ' + %Trim(%Char(s1Days))
+ ' days.';
g$Msg# = 'ERF9999';
*In41 = *On;
*In42 = *On;
ExSr $SndMsg;
$error = 'Y';
EndIf;
EndIf;
If $error = 'N' And s1Api <> '';
Exec sql
Select count(*) into :$count
From ILCCOD Where codSys ='FLAGSHIP' And codFil='API' And
codRcd =:s1Api Fetch First 1 Row Only;
If $count = 0;
g$MsgDta = 'Invalid API.';
g$Msg# = 'ERF9999';
*In43 = *On;
ExSr $SndMsg;
$error = 'Y';
EndIf;
EndIf;
If $error = 'Y';
pgmCtl = #DISPLAYSFL1;
Else;
pgmCtl = #CLRSFL1;
EndIf;
EndSr;
*--------------------------------------------------------------------------------*
* S U B R O U T I N E : $BuildSfl1 - Load records in Sfl1 *
*--------------------------------------------------------------------------------*
BegSr $BuildSfl1;
pgmCtl = #DISPLAYSFL1;
$ohdDtd= '';
wkOrdRls = %Editc(s1Ord:'X') + %Editc(s1Rls:'X');
//Get the Order Create Date from ILCOHD or ILCOHDT
Exec sql
Select ohdDtd Into :$ohdDtd1
From ILCOHD Where ohdOrd =:s1Ord And ohdRnm =:s1Rls
Fetch First 1 Row Only;
If $ohdDtd = '';
Exec sql
Select ohdDtd Into :$ohdDtd1
From ILCOHDT Where ohdOrd =:s1Ord And ohdRnm =:s1Rls
Fetch First 1 Row Only;
EndIf;
If $ohdDtd1 <> '';
$ohdDtd = %Char(%Date($ohdDtd1: *ISO0): *ISO);
EndIf;
// All the APIs have Order+Rls in the Flagship send message but CSHP has only Order.
// When Ord/Rls are entered
If s1Ord <> 0 And s1Rls <> 0 And s1Api <> '' And $ohdDtd <> '';
Exec sql
Declare msgCsr1 scroll Cursor For //Fetch all messages
Select apiNam, logTsp, jobNam, lstUpdUsr //of the order
From FSMSGLOG
Where msg like '%'||:wkOrdRls||'%' And apiNam =:s1Api
And substr(char(LOGTSP), 1, 10 ) >=:$ohdDtd
And sndOrRcv = 'Send'; //Only Send
Exec sql
Open msgCsr1;
Exec sql
Fetch Next From msgCsr1 into :sf1Api, :sf1SndTsmp,
:sf1JobNam, :sf1lstusr;
Dow SQLCODE = 0;
$rrn1 = $rrn1 + 1;
$rrn1Sv = $rrn1;
Write sflDsp1;
Exec sql
Fetch Next From msgCsr1 Into :sf1Api, :sf1SndTsmp,
:sf1JobNam, :sf1lstusr;
EndDo;
Exec sql
Close msgCsr1;
// When Ord/Rls/Api are entered
ElseIf s1Ord <> 0 and s1Rls <> 0 and s1Api = '' And $ohdDtd <> '';
Exec sql
Declare msgCsr2 scroll Cursor For
Select apiNam, logTsp, jobNam, lstUpdUsr
From FSMSGLOG
Where msg like '%'||:wkOrdRls||'%'
And substr(char(LOGTSP), 1, 10 ) >=:$ohdDtd
And sndOrRcv = 'Send'; //Only Send
Exec sql
Open msgCsr2;
Exec sql
Fetch Next From msgCsr2 into :sf1Api, :sf1SndTsmp,
:sf1JobNam, :sf1lstusr;
DoW SQLCODE = 0;
$rrn1 = $rrn1 + 1;
$rrn1Sv = $rrn1;
Write sflDsp1;
Exec sql
Fetch Next From msgCsr2 Into :sf1Api, :sf1SndTsmp,
:sf1JobNam, :sf1lstusr;
EndDo;
Exec sql
Close msgCsr2;
EndIf;
//For CSHP, Order number is scanned.
If s1Ord <> 0 And s1Rls <> 0 And $ohdDtd <> '' and (s1Api = '' Or
s1Api = 'CSHP');
Exec sql
Declare msgCsr3 scroll Cursor For
Select apiNam, logTsp, jobNam, lstUpdUsr
From FSMSGLOG
Where msg like '%'||:s1Ord||'%' And apiNam ='CSHP'
And substr(char(LOGTSP), 1, 10 ) >=:$ohdDtd
And sndOrRcv = 'Send'; //Only Send
Exec sql
Open msgCsr3;
Exec sql
Fetch Next From msgCsr3 into :sf1Api, :sf1SndTsmp,
:sf1JobNam, :sf1lstusr;
DoW SQLCODE = 0;
$rrn1 = $rrn1 + 1;
$rrn1Sv = $rrn1;
Write sflDsp1;
Exec sql
Fetch Next From msgCsr3 Into :sf1Api, :sf1SndTsmp,
:sf1JobNam, :sf1lstusr;
EndDo;
Exec sql
Close msgCsr3;
EndIf;
//End of CSHP
s1RcdNbr = 1;
EndSr;
*--------------------------------------------------------------------*
* S U B R O U T I N E : $DisplaySfl1 - To display Subfile1 *
*--------------------------------------------------------------------*
BegSr $DisplaySfl1;
If $rrn1Sv <= *Zeros; // If the Display file is empty
*In81 = *On; // SflDsp indicator
If s1Api = '' And s1Ord <> 0 And s1Rls <> 0 And $error='N';
g$MsgDta = 'No Flagship Messages found for ' +
%Editc(s1Ord:'X') + '/' + %Editc(s1Rls:'X') + '.';
g$Msg# = 'ERF9999';
ExSr $SndMsg;
ElseIf s1Api <> '' And s1Ord <> 0 And s1Rls <> 0 And $error='N';
g$MsgDta = 'No Flagship Messages found for ' + %Editc(s1Ord:'X')
+ '/' + %Editc(s1Rls:'X') + '/' + %Trim(s1Api) + '.';
g$Msg# = 'ERF9999';
ExSr $SndMsg;
EndIf;
*In82 = *Off; // SflDsp indicator
Else;
*In81 = *On; // SflDspCtl indicator
*In82 = *On; // SflDsp indicator
*In83 = *On; // SflEnd indicator
EndIf;
*In99 = *On;
Write Header1;
Write CmdKey1;
Write MsgCtl;
Exfmt SflCtl1;
Clear g$MsgKey;
QMhRmvPM ( psdPgm : g$MsgPsc : g$MsgKey :
g$MsgRmv : z$ApiErr );
Clear g$MsgCnt;
Select;
When *In25 = *On;
pgmCtl = #CMDKEYSFL1;
When s1Ord <> wrkOrd Or s1Rls <> wrkRls Or s1Ord = 0 Or
s1Rls = 0 Or (s1Api <> '' And s1Api <> wrkApi) Or $error='Y';
wrkOrd = s1Ord;
wrkRls = s1Rls;
wrkApi = s1Api;
pgmCtl = #VALIDSCR1;
Other;
pgmCtl = #PROCESSSFL1;
EndSl;
*In81 = *Off;
*In82 = *Off;
*In83 = *Off;
*In41 = *Off;
*In42 = *Off;
*In43 = *Off;
*In44 = *Off;
$error='N';
EndSr;
*--------------------------------------------------------------------*
* S U B R O U T I N E : $ProcessSfl1 - To process Sfl1 records *
*--------------------------------------------------------------------*
BegSr $ProcessSfl1;
pgmCtl = #CLRSFL1;
For $sflActRrn = 1 to $rrn1Sv; // Read Through All Loaded Records
Chain $sflActRrn sflDSP1;
If %Found;
Select;
When sf1Opt = '5';
s1RcdNbr = $sflActRrn ; // Position Cursor
Update sflDsp1;
pgmCtl = #CLRSFL1;
Callp DSPFLTRDTL(s1Ord:s1Rls:sf1Api:sf1SndTsmp:$returnflg);
If $returnflg = '03';
pgmCtl = #ENDPGM;
LeaveSr;
ElseIf $returnflg = '12';
s1RcdNbr = $sflActRrn ; // Position Cursor
pgmCtl = #DISPLAYSFL1;
LeaveSr;
EndIf;
When sf1Opt <> '';
g$MsgDta = 'Invalid Option selected.';
g$Msg# = 'ERF9999';
*In44 = *On;
s1RcdNbr = $sflActRrn ; // Position Cursor
ExSr $SndMsg;
Update sflDsp1;
*In44 = *Off;
pgmCtl = #DISPLAYSFL1;
Leave;
EndSl;
EndIf;
*In44 = *Off;
EndFor;
EndSr;
*--------------------------------------------------------------------------------*
* S U B R O U T I N E : $CmdKeySfl1 - To Handle Command Keys For The Subfile *
*--------------------------------------------------------------------------------*
BegSr $CmdKeySfl1;
pgmCtl = #DISPLAYSFL1;
If ##$Key = c$F03;
pgmCtl = #ENDPGM;
ElseIf ##$Key = c$F05;
pgmCtl = #CLRSFL1;
EndIf;
EndSr;
*----------------------------------------------------------------*
* S U B R O U T I N E : $SndMsg - Send Messages to program queue *
*----------------------------------------------------------------*
BegSr $SndMsg;
Clear g$MsgKey;
g$ErrCnt += 1;
QMHSndPM ( g$Msg# : g$MsgFil : g$MsgDta :
g$MsgLen : g$MsgTyp : psdPgm : g$MsgPsc :
g$MsgKey : z$ApiErr );
g$MsgCnt = g$MsgCnt + 1;
EndSr;
*--------------------------------------------------------------------*
* S U B R O U T I N E : $EndPgm - To end program *
*--------------------------------------------------------------------*
BegSr $EndPgm;
$Exit = *On;
EndSr;
/End-free