DIDGFTPT ;GFT/GFT - GET ALL ENTRIES THAT POINT TO ENTRY GFTIEN IN FILE GFTFILE ;20 Aug 2015 4:46 PM
;;22.2;VA FileMan;**19**;Jan 05, 2016;Build 2
;;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.
;
W !!,"THIS UTILITY TRIES TO FIND ALL ENTRIES IN ALL FILES POINTING TO A CERTAIN FILE",!
D DT^DICRW
N DIC,DIR,X,Y,GFTIEN,GFTANY,GFTFILE,GFTALL,DIRUT,DIBT,GFTIENLIST
K ^TMP($J)
S DIC=1,DIC(0)="AEQM" D ^DIC Q:Y<0 S GFTFILE=+Y,GFTANY=$P(^DIC(GFTFILE,0),U)
S DIR(0)="S^1:One particular "_GFTANY_" Entry;2:All "_GFTANY_" Entries;3:Non-existent "_GFTANY_" Entries"
S X="" F S X=$O(^DIBT("F"_GFTFILE,X)) Q:X="" F Y=0:0 S Y=$O(^DIBT("F"_GFTFILE,X,Y)) Q:'Y I $D(^DIBT(Y,1))>1 S DIBT(Y)=""
I $O(DIBT(0)) S DIR(0)=DIR(0)_";4:Entries from a "_GFTANY_" Search Template"
S DIR("A")="Find pointers to"
S DIR("B")=$P($P(DIR(0),";",2),":",2)
D ^DIR K DIR Q:$G(DIRUT)
I Y=4 S DIC=.401,DIC("S")="I $D(DIBT(+Y))",GFTANY=Y D ^DIC Q:Y'>0 K DIBT,DIC M GFTIENLIST=^DIBT(+Y,1) G ZIS
S DIC=GFTFILE,DIC("A")="Find pointers to "_GFTANY_" Entry: ",GFTANY=Y,GFTIENLIST=0
I Y=1 D ^DIC Q:Y<0 S GFTIENLIST=+Y
ZIS D ^%ZIS Q:$G(POP) U IO
W ! S $Y=0
START K DIC
D DEPEND(GFTFILE,.GFTIENLIST,,"M"_GFTANY)
;NOW WE HAVE ALL INFO
S GFTIEN="" F S GFTIEN=$O(^TMP($J,GFTFILE,GFTIEN)) Q:GFTIEN="" D Q:'$D(GFTIEN)
.S X=$$GET1^DIQ(GFTFILE,GFTIEN,.01) I X]"" Q:GFTANY=3
.E S X="NON-EXISTENT ENTRY # "_GFTIEN
.W !!,"***",$P(^DIC(GFTFILE,0),U),": " W X,"***"
.F I=0:0 Q:'$D(GFTIEN) S I=$O(^TMP($J,GFTFILE,GFTIEN,I)) Q:'I W !,"FILE ",I," (",$P(^DIC(I,0),U),")" F J=0:0 S J=$O(^TMP($J,GFTFILE,GFTIEN,I,J)) Q:'J D Q:'$D(GFTIEN)
..S Y=$O(^(J,""))
..W !?9,"`",J,?22,$$GET1^DIQ(I,J,.01)
..F Q:Y="" W:$X>(IOM-30) ! W ?IOM-30,$P(@("^DD("_Y_",0)"),U) S Y=$O(^TMP($J,GFTFILE,GFTIEN,I,J,Y))
..I $E($G(IOST))="C",$G(IOSL,24)-3<$Y S DIR(0)="E" D ^DIR S $Y=0 I 'Y K GFTIEN
K ^TMP($J)
I '$G(GFTALL) W !!! D ^%ZISC
Q
;
;
DEPEND(GFTFILE,IEN,GFTWHERE,GFTPARAM) ;
I $G(GFTPARAM)["M" N GFTANY S GFTANY=+$P(GFTPARAM,"M",2)
S:$G(GFTWHERE)="" GFTWHERE=$NA(^TMP($J))
K @GFTWHERE ;output array
I $D(IEN)<9 S GFTIEN(GFTFILE,+IEN)="" ;IEN can be either a scalar...
E M GFTIEN(GFTFILE)=IEN ;...or an array
N A,B
S A=0 F S A=+$O(^DD(GFTFILE,0,"PT",A)) Q:'A D
.S B=0 F S B=+$O(^DD(GFTFILE,0,"PT",A,B)) Q:'B D
..D CHASE(A,B,.GFTRCR)
COMPUTED S A=0 F S A=+$O(^DD(GFTFILE,0,"PTC",A)) Q:'A D
.S B=0 F S B=+$O(^DD(GFTFILE,0,"PTC",A,B)) Q:'B D
..D CHASE(A,B,.GFTRCR)
Q
;
;
CHASE(FILE,FIELD,GFTRCR) ;BUILD AN 'XEC' THAT WILL GO THRU FILE REMEMBERING FIELD'S POINTERS
I FILE=.6!(FILE=1.1) Q ;NOT AUDIT FILES
N GFTF,X,I,J,V,XEC,A,B,D0,D1,D2,D3,D4,D5,D6,D7,D8,D9,DICMX,DIDGFTPT,GFTFISCR
S GFTF=FILE,L=0,PUT="",DIDGFTPT=1 ;want this defined for special FILE SCREENS
UP F S I=$G(^DD(GFTF,0,"UP")) Q:'I S L=L+1,X=$O(^DD(I,"SB",GFTF,0)) Q:'X S J=$P($G(^DD(I,X,0)),U,4) Q:J'[";0" S GFTF=I,J(L)=$P(J,";")
Q:'$D(^DIC(GFTF,0,"GL")) S J=^("GL"),I=""
I $G(^DD(GFTF,0,"SCR"))]"" S GFTFISCR=^("SCR")
F A=L:-1:0 S X="D"_(L-A),PUT=PUT_"_D"_A_"_"",""",I=I_"F "_X_"=0:0 S "_X_"=$O("_J_X_")) Q:'"_X_" I $D(^("_X_",0)) " I A S J=J_X_","""_J(A)_""","
D Q:'$D(XEC) ;NOW WE HAVE 'L' AS LEVEL AND 'I' AS 'L' FOR LOOPS
.S X=$P($G(^DD(FILE,FIELD,0)),U,4) Q:X="" S A=$P(^(0),U,2),FIELD=FILE_","_FIELD,V=$P(X,";",2)
.I 'V Q:A'["C" Q:A'["p" S DICMX=$P(^(0),U,5,99),XEC="X DICMX I X" I A["m" D Q
..S XEC=I_"S DIDGFTPT=D0 "_DICMX,DICMX="D PUT^DIDGFTPT(+$G(D),DIDGFTPT,"""_FIELD_""")" ;m=MULTIPLE COMPUTED POINTER
.I V S XEC="S X=$P($G(^("""_$P(X,";")_""")),""^"","_+V_") I X" D:A["V"
..S XEC=XEC_",$P(X,"";"",2)="""_$$CONVQQ^DILIBF($P(^DIC(GFTFILE,0,"GL"),U,2))_""""
.S XEC=I_XEC_" D PUT(+X,D0,"""_FIELD_""")"
XEC X XEC
Q
;
PUT(XVAL,Y,FIELD) I '$D(GFTIEN(GFTFILE,XVAL)) Q:$G(GFTANY)<2!($G(GFTANY)=4) ;ONLY WANT POINTERS TO CERTAIN ENTRIES
I $D(GFTFISCR) X GFTFISCR E Q ;FILE SCREEN!
N IENS,L,S S IENS=D0_"," F L=1:1 S S=$G(@("D"_L)) Q:S="" S IENS=S_","_$G(IENS)
S @GFTWHERE@(GFTFILE,XVAL,GFTF,Y,FIELD,IENS)=""
Q
;
;
ALL ;Do all files (SO)
D ^%ZIS U IO
N GFTFILE
S GFTFILE=1.99999
F S GFTFILE=$O(^DIC(GFTFILE)) Q:'GFTFILE D
. I GFTFILE=80.2 Q
. I GFTFILE=80.3 Q
. N GFTIEN,GFTANY,GFTALL
. S GFTIEN=0,GFTANY=3,GFTALL=1
. D START
.Q
;
D ^%ZISC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDGFTPT 4554 printed Sep 23, 2025@20:22:56 Page 2
DIDGFTPT ;GFT/GFT - GET ALL ENTRIES THAT POINT TO ENTRY GFTIEN IN FILE GFTFILE ;20 Aug 2015 4:46 PM
+1 ;;22.2;VA FileMan;**19**;Jan 05, 2016;Build 2
+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 ;
+7 WRITE !!,"THIS UTILITY TRIES TO FIND ALL ENTRIES IN ALL FILES POINTING TO A CERTAIN FILE",!
+8 DO DT^DICRW
+9 NEW DIC,DIR,X,Y,GFTIEN,GFTANY,GFTFILE,GFTALL,DIRUT,DIBT,GFTIENLIST
+10 KILL ^TMP($JOB)
+11 SET DIC=1
SET DIC(0)="AEQM"
DO ^DIC
if Y<0
QUIT
SET GFTFILE=+Y
SET GFTANY=$PIECE(^DIC(GFTFILE,0),U)
+12 SET DIR(0)="S^1:One particular "_GFTANY_" Entry;2:All "_GFTANY_" Entries;3:Non-existent "_GFTANY_" Entries"
+13 SET X=""
FOR
SET X=$ORDER(^DIBT("F"_GFTFILE,X))
if X=""
QUIT
FOR Y=0:0
SET Y=$ORDER(^DIBT("F"_GFTFILE,X,Y))
if 'Y
QUIT
IF $DATA(^DIBT(Y,1))>1
SET DIBT(Y)=""
+14 IF $ORDER(DIBT(0))
SET DIR(0)=DIR(0)_";4:Entries from a "_GFTANY_" Search Template"
+15 SET DIR("A")="Find pointers to"
+16 SET DIR("B")=$PIECE($PIECE(DIR(0),";",2),":",2)
+17 DO ^DIR
KILL DIR
if $GET(DIRUT)
QUIT
+18 IF Y=4
SET DIC=.401
SET DIC("S")="I $D(DIBT(+Y))"
SET GFTANY=Y
DO ^DIC
if Y'>0
QUIT
KILL DIBT,DIC
MERGE GFTIENLIST=^DIBT(+Y,1)
GOTO ZIS
+19 SET DIC=GFTFILE
SET DIC("A")="Find pointers to "_GFTANY_" Entry: "
SET GFTANY=Y
SET GFTIENLIST=0
+20 IF Y=1
DO ^DIC
if Y<0
QUIT
SET GFTIENLIST=+Y
ZIS DO ^%ZIS
if $GET(POP)
QUIT
USE IO
+1 WRITE !
SET $Y=0
START KILL DIC
+1 DO DEPEND(GFTFILE,.GFTIENLIST,,"M"_GFTANY)
+2 ;NOW WE HAVE ALL INFO
+3 SET GFTIEN=""
FOR
SET GFTIEN=$ORDER(^TMP($JOB,GFTFILE,GFTIEN))
if GFTIEN=""
QUIT
Begin DoDot:1
+4 SET X=$$GET1^DIQ(GFTFILE,GFTIEN,.01)
IF X]""
if GFTANY=3
QUIT
+5 IF '$TEST
SET X="NON-EXISTENT ENTRY # "_GFTIEN
+6 WRITE !!,"***",$PIECE(^DIC(GFTFILE,0),U),": "
WRITE X,"***"
+7 FOR I=0:0
if '$DATA(GFTIEN)
QUIT
SET I=$ORDER(^TMP($JOB,GFTFILE,GFTIEN,I))
if 'I
QUIT
WRITE !,"FILE ",I," (",$PIECE(^DIC(I,0),U),")"
FOR J=0:0
SET J=$ORDER(^TMP($JOB,GFTFILE,GFTIEN,I,J))
if 'J
QUIT
Begin DoDot:2
+8 SET Y=$ORDER(^(J,""))
+9 WRITE !?9,"`",J,?22,$$GET1^DIQ(I,J,.01)
+10 FOR
if Y=""
QUIT
if $X>(IOM-30)
WRITE !
WRITE ?IOM-30,$PIECE(@("^DD("_Y_",0)"),U)
SET Y=$ORDER(^TMP($JOB,GFTFILE,GFTIEN,I,J,Y))
+11 IF $EXTRACT($GET(IOST))="C"
IF $GET(IOSL,24)-3<$Y
SET DIR(0)="E"
DO ^DIR
SET $Y=0
IF 'Y
KILL GFTIEN
End DoDot:2
if '$DATA(GFTIEN)
QUIT
End DoDot:1
if '$DATA(GFTIEN)
QUIT
+12 KILL ^TMP($JOB)
+13 IF '$GET(GFTALL)
WRITE !!!
DO ^%ZISC
+14 QUIT
+15 ;
+16 ;
DEPEND(GFTFILE,IEN,GFTWHERE,GFTPARAM) ;
+1 IF $GET(GFTPARAM)["M"
NEW GFTANY
SET GFTANY=+$PIECE(GFTPARAM,"M",2)
+2 if $GET(GFTWHERE)=""
SET GFTWHERE=$NAME(^TMP($JOB))
+3 ;output array
KILL @GFTWHERE
+4 ;IEN can be either a scalar...
IF $DATA(IEN)<9
SET GFTIEN(GFTFILE,+IEN)=""
+5 ;...or an array
IF '$TEST
MERGE GFTIEN(GFTFILE)=IEN
+6 NEW A,B
+7 SET A=0
FOR
SET A=+$ORDER(^DD(GFTFILE,0,"PT",A))
if 'A
QUIT
Begin DoDot:1
+8 SET B=0
FOR
SET B=+$ORDER(^DD(GFTFILE,0,"PT",A,B))
if 'B
QUIT
Begin DoDot:2
+9 DO CHASE(A,B,.GFTRCR)
End DoDot:2
End DoDot:1
COMPUTED SET A=0
FOR
SET A=+$ORDER(^DD(GFTFILE,0,"PTC",A))
if 'A
QUIT
Begin DoDot:1
+1 SET B=0
FOR
SET B=+$ORDER(^DD(GFTFILE,0,"PTC",A,B))
if 'B
QUIT
Begin DoDot:2
+2 DO CHASE(A,B,.GFTRCR)
End DoDot:2
End DoDot:1
+3 QUIT
+4 ;
+5 ;
CHASE(FILE,FIELD,GFTRCR) ;BUILD AN 'XEC' THAT WILL GO THRU FILE REMEMBERING FIELD'S POINTERS
+1 ;NOT AUDIT FILES
IF FILE=.6!(FILE=1.1)
QUIT
+2 NEW GFTF,X,I,J,V,XEC,A,B,D0,D1,D2,D3,D4,D5,D6,D7,D8,D9,DICMX,DIDGFTPT,GFTFISCR
+3 ;want this defined for special FILE SCREENS
SET GFTF=FILE
SET L=0
SET PUT=""
SET DIDGFTPT=1
UP FOR
SET I=$GET(^DD(GFTF,0,"UP"))
if 'I
QUIT
SET L=L+1
SET X=$ORDER(^DD(I,"SB",GFTF,0))
if 'X
QUIT
SET J=$PIECE($GET(^DD(I,X,0)),U,4)
if J'[";0"
QUIT
SET GFTF=I
SET J(L)=$PIECE(J,";")
+1 if '$DATA(^DIC(GFTF,0,"GL"))
QUIT
SET J=^("GL")
SET I=""
+2 IF $GET(^DD(GFTF,0,"SCR"))]""
SET GFTFISCR=^("SCR")
+3 FOR A=L:-1:0
SET X="D"_(L-A)
SET PUT=PUT_"_D"_A_"_"","""
SET I=I_"F "_X_"=0:0 S "_X_"=$O("_J_X_")) Q:'"_X_" I $D(^("_X_",0)) "
IF A
SET J=J_X_","""_J(A)_""","
+4 ;NOW WE HAVE 'L' AS LEVEL AND 'I' AS 'L' FOR LOOPS
Begin DoDot:1
+5 SET X=$PIECE($GET(^DD(FILE,FIELD,0)),U,4)
if X=""
QUIT
SET A=$PIECE(^(0),U,2)
SET FIELD=FILE_","_FIELD
SET V=$PIECE(X,";",2)
+6 IF 'V
if A'["C"
QUIT
if A'["p"
QUIT
SET DICMX=$PIECE(^(0),U,5,99)
SET XEC="X DICMX I X"
IF A["m"
Begin DoDot:2
+7 ;m=MULTIPLE COMPUTED POINTER
SET XEC=I_"S DIDGFTPT=D0 "_DICMX
SET DICMX="D PUT^DIDGFTPT(+$G(D),DIDGFTPT,"""_FIELD_""")"
End DoDot:2
QUIT
+8 IF V
SET XEC="S X=$P($G(^("""_$PIECE(X,";")_""")),""^"","_+V_") I X"
if A["V"
Begin DoDot:2
+9 SET XEC=XEC_",$P(X,"";"",2)="""_$$CONVQQ^DILIBF($PIECE(^DIC(GFTFILE,0,"GL"),U,2))_""""
End DoDot:2
+10 SET XEC=I_XEC_" D PUT(+X,D0,"""_FIELD_""")"
End DoDot:1
if '$DATA(XEC)
QUIT
XEC XECUTE XEC
+1 QUIT
+2 ;
PUT(XVAL,Y,FIELD) ;ONLY WANT POINTERS TO CERTAIN ENTRIES
IF '$DATA(GFTIEN(GFTFILE,XVAL))
if $GET(GFTANY)<2!($GET(GFTANY)=4)
QUIT
+1 ;FILE SCREEN!
IF $DATA(GFTFISCR)
XECUTE GFTFISCR
IF '$TEST
QUIT
+2 NEW IENS,L,S
SET IENS=D0_","
FOR L=1:1
SET S=$GET(@("D"_L))
if S=""
QUIT
SET IENS=S_","_$GET(IENS)
+3 SET @GFTWHERE@(GFTFILE,XVAL,GFTF,Y,FIELD,IENS)=""
+4 QUIT
+5 ;
+6 ;
ALL ;Do all files (SO)
+1 DO ^%ZIS
USE IO
+2 NEW GFTFILE
+3 SET GFTFILE=1.99999
+4 FOR
SET GFTFILE=$ORDER(^DIC(GFTFILE))
if 'GFTFILE
QUIT
Begin DoDot:1
+5 IF GFTFILE=80.2
QUIT
+6 IF GFTFILE=80.3
QUIT
+7 NEW GFTIEN,GFTANY,GFTALL
+8 SET GFTIEN=0
SET GFTANY=3
SET GFTALL=1
+9 DO START
+10 QUIT
End DoDot:1
+11 ;
+12 DO ^%ZISC
+13 QUIT
