DIDC ;SFISC-CONDENSED DD ;10:02 AM 4 Mar 2002 [ 12/09/2003 4:48 PM ]
;;22.0;VA FileMan;**19,105,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
S DM="",DAT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),X="I $Y+3>IOSL W $C(7) D P"
EN S N(0)=$O(^DD(X1),-1),I=0 F S N(0)=$O(^DD(N(0))) Q:N(0)'>0!(N(0)>X2) S NAME=$O(^DD(N(0),0,"NM",0)) I NAME'="" S P=0 D P,P2 G:DM["^" EXIT
EXIT K %DT,%ZIS,DAT,I,J,K,K1,M,N,N1,NAME,MO,P,X,X1,X2,Y,KK,NF,NY,POP S D0="B",M=DM K DM Q
P S P=P+1 I IOST?1"C-".E R:P'=1 DM:DTIME Q:DM["^"!'$T
W:$D(DIFF)&($Y) @IOF S DIFF=1 W !!,"CONDENSED DATA DICTIONARY---",NAME," FILE"," (#",N(0),")" I $D(^%ZOSF("UCI"))#2 X ^("UCI") W ?47,"UCI: "_Y
W ?63,$S($G(^DD(N(0),0,"VR"))]"":" VERSION: "_$P(^("VR"),U),1:" ") W !!,"STORED IN: ",$S($D(^DIC(N(0),0,"GL")):^("GL"),1:""),?58,DAT,?70,"PAGE ",P W ! F I=0:1:IOM-1 W "-"
G P1:P'=1 W !!,?50,"FILE SECURITY"
W !,?35,"DD SECURITY : ",$S($D(^DIC(N(0),0,"DD")):^("DD"),1:""),?58,"DELETE SECURITY: ",$S($D(^("DEL")):^("DEL"),1:"")
W !,?35,"READ SECURITY : ",$S($D(^("RD")):^("RD"),1:""),?58,"LAYGO SECURITY : ",$S($D(^("LAYGO")):^("LAYGO"),1:"")
W !,?35,"WRITE SECURITY : ",$S($D(^("WR")):^("WR"),1:"")
I $D(^VA(200,"AFOF")) W !?10,"(NOTE: Kernel's File Access Security has been installed in this UCI.)",!
W !,"CROSS REFERENCED BY:",!,?5
S NY="" F KK=1:1 S NY=$O(^DD(N(0),0,"IX",NY)) Q:NY="" S NF=+$O(^(NY,0)),N1=+$O(^(NF,0)) D
.N % S %=0 F S %=$O(^DD(NF,N1,1,%)) Q:'% I $D(^(%,0)),+^(0)=N(0),$P(^(0),U,2)=NY W:$X>50&($L($P(^DD(NF,N1,0),"^",1)>20)) !,?5 W " ",$P(^DD(NF,N1,0),"^",1),"(",NY,") "
D LIST^DIKCP(N(0),"","M")
P1 W !!!,?33,"FILE STRUCTURE",!! W "FIELD",?10,"FIELD",!,"NUMBER",?10,"NAME",! Q
P2 S M(0)=0 F K1=0:0 S M(0)=$O(^DD(N(0),M(0))),K=0 Q:+M(0)'>0!(M(0)?1U.U) X X Q:DM["^" W !,M(0),?10,$P(^DD(N(0),M(0),0),U,1)," " D M I J S K=K+1 D MO Q:DM["^"
Q
MO X X Q:DM["^" S N(K)=+$P(^DD(N(K-1),M(K-1),0),U,2) S M(K)=0
F L=0:0 S M(K)=$O(^DD(N(K),M(K))) Q:M(K)'>0 X X Q:DM["^" W !,?10+((K-1)*5),M(K),?15+((K-1)*5),$P(^DD(N(K),M(K),0),U,1)," " D M I J S K=K+1 D MO Q:DM["^"
Q:DM["^" X X Q:DM["^" S K=K-1 Q
M S J=$P(^(0),U,2) W $S(+J:"(Multiple-"_+J,1:"("_J),"), [",$P(^(0),U,4),"]"
Q
PTR ;
S F=0,I=0 F S F=$O(^UTILITY($J,"P",F)) Q:F="" D PT
S F=-1 Q
PT W !,F_" " W:$X>24 !?19 W "(#"_^(F,0)_") "
S %=0 F S %=$O(^UTILITY($J,"P",F,%)) Q:%="" W ?33," ",$S(%=F(1):"",1:$P(^DD(%,0)," SUB-FIELD",1)_":") S S=0 F S S=$O(^UTILITY($J,"P",F,%,S)) Q:S="" W ?34,$P(^DD(%,S,0),U)," (#"_S_")",!
S (%,S)=-1 Q
;
L ; CUSTOM LOOP
I $G(Y)=U!($G(M)=U) G Q
I DJ,IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T G Q
K ^UTILITY($J,0)
DD S DIB=$O(^DD(+DIB)) G:DIB>DIB(1)!(+DIB'=DIB) Q G:$D(^(DIB,0))[0 DD
I $G(DIPP(0,"IX"))["^DD(DFF,""AUDIT""",$O(^DD(DIB,"AUDIT",""))="" G DD:'$D(^DIC(DIB)) D G:'DIB!(DIB>DIB(1)) Q
. F S DIB=$O(^DIC(+DIB)) Q:'DIB!(DIB>DIB(1)) Q:$O(^DD(DIB,"AUDIT",""))]""
S %X="DIPP(",%Y="DPP(" D %XY^%RCR S DPP=DIPP,L=0
S DISEARCH=1,DFF=DIB,DJ=DIJS,DPQ=DIPQ,M=DIMS S:'$D(DIA) DC="," G ^DIO
Q S DFF=DIB(1) G STOP^DIO4
DIDC ;SFISC-CONDENSED DD ;10:02 AM 4 Mar 2002 [ 12/09/2003 4:48 PM ]
+1 ;;22.0;VA FileMan;**19,105,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET DM=""
SET DAT=$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
SET X="I $Y+3>IOSL W $C(7) D P"
EN SET N(0)=$ORDER(^DD(X1),-1)
SET I=0
FOR
SET N(0)=$ORDER(^DD(N(0)))
IF N(0)'>0!(N(0)>X2)
QUIT
SET NAME=$ORDER(^DD(N(0),0,"NM",0))
IF NAME'=""
SET P=0
DO P
DO P2
IF DM["^"
GOTO EXIT
EXIT KILL %DT,%ZIS,DAT,I,J,K,K1,M,N,N1,NAME,MO,P,X,X1,X2,Y,KK,NF,NY,POP
SET D0="B"
SET M=DM
KILL DM
QUIT
P SET P=P+1
IF IOST?1"C-".E
IF P'=1
READ DM:DTIME
IF DM["^"!'$TEST
QUIT
+1 IF $DATA(DIFF)&($Y)
WRITE @IOF
SET DIFF=1
WRITE !!,"CONDENSED DATA DICTIONARY---",NAME," FILE"," (#",N(0),")"
IF $DATA(^%ZOSF("UCI"))#2
XECUTE ^("UCI")
WRITE ?47,"UCI: "_Y
+2 WRITE ?63,$SELECT($GET(^DD(N(0),0,"VR"))]"":" VERSION: "_$PIECE(^("VR"),U),1:" ")
WRITE !!,"STORED IN: ",$SELECT($DATA(^DIC(N(0),0,"GL")):^("GL"),1:""),?58,DAT,?70,"PAGE ",P
WRITE !
FOR I=0:1:IOM-1
WRITE "-"
+3 IF P'=1
GOTO P1
WRITE !!,?50,"FILE SECURITY"
+4 WRITE !,?35,"DD SECURITY : ",$SELECT($DATA(^DIC(N(0),0,"DD")):^("DD"),1:""),?58,"DELETE SECURITY: ",$SELECT($DATA(^("DEL")):^("DEL"),1:"")
+5 WRITE !,?35,"READ SECURITY : ",$SELECT($DATA(^("RD")):^("RD"),1:""),?58,"LAYGO SECURITY : ",$SELECT($DATA(^("LAYGO")):^("LAYGO"),1:"")
+6 WRITE !,?35,"WRITE SECURITY : ",$SELECT($DATA(^("WR")):^("WR"),1:"")
+7 IF $DATA(^VA(200,"AFOF"))
WRITE !?10,"(NOTE: Kernel's File Access Security has been installed in this UCI.)",!
+8 WRITE !,"CROSS REFERENCED BY:",!,?5
+9 SET NY=""
FOR KK=1:1
SET NY=$ORDER(^DD(N(0),0,"IX",NY))
IF NY=""
QUIT
SET NF=+$ORDER(^(NY,0))
SET N1=+$ORDER(^(NF,0))
Begin DoDot:1
+10 NEW %
SET %=0
FOR
SET %=$ORDER(^DD(NF,N1,1,%))
IF '%
QUIT
IF $DATA(^(%,0))
IF +^(0)=N(0)
IF $PIECE(^(0),U,2)=NY
IF $X>50&($LENGTH($PIECE(^DD(NF,N1,0),"^",1)>20))
WRITE !,?5
WRITE " ",$PIECE(^DD(NF,N1,0),"^",1),"(",NY,") "
End DoDot:1
+11 DO LIST^DIKCP(N(0),"","M")
P1 WRITE !!!,?33,"FILE STRUCTURE",!!
WRITE "FIELD",?10,"FIELD",!,"NUMBER",?10,"NAME",!
QUIT
P2 SET M(0)=0
FOR K1=0:0
SET M(0)=$ORDER(^DD(N(0),M(0)))
SET K=0
IF +M(0)'>0!(M(0)?1U.U)
QUIT
XECUTE X
IF DM["^"
QUIT
WRITE !,M(0),?10,$PIECE(^DD(N(0),M(0),0),U,1)," "
DO M
IF J
SET K=K+1
DO MO
IF DM["^"
QUIT
+1 QUIT
MO XECUTE X
IF DM["^"
QUIT
SET N(K)=+$PIECE(^DD(N(K-1),M(K-1),0),U,2)
SET M(K)=0
+1 FOR L=0:0
SET M(K)=$ORDER(^DD(N(K),M(K)))
IF M(K)'>0
QUIT
XECUTE X
IF DM["^"
QUIT
WRITE !,?10+((K-1)*5),M(K),?15+((K-1)*5),$PIECE(^DD(N(K),M(K),0),U,1)," "
DO M
IF J
SET K=K+1
DO MO
IF DM["^"
QUIT
+2 IF DM["^"
QUIT
XECUTE X
IF DM["^"
QUIT
SET K=K-1
QUIT
M SET J=$PIECE(^(0),U,2)
WRITE $SELECT(+J:"(Multiple-"_+J,1:"("_J),"), [",$PIECE(^(0),U,4),"]"
+1 QUIT
PTR ;
+1 SET F=0
SET I=0
FOR
SET F=$ORDER(^UTILITY($JOB,"P",F))
IF F=""
QUIT
DO PT
+2 SET F=-1
QUIT
PT WRITE !,F_" "
IF $X>24
WRITE !?19
WRITE "(#"_^(F,0)_") "
+1 SET %=0
FOR
SET %=$ORDER(^UTILITY($JOB,"P",F,%))
IF %=""
QUIT
WRITE ?33," ",$SELECT(%=F(1):"",1:$PIECE(^DD(%,0)," SUB-FIELD",1)_":")
SET S=0
FOR
SET S=$ORDER(^UTILITY($JOB,"P",F,%,S))
IF S=""
QUIT
WRITE ?34,$PIECE(^DD(%,S,0),U)," (#"_S_")",!
+2 SET (%,S)=-1
QUIT
+3 ;
L ; CUSTOM LOOP
+1 IF $GET(Y)=U!($GET(M)=U)
GOTO Q
+2 IF DJ
IF IOST?1"C-".E
WRITE $CHAR(7)
READ X:DTIME
IF X[U!'$TEST
GOTO Q
+3 KILL ^UTILITY($JOB,0)
DD SET DIB=$ORDER(^DD(+DIB))
IF DIB>DIB(1)!(+DIB'=DIB)
GOTO Q
IF $DATA(^(DIB,0))[0
GOTO DD
+1 IF $GET(DIPP(0,"IX"))["^DD(DFF,""AUDIT"""
IF $ORDER(^DD(DIB,"AUDIT",""))=""
IF '$DATA(^DIC(DIB))
GOTO DD
Begin DoDot:1
+2 FOR
SET DIB=$ORDER(^DIC(+DIB))
IF 'DIB!(DIB>DIB(1))
QUIT
IF $ORDER(^DD(DIB,"AUDIT",""))]""
QUIT
End DoDot:1
IF 'DIB!(DIB>DIB(1))
GOTO Q
+3 SET %X="DIPP("
SET %Y="DPP("
DO %XY^%RCR
SET DPP=DIPP
SET L=0
+4 SET DISEARCH=1
SET DFF=DIB
SET DJ=DIJS
SET DPQ=DIPQ
SET M=DIMS
IF '$DATA(DIA)
SET DC=","
GOTO ^DIO
Q SET DFF=DIB(1)
GOTO STOP^DIO4
