[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 all root segments

COBOL/IMS/DLI PROGRAM TO DELETE ALL ROOT SEGMENTs

This illustrates how to GET HOLD NEXT (GHN) repeatedly in an IMS database, until the end of the 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. 'DLETALL'.
000300*--------------------------------------------------------*
000400* COBOL/IMS/DLI PROGRAM TO DELETE ALL ROOT SEGMENTS
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.
001700 01  PRINT-LINE-ROOT.
001800     03  FILLER PIC X(10) VALUE 'TSROOT'.
001900     03  PLR-TSRSTAFF     PIC 9(4).
002000     03  FILLER PIC X(02) VALUE SPACES.
002100     03  PLR-TSRSNAME     PIC X(30).
002200     03  FILLER PIC X(02) VALUE SPACES.
002300     03  PLR-TSRCNAME     PIC X(40).
002400     03  FILLER PIC X(02) VALUE SPACES.
002500     03  PLR-TSRDOB       PIC X(6).
002600     03  FILLER PIC X(02) VALUE SPACES.
002700     03  PLR-TSRDEPT      PIC X(20).
002800     03  FILLER PIC X(02) VALUE SPACES.
002900     03  PLR-TSRSEX       PIC X.
003000     03  FILLER PIC X(02) VALUE SPACES.
003100     03  PLR-TSRMARRY     PIC X.
003200
003300 01  PRINT-LINE-ADDR.
003400     03  FILLER PIC X(10) VALUE 'TSADDR'.
003500     03 PLA-TSAKEY     PIC  9(3).
003600     03  FILLER PIC X(02) VALUE SPACES.
003700     03 PLA-TSAADDR1   PIC X(30).
003800     03  FILLER PIC X(02) VALUE SPACES.
003900     03 PLA-TSAADDR2   PIC X(30).
004000     03  FILLER PIC X(02) VALUE SPACES.
004100     03 PLA-TSAADDR3   PIC X(30).
004200     03  FILLER PIC X(02) VALUE SPACES.
004300     03 PLA-TSAPCODE   PIC X(05).
004400
004500 01  PRINT-LINE-HOBBY.
004600     03  FILLER PIC X(10) VALUE 'TSHOBBY'.
004700     03  PLH-TSHKEY      PIC  9(3).
004800     03  FILLER PIC X(02) VALUE SPACES.
004900     03  PLH-TSHOBBY1    PIC X(15).
005000     03  FILLER PIC X(02) VALUE SPACES.
005100     03  PLH-TSHOBBY2    PIC X(15).
005200     03  FILLER PIC X(02) VALUE SPACES.
005300     03  PLH-TSHOBBY3    PIC X(15).
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'.
010200* includes are not shown
010300 COPY TSROOT.
010400 COPY TSADDR.
010500 COPY TSHOBBY.
010600 01 W2-LINECOUNT          PIC 99   VALUE 99.
010700 01 TIME-TO-STOP          PIC X    VALUE 'N'.
010800 01 W3-LASTSEG            PIC X(8) VALUE SPACES.
010900 01 BIG-IO-AREA           PIC X(120).
011000
011100 01  SSA-ROOT-QUAL.
011110     05  FILLER PIC X(8) VALUE 'TSROOT'.
011111     05  FILLER PIC X    VALUE '('.
011112     05  FILLER PIC X(8) VALUE 'TSRSTAFF'.
011113     05  FILLER PIC X(2) VALUE '= '.
011114     05  SSA-ROOT-VALUE  PIC X(4) VALUE '0000'.
011115     05  FILLER PIC X    VALUE ')'.
011116
011117 01  SSA-ROOT-UNQUAL.
011118     05  FILLER PIC X(8) VALUE 'TSROOT'.
011119     05  FILLER PIC X    VALUE ' '.
011120
011121 01  SSA-ADDR-QUAL.
011122     05  FILLER PIC X(8) VALUE 'TSADDR'.
011123     05  FILLER PIC X    VALUE '('.
011124     05  FILLER PIC X(8) VALUE 'TSAKEY'.
011125     05  FILLER PIC X(2) VALUE '= '.
011126     05  SSA-ADDR-VALUE  PIC 9(3) PACKED-DECIMAL VALUE 0.
011127     05  FILLER PIC X    VALUE ')'.
011128
011129 01  SSA-ADDR-UNQUAL.
011130     05  FILLER PIC X(8) VALUE 'TSADDR'.
011131     05  FILLER PIC X    VALUE ' '.
011132
011133 01  SSA-HOBBY-UNQUAL.
011134     05  FILLER PIC X(8) VALUE 'TSHOBBY'.
011135     05  FILLER PIC X    VALUE ' '.
011136
011140 LINKAGE SECTION.
011200 01 IO-PCBMASK.
011300     03 LTERM             PIC X(08).
011400     03 FILLER            PIC XX.
011500     03 IO-STATUS-CODE    PIC XX.
011600     03 THE-DATE          PIC S9(7) COMP-3.
011700     03 THE-TIME          PIC S9(7) COMP-3.
011800     03 THE-SEQUENCE      PIC S9(7) COMP-3.
011900     03 MODNAME           PIC X(08).
012000     03 USERID            PIC X(08).
012100
012200 01 DB-PCBMASK.
012300     03 DBD-NAME          PIC X(08).
012400     03 SEG-LEVEL         PIC X(02).
012500     03 DB-STATUS-CODE    PIC X(02).
012600     03 PROC-OPTIONS      PIC X(04).
012700     03 RESERVED          PIC S9(05) BINARY.
012800     03 SEG-NAME-FB       PIC X(08).
012900     03 LENGTH-KEY-FB     PIC S9(05) BINARY.
013000     03 NUM-SENS-SEGS     PIC S9(05) BINARY.
013100*    NOTE LENGTH OF KEY FB AREA DEPENDS ON DBD
013200     03 KEY-FB-AREA       PIC X(06).
013310
013400 PROCEDURE DIVISION USING IO-PCBMASK
013500                          DB-PCBMASK.
013600
013700     DISPLAY 'STARTING DLETALLL'
013800
013900     PERFORM INITIALIZE
014000     MOVE 'N' TO TIME-TO-STOP
014100     PERFORM MAIN-PROCESS UNTIL TIME-TO-STOP = 'Y'
014200     PERFORM FINALISE
014201
014210     CALL 'CBLTDLI' USING
014220          ROLB-FUNC
014230          IO-PCBMASK
014240
014300     GOBACK.
014400
014500 INITIALIZE.
014600*    When the very first call is a GN or GHN, 
014650*       it retrieves the first segment
014700     PERFORM GET-NEXT-ROOT
014800     PERFORM CHECK-STATUS-CODE.
014900
015000 MAIN-PROCESS.
015100     PERFORM DELETE-ROOT
016600     PERFORM GET-NEXT-ROOT
016700     PERFORM CHECK-STATUS-CODE.
016701
016710 DELETE-ROOT.
016711     CALL 'CBLTDLI' USING
016712           DLET-FUNC
016713           DB-PCBMASK
016714           TSROOT.
016720
016730     IF DB-STATUS-CODE = '  '
016740     THEN DISPLAY 'DELETED'
016750     ELSE DISPLAY 'CANNOT DELETE ' DB-STATUS-CODE.
016760
016800 FINALISE.
017100     DISPLAY 'ENDING'.
017200 GET-NEXT-ROOT.
017300*    DISPLAY 'GET NEXT'
017310     MOVE SPACES TO BIG-IO-AREA
017400     CALL 'CBLTDLI' USING GHN-FUNC
017500                          DB-PCBMASK
017600                          TSROOT
017610                          SSA-ROOT-UNQUAL.
017700* REMOVE NEXT STATEMENT.
017800*    DISPLAY 'SEG-LEVEL-' SEG-LEVEL.
017900 CHECK-STATUS-CODE.
018000     EVALUATE DB-STATUS-CODE
018100     WHEN '  '
018200        CONTINUE
018300*       DISPLAY 'SUCCESS'
018400     WHEN  'GA'
018500        CONTINUE
018600*       DISPLAY 'SUCCESS (HIGHER LEVEL SEG TYPE)'
018700     WHEN 'GK'
018800        CONTINUE
018900*       DISPLAY 'SUCCESS (SAME LEVEL DIFF SEG TYPE)'
019000     WHEN 'GE'
019100        DISPLAY 'NOT FOUND'
019200        MOVE 'Y' TO TIME-TO-STOP
019300     WHEN 'GB'
019400        DISPLAY 'END OF DATA BASE'
019500        MOVE 'Y' TO TIME-TO-STOP
019600     WHEN OTHER
019700        DISPLAY 'STATUS CODE IS  '  DB-STATUS-CODE
019800        MOVE 'Y' TO TIME-TO-STOP
019900     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 |