Coding lab: RPGLE and CL from fixed to free form

Clear the output and save the requested key separately from the record fields. CHAIN retrieves the customer; only a successful %FOUND allows the returned name to be used. A missing key must never reuse the previous customer's name. Both versions trim the name and produce the same greeting.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed.

Fixed-format RPG

     C                   EVAL      greeting = ''
     C                   EVAL      found = *off
     C     requestedId   CHAIN     CustomerRec
     C                   IF        %found(Customers)
     C                   EVAL      found = *on
     C                   EVAL      greeting = 'Hello ' + %trim(name)
     C                   ENDIF

Fully free RPG

**FREE
greeting = '';
found = *off;
chain requestedId CustomerRec;
if %found(Customers);
  found = *on;
  greeting = 'Hello ' + %trim(name);
endif;

Initialize total, position with SETLL and perform the first READE before entering a pre-tested DOW loop. READE sets %EOF when the next key does not match, so a separate comparison against a possibly stale record field is unnecessary. Use a saved input key and input-only access; this scan does not provide a transactionally consistent snapshot.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed.

Fixed-format RPG

     C                   EVAL      total = 0
     C     requestedId   SETLL     Orders
     C     requestedId   READE     Orders
     C                   DOW       not %eof(Orders)
     C                   EVAL      total = total + amount
     C     requestedId   READE     Orders
     C                   ENDDO

Fully free RPG

**FREE
total = 0;
setll requestedId Orders;
reade requestedId Orders;
dow not %eof(Orders);
  total = total + amount;
  reade requestedId Orders;
enddo;

Reject a negative quantity before acquiring a record lock. CHAIN against an update file must succeed before UPDATE can run. Return separate INVALID, MISSING and UPDATED results; I/O exceptions propagate to the enclosing error handler. Reading for update without the N extender holds the record for this short change.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. This example assumes native I/O outside commitment control; a transaction can retain locks until commit or rollback.

Fixed-format RPG

     C                   EVAL      result = 'INVALID'
     C                   IF        newQty >= 0
     C                   EVAL      result = 'MISSING'
     C     requestedId   CHAIN     ProductRec
     C                   IF        %found(Products)
     C                   EVAL      quantity = newQty
     C                   UPDATE    ProductRec
     C                   EVAL      result = 'UPDATED'
     C                   ENDIF
     C                   ENDIF

Fully free RPG

**FREE
result = 'INVALID';
if newQty >= 0;
  result = 'MISSING';
  chain requestedId ProductRec;
  if %found(Products);
    quantity = newQty;
    update ProductRec;
    result = 'UPDATED';
  endif;
endif;

Use a pre-tested scan so an empty import file cannot process stale fields. Pass each pending row's stable identifier to a separate transaction-owning routine. That routine must re-read and lock the durable row, detect already-completed operations, apply the business change and mark the source processed in the same transaction.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. The shown loop is dispatch only; it does not itself implement restartability or exactly-once effects.

Fixed-format RPG

     C                   READ      ImportRec
     C                   DOW       not %eof(Import)
     C                   IF        status = 'P'
     C                   EXSR      ProcessOne
     C                   ENDIF
     C                   READ      ImportRec
     C                   ENDDO

Fully free RPG

**FREE
read ImportRec;
dow not %eof(Import);
  if status = 'P';
    exsr ProcessOne;
  endif;
  read ImportRec;
enddo;

Enforce uniqueness in the database and attempt WRITE directly after validation. A CHAIN-then-WRITE precheck cannot prevent another job inserting the same key. Initialize every output field and use WRITE(E); distinguish duplicate-key status 1021 from other I/O failures before calling another operation that can replace the status.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed.

Fixed-format RPG

     C                   EVAL      orderId = requestedId
     C                   EVAL      customerId = requestedCustomer
     C                   EVAL      amount = requestedAmount
     C                   EVAL      status = 'NEW'
     C                   EVAL      fileStatus = 0
     C                   WRITE(E)  OrderRec
     C                   IF        %error
     C                   EVAL      fileStatus = %status(Orders)
     C                   IF        fileStatus = 1021
     C                   EVAL      result = 'DUPLICATE'
     C                   ELSE
     C                   EVAL      result = 'IO_ERROR'
     C                   ENDIF
     C                   ELSE
     C                   EVAL      result = 'CREATED'
     C                   ENDIF

Fully free RPG

**FREE
orderId = requestedId;
customerId = requestedCustomer;
amount = requestedAmount;
status = 'NEW';
fileStatus = 0;
write(e) OrderRec;
if %error;
  fileStatus = %status(Orders);
  if fileStatus = 1021;
    result = 'DUPLICATE';
  else;
    result = 'IO_ERROR';
  endif;
else;
  result = 'CREATED';
endif;

Record-lock timeout is RPG status 1218; 1211 means an operation was attempted on a closed file. Keep CHAIN and UPDATE inside the same MONITOR, and update only when %FOUND is true. Conversion errors belong in a separate validation block; they should not be mislabeled as file locks.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. This example assumes the requested quantity was validated before entry. A failure result ends this business action; callers must clean up or roll back as appropriate.

Fixed-format RPG

     C                   EVAL      fileStatus = 0
     C                   EVAL      result = 'MISSING'
     C                   MONITOR
     C     requestedId   CHAIN     OrderRec
     C                   IF        %found(Orders)
     C                   EVAL      quantity = newQty
     C                   UPDATE    OrderRec
     C                   EVAL      result = 'UPDATED'
     C                   ENDIF
     C                   ON-ERROR  1218
     C                   EVAL      fileStatus = %status(Orders)
     C                   EVAL      result = 'LOCKED'
     C                   ON-ERROR
     C                   EVAL      fileStatus = %status(Orders)
     C                   EVAL      result = 'IO_ERROR'
     C                   ENDMON

Fully free RPG

**FREE
fileStatus = 0;
result = 'MISSING';
monitor;
  chain requestedId OrderRec;
  if %found(Orders);
    quantity = newQty;
    update OrderRec;
    result = 'UPDATED';
  endif;
on-error 1218;
  fileStatus = %status(Orders);
  result = 'LOCKED';
on-error;
  fileStatus = %status(Orders);
  result = 'IO_ERROR';
endmon;

Parse the same deliberately restricted format in both versions: exactly two unsigned digit fields separated by one comma, with optional surrounding blanks and no CSV quoting. Locate the delimiter, reject absent/extra delimiters and empty fields, check length and digits, then convert into the qualified structure. Do not confuse fixed-position substrings with delimited parsing.

The declarations and calculations below are a parser fragment. Add a containing procedure that supplies rawLine and returns ok/importRow. The parser does not accept quoted CSV, signs, decimal points or other delimiters; no host compilation has been performed.

Fixed-format RPG

     DrawLine          S            256A   VARYING
     DleftText         S            256A   VARYING
     DrightText        S            256A   VARYING
     Dcut              S             10I 0
     Dok               S               N
     DimportRow        DS                  QUALIFIED
     DorderId                         9P 0
     DcustomerId                      9P 0
     C                   CLEAR     importRow
     C                   EVAL      ok = *off
     C                   EVAL      cut = %scan(',': rawLine)
     C                   IF        cut > 1 and cut < %len(rawLine)
     C                   IF        %scan(',': rawLine: cut + 1) = 0
     C                   EVAL      leftText = %trim(%subst(rawLine: 1: cut - 1))
     C                   EVAL      rightText = %trim(%subst(rawLine: cut + 1))
     C                   IF        %len(leftText) > 0 and %len(leftText) <= 9
     C                   IF        %len(rightText) > 0 and %len(rightText) <= 9
     C                   IF        %check('0123456789': leftText) = 0
     C                   IF        %check('0123456789': rightText) = 0
     C                   EVAL      importRow.orderId = %dec(leftText: 9: 0)
     C                   EVAL      importRow.customerId = %dec(rightText: 9: 0)
     C                   EVAL      ok = importRow.orderId > 0 and
     C                             importRow.customerId > 0
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C                   IF        not ok
     C                   CLEAR     importRow
     C                   ENDIF

Fully free RPG

**FREE
dcl-s rawLine varchar(256);
dcl-s leftText varchar(256);
dcl-s rightText varchar(256);
dcl-s cut int(10);
dcl-s ok ind;
dcl-ds importRow qualified;
  orderId packed(9:0);
  customerId packed(9:0);
end-ds;
clear importRow;
ok = *off;
cut = %scan(',': rawLine);
if cut > 1 and cut < %len(rawLine);
  if %scan(',': rawLine: cut + 1) = 0;
    leftText = %trim(%subst(rawLine: 1: cut - 1));
    rightText = %trim(%subst(rawLine: cut + 1));
    if %len(leftText) > 0 and %len(leftText) <= 9;
      if %len(rightText) > 0 and %len(rightText) <= 9;
        if %check('0123456789': leftText) = 0;
          if %check('0123456789': rightText) = 0;
            importRow.orderId = %dec(leftText: 9: 0);
            importRow.customerId = %dec(rightText: 9: 0);
            ok = importRow.orderId > 0 and importRow.customerId > 0;
          endif;
        endif;
      endif;
    endif;
  endif;
endif;
if not ok;
  clear importRow;
endif;

Validate all three advertised inputs in both versions: required trimmed text, an ISO date and a nonnegative decimal amount. Isolate each conversion in its own MONITOR, retain the original text and expose a field-specific error. Callers must not post when errorText is nonblank or use partially converted values.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. %DEC conversion is not a complete wire-format validator; this exercise assumes inputAmount has already been checked against the agreed decimal grammar and maximum scale of two.

Fixed-format RPG

     C                   EVAL      errorText = ''
     C                   EVAL      name = %trim(inputName)
     C                   IF        name = ''
     C                   EVAL      errorText = 'name is required'
     C                   ENDIF
     C                   IF        errorText = ''
     C                   MONITOR
     C                   EVAL      postingDate = %date(inputDate: *iso)
     C                   ON-ERROR
     C                   EVAL      errorText = 'date must be valid ISO'
     C                   ENDMON
     C                   ENDIF
     C                   IF        errorText = ''
     C                   MONITOR
     C                   EVAL      amount = %dec(inputAmount: 11: 2)
     C                   ON-ERROR
     C                   EVAL      errorText = 'amount is invalid'
     C                   ENDMON
     C                   IF        errorText = '' and amount < 0
     C                   EVAL      errorText = 'amount cannot be negative'
     C                   ENDIF
     C                   ENDIF

Fully free RPG

**FREE
errorText = '';
name = %trim(inputName);
if name = '';
  errorText = 'name is required';
endif;
if errorText = '';
  monitor;
    postingDate = %date(inputDate: *iso);
  on-error;
    errorText = 'date must be valid ISO';
  endmon;
endif;
if errorText = '';
  monitor;
    amount = %dec(inputAmount: 11: 2);
  on-error;
    errorText = 'amount is invalid';
  endmon;
  if errorText = '' and amount < 0;
    errorText = 'amount cannot be negative';
  endif;
endif;

Use the same contract in the prototype and procedure interface: an indicator return, a read-only packed order ID and a fixed 80-character output message. Clear the message on entry, reject nonpositive IDs and return true only for success. OPTIONS(*VARSIZE) does not make a fixed character parameter equivalent to VARCHAR and is not appropriate for this output contract.

These are module/procedure source fragments. Add H NOMAIN or ctl-opt nomain to build a module without a main procedure, export/bind only if required, and put the shared prototype in the caller copy member. No compilation has been performed.

Fixed-format RPG

     DvalidateOrder    PR              N
     DorderId                         9P 0 CONST
     DerrorText                      80A
     PvalidateOrder    B
     D                 PI              N
     DorderId                         9P 0 CONST
     DerrorText                      80A
     C                   EVAL      errorText = ''
     C                   IF        orderId <= 0
     C                   EVAL      errorText = 'orderId must be positive'
     C                   RETURN    *off
     C                   ENDIF
     C                   RETURN    *on
     PvalidateOrder    E

Fully free RPG

**FREE
dcl-pr validateOrder ind;
  orderId packed(9:0) const;
  errorText char(80);
end-pr;

dcl-proc validateOrder;
  dcl-pi *n ind;
    orderId packed(9:0) const;
    errorText char(80);
  end-pi;
errorText = '';
if orderId <= 0;
  errorText = 'orderId must be positive';
  return *off;
endif;
return *on;
end-proc;

Capture a returned status with EVAL in fixed-format RPG and assignment in free-format RPG. CALLP ignores a procedure's return value, so testing an unrelated result variable afterward is incorrect. The shared prototype, binder exports and calling convention are part of the interface contract.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. The postOrder implementation and binder source are not included.

Fixed-format RPG

     C                   EVAL      result = postOrder(orderId)
     C                   EVAL      serviceFailed = result <> 0

Fully free RPG

**FREE
result = postOrder(orderId);
serviceFailed = result <> 0;

Clear the subfile and reset its relative record number before loading. For general forward paging, SETGT plus READ continues after the last displayed unique key; READE would restrict the scan to an equal-key group. Increment the subfile relative record number before WRITE, copy row fields and save the last displayed key. The extra read is only a lookahead to compute hasMore.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. DDS indicators, the display/control record and the mapping helper are required; neither version is a complete screen program.

Fixed-format RPG

     C                   EXSR      ClearSubfile
     C                   EVAL      sflRrn = 0
     C                   IF        firstPage
     C     *loval        SETLL     Orders
     C                   ELSE
     C     lastId        SETGT     Orders
     C                   ENDIF
     C                   READ      Orders
     C                   DOW       not %eof(Orders) and sflRrn < pageSize
     C                   EVAL      sflRrn = sflRrn + 1
     C                   EXSR      CopyToScreen
     C                   WRITE     SflRecord
     C                   EVAL      lastId = orderId
     C                   READ      Orders
     C                   ENDDO
     C                   EVAL      hasMore = not %eof(Orders)

Fully free RPG

**FREE
exsr ClearSubfile;
sflRrn = 0;
if firstPage;
  setll *loval Orders;
else;
  setgt lastId Orders;
endif;
read Orders;
dow not %eof(Orders) and sflRrn < pageSize;
  sflRrn = sflRrn + 1;
  exsr CopyToScreen;
  write SflRecord;
  lastId = orderId;
  read Orders;
enddo;
hasMore = not %eof(Orders);

READC must be followed by a pre-tested loop so a screen with no changed rows does no work. For each row, validate the edit and let UpdateOne check the durable key/version. Mark errors in the subfile and rewrite its record with the DDS SFLNXTCHG option enabled when the row must be returned by a later READC; SFLNXTCHG alone does not display an error message.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed.

Fixed-format RPG

     C                   READC     SflRecord
     C                   DOW       not %eof(Display)
     C                   IF        editedQty >= 0
     C                   EXSR      UpdateOne
     C                   IF        not updateOk
     C                   EXSR      MarkError
     C                   ENDIF
     C                   ELSE
     C                   EXSR      MarkError
     C                   ENDIF
     C                   READC     SflRecord
     C                   ENDDO

Fully free RPG

**FREE
readc SflRecord;
dow not %eof(Display);
  if editedQty >= 0;
    exsr UpdateOne;
    if not updateOk;
      exsr MarkError;
    endif;
  else;
    exsr MarkError;
  endif;
  readc SflRecord;
enddo;

Use the same SQL naming convention and status handling in both source styles. Save SQLSTATE immediately after INSERT, before any later SQL operation replaces it. Translate duplicate key 23505 and missing parent 23503 separately; preserve all other nonzero states, including warnings, for explicit caller handling.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. SQL examples require the SQL RPG precompiler and matching table definitions. This fragment does not commit.

Fixed-format RPG

     C/EXEC SQL
     C+ insert into appdata.orders
     C+   (order_id, customer_id, amount)
     C+ values (:orderId, :customerId, :amount)
     C/END-EXEC
     C                   EVAL      savedState = SQLSTT
     C                   SELECT
     C                   WHEN      savedState = '00000'
     C                   EVAL      result = 'INSERTED'
     C                   WHEN      savedState = '23505'
     C                   EVAL      result = 'DUPLICATE'
     C                   WHEN      savedState = '23503'
     C                   EVAL      result = 'MISSING_PARENT'
     C                   OTHER
     C                   EVAL      result = 'SQL_CONDITION'
     C                   ENDSL

Fully free RPG

**FREE
exec sql insert into appdata.orders
    (order_id, customer_id, amount)
  values (:orderId, :customerId, :amount);
savedState = SQLSTT;
select;
when savedState = '00000';
  result = 'INSERTED';
when savedState = '23505';
  result = 'DUPLICATE';
when savedState = '23503';
  result = 'MISSING_PARENT';
other;
  result = 'SQL_CONDITION';
endsl;

Open a read-only cursor ordered by a unique key, fetch until the page is full or SQLSTATE 02000, and close it after the loop. Check OPEN and every FETCH before using host variables. Preserve the primary SQL condition when CLOSE also fails. Reopen for the next page using the last successfully returned key.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. Cursor lifecycle and cleanup are shown for SQL conditions; the containing procedure also needs an exception cleanup path if row-copy code can raise a non-SQL exception.

Fixed-format RPG

     C/EXEC SQL
     C+ declare C1 cursor for
     C+ select order_id, amount from appdata.orders
     C+ where order_id > :lastId order by order_id
     C+ for read only
     C/END-EXEC
     C                   EVAL      rowCount = 0
     C                   EVAL      hasMore = *off
     C                   EVAL      cursorOpen = *off
     C                   EVAL      savedState = '00000'
     C/EXEC SQL
     C+ open C1
     C/END-EXEC
     C                   EVAL      savedState = SQLSTT
     C                   IF        savedState = '00000'
     C                   EVAL      cursorOpen = *on
     C                   DOW       rowCount < pageSize
     C/EXEC SQL
     C+ fetch C1 into :orderId, :amount
     C/END-EXEC
     C                   EVAL      savedState = SQLSTT
     C                   IF        savedState <> '00000'
     C                   LEAVE
     C                   ENDIF
     C                   EVAL      rowCount = rowCount + 1
     C                   EXSR      CopyRow
     C                   EVAL      lastId = orderId
     C                   ENDDO
     C                   EVAL      hasMore = rowCount = pageSize
     C                   ENDIF
     C                   IF        cursorOpen
     C/EXEC SQL
     C+ close C1
     C/END-EXEC
     C                   EVAL      closeState = SQLSTT
     C                   EVAL      cursorOpen = *off
     C                   IF        savedState = '00000' or savedState = '02000'
     C                   IF        closeState <> '00000'
     C                   EVAL      savedState = closeState
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF

Fully free RPG

**FREE
exec sql declare C1 cursor for
  select order_id, amount from appdata.orders
  where order_id > :lastId order by order_id
  for read only;
rowCount = 0;
hasMore = *off;
cursorOpen = *off;
savedState = '00000';
exec sql open C1;
savedState = SQLSTT;
if savedState = '00000';
  cursorOpen = *on;
  dow rowCount < pageSize;
    exec sql fetch C1 into :orderId, :amount;
    savedState = SQLSTT;
    if savedState <> '00000';
      leave;
    endif;
    rowCount = rowCount + 1;
    exsr CopyRow;
    lastId = orderId;
  enddo;
  hasMore = rowCount = pageSize;
endif;
if cursorOpen;
  exec sql close C1;
  closeState = SQLSTT;
  cursorOpen = *off;
  if savedState = '00000' or savedState = '02000';
    if closeState <> '00000';
      savedState = closeState;
    endif;
  endif;
endif;

Only execute the audit INSERT after the order UPDATE succeeds and changes exactly one eligible row. Save the first SQL condition before the next statement can replace it. COMMIT runs only after both writes succeed; otherwise ROLLBACK runs, and its own status must also be checked. A failed or uncertain COMMIT cannot be reported as success or retried blindly.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. A dedicated transaction boundary with active commitment control, journaled tables and no unrelated pending work must already exist. SET TRANSACTION alone is not a substitute for this setup.

Fixed-format RPG

     C                   EVAL      firstState = '00000'
     C                   EVAL      affected = 0
     C/EXEC SQL
     C+ update appdata.orders set status = 'POSTED'
     C+ where order_id = :orderId and status = 'OPEN'
     C/END-EXEC
     C                   EVAL      firstState = SQLSTT
     C                   IF        firstState = '00000'
     C/EXEC SQL
     C+ get diagnostics :affected = row_count
     C/END-EXEC
     C                   EVAL      firstState = SQLSTT
     C                   ENDIF
     C                   IF        firstState = '00000' and affected = 1
     C/EXEC SQL
     C+ insert into appdata.order_audit
     C+   (order_id, posted_at)
     C+ values (:orderId, current_timestamp)
     C/END-EXEC
     C                   EVAL      firstState = SQLSTT
     C                   ENDIF
     C                   IF        firstState = '00000' and affected = 1
     C/EXEC SQL
     C+ commit
     C/END-EXEC
     C                   EVAL      endState = SQLSTT
     C                   IF        endState = '00000'
     C                   EVAL      result = 'COMMITTED'
     C                   ELSE
     C                   EVAL      result = 'COMMIT_ERROR'
     C                   ENDIF
     C                   ELSE
     C/EXEC SQL
     C+ rollback
     C/END-EXEC
     C                   EVAL      endState = SQLSTT
     C                   IF        endState = '00000'
     C                   EVAL      result = 'NOT_POSTED'
     C                   ELSE
     C                   EVAL      result = 'RECOVERY_ERR'
     C                   ENDIF
     C                   ENDIF

Fully free RPG

**FREE
firstState = '00000';
affected = 0;
exec sql update appdata.orders set status = 'POSTED'
  where order_id = :orderId and status = 'OPEN';
firstState = SQLSTT;
if firstState = '00000';
  exec sql get diagnostics :affected = row_count;
  firstState = SQLSTT;
endif;
if firstState = '00000' and affected = 1;
  exec sql insert into appdata.order_audit
      (order_id, posted_at)
    values (:orderId, current_timestamp);
  firstState = SQLSTT;
endif;
if firstState = '00000' and affected = 1;
  exec sql commit;
  endState = SQLSTT;
  if endState = '00000';
    result = 'COMMITTED';
  else;
    result = 'COMMIT_ERROR';
  endif;
else;
  exec sql rollback;
  endState = SQLSTT;
  if endState = '00000';
    result = 'NOT_POSTED';
  else;
    result = 'RECOVERY_ERR';
  endif;
endif;

QRCVDTAQ requires five parameters: queue name, library, returned data length, data buffer and wait time. Test returned length = 0 for timeout; waitSeconds is an input. The default receive removes the entry immediately. IBM i data queues do not provide a separate acknowledgment that can make dequeue and a database commit atomic.

The two examples perform one bounded destructive receive and dispatch its bytes. They are API fragments, not a reliable-delivery worker. To survive a crash after receive, keep the durable work item in a database/outbox and treat the queue as a wake-up hint, or implement a documented recovery mechanism. A processed-operation table alone prevents duplicate effects but does not recover a lost entry. No host execution has been performed.

Fixed-format RPG

     C                   EVAL      queueName = 'ORDERQ'
     C                   EVAL      libraryName = 'APPDATA'
     C                   EVAL      waitSeconds = 5
     C                   EVAL      dataLength = 0
     C                   CLEAR     queueData
     C                   CALLP     ReceiveQueue(queueName: libraryName:
     C                             dataLength: queueData: waitSeconds)
     C                   IF        dataLength = 0
     C                   EVAL      result = 'NO_WORK'
     C                   ELSE
     C                   EXSR      ProcessQueue
     C                   ENDIF

Fully free RPG

**FREE
queueName = 'ORDERQ';
libraryName = 'APPDATA';
waitSeconds = 5;
dataLength = 0;
clear queueData;
callp ReceiveQueue(queueName: libraryName: dataLength: queueData: waitSeconds);
if dataLength = 0;
  result = 'NO_WORK';
else;
  exsr ProcessQueue;
endif;

CLLE uses one command syntax, not RPG fixed/free columns. Declare the input, reject a blank run ID and call both qualified programs in order. If LOAD fails, POST must not run. If POST fails, the wrapper must also escape. A catch-all is justified only to add context and preserve a failed return; it is not recovery.

This wrapper adds a CPF9898 escape after leaving the original command messages in the job log. It does not claim to resend the original message identifier or undo a partially completed LOAD. The helper programs and their transaction/restart contracts are prerequisites; no CL compilation has been performed.

CLLE source fragment

PGM PARM(&RUNID)
  DCL VAR(&RUNID) TYPE(*CHAR) LEN(20)
  IF COND(&RUNID *EQ ' ') THEN(DO)
    SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
      MSGDTA('RUNID is required') MSGTYPE(*ESCAPE)
  ENDDO
  CALL PGM(APPDATA/LOAD) PARM(&RUNID)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
  CALL PGM(APPDATA/POST) PARM(&RUNID)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
  RETURN
ERROR:
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
    MSGDTA('Run failed; inspect job log: ' *CAT &RUNID) +
    MSGTYPE(*ESCAPE)
ENDPGM

Install a call-level override before PROCESSIN opens INPUT, then delete that override on both successful and failed calls. Monitor the CALL itself: monitoring only OVRDBF does not catch processing failures. Do not attempt cleanup after an override-creation failure as if the override were known to exist.

This CLLE fragment assumes a dedicated wrapper call level and a known compatible member. It preserves a failed outcome with CPF9898; original and cleanup diagnostics remain in the job log. No host compilation or override-scope test has been performed.

CLLE source fragment

PGM PARM(&MBR)
  DCL VAR(&MBR) TYPE(*CHAR) LEN(10)
  IF COND(&MBR *NE 'DAILY') THEN(GOTO CMDLBL(ERROR))
  CHKOBJ OBJ(APPDATA/INBOUND) OBJTYPE(*FILE) MBR(&MBR)
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  OVRDBF FILE(INPUT) TOFILE(APPDATA/INBOUND) +
    MBR(&MBR) OVRSCOPE(*CALLLVL)
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  CALL PGM(APPDATA/PROCESSIN)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(CLEANERR))
  DLTOVR FILE(INPUT) LVL(*)
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  RETURN
CLEANERR:
  DLTOVR FILE(INPUT) LVL(*)
  MONMSG MSGID(CPF0000)
ERROR:
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
            MSGDTA('Input member failed; inspect the job log') +
            MSGTYPE(*ESCAPE)
ENDPGM

Submit the qualified batch program with an explicit job queue, job description, execution user policy and initial library list. A successful SBMJOB confirms submission only; it says nothing about whether NIGHTLY later succeeds. Persist the run ID and record the submitted job identity from the completion message or a job-tracking mechanism.

This CLLE fragment validates and submits the request. It does not include durable run tracking, job-completion monitoring or parameter-marshalling tests. No job has been submitted or host compilation performed.

CLLE source fragment

PGM PARM(&RUNID)
  DCL VAR(&RUNID) TYPE(*CHAR) LEN(20)
  IF COND(&RUNID *EQ ' ') THEN(GOTO CMDLBL(ERROR))
  SBMJOB CMD(CALL PGM(APPDATA/NIGHTLY) PARM(&RUNID)) +
    JOBQ(APPDATA/BATCHQ) JOBD(APPDATA/NIGHTJD) +
    USER(*CURRENT) INLLIBL(*JOBD)
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  RETURN
ERROR:
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
    MSGDTA('Run not submitted; inspect job log') MSGTYPE(*ESCAPE)
ENDPGM

Use CHKOBJ to distinguish an existing queue from CPF9801 object-not-found, then create only when absent. A queue's mere existence does not prove its attributes match the contract. Retrieve and compare the description with QMHQRDQD or QSYS2.DATA_QUEUE_INFO before reuse. DSPDTAQ is not a shipped command for this example.

The CL fragment delegates attribute verification to an application helper CHECKQ, which must escape on mismatch. It is not a complete deployment until that helper is implemented. Deployments are serialized; if another creator wins between CHKOBJ and CRTDTAQ, this run fails safely and can be rerun instead of hiding arbitrary creation failures. No host execution has been performed.

CLLE source fragment

PGM
  CHKOBJ OBJ(APPDATA/ORDERQ) OBJTYPE(*DTAQ)
  MONMSG MSGID(CPF9801) EXEC(GOTO CMDLBL(CREATE))
  GOTO CMDLBL(VERIFY)
CREATE:
  CRTDTAQ DTAQ(APPDATA/ORDERQ) TYPE(*STD) +
    MAXLEN(256) SEQ(*FIFO) SENDERID(*NO) FORCE(*YES)
VERIFY:
  /* Application helper: retrieve and compare queue attributes. */
  CALL PGM(APPDATA/CHECKQ)
ENDPGM

Stage into a run-specific member, validate the path/file through an application helper, and submit the processor with that member and run ID. MBROPT(*ADD) into a newly created member avoids replacing a shared inbound member while another job is processing it. CPYFRMIMPF interprets import data; it is not a raw byte-copy or a complete file-security check.

This is a CLLE orchestration fragment. PREPIFS is a required application helper, not an IBM command: it validates and snapshots the input into a protected staging directory, checks size/identity and returns the stable snapshot path. The receiving programs and file schema are omitted. No IFS file was read and no batch job was submitted.

CLLE source fragment

PGM PARM(&PATH &MBR &RUNID)
  DCL VAR(&PATH) TYPE(*CHAR) LEN(256)
  DCL VAR(&MBR) TYPE(*CHAR) LEN(10)
  DCL VAR(&RUNID) TYPE(*CHAR) LEN(20)
  CALL PGM(APPDATA/PREPIFS) PARM(&PATH &MBR &RUNID)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
  ADDPFM FILE(APPDATA/INBOUND) MBR(&MBR)
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  CPYFRMIMPF FROMSTMF(&PATH) TOFILE(APPDATA/INBOUND &MBR) +
    MBROPT(*ADD) RCDDLM(*CRLF) DTAFMT(*DLM)
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  SBMJOB CMD(CALL PGM(APPDATA/PROCESSMBR) PARM(&MBR &RUNID)) +
    JOBQ(APPDATA/BATCHQ) JOBD(APPDATA/NIGHTJD) INLLIBL(*JOBD)
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  RETURN
ERROR:
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
    MSGDTA('Staging/submission failed; inspect run and job log') +
    MSGTYPE(*ESCAPE)
ENDPGM

Preflight the qualified program with CHKOBJ and monitor its documented CPF9801 object-not-found condition. A generic CPF0001 does not establish that program resolution failed. Keep authority failures distinct. A failure from CALL itself must remain a failed return; simply receiving its exception message does not propagate it.

This wrapper reports context using CPF9898 and keeps the original diagnostics in the job log. It does not re-send the original message ID. The full job monitor should store job identity/run ID and inspect the first relevant diagnostic; no program call or host compilation was performed.

CLLE source fragment

PGM PARM(&RUNID)
  DCL VAR(&RUNID) TYPE(*CHAR) LEN(20)
  CHKOBJ OBJ(APPDATA/NIGHTLY) OBJTYPE(*PGM) AUT(*USE)
  MONMSG MSGID(CPF9801) EXEC(GOTO CMDLBL(NOTFOUND))
  CALL PGM(APPDATA/NIGHTLY) PARM(&RUNID)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(FAILED))
  RETURN
NOTFOUND:
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
    MSGDTA('APPDATA/NIGHTLY missing; run ' *CAT &RUNID) +
    MSGTYPE(*ESCAPE)
  RETURN
FAILED:
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
    MSGDTA('NIGHTLY call failed; inspect job log; run ' *CAT &RUNID) +
    MSGTYPE(*ESCAPE)
ENDPGM

A procedure that declares a response structure return must actually return that structure on every normal path. Keep the request/response definitions identical in both versions, copy the correlation identifier and reject invalid requests before calling the business helper. Return the helper's documented result rather than implicitly declaring success.

These are procedure/module fragments for an RPG caller, not a complete HTTP or JSON API. ApplyRequest is an omitted helper that must authorize, deduplicate and atomically apply the business effect. Add NOMAIN/module binding and shared prototypes as appropriate; neither source has been compiled.

Fixed-format RPG

     DRequest_t        DS                  QUALIFIED TEMPLATE
     DoperationId                    40A
     DcustomerId                      9P 0
     DResponse_t       DS                  QUALIFIED TEMPLATE
     Dcode                           10I 0
     Dmessage                       256A   VARYING
     DcorrelationId                  40A
     DprocessRequest   PR                  LIKEDS(Response_t)
     Drequest                              LIKEDS(Request_t) CONST
     DApplyRequest     PR                  LIKEDS(Response_t)
     Drequest                              LIKEDS(Request_t) CONST
     PprocessRequest   B                   EXPORT
     D                 PI                  LIKEDS(Response_t)
     Drequest                              LIKEDS(Request_t) CONST
     Dresponse         DS                  LIKEDS(Response_t)
     C                   CLEAR     response
     C                   EVAL      response.correlationId = request.operationId
     C                   IF        %trim(request.operationId) = '' or
     C                             request.customerId <= 0
     C                   EVAL      response.code = 1
     C                   EVAL      response.message = 'Invalid request'
     C                   RETURN    response
     C                   ENDIF
     C                   EVAL      response = ApplyRequest(request)
     C                   EVAL      response.correlationId = request.operationId
     C                   RETURN    response
     PprocessRequest   E

Fully free RPG

**FREE
dcl-ds Request_t qualified template;
  operationId char(40);
  customerId packed(9:0);
end-ds;
dcl-ds Response_t qualified template;
  code int(10);
  message varchar(256);
  correlationId char(40);
end-ds;
dcl-pr processRequest likeds(Response_t);
  request likeds(Request_t) const;
end-pr;
dcl-pr ApplyRequest likeds(Response_t);
  request likeds(Request_t) const;
end-pr;
dcl-proc processRequest export;
  dcl-pi *n likeds(Response_t);
    request likeds(Request_t) const;
  end-pi;
  dcl-ds response likeds(Response_t);
clear response;
response.correlationId = request.operationId;
if %trim(request.operationId) = '' or request.customerId <= 0;
  response.code = 1;
  response.message = 'Invalid request';
  return response;
endif;
response = ApplyRequest(request);
response.correlationId = request.operationId;
return response;
end-proc;

First fix the lookup contract: a singleton SELECT INTO must not arbitrarily match every open order for a customer. This example asks for the earliest open order by unique order_id, orders explicitly and bounds the result to one row. If the business needs all orders, use a cursor/page instead. Clear output and check SQLSTATE before accepting returned values.

These are equivalent calculation fragments, not complete programs. Add the declarations, file/schema fixtures and helper implementations listed below; no IBM i compilation or execution has been performed. Timing helpers, representative data and an IBM i access-plan measurement session are omitted. The snippet shows a measurable query contract, not a demonstrated performance improvement.

Fixed-format RPG

     C                   CLEAR     orderId
     C                   CLEAR     amount
     C                   EVAL      found = *off
     C                   EXSR      StartTiming
     C/EXEC SQL
     C+ select order_id, amount into :orderId, :amount
     C+ from appdata.orders
     C+ where customer_id = :customerId and status = 'OPEN'
     C+ order by order_id fetch first 1 row only
     C/END-EXEC
     C                   EVAL      savedState = SQLSTT
     C                   IF        savedState = '00000'
     C                   EVAL      found = *on
     C                   ENDIF
     C                   EXSR      RecordTiming

Fully free RPG

**FREE
clear orderId;
clear amount;
found = *off;
exsr StartTiming;
exec sql select order_id, amount into :orderId, :amount
  from appdata.orders
  where customer_id = :customerId and status = 'OPEN'
  order by order_id fetch first 1 row only;
savedState = SQLSTT;
if savedState = '00000';
  found = *on;
endif;
exsr RecordTiming;

Fragment assumptions: the caller supplies validated unitPrice and qty in the declared packed-decimal fields; these declarations and calculations belong inside an existing program. Multiply at four decimal places into rawAmount, then use %DECH to half-adjust the complete line to cents. Both examples deliberately preserve fractional cents until the line amount is known.

The business rule is half-adjust rounding, including ties away from zero for negative amounts. It is not a rule to round every unit price first: three units at 1.0050 produce 3.02 under this contract. Validate the supported quantity and price range before this fragment and retain the original precision for audit; a different contractual rounding rule needs a different implementation.

Fixed-format RPG

     DunitPrice        S             11P 4
     Dqty              S              5P 0
     DrawAmount        S             17P 4
     DlineAmount       S             15P 2
     C                   EVAL      rawAmount = qty * unitPrice
     C                   EVAL      lineAmount = %dech(rawAmount:15:2)

Fully free RPG

**FREE
dcl-s unitPrice packed(11:4);
dcl-s qty packed(5:0);
dcl-s rawAmount packed(17:4);
dcl-s lineAmount packed(15:2);
rawAmount = qty * unitPrice;
lineAmount = %dech(rawAmount:15:2);

Fragment assumptions: the caller loads codes, amounts and used with a valid existing list, where 0 <= used <= 5 and occupied codes are unique. newCode is nonblank and newQty is positive; all totals fit packed(9:0). Search only occupied slots. A match adds to its quantity without increasing used, while a new code consumes one slot only if capacity remains.

Initialize pos on every invocation and skip %LOOKUP when used is zero, because there is no occupied range to search. Check the returned index rather than %FOUND: the lookup built-in does not establish a file-found result. FULL must leave the existing arrays and count untouched so the caller can split the picking list without losing quantities.

Fixed-format RPG

     Dcodes            S             10A   DIM(5)
     Damounts          S              9P 0 DIM(5)
     Dused             S             10I 0
     DnewCode          S             10A
     DnewQty           S              9P 0
     Dpos              S             10I 0
     Doutcome          S              8A
     C                   EVAL      pos = 0
     C                   IF        used > 0
     C                   EVAL      pos = %lookup(newCode:codes:1:used)
     C                   ENDIF
     C                   IF        pos > 0
     C                   EVAL      amounts(pos) += newQty
     C                   EVAL      outcome = 'MERGED'
     C                   ELSEIF    used < %elem(codes)
     C                   EVAL      used += 1
     C                   EVAL      codes(used) = newCode
     C                   EVAL      amounts(used) = newQty
     C                   EVAL      outcome = 'ADDED'
     C                   ELSE
     C                   EVAL      outcome = 'FULL'
     C                   ENDIF

Fully free RPG

**FREE
dcl-s codes char(10) dim(5);
dcl-s amounts packed(9:0) dim(5);
dcl-s used int(10);
dcl-s newCode char(10);
dcl-s newQty packed(9:0);
dcl-s pos int(10);
dcl-s outcome char(8);
pos = 0;
if used > 0;
  pos = %lookup(newCode:codes:1:used);
endif;
if pos > 0;
  amounts(pos) += newQty;
  outcome = 'MERGED';
elseif used < %elem(codes);
  used += 1;
  codes(used) = newCode;
  amounts(used) = newQty;
  outcome = 'ADDED';
else;
  outcome = 'FULL';
endif;

Fragment assumptions: dueDate and asOf are valid RPG date values supplied by the caller. The fragment calculates elapsed calendar days as reporting date minus due date. An invoice due today or in the future is CURRENT; positive ages from 1 through 30 and 31 through 60 occupy the next two buckets, with larger ages in OVER60.

Passing asOf makes a historical report reproducible instead of letting the machine date change the answer between runs. %DIFF with *DAYS performs date arithmetic across month ends and leap days. The classification here excludes payment allocation, business-day calendars and time zones because its inputs are already business dates; those belong in the surrounding reporting contract.

Fixed-format RPG

     DdueDate          S               D
     DasOf             S               D
     DageDays          S             10I 0
     Dbucket           S              8A
     C                   EVAL      ageDays = %diff(asOf:dueDate:*days)
     C                   IF        ageDays <= 0
     C                   EVAL      bucket = 'CURRENT'
     C                   ELSEIF    ageDays <= 30
     C                   EVAL      bucket = 'DUE1_30'
     C                   ELSEIF    ageDays <= 60
     C                   EVAL      bucket = 'DUE31_60'
     C                   ELSE
     C                   EVAL      bucket = 'OVER60'
     C                   ENDIF

Fully free RPG

**FREE
dcl-s dueDate date;
dcl-s asOf date;
dcl-s ageDays int(10);
dcl-s bucket char(8);
ageDays = %diff(asOf:dueDate:*days);
if ageDays <= 0;
  bucket = 'CURRENT';
elseif ageDays <= 30;
  bucket = 'DUE1_30';
elseif ageDays <= 60;
  bucket = 'DUE31_60';
else;
  bucket = 'OVER60';
endif;

Fragment assumptions: Shipment is an externally described, input-only file with an ascending composite access path (customer number packed(9:0), shipNo packed(9:0)); shipNo is an input field from its record format. wantCust matches the leading key exactly. Both fragments position after the requested customer group with SETGT and retrieve the preceding matching row with an explicitly keyed READPE.

The largest sequence is treated as the latest shipment only because that is the application’s ordering contract. READPE reports the boundary through %EOF when the previous row belongs to another customer, so the result remains zero with hasShip off. Keep the requested key separate from fields overwritten by input and reposition on every invocation; a prior end-of-file state must not control a new search.

Fixed-format RPG

     FShipment  IF   E           K DISK
     DwantCust         S              9P 0
     DlastShip         S              9P 0
     DhasShip          S               N
     C                   EVAL      lastShip = 0
     C                   EVAL      hasShip = *off
     C     wantCust      SETGT     Shipment
     C     wantCust      READPE    Shipment
     C                   IF        not %eof(Shipment)
     C                   EVAL      lastShip = shipNo
     C                   EVAL      hasShip = *on
     C                   ENDIF

Fully free RPG

**FREE
dcl-f Shipment keyed usage(*input);
dcl-s wantCust packed(9:0);
dcl-s lastShip packed(9:0);
dcl-s hasShip ind;
lastShip = 0;
hasShip = *off;
setgt wantCust Shipment;
readpe wantCust Shipment;
if not %eof(Shipment);
  lastShip = shipNo;
  hasShip = *on;
endif;

Subprocedure assumptions: insert the fixed-format prototype in the declaration section and the P-spec procedure after the enclosing program’s main calculations; the free version supplies the equivalent prototype and procedure. OrderLabel returns char(40), accepts a required char(10) orderId, and accepts a trailing char(10) prefix declared CONST OPTIONS(*NOPASS). Both implementations default to ORD on every call and examine prefix only when %PARMS confirms it exists.

Not passing a parameter differs from passing blanks. This contract deliberately honors a supplied blank prefix, which produces a leading hyphen, while a one-argument call uses ORD. The prototype and procedure interface must agree, and every parameter after the first *NOPASS parameter must also be optional. This example does not allow *OMIT; supporting *OMIT would require an additional availability check.

Fixed-format RPG

     DOrderLabel       PR            40A
     DorderId                        10A   CONST
     Dprefix                         10A   CONST OPTIONS(*NOPASS)
     POrderLabel       B
     DOrderLabel       PI            40A
     DorderId                        10A   CONST
     Dprefix                         10A   CONST OPTIONS(*NOPASS)
     DusePrefix        S             10A
     C                   EVAL      usePrefix = 'ORD'
     C                   IF        %parms() >= 2
     C                   EVAL      usePrefix = prefix
     C                   ENDIF
     C                   RETURN    %trim(usePrefix) + '-' + %trim(orderId)
     POrderLabel       E

Fully free RPG

**FREE
dcl-pr OrderLabel char(40);
  orderId char(10) const;
  prefix char(10) const options(*nopass);
end-pr;

dcl-proc OrderLabel;
  dcl-pi *n char(40);
    orderId char(10) const;
    prefix char(10) const options(*nopass);
  end-pi;
  dcl-s usePrefix char(10);
  usePrefix = 'ORD';
  if %parms() >= 2;
    usePrefix = prefix;
  endif;
  return %trim(usePrefix) + '-' + %trim(orderId);
end-proc;

Fragment assumptions: Config is an input-only externally described keyed file declared USROPN, cfgKey exactly matches its key, and enabled is supplied by the caller. The enclosing routine may call this fragment when Config is already open. didOpen records ownership of a successful OPEN so cleanup closes only the open performed here. outcome distinguishes disabled, missing, loaded, and I/O failure.

OPEN(E) and CHAIN(E) set %ERROR for their own operation, so check it immediately before another extended operation changes it. A failed OPEN skips the read. The normal cleanup uses CLOSE(E) and reports CLOSEERR if closing fails; a production caller should preserve detailed %STATUS information and arrange cleanup for unexpected exceptions outside these shown operations. A disabled request does no file I/O.

Fixed-format RPG

     FConfig    IF   E           K DISK    USROPN
     Denabled          S               N
     DcfgKey           S             10A
     DdidOpen          S               N
     Doutcome          S             10A
     C                   EVAL      didOpen = *off
     C                   EVAL      outcome = 'DISABLED'
     C                   IF        enabled
     C                   EVAL      outcome = 'OPENERR'
     C                   IF        not %open(Config)
     C                   OPEN(E)   Config
     C                   IF        not %error()
     C                   EVAL      didOpen = *on
     C                   ENDIF
     C                   ENDIF
     C                   IF        %open(Config)
     C     cfgKey        CHAIN(E)  Config
     C                   IF        %error()
     C                   EVAL      outcome = 'READERR'
     C                   ELSEIF    %found(Config)
     C                   EVAL      outcome = 'LOADED'
     C                   ELSE
     C                   EVAL      outcome = 'MISSING'
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C                   IF        didOpen
     C                   CLOSE(E)  Config
     C                   IF        %error()
     C                   EVAL      outcome = 'CLOSEERR'
     C                   ENDIF
     C                   ENDIF

Fully free RPG

**FREE
dcl-f Config keyed usage(*input) usropn;
dcl-s enabled ind;
dcl-s cfgKey char(10);
dcl-s didOpen ind;
dcl-s outcome char(10);
didOpen = *off;
outcome = 'DISABLED';
if enabled;
  outcome = 'OPENERR';
  if not %open(Config);
    open(e) Config;
    if not %error();
      didOpen = *on;
    endif;
  endif;
  if %open(Config);
    chain(e) cfgKey Config;
    if %error();
      outcome = 'READERR';
    elseif %found(Config);
      outcome = 'LOADED';
    else;
      outcome = 'MISSING';
    endif;
  endif;
endif;
if didOpen;
  close(e) Config;
  if %error();
    outcome = 'CLOSEERR';
  endif;
endif;

Fragment assumptions: BinStock is an externally described input file keyed in ascending order by region char(2), warehouse char(3), and SKU char(10). Its units field is packed(9:0); the search variables have identical key attributes and CCSIDs. The fixed version builds a two-field KLIST, while the free version supplies the same two values as a parenthesized key list.

Only a leading portion of the composite key can be omitted this way: region plus warehouse is valid, but warehouse alone would not mean the desired selection. Initialize totalUnits and rowCount, position once, and process each successful READE. An unmatched warehouse produces zero rows and zero units without reading stale fields from the last successful request.

Fixed-format RPG

     FBinStock  IF   E           K DISK
     DwantReg          S              2A
     DwantWhs          S              3A
     DtotalUnits       S             15P 0
     DrowCount         S             10I 0
     C     WhsKey        KLIST
     C                   KFLD                    wantReg
     C                   KFLD                    wantWhs
     C                   EVAL      totalUnits = 0
     C                   EVAL      rowCount = 0
     C     WhsKey        SETLL     BinStock
     C     WhsKey        READE     BinStock
     C                   DOW       not %eof(BinStock)
     C                   EVAL      totalUnits += units
     C                   EVAL      rowCount += 1
     C     WhsKey        READE     BinStock
     C                   ENDDO

Fully free RPG

**FREE
dcl-f BinStock keyed usage(*input);
dcl-s wantReg char(2);
dcl-s wantWhs char(3);
dcl-s totalUnits packed(15:0);
dcl-s rowCount int(10);
// Fixed form uses WhsKey with these two fields.
// First key: wantReg.
// Second key: wantWhs.
totalUnits = 0;
rowCount = 0;
setll (wantReg:wantWhs) BinStock;
reade (wantReg:wantWhs) BinStock;
dow not %eof(BinStock);
  totalUnits += units;
  rowCount += 1;
  reade (wantReg:wantWhs) BinStock;
enddo;

Fragment assumptions: Reserve is an externally described keyed update/delete-capable file with record format ResRec, key packed(9:0), and rsvStatus char(1); C means canceled. The file is not under commitment control in this focused example. CHAIN reads with a lock, and DELETE without a search key targets exactly that current locked record after its status has been checked.

MISSING performs no deletion. An active reservation returns RETAINED after UNLOCK so the routine does not hold a record while its caller decides what to do. These snippets show the successful-I/O business path; I/O exceptions deliberately propagate to the surrounding error boundary. Real application integration must add diagnostics and cleanup appropriate to its transaction policy, and must not claim RETAINED or DELETED after a failed operation.

Fixed-format RPG

     FReserve   UF   E           K DISK
     DreserveId        S              9P 0
     Doutcome          S              8A
     C                   EVAL      outcome = 'MISSING'
     C     reserveId     CHAIN     ResRec
     C                   IF        %found(Reserve)
     C                   IF        rsvStatus = 'C'
     C                   DELETE    ResRec
     C                   EVAL      outcome = 'DELETED'
     C                   ELSE
     C                   UNLOCK    Reserve
     C                   EVAL      outcome = 'RETAINED'
     C                   ENDIF
     C                   ENDIF

Fully free RPG

**FREE
dcl-f Reserve keyed usage(*update:*delete);
dcl-s reserveId packed(9:0);
dcl-s outcome char(8);
outcome = 'MISSING';
chain reserveId ResRec;
if %found(Reserve);
  if rsvStatus = 'C';
    delete ResRec;
    outcome = 'DELETED';
  else;
    unlock Reserve;
    outcome = 'RETAINED';
  endif;
endif;

SQL fragment assumptions: compile as SQLRPGLE with SQL naming and the normal SQLCA. APPDATA.ORDERPLAN has unique integer ORDER_ID and nullable DATE SHIP_DATE. The caller supplies orderId. shipInd is a two-byte signed integer, paired with shipDate in SELECT INTO. Only a successful, non-null result is converted into the character output shown to the caller.

A nullable date is not a blank date or a zero date. A negative output indicator means the associated date must not be used. Initialize dateText each time, distinguish SQLSTATE 02000 from a successful NULL, and treat other states as SQLERR. This prevents a previous order’s date from appearing after a null or missing-row lookup; dateText is meaningful as a date only with outcome DATED.

Fixed-format RPG

     DorderId          S             10I 0
     DshipDate         S               D
     DshipInd          S              5I 0
     DdateText         S             10A
     Doutcome          S             10A
     C                   EVAL      dateText = *blanks
     C                   EVAL      outcome = 'SQLERR'
     C/EXEC SQL
     C+ SELECT SHIP_DATE INTO :shipDate :shipInd
     C+ FROM APPDATA.ORDERPLAN WHERE ORDER_ID = :orderId
     C/END-EXEC
     C                   IF        SQLSTATE = '00000'
     C                   IF        shipInd < 0
     C                   EVAL      outcome = 'UNPLANNED'
     C                   ELSE
     C                   EVAL      dateText = %char(shipDate:*iso)
     C                   EVAL      outcome = 'DATED'
     C                   ENDIF
     C                   ELSEIF    SQLSTATE = '02000'
     C                   EVAL      outcome = 'MISSING'
     C                   ENDIF

Fully free RPG

**FREE
dcl-s orderId int(10);
dcl-s shipDate date;
dcl-s shipInd int(5);
dcl-s dateText char(10);
dcl-s outcome char(10);
dateText = *blanks;
outcome = 'SQLERR';
exec sql
  SELECT SHIP_DATE INTO :shipDate :shipInd
  FROM APPDATA.ORDERPLAN WHERE ORDER_ID = :orderId;
if SQLSTATE = '00000';
  if shipInd < 0;
    outcome = 'UNPLANNED';
  else;
    dateText = %char(shipDate:*iso);
    outcome = 'DATED';
  endif;
elseif SQLSTATE = '02000';
  outcome = 'MISSING';
endif;

SQL fragment assumptions: compile as SQLRPGLE with SQL naming and the normal SQLCA. APPDATA.STOCKEDIT has unique integer ITEM_ID, integer QTY, and a non-null integer REVISION. The caller supplies a validated nonnegative newQty and the oldVersion it originally read. Every writer increments REVISION, versions are not reset or reused for an identity, and overflow is prevented by the application contract.

The update tests identity and old version in one statement while incrementing the version in that same statement. Capture SQLSTATE and SQLERRD(3) immediately: one affected row means UPDATED, and zero means the row is missing or stale, reported together as CONFLICT. Do not silently retry using a freshly read version, because that would discard the user’s opportunity to review another person’s edit. The surrounding caller owns commit or rollback and reports final persistence only after its transaction succeeds.

Fixed-format RPG

     DitemId           S             10I 0
     DnewQty           S             10I 0
     DoldVersion       S             10I 0
     Dchanged          S             10I 0
     DsaveState        S              5A
     Doutcome          S             10A
     C/EXEC SQL
     C+ UPDATE APPDATA.STOCKEDIT
     C+ SET QTY = :newQty, REVISION = REVISION + 1
     C+ WHERE ITEM_ID = :itemId AND REVISION = :oldVersion
     C/END-EXEC
     C                   EVAL      saveState = SQLSTATE
     C                   EVAL      changed = SQLERRD(3)
     C                   EVAL      outcome = 'SQLERR'
     C                   IF        saveState = '00000' or saveState = '02000'
     C                   IF        changed = 1
     C                   EVAL      outcome = 'UPDATED'
     C                   ELSEIF    changed = 0
     C                   EVAL      outcome = 'CONFLICT'
     C                   ENDIF
     C                   ENDIF

Fully free RPG

**FREE
dcl-s itemId int(10);
dcl-s newQty int(10);
dcl-s oldVersion int(10);
dcl-s changed int(10);
dcl-s saveState char(5);
dcl-s outcome char(10);
exec sql
  UPDATE APPDATA.STOCKEDIT
  SET QTY = :newQty, REVISION = REVISION + 1
  WHERE ITEM_ID = :itemId AND REVISION = :oldVersion;
saveState = SQLSTATE;
changed = SQLERRD(3);
outcome = 'SQLERR';
if saveState = '00000' or saveState = '02000';
  if changed = 1;
    outcome = 'UPDATED';
  elseif changed = 0;
    outcome = 'CONFLICT';
  endif;
endif;

SQL fragment assumptions: compile as SQLRPGLE with SQL naming. APPDATA.PAYSTAGE has BATCH_ID char(10) and non-null AMOUNT decimal(11,2). The batch is frozen for validation and posting, all rows have passed field-level validation, and totals fit packed(17:2). The caller supplies batchId, expectedCount and expectedTotal from a validated trailer. A single aggregate query returns both observed controls for precisely that batch.

BALANCED requires both the count and the sum to match; checking money alone can hide missing or duplicated records with offsetting amounts. COALESCE supplies zero for the empty batch’s null SUM, making a declared zero-row batch a defined case. The check is a posting gate, not a complete integrity proof: enforce unique payment identifiers separately and preserve the same frozen batch or transaction boundary until posting consumes it.

Fixed-format RPG

     DbatchId          S             10A
     DexpectedCount    S             10I 0
     DexpectedTotal    S             17P 2
     DgotCount         S             10I 0
     DgotTotal         S             17P 2
     Doutcome          S             10A
     C                   EVAL      outcome = 'SQLERR'
     C/EXEC SQL
     C+ SELECT COUNT(*), COALESCE(SUM(AMOUNT), 0)
     C+ INTO :gotCount, :gotTotal FROM APPDATA.PAYSTAGE
     C+ WHERE BATCH_ID = :batchId
     C/END-EXEC
     C                   IF        SQLSTATE = '00000'
     C                   IF        gotCount = expectedCount
     C                   IF        gotTotal = expectedTotal
     C                   EVAL      outcome = 'BALANCED'
     C                   ELSE
     C                   EVAL      outcome = 'MISMATCH'
     C                   ENDIF
     C                   ELSE
     C                   EVAL      outcome = 'MISMATCH'
     C                   ENDIF
     C                   ENDIF

Fully free RPG

**FREE
dcl-s batchId char(10);
dcl-s expectedCount int(10);
dcl-s expectedTotal packed(17:2);
dcl-s gotCount int(10);
dcl-s gotTotal packed(17:2);
dcl-s outcome char(10);
outcome = 'SQLERR';
exec sql
  SELECT COUNT(*), COALESCE(SUM(AMOUNT), 0)
  INTO :gotCount, :gotTotal FROM APPDATA.PAYSTAGE
  WHERE BATCH_ID = :batchId;
if SQLSTATE = '00000';
  if gotCount = expectedCount;
    if gotTotal = expectedTotal;
      outcome = 'BALANCED';
    else;
      outcome = 'MISMATCH';
    endif;
  else;
    outcome = 'MISMATCH';
  endif;
endif;

SQL fragment assumptions: compile as SQLRPGLE with the normal SQLCA and SQL naming. The owning routine has declared and successfully opened cursor C1 for SELECT ORDER_ID, AMOUNT FROM APPDATA.ORDERS ORDER BY ORDER_ID, where ORDER_ID is a unique non-null INTEGER and AMOUNT is non-null DECIMAL(11,2). This is one-fetch processing, not the whole cursor lifecycle. batch has exactly the same column order and twenty elements.

Copy SQLSTATE and SQLERRD(3) immediately after FETCH, then process only elements 1 through gotRows for success or normal no-data completion. A short final batch may arrive with SQLSTATE 02000 while still containing valid rows; discarding all 02000 batches loses data. The caller repeats after a full successful batch, stops after processing a 02000 batch, handles every other state as failure, and closes C1 on each exit path. Old values outside gotRows are deliberately ignored.

Fixed-format RPG

     Dbatch            DS                  QUALIFIED DIM(20)
     DorderId                        10I 0
     Damount                         11P 2
     DgotRows          S             10I 0
     Didx              S             10I 0
     DfetchState       S              5A
     DbatchTotal       S             15P 2
     C/EXEC SQL
     C+ FETCH C1 FOR 20 ROWS INTO :batch
     C/END-EXEC
     C                   EVAL      fetchState = SQLSTATE
     C                   EVAL      gotRows = SQLERRD(3)
     C                   EVAL      batchTotal = 0
     C                   IF        fetchState = '00000' or fetchState = '02000'
     C                   FOR       idx = 1 to gotRows
     C                   EVAL      batchTotal += batch(idx).amount
     C                   ENDFOR
     C                   ELSE
     C                   EVAL      gotRows = 0
     C                   ENDIF

Fully free RPG

**FREE
dcl-ds batch qualified dim(20);
  orderId int(10);
  amount packed(11:2);
end-ds;
dcl-s gotRows int(10);
dcl-s idx int(10);
dcl-s fetchState char(5);
dcl-s batchTotal packed(15:2);
exec sql
  FETCH C1 FOR 20 ROWS INTO :batch;
fetchState = SQLSTATE;
gotRows = SQLERRD(3);
batchTotal = 0;
if fetchState = '00000' or fetchState = '02000';
  for idx = 1 to gotRows;
    batchTotal += batch(idx).amount;
  endfor;
else;
  gotRows = 0;
endif;

Use a lab physical file APPDATA/LABORD that exists at compile time and contains a non-null packed-decimal AMOUNT field of length 9 with 2 decimal places. DCLF supplies the record fields as CL variables. Return COUNT as packed decimal (7,0) and TOTAL as packed decimal (15,2); initialize both before the first read. The example processes every row in the selected member and does not apply a business filter.

Keep the CPF0864 monitor immediately after RCVF and leave the loop before using the fields. On this exception the record fields retain their previous values, which is why processing first and checking later duplicates the final amount. Other I/O or arithmetic exceptions must escape; callers must discard partial output parameters after a failure. Run the lab against stable test data because this loop does not promise a transactional snapshot.

Example

PGM PARM(&COUNT &TOTAL)
  DCL VAR(&COUNT) TYPE(*DEC) LEN(7 0)
  DCL VAR(&TOTAL) TYPE(*DEC) LEN(15 2)
  DCLF FILE(APPDATA/LABORD)

  CHGVAR VAR(&COUNT) VALUE(0)
  CHGVAR VAR(&TOTAL) VALUE(0)
READNEXT:
  RCVF
  MONMSG MSGID(CPF0864) EXEC(GOTO CMDLBL(DONE))
  CHGVAR VAR(&COUNT) VALUE(&COUNT + 1)
  CHGVAR VAR(&TOTAL) VALUE(&TOTAL + &AMOUNT)
  GOTO CMDLBL(READNEXT)
DONE:
  RETURN
ENDPGM

Prepare APPLAB/LABSEQ as a decimal data area (9,0) containing the last issued number, initially zero. One job must own an exclusive allocation across the retrieve, increment, and change commands. The output NEXT is packed decimal (9,0). The listing releases only the allocation it acquired, using the same qualified object, lock state, and job scope on both commands; an allocation failure occurs before any cleanup path is entered.

The failure path attempts to release the lock and sends an escape even if cleanup succeeds. A cleanup failure produces a diagnostic instead of being silently ignored. The sequence is not a business transaction: a number may have been consumed before a later failure, so the caller must discard NEXT on any escape and must not reuse gaps automatically. This lab assumes a single-threaded job and no other same-job routine manages this allocation.

Example

PGM PARM(&NEXT)
  DCL VAR(&NEXT) TYPE(*DEC) LEN(9 0)
  DCL VAR(&WHY) TYPE(*CHAR) LEN(100) +
      VALUE('Sequence update failed; inspect preceding messages.')

  ALCOBJ OBJ((APPLAB/LABSEQ *DTAARA *EXCL)) +
      WAIT(5) SCOPE(*JOB)
  RTVDTAARA DTAARA(APPLAB/LABSEQ *ALL) RTNVAR(&NEXT)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(FAILED))
  IF COND(&NEXT *LT 0 *OR &NEXT *GE 999999999) THEN(DO)
    CHGVAR VAR(&WHY) VALUE('Sequence value is invalid or exhausted.')
    GOTO CMDLBL(FAILED)
  ENDDO
  CHGVAR VAR(&NEXT) VALUE(&NEXT + 1)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(FAILED))
  CHGDTAARA DTAARA(APPLAB/LABSEQ *ALL) VALUE(&NEXT)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(FAILED))
  DLCOBJ OBJ((APPLAB/LABSEQ *DTAARA *EXCL)) SCOPE(*JOB)
  RETURN

FAILED:
  DLCOBJ OBJ((APPLAB/LABSEQ *DTAARA *EXCL)) SCOPE(*JOB)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(SNDPGMMSG +
      MSG('Sequence lock cleanup failed; inspect the job log.') +
      MSGTYPE(*DIAG))
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA(&WHY) +
      MSGTYPE(*ESCAPE)
ENDPGM

Create APPDATA/LABSALE and APPDATA/LABCREDIT as single-format lab physical files, each with a non-null packed-decimal AMOUNT (9,2). Declare them with different OPNID values so their generated variables become &S_AMOUNT and &C_AMOUNT. Return SALES, CREDITS, and NET as packed decimal (15,2). Credits are positive values to subtract, and the example reads stable test members from beginning to end.

Use independent read loops with a separate EOF branch for each open identifier. A paired read loop would incorrectly stop when the shorter file ends and would imply a relationship between row positions that this report does not have. Calculate NET only when both loops finish normally. A real accounting reconciliation may need a shared cutoff or consistent snapshot, which is a separate requirement from identifying the files correctly.

Example

PGM PARM(&SALES &CREDITS &NET)
  DCL VAR(&SALES) TYPE(*DEC) LEN(15 2)
  DCL VAR(&CREDITS) TYPE(*DEC) LEN(15 2)
  DCL VAR(&NET) TYPE(*DEC) LEN(15 2)
  DCLF FILE(APPDATA/LABSALE) OPNID(S)
  DCLF FILE(APPDATA/LABCREDIT) OPNID(C)

  CHGVAR VAR(&SALES) VALUE(0)
  CHGVAR VAR(&CREDITS) VALUE(0)
  CHGVAR VAR(&NET) VALUE(0)
READSALE:
  RCVF OPNID(S)
  MONMSG MSGID(CPF0864) EXEC(GOTO CMDLBL(READCREDIT))
  CHGVAR VAR(&SALES) VALUE(&SALES + &S_AMOUNT)
  GOTO CMDLBL(READSALE)
READCREDIT:
  RCVF OPNID(C)
  MONMSG MSGID(CPF0864) EXEC(GOTO CMDLBL(DONE))
  CHGVAR VAR(&CREDITS) VALUE(&CREDITS + &C_AMOUNT)
  GOTO CMDLBL(READCREDIT)
DONE:
  CHGVAR VAR(&NET) VALUE(&SALES - &CREDITS)
  RETURN
ENDPGM

Provide APPLAB/OBJMODEL as an empty model file with the QADSPOBJ layout required by DSPOBJD, and authorize the lab user to duplicate it. APPLAB/OBJREPORT is an exercise worker taking two CHAR(10) parameters, library then file; it reads that inventory, produces the report, closes its files, and sends an escape on failure. First create QTEMP/LABOBJ with CRTDUPOBJ. An existing object makes creation fail before the program can replace or delete its contents.

Only after successful creation may DSPOBJD replace the owned member and the worker consume it. On failure, the wrapper attempts a targeted delete and propagates an escape with the earlier diagnostics still in the job log. QTEMP belongs to the executing job, so this entire wrapper must run inside the job that produces the report; submitting only OBJREPORT would give it another QTEMP. This inventory is a report of visible objects, not proof that the user can see every object in the library.

Example

PGM
  DCL VAR(&LIB) TYPE(*CHAR) LEN(10) VALUE('QTEMP')
  DCL VAR(&FILE) TYPE(*CHAR) LEN(10) VALUE('LABOBJ')

  CRTDUPOBJ OBJ(OBJMODEL) FROMLIB(APPLAB) OBJTYPE(*FILE) +
      TOLIB(QTEMP) NEWOBJ(LABOBJ) DATA(*NO)
  DSPOBJD OBJ(APPLAB/*ALL) OBJTYPE(*PGM) DETAIL(*BASIC) +
      OUTPUT(*OUTFILE) OUTFILE(QTEMP/LABOBJ) +
      OUTMBR(*FIRST *REPLACE)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(FAILED))
  CALL PGM(APPLAB/OBJREPORT) PARM(&LIB &FILE)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(FAILED))
  DLTF FILE(QTEMP/LABOBJ)
  RETURN

FAILED:
  DLTF FILE(QTEMP/LABOBJ)
  MONMSG MSGID(CPF0000 MCH0000) EXEC(SNDPGMMSG +
      MSG('Could not delete this run''s QTEMP/LABOBJ file.') +
      MSGTYPE(*DIAG))
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
      MSGDTA('Inventory report failed; inspect preceding messages.') +
      MSGTYPE(*ESCAPE)
ENDPGM

Prepare APPLAB/READORD as a read-only lab worker that reads APPDATA/LABORD and closes it before returning. CHKOBJ without AUT only tests existence. The listing requests use authority for the program and the operational/read authorities required by the lab file, including its first member. Run the wrapper without adopted owner authority when testing the caller's own effective access; otherwise document which authority context the check is evaluating.

Leave the original errors available to the caller: for example, CPF9801 identifies an object that cannot be found, CPF9802 identifies missing object authority, and CPF9820 identifies missing library-use authority. Passing a preflight does not reserve the object or freeze permissions, so CALL must still be allowed to fail. Do not repair a failed check by granting broad authority or substituting another library-list object. DONE, a CHAR(1) output, becomes Y only after the worker returns normally.

Example

PGM PARM(&DONE)
  DCL VAR(&DONE) TYPE(*CHAR) LEN(1)

  CHGVAR VAR(&DONE) VALUE('N')
  CHKOBJ OBJ(APPLAB/READORD) OBJTYPE(*PGM) AUT(*USE)
  CHKOBJ OBJ(APPDATA/LABORD) OBJTYPE(*FILE) +
      MBR(*FIRST) AUT(*OBJOPR *READ)
  CALL PGM(APPLAB/READORD)
  CHGVAR VAR(&DONE) VALUE('Y')
  RETURN
ENDPGM

APPLAB/CHECKRUN is a lab worker taking a CHAR(20) run ID. For this bounded exercise its application escapes use CPF-prefixed message IDs and character replacement data no longer than 512 bytes. A command-level monitor transfers control immediately after the failed call, and RCVMSG captures the newest exception on this call entry before the wrapper adds another message. Keep the original message on the queue for job-log context and carry its returned message-file library with its name.

Re-send the captured ID with exactly the returned data length, treating a zero-length data record separately to avoid a zero-length substring. The wrapper also detects absent message metadata or data larger than its buffer and sends a clear fallback escape rather than claiming to preserve truncated data. This is a limited teaching wrapper, not a universal exception copier: binary or pointer-bearing system messages and arbitrary large replacement data require a suitably designed message API handler. Unmonitored exception families continue to escape normally.

Example

PGM PARM(&RUNID)
  DCL VAR(&RUNID) TYPE(*CHAR) LEN(20)
  DCL VAR(&MID) TYPE(*CHAR) LEN(7)
  DCL VAR(&MFILE) TYPE(*CHAR) LEN(10)
  DCL VAR(&MLIB) TYPE(*CHAR) LEN(10)
  DCL VAR(&MDATA) TYPE(*CHAR) LEN(512)
  DCL VAR(&DLEN) TYPE(*DEC) LEN(5 0)

  CALL PGM(APPLAB/CHECKRUN) PARM(&RUNID)
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(CAPTURE))
  RETURN

CAPTURE:
  RCVMSG PGMQ(*SAME) MSGTYPE(*EXCP) WAIT(0) RMV(*NO) +
      MSGID(&MID) MSGF(&MFILE) MSGFLIB(&MLIB) +
      MSGDTA(&MDATA) MSGDTALEN(&DLEN)
  SNDPGMMSG MSG('CHECKRUN failed for run' *BCAT &RUNID) +
      MSGTYPE(*DIAG)
  IF COND(&MID *EQ ' ' *OR &MFILE *EQ ' ' *OR +
      &MLIB *EQ ' ' *OR &DLEN *GT 512) +
      THEN(GOTO CMDLBL(FALLBACK))
  IF COND(&DLEN *EQ 0) THEN(DO)
    SNDPGMMSG MSGID(&MID) MSGF(&MLIB/&MFILE) +
        MSGTYPE(*ESCAPE)
    RETURN
  ENDDO
  SNDPGMMSG MSGID(&MID) MSGF(&MLIB/&MFILE) +
      MSGDTA(%SST(&MDATA 1 &DLEN)) MSGTYPE(*ESCAPE)
  RETURN

FALLBACK:
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
      MSGDTA('CHECKRUN failed; full error is in the job log.') +
      MSGTYPE(*ESCAPE)
ENDPGM

Create APPLAB/RETRYGATE as a lab data area. The routine receives TRIES as packed decimal (3,0), increments it before each attempt, and uses WAIT(0) so ALCOBJ itself does not add an unbounded wait. Its policy retries only CPF1002, the command's cannot-allocate response; other failures propagate immediately. The listing is an allocation probe: after success it releases its allocation and returns the number of attempts.

After the third failed attempt, send an escape without another delay. DLYJOB DLY(2) supplies a real pause between attempts, and CTLEND(*END), as documented on the IBM i 7.5 command, lets a controlled end terminate the waiting job. Inspect preceding diagnostics if allocation remains impossible; CPF1002 alone is not proof that every cause is transient. A real critical operation belongs while the lock is held and needs the cleanup discipline from the data-area exercise; this probe does not reserve future access.

Example

PGM PARM(&TRIES)
  DCL VAR(&TRIES) TYPE(*DEC) LEN(3 0)

  CHGVAR VAR(&TRIES) VALUE(0)
TRYLOCK:
  CHGVAR VAR(&TRIES) VALUE(&TRIES + 1)
  ALCOBJ OBJ((APPLAB/RETRYGATE *DTAARA *EXCL)) +
      WAIT(0) SCOPE(*JOB)
  MONMSG MSGID(CPF1002) EXEC(GOTO CMDLBL(BUSY))
  DLCOBJ OBJ((APPLAB/RETRYGATE *DTAARA *EXCL)) SCOPE(*JOB)
  RETURN

BUSY:
  IF COND(&TRIES *GE 3) THEN(GOTO CMDLBL(EXHAUSTED))
  DLYJOB DLY(2) CTLEND(*END)
  GOTO CMDLBL(TRYLOCK)
EXHAUSTED:
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
      MSGDTA('Gate allocation failed after three attempts.') +
      MSGTYPE(*ESCAPE)
ENDPGM

Retrieve TYPE into CHAR(1), JOB and USER into CHAR(10), NBR into CHAR(6), and CURUSER into CHAR(10). TYPE returns character 0 for batch and 1 for interactive. Build the qualified job identifier from number/user/name; USER is the job's original user component, while CURUSER reports the current profile. These values answer different diagnostic questions, especially in server or profile-switched work.

Provide APPLAB/BATCHRPT and APPLAB/PREVIEW with the same two input parameters: the qualified job identifier as CHAR(28), then current user as CHAR(10). Only PREVIEW may perform workstation I/O. The wrapper calls exactly one worker and propagates its errors. It does not infer interactivity from the job name, submitter, or current user, and a fallback escape prevents an unexpected type from falling through to a display operation.

Example

PGM
  DCL VAR(&TYPE) TYPE(*CHAR) LEN(1)
  DCL VAR(&JOB) TYPE(*CHAR) LEN(10)
  DCL VAR(&USER) TYPE(*CHAR) LEN(10)
  DCL VAR(&NBR) TYPE(*CHAR) LEN(6)
  DCL VAR(&CURUSER) TYPE(*CHAR) LEN(10)
  DCL VAR(&QUALJOB) TYPE(*CHAR) LEN(28)

  RTVJOBA JOB(&JOB) USER(&USER) NBR(&NBR) +
      TYPE(&TYPE) CURUSER(&CURUSER)
  CHGVAR VAR(&QUALJOB) VALUE(&NBR *TCAT '/' *TCAT +
      &USER *TCAT '/' *TCAT &JOB)
  SNDPGMMSG MSG('Job' *BCAT &QUALJOB *BCAT +
      'current user' *BCAT &CURUSER) MSGTYPE(*INFO)
  IF COND(&TYPE *EQ '0') THEN(DO)
    CALL PGM(APPLAB/BATCHRPT) PARM(&QUALJOB &CURUSER)
    RETURN
  ENDDO
  IF COND(&TYPE *EQ '1') THEN(DO)
    CALL PGM(APPLAB/PREVIEW) PARM(&QUALJOB &CURUSER)
    RETURN
  ENDDO
  SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
      MSGDTA('Unsupported job type; no report worker was called.') +
      MSGTYPE(*ESCAPE)
ENDPGM