/TITLE ** Work With Softcode Entries * H DEBUG(*YES) H OPTION(*SRCSTMT : *NODEBUGIO) DFTACTGRP(*NO) ACTGRP('QILE') H BNDDIR('QC2LE':'SC0000_BD') ******************************************************************** * Program Name - SC0320RP * * * * Function - This program was designed to allow a user to * * work with expansion project objects * * * * Programmer - Steve Croy 09/03/09 * ******************************************************************** ******************************************************************** * Compile instructions * *CRTPGM *RPGLE * *DBGVIEW *SOURCE * * * ******************************************************************** ******************************************************************** * Modification log * * * * Date Programmer Description * * * ******************************************************************** FSC0320DF CF E WORKSTN F SFILE(SC0320S1:RRNSI) F INFDS(DSPDS) *================================================================ D FUNCTIONKEY E DS EXTNAME(SCKEYSPF) qualified D PGMDS ESDS EXTNAME(SCPSTSPF) D DSPDS E DS EXTNAME(SCDSPFPF) D MACDS E DS EXTNAME(SCFUNCPF) INZ D OPTDS E DS EXTNAME(SCOPTNPF) INZ D OBJECT E DS extname(SCOBJSPF) D before E DS extname(SCOBJSPF) qualified D after E DS extname(SCOBJSPF) qualified D Macro E DS extname(SCMACRPF) D Function 30a overlay(Macro:1) D FormatSQL PR ExtPgm('SC0325RP') D pFcat 3 0 D pFseq 7 0 D pFobj 10a D pFtyp 10a D pFdsc 30a D pFsts 1a D pfSel 256 D pfOrd 256 D FilterSelect PR ExtPgm('SC0330RP') D pFcat 3 0 D pFseq 7 0 D pFobj 10a D pFtyp 10a D pFdsc 30a D pFsts 1a D pfACT 3 CONST D WithParms1 PR extpgm(SUBPGM) D parm01 10 D parm02 10 D mode 1 D return 7 D CommandLine PR extpgm('QUSCMDLN') D WorkSource PR extpgm(SUBPGM) D parm01 10 D parm02 10 D WorkObject PR extpgm(SUBPGM) D parm01 10 D parm02 10 D NoParms PR extpgm(SUBPGM) D DBUfile PR extpgm('SC0338CL') D parm01 10 D parm02 10 *-- Prototype Copybooks /copy qrpglesrc,SC0000_pr *--- d indPtr s * inz( %addr(*in) ) * define named indicators d indicators ds 99 based( indPtr ) d ScreenChange n overlay( indicators : 22 ) d SflControl n overlay( indicators : 50 ) d SflDisplay n overlay( indicators : 51 ) d SflInitialize n overlay( indicators : 52 ) d SflClear n overlay( indicators : 53 ) d SflEnd n overlay( indicators : 54 ) d SflDelete n overlay( indicators : 55 ) d SflNxtChange n overlay( indicators : 58 ) d SflMSGQdisplay... d n overlay( indicators : 59 ) D Quit pr D Exit pr extproc('exit') D 3u 0 value * Default cursor position D #DFPOS DS INZ D #DFROW 2 0 INZ(8) D #DFCOL 3 0 INZ(17) *--------------------------------------------------------------------- * Define constants *--------------------------------------------------------------------- D #TITLE C CONST('** Work With Objects List **') D #MSGF C CONST('SCMSSGF') D #SAME C CONST('*SAME') *--------------------------------------------------------------------- * START of work fields *--------------------------------------------------------------------- D authl S 3 inz('999') D CATEG S 3S 0 inz(500) D cl s 3s 0 D CMDKEY S 720 D dspatr S 1 D EOFIND S 1 INZ('0') D ErrorOccurred... D S n D FKEYDS S 1 D fmt S 10 inz('BEGIN') D INDLR S 1 D Keyidx S 2 D listAction S n D MessageToDisplay... D S n D MoreRecordsRemain... D S n inz(*OFF) D M S 3S 0 D MorOpt S 1 D MSG S 80 D MSGDTA S 132 D MSGF S 10 D MSGPGM S 10 D MSGRLQ S 5 D NoMoreRecords... D S n D O S 3S 0 D objectFound S n D OptIdx S 2 D OPTION S 720 d orderBy s 256a d P$ERR s 7 d P$MOD s 1 D p$mode S 1 D parm01 s 10 D parm02 s 10 D parm03 s 10 D parm04 s 10 D parm05 s 10 D parm06 s 1 D parm07 s 1 D parm08 s 1 D parm09 s 1 D parm10 s 10 D PASSC S 1 D PnlNam S 10a inz('SC0320C1') D pmt S 10 inz('PROMPT') D promptDta S 256 D RCDNBR S 5 0 INZ(1) D RRNSI S 4 0 D RW s 3s 0 D SAVRRN S 4 0 D ScanRequested... D S n inz(*ON) d selectOnly s 256a D SFLLOD S 4 0 D SFLMAX S 4 0 INZ(12) D SFLPOS S 4 0 D SFLRCN S 4 0 D thisOption S 10 D thisFormat S 10 D thisPgm S 10 D typatr S 1 D UsrNam S 10a D Work8 S 8 D Work6 S 6 *--------------------------------------------------------------------- * END of work fields *--------------------------------------------------------------------- /free CheckAuthority(USER:PRGNAM:CATEG:PASSC:AUTHL); IF PASSC <> 'P'; QUIT(); ENDIF; z$seq1 = #TITLE; functionKey = FunctionKeys(); MSGID = 'MIS0001'; EXSR @GetMsg; FilterSelect ( zfcat: zfseq: zfobj: zftyp: zfdsc: zfsts: 'GET'); EXSR @reset; DOU keyPressed = functionKey.F3; IF MessageToDisplay; SflMSGQdisplay = *ON; ELSE; SflMSGQdisplay = *OFF; ENDIF; // write subfile message queue WRITE SC0320C2; IF ScanRequested; #ROW = #DFROW; #COL = #DFCOL; ENDIF; // Display subfile, test for EOJ, and function requested. rrnsi = 0; sflControl = *ON; IF sflrcn > 0; sflDisplay = *ON; ENDIF; WRITE SC032001; EXFMT SC0320C1; sflControl = *OFF; sflDisplay = *OFF; getCsrLoc(ROW:COL:rw:cl); #ROW = rw; #COL = cl; IF MessageToDisplay; RmvMessage(prgnam); MessageToDisplay = *OFF; ENDIF; ThisFormat = fmtnam; ThisPgm = prgnam; GetFunction(thisPgm:thisFormat:keypressed:fkeyid:macro:authl); SELECT; WHEN KeyPressed = functionKey.ENTER; EXSR @ENTER; WHEN KeyPressed = functionKey.ROLLUP; EXSR @LOAD; WHEN KeyPressed = functionKey.ROLLDN; EXSR @DOWN; WHEN KeyPressed = functionKey.F23; DisplayOptions(option: z$opt1: z$opt2: O); WHEN KeyPressed = functionKey.F24; DisplayKeys(cmdkey: z$key1: z$key2: M); WHEN Function = 'EXIT'; QUIT(); WHEN Function = 'CANCEL'; EXSR @return; WHEN Function = 'RESET'; EXSR @RESET; WHEN Function = 'PROMPT'; EXSR @PROMPT; IF promptDta <> *blanks; PromptDta = *blanks; EXSR @RESET; ENDIF; WHEN Function = 'HELP'; HelpText(ThisPgm:fmt); WHEN SUBOP = 'CALL'; EXSR @CALLS; WHEN Function = 'CMDLINE'; CommandLine(); ENDSL; CLEAR macro; ENDDO; //*================================================================ //* Process ENTER key //*================================================================ BEGSR @PROMPT; READ SC032001; pmt = rtnfld; Prompter(Thispgm:pmt:PromptDta); SELECT; WHEN rtnfld = 'ZFSTS'; zfsts = %trim(PromptDta); WHEN rtnfld = 'ZFSEQ'; promptDta = %xlate(' ':'0':promptDta); zfseq = %dec(%subst(PromptDta:1:7):7:0); WHEN rtnfld = 'ZFCAT'; promptDta = %xlate(' ':'0':promptDta); zfcat = %dec(%subst(PromptDta:1:3):3:0); WHEN rtnfld = 'ZFOBJ'; zfobj = %trim(PromptDta); WHEN rtnfld = 'ZFTYP'; zftyp = %trim(PromptDta); WHEN rtnfld = 'ZFDSC'; zfdsc = %trim(PromptDta); OTHER; PromptDta = *blanks; ENDSL; ENDSR; //*================================================================ //* Process ENTER key //*================================================================ BEGSR @ENTER; // Read and Update subfile records ... IF Z$RRN1 > 0; DOU %eof(SC0320DF); READC SC0320S1; listAction = *off; IF NOT %eof(SC0320DF); IF Z$OPT <> *BLANK; listAction = *ON; thisOption = %triml(z$opt); ThisFormat = fmtnam; ThisPgm = prgnam; GetOption(Thispgm:ThisFormat:thisOption:macro:authl); SELECT; WHEN SUBOP = 'CALL'; EXSR @CALLS; WHEN function = 'PROCESS'; objectFound = retrieveObject( exobnm:exobtp ); IF objectFound; objectFound = ObjectProcess(); ENDIF; WHEN function = 'RESET'; objectFound = retrieveObject( exobnm:exobtp ); IF objectFound; objectFound = ResetProcess(); ENDIF; WHEN function = 'EXCEPTION'; objectFound = retrieveObject( exobnm:exobtp ); IF objectFound; objectFound = ProcException(); ENDIF; WHEN function = 'OBSOLETE'; objectFound = retrieveObject( exobnm:exobtp ); IF objectFound; objectFound = ObjectObsolete(); ENDIF; WHEN function = 'EXTEND'; objectFound = retrieveObject( exobnm:exobtp ); IF objectFound; objectFound = ObjectExpanded(); ENDIF; ENDSL; z$opt = *BLANK; IF before <> after; SELECT; WHEN p$mode = 'C'; OBJECT = after; exdesc= '*changed'; WHEN p$mode = 'D'; exdesc = '*deleted'; *IN30 = *ON; ENDSL; ENDIF; z$rrn2 = z$rrn1; UPDATE SC0320S1; *IN30 = *OFF; CLEAR MACRO; ENDIF; ENDIF; ENDDO; ENDIF; EXSR @READ; ENDSR; //*================================================================ //* Read the scan record format and move the scan value to the //* appropriate field. //*================================================================ BEGSR @READ; ScanRequested = *OFF; READ SC032001; IF ScreenChange; // Change indicator on ScanRequested = *ON; EXSR @RESET; ENDIF; ENDSR; //*================================================================ //* Initialize subfile, and reposition file for subfile load //*================================================================ BEGSR @reset; rrnsi = 1; rcdnbr = 1; sflrcn = 0; sflpos = 0; SflInitialize = *ON; WRITE SC0320C1; SflInitialize = *OFF; SflEnd = *OFF; ThisPgm = prgnam; ThisFormat = fmtnam; m = 0; o = 0; usrnam = user; GetKeyText(thisPgm:thisFormat:cmdkey:authl); GetOptText(thisPgm:thisFormat: option: authl); DisplayKeys(cmdkey: z$key1: z$key2: M); DisplayOptions(option: z$opt1: z$opt2: O); // Format the SQL request ... FormatSQL ( zfcat: zfseq: zfobj: zftyp: zfdsc: zfsts: SelectOnly: orderBy); CloseObjectCursor(); ClearObject(); SetObjectCursor(orderby: selectOnly); FilterSelect ( zfcat: zfseq: zfobj: zftyp: zfdsc: zfsts: 'SET'); EXSR @LOAD; ENDSR; //*================================================================ //* Subroutine to process rolldown key //*================================================================ BEGSR @DOWN; Z$RRN2 = Z$rrn2 - SFLMAX; SFLPOS = (SFLPOS - SFLMAX); IF SFLPOS < 1; SFLPOS = sflmax; ENDIF; IF Z$RRN2 < 1; Z$RRN2 = 1; MSGID = 'MIS0006'; EXSR @GetMsg; ENDIF; ENDSR; //*================================================================ //* Set lower limits using search argument, load subfile from DBF //* read file until end of file, or max nbr of records loaded //*================================================================ BEGSR @LOAD; sfllod = 0; savrrn = z$rrn2; SflEnd = *OFF; NoMoreRecords = *OFF; DOU NoMoreRecords or sfllod >= sflmax; MoreRecordsRemain = NextObject(); IF MoreRecordsRemain; OBJECT = GetObjectData(); sflrcn = sflrcn + 1; sfllod = sfllod + 1; RRNSI = SFLRCN; Z$RRN1 =SFLRCN; z$opt = *BLANKS; z$desc = exdesc; zfstat = *blanks; SELECT; WHEN exproc = 'Y'; dspatr = SetColor('BLU'); typatr = SetColor('WHT'); zfstat = dspatr + 'Active'; WHEN exproc = 'E'; dspatr = SetColor('YLW'); typatr = SetColor('WHT'); zfstat = dspatr + 'Review'; WHEN exproc = 'X'; dspatr = SetColor('GRN'); typatr = SetColor('GRN'); zfstat = dspatr + 'eXtended'; WHEN exproc = 'N'; dspatr = SetColor('GRN'); typatr = SetColor('GRN'); zfstat = dspatr + 'Pending'; WHEN exproc = 'O'; dspatr = SetColor('RED'); typatr = SetColor('RED'); zfstat = dspatr + 'Obsolete'; OTHER; dspatr = SetColor('GRN'); typatr = SetColor('GRN'); zfstat = dspatr + 'Undefined'; ENDSL; zfobnm = dspatr + exobnm + typatr + exobtp; WRITE SC0320S1; ELSE ; Sflend = *ON; NoMoreRecords = *ON; ENDIF; ENDDO; sflpos = sflpos + sflmax; z$rrn2 = (sflpos - sflmax) + 1; IF z$rrn2 > sflrcn; sflpos = sflpos - sflmax; z$rrn2 = savrrn; msgid = 'MIS0007'; EXSR @GetMsg; ENDIF; ENDSR; //*================================================================ //* This subroutine allows program calls using pre-defined PLISTs //*================================================================ BEGSR @CALLS; EXSR @SETPM; MONITOR; SELECT; WHEN CALLPM = 'WORKSOURCE'; CALLP WorkSource(exombr: exobsr); WHEN CALLPM = 'WORKOBJECT'; CALLP WorkObject(parm01: parm02); WHEN CALLPM = 'PLIST1'; CALLP WithParms1(parm01: parm02: p$mode: p$err); WHEN CALLPM = 'DBUFILE'; CALLP DBUfile(exobnm: exoblb); OTHER; CALLP NoParms(); ENDSL; ON-ERROR; P$ERR = 'MIS0012'; EXSR @GetMsg; ENDMON; EXSR @RETPM; ENDSR; //*================================================================ //* This subroutine sets values for pre-defined PLISTs //*================================================================ BEGSR @SETPM; parm01 = exobnm; parm02 = exobtp; parm04 = *blanks; p$err = *blanks; p$mode = subact; IF p$mode = 'A'; parm01 = *blanks; parm02 = *blanks; ENDIF; IF listAction; IF RetrieveObject(exobnm:exobtp); before = GetObjectData(); ELSE; CLEAR before; ENDIF; ENDIF; ENDSR; //*================================================================ //* This subroutine determines actions based on returned parms //*================================================================ BEGSR @retpm; IF listAction; IF RetrieveObject(exobnm:exobtp); after = GetObjectData(); ELSE; CLEAR after; ENDIF; ENDIF; IF p$err<>*BLANKS; msgid = p$err; MessageToDisplay = *ON; EXSR @GetMsg; ENDIF; ENDSR; //*===================================================================== //* Get message text from message file and turn on message flag //*===================================================================== BEGSR @getmsg; msgdta = *BLANKS; msg = *BLANKS; msgf = #MSGF; MONITOR; RtvMessage(msgid:msgf:msgdta:msg); ON-ERROR; MessageToDisplay = *ON; ENDMON; msgtxt = msg; EXSR @SendMessage; ENDSR; //*===================================================================== //* Subroutine to send messages to program message queue //*===================================================================== BEGSR @SendMessage; msgdta = msgtxt; msgpgm = PRGNAM; msgrlq = #SAME; msgf = #MSGF; SndMessage(msgid:msgf:msgdta:msgrlq:msgpgm); MessageToDisplay = *ON; ENDSR; //*===================================================================== BEGSR @return; ErrorOccurred = CloseObjectCursor(); *inlr = *on; return; ENDSR; /end-free P Quit b /free ErrorOccurred = CloseObjectCursor(); *inlr = *on ; exit(0) ; /end-free P Quit e