*DISABLE ERROR ABORT
*DEFINE SF ORD1.COB
(Depending on the editor used, the command "INSERT" may need to be entered.)
[Beginning of COBOL code example 1.]
=================================================================
IDENTIFICATION DIVISION.
PROGRAM-ID. ORD1.
AUTHOR. USERNAME.
INSTALLATION. NIS.
DATE-WRITTEN. 3/6/91.
DATE-COMPILED.3/7/91
*
* This program is used to enter data into the ACCENT R BOOKS DBL.
*
* A store code is entered and verified. If the code does not already exist, a
* new store may be added. The order number is entered.
* The title code for the book is entered then verified. Other order data is then entered for
* a new sales record.
* Sales is figured by multiplying the order quantity by the book price then
* subtracting a discount (if applicable). The year-to-date sales is updated.
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. VAX.
OBJECT-COMPUTER. VAX.
DATA DIVISION.
WORKING-STORAGE SECTION.
* Variables for Data Set designators.
01 DATA-SET-NUMBER USAGE COMP.
02 BOOKS-DS PIC 9(9).
02 SALES-DS PIC 9(9).
02 DISCOUNTS-DS PIC 9(9).
02 STORES-DS PIC 9(9).
*
* Variables corresponding to DS fields.
*
01 DATA-SET-FIELDS.
02 BOOKS-FIELDS.
03 TITLE-CODE PIC X(6) USAGE DISPLAY.
03 T-CODE REDEFINES TITLE-CODE USAGE DISPLAY.
05 TITLE-TYPE PIC X(2).
05 TITLE-NO PIC X(4).
03 TITLE-TEXT PIC X(40) USAGE DISPLAY.
03 TYPE-CODE PIC X(12) USAGE DISPLAY.
03 PUB-CODE PIC X(4) USAGE DISPLAY.
03 PRICE PIC 9(8)V99 USAGE DISPLAY.
03 ADVANCE PIC 9(10) USAGE DISPLAY.
03 ROYALTY PIC 9(3) USAGE DISPLAY.
03 YTD-SALES USAGE COMP-2.
03 NOTES PIC X(200) USAGE DISPLAY.
03 PUB-DATE PIC 9(8) USAGE DISPLAY.
02 SALES-FIELDS.
03 STORE-CODE PIC X(4) USAGE DISPLAY.
03 ORDER-NO PIC X(20) USAGE DISPLAY.
03 ORDER-DATE PIC 9(8) USAGE DISPLAY
03 QTY USAGE COMP-2.
03 PAY-TERMS PIC X(12) USAGE DISPLAY.
03 ST-CODE PIC X(6) USAGE DISPLAY.
02 DISCOUNT-FIELDS.
03 DISCOUNT-TYPE PIC X(40) USAGE DISPLAY.
03 DS-CODE PIC X(4) USAGE DISPLAY.
03 LO-QTY USAGE COMP-2.
03 HI-QTY USAGE COMP-2.
03 DISCOUNT USAGE COMP-2.
02 STORES-FIELDS.
03 SS-CODE PIC X(4) USAGE DISPLAY.
03 STORE-NAME PIC X(30) USAGE DISPLAY.
03 ADDRESS PIC X(30) USAGE DISPLAY.
03 CITY PIC X (20) USAGE DISPLAY.
03 STATE PIC XX USAGE DISPLAY.
03 ZIP PIC X(5) USAGE DISPLAY.
03 COUNTRY PIC X(20) USAGE DISPLAY.
*
* Variables to hold user entered data, DISPLAY fields
*
77 SALES USAGE COMP-2.
77 ERROR-CODE PIC 9(9) USAGE COMP.
77 AUX PIC X(5) USAGE DISPLAY.
77 ANSWER PIC X(4) USAGE DISPLAY.
77 SET-TO-0 PIC 9(9) USAGE COMP VALUE IS 0.
77 SET-TO-1 PIC 9(9) USAGE COMP VALUE IS 1.
77 D-TITLE-CODE PIC X(6) USAGE DISPLAY.
77 D-STORE-CODE PIC X(4) USAGE DISPLAY.
PROCEDURE DIVISION.
HLI-INITIALIZATION.
*
* Call #1 (ACCINI) - Initializing the HLI environment.
*
CALL 'ACCINI' USING BY DESCRIPTOR ERROR-CODE, 'TRACE', 'COBOL'.
*
* Call #2 (ACCSTO) - Storing values in ACCENT R fields; set a non-zero value
to System Field @HLI_TRACE for debugging. This causes
all HLI calls to display a trace when executed. Tracing
can be disabled for any call with the
* NOTRACE option.
*
CALL 'ACCSTO' USING BY DESCRIPTOR ERROR-CODE,'TRACE',
BY DESCRIPTOR SET-TO-0, '@HLI_TRACE', BY DESCRIPTOR SET-TO-1.
*
* Control loop that handles the order processing.
*
CONTROL-CENTER.
PERFORM DBL-SPECIFICATION THRU 911-QUIT.
IF ERROR-CODE IS NOT EQUAL TO ZERO,
PERFORM BEGIN-ORDER THRU 950-OUT
UNTIL D-STORE-CODE = 'STOP' OR D-STORE-CODE = 'stop'.
IF ERROR-CODE IS EQUAL TO 0, PERFORM TERMINATION.
*
* Close all DS's and DBL/clean-up.
*
NORMAL-END.
CALL 'ACCCLS' USING BY DESCRIPTOR ERROR-CODE,'ALL'.
DISPLAY SPACE.
*
* Execute command. Use OSQL to review sales file.
*
DISPLAY '!! BUILDING SCREEN TO REVIEW SALES FILE !!'.
DISPLAY SPACE.
CALL 'ACCCMD' USING BY DESCRIPTOR ERROR-CODE, BY DESCRIPTOR
SET-TO-0, 'OSQL SELECT * FROM NISDEMO:SALES_DBM2 WITH WINDOW', 'QUIT'.
*
* Call #12 (ACCEND) - Terminate HLI session
*
CALL 'ACCEND' USING BY DESCRIPTOR ERROR-CODE.
STOP RUN.
*
* Call #3 (ACCDBL) - Declaring the BOOKS DBL for access.
*
DBL-SPECIFICATION.
CALL 'ACCDBL' USING BY DESCRIPTOR ERROR-CODE,
BY DESCRIPTOR SET-TO-0, 'BOOKS'.
IF ERROR-CODE IS NOT ZERO, GO TO 911-QUIT.
*
* Call #4 (ACCOPN) - Opening Data Sets for access
*
SALES-DS-SPECIFICATION.
CALL 'ACCOPN' USING BY DESCRIPTOR ERROR-CODE, 'UPDATE', 'DI',
'NISDEMO:SALES_DBM2', BY DESCRIPTOR SALES-DS.
*
* Specifying host field whose values are to be stored into Data Set. The DEFER option causes
* the data to be transferred when the ACCPUT call is executed.
*
CALL 'ACCSTO' USING BY DESCRIPTOR ERROR-CODE, 'CREATE+DEFER',
BY DESCRIPTOR SALES-DS,
'STORE_CODE', BY DESCRIPTOR STORE-CODE,
'ORD_NUM', BY DESCRIPTOR ORDER-NO,
'ORD_DATE', BY DESCRIPTOR ORDER-DATE,
'QTY', BY DESCRIPTOR QTY,
'PAY_TERMS', BY DESCRIPTOR PAY-TERMS,
'TITLE_CODE', BY DESCRIPTOR ST-CODE.
IF ERROR-CODE IS NOT ZERO, GO TO 911-QUIT.
STORES-DS-SPECIFICATION.
CALL 'ACCOPN' USING BY DESCRIPTOR ERROR-CODE, 'INPUT', 'DI',
'NISDEMO:STORES_DBM2', BY DESCRIPTOR STORES-DS.
*
* Call #5 (ACCLOA) - Specifying the fields in the Data Set whose values are to
be loaded into host fields. The DEFER option cause the
data to be transferred when the ACCGET call is executed.
*
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE, 'DEFER',
BY DESCRIPTOR STORES-DS,
'STORE_CODE', BY DESCRIPTOR SS-CODE,
'STORE_NAME', BY DESCRIPTOR STORE-NAME,
'STORE_ADDRESS', BY DESCRIPTOR ADDRESS,
'CITY', BY DESCRIPTOR CITY,
'STATE', BY DESCRIPTOR STATE,
'ZIP', BY DESCRIPTOR ZIP,
'COUNTRY', BY DESCRIPTOR COUNTRY.
IF ERROR-CODE IS NOT ZERO, GO TO 911-QUIT.
BOOKS-DS-SPECIFICATION.
CALL 'ACCOPN' USING BY DESCRIPTOR ERROR-CODE, 'UPDATE', 'DI',
'NISDEMO:BOOKS_DBM2', BY DESCRIPTOR BOOKS-DS.
*
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE, 'DEFER',
BY DESCRIPTOR BOOKS-DS,
'TITLE_CODE', BY DESCRIPTOR TITLE-CODE,
'TITLE_TEXT', BY DESCRIPTOR TITLE-TEXT,
'TYPE_CODE', BY DESCRIPTOR TYPE-CODE,
'PUB_CODE', BY DESCRIPTOR PUB-CODE,
'PRICE', BY DESCRIPTOR PRICE,
'ADVANCE_AMT', BY DESCRIPTOR ADVANCE,
'ROYALTY', BY DESCRIPTOR ROYALTY,
'YTD_SALES', BY DESCRIPTOR YTD-SALES,
'NOTES', BY DESCRIPTOR NOTES,
'PUB_DATE', BY DESCRIPTOR PUB-DATE.
IF ERROR-CODE IS NOT ZERO, GO TO 911-QUIT.
*
CALL 'ACCSTO' USING BY DESCRIPTOR ERROR-CODE, 'DEFER',
BY DESCRIPTOR BOOKS-DS,
'YTD_SALES', BY DESCRIPTOR YTD-SALES.
IF ERROR-CODE IS NOT ZERO, GO TO 911-QUIT.
*
DISCOUNTS-DS-SPECIFICATION.
CALL 'ACCOPN' USING BY DESCRIPTOR ERROR-CODE, 'UPDATE', 'DI',
'NISDEMO:DISCOUNTS_DBM2', BY DESCRIPTOR DISCOUNTS-DS.
*
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE, 'DEFER',
BY DESCRIPTOR DISCOUNTS-DS,
'DISCOUNT_TYPE',BY DESCRIPTOR DISCOUNT-TYPE,
'STORE_CODE',BY DESCRIPTOR DS-CODE,
'LOW_QTY',BY DESCRIPTOR LO-QTY,
'HIGH_QTY',BY DESCRIPTOR HI-QTY,
'DISCOUNT',BY DESCRIPTOR DISCOUNT.
IF ERROR-CODE IS NOT ZERO, GO TO 911-QUIT.
911-QUIT.
EXIT.
*
* Begin processing book orders...
*
BEGIN-ORDER.
*
* Read in system date from an ACCENT R System Field to a host field.
*
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE,
BY DESCRIPTOR SET-TO-0, BY DESCRIPTOR SET-TO-0,
'@DATE', BY DESCRIPTOR ORDER_DATE.
DISPLAY 'Enter STOP to leave the application.'.
*
GET-STORE-CODE.
DISPLAY SPACE
MOVE SPACES TO D-STORE-CODE.
DISPLAY 'Enter store code (or STOP): ' WITH NO ADVANCING.
ACCEPT D-STORE-CODE.
IF D-STORE-CODE IS EQUAL TO 'STOP', GO TO 950-OUT.
IF D-STORE-CODE IS EQUAL TO 'stop', GO TO 950-OUT.
IF D-STORE-CODE IS EQUAL TO SPACES, GO TO 950-OUT.
*
*
Call #6 (ACCGET) - Verify store code entered by user
with DS records, Load
in processing status field (@AUX- ACCENTR System Field)
to host variable to test whether the store code exists.
If not, offer the option to add a new store.(ACCLOA)
*
STORE-CODE-CHECK.
MOVE SPACES TO STORE-FIELDS.
CALL 'ACCGET' USING BY DESCRIPTOR ERROR-CODE, 'MATCH+HUSH',
BY DESCRIPTOR STORES-DS, ' ', BY DESCRIPTOR D-STORE-CODE.
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE, BY DESCRIPTOR
SET-TO-0, BY DESCRIPTOR SET-TO-0,'@AUX', BY DESCRIPTOR AUX.
IF AUX IS EQUAL TO 'YES', DISPLAY 'Store Name: ', STORE-NAME.
IF AUX IS NOT EQUAL TO 'YES', PERFORM SHOW-OPTION.
IF ANSWER IS EQUAL TO 'N', GO TO 950-OUT.
IF AUX IS NOT EQUAL TO 'YES', PERFORM ADD-STORE.
*
GET-ORDER.
DISPLAY SPACE .
DISPLAY 'Enter order number or RETURN (with no entry) to start over:'.
ACCEPT ORDER-NO.
IF ORDER-NO IS EQUAL TO SPACES, GO TO 950-OUT.
MOVE 'NEW' TO D-TITLE-CODE.
PERFORM GET-TITLE-CODE THRU 975-CLOSE
UNTIL D-TITLE-CODE IS EQUAL TO SPACES.
950-OUT.
EXIT.
GET_TITLE_CODE.
MOVE SPACES TO D-TITLE-CODE.
DISPLAY SPACE.
DISPLAY 'Enter book title code or RETURN (with no entry) to end order:'.
ACCEPT D-TITLE-CODE.
IF D-TITLE-CODE IS EQUAL TO SPACES, DISPLAY SPACE.
DISPLAY '<< Order completed >>'.; GO TO 975-CLOSE.
MOVE SPACES TO TITLE-CODE, TITLE-TEXT, TYPE-CODE, PUB-CODE, NOTES.
MOVE ZEROS TO PRICE, ADVANCE, ROYALTY, YTD-SALES, PUB-DATE.
*
* Verify title code entered
*
CALL 'ACCGET' USING DESCRIPTOR ERROR-CODE, 'MATCH+HUSH',
BY DESCRIPTOR BOOKS-DS, ' ', BY DESCRIPTOR D-TITLE-CODE.
CALL 'ACCLOA' USING DESCRIPTOR ERROR-CODE, BY DESCRIPTOR SET-TO-0,
BY DESCRIPTOR SET-TO-0, '@AUX', BY DESCRIPTOR AUX.
IF AUX IS NOT EQUAL TO 'YES', DISPLAY SPACE;
DISPLAY 'Code does not match in file--try again.'; GO TO 975-CLOSE.
*
* Enter the rest of the order information...
*
DISPLAY 'Title: ', TITLE-TEXT.
DISPLAY 'Price: ', PRICE.
DISPLAY SPACE.
DISPLAY 'Enter order quantity: ' WITH NO ADVANCING.
ACCEPT QTY.
DISPLAY 'Enter terms of payment: (ex. net 30, net 60) ' WITH NO ADVANCING.
ACCEPT PAY-TERMS.
MOVE D-TITLE-CODE TO ST-CODE.
MOVE D-STORE-CODE TO STORE-CODE.
PERFORM FIND-DISCOUNT
UNTIL AUX IS NOT EQUAL TO 'YES'
OR QTY IS NOT LESS THAN LO-QTY
AND QTY IS NOT GREATER THAN HI-QTY.
*
* Figure sales for update...
*
COMPUTE DISCOUNT = DISCOUNT/100.
DIVIDE 100 INTO PRICE.
COMPUTE SALES = PRICE * QTY - (PRICE * QTY) * DISCOUNT.
ADD SALES TO YTD-SALES.
*
UPDATE-SETS.
*
* Call #9 (ACCPUT) - Update the DS BOOKS_DBM2.
*
CALL 'ACCPUT' USING BY DESCRIPTOR ERROR-CODE, BY DESCRIPTOR
SET-TO-0, BY DESCRIPTOR BOOKS-DS.
*
* Call #10 (ACCRDY) - Initialize record area for ACCCRE.
*
CALL 'ACCRDY' USING BY DESCRIPTOR ERROR-CODE, BY DESCRIPTOR
SET-TO-0, BY DESCRIPTOR SALES-DS.
*
* Call #11 (ACCCRE) - Append to DS SALES_DBM2.
*
CALL 'ACCCRE' USING BY DESCRIPTOR ERROR-CODE, BY DESCRIPTOR
SET-TO-0, BY DESCRIPTOR SALES-DS.
MOVE SPACES TO STORE-CODE, PAY-TERMS, ST-CODE.
MOVE ZEROS TO QTY
975-CLOSE.
EXIT.
*
* Find discount for order by store.
*
FIND-DISCOUNT.
MOVE SPACES TO DISCOUNT-TYPE, DS-CODE.
MOVE ZEROS TO LO-QTY, HI-QTY, DISCOUNT.
CALL 'ACCGET' USING BY DESCRIPTOR ERROR-CODE, 'MATCH+HUSH',
BY DESCRIPTOR DISCOUNTS-DS,' ', BY DESCRIPTOR D-STORE-CODE.
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE, BY DESCRIPTOR
SET-TO-0, BY DESCRIPTOR SET-TO-0, '@AUX', BY DESCRIPTOR AUX.
IF AUX IS NOT EQUAL TO 'YES', MOVE 0 TO DISCOUNT.
*
* Get a YES or NO answer from the user
*
GET-YES-NO-ANSWER.
IF ANSWER IS EQUAL TO 'y', MOVE 'Y' TO ANSWER.
IF ANSWER IS EQUAL TO 'n', MOVE 'N' TO ANSWER
IF ANSWER IS NOT EQUAL TO 'Y'
IF ANSWER IS NOT EQUAL TO 'N', DISPLAY SPACE ;
DISPLAY 'You must answer either Y or N: ' WITH NO ADVANCING;
ACCEPT ANSWER .
*
SHOW-OPTION.
DISPLAY SPACE.
DISPLAY 'Store code does not match in file. Should it be added? (Y/N):'
WITH NO ADVANCING.
ACCEPT ANSWER.
PERFORM GET-YES-NO-ANSWER UNTIL ANSWER IS EQUAL TO 'Y' OR 'N'.
*
ADD-STORE.
*
PERFORM CLOSE-DS.
DISPLAY SPACE.
*
* Call #8 (ACCCMD) - Execute a command. Use OSQL to build insert screen.
*
DISPLAY '!! BUILDING SCREEN TO ADD NEW STORE !!'.
CALL 'ACCCMD' USING BY DESCRIPTOR ERROR-CODE, 'COMMAND',
'OSQL INSERT NISDEMO:STORES_DBM2 WITH WINDOW', 'QUIT'.
DISPLAY '<< Store addition (if any) has been completed >>' .
*
* Re-open the DBL / Data Set for read access. (The files were closed by OSQL operation. See * Call #8)
*
PERFORM DBL-SPECIFICATION.
PERFORM STORES-DS-SPECIFICATION.
* Retrieve and display the store record just entered.
*
CALL 'ACCGET' USING BY DESCRIPTOR ERROR-CODE, 'LAST+NOTINDEXED',
BY DESCRIPTOR STORES-DS, ' '.
DISPLAY 'The following STORE has been added:'.
DISPLAY SPACE .
DISPLAY 'Store Code: ', D-STORE-CODE.
DISPLAY 'Store Name: ', STORE-NAME.
*
CLOSE-DS.
*
* Call #7 (ACCCLS) - Closing DS STORES_DBM2 so OSQL can access it.
*
CALL 'ACCCLS' USING BY DESCRIPTOR ERROR-CODE,
BY DESCRIPTOR SET-TO-0, BY DESCRIPTOR STORES-DS.
*
* Display error message if error encountered while opening the Data Sets.
*
TERMINATION.
DISPLAY SPACE.
DISPLAY '*** Order entry terminated due to error ***'.
================================================================================
[End of COBOL code example 1.]
Exit the insert mode. Enter "END" or use CTRL-Z depending on the editor used.
Save the program by entering "SAVE". The editor will return control to the command level prompt.
Compile and LINK the COBOL program through a System File (SF). Enter commands below.
(Depending on the editor used, the command "INSERT" may need to be entered.)
*DEFINE SF HLICOB_1.COM
$purge ord1.cob
$delete ord1.obj;*
$delete ord1.exe;*
$define nisdemo [user_directory]
$define nis [accent_r_directory]
$define acchli nis:acchli
$cobol ord1
$link ord1,nis:accvax,nis:acchli/lib
Exit the insert mode. Enter "END" or use CTRL-Z depending on the editor used.
Save the command file by entering "SAVE". The editor will return control to the command level prompt.
Initiate the link then exit ACCENT R or link at the DCL command level.
*LINK TO DCL WITH '@HLICOB_1' AND RETURN
*QUIT
(or)
*QUIT
$@HLICOB_1
Run application at the VAX DCL prompt.
$RUN ORD1
Define the System File (SF) that will contain the COBOL source code. Insert the code below.
*DEFINE SF ORD2.COB
(Depending on the editor used, the command "INSERT" may need to be entered.)
[Beginning of COBOL code example 2.]
=====================================================================
IDENTIFICATION DIVISION.
PROGRAM-ID. ORD2.
AUTHOR. USERNAME.
INSTALLATION. NIS.
DATE-WRITTEN. 3/6/91.
DATE-COMPILED. 3/7/91.
*
* This program is used to delete data from an ACCENT R Data Set.
*
* This example covers HLI procedures that were not used in the first example. Only the new procedures are
* commented with "call numbers" to avoid redundancy. ACCVER lists the ACCENT R version being used. ACCLOK
* reserves a whole a data set for processing. ACCFRE releases locked data sets. ACCKWD allows the use of
* keywords. ACCGET can be used to get information on a DBL object (used with ACCOPN and ACCLOA). ACCDEL
* deletes a data set record.
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. VAX.
OBJECT-COMPUTER. VAX.
*
DATA DIVISION.
WORKING-STORAGE SECTION.
*
* Set up host fields that correlate to ACCENT R fields
*
01 DATA-SET-NUMBER USAGE COMP.
02 SALES-DS PIC 9(9).
02 BOOKS-DBL PIC 9(9).
01 DBL-DATA USAGE DISPLAY.
02 E-TIME PIC 9(4).
02 E-TYPE PIC XXX.
02 E-NAME PIC X(40).
01 DATA-SET-FIELDS.
02 SALES-FIELDS.
03 STORE-CODE PIC X(4) USAGE DISPLAY.
03 ORDER-NO PIC X(20) USAGE DISPLAY.
03 ORDER-DATE PIC 9(8) USAGE DISPLAY.
03 QTY USAGE COMP-2.
03 PAY-TERMS PIC X(12) USAGE DISPLAY.
03 ST-CODE PIC X(6) USAGE DISPLAY.
*
* Specify host fields that hold data entered from terminal; DISPLAY fields.
*
77 ERROR-CODE PIC 9(9) USAGE COMPUTATIONAL.
77 AUX PIC X(5) USAGE DISPLAY.
77 ANSWER PIC X(4) USAGE DISPLAY.
77 SET-TO-0 PIC 9(9) USAGE COMP VALUE IS 0.
77 SET-TO-1 PIC 9(9) USAGE COMP VALUE IS 1.
77 D-T-CODE PIC X(6) USAGE DISPLAY.
77 X-HUSH PIC 9(9) USAGE COMP.
77 X-MATCH PIC 9(9) USAGE COMP.
77 X-LOCKED PIC 9(9) USAGE COMP.
77 X-OPTION PIC 9(9) USAGE COMP.
*
PROCEDURE DIVISION.
HLI-INITIALIZATION.
*
* Initializing the HLI environment (ACCINI).
*
CALL 'ACCINI' USING BY DESCRIPTOR ERROR-CODE, 'TRACE', 'COBOL'.
*
* Storing values in ACCENT R variables (ACCSTO). Set a non-zero value to
* System Field @HLI_TRACE for debugging. This causes all HLI calls to display
* a trace when executed. Tracing can be disabled for any call with the NOTRACE
* option.
*
CALL 'ACCSTO' USING BY DESCRIPTOR ERROR-CODE,'TRACE',
BY DESCRIPTOR SET-TO-0,'@HLI_TRACE',BY DESCRIPTOR SET-TO-1.
*
* CALL #13: (ACCVER) - List ACCENT R version. Processing is paused for user
* to see the version number. User presses Return to
* continue.
*
DISPLAY-VERSION.
DISPLAY SPACE.
CALL 'ACCVER' USING BY DESCRIPTOR ERROR-CODE, 'TRACE'.
DISPLAY '<< Press RETURN to continue...>>' WITH NO ADVANCING.
ACCEPT ANSWER.
*
* Control loop than handles the processing.
*
CONTROL-CENTER.
PERFORM DBL-SPECIFICATION THRU 911-QUIT.
IF ERROR-CODE IS EQUAL TO 0,
PERFORM BEGIN-ORDER THRU 950-OUT
UNTIL D-T-CODE IS EQUAL TO 'STOP' OR D-T-CODE = 'stop'.
IF ERROR-CODE IS NOT EQUAL TO 0, PERFORM TERMINATION.
NORMAL-END.
*
* Call #18 (ACCFRE) - release all locked Data Sets and close Data Sets (ACCCLS).
*
CALL 'ACCFRE' USING BY DESCRIPTOR ERROR-CODE,'ALL', BY DESCRIPTOR
SALES-DS.
CALL 'ACCCLS' USING BY DESCRIPTOR ERROR-CODE,'ALL'.
*
* Terminate HLI session. (ACCEND)
*
CALL 'ACCEND' USING BY DESCRIPTOR ERROR-CODE.
STOP RUN.
*
* Declare the BOOKS DBL for access.
*
DBL-SPECIFICATION.
CALL 'ACCDBL' USING BY DESCRIPTOR ERROR-CODE,
BY DESCRIPTOR SET-TO-0, 'BOOKS'.
IF ERROR-CODE IS NOT ZERO, GO TO 911-QUIT.
*
* Open DS SALES_DBM2 for access. (ACCOPN)
*
SALES-DS-SPECIFICATION.
CALL 'ACCOPN' USING BY DESCRIPTOR ERROR-CODE, 'UPDATE', 'DI',
'NISDEMO:SALES_DBM2', BY DESCRIPTOR SALES-DS, 'UPDATE'.
*
* Specify DS SALES_DBM2 fields whose values are to be loaded into host fields. (ACCSTO)
* Data actually transferred with ACCGET because of the "DEFER" option.
*
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE, 'DEFER',
BY DESCRIPTOR SALES-DS,
'STORE_CODE', BY DESCRIPTOR STORE-CODE,
'ORD_NUM', BY DESCRIPTOR ORDER-NO,
'ORD_DATE', BY DESCRIPTOR ORDER-DATE,
'QTY', BY DESCRIPTOR QTY,
'PAY_TERMS', BY DESCRIPTOR PAY-TERMS,
'TITLE_CODE', BY DESCRIPTOR ST-CODE.
IF ERROR-CODE IS NOT ZERO, GO TO 911-QUIT.
*
* Call #14: (ACCGET)- Retrieve information on a DBL object (SD SALES_DBM2).
* This version of ACCGET requires the DBL to be opened
* (ACCOPN) in a prior call with the GET option and DBL object
* type. Processing is paused so the information can be seen.
* The Return key is pressed to continue.
* DBL-SEARCH.
DISPLAY SPACE.
DISPLAY '<< Searching for DBL object information... >>'.
DISPLAY SPACE.
CALL 'ACCOPN' USING BY DESCRIPTOR ERROR-CODE, 'GET', 'DBL', 'BOOKS',
BY DESCRIPTOR BOOKS-DBL.
CALL 'ACCGET' USING BY DESCRIPTOR ERROR-CODE, 'DBL+TRACE+ENTRY',
BY DESCRIPTOR BOOKS-DBL, ' ', 'SD', 'SALES_DBM2'.
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE, 'TRACE', BY
DESCRIPTOR BOOKS-DBL,
'ENTRY.TYPE', BY DESCRIPTOR E-TYPE,
'ENTRY.NAME', BY DESCRIPTOR E-NAME,
'CREATE.TIME', BY DESCRIPTOR E-TIME.
DISPLAY 'DBL object type: ', E-TYPE.
DISPLAY 'DBL object name: ', E-NAME.
DISPLAY 'Create time: ', E-TIME.
DISPLAY SPACE.
DISPLAY 'Press RETURN to continue.' WITH NO ADVANCING.
ACCEPT ANSWER.
*
* Call #15:(ACCKWD)- Set up keyword (used to combine options into one descriptor)
*
SET-KEYWORD.
CALL 'ACCKWD' USING BY DESCRIPTOR ERROR-CODE, 'TRACE',
'MATCH', BY DESCRIPTOR X-MATCH,
'HUSH', BY DESCRIPTOR X-HUSH,
'LOCKED', BY DESCRIPTOR X-LOCKED.
COMPUTE X-OPTION = X-MATCH + X-HUSH + X-LOCKED.
911-QUIT.
EXIT.
*
* Begin processing sales records to be deleted.
*
BEGIN-ORDER.
DISPLAY 'Enter STOP to leave the application.'.
*
GET-TITLE-CODE.
DISPLAY SPACE
MOVE SPACES TO D-T-CODE.
DISPLAY 'Enter title code (or STOP): ' WITH NO ADVANCING.
ACCEPT D-T-CODE.
IF D-T-CODE IS EQUAL TO 'STOP', GO TO 950-OUT.
IF D-T-CODE IS EQUAL TO 'stop', GO TO 950-OUT.
IF D-T-CODE IS EQUAL TO SPACES, GO TO 950-OUT.
*
* Verify title code entered by user with DS records. (ACCGET) Load in
* processing status from ACCENT R field to host variable to see if title code
* exists. (ACCLOA)
*
TITLE-CODE-CHECK.
MOVE SPACES TO SALES-FIELDS.
CALL 'ACCGET' USING BY DESCRIPTOR ERROR-CODE, BY DESCRIPTOR
X-OPTION, BY DESCRIPTOR SALES-DS, ' ', BY DESCRIPTOR D-T-CODE.
*
* Call #16: Records are locked as they are retrieved with the 'LOCKED' option
* in ACCGET as is needed for ACCDEL. ACCLOK reserves the whole Data
* Set and is shown as a comment.
*
* CALL 'ACCLOK' USING BY DESCRIPTOR ERROR-CODE, 'ALL', BY DESCRIPTOR
* SALES-DS.
*
CALL 'ACCLOA' USING BY DESCRIPTOR ERROR-CODE, BY DESCRIPTOR
SET-TO-0, BY DESCRIPTOR SET-TO-0,'@AUX', BY DESCRIPTOR AUX.
IF AUX IS NOT EQUAL TO 'YES',
DISPLAY SPACE
DISPLAY 'Title code entered does not match in file -- try again.'
GO TO 950-OUT.
*
DISPLAY-ORDER.
DISPLAY SPACE.
DISPLAY 'Order Number: ', ORDER-NO.
DISPLAY 'Store Code: ', STORE-CODE.
DISPLAY 'Order Date: ', ORDER-DATE.
DISPLAY 'Order Qty: ', QTY.
DISPLAY 'Pay Terms: ', PAY-TERMS.
DISPLAY 'Title Code: ', ST-CODE.
DISPLAY SPACE.
DISPLAY 'Delete this order? (Y/N)' WITH NO ADVANCING.
ACCEPT ANSWER.
PERFORM GET-YES-NO-ANSWER UNTIL ANSWER IS EQUAL TO 'Y' OR 'N'.
IF ANSWER IS EQUAL TO 'N', GO TO 950-OUT.
*
* Call #17: (ACCDEL) - Delete selected Data Set record.
*
DELETE-ORDER.
CALL 'ACCDEL' USING BY DESCRIPTOR ERROR-CODE, 'IMMEDIATE', BY
DESCRIPTOR SALES-DS.
DISPLAY SPACE.
DISPLAY '<<Record deleted...>>'.
MOVE SPACES TO STORE-CODE, PAY-TERMS, ST-CODE.
MOVE ZEROS TO QTY, ORDER-DATE.
950-OUT.
EXIT.
*
* Get a YES or NO answer from the user
*
GET-YES-NO-ANSWER.
IF ANSWER IS EQUAL TO 'y', MOVE 'Y' TO ANSWER.
IF ANSWER IS EQUAL TO 'n', MOVE 'N' TO ANSWER.
IF ANSWER IS NOT EQUAL TO 'Y'
IF ANSWER IS NOT EQUAL TO 'N', DISPLAY SPACE ;
DISPLAY 'You must answer either Y or N: ' WITH NO ADVANCING;
ACCEPT ANSWER .
*
* Display error message if applicable.
*
TERMINATION.
DISPLAY SPACE.
DISPLAY '*** Program terminated due to error ***'.
=====================================================================
[End of COBOL code example 2.]
Exit the insert mode. Enter "END" or use CTRL-Z depending on the editor used.
Save the program by entering "SAVE". The editor will return control to the command level prompt.
Compile and LINK the COBOL program through a System File (SF). Enter commands below.
(Depending on the editor used, the command "INSERT" may need to be entered.)
*DEFINE SF HLICOB_2.COM
$purge ord2.cob
$delete ord2.obj;*
$delete ord2.exe;*
$define nisdemo [user_directory]
$define nis [accent_r_directory]
$define acchli nis:acchli
$cobol ord2
$link ord2,nis:accvax,nis:acchli/lib
Exit the insert mode. Enter "END" or use CTRL-Z depending on the editor used.
Save the command file by entering "SAVE". The editor will return control to the command level prompt.
Initiate the link then exit ACCENT R or link at the DCL command level.
*LINK TO DCL WITH '@HLICOB_2' AND RETURN
*QUIT
(or)
*QUIT
$@HLICOB_2
$RUN ORD2