*DECK DBSLNXITM 
USETEXT DBTEXT
PROC NXTITM;
*CALL DEBUGVARS 
START("NXTITM") 
CONTROL IFNQ CB5$CDCS,"NO"; 
XREF BEGIN
PROC IERR$; 
PROC NXTKI; 
PROC NXTRNRD; 
FUNC WA$TO$DNAT;
END 
  
# 
THIS PROCEDURE PERFORMS THE FOLLOWING FUNCTIONS :-
  A. IF THERE ARE MORE ITEMS TO BE PROCESSED (ACCORDING 
     TO THE COUNT ORIGINALLY IN THE RECORD ENTRY) 
     THEN THE NEXT ITEM WILL BE READ IN AND UNPACKED. 
     CALLS WILL BE MADE TO NXTRNRD (RENAME/REDEFINE)
     AND NXTKI (KEY/INDEX) TO UNPACK THEIR APPROPRIATE
     FIELDS.
  B. IF NO FURTHER ITEMS REMAIN FOR THE CURRENT RECORD
     THE MODULE FLAG ITM$F WILL BE SET TO END$STATUS. 
# 
IF INXTITMPTR NQ 0
  THENB ("MORE ITEMS REMAIN TO BE PROCESSED") 
  DA$GTSB(ITMA,ITMASIZE,RNXTITMWA); #RD ITEM IN#
  IF DASTATE EQ 1 
    THENB ("ATTEMPT TO READ OUTSIDE FILE")
    IERR$(L9,ABORT);
  ENDIF 
  #UNPACK ITEM# 
  SETI("ITYPE",ITYPE,SBITMTYPE[1])
  SETI("IORDINAL",IORDINAL,SBITMORDINAL[1]) 
  SETI("ILEVEL",ILEVEL,SBITMLEVEL[1]) 
IF ILEVEL EQ $LEVEL66 
  THENB("LEVEL SHOULD BE 66") 
  SETI("ILEVEL",ILEVEL,66)
ENDIF 
IF ILEVEL EQ $LEVEL88 
  THENB("LEVEL SHOULD BE 88") 
  SETI("ILEVEL",ILEVEL,88)
ENDIF 
  IF SBITMKEYFLG[1] THEN IPRKEY=1; ELSE IPRKEY=0; #PRIMARY KEY# 
  IF SBITMALTKEYF[1] THEN IARKEY=1; ELSE IARKEY=0; #ALT KEY#
 CONTROL IFEQ CB5$CDCS,"CDCS2"; 
  IF SBITMMAJKEYF[1] THEN IMRKEY=1; ELSE IMRKEY=0;  #MAJOR PART OF KEY# 
      IV$($SET$,"IMRKEY",IMRKEY)
 CONTROL FI;
      IV$($SET$,"IPRKEY",IPRKEY) IV$($SET$,"IARKEY",IARKEY) 
    SETI("IRNRD",IRNRD,SBITMRNRDPTR[1]) 
  IPRVITMPTR=SBITMPRIORP[1];  #PREVIOUS ITEM PTR# 
  SETO("INXTITMPTR",INXTITMPTR,SBITMNEXTP[1])  #NEXT ITM PTR# 
  SETI("IBWP",IBWP,SBITMBWP[1])   #BEGINNING WORD POSN# 
  SETI("IBBP",IBBP,SBITMBBP[1])   #BEGINNING BIT POSN#
  SETI("IUSESIZE",IUSESIZE,SBITMUSESIZE[1]) 
  SETI("IPICSIZE",IPICSIZE,SBITMIPICSIZ[1]) #PICTURE SIZE#
IF SBITMPTLOC[1] NQ 0 
  THENB("POINT LOCATION PRESENT") 
  IF SBITMLFTPT[1] EQ 0 
    THENB ("DEC PT N DIGITS FROM RIGHT")
    SETI("IDPLOC",IDPLOC,0-SBITMPTLOC[1]) #HELD IN COBOL5 AS -VE# 
    ELSEB ("PT IS TO LEFT") 
    SETI("IDPLOC",IDPLOC,SBITMPTLOC[1]) 
  ENDIF 
  ELSEB("RESET PT LOC TO 0")
  SETI("IDPLOC",IDPLOC,0) 
ENDIF 
  SETI("ISIGNSEP",ISIGNSEP,0) 
          #ONLY OVERPUNCH IMPLEMENTED IN DDL# 
 CONTROL IFEQ CB5$CDCS,"CDCS1"; 
  SETI("ISIGN",ISIGN,SBITMSIGNF[1]) #ITEM SIGNED# 
 CONTROL FI;
 CONTROL IFEQ CB5$CDCS,"CDCS2"; 
  SETI("ISIGN",ISIGN,SBITMSIGNFO[1])
 CONTROL FI;
  SETI("IUSAGE",IUSAGE,SBITMUSAGE[1]) 
  SETI("ICLASS",ICLASS,SBITMCLASS[1]) 
  IF SBITMOCCURP[1] NQ 0
    THEN ISUBOCC=1; ELSE ISUBOCC=0; #SBORD TO OCC#
  SETO("IOCCPTR",IOCCPTR,SBITMOCCURP[1]) #PTR TO OCCURRENCE DATA# 
 CONTROL IFEQ CB5$CDCS,"CDCS1"; 
  IDOMPTR=SBITMDOMPTR[1]; #DOMINANT ITM PTR IF CURR ITM IS REPGRP#
 CONTROL FI;
  SETO("IDOMWA",IDOMWA,SBITMDOMADR[1]) #DOMINANT ITM WA, ALL GRPS#
  SETI("ISOURCELINE",ISOURCELINE,SBITMSRCLNEN[1]) #SOURCE LINE IN DDL#
  IF SBITMREDEFFG[1] THEN IRDEF=1; ELSE IRDEF=0; #RDEF OR SBORD#
      IV$($SET$,"IRDEF",IRDEF)
  IF SBITMSYNC[1] THEN ISYNC=1; ELSE ISYNC=0;  #SYNC ITEM#
  IF SBITMSYNCLFT[1] THEN ISYNCL=1; ELSE ISYNCL=0; #SYNC LEFT#
  IF SBITMJUST[1] THEN IJUST=1; ELSE IJUST=0; #JUSTIFIED# 
  SETI("IOCCRRFLG",IOCCRRFLG,0) 
  IF IOCCPTR NQ 0 
    THENB ("THERE IS OCCURRENCE DATA")
    SETO("P<ITMBA>",P<ITMBA>,LOC(ITMA) + IOCCPTR) 
                   #SET ARRAY BASE TO OCCUR DATA# 
    SETO("IOCCWA",IOCCWA,RNXTITMWA+IOCCPTR) 
    IF IOCCPTR+3 GR ITMASIZE
      THENB("3 OCCURS WORDS NOT IN CORE") 
        SETO("P<ITMBA>",P<ITMBA>,LOC(ITMA)+ITMFIXSIZE)
        DA$GTSB(ITMBA,ITMASIZE-ITMFIXSIZE,IOCCWA);
        IF DASTATE EQ 1 
          THENB("ITEM OCC READ ERROR")
          IERR$(L9,ABORT);
        ENDIF 
        SETI("IOCCRRFLG",IOCCRRFLG,1) 
    ENDIF 
    IF SBITMDEPNDON[1] THEN IDEP=1; ELSE IDEP=0; #DEP ON FLG# 
      IV$($SET$,"IDEP",IDEP)
    SETI("IMINOCC",IMINOCC,SBITMLOWBNDS[1])  #MIN OCCURS# 
    SETI("IMAXOCC",IMAXOCC,SBITMHIBNDS[1])  #MAX OCCURS#
IF SBITMOCCKNXT[1]
  THENB("KEY/INDEX ATOM PRESENT") 
  IKINXT=1; 
 CONTROL IFEQ CB5$CDCS,"CDCS1"; 
  SETI("KEYINDEXR",KEYINDEXR,0)   #ACCESS LEFT ATOM#
 CONTROL FI;
  SETO("P<ITMBA>",P<ITMBA>,P<ITMBA>+1)  #MOVE TO NEXT WD# 
  SETO("IOCCWA",IOCCWA,IOCCWA+1)
 CONTROL IFEQ CB5$CDCS,"CDCS1"; 
  SETI("IKIQUAL",IKIQUAL,0) 
 CONTROL FI;
  SETO("KEYINDEXBASE",KEYINDEXBASE,P<ITMBA>)  #STORE BASE FOR NXTKI#
  ELSEB("NO KEY/INDEX ATOMS") 
  IKINXT=0; 
    SETO("P<ITMBA>",P<ITMBA>,P<ITMBA>+1)
  SETO("IOCCWA",IOCCWA,IOCCWA+1)
                   #MOVE BASED ARRAY TO NEXT WD#
  SETO("KEYINDEXBASE",KEYINDEXBASE,0)  #CLEAR AS NO ATOMS#
ENDIF 
    IF IDEP NQ 0
      THENB ("OCCURS DEPENDING SPECIFIED")
      IF SBITMOCCLTYP[1] NQ $DEPON
        THENB ("FIRST ATOM NOT DEPENDING ON NAME")
        IERR$(L10,ABORT); 
        ELSEB ("DEP ON NAME FOUND") 
        #CONVERT WORD ADDR TO DNAT PTR# 
        OV$($SET$,"DEP WORD",SBITMALIASNM[1]) 
        OV$($SET$,"DEPON WA",SBITMOCCLDNA[1]) 
        SETI("IDEPNAME",IDEPNAME,WA$TO$DNAT(SBITMOCCLDNA[1])) 
       CONTROL IFEQ CB5$CDCS,"CDCS1"; 
        SETI("KEYINDEXR",KEYINDEXR,1) 
                   #FORCE ACCESS OF RIGHT ATOM (KEY/IDX)# 
       CONTROL FI;
        IF SBITMOCCLQAL[1] THEN IKIQUAL=1; ELSE IKIQUAL=0;
                 IV$($SET$,"IKIQUAL",IKIQUAL) 
       CONTROL IFEQ CB5$CDCS,"CDCS2"; 
        SETO("P<ITMBA>",P<ITMBA>,P<ITMBA>+1)  #NEXT WORD# 
        SETO("IOCCWA",IOCCWA,IOCCWA+1)
        IF KEYINDEXBASE NQ 0
          THENB("KEY/INDEX ATOMS")
            SETO("KEYINDEXBASE",KEYINDEXBASE,KEYINDEXBASE+1)
        ENDIF 
       CONTROL FI;
        NXTKI;
      ENDIF 
      ELSEB ("NO OCCURS DEPENDING") 
    NXTKI;
    ENDIF 
    ELSEB ("NO OCCURRENCE DATA")
    SETI("IDEP",IDEP,0)  #RESET ALL FIELDS# 
    SETI("IMINOCC",IMINOCC,0) 
    SETI("IMAXOCC",IMAXOCC,0) 
    SETO("KEYINDEXBASE",KEYINDEXBASE,0) 
    SETI("KEYINDEXR",KEYINDEXR,0) 
    SETI("IDEPNAME",IDEPNAME,0) 
  ENDIF 
  IF IRNRD NQ 0 
    THENB ("THERE ARE RENAME/REDEFINES ATOMS")
    #SET FIELDS FOR NXTRNRD#
    SETO("P<ITMBA>",P<ITMBA>,LOC(ITMA)+IRNRD) 
                   #SET BASE OF RN/RD ATOMS#
    SETO("IRNRDWA",IRNRDWA,RNXTITMWA+IRNRD) 
    IF (IOCCRRFLG EQ 1) OR (IRNRD GR ITMASIZE)
      THENB("RN/RD WORD NOT IN CORE") 
        SETO("P<ITMBA>",P<ITMBA>,LOC(ITMA)+ITMFIXSIZE)
        DA$GTSB(ITMBA,ITMASIZE-ITMFIXSIZE,IRNRDWA); 
        IF DASTATE EQ 1 
          THENB("RN/RD ITEM READ ERROR")
          IERR$(L9,ABORT);
        ENDIF 
        SETI("IOCCRRFLG",IOCCRRFLG,2) 
    ENDIF 
    SETI("RNRDR",RNRDR,0) #FORCE EXTRACT OF LEFT ATOM#
    IRNQUAL=0;  #RESET NEXT ATOM QUALIFIER FLAG#
    NXTRNRD;  #UNPACK FIRST ATOM# 
    ELSEB ("NO REDEF/RENAMES ATOMS")
  SETI("IREDEF",IREDEF,0)  #RESET DNAT PTR TO REDEFD ITEM#
  ENDIF 
  #SETUP WORD ADDRESS FOR NEXT ITEM INPUT#
  SETO("IWA",IWA,RNXTITMWA)  #SAVE CURR ITM WD ADDR#
  SETO("RNXTITMWA",RNXTITMWA,RNXTITMWA+INXTITMPTR)
  ELSEB ("NO MORE ITEMS") 
  SETI("ITM$F",ITM$F,END$STATUS)
ENDIF 
CONTROL FI; 
FINIS("NXTITM") 
TERM
