DIDH1 ;SFISC-HDR FOR DD LISTS ;7:34 AM 29 Sep 2003 [ 12/09/2003 4:31 PM ]
;;22.0;VA FileMan;**76,105,131,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
N DIDHI,DIDHJ,W D ;*131*
.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
.X ^DD("FUNC",24,1) S Y=X X ^DD("DD")
.S W=Y_" PAGE "_DC W:$L(W)+$X+2>IOM ! W ?(IOM-$L(W)-1),W
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)
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 $D(^VA(200,"AFOF")) W !!?8,"(NOTE: Kernel's File Access Security has been installed in this UCI.)",!
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)
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)
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
DIDH1 ;SFISC-HDR FOR DD LISTS ;7:34 AM 29 Sep 2003 [ 12/09/2003 4:31 PM ]
+1 ;;22.0;VA FileMan;**76,105,131,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;*131*
NEW DIDHI,DIDHJ,W
Begin DoDot:1
+4 NEW I,J
DO IJ^DIUTL(DFF)
MERGE DIDHJ=J,DIDHI=I
SET DIDHJ=$ORDER(J(""),-1)
End DoDot:1
+5 SET M=1
IF DC=1
SET (F(1),DA)=DFF
SET Z=1
+6 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
+7 SET M1=$SELECT($GET(^DD(F(1),0,"VR"))]"":" (VERSION "_$PIECE(^("VR"),U)_") ",1:"")
IF IOST?1"C".E
SET DIFF=1
+8 IF $DATA(DIFF)&($Y)
WRITE @IOF
SET DIFF=1
WRITE $SELECT(DHIT["DIDX":"BRIEF",DHIT["DIDG":"GLOBAL MAP",$DATA(DINM):"MODIFIED",1:"STANDARD")
+9 WRITE " DATA DICTIONARY #"_DFF_" -- "_$ORDER(^DD(DFF,0,"NM",0))_" "_$SELECT(DIDHJ:"SUB-",1:"")_"FILE "
+10 SET DIC=^DIC(DUB,0,"GL")
Begin DoDot:1
+11 NEW X,Y
+12 XECUTE ^DD("FUNC",24,1)
SET Y=X
XECUTE ^DD("DD")
+13 SET W=Y_" PAGE "_DC
IF $LENGTH(W)+$X+2>IOM
WRITE !
WRITE ?(IOM-$LENGTH(W)-1),W
End DoDot:1
+14 SET M=IOM\2
SET S=" "
SET W=""
IF $DATA(^DD("SITE"))
SET W="SITE: "_^("SITE")_" "
+15 IF $DATA(^%ZOSF("UCI"))#2
XECUTE ^("UCI")
SET W=W_"UCI: "_Y
+16 WRITE !
IF DHIT["DIDX"
WRITE W,?(IOM-$LENGTH(M1)-1),M1
SET W=""
SET $PIECE(W,"-",IOM)=""
WRITE !,W
SET W=""
GOTO Q^DIDH
+17 WRITE "STORED IN ",DIC
FOR I=1:1
IF '$DATA(DIDHI(I))
QUIT
WRITE "D",I-1,",",DIDHI(I),","
+18 IF 'DIDHJ
Begin DoDot:1
+19 IF $ORDER(@(DIC_"0)"))'>0
WRITE " *** NO DATA STORED YET ***"
QUIT
+20 SET I=$PIECE(^(0),U,4)
IF I
WRITE " ("_I_" ENTR"_$SELECT(I=1:"Y)",1:"IES)")
End DoDot:1
+21 WRITE " ",W,?(IOM-$LENGTH(M1)-1),M1
IF DHIT'["DIDG"
Begin DoDot:1
+22 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
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 IF $DATA(^VA(200,"AFOF"))
WRITE !!?8,"(NOTE: Kernel's File Access Security has been installed in this UCI.)",!
+16 IF $ORDER(^DD(DA,0,"ID",""))]""
WRITE !,"IDENTIFIED BY: "
+17 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 ", "
+18 IF X=""
SET X=-1
+19 ;
+20 ;Print "WRITE" identifiers
+21 IF '$DATA(DINM)
SET X=" "
FOR
SET X=$ORDER(^DD(DA,0,"ID",X))
IF X=""
QUIT
Begin DoDot:1
+22 NEW DIDLN,DIDPG
+23 SET DIDLN(1)=$GET(^DD(DA,0,"ID",X))
IF DIDLN(1)?."^"
QUIT
+24 SET DIDLN(0)=""""_X_""": "
+25 SET DIDLN(0)=$JUSTIFY("",15-$LENGTH(DIDLN(0)))_DIDLN(0)
+26 SET DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
+27 DO WRPHI^DIKCP1(.DIDLN,IOM-16,0,15,1,.DIDPG)
End DoDot:1
IF M=U
QUIT
+28 IF M=U
QUIT
+29 ;
+30 IF $DATA(^DD("KEY","B",DA))
Begin DoDot:1
+31 NEW DIDPG
+32 SET DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
+33 DO PRINT^DIKKP(DA,"","C20",.DIDPG)
End DoDot:1
+34 DO POINT^DIDH
IF M=U
QUIT
DO TRIG^DIDH
DO XR^DIDH
IF M=U
QUIT
+35 IF $DATA(^DD("IX","B",DA))
Begin DoDot:1
+36 NEW DIDPG
+37 SET DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
+38 DO LIST^DIKCP(DA,"","C15",.DIDPG)
End DoDot:1
IF M=U
QUIT
WRITE !
+39 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)
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
