- 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 Feb 19, 2025@00:13:05 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