- DIDC ;SFISC/STAFF-CONDENSED DD ;26APR2010
- ;;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.
- ;
- TODAY S DM="",Y=DT,X="I $Y+3>IOSL W $C(7) D P" X ^DD("DD") S DAT=Y ;**CCO/NI TODAY'S DATE
- 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:"")
- AFOF I $D(^VA(200,"AFOF",N(0))) W !?10,"(NOTE: Kernel's File Access Security applies to this File.)",!
- 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_" " I ^(F,0) W:$X>24 !?19 W "(#"_^(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",""))]""
- SUBFILES M DPP=DIPP
- F Y="S","N","Q","H","L" D ;IF THERE ARE SUBTOTALS, ETC, ZERO THEM OUT
- .N C,V S C=Y_"(V)" F V=0:0 S V=$O(@C) Q:V="" S @C=0
- S L=0,DISEARCH=1,DFF=DIB,DJ=DIJS,DPQ=DIPQ,M=DIMS S:'$D(DIA) DC="," G ^DIO
- Q S DFF=DIB(1) G STOP^DIO4
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDC 3372 printed Feb 19, 2025@00:13:03 Page 2
- DIDC ;SFISC/STAFF-CONDENSED DD ;26APR2010
- +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 ;
- TODAY ;**CCO/NI TODAY'S DATE
- SET DM=""
- SET Y=DT
- SET X="I $Y+3>IOSL W $C(7) D P"
- XECUTE ^DD("DD")
- SET DAT=Y
- 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:"")
- AFOF IF $DATA(^VA(200,"AFOF",N(0)))
- WRITE !?10,"(NOTE: Kernel's File Access Security applies to this File.)",!
- +1 WRITE !,"CROSS REFERENCED BY:",!,?5
- +2 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
- +3 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
- +4 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 ^(F,0)
- if $X>24
- WRITE !?19
- WRITE "(#"_^(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
- SUBFILES MERGE DPP=DIPP
- +1 ;IF THERE ARE SUBTOTALS, ETC, ZERO THEM OUT
- FOR Y="S","N","Q","H","L"
- Begin DoDot:1
- +2 NEW C,V
- SET C=Y_"(V)"
- FOR V=0:0
- SET V=$ORDER(@C)
- if V=""
- QUIT
- SET @C=0
- End DoDot:1
- +3 SET L=0
- 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