[USflag] The American Programmer [USflag]


Home
Books on Mainframe Programming
Mainframe Manuals and Tutorials
System Abend codes, Sqlcodes, VSAM/QSAM codes
Everything about the IBM AS/400 Midrange Computer - iSeries
Everything about CICS
Everything about COBOL
Everything about DB2 and SQL
Everything about IMS
  Books on IMS
  Manuals on IMS - Hierarchical Database Management System
  IMS/DLI and other type Abend Codes
  IMS/DLI skeleton COBOL Example program
  IMS/DLI DBD PSB Example
  IMS/DLI COBOL Example program to delete segments
  IMS/DLI COBOL program delete all root segments
  IMS/DLI COBOL Example program to insert segments
  IMS/DLI COBOL Example program to update segments
Everything about Java and JavaScript
Everything about JCL and JES
Everything about REXX
Everything about zOS, VSAM, Tivoli, Assembler
Everything about TSO, ISPF, Spufi
Site Map and Site Search

           Home   > IMS   > IMS program in COBOL that deletes a root segment

COBOL/IMS/DLI PROGRAM TO DELETE A ROOT SEGMENT

This illustrates how to GET HOLD (GHU) a specific segment in an IMS database, check the status code, and delete (DLET) that segment (and all dependent segments under it).
Illustrates status code checking.
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. 'DLET'.
000300*--------------------------------------------------------*
000400* COBOL/IMS/DLI PROGRAM TO DELETE THE ROOT SEGMENT 9678
000600* THEN DOES A ROLLBACK                               *
000700 ENVIRONMENT DIVISION.
000800 INPUT-OUTPUT SECTION.
000900 FILE-CONTROL.
001100 DATA DIVISION.
001200 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
008500
008600 01  W200-FUNCTION.
008700     03  GN-FUNC          PIC X(4) VALUE 'GN'.
008800     03  GU-FUNC          PIC X(4) VALUE 'GU'.
008900     03  GHU-FUNC         PIC X(4) VALUE 'GHU'.
009000     03  GHN-FUNC         PIC X(4) VALUE 'GHN'.
009100     03  GNP-FUNC         PIC X(4) VALUE 'GNP'.
009200     03  DLET-FUNC        PIC X(4) VALUE 'DLET'.
009300     03  ROLB-FUNC        PIC X(4) VALUE 'ROLB'.
009400     03  ISRT-FUNC        PIC X(4) VALUE 'ISRT'.
009500     03  REPL-FUNC        PIC X(4) VALUE 'REPL'.
010190
010200 01  SSA-ROOT-QUAL.
010210     05  FILLER PIC X(8) VALUE 'TSROOT'.
010211     05  FILLER PIC X    VALUE '('.
010212     05  FILLER PIC X(8) VALUE 'TSRSTAFF'.
010213     05  FILLER PIC X(2) VALUE '= '.
010214     05  SSA-ROOT-VALUE  PIC X(4) VALUE '0000'.
010215     05  FILLER PIC X    VALUE ')'.
010216
010217 01  SSA-ROOT-UNQUAL.
010218     05  FILLER PIC X(8) VALUE 'TSROOT'.
010219     05  FILLER PIC X    VALUE ' '.
010220
010221 01  SSA-ADDR-QUAL.
010222     05  FILLER PIC X(8) VALUE 'TSADDR'.
010223     05  FILLER PIC X    VALUE '('.
010224     05  FILLER PIC X(8) VALUE 'TSAKEY'.
010225     05  FILLER PIC X(2) VALUE '= '.
010226     05  SSA-ADDR-VALUE  PIC 9(3) PACKED-DECIMAL VALUE 0.
010227     05  FILLER PIC X    VALUE ')'.
010228
010229 01  SSA-ADDR-UNQUAL.
010230     05  FILLER PIC X(8) VALUE 'TSADDR'.
010231     05  FILLER PIC X    VALUE ' '.
010232
010233 01  SSA-HOBBY-UNQUAL.
010234     05  FILLER PIC X(8) VALUE 'TSHOBBY'.
010235     05  FILLER PIC X    VALUE ' '.
010236* Indludes are not shown
010240 COPY TSROOT.
010300 COPY TSADDR.
010400 COPY TSHOBBY.
010500 01 W2-LINECOUNT          PIC 99   VALUE 99.
010600 01 TIME-TO-STOP          PIC X    VALUE 'N'.
010700 01 W3-LASTSEG            PIC X(8) VALUE SPACES.
010800 01 BIG-IO-AREA           PIC X(120).
010900
011000 LINKAGE SECTION.
011100 01 IO-PCBMASK.
011200     03 LTERM             PIC X(08).
011300     03 FILLER            PIC XX.
011310     03 IO-STATUS-CODE    PIC XX.
011320     03 THE-DATE          PIC S9(7) COMP-3.
011330     03 THE-TIME          PIC S9(7) COMP-3.
011340     03 THE-SEQUENCE      PIC S9(7) COMP-3.
011350     03 MODNAME           PIC X(08).
011360     03 USERID            PIC X(08).
011400
011500 01 DB-PCBMASK.
011600     03 DBD-NAME          PIC X(08).
011700     03 SEG-LEVEL         PIC X(02).
011800     03 DB-STATUS-CODE    PIC X(02).
011900     03 PROC-OPTIONS      PIC X(04).
011910     03 RESERVED          PIC S9(05) BINARY.
011920     03 SEG-NAME-FB       PIC X(08).
011930     03 LENGTH-KEY-FB     PIC S9(05) BINARY.
011940     03 NUM-SENS-SEGS     PIC S9(05) BINARY.
011950*    NOTE LENGTH OF KEY FB AREA DEPENDS ON DBD
011960     03 KEY-FB-AREA       PIC X(06).
012000
012100 PROCEDURE DIVISION USING IO-PCBMASK
012200                          DB-PCBMASK.
012300
012400     DISPLAY 'STARTING  DLET'.
012500
012561     MOVE  '9678' TO SSA-ROOT-VALUE
012570
012600     CALL 'CBLTDLI' USING
012700           GHU-FUNC
012800           DB-PCBMASK
012900           TSROOT
012910           SSA-ROOT-QUAL
012911
012912     PERFORM  CHECK-STATUS-CODE.
012913
012914     CALL 'CBLTDLI' USING
012915           DLET-FUNC
012916           DB-PCBMASK
012917           TSROOT
012970
012980     PERFORM  CHECK-STATUS-CODE.
012981
012990     CALL 'CBLTDLI' USING
012991          ROLB-FUNC
012992          IO-PCBMASK
012993
013000     GOBACK.
013100
016400
016500 CHECK-STATUS-CODE.
016600     EVALUATE DB-STATUS-CODE
016700     WHEN '  '
016800*       CONTINUE
016900        DISPLAY 'SUCCESS'
017000     WHEN  'GA'
017100        CONTINUE
017200*       DISPLAY 'SUCCESS (HIGHER LEVEL SEG TYPE)'
017300     WHEN 'GK'
017400        CONTINUE
017500*       DISPLAY 'SUCCESS (SAME LEVEL DIFF SEG TYPE)'
017600     WHEN 'GE'
017700        DISPLAY 'NOT FOUND'
017800        MOVE 'Y' TO TIME-TO-STOP
017900     WHEN 'GB'
018000        DISPLAY 'END OF DATA BASE'
018100        MOVE 'Y' TO TIME-TO-STOP
018200     WHEN OTHER
018300        DISPLAY 'STATUS CODE IS  '  DB-STATUS-CODE
018400        MOVE 'Y' TO TIME-TO-STOP
018500     END-EVALUATE.

Learn how to use all the features of IMS: IMS/DLI Programming Books

[Books Computer]

Home Books for Computer Professionals Privacy Terms |
Site Map and Site Search Programming Manuals and Tutorials The REXX Files Top of Page |