Source on IFS & Local Development
This commit is contained in:
+58
-66
@@ -1,67 +1,59 @@
|
||||
*==============================================================
|
||||
* Program that locks a record and then waits for input from
|
||||
* the operator.
|
||||
*
|
||||
* Call this program in two different sessions to see the effect.
|
||||
* Second program will typically get a error:
|
||||
* 'Unable to allocate a record in file' (RNX1218)
|
||||
* and the end user typically choses an unhelpful response.
|
||||
*==============================================================
|
||||
* Note: This is a poor technique because the record remains
|
||||
* locked to all other users until the transaction is
|
||||
* completed, which may be in a few seconds or after lunch.
|
||||
*
|
||||
*Note: Pgm reads by RRN for convenience. This is not a good
|
||||
* idea is a production program.
|
||||
*
|
||||
*Note: DSPLY is use to simulate a display file interaction
|
||||
* with the user.
|
||||
*
|
||||
*Note: QIWS/QCUSTCDT: believed to be on virtually all systems.
|
||||
*==============================================================
|
||||
**free
|
||||
// ==============================================================
|
||||
// Program that locks a record and then waits for input from
|
||||
// the operator.
|
||||
//
|
||||
// Call this program in two different sessions to see the effect.
|
||||
// Second program will typically get a error:
|
||||
// 'Unable to allocate a record in file' (RNX1218)
|
||||
// and the end user typically choses an unhelpful response.
|
||||
// ==============================================================
|
||||
// Note: This is a poor technique because the record remains
|
||||
// locked to all other users until the transaction is
|
||||
// completed, which may be in a few seconds or after lunch.
|
||||
//
|
||||
// Note: Pgm reads by RRN for convenience. This is not a good
|
||||
// idea is a production program.
|
||||
//
|
||||
// Note: DSPLY is use to simulate a display file interaction
|
||||
// with the user.
|
||||
//
|
||||
// Note: QIWS/QCUSTCDT: believed to be on virtually all systems.
|
||||
// ==============================================================
|
||||
|
||||
H DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF)
|
||||
H DFTACTGRP(*NO) ACTGRP(*NEW)
|
||||
|
||||
FQCUSTCDT UF E DISK USROPN EXTDESC('QIWS/QCUSTCDT')
|
||||
F RECNO(RRN)
|
||||
F* INFSR(*PSSR)
|
||||
|
||||
D QCmdexc PR EXTPGM('QCMDEXC')
|
||||
D CMD 512A
|
||||
D lgth 15P 5 const
|
||||
|
||||
D RRN s 10p 0 inz(10)
|
||||
D reply S 1A inz('*')
|
||||
D Cmd S 512A
|
||||
|
||||
/free
|
||||
*inlr = *on;
|
||||
|
||||
// Set update file to a short wait time. Otherwise the file or
|
||||
// system default wait time applies.
|
||||
cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
|
||||
QCMDEXC(cmd:512);
|
||||
open QCUSTCDT;
|
||||
|
||||
chain RRN QCUSTCDT;
|
||||
|
||||
if %found(QCUSTCDT);
|
||||
// Logic to update the record would be here.
|
||||
dsply 'Read for update' ' ' reply;
|
||||
else;
|
||||
// Logic for record not found would be here
|
||||
dsply 'Record not found' ' ' reply;
|
||||
endif;
|
||||
|
||||
// === End of Program =========================================
|
||||
// Close file before returning
|
||||
close QCUSTCDT;
|
||||
return;
|
||||
|
||||
// Often found in old programs. Uncomment INFSR(*PSSR) in the
|
||||
// F-SPEC to make this active.
|
||||
BEGSR *PSSR;
|
||||
dsply 'In the *PSSR' ' ' reply;
|
||||
dump(a);
|
||||
ENDSR '*CANCL';
|
||||
Ctl-Opt DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF);
|
||||
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
|
||||
Dcl-F QCUSTCDT Usage(*Update:*Delete:*Output) USROPN EXTDESC('QIWS/QCUSTCDT') RECNO(RRN)
|
||||
// INFSR(*PSSR)
|
||||
;
|
||||
Dcl-PR QCmdexc EXTPGM('QCMDEXC');
|
||||
Cmd Char(512);
|
||||
lgth Packed(15:5) CONST;
|
||||
End-PR;
|
||||
Dcl-S RRN Packed(10:0) INZ(10);
|
||||
Dcl-S reply Char(1) INZ('*');
|
||||
Dcl-S Cmd Char(512);
|
||||
*inlr = *on;
|
||||
// Set update file to a short wait time. Otherwise the file or
|
||||
// system default wait time applies.
|
||||
Cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
|
||||
QCmdexc(Cmd:512);
|
||||
open QCUSTCDT;
|
||||
chain RRN QCUSTCDT;
|
||||
if %found(QCUSTCDT);
|
||||
// Logic to update the record would be here.
|
||||
dsply 'Read for update' ' ' reply;
|
||||
else;
|
||||
// Logic for record not found would be here
|
||||
dsply 'Record not found' ' ' reply;
|
||||
endif;
|
||||
// === End of Program =========================================
|
||||
// Close file before returning
|
||||
close QCUSTCDT;
|
||||
return;
|
||||
// Often found in old programs. Uncomment INFSR(*PSSR) in the
|
||||
// F-SPEC to make this active.
|
||||
BEGSR *PSSR;
|
||||
dsply 'In the *PSSR' ' ' reply;
|
||||
dump(a);
|
||||
ENDSR '*CANCL';
|
||||
|
||||
+85
-89
@@ -1,93 +1,89 @@
|
||||
*==============================================================
|
||||
* Program that locks a record and then waits for input from
|
||||
* the operator.
|
||||
*
|
||||
* Call this program in two different sessions to see the effect.
|
||||
*==============================================================
|
||||
* - Locking the record first is a poor technique because
|
||||
* the record remains locked to all other users until the
|
||||
* transaction is completed, which may be in a few seconds or
|
||||
* after lunch.
|
||||
* It is used here to demonstate the RCDLCKDSP processing.
|
||||
*==============================================================
|
||||
* - Pgm reads by RRN for convenience. This is generally not a
|
||||
* good idea is a production program.
|
||||
*
|
||||
*- DSPLY is use to simulate a display file interaction with
|
||||
* the user. Not normally done in production.
|
||||
*
|
||||
* - QIWS/QCUSTCDT: believed to be on virtually all systems.
|
||||
*==============================================================
|
||||
**free
|
||||
// ==============================================================
|
||||
// Program that locks a record and then waits for input from
|
||||
// the operator.
|
||||
//
|
||||
// Call this program in two different sessions to see the effect.
|
||||
// ==============================================================
|
||||
// - Locking the record first is a poor technique because
|
||||
// the record remains locked to all other users until the
|
||||
// transaction is completed, which may be in a few seconds or
|
||||
// after lunch.
|
||||
// It is used here to demonstate the RCDLCKDSP processing.
|
||||
// ==============================================================
|
||||
// - Pgm reads by RRN for convenience. This is generally not a
|
||||
// good idea is a production program.
|
||||
//
|
||||
// - DSPLY is use to simulate a display file interaction with
|
||||
// the user. Not normally done in production.
|
||||
//
|
||||
// - QIWS/QCUSTCDT: believed to be on virtually all systems.
|
||||
// ==============================================================
|
||||
|
||||
H DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF)
|
||||
H DFTACTGRP(*NO) ACTGRP(*NEW)
|
||||
Ctl-Opt DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF);
|
||||
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
|
||||
|
||||
FQCUSTCDT UF E DISK USROPN EXTDESC('QIWS/QCUSTCDT')
|
||||
F RECNO(RRN)
|
||||
F* INFSR(*PSSR)
|
||||
Dcl-F QCUSTCDT Usage(*Update:*Delete:*Output)
|
||||
USROPN EXTDESC('QIWS/QCUSTCDT') RECNO(RRN)
|
||||
// INFSR(*PSSR)
|
||||
;
|
||||
|
||||
D RCDLCKDSP PR EXTPGM('RCDLCKDSP')
|
||||
D poReply 1A
|
||||
D piPSDS *
|
||||
Dcl-PR RCDLCKDSP EXTPGM('RCDLCKDSP');
|
||||
poReply Char(1);
|
||||
piPSDS Pointer;
|
||||
End-PR;
|
||||
Dcl-PR QCmdexc EXTPGM('QCMDEXC');
|
||||
Cmd Char(512);
|
||||
lgth Packed(15:5) CONST;
|
||||
End-PR;
|
||||
Dcl-S RRN Packed(10:0) INZ(10);
|
||||
Dcl-S reply Char(1) INZ('*');
|
||||
Dcl-S Cmd Char(512);
|
||||
Dcl-DS myPSDS PSDS;
|
||||
End-DS;
|
||||
Dcl-S myPSDS_ptr Pointer INZ(%ADDR(myPSDS));
|
||||
*inlr = *on;
|
||||
// Set update file to a short wait time. Otherwise the file or
|
||||
// system default wait time applies.
|
||||
Cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
|
||||
QCmdexc(Cmd:512);
|
||||
open QCUSTCDT;
|
||||
dou not %error;
|
||||
chain(e) RRN QCUSTCDT;
|
||||
if %error;
|
||||
RCDLCKDSP(reply: myPSDS_ptr);
|
||||
if reply = 'R';
|
||||
iter;
|
||||
endif;
|
||||
if reply = 'C';
|
||||
exsr Prog_Cancelled;
|
||||
endif;
|
||||
if reply = 'D';
|
||||
dump(a);
|
||||
exsr Prog_Cancelled;
|
||||
endif;
|
||||
endif;
|
||||
enddo;
|
||||
if %found(QCUSTCDT);
|
||||
// Logic to update the record would be here.
|
||||
dsply 'Read for update' ' ' reply;
|
||||
else;
|
||||
// Logic for record not found would be here
|
||||
dsply 'Record not found' ' ' reply;
|
||||
endif;
|
||||
// === End of Program =========================================
|
||||
// Close file before returning
|
||||
close QCUSTCDT;
|
||||
return;
|
||||
begsr Prog_Cancelled;
|
||||
close QCUSTCDT;
|
||||
// Put graceful ending logic & notification to user here
|
||||
return;
|
||||
endsr;
|
||||
|
||||
D QCmdexc PR EXTPGM('QCMDEXC')
|
||||
D CMD 512A
|
||||
D lgth 15P 5 const
|
||||
|
||||
D RRN s 10p 0 inz(10)
|
||||
D reply S 1A inz('*')
|
||||
D Cmd S 512A
|
||||
|
||||
D myPSDS SDS
|
||||
D myPSDS_ptr S * inz(%addr(myPSDS))
|
||||
|
||||
/free
|
||||
*inlr = *on;
|
||||
// Set update file to a short wait time. Otherwise the file or
|
||||
// system default wait time applies.
|
||||
cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
|
||||
QCMDEXC(cmd:512);
|
||||
open QCUSTCDT;
|
||||
|
||||
dou not %error;
|
||||
chain(e) RRN QCUSTCDT;
|
||||
if %error;
|
||||
RCDLCKDSP(reply: myPSDS_ptr);
|
||||
if reply = 'R';
|
||||
iter;
|
||||
endif;
|
||||
if reply = 'C';
|
||||
exsr Prog_Cancelled;
|
||||
endif;
|
||||
if reply = 'D';
|
||||
dump(a);
|
||||
exsr Prog_Cancelled;
|
||||
endif;
|
||||
endif;
|
||||
enddo;
|
||||
|
||||
if %found(QCUSTCDT);
|
||||
// Logic to update the record would be here.
|
||||
dsply 'Read for update' ' ' reply;
|
||||
else;
|
||||
// Logic for record not found would be here
|
||||
dsply 'Record not found' ' ' reply;
|
||||
endif;
|
||||
|
||||
// === End of Program =========================================
|
||||
// Close file before returning
|
||||
close QCUSTCDT;
|
||||
return;
|
||||
|
||||
begsr Prog_Cancelled;
|
||||
close QCUSTCDT;
|
||||
// Put graceful ending logic & notification to user here
|
||||
return;
|
||||
endsr;
|
||||
|
||||
// Often found in old programs. Uncomment INFSR(*PSSR) in the
|
||||
// F-SPEC to make this active.
|
||||
BEGSR *PSSR;
|
||||
dsply 'In the *PSSR' ' ' reply;
|
||||
dump(a);
|
||||
ENDSR '*CANCL';
|
||||
// Often found in old programs. Uncomment INFSR(*PSSR) in the
|
||||
// F-SPEC to make this active.
|
||||
BEGSR *PSSR;
|
||||
dsply 'In the *PSSR' ' ' reply;
|
||||
dump(a);
|
||||
ENDSR '*CANCL';
|
||||
|
||||
+169
-198
@@ -1,202 +1,173 @@
|
||||
*==============================================================
|
||||
* When an interactive program tries to update a record that is
|
||||
* locked by another user, often the program doesn't handle it.
|
||||
* The RPG error routines kick in and give the user a confusing
|
||||
* error message.
|
||||
*
|
||||
* Instead, trap the error and handle it by calling this program.
|
||||
*
|
||||
* This program communicates info about a locked record to an
|
||||
* interactive user telling who has the lock.
|
||||
**free
|
||||
// ==============================================================
|
||||
// When an interactive program tries to update a record that is
|
||||
// locked by another user, often the program doesn't handle it.
|
||||
// The RPG error routines kick in and give the user a confusing
|
||||
// error message.
|
||||
//
|
||||
// Instead, trap the error and handle it by calling this program.
|
||||
//
|
||||
// This program communicates info about a locked record to an
|
||||
// interactive user telling who has the lock.
|
||||
|
||||
* See program RCDLCKDEMO for a usage example.
|
||||
*
|
||||
* RCDLCKDSP accepts a continuation reply from the user and
|
||||
* passes it back to the caller.
|
||||
*
|
||||
* If the status is not 1218, then it is considered an
|
||||
* unexpected error and a slightly different dialog is
|
||||
* presented, asking the user to contact IT. You can
|
||||
* customize this as you see fit. Or add other statuses.
|
||||
*
|
||||
* Information is retrieved from the *PSDS passed from the caller.
|
||||
*
|
||||
*==============================================================
|
||||
* Parameters
|
||||
* ==========
|
||||
* 1 Output CL1 User's reply about what to do:
|
||||
* R - Retry the IO operation that failed
|
||||
* C - Cancel the program
|
||||
* D - DUmp the program and cancel
|
||||
* 2 Input * Pointer to the *PSDS in the calling program.
|
||||
* (A pointer is used because the *PDSD is not
|
||||
* always the same length in a program.)
|
||||
*==============================================================
|
||||
* Create with CRTBNDRPG
|
||||
* New activation group so we destroy nothing in the caller.
|
||||
* No worries about overhead since rarely called.
|
||||
h OPTION(*NODEBUGIO: *SRCSTMT)
|
||||
H DFTACTGRP(*NO) ACTGRP(*NEW)
|
||||
*==============================================================
|
||||
// See program RCDLCKDEMO for a usage example.
|
||||
//
|
||||
// RCDLCKDSP accepts a continuation reply from the user and
|
||||
// passes it back to the caller.
|
||||
//
|
||||
// If the status is not 1218, then it is considered an
|
||||
// unexpected error and a slightly different dialog is
|
||||
// presented, asking the user to contact IT. You can
|
||||
// customize this as you see fit. Or add other statuses.
|
||||
//
|
||||
// Information is retrieved from the *PSDS passed from the caller.
|
||||
//
|
||||
// ==============================================================
|
||||
// Parameters
|
||||
// ==========
|
||||
// 1 Output CL1 User's reply about what to do:
|
||||
// R - Retry the IO operation that failed
|
||||
// C - Cancel the program
|
||||
// D - DUmp the program and cancel
|
||||
// 2 Input * Pointer to the *PSDS in the calling program.
|
||||
// (A pointer is used because the *PDSD is not
|
||||
// always the same length in a program.)
|
||||
// ==============================================================
|
||||
// Create with CRTBNDRPG
|
||||
// New activation group so we destroy nothing in the caller.
|
||||
// No worries about overhead since rarely called.
|
||||
Ctl-Opt OPTION(*NODEBUGIO: *SRCSTMT);
|
||||
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
|
||||
// ==============================================================
|
||||
|
||||
FrcdlckdspdCF E WORKSTN
|
||||
Dcl-F rcdlckdspd WORKSTN;
|
||||
Dcl-PR RCDLCKDSP;
|
||||
poReply Char(1);
|
||||
piPSDS Pointer;
|
||||
End-PR;
|
||||
Dcl-PI RCDLCKDSP;
|
||||
poReply Char(1);
|
||||
piPSDS Pointer;
|
||||
End-PI;
|
||||
|
||||
d RCDLCKDSP pr
|
||||
D poReply 1A
|
||||
D piPSDS *
|
||||
// === The caller's Program Status Data Structure ===============
|
||||
// Many fields not currently used.
|
||||
Dcl-DS PSDS QUALIFIED BASED(PIPSDS);
|
||||
PROC_NAME Char(10) Pos(1); //* Procedure name
|
||||
PGM_STATUS Zoned(5:0) Pos(11); //* Status code
|
||||
PRV_STATUS Zoned(5:0) Pos(16); //* Previous status
|
||||
LINE_NUM Char(8) Pos(21); //* Src list line num
|
||||
ROUTINE Char(8) Pos(29); //* Routine name
|
||||
PARMS Char(3) Pos(37); //* Num passed parms
|
||||
EXCP_TYPE Char(3) Pos(40); //* Exception type
|
||||
EXCP_NUM Char(4) Pos(43); //* Exception number
|
||||
PGM_LIB Char(10) Pos(81); //* Program library
|
||||
EXCP_DATA Char(80) Pos(91); //* Exception data
|
||||
EXCP_ID Char(4) Pos(171); //* Exception Id
|
||||
LAST_FILE_IO Char(10) Pos(175); //* Last file used
|
||||
DATE Char(8) Pos(191); //* Date (*DATE fmt)
|
||||
YEAR Zoned(2:0) Pos(199); //* Year (*YEAR fmt)
|
||||
LAST_FILE Char(8) Pos(201); //* Last file used
|
||||
FILE_INFO_STATUS Zoned(5:0) Pos(209) ; //* Last file status
|
||||
FILE_INFO_OPCODE Char(6) Pos(214); //* Last file opcode
|
||||
FILE_INFO_ROUTINE Char(8) Pos(220) ; //* Last file RPG
|
||||
FILE_INFO_LIST_NUM Char(8) Pos(228) ; //* Last file listing
|
||||
FILE_INFO_RECORD Int(20) Pos(236) ; //* Last file record
|
||||
JOB_NAME Char(10) Pos(244); //* Job name
|
||||
USER Char(10) Pos(254); //* User name
|
||||
JOB_NUM Zoned(6:0) Pos(264); //* Job number
|
||||
JOB_DATE Zoned(6:0) Pos(270); //* Date (UDATE fmt)
|
||||
RUN_DATE Zoned(6:0) Pos(276); //* Run date (UDATE)
|
||||
RUN_TIME Zoned(6:0) Pos(282); //* Run time (UDATE)
|
||||
CRT_DATE Char(6) Pos(288); //* Create date
|
||||
CRT_TIME Char(6) Pos(294); //* Create time
|
||||
CPL_LEVEL Char(4) Pos(300); //* Compiler level
|
||||
SRC_FILE Char(10) Pos(304); //* Source file
|
||||
SRC_LIB Char(10) Pos(314); //* Source file lib
|
||||
SRC_MBR Char(10) Pos(324); //* Source file mbr
|
||||
PROC_PGM Char(10) Pos(334); //* Pgm Proc is in
|
||||
PROC_MOD Char(10) Pos(344); //* Mod Proc is in
|
||||
LINE_NUM_SRCID Int(5) Pos(354); //* Src list source ID
|
||||
FILE_INFO_LIST_NUM_SRCID Int(5) Pos(356) ; //* Last file listing
|
||||
CURR_USER Char(10) Pos(358) ; //* Current user
|
||||
EXTERNAL_RC Int(10) Pos(368) ; //* External return
|
||||
NUM_XML_ELEMS Int(20) Pos(372) ; //* Number of XML
|
||||
End-DS;
|
||||
// === My Variables ==============================================
|
||||
Dcl-DS MyPSDS PSDS;
|
||||
MyName Char(10) Pos(1); //* This program
|
||||
End-DS;
|
||||
|
||||
d RCDLCKDSP pi
|
||||
D poReply 1A
|
||||
D piPSDS *
|
||||
|
||||
* === The caller's Program Status Data Structure ===============
|
||||
* Many fields not currently used.
|
||||
D PSDS DS qualified based(piPSDS)
|
||||
D PROC_NAME 1 10 * Procedure name
|
||||
D PGM_STATUS 11 15s 0 * Status code
|
||||
D PRV_STATUS 16 20S 0 * Previous status
|
||||
D LINE_NUM 21 28 * Src list line num
|
||||
D ROUTINE 29 36 * Routine name
|
||||
D PARMS 37 39 * Num passed parms
|
||||
D EXCP_TYPE 40 42 * Exception type
|
||||
D EXCP_NUM 43 46 * Exception number
|
||||
D PGM_LIB 81 90 * Program library
|
||||
D EXCP_DATA 91 170 * Exception data
|
||||
D EXCP_ID 171 174 * Exception Id
|
||||
D LAST_FILE_IO 175 184 * Last file used
|
||||
D DATE 191 198 * Date (*DATE fmt)
|
||||
D YEAR 199 200S 0 * Year (*YEAR fmt)
|
||||
D LAST_FILE 201 208 * Last file used
|
||||
D FILE_INFO_STATUS...
|
||||
D 209 213S 0 * Last file status
|
||||
D * Code
|
||||
D FILE_INFO_OPCODE...
|
||||
D 214 219 * Last file opcode
|
||||
D FILE_INFO_ROUTINE...
|
||||
D 220 227 * Last file RPG
|
||||
D * routine
|
||||
D FILE_INFO_LIST_NUM...
|
||||
D 228 235 * Last file listing
|
||||
D * line
|
||||
D FILE_INFO_RECORD...
|
||||
D 236 243I 0 * Last file record
|
||||
D * name
|
||||
D JOB_NAME 244 253 * Job name
|
||||
D USER 254 263 * User name
|
||||
D JOB_NUM 264 269S 0 * Job number
|
||||
D JOB_DATE 270 275S 0 * Date (UDATE fmt)
|
||||
D RUN_DATE 276 281S 0 * Run date (UDATE)
|
||||
D RUN_TIME 282 287S 0 * Run time (UDATE)
|
||||
D CRT_DATE 288 293 * Create date
|
||||
D CRT_TIME 294 299 * Create time
|
||||
D CPL_LEVEL 300 303 * Compiler level
|
||||
D SRC_FILE 304 313 * Source file
|
||||
D SRC_LIB 314 323 * Source file lib
|
||||
D SRC_MBR 324 333 * Source file mbr
|
||||
D PROC_PGM 334 343 * Pgm Proc is in
|
||||
D PROC_MOD 344 353 * Mod Proc is in
|
||||
D LINE_NUM_SRCID...
|
||||
D 354 355I 0 * Src list source ID
|
||||
D FILE_INFO_LIST_NUM_SRCID...
|
||||
D 356 357I 0 * Last file listing
|
||||
D * source ID
|
||||
D CURR_USER 358 367 * Current user
|
||||
D * profile
|
||||
D EXTERNAL_RC 368 371I 0 * External return
|
||||
D * code
|
||||
D NUM_XML_ELEMS 372 379I 0 * Number of XML
|
||||
d * elements
|
||||
*=== My Variables ==============================================
|
||||
D MyPSDS sDS
|
||||
D MyName 1 10 * This program
|
||||
|
||||
D User c 'User: '
|
||||
D UserPrf S 10A inz(' ')
|
||||
D UserName S 40A inz(' ')
|
||||
|
||||
D wkI s 10I 0
|
||||
D wkJ s 10I 0
|
||||
|
||||
d myStatus s 4S 0
|
||||
D*AAA DS likeds(PSDS)
|
||||
/FREE
|
||||
// AAA = PSDS; // Eases Debugging...
|
||||
|
||||
SH_PGM = MyName;
|
||||
|
||||
// Sometimes the Status is not numeric
|
||||
monitor;
|
||||
myStatus = psds.FILE_INFO_STATUS;
|
||||
on-error;
|
||||
myStatus = -0;
|
||||
ENDMON;
|
||||
|
||||
// Display fields are prefixed with SC_.
|
||||
select;
|
||||
when myStatus = 1218; //Record locked
|
||||
SC_USER1 = 'Cannot continue until the user below completes';
|
||||
SC_USER2 = 'their transaction or exits their application.';
|
||||
exsr GetUserPrf;
|
||||
//exsr GetUserName;
|
||||
|
||||
// Fill in user profile and user name
|
||||
select;
|
||||
when UserPrf = ' ' and UserName = ' ';
|
||||
SC_USER3 = User + '*Unknown* -- Call IT Now.';
|
||||
when UserName = ' ';
|
||||
SC_USER3 = User + UserPrf;
|
||||
other;
|
||||
SC_USER3 = User + UserName;
|
||||
endsl;
|
||||
|
||||
SC_INSTR = 'Enter R to Retry, C to Cancel';
|
||||
|
||||
other; //Unknown error
|
||||
SC_USER1 = 'An unexpected error has occurred.';
|
||||
SC_USER2 = 'Please contact IT now.';
|
||||
SC_INSTR = 'IT: D=Dump, C=Cancel; R=Retry';
|
||||
endsl;
|
||||
|
||||
// We try to fill in this info for all conditions
|
||||
SC_IT_PGM = PSDS.PROC_NAME;
|
||||
SC_IT_STS = myStatus;
|
||||
SC_IT_FILE = PSDS.LAST_FILE;
|
||||
SC_IT_OPCD = PSDS.FILE_INFO_OPCODE;
|
||||
|
||||
SC_IT_EM1 = %subst(PSDS.EXCP_DATA: 1: %len(SC_IT_EM1));
|
||||
SC_IT_EM2 = %subst(PSDS.EXCP_DATA: %len(SC_IT_EM1)+1);
|
||||
|
||||
exfmt dspwin;
|
||||
|
||||
poReply = 'R'; //Default to R
|
||||
if SC_RESP = 'C' or SC_RESP = 'R' or SC_RESP = 'D';
|
||||
poReply = SC_RESP;
|
||||
endif;
|
||||
|
||||
*inlr = *on;
|
||||
return;
|
||||
|
||||
begsr GetUserPrf;
|
||||
// Dig the user profile out of the error message (EXCP_DATA)
|
||||
// which looks like this:
|
||||
// Record 3317 in use by job 018249/SLENNON/MISREMSAM
|
||||
UserPrf = ' ';
|
||||
wkI = %scan('/':PSDS.EXCP_DATA);
|
||||
if wkI <> 0;
|
||||
wkI = wkI +1;
|
||||
wkJ = %scan('/' :PSDS.EXCP_DATA: wkI);
|
||||
if WkJ <> 0;
|
||||
wkJ = WkJ - wkI;
|
||||
if wkI > 0;
|
||||
UserPrf = %subst(PSDS.EXCP_DATA: wkI: wkJ);
|
||||
endif;
|
||||
endif;
|
||||
endif;
|
||||
endsr;
|
||||
|
||||
begsr GetUserName;
|
||||
// If you have a way to connect a user name to a user
|
||||
// then set UserName here.
|
||||
UserName = ' ';
|
||||
endsr;
|
||||
/END-FREE
|
||||
Dcl-C USER 'USER: ';
|
||||
Dcl-S UserPrf Char(10) INZ(' ');
|
||||
Dcl-S UserName Char(40) INZ(' ');
|
||||
Dcl-S wkI Int(10);
|
||||
Dcl-S wkJ Int(10);
|
||||
Dcl-S myStatus Zoned(4:0);
|
||||
//Dcl-DS AAA LIKEDS(PSDS);
|
||||
// AAA = PSDS; // Eases Debugging...
|
||||
SH_PGM = MyName;
|
||||
// Sometimes the Status is not numeric
|
||||
monitor;
|
||||
myStatus = PSDS.FILE_INFO_STATUS;
|
||||
on-error;
|
||||
myStatus = -0;
|
||||
ENDMON;
|
||||
// Display fields are prefixed with SC_.
|
||||
select;
|
||||
when myStatus = 1218; //Record locked
|
||||
SC_USER1 = 'Cannot continue until the user below completes';
|
||||
SC_USER2 = 'their transaction or exits their application.';
|
||||
exsr GetUserPrf;
|
||||
//exsr GetUserName;
|
||||
// Fill in user profile and user name
|
||||
select;
|
||||
when UserPrf = ' ' and UserName = ' ';
|
||||
SC_USER3 = USER + '*Unknown* -- Call IT Now.';
|
||||
when UserName = ' ';
|
||||
SC_USER3 = USER + UserPrf;
|
||||
other;
|
||||
SC_USER3 = USER + UserName;
|
||||
endsl;
|
||||
SC_INSTR = 'Enter R to Retry, C to Cancel';
|
||||
other; //Unknown error
|
||||
SC_USER1 = 'An unexpected error has occurred.';
|
||||
SC_USER2 = 'Please contact IT now.';
|
||||
SC_INSTR = 'IT: D=Dump, C=Cancel; R=Retry';
|
||||
endsl;
|
||||
// We try to fill in this info for all conditions
|
||||
SC_IT_PGM = PSDS.PROC_NAME;
|
||||
SC_IT_STS = myStatus;
|
||||
SC_IT_FILE = PSDS.LAST_FILE;
|
||||
SC_IT_OPCD = PSDS.FILE_INFO_OPCODE;
|
||||
SC_IT_EM1 = %subst(PSDS.EXCP_DATA: 1: %len(SC_IT_EM1));
|
||||
SC_IT_EM2 = %subst(PSDS.EXCP_DATA: %len(SC_IT_EM1)+1);
|
||||
exfmt DSPWIN;
|
||||
poReply = 'R'; //Default to R
|
||||
if SC_RESP = 'C' or SC_RESP = 'R' or SC_RESP = 'D';
|
||||
poReply = SC_RESP;
|
||||
endif;
|
||||
*inlr = *on;
|
||||
return;
|
||||
begsr GetUserPrf;
|
||||
// Dig the user profile out of the error message (EXCP_DATA)
|
||||
// which looks like this:
|
||||
// Record 3317 in use by job 018249/SLENNON/MISREMSAM
|
||||
UserPrf = ' ';
|
||||
wkI = %scan('/':PSDS.EXCP_DATA);
|
||||
if wkI <> 0;
|
||||
wkI = wkI +1;
|
||||
wkJ = %scan('/' :PSDS.EXCP_DATA: wkI);
|
||||
if wkJ <> 0;
|
||||
wkJ = wkJ - wkI;
|
||||
if wkI > 0;
|
||||
UserPrf = %subst(PSDS.EXCP_DATA: wkI: wkJ);
|
||||
endif;
|
||||
endif;
|
||||
endif;
|
||||
endsr;
|
||||
begsr GetUserName;
|
||||
// If you have a way to connect a user name to a user
|
||||
// then set UserName here.
|
||||
UserName = ' ';
|
||||
endsr;
|
||||
|
||||
+1
-1
@@ -16,7 +16,7 @@ The top half of the window is information for the current user of the interactiv
|
||||
|
||||
The bottom half provides information for the IT Department should the need arise.
|
||||
|
||||
## RCDLCKDSP
|
||||
## RCDLCKDSP.RPGLE
|
||||
|
||||
This is the standalone RPG program that handles the window display. It is passed two parameters:
|
||||
|
||||
|
||||
Reference in New Issue
Block a user