HP 3000 Manuals HP 3000 Manuals
ORDERS Database Model Program (Continued)
COBOL II (Continued)
Opening the Database.
This paragraph implements the OPEN-THE-DATABASE routine of the sample
program in COBOL II. All required values, such as the password, are
provided by the routine. Note that the password DO-ALL establishes user
class number 18. The password DO-ALL is followed by a semicolon because
it is less than eight characters long; a blank can be substituted for the
semicolon. OPEN-THE-DATABASE uses open mode 1, which is the shared
modify access mode. Error trapping is done by referring all non-zero
conditions to paragraph 1100-GET-ERROR-AND-EXPLAIN.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access (SMA) with locking required
*
* Called By: 30-DO-ACTION
*
* Calls : DBOPEN in mode 1 (SMA)
* 1100-GET-ERROR-AND-EXPLAIN
100-OPEN-THE-DATABASE.
MOVE SPACES TO BASEID
MOVE "ORDERS" TO BASENAME
MOVE ";" TO TERMINATOR
MOVE "DO-ALL;" TO PASSWORD
MOVE 1 TO DB-MODE
CALL "DBOPEN" USING DBNAME, PASSWORD, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF.
Retrieving All the Records on a Chain (with Item Level Locking).
This paragraph implements the GET-SALES-FOR-DATE routine of the sample
program. Chain access is achieved using a call to DBFIND to determine
the location of the first and last entries in the chain. The search item
used for this call is PURCH-DATE. An item level lock is obtained on the
value of the search item before the DBFIND call. After that, individual
chain items are retrieved, until the end of the chain is encountered.
This is done using multiple calls to the DBGET procedure.
The routine traps two exceptional conditions:
1. Status condition 17 from the DBFIND call, indicating that the
chain head cannot be located.
2. Status 15 from the DBGET call, indicating the end of the chain.
The status interpretation routine permits you to either abort or continue
with the execution after viewing all error messages.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBLOCK in mode 5 (unconditional item level locking)
* DBFIND in mode 1 (chained access)
* DBGET in mode 5 (forward chained read)
* DBUNLOCK in mode 1 (unlock)
* 1100-GET-ERROR-AND-EXPLAIN
200-GET-SALES-FOR-DATE.
MOVE 1 TO NUM-OF-ELEMENTS
MOVE 21 TO LENGTH-OF-DESCRIPTOR
MOVE "SALES;" TO DATA-SET-OF-DESCRIPTOR
MOVE "PURCH-DATE;" TO DATA-ITEM-OF-DESCRIPTOR
MOVE " =" TO RELOP-FOR-DATA-ITEM
DISPLAY CLEAR SCREEN
DISPLAY " Enter The Date of Purchase as (YYMMDD) >>> "
NO ADVANCING
ACCEPT SEARCH-ITEM-VALUE FREE
MOVE 5 TO DB-MODE
MOVE SEARCH-ITEM-VALUE TO VALUE-FOR-DATA-ITEM
CALL "DBLOCK" USING DBNAME, LOCK-DESCRIPTOR-ARRAY, DB-MODE,
STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE "SALES;" TO SALES-DETAIL
MOVE 1 TO DB-MODE
MOVE "PURCH-DATE;" TO SEARCH-ITEM-NAME
CALL "DBFIND" USING DBNAME, SALES-DETAIL, DB-MODE, STATUS1,
SEARCH-ITEM-NAME, SEARCH-ITEM-VALUE
IF CONDITION = 0 THEN
SET FOUND TO TRUE
ELSE
SET NOT-FOUND TO TRUE
IF CONDITION = NO-CHAIN-HEAD THEN
DISPLAY CLEAR SCREEN
DISPLAY "****************************************"
DISPLAY "* No Such Entry in the Sales Data Set. *"
DISPLAY "* Please Try Again. *"
DISPLAY "****************************************"
DISPLAY "Press Enter to Continue -------------->"
NO ADVANCING
ACCEPT OPTION FREE
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
END-IF
IF FOUND THEN
DISPLAY CLEAR SCREEN
DISPLAY SALES-BUFFER-HEADER
DISPLAY LINE-HEADER
PERFORM WITH TEST BEFORE UNTIL CONDITION = END-OF-CHAIN
MOVE 5 TO DB-MODE
MOVE "@;" TO LIST
CALL "DBGET" USING DBNAME, SALES-DETAIL, DB-MODE,
STATUS1, LIST, SALES-BUFFER,
NOT-USED-PARM-16
IF CONDITION NOT = 0 THEN
IF CONDITION = END-OF-CHAIN THEN
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "-----> End of Chain, " NO ADVANCING
DISPLAY "Hit Enter to Continue" NO ADVANCING
ACCEPT OPTION FREE
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
END-IF
MOVE ACCOUNT-NUMBER OF SALES-BUFFER
TO ACCOUNT-NUMBER-OUT
MOVE STOCK-NUMBER OF SALES-BUFFER
TO STOCK-NUMBER-OUT
MOVE QUANTITY OF SALES-BUFFER TO QUANTITY-OUT
MOVE PRICE OF SALES-BUFFER TO PRICE-OUT
MOVE TAX OF SALES-BUFFER TO TAX-OUT
MOVE TOTAL OF SALES-BUFFER TO TOTAL-OUT
MOVE PURCH-DATE OF SALES-BUFFER TO PURCH-DATE-OUT
MOVE DELIV-DATE OF SALES-BUFFER TO DELIV-DATE-OUT
DISPLAY SALES-BUFFER-OUT
END-PERFORM
END-IF
MOVE 1 TO DB-MODE
CALL "DBUNLOCK" USING DBNAME, SALES-DETAIL, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF.
Retrieving a Data Entry Using a Record Number.
This paragraph implements the GET-A-CUSTOMER-RECORD routine of the sample
program. The record number for the directed read is obtained by calling
DBGET in mode 7. The saved record number is then used as the argument
value for a call to DBGET in mode 4. Status 17 indicates two different
conditions for DBGET in modes 4 and 7, as follows:
1. For mode 7, this value means that no entry exists with the
specified search value.
2. For mode 4, this value means that the entry at the specified
record number is empty.
Note that for increased performance, the calculated access call is made
with a list parameter equal to zero.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBGET in mode 7 (calculated read)
* DBGET in mode 4 (directed read)
* 1100-GET-ERROR-AND-EXPLAIN
300-GET-A-CUSTOMER-RECORD.
SET NOT-FOUND TO TRUE
DISPLAY CLEAR SCREEN
DISPLAY "Enter the Account # For The Customer Master"
NO ADVANCING
DISPLAY "------------> " NO ADVANCING
ACCEPT KEY-ITEM-VALUE FREE
MOVE 7 TO DB-MODE
MOVE ZERO TO LIST-NO-ITEM
MOVE "@;" TO LIST
MOVE "CUSTOMER;" TO CUSTOMER-MASTER
CALL "DBGET" USING DBNAME, CUSTOMER-MASTER, DB-MODE, STATUS1,
LIST-NO-ITEM, CUSTOMER-BUFFER,
KEY-ITEM-VALUE
IF CONDITION = 0 THEN
SET FOUND TO TRUE
MOVE RECORD-NUMBER TO SAVED-RECORD-NUMBER
ELSE
IF CONDITION = NO-SUCH-ENTRY THEN
DISPLAY CLEAR SCREEN
DISPLAY "*****************************************"
DISPLAY "* No Such Entry in the Customer Data Set."
DISPLAY "* Please Try Again. "
DISPLAY "*****************************************"
DISPLAY "Press Enter to Continue ------------>"
NO ADVANCING
ACCEPT OPTION FREE
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
END-IF
IF FOUND THEN
MOVE 4 TO DB-MODE
MOVE "@;" TO LIST
MOVE "CUSTOMER;" TO CUSTOMER-MASTER
CALL "DBGET" USING DBNAME, CUSTOMER-MASTER, DB-MODE,
STATUS1, LIST, CUSTOMER-BUFFER,
SAVED-RECORD-NUMBER
IF CONDITION NOT = 0 THEN
IF CONDITION = ENTRY-HAS-NO-DATA THEN
DISPLAY CLEAR SCREEN
DISPLAY "***************************************"
DISPLAY "* Entry At The Specified Record Number "
DISPLAY "* Has Been Deleted. "
DISPLAY "***************************************"
DISPLAY "Press Enter To Continue ------------->"
NO ADVANCING
ACCEPT OPTION FREE
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
ELSE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
MOVE KEY-ITEM-VALUE TO ACCOUNT-NUMBER-CUST-OUT
DISPLAY "Data On Account# = ",
ACCOUNT-NUMBER-CUST-OUT
DISPLAY "****************************************"
DISPLAY "* *"
MOVE ACCOUNT-NUMBER OF CUSTOMER-BUFFER TO
ACCOUNT-NUMBER-CUST-OUT
DISPLAY "* Account # = ", ACCOUNT-NUMBER-CUST-OUT
DISPLAY "* Last Name = ", LAST-NAME
OF CUSTOMER-BUFFER
DISPLAY "* First Name = ", FIRST-NAME
OF CUSTOMER-BUFFER
DISPLAY "* Initial = ", INITIAL1
OF CUSTOMER-BUFFER
DISPLAY "* Address = ", STREET-ADDRESS
OF CUSTOMER-BUFFER
DISPLAY "* City = ", CITY OF CUSTOMER-BUFFER
DISPLAY "* State = ", STATE OF CUSTOMER-BUFFER
DISPLAY "* Zip = ", ZIP OF CUSTOMER-BUFFER
DISPLAY "* *"
DISPLAY "****************************************"
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "Press Enter to Continue ------------------>"
NO ADVANCING
ACCEPT OPTION FREE
END-IF
END-IF.
Retrieving Master Data Using a Key Value.
This paragraph implements the GET-PRODUCT-RECORD routine of the sample
program. The calculated access is achieved by a call to DBGET in mode 7.
The exceptional condition in this routine is indicated by status 17 for
search values which do not have any corresponding entries. Error
trapping calls 1100-GET-ERROR-AND-EXPLAIN upon detection of a
non-exceptional condition.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBGET in mode 7 (calculated read)
* 1100-GET-ERROR-AND-EXPLAIN
400-GET-PRODUCT-RECORD.
SET NOT-FOUND TO TRUE
DISPLAY CLEAR SCREEN
DISPLAY "Enter the Stock # in the Product Master ----->"
NO ADVANCING
ACCEPT KEY-ITEM-VALUE-PRODUCT FREE
MOVE 7 TO DB-MODE
MOVE "@;" TO LIST
MOVE "PRODUCT;" TO PRODUCT-MASTER
CALL "DBGET" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1,
LIST, PRODUCT-BUFFER,
KEY-ITEM-VALUE-PRODUCT
IF CONDITION = 0 THEN
SET FOUND TO TRUE
ELSE
SET NOT-FOUND TO TRUE
IF CONDITION = NO-CHAIN-HEAD THEN
DISPLAY CLEAR SCREEN
DISPLAY "****************************************"
DISPLAY "* No Such Entry in the Product Data Set."
DISPLAY "* Please Try Again. "
DISPLAY "****************************************"
DISPLAY "Press Enter To Continue ------------->"
NO ADVANCING
ACCEPT OPTION FREE
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
END-IF
IF FOUND THEN
DISPLAY SPACE
DISPLAY "Data On Stock # = ", KEY-ITEM-VALUE-PRODUCT
DISPLAY "**********************************************"
DISPLAY "* *"
DISPLAY "* Stock # = ", STOCK-NUMBER OF PRODUCT-BUFFER
DISPLAY "* Product = ", DESCRIPTION OF PRODUCT-BUFFER
DISPLAY "* *"
DISPLAY "**********************************************"
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "Press Enter To Continue ------------->"
NO ADVANCING
ACCEPT OPTION FREE
END-IF.
Retrieving Data Serially (with Set Level Locking).
This paragraph implements the LIST-ALL-CUSTOMERS routine of the sample
program. Serial read of the Customer data set is achieved using multiple
calls to the DBGET procedure in mode 2. Using the list parameter the
routine requests only the ACCOUNT, FIRST-NAME, LAST-NAME, and INITIAL
data items.
This procedure locks the Customer data set exclusively using a call to
the DBLOCK procedure in mode 3. The subsequent DBUNLOCK releases this
lock. This is done when the exceptional condition, end of data set, is
encountered. Locking in a shared modify access environment guarantees
that no other user is modifying the data that you are reading. Error
trapping calls 1100-GET-ERROR-AND-EXPLAIN for any non-exceptional
condition codes.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBLOCK in mode 3 (unconditional)
* DBGET in mode 2 (forward read)
* DBUNLOCK in mode 1 (unlock)
* 1100-GET-ERROR-AND-EXPLAIN
500-LIST-ALL-CUSTOMERS.
DISPLAY CLEAR SCREEN
DISPLAY SPACE
DISPLAY "Acct-Number N A M E"
DISPLAY "-------------------------------------------"
SET NOT-DONE TO TRUE
MOVE 3 TO DB-MODE
MOVE "@;" TO LIST
MOVE "CUSTOMER;" TO CUSTOMER-MASTER
CALL "DBLOCK" USING DBNAME, CUSTOMER-MASTER, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE 2 TO DB-MODE
MOVE "ACCOUNT,LAST-NAME,FIRST-NAME,INITIAL;" TO LIST
PERFORM WITH TEST AFTER UNTIL DONE
CALL "DBGET" USING DBNAME, CUSTOMER-MASTER, DB-MODE,
STATUS1, LIST, CUSTOMER-BUFFER,
NOT-USED-PARM-32
IF CONDITION NOT = 0 THEN
IF CONDITION = END-OF-DATA-SET THEN
SET DONE TO TRUE
DISPLAY SPACE
DISPLAY "*End of Data Set"
DISPLAY "* Press Enter to Continue ------->"
NO ADVANCING
ACCEPT OPTION FREE
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
ELSE
MOVE ACCOUNT-NUMBER OF CUSTOMER-BUFFER TO
ACCOUNT-NUMBER-CUST-OUT
MOVE FIRST-NAME OF CUSTOMER-BUFFER TO
FIRST-NAME-CUST-OUT
MOVE INITIAL1 OF CUSTOMER-BUFFER TO
INITIAL1-CUST-OUT
MOVE LAST-NAME OF CUSTOMER-BUFFER TO
LAST-NAME-CUST-OUT
DISPLAY CUSTOMER-BUFFER-OUT
END-IF
END-PERFORM
MOVE 1 TO DB-MODE
CALL "DBUNLOCK" USING DBNAME, CUSTOMER-MASTER, DB-MODE,
STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF.
Adding an Entry.
This paragraph implements the ADD-A-PRODUCT routine of the sample program
to add a data entry to the Product manual master data set. The add entry
operation is achieved using a call to DBPUT. Before this call, the
paragraph initiates a TurboIMAGE/XL transaction and locks the product
master data set. The beginning and end of the transaction are indicated
by calls to DBBEGIN and DBEND. Locking is done exclusively at the set
level. For error trapping, 1100-GET-ERROR-AND-EXPLAIN is called when any
status code is not equal to zero.
Note that the list contains an at-sign (@) which requests TurboIMAGE/XL
to return all fields of the data set in the order defined in the schema.
Other valid lists are the null list ('0;') which returns no data, and
same list ('*;') which returns the same fields listed in the previous
call.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBLOCK in mode 3 (unconditional)
* DBBEGIN in mode 1 (transaction begin)
* DBPUT in mode 1 (put)
* DBEND in mode 1 (transaction end)
* DBUNLOCK in mode 1 (unlock)
* 1100-GET-ERROR-AND-EXPLAIN
600-ADD-A-PRODUCT.
MOVE 0 TO ANSWER
PERFORM WITH TEST BEFORE UNTIL ANSWER = 1
DISPLAY CLEAR SCREEN
DISPLAY " Please Provide the Following Values "
DISPLAY "****************************************"
DISPLAY "* *"
DISPLAY "* Stock # = " NO ADVANCING
ACCEPT STOCK-NUMBER OF PRODUCT-BUFFER FREE
DISPLAY "* Product = " NO ADVANCING
ACCEPT DESCRIPTION OF PRODUCT-BUFFER FREE
DISPLAY "* *"
DISPLAY "****************************************"
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "Enter, <1> to Continue, <2> to Retry >"
NO ADVANCING
ACCEPT ANSWER FREE
END-PERFORM
MOVE "PRODUCT;" TO PRODUCT-MASTER
MOVE 3 TO DB-MODE
CALL "DBLOCK" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE "Add Entry to Product Set Begin" TO TEXT1
MOVE 16 TO TEXTLEN
MOVE 1 TO DB-MODE
CALL "DBBEGIN" USING DBNAME, TEXT1, DB-MODE, STATUS1, TEXTLEN
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE "@;" TO LIST
CALL "DBPUT" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1,
LIST, PRODUCT-BUFFER
IF CONDITION = 0 THEN
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "*************************************"
DISPLAY "Stock ", STOCK-NUMBER OF PRODUCT-BUFFER,
"Was Successfully Added to the Product Set"
DISPLAY "*************************************"
DISPLAY "Enter to Continue ..............>"
NO ADVANCING
ACCEPT OPTION FREE
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE "Add Entry to Product Set End" TO TEXT1
MOVE 14 TO TEXTLEN
CALL "DBEND" USING DBNAME, TEXT1, DB-MODE, STATUS1, TEXTLEN
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
CALL "DBUNLOCK" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF.