HP 3000 Manuals HP 3000 Manuals
COBOL Example Program
$CONTROL SOURCE,MAP,CROSSREF
***************************************************************
** **
** This COBOL program gives examples of calling System **
** Dictionary intrinsics. The examples in this program **
** include: **
** **
** OPEN-DICTIONARY Shows how to open a System Dictionary **
** **
** CLOSE-DICTIONARY Shows how to close a System Dictionary **
** **
** FIND-ELEMENTS Shows how to find relationships when **
** only one of the entities is known, **
** using the SDFindRelList intrinsic **
** **
** FIND-BY-NUMBER The same example as FIND-ELEMENTS, **
** but using internal numbers **
** **
** CREATE-ELEMENT Shows how to create an entity **
** occurrence using both internal and **
** external names **
** **
** LINK-ELEMENT Shows how to link a local domain **
** entity to a common domain entity **
** **
** REMOVE-REL-LINK Shows how to remove a link between **
** a local domain relationship and a **
** common domain relationship **
** **
***************************************************************
***************************************************************
** identification division **
***************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. COBOL-EXAMPLE.
***************************************************************
** environment division **
***************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. HP-3000.
OBJECT-COMPUTER. HP-3000.
***************************************************************
** data division **
***************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 DCB.
05 FILLER PIC S9(9) COMP OCCURS 30 TIMES.
01 RETRIEVAL-ID.
05 RETRIEVAL-INIT PIC S9(9) COMP.
05 FILLER PIC S9(9) COMP OCCURS 19 TIMES.
01 SD-STATUS.
05 COND-CODE PIC S9(9) COMP.
05 SUBSYS-NUMBER PIC S9(9) COMP.
05 SUBSYS-COND-CODE PIC S9(9) COMP.
05 INTRINSIC-NUMBER PIC S9(9) COMP.
05 STATUS-5 PIC S9(9) COMP.
05 STATUS-6 PIC S9(9) COMP.
05 STATUS-7 PIC S9(9) COMP.
01 DICTIONARY-PARAMETERS.
05 DICTIONARY-NAME PIC X(26).
05 SCOPE-NAME PIC X(32).
05 SCOPE-PASSWORD PIC X(32).
05 DOMAIN-NAME PIC X(32).
05 VERSION-NAME PIC X(32).
05 NAME-MODE PIC S9(9) COMP.
05 OPEN-MODE PIC S9(9) COMP.
05 VERSION-STATUS PIC S9(9) COMP.
01 SD-NAMES.
05 ENTITY-TYPE PIC X(32).
05 RELATIONSHIP-TYPE PIC X(32).
05 RELATIONSHIP-CLASS PIC X(32).
05 ENTITY-NAME PIC X(32).
05 RELATIONSHIP-NAME PIC X(32).
05 COMMON-ENTITY-NAME PIC X(32).
05 ATTRIBUTE-NAME PIC X(32).
05 OWNER-SCOPE-NAME PIC X(32).
01 NEW-ENTITY-NAME.
05 INTERNAL-ENTITY-NAME PIC X(32).
05 EXTERNAL-ENTITY-NAME PIC X(32).
01 SD-NAME-LISTS.
05 COMMON-ENTITY-LIST PIC X(2).
05 ENTITY-LIST.
10 ENTITY-LIST-NAME PIC X(32) OCCURS 3 TIMES.
05 ENTITY-SEARCH-LIST PIC X(18).
05 ATTRIBUTE-TYPE-LIST PIC X(31).
01 SD-NUMBER-LISTS.
05 ENTITY-TYPE-NBR-LIST.
10 ENTITY-TYPE-NBR PIC S9(9) COMP OCCURS 2 TIMES.
05 ENTITY-NBR-LIST.
10 ENTITY-NBR PIC S9(9) COMP OCCURS 2 TIMES.
05 ATTRIBUTE-TYPE-NBR-LIST.
10 ATTRIBUTE-TYPE-NBR PIC S9(9) COMP OCCURS 4 TIMES.
01 ATTRIBUTE-VALUES-LIST.
05 COUNT-VALUE PIC S9(9) COMP.
05 BYTE-LENGTH-VALUE PIC S9(9) COMP.
05 ELEMENT-TYPE-VALUE PIC X(2).
01 SD-DUMMY-PARAMETERS.
05 ATTRIBUTE-PARMS.
10 FILLER PIC S9(9) COMP OCCURS 2 TIMES.
05 ATTRIBUTE-VALUES.
10 FILLER PIC S9(9) COMP OCCURS 2 TIMES.
05 EDITS-LENGTH PIC S9(9) COMP.
05 ATTRIBUTE-EDITS PIC X(255).
***************************************************************
** procedure division **
***************************************************************
PROCEDURE DIVISION.
MAIN-PROGRAM.
PERFORM OPEN-DICTIONARY.
PERFORM FIND-ELEMENTS.
PERFORM FIND-BY-NUMBER.
PERFORM CREATE-ELEMENT.
PERFORM LINK-ENTITY.
PERFORM REMOVE-REL-LINK.
PERFORM CLOSE-DICTIONARY.
STOP RUN.
***************************************************************
** **
** procedure OPEN-DICTIONARY **
** **
** This procedure will open the System Dictionary **
** SYSDIC.PUB.SYS with the PROGRAMMER scope, for domain D, **
** and test version. The name mode is external (2), the **
** open mode is exclusive update (3), and the version **
** status is test (1). **
** **
***************************************************************
OPEN-DICTIONARY.
MOVE "SYSDIC.PUB.SYS" TO DICTIONARY-NAME.
MOVE "PROGRAMMER" TO SCOPE-NAME.
MOVE "SECRET" TO SCOPE-PASSWORD.
MOVE 3 TO OPEN-MODE.
MOVE 2 TO NAME-MODE.
MOVE "D" TO DOMAIN-NAME.
MOVE " " TO VERSION-NAME.
MOVE 1 TO VERSION-STATUS.
CALL INTRINSIC "SDOPEN" USING DICTIONARY-NAME,
SCOPE-NAME,
SCOPE-PASSWORD,
OPEN-MODE,
NAME-MODE,
DOMAIN-NAME,
VERSION-NAME,
VERSION-STATUS,
DCB,
SD-STATUS.
IF COND-CODE NOT EQUAL ZERO THEN
DISPLAY "System Dictionary Error #", COND-CODE.
***************************************************************
** **
** procedure CLOSE-DICTIONARY **
** **
** This procedure closes the System Dictionary. **
** **
***************************************************************
CLOSE-DICTIONARY.
CALL INTRINSIC "SDCLOSE" USING DCB,
SD-STATUS.
IF COND-CODE NOT EQUAL ZERO THEN
DISPLAY "System Dictionary Error #", COND-CODE.
***************************************************************
** **
** procedure FIND-ELEMENTS **
** **
** This procedure finds all elements related to the record **
** ACCOUNTS-RECORD. It sets up parameters, and performs **
** a procedure, FIND-AN-ELEMENT, which finds and retrieves **
** info on a single element until no more elements can be **
** found. **
** **
** FIND-AN-ELEMENT uses the intrinsic SDFindRelList to **
** search for an element. It then calls SDGetEnt to **
** retrieve the COUNT, ELEMENT-TYPE, and BYTE-LENGTH **
** attributes for the element. **
** **
***************************************************************
FIND-ELEMENTS.
DISPLAY " ".
DISPLAY "*** Elements related to ACCOUNTS-RECORD ***".
DISPLAY " ".
DISPLAY "Element Count Type Length".
DISPLAY " ".
MOVE "RECORD ELEMENT;" TO RELATIONSHIP-TYPE.
MOVE "CONTAINS" TO RELATIONSHIP-CLASS.
MOVE "ACCOUNTS-RECORD ?;" TO ENTITY-SEARCH-LIST.
MOVE ZERO TO RETRIEVAL-INIT.
MOVE "ELEMENT" TO ENTITY-TYPE.
MOVE "COUNT BYTE-LENGTH ELEMENT-TYPE;"
TO ATTRIBUTE-TYPE-LIST.
PERFORM FIND-AN-ELEMENT
UNTIL COND-CODE NOT EQUAL ZERO.
***************************************************************
** procedure FIND-AN-ELEMENT **
***************************************************************
FIND-AN-ELEMENT.
CALL INTRINSIC "SDFINDRELLIST" USING DCB,
RELATIONSHIP-TYPE,
RELATIONSHIP-CLASS,
ENTITY-SEARCH-LIST,
RETRIEVAL-ID,
ENTITY-LIST,
SD-STATUS.
IF COND-CODE EQUAL ZERO THEN
CALL INTRINSIC "SDGETENT" USING DCB,
ENTITY-TYPE,
ENTITY-LIST-NAME(2),
ATTRIBUTE-TYPE-LIST,
ATTRIBUTE-VALUES-LIST,
COMMON-ENTITY-NAME,
SD-STATUS
IF COND-CODE EQUAL ZERO THEN
DISPLAY ENTITY-LIST-NAME(2), COUNT-VALUE, " ",
ELEMENT-TYPE-VALUE, " ", BYTE-LENGTH-VALUE
ELSE
DISPLAY "System Dictionary Error #", COND-CODE.
***************************************************************
** **
** procedure FIND-BY-NUMBER **
** **
** This procedure finds all elements related to the **
** ACCOUNTS-RECORD record. It does this by calling the **
** intrinsic SDFindRelList. It is similar to the previous **
** example, FIND-ELEMENTS, except internal numbers are **
** used whenever possible. Internal numbers should never **
** be "hard-coded" into a program. **
** **
** The use of internal numbers will improve the performance **
** of System Dictionary intrinsic calls. **
** **
***************************************************************
FIND-BY-NUMBER.
DISPLAY " ".
DISPLAY "*** Elements related to ACCOUNTS-RECORD ***".
DISPLAY " ".
DISPLAY "Element Count Type Length".
DISPLAY " ".
MOVE "RECORD ELEMENT;" TO RELATIONSHIP-TYPE.
MOVE "CONTAINS" TO RELATIONSHIP-CLASS.
MOVE "ACCOUNTS-RECORD ?;" TO ENTITY-SEARCH-LIST.
MOVE ZERO TO RETRIEVAL-INIT.
MOVE "ELEMENT" TO ENTITY-TYPE.
CALL INTRINSIC "SDGETENTTYPE" USING DCB,
ENTITY-TYPE,
OWNER-SCOPE-NAME,
SD-STATUS.
MOVE 1 TO ENTITY-TYPE-NBR(1).
MOVE STATUS-5 TO ENTITY-TYPE-NBR(2).
MOVE 3 TO ATTRIBUTE-TYPE-NBR(1).
MOVE "COUNT" TO ATTRIBUTE-NAME.
CALL INTRINSIC "SDGETATTR" USING DCB,
ATTRIBUTE-NAME,
ATTRIBUTE-PARMS,
ATTRIBUTE-EDITS,
EDITS-LENGTH,
OWNER-SCOPE-NAME,
SD-STATUS.
MOVE STATUS-5 TO ATTRIBUTE-TYPE-NBR(2).
MOVE "BYTE-LENGTH" TO ATTRIBUTE-NAME.
CALL INTRINSIC "SDGETATTR" USING DCB,
ATTRIBUTE-NAME,
ATTRIBUTE-PARMS,
ATTRIBUTE-EDITS,
EDITS-LENGTH,
OWNER-SCOPE-NAME,
SD-STATUS.
MOVE STATUS-5 TO ATTRIBUTE-TYPE-NBR(3).
MOVE "ELEMENT-TYPE" TO ATTRIBUTE-NAME.
CALL INTRINSIC "SDGETATTR" USING DCB,
ATTRIBUTE-NAME,
ATTRIBUTE-PARMS,
ATTRIBUTE-EDITS,
EDITS-LENGTH,
OWNER-SCOPE-NAME,
SD-STATUS.
MOVE STATUS-5 TO ATTRIBUTE-TYPE-NBR(4).
PERFORM FIND-AN-ELEMENT-BY-NUMBER
UNTIL COND-CODE NOT EQUAL ZERO.
***************************************************************
** procedure FIND-AN-ELEMENT-BY-NUMBER **
***************************************************************
FIND-AN-ELEMENT-BY-NUMBER.
CALL INTRINSIC "SDFINDRELLIST" USING DCB,
RELATIONSHIP-TYPE,
RELATIONSHIP-CLASS,
ENTITY-SEARCH-LIST,
RETRIEVAL-ID,
ENTITY-LIST,
SD-STATUS.
IF COND-CODE EQUAL ZERO THEN
MOVE 1 TO ENTITY-NBR(1)
MOVE STATUS-6 TO ENTITY-NBR(2)
CALL INTRINSIC "SDGETENT" USING DCB,
ENTITY-TYPE-NBR-LIST,
ENTITY-NBR-LIST,
ATTRIBUTE-TYPE-NBR-LIST,
ATTRIBUTE-VALUES-LIST,
COMMON-ENTITY-NAME,
SD-STATUS
IF COND-CODE EQUAL ZERO THEN
DISPLAY ENTITY-LIST-NAME(2), COUNT-VALUE, " ",
ELEMENT-TYPE-VALUE, " ", BYTE-LENGTH-VALUE
ELSE
DISPLAY "System Dictionary Error #", COND-CODE.
***************************************************************
** **
** procedure CREATE-ELEMENT **
** **
** This procedure creates an entity occurrence by calling **
** the intrinsic SDCreateEnt. The entity being created **
** has both an internal and external name specified. **
** **
***************************************************************
CREATE-ELEMENT.
MOVE "ELEMENT" TO ENTITY-TYPE.
MOVE "DATE" TO INTERNAL-ENTITY-NAME.
MOVE "DELIVERY-DATE" TO EXTERNAL-ENTITY-NAME.
MOVE "COUNT BYTE-LENGTH ELEMENT-TYPE;"
TO ATTRIBUTE-TYPE-LIST.
MOVE 1 TO COUNT-VALUE.
MOVE 6 TO BYTE-LENGTH-VALUE.
MOVE "X " TO ELEMENT-TYPE-VALUE.
MOVE " " TO COMMON-ENTITY-NAME.
CALL INTRINSIC "SDCREATEENT" USING DCB,
ENTITY-TYPE,
NEW-ENTITY-NAME,
ATTRIBUTE-TYPE-LIST,
ATTRIBUTE-VALUES-LIST,
COMMON-ENTITY-NAME,
SD-STATUS.
IF COND-CODE NOT EQUAL ZERO THEN
DISPLAY "System Dictionary Error #", COND-CODE.
***************************************************************
** **
** procedure LINK-ENTITY **
** **
** This procedure links a local domain entity to a common **
** domain entity. The procedure call SDModifyEnt to link **
** the entities. Note that the existing attribute values **
** are removed, and the attribute values will now be **
** retrieved from the common entity. **
** **
***************************************************************
LINK-ENTITY.
MOVE "ELEMENT" TO ENTITY-TYPE.
MOVE "P-NUM" TO ENTITY-NAME.
MOVE " " TO NEW-ENTITY-NAME.
MOVE ";" TO ATTRIBUTE-TYPE-LIST.
MOVE "PART-NUMBER" TO COMMON-ENTITY-NAME.
CALL INTRINSIC "SDMODIFYENT" USING DCB,
ENTITY-TYPE,
ENTITY-NAME,
NEW-ENTITY-NAME,
ATTRIBUTE-TYPE-LIST,
ATTRIBUTE-VALUES-LIST,
COMMON-ENTITY-NAME,
SD-STATUS.
IF COND-CODE NOT EQUAL ZERO THEN
DISPLAY "System Dictionary Error #", COND-CODE.
***************************************************************
** **
** procedure REMOVE-REL-LINK **
** **
** This procedure removes the link between a relationship **
** in a local domain and a relationship in the common **
** domain. The procedure calls SDModifyRel to remove the **
** link; the parameter COMMON-ENTITY-LIST is set to '/;' **
** to instruct SDModifyRel to remove the link. If a user **
** does not want to remove the link, then the parameter **
** COMMON-ENTITY-LIST should be set to "; ". **
** **
***************************************************************
REMOVE-REL-LINK.
MOVE "RECORD ELEMENT;" TO RELATIONSHIP-TYPE.
MOVE "CONTAINS" TO RELATIONSHIP-CLASS.
MOVE "ACCOUNTS-RECORD ACCOUNT-NUMBER;" TO ENTITY-LIST.
MOVE ";" TO ATTRIBUTE-TYPE-LIST.
MOVE "/;" TO COMMON-ENTITY-LIST.
CALL INTRINSIC "SDMODIFYREL" USING DCB,
RELATIONSHIP-TYPE,
RELATIONSHIP-CLASS,
ENTITY-LIST,
ATTRIBUTE-TYPE-LIST,
ATTRIBUTE-VALUES,
COMMON-ENTITY-LIST,
SD-STATUS.
IF COND-CODE NOT EQUAL ZERO THEN
DISPLAY "System Dictionary Error #", COND-CODE.