 |
» |
|
|
|
The example programs in this section are based on the
manufacturing database and the purchasing database that are a part of the
sample database environment, PartsDBE. (Reference the , appendix C.)
Informative comments and explanations are present throughout each listing.
The following programs are included:
COBEX30, using date/time functions to allow
input and display of DATE and DATETIME columns in European format.
COBEX9a, converting a column data type from CHAR to DATE.
Example Program Using Date/Time Functions | |
The following program is intended as a framework
in which to illustrate
why you might use date/time functions and how they are implemented.
It is based on the manufacturing database, ManufDB, which is supplied
as part of the ALLBASE/SQL software package. The schema files used to
create the database are found in appendix C of the .
As you work with the program, you will also become familiar with
integrity contraints, since the BatchStamp column in the
TestData table references the BatchStamp column in the SupplyBatches
table.
You could enhance this program to fit your needs. One useful enhancement
might be to use bulk table processing rather than simple data manipulation
commands. Thus you could operate on duplicate BatchStamps within the TestData table.
Figure 13-1 Using Date/Time Functions
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* This program illustrates the use of DATE/TIME functions. *
* Simple data manipulation commands are used on the TestData *
* table (part of the ManufDB database in the PartsDBE database*
* environment). Rows can be selected, deleted, or updated on *
* the basis of the BatchStamp column (defined in the table as *
* of DATETIME data type). Any column that can contain null *
* values (any column except BatchStamp) can be updated. Rows *
* can also be inserted. *
* *
* User input and output for DATETIME and DATE columns is in *
* European formats rather than the default formats for these *
* data types. *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
IDENTIFICATION DIVISION.
PROGRAM-ID. COBEX30.
AUTHOR. JOANN GRAY
INSTALLATION. HP.
DATE-WRITTEN. 31 OCT 1990.
DATE-COMPILED. 31 OCT 1990.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. HP-9000.
OBJECT-COMPUTER. HP-9000.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT TERM ASSIGN TO ":CO:".
DATA DIVISION.
FILE SECTION.
FD TERM.
01 PROMPT-USER PIC X(40).
WORKING-STORAGE SECTION.
EXEC SQL INCLUDE SQLCA END-EXEC.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * * * * BEGIN HOST VARIABLE DECLARATIONS * * * * * * * *
EXEC SQL BEGIN DECLARE SECTION END-EXEC.
* DATETIME column, not null *
01 BATCHSTAMP PIC X(23).
01 BATCHSTAMP2 PIC X(23).
01 BATCHSTAMP3 PIC X(23).
* DATE column, nulls allowed *
01 TESTDATE PIC X(10).
01 TESTDATEIND SQLIND.
* TIME column, nulls allowed *
01 TESTSTART PIC X(8).
01 TESTSTARTIND SQLIND.
* TIME column, nulls allowed *
01 TESTEND PIC X(8).
01 TESTENDIND SQLIND.
* INTERVAL column, nulls allowed *
01 LABTIME PIC X(20).
01 LABTIMEIND SQLIND.
* INTEGER column, nulls allowed *
01 PASSQTY PIC S9(9) COMP.
01 PASSQTYIND SQLIND.
* INTEGER column, nulls allowed *
01 TESTQTY PIC S9(9) COMP.
01 TESTQTYIND SQLIND.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* Host Variables for date/time function format specifications. *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
01 BATCHSTAMP-FORMAT PIC X(23).
01 TESTDATE-FORMAT PIC X(10).
01 SQLMESSAGE PIC X(132).
EXEC SQL END DECLARE SECTION END-EXEC.
* * * * * * END OF HOST VARIABLE DECLARATIONS * * * * * * *
77 DONE-FLAG PIC X VALUE SPACE.
88 NOT-DONE VALUE SPACE.
88 DONE VALUE "X".
77 FUNC-DONE-FLAG PIC X VALUE SPACE.
88 FUNC-NOT-DONE VALUE SPACE.
88 FUNC-DONE VALUE "X".
77 ABORT-FLAG PIC X VALUE SPACE.
88 NOT-ABORT VALUE SPACE.
88 ABORT VALUE "X".
01 OK PIC S9(9) COMP VALUE 0.
01 NOTFOUND PIC S9(9) COMP VALUE 100.
01 DEADLOCK PIC S9(9) COMP VALUE -14024.
01 NOMEMORY PIC S9(9) COMP VALUE -4008.
01 RESPONSE.
05 RESPONSE-PREFIX PIC X(1) VALUE SPACE.
05 RESPONSE-SUFFIX PIC X(22) VALUE SPACES.
01 RESPONSE1 PIC S9(9) COMP.
01 COUNTER PIC S9(4) COMP.
01 NUMFORMAT PIC ZZZZZ9.
PROCEDURE DIVISION.
A100-MAIN.
ACCEPT RESPONSE1.
DISPLAY "Program COBEX30."
DISPLAY "Using Date/Time Functions to Allow Input and Display
-" of DATE and DATETIME".
DISPLAY "Columns in European Format."
DISPLAY " ".
OPEN OUTPUT TERM.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* Initialize host variable format specifications for date/time *
* operations. These could be changed depending on the standard *
* format used by a particular set of users in a given location. *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
MOVE "DD-MM-YYYY HH:MI:SS.FFF" TO BATCHSTAMP-FORMAT.
MOVE "DD-MM-YYYY" TO TESTDATE-FORMAT.
PERFORM A200-CONNECT-DBENVIRONMENT THRU A200-EXIT.
PERFORM B100-DISPLAY-MENU THRU B100-EXIT
UNTIL DONE.
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
A100-EXIT.
EXIT.
A200-CONNECT-DBENVIRONMENT.
DISPLAY "Connect to ../sampledb/PartsDBE".
EXEC SQL
CONNECT TO '../sampledb/PartsDBE'
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
A200-EXIT.
EXIT.
A300-BEGIN-TRANSACTION.
DISPLAY " ".
DISPLAY "Begin Work".
EXEC SQL
BEGIN WORK
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
A300-EXIT.
EXIT.
A400-COMMIT-WORK.
DISPLAY " ".
DISPLAY "Commit Work".
EXEC SQL
COMMIT WORK
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
A400-EXIT.
EXIT.
A500-TERMINATE-PROGRAM.
EXEC SQL
RELEASE
END-EXEC.
STOP RUN.
A500-EXIT.
EXIT.
B100-DISPLAY-MENU.
DISPLAY " ".
DISPLAY " ".
DISPLAY " 1 . . . SELECT rows from ManufDB.TestData table.".
DISPLAY " 2 . . . UPDATE rows in ManufDB.TestData table.".
DISPLAY " 3 . . . DELETE rows from ManufDB.TestData table.".
DISPLAY " 4 . . . INSERT rows into ManufDB.TestData table.".
DISPLAY " ".
MOVE "Enter choice or 0 to STOP > " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT RESPONSE1.
IF RESPONSE1 = ZERO
MOVE "X" TO DONE-FLAG
GO TO B100-EXIT.
DISPLAY " ".
MOVE SPACES TO FUNC-DONE-FLAG.
IF RESPONSE1 = 1
DISPLAY " "
DISPLAY " *** Procedure to SELECT rows from ManufDB.TestD
- "ata *** "
DISPLAY " "
PERFORM C100-SELECT-DATA THRU C100-EXIT
UNTIL FUNC-DONE
MOVE SPACES TO FUNC-DONE-FLAG
GO TO B100-EXIT.
IF RESPONSE1 = 2
DISPLAY " "
DISPLAY " *** Procedure to UPDATE rows in ManufDB.TestData
- " *** "
DISPLAY " "
PERFORM C200-UPDATE-DATA THRU C200-EXIT
UNTIL FUNC-DONE
MOVE SPACES TO FUNC-DONE-FLAG
GO TO B100-EXIT.
IF RESPONSE1 = 3
DISPLAY " "
DISPLAY " *** Procedure to DELETE rows from ManufDB.TestD
- "ata *** "
DISPLAY " "
PERFORM C300-DELETE-DATA THRU C300-EXIT
UNTIL FUNC-DONE
MOVE SPACES TO FUNC-DONE-FLAG
GO TO B100-EXIT.
IF RESPONSE1 = 4
DISPLAY " "
DISPLAY " *** Procedure to INSERT rows into ManufDB.Vendo
- "rs *** "
DISPLAY " "
PERFORM C400-INSERT-DATA THRU C400-EXIT
UNTIL FUNC-DONE
MOVE SPACES TO FUNC-DONE-FLAG
GO TO B100-EXIT.
IF RESPONSE1 NOT = 0
AND RESPONSE1 NOT = 1
AND RESPONSE1 NOT = 2
AND RESPONSE1 NOT = 3
AND RESPONSE1 NOT = 4
DISPLAY "Enter 0-4 only, please".
B100-EXIT.
C100-SELECT-DATA.
MOVE "Enter BatchStamp or 0 for MENU> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT RESPONSE.
IF RESPONSE-PREFIX = ZERO AND RESPONSE-SUFFIX = SPACES
MOVE "X" TO FUNC-DONE-FLAG
GO TO C100-EXIT
ELSE
MOVE RESPONSE TO BATCHSTAMP.
PERFORM A300-BEGIN-TRANSACTION THRU A300-EXIT.
PERFORM D200-SQL-SELECT THRU D200-EXIT.
IF SQLCODE = OK
PERFORM D100-DISPLAY-ROW THRU D100-EXIT
ELSE
IF SQLCODE = NOTFOUND
DISPLAY " "
DISPLAY "Row not found!"
ELSE
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT.
PERFORM A400-COMMIT-WORK THRU A400-EXIT.
C100-EXIT.
EXIT.
C200-UPDATE-DATA.
MOVE "Enter BatchStamp or 0 for MENU> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT RESPONSE.
IF RESPONSE-PREFIX = ZERO AND RESPONSE-SUFFIX = SPACES
MOVE "X" TO FUNC-DONE-FLAG
GO TO C200-EXIT
ELSE
MOVE RESPONSE TO BATCHSTAMP.
PERFORM A300-BEGIN-TRANSACTION THRU A300-EXIT.
PERFORM D200-SQL-SELECT THRU D200-EXIT.
IF SQLCODE = OK
PERFORM C250-DISPLAY-UPDATE THRU C250-EXIT
ELSE
IF SQLCODE = NOTFOUND
DISPLAY " "
DISPLAY "Row not found!"
ELSE
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT.
PERFORM A400-COMMIT-WORK THRU A400-EXIT.
C200-EXIT.
EXIT.
C250-DISPLAY-UPDATE.
PERFORM D100-DISPLAY-ROW THRU D100-EXIT.
MOVE SPACES TO TESTDATE.
MOVE "Enter New TestDate (0 for NULL)> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT TESTDATE.
MOVE SPACES TO TESTSTART.
MOVE "Enter New TestStart (0 for NULL)> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT TESTSTART.
MOVE SPACES TO TESTEND.
MOVE "Enter New TestEnd (0 for NULL)> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT TESTEND.
MOVE SPACES TO LABTIME.
MOVE "Enter New LabTime (0 for NULL)> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT LABTIME.
MOVE ZERO TO PASSQTY.
MOVE "Enter New PassQty (0 for NULL)> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT PASSQTY.
MOVE ZERO TO TESTQTY.
MOVE "Enter New TestQty (0 for NULL)> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT TESTQTY.
IF TESTDATE = 0
MOVE -1 TO TESTDATEIND
ELSE
MOVE 0 TO TESTDATEIND.
IF TESTSTART = 0
MOVE -1 TO TESTSTARTIND
ELSE
MOVE 0 TO TESTSTARTIND.
IF TESTEND = 0
MOVE -1 TO TESTENDIND
ELSE
MOVE 0 TO TESTENDIND.
IF LABTIME = 0
MOVE -1 TO LABTIMEIND
ELSE
MOVE 0 TO LABTIMEIND.
IF PASSQTY = 0
MOVE -1 TO PASSQTYIND
ELSE
MOVE 0 TO PASSQTYIND.
IF TESTQTY = 0
MOVE -1 TO TESTQTYIND
ELSE
MOVE 0 TO TESTQTYIND.
EXEC SQL UPDATE MANUFDB.TESTDATA
SET TESTDATE = TO_DATE
(:TESTDATE :TESTDATEIND, :TESTDATE-FORMAT),
TESTSTART = :TESTSTART :TESTSTARTIND,
TESTEND = :TESTEND :TESTENDIND,
LABTIME = :LABTIME :LABTIMEIND,
PASSQTY = :PASSQTY :PASSQTYIND,
TESTQTY = :TESTQTY :TESTQTYIND
WHERE BATCHSTAMP = TO_DATETIME
(:BATCHSTAMP, :BATCHSTAMP-FORMAT)
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT.
C250-EXIT.
EXIT.
C300-DELETE-DATA.
MOVE "Enter BatchStamp or 0 for MENU> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT RESPONSE.
IF RESPONSE-PREFIX = ZERO AND RESPONSE-SUFFIX = SPACES
MOVE "X" TO FUNC-DONE-FLAG
GO TO C300-EXIT
ELSE
MOVE RESPONSE TO BATCHSTAMP.
PERFORM A300-BEGIN-TRANSACTION THRU A300-EXIT.
PERFORM D200-SQL-SELECT THRU D200-EXIT.
IF SQLCODE = OK
PERFORM C350-DISPLAY-DELETE THRU C350-EXIT
ELSE
IF SQLCODE = NOTFOUND
DISPLAY " "
DISPLAY "Row not found!"
ELSE
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT.
PERFORM A400-COMMIT-WORK THRU A400-EXIT.
C300-EXIT.
EXIT.
C350-DISPLAY-DELETE.
PERFORM D100-DISPLAY-ROW THRU D100-EXIT.
MOVE "Is it OK to DELETE this row (N/Y) ? > "
TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT RESPONSE.
IF RESPONSE-PREFIX = "Y"
OR RESPONSE-PREFIX = "y"
DISPLAY "DELETE row from ManufDB.TestData"
EXEC SQL
DELETE FROM MANUFDB.TESTDATA
WHERE BATCHSTAMP = TO_DATETIME
(:BATCHSTAMP, :BATCHSTAMP-FORMAT)
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT.
C350-EXIT.
EXIT.
C400-INSERT-DATA.
MOVE "Enter BatchStamp or 0 for MENU> " TO PROMPT-USER.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT RESPONSE.
IF RESPONSE-PREFIX = ZERO AND RESPONSE-SUFFIX = SPACES
MOVE "X" TO FUNC-DONE-FLAG
GO TO C400-EXIT
ELSE
MOVE RESPONSE TO BATCHSTAMP.
MOVE "Enter TestDate (0 for null)> " TO PROMPT-USER.
MOVE SPACES TO TESTDATE.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT TESTDATE.
IF TESTDATE = 0
MOVE -1 TO TESTDATEIND
ELSE
MOVE 0 TO TESTDATEIND.
MOVE "Enter TestStart (0 for null)> " TO PROMPT-USER.
MOVE SPACES TO TESTSTART.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT TESTSTART.
IF TESTSTART = 0
MOVE -1 TO TESTSTARTIND
ELSE
MOVE 0 TO TESTSTARTIND.
MOVE "Enter TestEnd (0 for null)> " TO PROMPT-USER.
MOVE SPACES TO TESTEND.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT TESTEND.
IF TESTEND = 0
MOVE -1 TO TESTENDIND
ELSE
MOVE 0 TO TESTENDIND.
MOVE "Enter LabTime> " TO PROMPT-USER.
MOVE SPACES TO LABTIME.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT LABTIME.
IF LABTIME = 0
MOVE -1 TO LABTIMEIND
ELSE
MOVE 0 TO LABTIMEIND.
MOVE "Enter PassQuantity> " TO PROMPT-USER.
MOVE ZERO TO PASSQTY.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT PASSQTY.
IF PASSQTY = 0
MOVE -1 TO PASSQTYIND
ELSE
MOVE 0 TO PASSQTYIND.
MOVE "Enter TestQuantity> " TO PROMPT-USER.
MOVE ZERO TO TESTQTY.
DISPLAY " ".
WRITE PROMPT-USER.
ACCEPT TESTQTY.
IF TESTQTY = 0
MOVE -1 TO TESTQTYIND
ELSE
MOVE 0 TO TESTQTYIND.
PERFORM A300-BEGIN-TRANSACTION THRU A300-EXIT.
DISPLAY "INSERT row into ManufDB.TestData".
EXEC SQL INSERT
INTO MANUFDB.TESTDATA
(BATCHSTAMP,
TESTDATE,
TESTSTART,
TESTEND,
LABTIME,
PASSQTY,
TESTQTY)
VALUES (TO_DATETIME (:BATCHSTAMP, :BATCHSTAMP-FORMAT),
TO_DATE (:TESTDATE :TESTDATEIND,
:TESTDATE-FORMAT),
:TESTSTART :TESTSTARTIND,
:TESTEND :TESTENDIND,
:LABTIME :LABTIMEIND,
:PASSQTY :PASSQTYIND,
:TESTQTY :TESTQTYIND)
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT.
PERFORM A400-COMMIT-WORK THRU A400-EXIT.
C400-EXIT.
EXIT.
D100-DISPLAY-ROW.
DISPLAY " ".
DISPLAY " BatchStamp: " BATCHSTAMP.
IF TESTDATEIND < 0
DISPLAY " TestDate is NULL."
ELSE
DISPLAY " TestDate: " TESTDATE.
IF TESTSTARTIND < 0
DISPLAY " TestStart is NULL."
ELSE
DISPLAY " TestStart: " TESTSTART.
IF TESTENDIND < 0
DISPLAY " TestEnd is NULL."
ELSE
DISPLAY " TestEnd: " TESTEND.
IF LABTIMEIND < 0
DISPLAY " LabTime is NULL."
ELSE
DISPLAY " LabTime: " LABTIME.
IF PASSQTYIND < 0
DISPLAY " PassQuantity is NULL."
ELSE
MOVE PASSQTY TO NUMFORMAT
DISPLAY " PassQuantity: " NUMFORMAT.
IF TESTQTYIND < 0
DISPLAY " TestQuantity is NULL."
ELSE
MOVE TESTQTY TO NUMFORMAT
DISPLAY " TestQuantity: " NUMFORMAT.
D100-EXIT.
EXIT.
D200-SQL-SELECT.
DISPLAY "SELECT * FROM ManufDB.TestData".
EXEC SQL SELECT TO_CHAR
(BATCHSTAMP, :BATCHSTAMP-FORMAT),
TO_CHAR
(TESTDATE, :TESTDATE-FORMAT),
TESTSTART,
TESTEND,
LABTIME,
PASSQTY,
TESTQTY
INTO :BATCHSTAMP,
:TESTDATE :TESTDATEIND,
:TESTSTART :TESTSTARTIND,
:TESTEND :TESTENDIND,
:LABTIME :LABTIMEIND,
:PASSQTY :PASSQTYIND,
:TESTQTY :TESTQTYIND
FROM MANUFDB.TESTDATA
WHERE BATCHSTAMP = TO_DATETIME
(:BATCHSTAMP, :BATCHSTAMP-FORMAT)
END-EXEC.
D200-EXIT.
EXIT.
S100-SQL-STATUS-CHECK.
MOVE SPACE TO ABORT-FLAG.
IF SQLCODE <= DEADLOCK
MOVE "X" TO ABORT-FLAG.
IF SQLCODE = NOMEMORY
MOVE "X" TO ABORT-FLAG.
PERFORM S200-SQLEXPLAIN UNTIL SQLCODE = 0.
IF ABORT
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
S100-EXIT.
EXIT.
S200-SQLEXPLAIN.
EXEC SQL
SQLEXPLAIN :SQLMESSAGE
END-EXEC.
DISPLAY SQLMESSAGE.
S200-EXIT.
EXIT.
|
Example Program Converting a Column from CHAR to DATE Data Type | |
The next data conversion program is intended as a guide
should you decide
to convert any character (CHAR) columns in an existing table to a date/time
data type.
Before running this program, you must create a new table,
PurchDB.NewOrders, in PartsDBE. This table is similar to the PurchDB.Orders
table already existing in PartsDBE, except that the OrderDate column
is of the DATE data type.
(Reference the , appendix C.)
You can create the table by issuing the
following command from ISQL:
CREATE PUBLIC TABLE PurchDB.NewOrders(
OrderNumber INTEGER NOT NULL,
VendorNumber INTEGER,
OrderDate DATE)
IN OrderFS;
|
Example Program to Convert from CHAR to Default Data TypeFigure 13-2 Converting Date from CHAR to Default Type
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* This program uses BULK FETCH and BULK INSERT commands to select all *
* rows from the Orders table (part of the sample DBEnvironment, *
* PartsDBE), convert the order date column from the CHAR data type to *
* the DATE data type default format, and write all Orders table *
* information to another table called NewOrders table (created *
* previously by you as described in this chapter). *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
IDENTIFICATION DIVISION.
PROGRAM-ID. COBEX9A.
AUTHOR. JOANN GRAY
INSTALLATION. HP.
DATE-WRITTEN. 31 OCT 1990.
DATE-COMPILED. 31 OCT 1990.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. HP-9000.
OBJECT-COMPUTER. HP-9000.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
EXEC SQL INCLUDE SQLCA END-EXEC.
* * * * * * BEGIN HOST VARIABLE DECLARATIONS * * * * * * *
EXEC SQL BEGIN DECLARE SECTION END-EXEC.
01 ORDERS.
05 EACH-ROW OCCURS 25 TIMES.
10 ORDERNUMBER PIC S9(9) COMP.
10 VENDORNUMBER PIC S9(9) COMP.
10 VENDORNUMBERIND SQLIND.
10 ORDERDATE PIC X(8).
10 ORDERDATEIND SQLIND.
01 STARTINDEX PIC S9(4) COMP.
01 NUMBEROFROWS PIC S9(4) COMP.
01 NEW-ORDERS.
05 EACH-ROW OCCURS 25 TIMES.
10 NEW-ORDERNUMBER PIC S9(9) COMP.
10 NEW-VENDORNUMBER PIC S9(9) COMP.
10 NEW-VENDORNUMBERIND SQLIND.
10 NEW-ORDERDATE PIC X(10).
10 NEW-ORDERDATEIND SQLIND.
01 SQLMESSAGE PIC X(132).
EXEC SQL END DECLARE SECTION END-EXEC.
* * * * * * END OF HOST VARIABLE DECLARATIONS * * * * * * *
77 DONE-CONVERT PIC X VALUE SPACE.
88 NOT-DONE VALUE SPACE.
88 DONE VALUE 'X'.
77 ORDERS-OK PIC X VALUE SPACE.
88 NOT-OK VALUE SPACE.
88 OK-ORDERS VALUE 'X'.
77 ABORT-FLAG PIC X VALUE SPACE.
88 NOT-ABORT VALUE SPACE.
88 ABORT VALUE 'X'.
77 CONNECT-FLAG PIC X VALUE SPACE.
88 NOT-CONNECT VALUE SPACE.
88 CONNECT VALUE 'X'.
01 DATE-TRANSFER PIC X(8).
01 DATE-TRANSFER-FROM REDEFINES DATE-TRANSFER.
10 YEAR PIC X(4).
10 MONTH PIC X(2).
10 DAY-FROM PIC X(2).
01 DATE-TRANSFER-TO.
10 YEAR-TO PIC X(4).
10 DASH PIC X VALUE '-'.
10 MONTH-TO PIC X(2).
10 DASH2 PIC X VALUE '-'.
10 DAY-TO PIC X(2).
01 COUNTER1 PIC S9(9) COMP VALUE 0.
01 I PIC S9(9) COMP VALUE 0.
01 OK PIC S9(9) COMP VALUE 0.
01 NOTFOUND PIC S9(9) COMP VALUE 100.
01 DEADLOCK PIC S9(9) COMP VALUE -14024.
01 NOMEMORY PIC S9(9) COMP VALUE -4008.
PROCEDURE DIVISION.
A100-MAIN.
***********************************************************************
* The cursor for the BULK FETCH is declared in a function that is *
* never executed at run time. The section for this cursor is created *
* and stored in the program module at preprocess time. *
***********************************************************************
EXEC SQL DECLARE OrdersCursor
CURSOR FOR
SELECT *
FROM PURCHDB.ORDERS
END-EXEC.
DISPLAY "Program to convert date from CHAR to DATE data type.
- "".
DISPLAY " ".
DISPLAY "Event List:".
DISPLAY " Connect to PartsDBE.".
DISPLAY " BULK FETCH all rows from OrdersTable.".
DISPLAY " Convert the date.".
DISPLAY " BULK INSERT all fetched rows into NewOrders Table".
DISPLAY " with converted date.".
DISPLAY " Release PartsDBE".
DISPLAY " ".
PERFORM A200-CONNECT-DBENVIRONMENT THRU A200-EXIT.
MOVE SPACE TO DONE-CONVERT.
MOVE "X" TO ORDERS-OK.
PERFORM A300-BEGIN-TRANSACTION THRU A300-EXIT.
EXEC SQL OPEN ORDERSCURSOR KEEP CURSOR WITH LOCKS END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT
PERFORM A450-ROLLBACK-WORK THRU A450-EXIT
MOVE SPACE TO ORDERS-OK
MOVE "X" TO DONE-CONVERT.
PERFORM B100-FETCH-OLD THRU B100-EXIT UNTIL DONE.
***********************************************************************
* DoneConvert is TRUE when all data has been converted and inserted *
* or when an error condition not serious enough for ALLBASE/SQL to *
* rollback work was encountered. *
***********************************************************************
***********************************************************************
* If there were no errors in processing, data is committed to the *
* database. Else, if there were ALLBASE/SQL errors, rollback the *
* transaction before releasing the database environment. *
***********************************************************************
IF OK-ORDERS
PERFORM A400-COMMIT-WORK THRU A400-EXIT
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT
ELSE
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
A100-EXIT.
EXIT.
A200-CONNECT-DBENVIRONMENT.
***********************************************************************
* Subroutine to connect to the sample database environment, PartsDBE. *
***********************************************************************
DISPLAY "Connect to PartsDBE".
EXEC SQL
CONNECT TO '../sampledb/PartsDBE'
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
A200-EXIT.
EXIT.
A300-BEGIN-TRANSACTION.
***********************************************************************
* Subroutine to begin the transaction with cursor stability specified.*
***********************************************************************
EXEC SQL
BEGIN WORK CS
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
A300-EXIT.
EXIT.
A400-COMMIT-WORK.
***********************************************************************
* Subroutine to commit work to the database OR save the cursor *
* position. *
***********************************************************************
DISPLAY "Commit Work".
EXEC SQL
COMMIT WORK
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT.
A400-EXIT.
EXIT.
A450-ROLLBACK-WORK.
***********************************************************************
* Subroutine to rollback the transaction. *
***********************************************************************
DISPLAY "Rollback Work".
EXEC SQL
ROLLBACK WORK
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT.
A450-EXIT.
EXIT.
A500-TERMINATE-PROGRAM.
***********************************************************************
* Subroutine to release PartsDBE. *
***********************************************************************
EXEC SQL
RELEASE
END-EXEC.
STOP RUN.
A500-EXIT.
EXIT.
***********************************************************************
* Subroutine to BULK FETCH Orders table data 25 rows at a time into *
* an array. *
***********************************************************************
B100-FETCH-OLD.
MOVE 25 TO NUMBEROFROWS.
MOVE 1 TO STARTINDEX.
DISPLAY 'BULK FETCH PurchDB.Orders'.
EXEC SQL BULK FETCH ORDERSCURSOR
INTO :ORDERS, :STARTINDEX, :NUMBEROFROWS
END-EXEC.
* Set COUNTER1 to the number of rows fetched. *
MOVE SQLERRD(3) TO COUNTER1.
IF SQLCODE = OK
PERFORM A400-COMMIT-WORK THRU A400-EXIT
ELSE
IF SQLCODE = NOTFOUND
DISPLAY 'There are no Orders Table rows to FETCH.'
MOVE "X" TO DONE-CONVERT
ELSE
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT
PERFORM A450-ROLLBACK-WORK THRU A450-EXIT
MOVE SPACE TO ORDERS-OK
MOVE "X" TO DONE-CONVERT.
IF NOT-DONE
PERFORM B200-TRANSFER-DATA THRU B200-EXIT.
IF NOT-DONE
PERFORM B300-INSERT-NEW THRU B300-EXIT.
B100-EXIT.
EXIT.
B200-TRANSFER-DATA.
***********************************************************************
* Subroutine to convert OrderDate form CHAR to DATE data type and *
* transfer data to an array in preparation for BULK INSERT into a new *
* table. *
***********************************************************************
MOVE COUNTER1 TO NUMBEROFROWS.
PERFORM C200 THRU C200-EXIT
VARYING I FROM 1 BY 1 UNTIL I > NUMBEROFROWS.
PERFORM C205 THRU C205-EXIT
VARYING I FROM 1 BY 1 UNTIL I > NUMBEROFROWS.
B200-EXIT.
EXIT.
C200.
MOVE ORDERNUMBER(I) TO NEW-ORDERNUMBER(I).
MOVE VENDORNUMBER(I) TO NEW-VENDORNUMBER(I).
C200-EXIT.
EXIT.
C205.
* Here the old orderdate column data is moved to a data item *
* to break it into the component parts of the default DATE format.*
MOVE ORDERDATE(I) TO DATE-TRANSFER.
MOVE YEAR TO YEAR-TO.
MOVE MONTH TO MONTH-TO.
MOVE DAY-FROM TO DAY-TO.
MOVE DATE-TRANSFER-TO TO NEW-ORDERDATE(I).
C205-EXIT.
EXIT.
B300-INSERT-NEW.
***********************************************************************
* Subroutine to BULK INSERT into PURCHDB.NewOrders table. *
***********************************************************************
MOVE COUNTER1 TO NUMBEROFROWS.
MOVE 1 TO STARTINDEX.
DISPLAY 'BULK INSERT INTO PurchDB.NewOrders'.
EXEC SQL BULK INSERT INTO PURCHDB.NEWORDERS
VALUES (:NEW-ORDERS,
:STARTINDEX,
:NUMBEROFROWS)
END-EXEC.
IF SQLCODE NOT = OK
PERFORM S100-SQL-STATUS-CHECK THRU S100-EXIT
PERFORM A450-ROLLBACK-WORK THRU A450-EXIT
MOVE SPACE TO ORDERS-OK
MOVE "X" TO DONE-CONVERT.
B300-EXIT.
EXIT.
S100-SQL-STATUS-CHECK.
***********************************************************************
* Subroutine to display error messages and terminate the program when *
* the transaction has been rolled back by ALLBASE/SQL. *
***********************************************************************
MOVE SPACE TO ABORT-FLAG.
IF SQLCODE <= DEADLOCK
MOVE 'X' TO ABORT-FLAG.
IF SQLCODE = NOMEMORY
MOVE 'X' TO ABORT-FLAG.
PERFORM S200-SQLEXPLAIN
UNTIL SQLCODE = 0.
* The abort flag is set if the transaction was rolled back by *
* ALLBASE/SQL. *
IF ABORT
PERFORM A500-TERMINATE-PROGRAM THRU A500-EXIT.
S100-EXIT.
EXIT.
S200-SQLEXPLAIN.
EXEC SQL
SQLEXPLAIN :SQLMESSAGE
END-EXEC.
DISPLAY SQLMESSAGE.
S200-EXIT.
EXIT.
|
|
