DICL3 ;SF/TKW-VA FileMan: Lookup: Lister, Part 4 ;1/26/99 08:32
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
FOLLOW(DIFILE,DIF,DIDEF,DICHNNO,DILVL,DIFRFILE,DIFIELD,DIDXFILE,DIVPTR,DISUB,DISCREEN) ;
;
; follow pointer/vp chains to end, building stack along the way
;
F1 ; increment stack level, loop increments at top
; if pointing file lacks B index, store that in stack
;
S DILVL=DILVL+1
I DILVL=1 S DIF(1,DIFILE)=U_DIDXFILE
I DILVL>1 D
. S DIF(DILVL,DIFILE)=DIFRFILE_U_DIVPTR
. I '$D(@DIFILE(DIFILE)@("B")) S DIFILE(DIFILE,"NO B")=""
. S DIFILE(DIFILE,"O")=$$OREF^DIQGU(DIFILE(DIFILE))
. Q
F2 ; Find data type of .01 field of pointed-to file, process
; end of pointer chain.
N T S T=$P(DIDEF,U,2)
I T'["P",T'["V" D Q
. S DIFILE("STACKEND",DICHNNO)=DILVL_U_DIFILE
. N L,F F L=DILVL:-1:1 D
. . S DIFILE("STACK",DICHNNO,L,DIFILE)=DIFRFILE_U_DIVPTR
. . Q:L=1
. . S DIFILE=+DIF(L,DIFILE)
. . S F=DIF(L-1,DIFILE),DIFRFILE=$P(F,U),DIVPTR=$P(F,U,2)
. S DICHNNO=DICHNNO+1
. Q
F3 ; Advance file number, Process regular pointers within pointer chain.
N DIFRFILE S DIFRFILE=DIFILE
I T["P" D Q
. S DIFILE=+$P($P(DIDEF,U,2),"P",2)
. S DIFILE(DIFILE)=$$CREF^DIQGU(U_$P(DIDEF,U,3))
. S DIDEF=$G(^DD(DIFILE,.01,0))
. D FOLLOW(.DIFILE,.DIF,DIDEF,.DICHNNO,.DILVL,DIFRFILE,"","",0)
. Q
F4 ; Process variable pointers within the pointer chain.
N DIVP,G
S:'$G(DIFIELD) DIFIELD=.01
F DIVP=0:0 S DIVP=$O(^DD(DIFILE,DIFIELD,"V",DIVP)) Q:'DIVP S G=$G(^(DIVP,0)) D
. Q:'G
. S DIFILE=+G,G=$G(^DIC(DIFILE,0,"GL")) I G="" S DIFILE=DIFRFILE Q
. I DILVL=1,$D(DISCREEN("V",DISUB)),'$D(DINDEX(DISUB,"VP",G)) S DIFILE=DIFRFILE Q
. S DIFILE(DIFILE)=$$CREF^DIQGU(G)
. S DIDEF=$G(^DD(DIFILE,.01,0))
. N DISAVL S DISAVL=DILVL
. D FOLLOW(.DIFILE,.DIF,DIDEF,.DICHNNO,.DILVL,DIFRFILE,"","",1)
. S DILVL=DISAVL,DIFILE=DIFRFILE
Q
;
BACKTRAK(DIFLAGS,DIFILE,DISTACK,DIEN,DIFIEN,DINDEX0,DINDEX,DIDENT,DISCREEN,DILIST) ;
;
; Back up on pointer stack until we get back to home file.
;
B1 ; back up one level on stack, recover file #, root, and index file,
; and set value to match equal to the previous level's ien value
;
N F,DIVPTR S F=DIFILE("STACK",+DISTACK,+$P(DISTACK,U,2),+$P(DISTACK,U,3))
S DIVPTR=$P(F,U,2),F=+F
N DIVALUE D
. I 'DIVPTR S DIVALUE=DIEN Q
. S DIVALUE=DIEN_";"_$P(DIFILE(+$P(DISTACK,U,3),"O"),U,2)
. Q
S DISTACK=(+DISTACK)_U_($P(DISTACK,U,2)-1)_U_F
I $P(DISTACK,U,2)=1 D Q
. N DIROOT1 S DIROOT1=$S($D(DIFILE(F,"NO B")):DIFILE(F,"NO B"),1:DIFILE(F,"O")_"DINDEX0")_")"
. I $O(@DIROOT1@(DIVALUE,""))="" S DIEN="" Q
. S DINDEX0(1)=DIVALUE,DIEN=""
. S DIFILE=+F
. S F=$TR(DIFLAGS,"vp")
. D WALK^DICLIX(F,.DINDEX0,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,"",.DIC)
. S DIFILE=+$P(DIFILE("STACK"),U,3)
. Q
;
B2 ; loop through matches on pointer index,
; quit when no matches, if not back to root of pointer chain yet,
; make another recursive call to BACKTRAK to unwind to pointing
; file's matches
;
S DIEN="" F D Q:DIEN=""!($G(DIERR))
. N DIROOT1 S DIROOT1=$S($D(DIFILE(F,"NO B")):DIFILE(F,"NO B"),1:DIFILE(F,"O")_"""B""")_")"
. S DIEN=$O(@DIROOT1@(DIVALUE,DIEN))
. Q:DIEN=""
. D BACKTRAK(.DIFLAGS,.DIFILE,DISTACK,DIEN,DIFIEN,.DINDEX0,.DINDEX,.DIDENT,.DISCREEN,.DILIST)
. Q
Q
;
SETB ; Set temporary "B" index on pointed-to files.
Q:'$O(DIFILE("STACK",0))
N I,J,DIFL,DITEMP
F I=0:0 S I=$O(DIFILE("STACK",I)) Q:'I F J=0:0 S J=$O(DIFILE("STACK",I,J)) Q:'J F DIFL=0:0 S DIFL=$O(DIFILE("STACK",I,J,DIFL)) Q:'DIFL I $D(DIFILE(DIFL,"NO B")) D
. D TMPB^DICUIX1(.DITEMP,DIFL)
. S DIFILE(DIFL,"NO B")=DITEMP
. D BLDB^DICUIX1(DIFILE(DIFL),DITEMP)
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICL3 3985 printed Sep 23, 2025@20:22:18 Page 2
DICL3 ;SF/TKW-VA FileMan: Lookup: Lister, Part 4 ;1/26/99 08:32
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
FOLLOW(DIFILE,DIF,DIDEF,DICHNNO,DILVL,DIFRFILE,DIFIELD,DIDXFILE,DIVPTR,DISUB,DISCREEN) ;
+1 ;
+2 ; follow pointer/vp chains to end, building stack along the way
+3 ;
F1 ; increment stack level, loop increments at top
+1 ; if pointing file lacks B index, store that in stack
+2 ;
+3 SET DILVL=DILVL+1
+4 IF DILVL=1
SET DIF(1,DIFILE)=U_DIDXFILE
+5 IF DILVL>1
Begin DoDot:1
+6 SET DIF(DILVL,DIFILE)=DIFRFILE_U_DIVPTR
+7 IF '$DATA(@DIFILE(DIFILE)@("B"))
SET DIFILE(DIFILE,"NO B")=""
+8 SET DIFILE(DIFILE,"O")=$$OREF^DIQGU(DIFILE(DIFILE))
+9 QUIT
End DoDot:1
F2 ; Find data type of .01 field of pointed-to file, process
+1 ; end of pointer chain.
+2 NEW T
SET T=$PIECE(DIDEF,U,2)
+3 IF T'["P"
IF T'["V"
Begin DoDot:1
+4 SET DIFILE("STACKEND",DICHNNO)=DILVL_U_DIFILE
+5 NEW L,F
FOR L=DILVL:-1:1
Begin DoDot:2
+6 SET DIFILE("STACK",DICHNNO,L,DIFILE)=DIFRFILE_U_DIVPTR
+7 if L=1
QUIT
+8 SET DIFILE=+DIF(L,DIFILE)
+9 SET F=DIF(L-1,DIFILE)
SET DIFRFILE=$PIECE(F,U)
SET DIVPTR=$PIECE(F,U,2)
End DoDot:2
+10 SET DICHNNO=DICHNNO+1
+11 QUIT
End DoDot:1
QUIT
F3 ; Advance file number, Process regular pointers within pointer chain.
+1 NEW DIFRFILE
SET DIFRFILE=DIFILE
+2 IF T["P"
Begin DoDot:1
+3 SET DIFILE=+$PIECE($PIECE(DIDEF,U,2),"P",2)
+4 SET DIFILE(DIFILE)=$$CREF^DIQGU(U_$PIECE(DIDEF,U,3))
+5 SET DIDEF=$GET(^DD(DIFILE,.01,0))
+6 DO FOLLOW(.DIFILE,.DIF,DIDEF,.DICHNNO,.DILVL,DIFRFILE,"","",0)
+7 QUIT
End DoDot:1
QUIT
F4 ; Process variable pointers within the pointer chain.
+1 NEW DIVP,G
+2 if '$GET(DIFIELD)
SET DIFIELD=.01
+3 FOR DIVP=0:0
SET DIVP=$ORDER(^DD(DIFILE,DIFIELD,"V",DIVP))
if 'DIVP
QUIT
SET G=$GET(^(DIVP,0))
Begin DoDot:1
+4 if 'G
QUIT
+5 SET DIFILE=+G
SET G=$GET(^DIC(DIFILE,0,"GL"))
IF G=""
SET DIFILE=DIFRFILE
QUIT
+6 IF DILVL=1
IF $DATA(DISCREEN("V",DISUB))
IF '$DATA(DINDEX(DISUB,"VP",G))
SET DIFILE=DIFRFILE
QUIT
+7 SET DIFILE(DIFILE)=$$CREF^DIQGU(G)
+8 SET DIDEF=$GET(^DD(DIFILE,.01,0))
+9 NEW DISAVL
SET DISAVL=DILVL
+10 DO FOLLOW(.DIFILE,.DIF,DIDEF,.DICHNNO,.DILVL,DIFRFILE,"","",1)
+11 SET DILVL=DISAVL
SET DIFILE=DIFRFILE
End DoDot:1
+12 QUIT
+13 ;
BACKTRAK(DIFLAGS,DIFILE,DISTACK,DIEN,DIFIEN,DINDEX0,DINDEX,DIDENT,DISCREEN,DILIST) ;
+1 ;
+2 ; Back up on pointer stack until we get back to home file.
+3 ;
B1 ; back up one level on stack, recover file #, root, and index file,
+1 ; and set value to match equal to the previous level's ien value
+2 ;
+3 NEW F,DIVPTR
SET F=DIFILE("STACK",+DISTACK,+$PIECE(DISTACK,U,2),+$PIECE(DISTACK,U,3))
+4 SET DIVPTR=$PIECE(F,U,2)
SET F=+F
+5 NEW DIVALUE
Begin DoDot:1
+6 IF 'DIVPTR
SET DIVALUE=DIEN
QUIT
+7 SET DIVALUE=DIEN_";"_$PIECE(DIFILE(+$PIECE(DISTACK,U,3),"O"),U,2)
+8 QUIT
End DoDot:1
+9 SET DISTACK=(+DISTACK)_U_($PIECE(DISTACK,U,2)-1)_U_F
+10 IF $PIECE(DISTACK,U,2)=1
Begin DoDot:1
+11 NEW DIROOT1
SET DIROOT1=$SELECT($DATA(DIFILE(F,"NO B")):DIFILE(F,"NO B"),1:DIFILE(F,"O")_"DINDEX0")_")"
+12 IF $ORDER(@DIROOT1@(DIVALUE,""))=""
SET DIEN=""
QUIT
+13 SET DINDEX0(1)=DIVALUE
SET DIEN=""
+14 SET DIFILE=+F
+15 SET F=$TRANSLATE(DIFLAGS,"vp")
+16 DO WALK^DICLIX(F,.DINDEX0,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,"",.DIC)
+17 SET DIFILE=+$PIECE(DIFILE("STACK"),U,3)
+18 QUIT
End DoDot:1
QUIT
+19 ;
B2 ; loop through matches on pointer index,
+1 ; quit when no matches, if not back to root of pointer chain yet,
+2 ; make another recursive call to BACKTRAK to unwind to pointing
+3 ; file's matches
+4 ;
+5 SET DIEN=""
FOR
Begin DoDot:1
+6 NEW DIROOT1
SET DIROOT1=$SELECT($DATA(DIFILE(F,"NO B")):DIFILE(F,"NO B"),1:DIFILE(F,"O")_"""B""")_")"
+7 SET DIEN=$ORDER(@DIROOT1@(DIVALUE,DIEN))
+8 if DIEN=""
QUIT
+9 DO BACKTRAK(.DIFLAGS,.DIFILE,DISTACK,DIEN,DIFIEN,.DINDEX0,.DINDEX,.DIDENT,.DISCREEN,.DILIST)
+10 QUIT
End DoDot:1
if DIEN=""!($GET(DIERR))
QUIT
+11 QUIT
+12 ;
SETB ; Set temporary "B" index on pointed-to files.
+1 if '$ORDER(DIFILE("STACK",0))
QUIT
+2 NEW I,J,DIFL,DITEMP
+3 FOR I=0:0
SET I=$ORDER(DIFILE("STACK",I))
if 'I
QUIT
FOR J=0:0
SET J=$ORDER(DIFILE("STACK",I,J))
if 'J
QUIT
FOR DIFL=0:0
SET DIFL=$ORDER(DIFILE("STACK",I,J,DIFL))
if 'DIFL
QUIT
IF $DATA(DIFILE(DIFL,"NO B"))
Begin DoDot:1
+4 DO TMPB^DICUIX1(.DITEMP,DIFL)
+5 SET DIFILE(DIFL,"NO B")=DITEMP
+6 DO BLDB^DICUIX1(DIFILE(DIFL),DITEMP)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
