Adabas ダイレクトコールを使用する VAX-11 COBOL の例です。付録 B で定義された Adabas ファイルが使用されています。
IDENTIFICATION DIVISION.
PROGRAM-ID. EXAMPLE.
********************************************************* * * * A D A B A S / V M S COBOL example program * * ------------------------------------------- * * * * Compile, link and run this program by typing: * * * * $ COBOL EXAMPLE * * $ LINK EXAMPLE * * $ RUN EXAMPLE * * * * Function: * * * * Find in the default database all people * * named 'SMITH' and increase their salary * * by 10% * * * *********************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION. SOURCE-COMPUTER. VAX-11. OBJECT-COMPUTER. VAX-11.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 EXAMPLE-DB COMP PIC 9(4) VALUE 0. 01 EXAMPLE-DB-X REDEFINES EXAMPLE-DB PIC X(1).
01 EMPLOYEES-FILE COMP PIC 9(4) VALUE 11. 01 EMPLOYEES-FILE-X REDEFINES EMPLOYEES-FILE PIC X(1).
77 QUANTITY PIC Z(4)9. 77 OLD-SALARY DISPLAY PIC Z(9)9. 77 NEW-SALARY DISPLAY PIC Z(9)9. 77 UPD_COUNT COMP PIC 9(5) VALUE ZERO.
* Control Block
vms 01 CB.
02 FILLER PIC X(2).
02 COMMAND-CODE PIC X(2).
02 COMMAND-ID PIC X(4).
02 FILE-NUMBER PIC X(1).
02 DB-ID PIC X(1).
02 RESPONSE-CODE COMP PIC 9(3).
02 ISN COMP PIC 9(8).
02 ISN-LL COMP PIC 9(9).
02 ISN-QUANTITY COMP PIC 9(9) VALUE ZERO.
02 FMT-BUF-LNG COMP PIC 9(4).
02 REC-BUF-LNG COMP PIC 9(4).
02 SEA-BUF-LNG COMP PIC 9(4).
02 VAL-BUF-LNG COMP PIC 9(4).
02 ISN-BUF-LNG COMP PIC 9(4).
02 CMD-OPT-1 PIC X(1).
02 CMD-OPT-2 PIC X(1).
02 ADDITIONS-1 PIC X(8).
02 ADDITIONS-2 PIC X(4).
02 ADDITIONS-3 PIC X(8).
02 ADDITIONS-4 PIC X(8).
02 ADDITIONS-5 PIC A(8).
02 COMMAND-TIME COMP PIC 9(9).
02 USER-AREA PIC X(4).
* Format Buffer
77 FB PIC A(8) VALUE "ASN,4,F.". 77 L-FB COMP PIC 9(4) VALUE 7 .
* Record Buffer
01 RB.
02 OP PIC A(7) VALUE "UPD=11.".
02 SALARY REDEFINES OP COMP PIC 9(7).
77 L-RB-OP COMP PIC 9(4) VALUE 7 . 77 L-RB COMP PIC 9(4) VALUE 4 .
* Search Buffer
77 SB PIC X(5) VALUE "AE,5.". 77 L-SB COMP PIC 9(4) VALUE 5.
* Value Buffer
77 VB PIC A(5) VALUE "SMITH". 77 L-VB COMP PIC 9(4) VALUE 5.
* ISN Buffer
77 IB PIC 9(9). 77 L-IB COMP PIC 9(4) VALUE 4.
PROCEDURE DIVISION.
MAIN-PROGRAM SECTION.
EXAMPLE-START.
DISPLAY "COBOL example program for calling ADABAS (OpenVMS)".
PERFORM OPEN-DATABASE.
IF RESPONSE-CODE NOT EQUAL ZERO
PERFORM RESPONSE
ELSE
PERFORM FIND-RECORD
IF RESPONSE-CODE EQUAL ZERO
MOVE ISN-QUANTITY TO QUANTITY
DISPLAY "Found : ", QUANTITY, " records"
PERFORM INCREASE-SALARY UNTIL ISN-QUANTITY EQUAL ZERO
END-IF
IF RESPONSE-CODE NOT EQUAL ZERO
PERFORM RESPONSE
MOVE ZERO TO RESPONSE-CODE
IF UPD-COUNT NOT EQUAL TO ZERO
PERFORM ISSUE-BT
IF RESPONSE-CODE EQUAL ZERO
MOVE ZERO TO UPD-COUNT
ELSE
PERFORM RESPONSE
END-IF
END-IF
END-IF
IF RESPONSE-CODE EQUAL ZERO
PERFORM CLOSE-DATABASE
IF RESPONSE-CODE NOT EQUAL ZERO
PERFORM RESPONSE.
STOP RUN.
SUBROUTINES SECTION.
INCREASE-SALARY.
MOVE SALARY TO OLD-SALARY.
COMPUTE SALARY = SALARY + SALARY / 10.
MOVE "A1" TO COMMAND-CODE.
CALL "ADABAS" USING CB, FB, RB.
IF RESPONSE-CODE NOT EQUAL ZERO
MOVE ZERO TO ISN-QUANTITY
ELSE
MOVE SALARY TO NEW-SALARY
DISPLAY " ISN =", ISN WITH CONVERSION,
" old salary = ", OLD-SALARY,
" new salary = ", NEW-SALARY
ADD 1 TO UPD_COUNT
PERFORM FIND-RECORD
IF RESPONSE-CODE NOT EQUAL ZERO
MOVE ZERO TO ISN-QUANTITY
IF RESPONSE-CODE EQUAL 3
MOVE ZERO TO RESPONSE-CODE.
FIND-RECORD.
MOVE "L4" TO COMMAND-CODE.
IF ISN-QUANTITY EQUAL ZERO
MOVE "S4" TO COMMAND-CODE
MOVE EMPLOYEES-FILE-X TO FILE-NUMBER
MOVE "FIND" TO COMMAND-ID
MOVE L-FB TO FMT-BUF-LNG
MOVE L-RB TO REC-BUF-LNG
MOVE L-SB TO SEA-BUF-LNG
MOVE L-VB TO VAL-BUF-LNG
MOVE L-IB TO ISN-BUF-LNG
MOVE "N" TO CMD-OPT-2.
CALL "ADABAS" USING CB, FB, RB, SB, VB, IB.
OPEN-DATABASE.
MOVE EXAMPLE-DB-X TO DB-ID.
MOVE "OP" TO COMMAND-CODE.
MOVE L-RB-OP TO REC-BUF-LNG.
PERFORM OPEN-DATABASE-9 TEST AFTER
UNTIL RESPONSE-CODE NOT EQUAL 9.
OPEN-DATABASE-9.
CALL "ADABAS" USING CB, FB, RB.
CLOSE-DATABASE.
MOVE "CL" TO COMMAND-CODE.
CALL "ADABAS" USING CB.
ISSUE-BT.
MOVE "BT" TO COMMAND-CODE.
CALL "ADABAS" USING CB.
RESPONSE.
DISPLAY "** Response code ", RESPONSE-CODE WITH CONVERSION
" from ADABAS for command ", COMMAND-CODE.