- 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
