[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   > Program to Insert Segments into IMS Database

COBOL/IMS/DLI Program. Uses ISRT to add segments to a database

Inserting root and dependent segments
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. 'ISRTALL'.
000300* PROGRAM TO INSERT SEGMENTS
000400 ENVIRONMENT DIVISION.
000500 INPUT-OUTPUT SECTION.
000600 FILE-CONTROL.
000700 DATA DIVISION.
000800 FILE SECTION.
000900 WORKING-STORAGE SECTION.
001000
001100 01  W200-FUNCTION.
001200     03  GN-FUNC          PIC X(4) VALUE 'GN'.
001300     03  GU-FUNC          PIC X(4) VALUE 'GU'.
001400     03  GHU-FUNC         PIC X(4) VALUE 'GHU'.
001500     03  GHN-FUNC         PIC X(4) VALUE 'GHN'.
001600     03  GNP-FUNC         PIC X(4) VALUE 'GNP'.
001700     03  DLET-FUNC        PIC X(4) VALUE 'DLET'.
001800     03  ROLB-FUNC        PIC X(4) VALUE 'ROLB'.
001900     03  ISRT-FUNC        PIC X(4) VALUE 'ISRT'.
002000     03  REPL-FUNC        PIC X(4) VALUE 'REPL'.
003600*includes not shown
003601 COPY TSROOT.
003602 COPY TSADDR.
003610 COPY TSHOBBY.
003620
003630*01  TSROOT.
003640*    05 TSRSTAFF  PIC X(4).
003650*    05 TSRSNAME  PIC X(30).
003660*    05 TSRCNAME  PIC X(40).
003670*    05 TSRDOB    PIC X(6).
003680*    05 TSRDEPT   PIC X(20).
003690*    05 TSRSEX    PIC X(1).
003691*    05 TSRMARRY  PIC X(1).
003692*
003693*01  TSADDR.
003694*    05 TSAKEY    PIC  9(3) PACKED-DECIMAL.
003695*    05 TSAADDR1  PIC X(30).
003696*    05 TSAADDR2  PIC X(30).
003697*    05 TSAADDR3  PIC X(30).
003698*    05 FILLER    PIC X(02).
003699*    05 TSAPCODE  PIC X(05).
003700*
003701*01  TSHOBBY.
003702*    05 TSHKEY    PIC  9(3) PACKED-DECIMAL.
003703*    05 TSHOBBY1  PIC X(15).
003704*    05 TSHOBBY2  PIC X(15).
003705*    05 TSHOBBY3  PIC X(15).
003706*    05 FILLER    PIC X(02).
006100
006200 01 TIME-TO-STOP          PIC X    VALUE 'N'.
006300
006310 01  SSA-ROOT-QUAL.
006320     05  FILLER PIC X(8) VALUE 'TSROOT'.
006330     05  FILLER PIC X    VALUE '('.
006340     05  FILLER PIC X(8) VALUE 'TSRSTAFF'.
006350     05  FILLER PIC X(2) VALUE '= '.
006360     05  SSA-ROOT-VALUE  PIC X(4) VALUE '0000'.
006370     05  FILLER PIC X    VALUE ')'.
006380
006390 01  SSA-ROOT-UNQUAL.
006391     05  FILLER PIC X(8) VALUE 'TSROOT'.
006392     05  FILLER PIC X    VALUE ' '.
006393
006394 01  SSA-ADDR-QUAL.
006395     05  FILLER PIC X(8) VALUE 'TSADDR'.
006396     05  FILLER PIC X    VALUE '('.
006397     05  FILLER PIC X(8) VALUE 'TSAKEY'.
006398     05  FILLER PIC X(2) VALUE '= '.
006399     05  SSA-ADDR-VALUE  PIC 9(3) PACKED-DECIMAL VALUE 0.
006400     05  FILLER PIC X    VALUE ')'.
006401
006402 01  SSA-ADDR-UNQUAL.
006403     05  FILLER PIC X(8) VALUE 'TSADDR'.
006404     05  FILLER PIC X    VALUE ' '.
006410
006420 01  SSA-HOBBY-UNQUAL.
006430     05  FILLER PIC X(8) VALUE 'TSHOBBY'.
006440     05  FILLER PIC X    VALUE ' '.
006450
006500 LINKAGE SECTION.
006600 01 IO-PCBMASK.
006700     03 LTERM             PIC X(08).
006800     03 FILLER            PIC XX.
006900     03 IO-STATUS-CODE    PIC XX.
006910     03 THE-DATE          PIC S9(7) COMP-3.
006920     03 THE-TIME          PIC S9(7) COMP-3.
006930     03 THE-SEQUENCE      PIC S9(7) COMP-3.
006940     03 MODNAME           PIC X(08).
006950     03 USERID            PIC X(08).
006960
007000 01 DB-PCBMASK.
007100     03 DBD-NAME          PIC X(08).
007200     03 SEG-LEVEL         PIC X(02).
007300     03 DB-STATUS-CODE    PIC X(02).
007400     03 PROC-OPTIONS      PIC X(04).
007500     03 RESERVED          PIC S9(05) BINARY.
007600     03 SEG-NAME-FB       PIC X(08).
007700     03 LENGTH-KEY-FB     PIC S9(05) BINARY.
007800     03 NUM-SENS-SEGS     PIC S9(05) BINARY.
007900*    NOTE LENGTH OF KEY FB AREA DEPENDS ON DBD
008000     03 KEY-FB-AREA       PIC X(06).
008100
008200 PROCEDURE DIVISION USING IO-PCBMASK
008300                          DB-PCBMASK.
008400
008500     DISPLAY 'STARTING ISTRALL'
008600     PERFORM MAIN-PROCESS
008700
008800*    DISPLAY 'DOING ROLLBACK'
008900*    CALL 'CBLTDLI' USING
009000*          ROLB-FUNC
009100*          IO-PCBMASK
009200*    DISPLAY IO-STATUS-CODE.
009300     GOBACK.
009400
009500 MAIN-PROCESS.
009600     PERFORM INSERT-ROOTS
009700     PERFORM INSERT-ADDRS
009800     PERFORM INSERT-HOBBYS.
009900
010000 INSERT-ROOTS.
010100     DISPLAY 'INSERT ROOT 7001'
010200     MOVE '7001'       TO TSRSTAFF
010300     MOVE 'MARIA '     TO TSRSNAME
010400     MOVE 'K'          TO TSRCNAME
010500     MOVE '19680801'   TO TSRDOB
010600     MOVE 'A'          TO  TSRDEPT
010700     MOVE 'F'          TO  TSRSEX
010800     MOVE 'N'          TO  TSRMARRY
010900     PERFORM INSERT-A-ROOT.
011000
011100     DISPLAY 'INSERT ROOT 8001'
011200     MOVE '8001'       TO TSRSTAFF
011300     MOVE 'NADIA '     TO TSRSNAME
011400     MOVE 'K'          TO TSRCNAME
011500     MOVE '19691222'   TO TSRDOB
011600     MOVE 'A'          TO  TSRDEPT
011700     MOVE 'F'          TO  TSRSEX
011800     MOVE 'N'          TO  TSRMARRY
011900     PERFORM INSERT-A-ROOT.
012000
012010     DISPLAY 'INSERT ROOT 9001'
012020     MOVE '9001'       TO TSRSTAFF
012030     MOVE 'ELLEN '     TO TSRSNAME
012040     MOVE 'Y'          TO TSRCNAME
012050     MOVE '19490909'   TO TSRDOB
012060     MOVE 'Y'          TO  TSRDEPT
012070     MOVE 'F'          TO  TSRSEX
012080     MOVE 'N'          TO  TSRMARRY
012090     PERFORM INSERT-A-ROOT.
012091
012100     DISPLAY 'INSERT ROOT 9678'
012200     MOVE '9678'       TO TSRSTAFF
012300     MOVE 'KAREN '     TO TSRSNAME
012400     MOVE 'C'          TO TSRCNAME
012500     MOVE '19740222'   TO TSRDOB
012600     MOVE 'A'          TO  TSRDEPT
012700     MOVE 'F'          TO  TSRSEX
012800     MOVE 'Y'          TO  TSRMARRY
012900     PERFORM INSERT-A-ROOT.
013000
013092      DISPLAY 'INSERT ROOT 9602'          
013093      MOVE '9602'       TO TSRSTAFF       
013094      MOVE 'ANNA  '     TO TSRSNAME       
013095      MOVE 'KONDA '     TO TSRCNAME       
013096      MOVE '19930213'   TO TSRDOB         
013097      MOVE 'A'          TO  TSRDEPT       
013098      MOVE 'F'          TO  TSRSEX        
013099      MOVE 'N'          TO  TSRMARRY      
013100      PERFORM INSERT-A-ROOT.              
013101                                          
013102      DISPLAY 'INSERT ROOT 9603'          
013103      MOVE '9603'       TO TSRSTAFF       
013104      MOVE 'J.    '     TO TSRSNAME       
013105      MOVE 'WALKER'     TO TSRCNAME       
013106      MOVE '19730213'   TO TSRDOB         
013107      MOVE 'D'          TO  TSRDEPT       
013108      MOVE 'M'          TO  TSRSEX        
013109      MOVE 'Y'          TO  TSRMARRY      
013110      PERFORM INSERT-A-ROOT.              
013111                                          
013100 INSERT-A-ROOT.
013110*    TO INSERT A ROOT:
013111*    MOVE DATA VALUES TO THE IO AREA
013112*    DO THE CALL WITH
013113*       INSERT FUNCTION
013120*       DATABASE PCB
013130*       IO AREA FOR THE ROOT
013140*       UNQUALIFIED SSA FOR THE ROOT
013150*
013170*    POSSIBLE STATUS CODES:
013180*     GE PARENT SPECIFIED WAS NOT FOUND
013190*     AH YOU FORGOT AN SSA
013191*     AJ YOUR SSA IS NOT QUALIFIED CORRECTLY
013192*     AC HIERARCHICAL ERROR IN SSA'S (SSA'S OUT OF ORDER)
013193*     II DUPLICATE KEY
013194*
013200     CALL 'CBLTDLI' USING ISRT-FUNC
013300                          DB-PCBMASK
013400                          TSROOT
013500                          SSA-ROOT-UNQUAL
013600     PERFORM CHECK-STATUS-CODE.
013700
013800 INSERT-ADDRS.
013900     DISPLAY 'INSERT ADDR 001 UNDER 7001'
014000     MOVE '7001'       TO
014100           SSA-ROOT-VALUE
014200      MOVE 001          TO TSAKEY
014300      MOVE '835 TURK ST' TO TSAADDR1
014400      MOVE 'HARTFORD CT' TO TSAADDR2
014500      MOVE 'USA'         TO TSAADDR3
014600      MOVE 'X'           TO TSAPCODE
014700      PERFORM INSERT-A-ADDR.
014800
014900     DISPLAY 'INSERT ADDR 002 UNDER 7001'
015000     MOVE '7001'       TO
015100           SSA-ROOT-VALUE
015200      MOVE 002          TO TSAKEY
015300      MOVE '101 SUTTER ' TO TSAADDR1
015400      MOVE 'OAKLAND CA ' TO TSAADDR2
015500      MOVE 'USA'         TO TSAADDR3
015600      MOVE 'Y'           TO TSAPCODE
015700      PERFORM INSERT-A-ADDR.
015800
015900     DISPLAY 'INSERT ADDR 003 UNDER 8001'
016000     MOVE '8001'       TO
016100           SSA-ROOT-VALUE
016200      MOVE 003          TO TSAKEY
016300      MOVE '101 ELM  ST' TO TSAADDR1
016400      MOVE 'PETERBORO  ' TO TSAADDR2
016500      MOVE 'ENGLAND'     TO TSAADDR3
016600      MOVE 'Y'           TO TSAPCODE
016700      PERFORM INSERT-A-ADDR.
016800
016900     DISPLAY 'INSERT ADDR 004 UNDER 8001'
017000     MOVE '8001'       TO
017100           SSA-ROOT-VALUE
017200      MOVE 004          TO TSAKEY
017300      MOVE '123 CEDAR  ' TO TSAADDR1
017400      MOVE 'BATH       ' TO TSAADDR2
017500      MOVE 'ENGLAND'     TO TSAADDR3
017600      MOVE 'Z'           TO TSAPCODE
017700      PERFORM INSERT-A-ADDR.
017800
017900     DISPLAY 'INSERT ADDR 001 UNDER 9678'
018000     MOVE '9678'       TO
018100           SSA-ROOT-VALUE
018200      MOVE 001          TO TSAKEY
018300      MOVE '15 THISTLE ' TO TSAADDR1
018400      MOVE 'EDINBURG   ' TO TSAADDR2
018500      MOVE 'ECOSSE '     TO TSAADDR3
018600      MOVE 'A'           TO TSAPCODE
018700      PERFORM INSERT-A-ADDR.
018800
018900     DISPLAY 'INSERT ADDR 009 UNDER 9678'
019000     MOVE '9678'       TO
019100           SSA-ROOT-VALUE
019200      MOVE 009          TO TSAKEY
019300      MOVE '121 HIGH ST' TO TSAADDR1
019400      MOVE 'GLASCOW    ' TO TSAADDR2
019500      MOVE 'ECOSSE '     TO TSAADDR3
019600      MOVE 'Y'           TO TSAPCODE
019700      PERFORM INSERT-A-ADDR.
019800
019810      DISPLAY 'INSERT ADDR 100 UNDER 9603'     
019820      MOVE '9603'       TO                     
019830            SSA-ROOT-VALUE                     
019840       MOVE 100          TO TSAKEY             
019850       MOVE '432 GEORGE ' TO TSAADDR1          
019860       MOVE 'BRONX      ' TO TSAADDR2          
019870       MOVE 'NY     '     TO TSAADDR3          
019880       MOVE 'Z'           TO TSAPCODE          
019890       PERFORM INSERT-A-ADDR.                  
019891                                               
019892      DISPLAY 'INSERT ADDR 101 UNDER 9603'     
019893      MOVE '9603'       TO                     
019894            SSA-ROOT-VALUE                     
019895       MOVE 101          TO TSAKEY             
019896       MOVE '564 HANOVER' TO TSAADDR1          
019897       MOVE 'EDINBURGH  ' TO TSAADDR2          
019898       MOVE 'SCOTLAND'    TO TSAADDR3          
019899       MOVE 'F'           TO TSAPCODE          
019900       PERFORM INSERT-A-ADDR.                  
019901                                               
019900      CONTINUE.
020000
020100 INSERT-A-ADDR.
020110*    TO INSERT AN ADDR:
020120*    MOVE DATA VALUES TO THE IO AREA
020121*    MOVE THE ROOT KEY TO THE FIELD IN THE ROOT SSA!
020130*    DO THE CALL WITH
020140*       INSERT FUNCTION
020150*       DATABASE PCB
020160*       IO AREA FOR THE ADDR
020170*       QUALIFIED SSA FOR THE ROOT
020171*       UNQUALIFIED SSA FOR THE ADDR
020180*
020190*    POSSIBLE STATUS CODES:
020191*     GE PARENT SPECIFIED WAS NOT FOUND
020192*     AH YOU FORGOT AN SSA
020193*     AJ YOUR SSA IS NOT QUALIFIED CORRECTLY
020194*     AC HIERARCHICAL ERROR IN SSA'S (SSA'S OUT OF ORDER)
020195*     II DUPLICATE KEY
020196*
020200     CALL 'CBLTDLI' USING ISRT-FUNC
020300                          DB-PCBMASK
020400                          TSADDR
020500                          SSA-ROOT-QUAL
020600                          SSA-ADDR-UNQUAL
020700     PERFORM CHECK-STATUS-CODE.
020800
020900 INSERT-HOBBYS.
021000     DISPLAY 'INSERT HOBB 011 UNDER 7001'
021100     MOVE '7001'       TO
021200           SSA-ROOT-VALUE
021300      MOVE 011             TO TSHKEY
021400      MOVE 'HANG GLIDING'   TO TSHOBBY1
021500      MOVE 'SNAKE CHARMING' TO TSHOBBY2
021600      MOVE 'FOOTBALL'       TO TSHOBBY3
021700      PERFORM INSERT-A-HOBBY.
021800
021900     DISPLAY 'INSERT HOBB 012 UNDER 7001'
022000     MOVE '7001'       TO
022100           SSA-ROOT-VALUE
022200      MOVE 012             TO TSHKEY
022300      MOVE 'FOOTBALL    '   TO TSHOBBY1
022400      MOVE 'FOOTBALL      ' TO TSHOBBY2
022500      MOVE 'FOOTBALL'       TO TSHOBBY3
022600      PERFORM INSERT-A-HOBBY.
022700
022800     DISPLAY 'INSERT HOBB 013 UNDER 8001'
022900     MOVE '8001'       TO
023000           SSA-ROOT-VALUE
023100      MOVE 013             TO TSHKEY
023200      MOVE 'SKY DIVING  '   TO TSHOBBY1
023300      MOVE 'SNAKE HANDLING' TO TSHOBBY2
023400      MOVE 'FOOTBALL'       TO TSHOBBY3
023500      PERFORM INSERT-A-HOBBY.
023600
023700     DISPLAY 'INSERT HOBB 001 UNDER 8001'
023800     MOVE '8001'       TO
023900           SSA-ROOT-VALUE
024000      MOVE 001             TO TSHKEY
024100      MOVE 'SOCCER      '   TO TSHOBBY1
024200      MOVE 'SOCCER        ' TO TSHOBBY2
024300      MOVE 'SOCCER  '       TO TSHOBBY3
024400      PERFORM INSERT-A-HOBBY.
024500
024600     DISPLAY 'INSERT HOBB 009 UNDER 9678'
024700     MOVE '9678'       TO
024800           SSA-ROOT-VALUE
024900      MOVE 009             TO TSHKEY
025000      MOVE 'SNAKE CHARM '   TO TSHOBBY1
025100      MOVE 'BOMB DEFUSING ' TO TSHOBBY2
025200      MOVE 'SHARK TAMING'   TO TSHOBBY3
025300      PERFORM INSERT-A-HOBBY.
025400
025500 INSERT-A-HOBBY.
025600     CALL 'CBLTDLI' USING ISRT-FUNC
025700                          DB-PCBMASK
025800                          TSHOBBY
025900                          SSA-ROOT-QUAL
026000                          SSA-HOBBY-UNQUAL
026100     PERFORM CHECK-STATUS-CODE.
026200
026300 CHECK-STATUS-CODE.
026400     EVALUATE DB-STATUS-CODE
026500     WHEN '  '
026600        CONTINUE
026700        DISPLAY 'SUCCESS'
026800     WHEN  'GA'
026900        CONTINUE
027000*       DISPLAY 'SUCCESS (HIGHER LEVEL SEG TYPE)'
027100     WHEN 'GK'
027200        CONTINUE
027300*       DISPLAY 'SUCCESS (SAME LEVEL DIFF SEG TYPE)'
027400     WHEN 'GE'
027500        DISPLAY 'NOT FOUND'
027600        MOVE 'Y' TO TIME-TO-STOP
027700     WHEN 'GB'
027800        DISPLAY 'END OF DATA BASE'
027900        MOVE 'Y' TO TIME-TO-STOP
028000     WHEN 'II'
028100        DISPLAY 'DUPLICATE       '
028200     WHEN OTHER
028300        DISPLAY 'STATUS CODE IS  '  DB-STATUS-CODE
028400        MOVE 'Y' TO TIME-TO-STOP
028500        GO TO ERROR-EXIT
028600     END-EVALUATE.
028700
028800 ERROR-EXIT.
028900      DISPLAY 'PROGRAM ABANDOND '
029000
029100     CALL 'CBLTDLI' USING
029200           ROLB-FUNC
029300           IO-PCBMASK
029400
029500     GOBACK.
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 |