RCDLCKBAD

**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.
// ==============================================================

 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';