DIDH1 ;SFISC/ALL - HDR FOR DD LISTS;16NOV2012
;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
;;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.
;
N DIDHI,DIDHJ,DIC,W,M1 D
.N I,J D IJ^DIUTL(DFF) M DIDHJ=J,DIDHI=I S DIDHJ=$O(J(""),-1)
S M=1 I DC=1 S (F(1),DA)=DFF,Z=1
E I $Y,IOST?1"C".E W $C(7) R M:DTIME I M=U!'$T K DIOEND S M=U,DN=0 Q
S M1=$S($G(^DD(F(1),0,"VR"))]"":" (VERSION "_$P(^("VR"),U)_") ",1:"") I IOST?1"C".E S DIFF=1
W:$D(DIFF)&($Y) @IOF S DIFF=1 W $S(DHIT["DIDX":"BRIEF",DHIT["DIDG":"GLOBAL MAP",$D(DINM):"MODIFIED",1:"STANDARD")
W " DATA DICTIONARY #"_DFF_" -- "_$O(^DD(DFF,0,"NM",0))_" "_$S(DIDHJ:"SUB-",1:"")_"FILE "
S DIC=^DIC(DUB,0,"GL") D
.N X,Y
TODAY .S W=$$OUT^DIALOGU(DT,"FMTE","2D")_" "_$$EZBLD^DIALOG(7095,DC) W ?(IOM-$L(W)-1),W ;**CCO/NI TODAY'S DATE, 'PAGE'
S M=IOM\2,S=" ",W="" I $D(^DD("SITE")) S W="SITE: "_^("SITE")_" "
I $D(^%ZOSF("UCI"))#2 X ^("UCI") S W=W_"UCI: "_Y
W ! I DHIT["DIDX" W W,?(IOM-$L(M1)-1),M1 S W="",$P(W,"-",IOM)="" W !,W S W="" G Q^DIDH
W "STORED IN ",DIC F I=1:1 Q:'$D(DIDHI(I)) W "D",I-1,",",DIDHI(I),","
I 'DIDHJ D
.I $O(@(DIC_"0)"))'>0 W " *** NO DATA STORED YET ***" Q
.S I=$P(^(0),U,4) W:I " ("_I_" ENTR"_$S(I=1:"Y)",1:"IES)")
W " ",W,?(IOM-$L(M1)-1),M1 D:DHIT'["DIDG"
.W !!,"DATA",?14,"NAME",?36,"GLOBAL",?50,"DATA",!,"ELEMENT",?14,"TITLE",?36,"LOCATION",?50,"TYPE"
G W ! F I=1:1:IOM-1 W "-"
S W="" Q:DC>1!$G(DIDRANGE)
FIRST F DG=0:0 S DG=$O(^DIC(DA,"ALANG",DG)) Q:'DG I $D(^(DG,0)) S DIWR=$P(^(0),U) I $D(^DI(.85,DG,0)) W !,$P(^(0),U)," FILE NAME: ",DIWR ;**SHOW FOREIGN FILE NAMES
PAGE1 I 'DIDHJ,'$$WP^DIUTL($NA(^DIC(DA,"%D"))) S M="^" Q
I DIDHJ D I M=U Q
.S W=DIDHJ(DIDHJ-1),W=$NA(^DD(W,+$O(^DD(W,"SB",DFF,"")))) I '$$WP^DIUTL($NA(@W@(21))) S M=U Q
.I $D(@W@(23)) W !,"TECHNICAL DESCRIPTION:",! I '$$WP^DIUTL($NA(@W@(23))) S M=U
.F I=8,9 I $D(@W@(I)) W !,?15,$P("READ^WRITE",U,I-7)," ACCESS: ",^(I)
I DHIT["DIDG" D Q
. D XR^DIDH Q:M=U
. N DIDPG S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
. D LIST^DIKCP(DA,"","C15",.DIDPG) Q:M=U
. D WRLN^DIKCP1("",0,.DIDPG)
Q:DHIT["DIDX"!(M=U) W !
F %=1:1:4 S X=$P("SCR^DIC^ACT^DIK",U,%) I $G(^DD(DA,0,X))]"" W !,$P("FILE SCREEN (SCR-node) ^SPECIAL LOOKUP ROUTINE ^POST-SELECTION ACTION ^COMPILED CROSS-REFERENCE ROUTINE",U,%)_": " S W=^(X) D W^DIDH G Q:M=U
W:$P($G(^DD(DA,0,"DI")),U)["Y" !,"THIS IS AN ARCHIVE FILE."
W:$P($G(^DD(DA,0,"DI")),U,2)["Y" !,"EDITING OF FILE IS NOT ALLOWED."
F N="DD","RD","WR","DEL","LAYGO","AUDIT" I $D(^DIC(DA,0,N)) W !?(Z+Z+14-$L(N)),N," ACCESS: ",^(N)
I $O(^DIC(DA,"%",0)) W !!?3,"APPLICATION GROUP(S): " S (%,N)=0 F S N=$O(^DIC(DA,"%",N)) Q:'N S X=$G(^(N,0)) D:X]"" ;p14
. I ($L(X)+$X)+1>IOM W ",",!?25 S %=0
. W $S(%:", ",1:""),X S %=%+1
AFOF I $D(^VA(200,"AFOF",DA)) W !!?8,"(NOTE: Kernel's File Access Security applies to this File.)",!
I $O(^DD(DA,0,"ID",""))]"" W !,"IDENTIFIED BY: "
S X=0 F S X=$O(^DD(DA,0,"ID",X)) Q:X="" Q:'$D(^DD(DA,X,0)) S I1=$P(^(0),U)_" (#"_X_")"_$S($P(^(0),U,2)["R":"[R]",1:"") W:($L(I1)+$X)+1>IOM ! W ?15,I1 I $O(^DD(DA,0,"ID",X)) W ", "
S:X="" X=-1
;
;Print "WRITE" identifiers
I '$D(DINM) S X=" " F S X=$O(^DD(DA,0,"ID",X)) Q:X="" D Q:M=U
. N DIDLN,DIDPG
. S DIDLN(1)=$G(^DD(DA,0,"ID",X)) Q:DIDLN(1)?."^"
. S DIDLN(0)=""""_X_""": "
. S DIDLN(0)=$J("",15-$L(DIDLN(0)))_DIDLN(0)
. S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
. D WRPHI^DIKCP1(.DIDLN,IOM-16,0,15,1,.DIDPG)
Q:M=U
;
I $D(^DD("KEY","B",DA)) D
. N DIDPG
. S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
. D PRINT^DIKKP(DA,"","C20",.DIDPG)
D POINT^DIDH Q:M=U D TRIG^DIDH,XR^DIDH Q:M=U
I $D(^DD("IX","B",DA)) D Q:M=U W !
. N DIDPG
. S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
. D LIST^DIKCP(DA,"","C15",.DIDPG)
CREATED W !! S N=$G(^DIC(DA,"%A")),Y=$P(N,U,2) I Y X ^DD("DD") W ?3,"CREATED ON: "_Y I $S($D(^VA(200,0)):1,1:$D(^DIC(3,0))),^(0)["NEW PERSON"!(^(0)["USER")!(^(0)["EMPLOY"),$D(^(+N,0)) W " by "_$P(^(0),U)
S Y=+$G(^DIC(DA,"%MSC")) I Y X ^DD("DD") W " LAST MODIFIED: "_Y
Q Q
W W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5<M:IOM-5-$L(W),1:M),S S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1),S Q:%Y="" S W=%Y G W
Q
WR ;
S W="TRIGGERED by the "_$P(^(0),U)_" field"
UP1 S W=W_" of the "_$O(^DD(%,0,"NM",0))
I $D(^DD(%,0,"UP")) S %=^("UP") S W=W_" sub-field" G UP1
S W=W_" File"
W1 S DDV1="" W ?DDL2 F K=1:1 S DDV=$P(W," ",K)_" ",DDV1=DDV1_DDV W:$L(DDV)+$X>IOM !?DDL2 W DDV Q:$L(DDV1)>$L(W)
I $Y+6>IOSL S DC=DC+1 D DIDH1
K DDV,DDV1 Q
DE ;
W !?DDL1,$P("DESCRIPTION:^TECHNICAL DESCR:",U,%Y=23+1)
I '$$WP^DIUTL($NA(^DD(F(Z),DJ(Z),%Y)),DDL2+1) S M="^"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDH1 4867 printed Jan 18, 2025@03:47:51 Page 2
DIDH1 ;SFISC/ALL - HDR FOR DD LISTS;16NOV2012
+1 ;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
+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 NEW DIDHI,DIDHJ,DIC,W,M1
Begin DoDot:1
+8 NEW I,J
DO IJ^DIUTL(DFF)
MERGE DIDHJ=J,DIDHI=I
SET DIDHJ=$ORDER(J(""),-1)
End DoDot:1
+9 SET M=1
IF DC=1
SET (F(1),DA)=DFF
SET Z=1
+10 IF '$TEST
IF $Y
IF IOST?1"C".E
WRITE $CHAR(7)
READ M:DTIME
IF M=U!'$TEST
KILL DIOEND
SET M=U
SET DN=0
QUIT
+11 SET M1=$SELECT($GET(^DD(F(1),0,"VR"))]"":" (VERSION "_$PIECE(^("VR"),U)_") ",1:"")
IF IOST?1"C".E
SET DIFF=1
+12 if $DATA(DIFF)&($Y)
WRITE @IOF
SET DIFF=1
WRITE $SELECT(DHIT["DIDX":"BRIEF",DHIT["DIDG":"GLOBAL MAP",$DATA(DINM):"MODIFIED",1:"STANDARD")
+13 WRITE " DATA DICTIONARY #"_DFF_" -- "_$ORDER(^DD(DFF,0,"NM",0))_" "_$SELECT(DIDHJ:"SUB-",1:"")_"FILE "
+14 SET DIC=^DIC(DUB,0,"GL")
Begin DoDot:1
+15 NEW X,Y
TODAY ;**CCO/NI TODAY'S DATE, 'PAGE'
SET W=$$OUT^DIALOGU(DT,"FMTE","2D")_" "_$$EZBLD^DIALOG(7095,DC)
WRITE ?(IOM-$LENGTH(W)-1),W
End DoDot:1
+1 SET M=IOM\2
SET S=" "
SET W=""
IF $DATA(^DD("SITE"))
SET W="SITE: "_^("SITE")_" "
+2 IF $DATA(^%ZOSF("UCI"))#2
XECUTE ^("UCI")
SET W=W_"UCI: "_Y
+3 WRITE !
IF DHIT["DIDX"
WRITE W,?(IOM-$LENGTH(M1)-1),M1
SET W=""
SET $PIECE(W,"-",IOM)=""
WRITE !,W
SET W=""
GOTO Q^DIDH
+4 WRITE "STORED IN ",DIC
FOR I=1:1
if '$DATA(DIDHI(I))
QUIT
WRITE "D",I-1,",",DIDHI(I),","
+5 IF 'DIDHJ
Begin DoDot:1
+6 IF $ORDER(@(DIC_"0)"))'>0
WRITE " *** NO DATA STORED YET ***"
QUIT
+7 SET I=$PIECE(^(0),U,4)
if I
WRITE " ("_I_" ENTR"_$SELECT(I=1:"Y)",1:"IES)")
End DoDot:1
+8 WRITE " ",W,?(IOM-$LENGTH(M1)-1),M1
if DHIT'["DIDG"
Begin DoDot:1
+9 WRITE !!,"DATA",?14,"NAME",?36,"GLOBAL",?50,"DATA",!,"ELEMENT",?14,"TITLE",?36,"LOCATION",?50,"TYPE"
End DoDot:1
G WRITE !
FOR I=1:1:IOM-1
WRITE "-"
+1 SET W=""
if DC>1!$GET(DIDRANGE)
QUIT
FIRST ;**SHOW FOREIGN FILE NAMES
FOR DG=0:0
SET DG=$ORDER(^DIC(DA,"ALANG",DG))
if 'DG
QUIT
IF $DATA(^(DG,0))
SET DIWR=$PIECE(^(0),U)
IF $DATA(^DI(.85,DG,0))
WRITE !,$PIECE(^(0),U)," FILE NAME: ",DIWR
PAGE1 IF 'DIDHJ
IF '$$WP^DIUTL($NAME(^DIC(DA,"%D")))
SET M="^"
QUIT
+1 IF DIDHJ
Begin DoDot:1
+2 SET W=DIDHJ(DIDHJ-1)
SET W=$NAME(^DD(W,+$ORDER(^DD(W,"SB",DFF,""))))
IF '$$WP^DIUTL($NAME(@W@(21)))
SET M=U
QUIT
+3 IF $DATA(@W@(23))
WRITE !,"TECHNICAL DESCRIPTION:",!
IF '$$WP^DIUTL($NAME(@W@(23)))
SET M=U
+4 FOR I=8,9
IF $DATA(@W@(I))
WRITE !,?15,$PIECE("READ^WRITE",U,I-7)," ACCESS: ",^(I)
End DoDot:1
IF M=U
QUIT
+5 IF DHIT["DIDG"
Begin DoDot:1
+6 DO XR^DIDH
if M=U
QUIT
+7 NEW DIDPG
SET DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
+8 DO LIST^DIKCP(DA,"","C15",.DIDPG)
if M=U
QUIT
+9 DO WRLN^DIKCP1("",0,.DIDPG)
End DoDot:1
QUIT
+10 if DHIT["DIDX"!(M=U)
QUIT
WRITE !
+11 FOR %=1:1:4
SET X=$PIECE("SCR^DIC^ACT^DIK",U,%)
IF $GET(^DD(DA,0,X))]""
WRITE !,$PIECE("FILE SCREEN (SCR-node) ^SPECIAL LOOKUP ROUTINE ^POST-SELECTION ACTION ^COMPILED CROSS-REFERENCE ROUTINE",U,%)_": "
SET W=^(X)
DO W^DIDH
if M=U
GOTO Q
+12 if $PIECE($GET(^DD(DA,0,"DI")),U)["Y"
WRITE !,"THIS IS AN ARCHIVE FILE."
+13 if $PIECE($GET(^DD(DA,0,"DI")),U,2)["Y"
WRITE !,"EDITING OF FILE IS NOT ALLOWED."
+14 FOR N="DD","RD","WR","DEL","LAYGO","AUDIT"
IF $DATA(^DIC(DA,0,N))
WRITE !?(Z+Z+14-$LENGTH(N)),N," ACCESS: ",^(N)
+15 ;p14
IF $ORDER(^DIC(DA,"%",0))
WRITE !!?3,"APPLICATION GROUP(S): "
SET (%,N)=0
FOR
SET N=$ORDER(^DIC(DA,"%",N))
if 'N
QUIT
SET X=$GET(^(N,0))
if X]""
Begin DoDot:1
+16 IF ($LENGTH(X)+$X)+1>IOM
WRITE ",",!?25
SET %=0
+17 WRITE $SELECT(%:", ",1:""),X
SET %=%+1
End DoDot:1
AFOF IF $DATA(^VA(200,"AFOF",DA))
WRITE !!?8,"(NOTE: Kernel's File Access Security applies to this File.)",!
+1 IF $ORDER(^DD(DA,0,"ID",""))]""
WRITE !,"IDENTIFIED BY: "
+2 SET X=0
FOR
SET X=$ORDER(^DD(DA,0,"ID",X))
if X=""
QUIT
if '$DATA(^DD(DA,X,0))
QUIT
SET I1=$PIECE(^(0),U)_" (#"_X_")"_$SELECT($PIECE(^(0),U,2)["R":"[R]",1:"")
if ($LENGTH(I1)+$X)+1>IOM
WRITE !
WRITE ?15,I1
IF $ORDER(^DD(DA,0,"ID",X))
WRITE ", "
+3 if X=""
SET X=-1
+4 ;
+5 ;Print "WRITE" identifiers
+6 IF '$DATA(DINM)
SET X=" "
FOR
SET X=$ORDER(^DD(DA,0,"ID",X))
if X=""
QUIT
Begin DoDot:1
+7 NEW DIDLN,DIDPG
+8 SET DIDLN(1)=$GET(^DD(DA,0,"ID",X))
if DIDLN(1)?."^"
QUIT
+9 SET DIDLN(0)=""""_X_""": "
+10 SET DIDLN(0)=$JUSTIFY("",15-$LENGTH(DIDLN(0)))_DIDLN(0)
+11 SET DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
+12 DO WRPHI^DIKCP1(.DIDLN,IOM-16,0,15,1,.DIDPG)
End DoDot:1
if M=U
QUIT
+13 if M=U
QUIT
+14 ;
+15 IF $DATA(^DD("KEY","B",DA))
Begin DoDot:1
+16 NEW DIDPG
+17 SET DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
+18 DO PRINT^DIKKP(DA,"","C20",.DIDPG)
End DoDot:1
+19 DO POINT^DIDH
if M=U
QUIT
DO TRIG^DIDH
DO XR^DIDH
if M=U
QUIT
+20 IF $DATA(^DD("IX","B",DA))
Begin DoDot:1
+21 NEW DIDPG
+22 SET DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
+23 DO LIST^DIKCP(DA,"","C15",.DIDPG)
End DoDot:1
if M=U
QUIT
WRITE !
CREATED WRITE !!
SET N=$GET(^DIC(DA,"%A"))
SET Y=$PIECE(N,U,2)
IF Y
XECUTE ^DD("DD")
WRITE ?3,"CREATED ON: "_Y
IF $SELECT($DATA(^VA(200,0)):1,1:$DATA(^DIC(3,0)))
IF ^(0)["NEW PERSON"!(^(0)["USER")!(^(0)["EMPLOY")
IF $DATA(^(+N,0))
WRITE " by "_$PIECE(^(0),U)
+1 SET Y=+$GET(^DIC(DA,"%MSC"))
IF Y
XECUTE ^DD("DD")
WRITE " LAST MODIFIED: "_Y
Q QUIT
W if $X+$LENGTH(W)+3>IOM
WRITE !,?$SELECT(IOM-$LENGTH(W)-5<M:IOM-5-$LENGTH(W),1:M),S
SET %Y=$EXTRACT(W,IOM-$X,999)
WRITE $EXTRACT(W,1,IOM-$X-1),S
if %Y=""
QUIT
SET W=%Y
GOTO W
+1 QUIT
WR ;
+1 SET W="TRIGGERED by the "_$PIECE(^(0),U)_" field"
UP1 SET W=W_" of the "_$ORDER(^DD(%,0,"NM",0))
+1 IF $DATA(^DD(%,0,"UP"))
SET %=^("UP")
SET W=W_" sub-field"
GOTO UP1
+2 SET W=W_" File"
W1 SET DDV1=""
WRITE ?DDL2
FOR K=1:1
SET DDV=$PIECE(W," ",K)_" "
SET DDV1=DDV1_DDV
if $LENGTH(DDV)+$X>IOM
WRITE !?DDL2
WRITE DDV
if $LENGTH(DDV1)>$LENGTH(W)
QUIT
+1 IF $Y+6>IOSL
SET DC=DC+1
DO DIDH1
+2 KILL DDV,DDV1
QUIT
DE ;
+1 WRITE !?DDL1,$PIECE("DESCRIPTION:^TECHNICAL DESCR:",U,%Y=23+1)
+2 IF '$$WP^DIUTL($NAME(^DD(F(Z),DJ(Z),%Y)),DDL2+1)
SET M="^"
+3 QUIT
