- 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 Jan 18, 2025@03:47:50 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