HP 3000 Manuals HP 3000 Manuals
ORDERS Database Model Program (contd)
Closing the Database
(USER SELECTS 12 TO CLOSE THE DATABASE)
ROUTINE: Close_The_Database
* OBJECTIVE: This routine closes the ORDERS database by calling
* the DBCLOSE intrinsic.
*
* ACCESS: Mode 1 - Shared Modify Access
*
* CALLED BY: Main Line
*
* CALLS: DBCLOSE in mode 1 (close)
BEGIN ROUTINE
CALL DBCLOSE (DBname, Not_Used_Parm, Mode1_Close, Status)
ERROR CHECKING
END ROUTINE
C
[REV BEG]
This section shows, in C, portions of the model program presented at the
beginning of this chapter. The examples perform specific tasks to
illustrate the use of TurboIMAGE/XL intrinsics. The C example does not
illustrate everything in the COBOL example. Some blocks of code may be
appropriate only if expanded to a full program.[REV END]
Data items are defined at the beginning of the sample program.
TurboIMAGE/XL intrinsics must be declared for C as external procedures.
The procedure name is identified by the word "Intrinsic."
Type declarations declare names for data structure forms that will be
used in allocating variables. Variable declarations allocate the
variables of the program. Variables are defined with precise types or
forms. C string literals are delimited with double quotation marks ("
"). Field and record names are separated with a dot (.) when referenced
(for example, base_name.baseid).
NOTE Because the Schema Processor, DBSCHEMA, upshifts alphabetic
characters, programs must specify data set and data item names in
all uppercase characters. Take note of this because C does not
require that you use uppercase characters.
For information on TurboIMAGE/XL data item lengths and type designators,
refer to chapter 3. Tables 3-2 and 3-3 show the TurboIMAGE/XL type
designators, sub-item lengths, and data types typically used to process
them in C.
NOTE All parameters must be on halfword boundaries.
Defining Data Types, Variables, and Intrinsics
The following is part of the C example program; it defines type
declarations, variable declarations, and TurboIMAGE/XL intrinsics.
[REV BEG]
#pragma list off
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#pragma list on
/* Define all TurboIMAGE/XL procedure calls that */
/* will be used in your application program */
#pragma intrinsic DBBEGIN, DBEND, DBOPEN, DBCLOSE, DBGET, DBPUT,DBFIND, DBINFO
#pragma intrinsic DBEXPLAIN, DBERROR, DBDELETE, DBUPDATE, DBLOCK,DBUNLOCK
/* Define all your TurboIMAGE/XL constants */
#define End_Of_Chain 15 /* For DBGET Mode 5 */
#define End_Of_Data_Set 11 /* For DBGET Mode 2 */
#define No_Chain_Head 17 /* For DBFIND */
#define No_Such_Entry 17 /* For DBGET Mode 7 */
#define Entry_Has_No_Data 17 /* For DBGET Mode 4 */
short DBname[6]
Password[4]
Sales_D_Set[4];
char
*Purch_Date = "PURCH-DATE;",
*Equal_Op = " =",
*Item_List ="ACCOUNT,STOCK#,PRICE,TAX,TOTAL,PURCH-DATE;";
/* Define all your global variables. */
struct
Database_Status_Type { short Condition;
short Length;
int Record_Number;
int Chain_Count;
int Back_Pointer;
int Forward_Pointer;
} Status;
struct
Sales_Data_Set_Type {int Account_Number;
char Stock_Number[8];
int Price;
int Tax;
int Total;
char Purch_Date[6];
};
struct
Lock_Descriptor_Type {short Num_Of_Elements;
short Length_Of_Descriptor;
char Data_Set_Of_Descriptor[16];
char Data_Item_Of_Descriptor[16];
char Relop_For_Data_Item[2];
char Value_For_Data_Item[6];
};
short Mode;
Main Body of Program
/* Beginning of the main program */
main()
{
/* Initialize the database and set information */
strcpy ((char *)DBname," ORDERS; ");
strcpy ((char *)Password,"DO-ALL;");
strcpy ((char *)Sales_D_Set,"SALES;");
Open_The_Database();
Get_Sales_For_Date();
exit (0);
}
[REV END]
Obtaining Error Messages and Explanations
The following paragraph implements the GET-ERROR-AND-EXPLAIN routine of
the sample program. This routine calls DBEXPLAIN and DBERROR. DBEXPLAIN
interprets the contents of the status parameter and prints a message on
$STDLIST. DBERROR returns a message in the ERROR-BUFFER, explaining the
condition code returned by TurboIMAGE/XL. At the end the routine, users
can choose to abort or continue the execution of this program.
[REV BEG]
/* Beginning of subroutines */
Get_Error_And_Explain()
{
/*
Access : Mode 1 - Shared Modified Access
The Orders database was opened in mode 1
Called by: Open_The_Database
Get_Sales_For_Date
Get_A_Product_Record
List_All_Customers
Add_A_Product
Update_A_Customer
Delete_A_Product
Rewind_Customer_Set
Get_Data_Item_Info
Close_The_Database
Calls : DBERROR
DBEXPLAIN
*/
short Error_Buffer[80];
short Error_Length;
int Answer;
DBERROR(&Status,Error_Buffer,&Error_Length);
printf("-------------------------------------------\n");
printf("%.*s\n",Error_Length, (char *)Error_Buffer);
printf("-------------------------------------------\n");
DBEXPLAIN(&Status);
Answer=0;
printf("---Enter, <1> to ABORT..., <2> to Continue >\n");
scanf("%d",&Answer);
if (Answer != 1)
printf(" Continuing .........\n");
else
exit(0);
}
[REV END]
Opening the Database
This paragraph implements the OPEN-THE-DATABASE routine of the sample
program in C. All required values, such as the password, are defined in
the "static char" section of the program. 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 the GET-ERROR-AND-EXPLAIN procedure.
Open_The_Database()
{
/*
ACCESS : Mode 1 - Shared Modify Access (SMA) with locking required
Called By: Main Line
Calls : DBOPEN in mode 1 (SMA)
Get_Error_And_Explain
*/
Mode =1;
DBOPEN(DBname,Password,&Mode,&Status);
if (Status.Condition != 0)
Get_Error_And_Explain();
}
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.
[REV BEG]
Get_Sales_For_Date()
/*
ACCESS : Mode 1 - Shared Modify Access
The Orders database was opened in mode 1
Called By: Main Line
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)
Get_Error_And_Explain
*/
{
struct Lock_Descriptor_Type Lock_Descriptor;
struct Sales_Data_Set_Type Sales_Buffer;
short Search_Item_Value[3];
short Search_Item_Name[8];
short List[40];
short Dummy;
size_t srch_len = 6;
/* Prepare the lock descriptor buffer for obtaining item
level locks on the Sales data set.
*/
Lock_Descriptor.Num_Of_Elements = 1;
Lock_Descriptor.Length_Of_Descriptor = 21;
strcpy(Lock_Descriptor.Data_Set_Of_Descriptor,(char *)Sales_D_Set);
strcpy(Lock_Descriptor.Data_Item_Of_Descriptor,(char *)Purch_Date);
Lock_Descriptor.Relop_For_Data_Item[0] = Equal_Op[0];
Lock_Descriptor.Relop_For_Data_Item[1] = Equal_Op[1];
printf("Enter The Date of Purchase as (YYMMDD) >>> \n");
scanf("%6c", (char *)Search_Item_Value);
/* Request item level locks (mode 5) */
Mode = 5;
/* Append the user's input to the lock descriptor buffer */
strncpy(Lock_Descriptor.Value_For_Data_Item,
(char *)Search_Item_Value,srch_len);
/* Place item level locks on all entries identified by
the value in the Search_Item_Value
*/
DBLOCK(DBname,&Lock_Descriptor,&Mode,&Status);
if (Status.Condition != 0)
Get_Error_And_Explain();
Mode = 1;
strcpy((char *)Search_Item_Name, Purch_Date);
/* Locate the chain identified by the value in the
Search_Item_Value
*/
DBFIND(DBname,Sales_D_Set,&Mode,&Status,
Search_Item_Name, Search_Item_Value);
if (Status.Condition != 0)
{
if (Status.Condition == No_Chain_Head)
{
printf("***************************************\n");
printf("* No Such Entry in the Sales Dataset *\n");
printf("* Please Try Again. *\n");
printf("***************************************\n");
}
else
Get_Error_And_Explain();
}
else
{
/* Start retrieving all records in the current chain */
printf("\n");
printf("Acct-Number Stock_Number Price Tax Total Purch-Date \n");
printf("---------------------------------------------------------\n");
Mode = 5;
strcpy((char *)List,Item_List);
while (Status.Condition != End_Of_Chain)
{
DBGET(DBname,Sales_D_Set,&Mode,&Status,List,&Sales_Buffer,
&Dummy);
if (Status.Condition == 0)
{
printf("\n");
printf("%11d",Sales_Buffer.Account_Number);
printf("%13.8s",Sales_Buffer.Stock_Number);
printf("%8d",Sales_Buffer.Price);
printf("%6d",Sales_Buffer.Tax);
printf("%7d",Sales_Buffer.Total);
printf("%12.6s",Sales_Buffer.Purch_Date);
}
else
{
if (Status.Condition == End_Of_Chain)
{
printf("\n\n\n");
printf ("----> End Of Chain.\n");
}
else
Get_Error_And_Explain();
}
} /* while */
} /* else */
/* Release all locks aquired at the beginning of the process */
Mode = 1; = 1;
DBUNLOCK (DBname,Sales_D_Set,&Mode,&Status);
if (Status.Condition != 0)
Get_Error_And_Explain();
}
[REV END]
COBOL II
The model program presented at the beginning of this chapter is now shown
here in COBOL II. The program performs specific tasks to illustrate the
use of TurboIMAGE/XL intrinsics. Note that the code, although broken out
by task, can be combined to make up a complete, executable program.
Data items are defined at the beginning of the sample program. The
parameters for the TurboIMAGE/XL intrinsics are defined in the data
division, and their values are defined when the procedure is called or,
in some cases, after it is executed.
The database identifier is described as follows:
01 DBNAME.
05 BASEID PIC X(02).
05 BASENAME PIC X(06).
05 TERMINATOR PIC X(02).
To access a database catalogued in a group other than the user's log-on
group, the database name must be followed by a period and the group name,
for example, ORDERS.GROUPX. If the database is in an account other than
the user's account, the group name must be followed by a period and the
account name, for example, ORDERS.GROUPX.ACCOUNT1.
Once the database has been opened and the database identifier has been
moved to the first halfword of the element (as shown in "Opening the
Database"), it remains the same for all subsequent calls illustrated.
The status record is defined in the same way for all tasks but its
content varies depending upon which procedure is called and the results
of that procedure. The status record is defined as follows:
01 STATUS1.
05 CONDITION PIC S9(4) COMP.
05 LENGTH1 PIC S9(4) COMP.
05 RECORD-NUMBER PIC S9(9) COMP.
05 CHAIN-COUNT PIC S9(9) COMP.
05 BACK-POINTER PIC S9(9) COMP.
05 FORWARD-POINTER PIC S9(9) COMP.
NOT-USED-PARM appears as a reminder when a parameter is not used by a
procedure performing the task being illustrated. NOT-USED-PARM is
defined in this program as follows:
01 NOT-USED-PARM-16 PIC S9(4) COMP.
01 NOT-USED-PARM-32 PIC S9(9) COMP.
NOTE Because the Schema Processor, DBSCHEMA, upshifts alphabetic
characters, programs must specify data set and data item names in
all uppercase characters. Take note of this because COBOL II does
not require that you use uppercase characters.
For information on TurboIMAGE/XL data item lengths and type designators,
refer to chapter 3. Tables 3-2 and 3-3 show the TurboIMAGE/XL type
designators, sub-item lengths, and data types typically used to process
them in COBOL II.
NOTE All parameters must be on halfword boundaries.
Defining Data Types, Variables, and Intrinsics
The following is part of the COBOL II program; it defines all the data
items and records.
IDENTIFICATION DIVISION.
PROGRAM-ID. RECEIVE.
DATE-COMPILED.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
SYMBOLIC CHARACTERS CLEAR, SCREEN IS 28, 86.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 END-OF-CHAIN PIC S9(4) COMP VALUE 15.
01 END-OF-DATA-SET PIC S9(4) COMP VALUE 11.
01 NO-CHAIN-HEAD PIC S9(4) COMP VALUE 17.
01 NO-SUCH-ENTRY PIC S9(4) COMP VALUE 17.
01 ENTRY-HAS-NO-DATA PIC S9(4) COMP VALUE 17.
01 DBNAME.
05 BASEID PIC X(02).
05 BASENAME PIC X(06).
05 TERMINATOR PIC X(02).
01 PASSWORD PIC X(10).
01 STATUS1.
05 CONDITION PIC S9(4) COMP.
05 LENGTH1 PIC S9(4) COMP.
05 RECORD-NUMBER PIC S9(9) COMP.
05 CHAIN-COUNT PIC S9(9) COMP.
05 BACK-POINTER PIC S9(9) COMP.
05 FORWARD-POINTER PIC S9(9) COMP.
01 OPTION PIC S9(4) COMP.
01 DB-MODE PIC S9(4) COMP.
01 LIST PIC X(80).
01 ERROR-BUFFER PIC X(80).
01 ERROR-LENGTH PIC S9(9) COMP.
01 ANSWER PIC S9(4) COMP.
01 LOCK-DESCRIPTOR-ARRAY.
05 NUM-OF-ELEMENTS PIC S9(4) COMP.
05 LOCK-DESCRIPTOR-SALES.
10 LENGTH-OF-DESCRIPTOR PIC S9(4) COMP.
10 DATA-SET-OF-DESCRIPTOR PIC X(16).
10 DATA-ITEM-OF-DESCRIPTOR PIC X(16).
10 RELOP-FOR-DATA-ITEM PIC X(02).
10 VALUE-FOR-DATA-ITEM PIC X(6).
10 NUM-VALUE-FOR-DATA-ITEM REDEFINES
VALUE-FOR-DATA-ITEM PIC S9(9) COMP.
01 SALES-DETAIL PIC X(16).
01 SEARCH-ITEM-NAME PIC X(16).
01 SEARCH-ITEM-VALUE PIC X(6).
01 SALES-BUFFER.
05 ACCOUNT-NUMBER PIC S9(9) COMP.
05 STOCK-NUMBER PIC X(8).
05 QUANTITY PIC S9(4) COMP.
05 PRICE PIC S9(9) COMP.
05 TAX PIC S9(9) COMP.
05 TOTAL PIC S9(9) COMP.
05 PURCH-DATE PIC X(6).
05 DELIV-DATE PIC X(6).
01 SALES-BUFFER-OUT.
05 ACCOUNT-NUMBER-OUT PIC Z(9)9.
05 STOCK-NUMBER-OUT PIC B(7)X(8).
05 QUANTITY-OUT PIC Z(5)9.
05 PRICE-OUT PIC Z(6)9.
05 TAX-OUT PIC Z(4)9.
05 TOTAL-OUT PIC Z(6)9.
05 PURCH-DATE-OUT PIC B(6)X(6).
05 DELIV-DATE-OUT PIC B(6)X(6).
01 SALES-BUFFER-HEADER.
05 ACCOUNT-NUMBER-HEAD PIC X(13)
VALUE "Acct-Number ".
05 STOCK-NUMBER-HEAD PIC X(15)
VALUE "Stock-Number ".
05 QUANTITY-HEAD PIC X(05)
VALUE "QTY ".
05 PRICE-HEAD PIC X(07)
VALUE "Price ".
05 TAX-HEAD PIC X(06)
VALUE "Tax ".
05 TOTAL-HEAD PIC X(07)
VALUE "Total ".
05 PURCH-DATE-HEAD PIC X(13)
VALUE "Purch-Date ".
05 DELIV-DATE-HEAD PIC X(14)
VALUE "Delive-Date ".
01 LINE-HEADER.
05 PIC X(40)
VALUE "----------------------------------------".
05 PIC X(38)
VALUE "--------------------------------------".
01 NOT-USED-PARM-16 PIC S9(4) COMP.
01 NOT-USED-PARM-32 PIC S9(9) COMP.
01 FOUND-VALUE PIC S9(4) COMP.
88 NOT-FOUND VALUE 0.
88 FOUND VALUE 1.
01 CUSTOMER-MASTER PIC X(16).
01 CUSTOMER-BUFFER.
05 ACCOUNT-NUMBER PIC S9(9) COMP.
05 LAST-NAME PIC X(16).
05 FIRST-NAME PIC X(10).
05 INITIAL1 PIC X(02).
05 STREET-ADDRESS PIC X(26).
05 CITY PIC X(12).
05 STATE PIC X(02).
05 ZIP PIC X(06).
05 CREDIT-RATING PIC X(08).
01 CUSTOMER-BUFFER-OUT.
05 ACCOUNT-NUMBER-CUST-OUT PIC 9(6).
05 FIRST-NAME-CUST-OUT PIC X(15) JUST RIGHT.
05 PIC X.
05 INITIAL1-CUST-OUT PIC X(02).
05 LAST-NAME-CUST-OUT PIC X(16) JUST RIGHT.
01 KEY-ITEM-VALUE-PRODUCT PIC X(08).
01 KEY-ITEM-VALUE PIC S9(9) COMP.
01 LIST-NO-ITEM PIC S9(9) COMP.
01 SAVED-RECORD-NUMBER PIC S9(9) COMP.
01 PRODUCT-MASTER PIC X(16).
01 PRODUCT-BUFFER.
05 STOCK-NUMBER PIC X(08).
05 DESCRIPTION PIC X(20).
01 DONE-VALUE PIC S9(4) COMP.
88 NOT-DONE VALUE 0.
88 DONE VALUE 1.
01 TEXT1 PIC X(80).
01 TEXTLEN PIC S9(9) COMP.
01 CUSTOMER-BUFFER-NEW.
05 ACCOUNT-NUMBER PIC S9(9) COMP.
05 LAST-NAME PIC X(16).
05 FIRST-NAME PIC X(10).
05 INITIAL1 PIC X(02).
05 STREET-ADDRESS PIC X(26).
05 CITY PIC X(12).
05 STATE PIC X(02).
05 ZIP PIC X(06).
05 CREDIT-RATING PIC X(08).
01 CUSTOMER-BUFFER-OLD.
05 ACCOUNT-NUMBER PIC S9(9) COMP.
05 LAST-NAME PIC X(16).
05 FIRST-NAME PIC X(10).
05 INITIAL1 PIC X(02).
05 STREET-ADDRESS PIC X(26).
05 CITY PIC X(12).
05 STATE PIC X(02).
05 ZIP PIC X(06).
05 CREDIT-RATING PIC X(08).
01 DATA-ITEM-NAME-IN PIC X(16).
01 M-102-BUFFER.
05 DATA-ITEM-NAME PIC X(16).
05 DATA-ITEM-TYPE PIC X(02).
05 DATA-ITEM-LENGTH PIC S9(4) COMP.
05 DATA-ITEM-COUNT PIC S9(4) COMP.
05 NOT-USED-ITEM PIC S9(4) COMP.
01 MENU.
05 MENU-LINE-1 PIC X(62) VALUE
"--------------------------------------------------------------".
05 MENU-LINE-2 PIC X(62) VALUE
"| |".
05 MENU-LINE-3 PIC X(62) VALUE
"| Entry Point |".
05 MENU-LINE-4 PIC X(62) VALUE
"| O R D E R S D A T A B A S E |".
05 MENU-LINE-5 PIC X(62) VALUE
"|------------------------------------------------------------|".
05 MENU-LINE-6 PIC X(62) VALUE
"| 1)OPEN DATABASE 2)GET SALES RECORD FOR DATE |".
05 MENU-LINE-7 PIC X(62) VALUE
"| 3)GET A CUSTOMER RECORD 4)GET A PRODUCT RECORD |".
05 MENU-LINE-8 PIC X(62) VALUE
"| 5)LIST ALL CUSTOMERS 6)ADD A PRODUCT |".
05 MENU-LINE-9 PIC X(62) VALUE
"| 7)UPDATE CUSTOMER RECORD 8)DELETE A PRODUCT |".
05 MENU-LINE-10 PIC X(62) VALUE
"| 9)REWIND/RESET CUSTOMER SET 10)OBTAIN DATA ITEM INFORMATION|".
05 MENU-LINE-11 PIC X(62) VALUE
"| 11)GENERATE ERROR MESSAGES 12)CLOSE DATABASE |".
Main Body of Program
PROCEDURE DIVISION.
10-MAIN-LINE.
PERFORM WITH TEST AFTER UNTIL OPTION = 12
PERFORM 20-DISPLAY-MENU
PERFORM 30-DO-ACTION
END-PERFORM
STOP RUN.
20-DISPLAY-MENU.
DISPLAY CLEAR SCREEN
DISPLAY MENU-LINE-1
DISPLAY MENU-LINE-2
DISPLAY MENU-LINE-3
DISPLAY MENU-LINE-4
DISPLAY MENU-LINE-5
DISPLAY MENU-LINE-2
DISPLAY MENU-LINE-6
DISPLAY MENU-LINE-7
DISPLAY MENU-LINE-8
DISPLAY MENU-LINE-9
DISPLAY MENU-LINE-10
DISPLAY MENU-LINE-11
DISPLAY MENU-LINE-2
DISPLAY MENU-LINE-1
DISPLAY SPACE.
30-DO-ACTION.
DISPLAY " Enter your option : "
WITH NO ADVANCING
ACCEPT OPTION FREE
EVALUATE OPTION
WHEN 1 PERFORM 100-OPEN-THE-DATABASE
WHEN 2 PERFORM 200-GET-SALES-FOR-DATE
WHEN 3 PERFORM 300-GET-A-CUSTOMER-RECORD
WHEN 4 PERFORM 400-GET-A-PRODUCT-RECORD
WHEN 5 PERFORM 500-LIST-ALL-CUSTOMERS
WHEN 6 PERFORM 600-ADD-A-PRODUCT
WHEN 7 PERFORM 700-UPDATE-A-CUSTOMER
WHEN 8 PERFORM 800-DELETE-A-PRODUCT
WHEN 9 PERFORM 900-REWIND-CUSTOMER-SET
WHEN 10 PERFORM 1000-GET-DATA-ITEM-INFO
WHEN 11 PERFORM 1100-GET-ERROR-AND-EXPLAIN
WHEN 12 PERFORM 1200-CLOSE-THE-DATABASE
WHEN OTHER
DISPLAY "-----------------------------------"
DISPLAY "| Please enter an option between |"
DISPLAY "| 1 and 12. |"
DISPLAY "-----------------------------------"
DISPLAY "Press Enter to Continue... "
NO ADVANCING
ACCEPT OPTION FREE
END-EVALUATE.
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.