This is an ADSORPTS ( similar to a compilation listing ) of a small menu program which was written some time ago.

It will give a feel for ads syntax to anyone who has never seen it before.

It is the entry dialog to an application and acts as a menu to other functions.

For ADS users it is worth noting the use of NOSAVE at various points. This removes the overhead of ADS currency save/restore which accounts for most of the increased cpu (and i/o) of ADS compared to DC-COBOL. It also allows this dialog to run retrieval nolock (provided this is allowed by sysgen) even though the invoked dialogs are update.

ADSORPTS S10213      COMPUTER ASSOCIATES INTERNATIONAL
PREMAP PROCESS: RVM980-PP                           VERS.: 0001
     00000100  READY MARC-REGION    USAGE-MODE IS RETRIEVAL.
     00000200  READY RVPARAM-REGION USAGE-MODE IS RETRIEVAL.
     00000300
     00000400  IF FIRST-TIME THEN
     00000500     DO.
     00000600       INITIALIZE RECORDS (RVWRM-MARC-GLOBAL).
     00000700       ACCEPT USER ID           INTO RVWRM-G-USER-ID8.
     00000800       ACCEPT PTERM ID          INTO RVWRM-G-VDU-ID.
     00000900
     00001000       MOVE 'RVB001' TO RV36-PROGRAM-NO.
     00001100       OBTAIN CALC RV36SYS.
     00001200       MOVE RV36-PROGRAM-NO-FILLER-160 TO RVB001-RV36SYS-RVB001.
     00001300       MOVE RVB001-COUNTRY             TO RVMG-MARC-LOC-NAME.
     00001400       MOVE RVB001-ML-REF-LOCN-CD      TO RVMG-MARC-LOC.
     00001500
     00001600       IF RVMG-MARC-LOC EQ '  '  THEN DO
     00001700          MOVE 'XX' TO RVMG-MARC-LOC.
     00001800       END.
     00001900     END.
     00002000
     00002100  MOVE DATE             TO RVWRM-G-DATE-YMD-99.
     00002200  MOVE RVWRM-G-YEAR-99  TO RVWRM-G-YEAR2-99.
     00002300  MOVE RVWRM-G-MONTH-99 TO RVWRM-G-MONTp-99.
     00002400  MOVE RVWRM-G-DAY-99   TO RVWRM-G-DAY2-99.
     00002500  !
     00002600  MOVE TIME             TO RVWRM-G-TIME-HHMMSS-99.
     00002700  MOVE RVWRM-G-TIME-HH  TO RVWRM-G-TIME-HH-99.
     00002800  MOVE RVWRM-G-TIME-MM  TO RVWRM-G-TIME-MM-99.
     00002900  MOVE RVWRM-G-TIME-SS  TO RVWRM-G-TIME-SS-99.
     00003000  !
     00003100  MOVE RVMG-MARC-LOC    TO RVMG-MARC-QLOC.
     00003200  !
     00003300  MOVE SPACES           TO RVMG-MARC-QNAME.
     00003400  !
     00003500  MOVE ZERO             TO RVMG-MARC-FILE-SEQ.
     00003600  MOVE SPACES           TO RVMG-MARC-INTF.
     00003700  MOVE SPACES           TO RVMG-SOURCE-SYSTEM.
     00003800  MOVE 1                TO RVMG-MARC-FILE-VER.
     00003900  MOVE ZERO             TO RVMG-SELECTION.
     00004000  DISPLAY.

RESPONSE PROCESS: RVM980-RPE                          VERS.: 0001
     00000100  IF FIELD RVMG-MARC-QNAME CHANGED THEN
     00000200     DO.
     00000300       INITIALIZE RECORD (MC01-QUEUE-HDR).
     00000400       MOVE RVMG-MARC-QNAME TO MC01-MARC-INTF.
     00000500       IF RVMG-MARC-QNAME NE 'ARCHIVED' AND
     00000600          RVMG-MARC-QNAME NE 'HOLDOVER' AND
     00000700          RVMG-MARC-QNAME NE 'RESTORED' THEN
     00000800             MOVE RVMG-MARC-QLOC TO MC01-MARC-LOC.
     00000900       FIND CALC MC01-QUEUE-HDR.
     00001000       IF DB-REC-NOT-FOUND THEN
     00001100          DISPLAY MESSAGE TEXT IS '*** QUEUE NOT FOUND ***'.
     00001200       ELSE
     00001300            INVOKE NOSAVE 'RVD982'.
     00001400     END.
     00001500  IF ANY OF ( RVMG-MARC-LOC,
     00001600              RVMG-MARC-FILE-SEQ,
     00001700              RVMG-MARC-INTF,
     00001800              RVMG-SOURCE-SYSTEM,
     00001900              RVMG-MARC-FILE-VER ) CHANGED THEN
     00002000     DO.
     00002100       INITIALIZE RECORD (MC02-FILE-HDR).
     00002200       MOVE RVMG-MARC-FILE TO MC02-MARC-FILE.
     00002300       FIND CALC MC02-FILE-HDR.
     00002400       IF DB-REC-NOT-FOUND THEN
     00002500            DISPLAY MESSAGE TEXT IS '*** FILE NOT FOUND ***'.
     00002600       ELSE
     00002700            OBTAIN OWNER WITHIN MC01-MC02.
     00002800       IF MC01-MARC-INTF EQ 'ARCHIVED' THEN
     00002900            INVOKE NOSAVE 'RVD984'.
     00003000       ELSE
     00003100            INVOKE NOSAVE 'RVD986'.
     00003200     END.
     00003300  IF RVMG-SELECTION EQ 1 THEN
     00003400     DO.
     00003500        MOVE 'ARCHIVED' TO RVMG-MARC-QNAME.
     00003600        INVOKE NOSAVE 'RVD985'.
     00003700     END.
     00003800  IF RVMG-SELECTION EQ 2 THEN
     00003900     DO.
     00004000        MOVE SPACES     TO RVMG-ACTION.
     00004100        MOVE 'HOLDOVER' TO RVMG-MARC-QNAME.
     00004200        INVOKE NOSAVE 'RVD983'.
     00004300     END.
     00004400  IF RVMG-SELECTION EQ 3 THEN
     00004500     DO.
     00004600        MOVE SPACES     TO RVMG-ACTION.
     00004700        MOVE 'OUTGOING' TO RVMG-MARC-QNAME.
     00004800        INVOKE NOSAVE 'RVD983'.
     00004900     END.
     00005000  IF RVMG-SELECTION EQ 4 THEN
     00005100     DO.
     00005200        MOVE SPACES     TO RVMG-ACTION.
     00005300        MOVE 'RESTORED' TO RVMG-MARC-QNAME.
     00005400        INVOKE NOSAVE 'RVD983'.
     00005500     END.
     00005600  IF RVMG-SELECTION EQ 5 THEN
     00005700        INVOKE NOSAVE 'RVD981'.
     00005800  IF RVMG-SELECTION EQ 6 THEN
     00005900     DO.
     00006000        MOVE 'ACK'      TO RVMG-ACTION.
     00006100        MOVE 'HOLDOVER' TO RVMG-MARC-QNAME.
     00006200        INVOKE NOSAVE 'RVD983'.
     00006300     END.
     00006400  IF RVMG-SELECTION EQ 7 THEN
     00006500     DO.
     00006600        INVOKE NOSAVE 'RVD987'.
     00006700     END.
     00006800  DISPLAY MSG TEXT IS
     00006900         '*** INVALID SELECTION. ENTER A DISPLAYED VALUE ***'.