DIDH ;SFISC/GFT,XAK-HDR FOR DD LISTS ;13SEP2010
;;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.
;
D ^DIDH1 I $G(M)=U S DN=0
Q K DDV,%F,M1 Q
;
;
XR S X=2,J=0,DG=F(Z) W:$Y !
XL S J=$O(^DD(DA,0,"IX",J)) I J="" S F(Z)=DG Q
F K=0:0 S K=$O(^DD(DA,0,"IX",J,K)) G XL:K'>0 F N=0:0 S N=$O(^DD(DA,0,"IX",J,K,N)) Q:N'>0 I 1 S F(Z)=K,DJ(Z)=N X:$D(DIGR) DIGR D:$T XL1
XL1 F %=0:0 S %=$O(^DD(K,N,1,%)) Q:'%!(M=U) I $D(^(%,0)),+^(0)=DA,$P(^(0),U,2)=J W:X=2 !,"CROSS",! W $P(", ^REFERENCED BY: ",U,X) S X=$P(^DD(K,N,0),U)_"("_J_")" W:($L(X)+$X+4)'<IOM !?15 W X S X=1 Q:$Y+4'>IOSL I '$D(DIU) D H S X=2
Q
;
;
;
POINT ; CALLED BY ^DD(1,.01,"DEL",.5,0)
N W1,DDPT,DDC,DDV,X1 S M=""
S W1="W:$Y ! W !,""POINTED TO BY: "",?15" I $O(^DD(DA,0,"PT",""))'="" S DDPT=1
S X="" F S X=$O(^DD(DA,0,"PT",X)) Q:X="" S DG=0 F S DG=$O(^DD(DA,0,"PT",X,DG)) Q:DG="" D W:$D(^DD(DA,0,"PT",X,DG)) !?15 I '$D(DIU) D H G Q:M=U
.I $S('$D(^DD(X,DG,0)):1,$P(^(0),U,2)["V":0,1:$P($P(^(0),U,2),"P",2)-DA) K ^DD(DA,0,"PT",X,DG) Q
.D PD
S W1="W:$Y ! W !,""POINTED TO BY COMPUTED POINTER: "",!?15" I $O(^DD(DA,0,"PTC",""))'="" S DDPT=1
S X="" F S X=$O(^DD(DA,0,"PTC",X)) Q:X="" S DG=0 F S DG=$O(^DD(DA,0,"PTC",X,DG)) Q:DG="" D W:$D(^DD(DA,0,"PTC",X,DG)) !?15 I '$D(DIU) D H G Q:M=U
.S %=$P($G(^DD(X,DG,0)),U,2) I $P(%,"Cp",2)-DA,$P(%,"mp",2)-DA K ^DD(DA,0,"PTC",X,DG) Q
.D PD
S (DG,X)=-1 K W1,DDPT Q
;
PD ;
S %=X,%F=DG
WR I '$D(IOM) S IOP="HOME" N %X D ^%ZIS Q:POP
I $D(DDPT) X W1 K DDPT
S X1=$P(^DD(%,%F,0),U)_" field (#"_%F_")"
UP I $L(X1)+$L(%)+$L($O(^DD(%,0,"NM",0)))>225 S X1=X1_" etc... ^" G L1
S X1=X1_" of the "_$O(^(0))
I $D(^DD(%,0,"UP")) S X1=X1_" sub-field (#"_%_")",%=^("UP") G UP
S X1=X1_" File (#"_%_") ^"
L1 F DDC=1:1 S DDV=$P(X1," ",DDC)_" " Q:DDV["^" W:$L(DDV)+$X>IOM !,?19 W DDV
K DDC,DDV,X1 Q
;
TRIG ;CALLED BY ^DD(1,.01,"DEL","TRB",0)
S W1="W:$Y ! W !,""A FIELD IS"",!,""TRIGGERED BY :"",?15",DDPT=1
K X S X="" F S X=$O(^DD(DA,"TRB",X)) Q:X="" I X-DA,'$D(^DD(DA,"SB",X)) S %=0 F S %=$O(^DD(DA,"TRB",X,%)) Q:%="" S %X=0 F S %X=$O(^DD(DA,"TRB",X,%,%X)) Q:%X="" S %Y=0 F S %Y=$O(^DD(DA,"TRB",X,%,%X,%Y)) Q:%Y'>0 D TT
S %Y=-1 I $D(X)>9 S %X=0 F S %X=$O(X(%X)) Q:%X="" S X=0 F S X=$O(X(%X,X)) Q:X="" S %F=X,%=%X D WR:$D(^DD(%,X,0)) W !?15 D:'$D(DIU) H I 1
K X,%X,%Y,W1,DDPT Q
;
TT S X(X,%)=0 I $D(^DD(X,%,0)) Q:$P(^(0),U,2) I $D(^(1,%X,0)),^(0)["TRIGGER" Q
K X(X,%),^DD(DA,"TRB",X,%,%X,%Y)
Q
H I $D(IOSL),$Y+4>IOSL S DC=DC+1 D ^DIDH1 G Q:M=U
Q
W F K=0:1 W:$D(DDF) !?25 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y,DDF=1
K DDF Q
PTR(X) ;finds pointers to file being deleted
N Y,Z S (Y,Z)=0
I $O(^DD(X,0,"PT",Y))="" Q Z
D Q Z
. F S Y=$O(^DD(X,0,"PT",Y)) Q:Y="" I $$FNO^DILIBF(Y)'=X S Z=1 Q
. Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDH 3054 printed Dec 13, 2024@02:46:51 Page 2
DIDH ;SFISC/GFT,XAK-HDR FOR DD LISTS ;13SEP2010
+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 ;
+7 DO ^DIDH1
IF $GET(M)=U
SET DN=0
Q KILL DDV,%F,M1
QUIT
+1 ;
+2 ;
XR SET X=2
SET J=0
SET DG=F(Z)
if $Y
WRITE !
XL SET J=$ORDER(^DD(DA,0,"IX",J))
IF J=""
SET F(Z)=DG
QUIT
+1 FOR K=0:0
SET K=$ORDER(^DD(DA,0,"IX",J,K))
if K'>0
GOTO XL
FOR N=0:0
SET N=$ORDER(^DD(DA,0,"IX",J,K,N))
if N'>0
QUIT
IF 1
SET F(Z)=K
SET DJ(Z)=N
if $DATA(DIGR)
XECUTE DIGR
if $TEST
DO XL1
XL1 FOR %=0:0
SET %=$ORDER(^DD(K,N,1,%))
if '%!(M=U)
QUIT
IF $DATA(^(%,0))
IF +^(0)=DA
IF $PIECE(^(0),U,2)=J
if X=2
WRITE !,"CROSS",!
WRITE $PIECE(", ^REFERENCED BY: ",U,X)
SET X=$PIECE(^DD(K,N,0),U)_"("_J_")"
if ($LENGTH(X)+$X+4)'<IOM
WRITE !?15
WRITE X
SET X=1
if $Y+4'>IOSL
QUIT
IF '$DATA(DIU)
DO H
SET X=2
+1 QUIT
+2 ;
+3 ;
+4 ;
POINT ; CALLED BY ^DD(1,.01,"DEL",.5,0)
+1 NEW W1,DDPT,DDC,DDV,X1
SET M=""
+2 SET W1="W:$Y ! W !,""POINTED TO BY: "",?15"
IF $ORDER(^DD(DA,0,"PT",""))'=""
SET DDPT=1
+3 SET X=""
FOR
SET X=$ORDER(^DD(DA,0,"PT",X))
if X=""
QUIT
SET DG=0
FOR
SET DG=$ORDER(^DD(DA,0,"PT",X,DG))
if DG=""
QUIT
Begin DoDot:1
+4 IF $SELECT('$DATA(^DD(X,DG,0)):1,$PIECE(^(0),U,2)["V":0,1:$PIECE($PIECE(^(0),U,2),"P",2)-DA)
KILL ^DD(DA,0,"PT",X,DG)
QUIT
+5 DO PD
End DoDot:1
if $DATA(^DD(DA,0,"PT",X,DG))
WRITE !?15
IF '$DATA(DIU)
DO H
if M=U
GOTO Q
+6 SET W1="W:$Y ! W !,""POINTED TO BY COMPUTED POINTER: "",!?15"
IF $ORDER(^DD(DA,0,"PTC",""))'=""
SET DDPT=1
+7 SET X=""
FOR
SET X=$ORDER(^DD(DA,0,"PTC",X))
if X=""
QUIT
SET DG=0
FOR
SET DG=$ORDER(^DD(DA,0,"PTC",X,DG))
if DG=""
QUIT
Begin DoDot:1
+8 SET %=$PIECE($GET(^DD(X,DG,0)),U,2)
IF $PIECE(%,"Cp",2)-DA
IF $PIECE(%,"mp",2)-DA
KILL ^DD(DA,0,"PTC",X,DG)
QUIT
+9 DO PD
End DoDot:1
if $DATA(^DD(DA,0,"PTC",X,DG))
WRITE !?15
IF '$DATA(DIU)
DO H
if M=U
GOTO Q
+10 SET (DG,X)=-1
KILL W1,DDPT
QUIT
+11 ;
PD ;
+1 SET %=X
SET %F=DG
WR IF '$DATA(IOM)
SET IOP="HOME"
NEW %X
DO ^%ZIS
if POP
QUIT
+1 IF $DATA(DDPT)
XECUTE W1
KILL DDPT
+2 SET X1=$PIECE(^DD(%,%F,0),U)_" field (#"_%F_")"
UP IF $LENGTH(X1)+$LENGTH(%)+$LENGTH($ORDER(^DD(%,0,"NM",0)))>225
SET X1=X1_" etc... ^"
GOTO L1
+1 SET X1=X1_" of the "_$ORDER(^(0))
+2 IF $DATA(^DD(%,0,"UP"))
SET X1=X1_" sub-field (#"_%_")"
SET %=^("UP")
GOTO UP
+3 SET X1=X1_" File (#"_%_") ^"
L1 FOR DDC=1:1
SET DDV=$PIECE(X1," ",DDC)_" "
if DDV["^"
QUIT
if $LENGTH(DDV)+$X>IOM
WRITE !,?19
WRITE DDV
+1 KILL DDC,DDV,X1
QUIT
+2 ;
TRIG ;CALLED BY ^DD(1,.01,"DEL","TRB",0)
+1 SET W1="W:$Y ! W !,""A FIELD IS"",!,""TRIGGERED BY :"",?15"
SET DDPT=1
+2 KILL X
SET X=""
FOR
SET X=$ORDER(^DD(DA,"TRB",X))
if X=""
QUIT
IF X-DA
IF '$DATA(^DD(DA,"SB",X))
SET %=0
FOR
SET %=$ORDER(^DD(DA,"TRB",X,%))
if %=""
QUIT
SET %X=0
FOR
SET %X=$ORDER(^DD(DA,"TRB",X,%,%X))
if %X=""
QUIT
SET %Y=0
FOR
SET %Y=$ORDER(^DD(DA,"TRB",X,%,%X,%Y))
if %Y'>0
QUIT
DO TT
+3 SET %Y=-1
IF $DATA(X)>9
SET %X=0
FOR
SET %X=$ORDER(X(%X))
if %X=""
QUIT
SET X=0
FOR
SET X=$ORDER(X(%X,X))
if X=""
QUIT
SET %F=X
SET %=%X
if $DATA(^DD(%,X,0))
DO WR
WRITE !?15
if '$DATA(DIU)
DO H
IF 1
+4 KILL X,%X,%Y,W1,DDPT
QUIT
+5 ;
TT SET X(X,%)=0
IF $DATA(^DD(X,%,0))
if $PIECE(^(0),U,2)
QUIT
IF $DATA(^(1,%X,0))
IF ^(0)["TRIGGER"
QUIT
+1 KILL X(X,%),^DD(DA,"TRB",X,%,%X,%Y)
+2 QUIT
H IF $DATA(IOSL)
IF $Y+4>IOSL
SET DC=DC+1
DO ^DIDH1
if M=U
GOTO Q
+1 QUIT
W FOR K=0:1
if $DATA(DDF)
WRITE !?25
SET %Y=$EXTRACT(W,IOM-$X,999)
WRITE $EXTRACT(W,1,IOM-$X-1)
if %Y=""
QUIT
SET W=%Y
SET DDF=1
+1 KILL DDF
QUIT
PTR(X) ;finds pointers to file being deleted
+1 NEW Y,Z
SET (Y,Z)=0
+2 IF $ORDER(^DD(X,0,"PT",Y))=""
QUIT Z
+3 Begin DoDot:1
+4 FOR
SET Y=$ORDER(^DD(X,0,"PT",Y))
if Y=""
QUIT
IF $$FNO^DILIBF(Y)'=X
SET Z=1
QUIT
+5 QUIT
End DoDot:1
QUIT Z
