H/TITLE ** SOFTCODE SERVICE MODULE ** H DEBUG(*YES) H nomain **************************************************************** * PROGRAM NAME - SC0080RM * * * * FUNCTION - This is a module designed to support the * * softcoded program functions. * * * * PROGRAMMER - STEVE CROY 04/11/06 * **************************************************************** **************************************************************** * MODIFICATION LOG * * * * DATE PROGRAMMER DESCRIPTION * * * **************************************************************** **************************************************************** * PROCEDURE INTERFACE SECTION * * * * PROCEDURES: GETFUNCTION * * GETKEYTEXT * * DISPLAYKEYS * * GETOPTION * * GETOPTTEXT * * DISPLAYOPTS * **************************************************************** * Prototypes *--- /copy qrpglesrc,SC0000_PR *--- DExecCmd PR EXTPGM('QCMDEXC') D Command 256 D Length 15 5 *--- * Global Variables *--- D KEYMACRO E DS EXTNAME(SCFUNCPF) D MACRO E DS EXTNAME(SCOPTNPF) D sql s 32767a varying D SQLSTTOK C '00000' D SQLNOMOREROWS C '02000' D True C '1' D False C '0' D CloseLbl C 'Close' D FetchLbl C 'Fetch' D OpenLbl C 'Open' D MoreRows S 1A Inz('0') D SourceOpen S 1A Inz('0') D PgmError S 1A Inz('0') D URLfound S N D ProgramName S 10A D PanelName S 10A D SQLTable S 21A D SQLStmnt S 10A D TblName S 10A D Sort2 S 10A D Msg S 51A D W$CMD S 256 INZ D W$LEN S 15 5 INZ(256) ********************************************************************** * Get function keys ********************************************************************** P GetFunction B export D GetFunction PI D pgmnam 10 D pnlnam 10 D keyDS 1 D keyID 10 D function 45 D level 3 D FN S 10 DIM(31) D K S 3 0 D I S 3 0 D thisPgm S 10 D thisPnl S 10 D CMDKEY E DS EXTNAME(SCKEYSPF) QUALIFIED D KeyDefined 1 31 DIM(31) /free cmdkey = FunctionKeys(); programName = pgmnam; panelName = pnlnam; thisPgm = pgmnam; thisPnl = pnlnam; cmdkey = FunctionKeys(); FN(1) = 'ENTER'; FN(2) = 'ROLLUP'; FN(3) = 'ROLLDN'; FN(4) = 'HELP'; FN(5) = 'PRINT'; FN(6) = 'BSPACE'; FN(7) = 'CLEAR'; FN(8) = 'F1'; FN(9) = 'F2'; FN(10)= 'F3'; FN(11)= 'F4'; FN(12)= 'F5'; FN(13)= 'F6'; FN(14)= 'F7'; FN(15)= 'F8'; FN(16)= 'F9'; FN(17)= 'F10'; FN(18)= 'F11'; FN(19)= 'F12'; FN(20)= 'F13'; FN(21)= 'F14'; FN(22)= 'F15'; FN(23)= 'F16'; FN(24)= 'F17'; FN(25)= 'F18'; FN(26)= 'F19'; FN(27)= 'F20'; FN(28)= 'F21'; FN(29)= 'F22'; FN(30)= 'F23'; FN(31)= 'F24'; k = %lookup(KeyDS:CMDKEY.KeyDefined:1); // Lookup key passed IF k > 0; keyID = fn(k); ELSE; keyID = *blank; ENDIF; //*------------------------------------------------------------- // Determine what macro is to be returned to the calling pgm //*------------------------------------------------------------- EXSR @find; IF sqlstt <> sqlsttok; thisPnl = *blank; EXSR @find; ENDIF; IF sqlstt <> sqlsttok; thisPgm = '*SYS'; thisPnl = *blank; EXSR @find; ENDIF; IF sqlstt <> sqlsttok; function = 'Undefined'; ELSE; IF fkautl <= level; IF %subst(fmacro:1:1) = '&'; w$cmd = %subst(fmacro:2); w$len = %len(%trim(w$cmd)); function = '*NOOP'; Command( w$cmd : w$len); ELSEIF %subst(fmacro:1:5) = '*HELP'; URLfound = ShowHelp( programName ); IF URLfound; function = '*NOOP'; ELSE; HelpText(programName:fpnlid); function = '*NOOP'; ENDIF; ELSE; function = fmacro; ENDIF; ELSE; function = 'Unauthorized'; ENDIF; ENDIF; RETURN; /end-free *============================================================= * Subroutine to find function *============================================================= CSR @FIND BEGSR c/Exec SQL c+ Set Option Commit = *None c/End-Exec c/exec sql c+ select * c+ into :KEYMACRO c+ from SCFUNCPF c+ where fpgmid=:thisPgm and fpnlid=:thisPnl and fkeyid=:keyID c/end-exec CSR ENDSR P GetFunction E ********************************************************************** * Get function key text ********************************************************************** P GetKeyText B export D GetKeyText PI D pgmnam 10 D pnlnam 10 D keytxt 720 D level 3 D KEYS S 10 DIM(80) KEY LIST D TEXT DS 720 D INFO 1 720 DIM(36) D SORT DS 720 D ARR 1 720 DIM(36) ASCEND D F S 3 0 D I S 3 0 D K S 3 0 D X S 3 0 D R S 3 0 /free EXSR SetCursor; f = 0; k = 0; x = 0; i = 1; sort = *blanks; text = *blanks; EXSR OpnCursor; IF SQLStt = SQLSttOK; SourceOpen = True; MoreRows = True; ELSE; SourceOpen = False; MoreRows = False; SQLStmnt = OpenLbl; SQLTable = 'KeySource'; SQLError(); ENDIF; DOU MoreRows = false; EXSR FetchNext; IF MoreRows = True; IF (fpnlid = pnlnam or fpnlid = *blank) AND fkautl <= level; r = %lookup(fkeyid:keys:1); IF r = 0; F = F + 1; keys(f) = fkeyid; info(i) = %trim(fkeyid) + '=' + %trim(fktext); i = i + 1; ENDIF; ENDIF; ENDIF; ENDDO; sort = text; FOR x = 1 to 36; IF %subst(arr(x):3:1) = '='; arr(x) = 'A' + %subst(arr(x):2); ENDIF; ENDFOR; SORTA ARR; CLEAR text; i = 1; FOR x = 1 to 36; IF %subst(arr(x):1:1) = 'A'; arr(x) = 'F' + %subst(arr(x):2); ENDIF; IF arr(x)<> *blank; info(i) = arr(x); i = i+ 1; ENDIF; ENDFOR; IF SourceOpen = True; SourceOpen = False; EXSR ClsCursor; IF SQLStt <> SQLSttOK; SQLStmnt = CloseLbl; SQLTable = 'File' + ':Source'; SQLError(); ENDIF; ENDIF; keytxt = text; RETURN; //*============================================================= //* Read the Cursor //*============================================================= BEGSR FetchNext; EXSR GetNext; SELECT; WHEN SQLStt = SQLSttOK; MoreRows = *ON; WHEN SQLStt = SQLNoMoreRows; MoreRows = *Off; OTHER; SQLStmnt = FetchLbl; SQLTable = 'File' + ':KeySource'; SQLError(); ENDSL; ENDSR; /end-free *--------------------------------------------------------------------- * Declare Cursor *--------------------------------------------------------------------- CSR SetCursor BEGSR C/Exec SQL C+ Declare KeySource scroll Cursor For C+ Select * C+ From SCFUNCPF C+ Where FPGMID=:PGMNAM C+ Order By FPGMID, FPNLID C+ For Read Only C+ Optimize for 1 Rows C/End-Exec CSR ENDSR CSR ClsCursor BEGSR C/Exec SQL C+ Close KeySource C/End-Exec CSR ENDSR CSR OpnCursor BEGSR C/Exec SQL C+ Open KeySource C/End-Exec CSR ENDSR CSR GetNext BEGSR C/Exec SQL C+ FETCH NEXT FROM KeySource INTO :KeyMacro C/End-Exec CSR ENDSR P GetKeyText E ********************************************************************** * Get program option ********************************************************************** P GetOption B export D GetOption PI D pgmnam 10 D pnlnam 10 D optID 10 D option 45 D level 3 D thisPgm S 10 D thisPnl S 10 /free thisPgm = pgmnam; thisPnl = pnlnam; EXSR @find; IF sqlstt <> sqlsttok; thisPnl = *blank; EXSR @find; ENDIF; IF sqlstt <> sqlsttok; thisPgm = '*SYS'; thisPnl = *blank; EXSR @find; ENDIF; IF sqlstt <> sqlsttok; option = 'Undefined'; ELSE; IF OPautl <= level; IF %subst(omacro:1:1) = '&'; w$cmd = %subst(omacro:2); w$len = %len(%trim(w$cmd)); option = '*NOOP'; Command(w$cmd:w$len); ELSEIF %subst(omacro:1:5) = '*HELP'; ShowHelp( pgmnam ); option = '*NOOP'; ELSE; option = omacro; ENDIF; ELSE; option = 'Unauthorized'; ENDIF; ENDIF; RETURN; /end-free *============================================================= * Subroutine to find program option *============================================================= ---> CSR @FIND BEGSR C/exec sql C+ select * C+ into :macro C+ from SCOPTNPF C+ where opgmid=:thisPgm and opnlid=:thisPnl and optnid=:optID C/end-exec <--- CSR ENDSR P GetOption E ********************************************************************** * Get program option text ********************************************************************** P GetOptText B export D GetOptText PI D pgmnam 10 D pnlnam 10 D Opttxt 720 D level 3 D FA S 01 DIM(80) ACTION D OPTS S 10 DIM(80) OPTION LIST D TEXT DS 720 D INFO 1 720 DIM(36) D SORT DS 720 D ARR 1 720 DIM(36) ASCEND D F S 3 0 D I S 3 0 D K S 3 0 D X S 3 0 D R S 3 0 /free EXSR SetCursor; f = 0; k = 0; x = 0; i = 1; sort = *blanks; text = *blanks; EXSR OpnCursor; IF SQLStt = SQLSttOK; SourceOpen = True; MoreRows = True; ELSE; SourceOpen = False; MoreRows = False; SQLStmnt = OpenLbl; SQLTable = 'File' + ':OptSource'; SQLError(); ENDIF; DOU MoreRows = false; EXSR FetchNext; IF MoreRows = True; IF (opnlid = pnlnam or opnlid = *blank) AND opautl <= level; r = %lookup(optnid:opts:1); IF r = 0; F = F + 1; opts(f) = optnid; info(i) = %trim(optnid) + '=' + %trim(OPtext); i = i + 1 ; ENDIF; ENDIF; ENDIF; ENDDO; sort = text; SORTA ARR; CLEAR text; i = 1; FOR x = 1 to 36; IF arr(x)<> *blank; info(i) = arr(x); i = i+ 1; ENDIF; ENDFOR; IF SourceOpen = True; SourceOpen = False; EXSR ClsCursor; IF SQLStt <> SQLSttOK; SQLStmnt = CloseLbl; SQLTable = 'File' + ':OptSource'; SQLError(); ENDIF; ENDIF; OptTxt = text; RETURN; //*============================================================= //* Read the Cursor //*============================================================= BEGSR FetchNext; EXSR GetNext; SELECT; WHEN SQLStt = SQLSttOK; MoreRows = *ON; WHEN SQLStt = SQLNoMoreRows; MoreRows = *Off; OTHER; SQLStmnt = FetchLbl; SQLTable = 'File' + ':OptSource'; SQLError(); ENDSL; ENDSR; /end-free *--------------------------------------------------------------------- * Declare Cursor *--------------------------------------------------------------------- CSR SetCursor BEGSR C/Exec SQL C+ Declare OptSource Cursor For C+ Select * C+ From SCOPTNPF C+ Where OPGMID=:PGMNAM C+ Order By OPGMID, OPNLID C+ For Read Only C+ Optimize for 1 Rows C/End-Exec CSR ENDSR CSR ClsCursor BEGSR C/Exec SQL C+ Close OptSource C/End-Exec CSR ENDSR CSR OpnCursor BEGSR C/Exec SQL C+ Open OptSource C/End-Exec CSR ENDSR CSR GetNext BEGSR C/Exec SQL C+ Fetch Next C+ From OptSource C+ Into :MACRO C/End-Exec CSR ENDSR P GetOptText E ********************************************************************** * SQL error ********************************************************************** P SQLError B export D SQLError PI /free Msg = 'SQL error ' + SQLStt + ' on ' + %TrimR(SQLStmnt) + ' for ' + %TrimR(SQLTable) + ' table.'; DSPLY(E) Msg; PgmError = True; RETURN ; /end-free P SQLError E ********************************************************************** * Execute command ********************************************************************** P Command B D Command PI D Cmd 256 D Len 15 5 /free MONITOR; CALLP ExecCmd( cmd: len ); ON-ERROR; PgmError = True; ENDMON; RETURN; /end-free P Command E ********************************************************************** * Display Function keys ********************************************************************** P DisplayKeys B EXPORT D DisplayKeys PI D KeysIn 720 D LinOut1 60 D LinOut2 60 D KeyIdx 3S 0 D pos S 3S 0 D MoreKeys S 20a INZ('F24=More Keys ') /free IF KeyIdx > 601 ; KeyIdx = 0 ; ENDIF ; LinOut1 = %subst(KeysIn:KeyIdx +1 :60) ; LinOut2 = %subst(KeysIn:KeyIdx + 61:60) ; KeyIdx = KeyIdx + 60 ; IF LinOut1 = *blanks ; LinOut1 = %subst(KeysIn:1:60) ; LinOut2 = %subst(KeysIn:61:60) ; KeyIdx = 60 ; ENDIF ; pos = %scan('=':KeysIn:120) ; IF pos > 120 ; %subst(LinOut2:41:20) = MoreKeys ; ENDIF ; RETURN; /end-free P DisplayKeys E ********************************************************************** * Display Program Options ********************************************************************** P DisplayOptions B EXPORT D DisplayOptions PI D OptionsIn 720 D LinOut1 60 D LinOut2 60 D OptIdx 3S 0 D pos S 3S 0 /free IF OptIdx > 601 ; OptIdx = 0 ; ENDIF ; LinOut1 = %subst(OptionsIn:OptIdx +1 :60) ; LinOut2 = %subst(OptionsIn:OptIdx + 61:60) ; OptIdx = OptIdx + 120 ; IF LinOut1 = *blanks ; LinOut1 = %subst(OptionsIn:1:60) ; LinOut2 = %subst(OptionsIn:61:60) ; OptIdx = 120 ; ENDIF ; pos = %scan('=':OptionsIn:120) ; IF pos > 120 ; %subst(LinOut2:57:3) = '...' ; ENDIF ; RETURN; /end-free P DisplayOptions E