DDEPRT ;SLC/MKB -- Entity Print Utilities ;09/18/18 4:36pm
;;22.2;VA FileMan;**16,17**;Jan 05, 2016;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; %ZIS 10086
; %ZTLOAD 10063
; XLFDT 10103
; XLFSTR 10104
;
EN ; -- enter here to print a SDA entity
N DDENT,DDEFMT
D ENTITY(.DDENT) Q:"^"[DDENT
S DDEFMT=$$FORMAT Q:"^"[DDEFMT
;
;Device
S %ZIS=$S($D(^%ZTSK):"Q",1:"")
W ! D ^%ZIS K %ZIS I $G(POP) K POP Q
K POP
;
;Queue report?
I $D(IO("Q")),$D(^%ZTSK) D G END
. N ZTRTN,ZTDESC,ZTSAVE
. S ZTRTN="ENP^DDEPRT"
. S ZTDESC="Report of Entity "_$P(DDENT,U,2)
. S ZTSAVE("DDENT")="",ZTSAVE("DDEFMT")=""
. D ^%ZTLOAD
. I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
. E W !,"Report canceled!",!
. K ZTSK
. S IOP="HOME" D ^%ZIS
;
U IO
;
ENP ; -- entry point for [queued] report
N DDEFN,DDEFILE,DDEDT,DDEPG,DDECRT
;
S DDEFN=+$P($G(DDENT(0)),U,2),DDEDT=$$FMTE^XLFDT($$NOW^XLFDT)
S DDEFILE=$S(DDEFN:DDEFN_U_$$NAME(DDEFN),1:"")
S DDECRT=$E(IOST,1,2)="C-",DDEPG=0
K DIRUT,DUOUT,DTOUT
;
D @("HDR"_(2-DDECRT))
D @DDEFMT
END ;
I $D(ZTQUEUED) S ZTREQ="@"
E X $G(^%ZIS("C"))
K DIRUT,DUOUT,DTOUT
Q
;
ENTITY(Y) ; -- select an entity
N X,DIC
S DIC=1.5,DIC(0)="AEQMZ" D ^DIC
I Y<1 S Y="^"
Q Y
;
FORMAT() ; -- summary or details?
N X,Y,DIR,DUOUT,DTOUT,DIRUT
S DIR(0)="SA^SUM:Summary;DET:Detailed;"
S DIR("A")="Print item summary or details? "
S DIR("?")="Select Summary for a simple list of item names in sequence"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
SUM ; -- print summary of ENTity
N DSEQ,DITM
D MAIN Q:$D(DIRUT)
W !!,"Seq Item Type Field Sub/File Entity"
W !,$$REPEAT^XLFSTR("-",79)
S DSEQ=0 F S DSEQ=$O(^DDE(+DDENT,1,"SEQ",DSEQ)) Q:'DSEQ D Q:$D(DIRUT)
. S DITM=0 F S DITM=$O(^DDE(+DDENT,1,"SEQ",DSEQ,DITM)) Q:'DITM D LINE(DITM) Q:$D(DIRUT)
Q
;
LINE(DA) ; -- print single item row
N X0 S X0=$G(^DDE(+DDENT,1,DA,0))
D PG Q:$D(DIRUT)
W !,$P(X0,U,2),?5,$P(X0,U),?35,$P(X0,U,3),$$RJ^XLFSTR($P(X0,U,5),7)," ",$P(X0,U,4)
W:$P(X0,U,8) ?56,$E($P($G(^DDE(+$P(X0,U,8),0)),U),1,24)
; look for complex items
I $P(X0,U,3)="C" D
. N CSEQ,CITM
. S CSEQ=0 F S CSEQ=$O(^DDE(+DDENT,1,DA,3,"B",CSEQ)) Q:CSEQ<1 D
.. S CITM=0 F S CITM=$O(^DDE(+DDENT,1,DA,3,"B",CSEQ,CITM)) Q:CITM<1 D
... S CNM=$P($G(^DDE(+DDENT,1,DA,3,CITM,0)),U,2) Q:CNM=""
... S CDA=$O(^DDE(+DDENT,1,"B",CNM,0)) D LINE(CDA)
Q
;
DET ; -- print details of ENTity
N DDELN,DSEQ,DITM
D DESC Q:$D(DIRUT)
D MAIN Q:$D(DIRUT)
W !!,"Seq Item",!,"Number Properties",!,"------ ----------"
S DSEQ=0 F S DSEQ=$O(^DDE(+DDENT,1,"SEQ",DSEQ)) Q:'DSEQ D Q:$D(DIRUT)
. S DITM=0 F S DITM=$O(^DDE(+DDENT,1,"SEQ",DSEQ,DITM)) Q:'DITM D ITEM(DITM,DSEQ) Q:$D(DIRUT)
Q
;
DESC ; -- description
N I S I=0
F S I=$O(^DDE(+DDENT,19,I)) Q:I<1 D PG Q:$D(DIRUT) W !,$G(^(I,0))
Q
;
MAIN ; -- main Entity properties
N X0 S X0=$G(DDENT(0)) D PG Q:$D(DIRUT)
W !!," DISPLAY NAME: "_$G(^DDE(+DDENT,.1))
D PG Q:$D(DIRUT)
W !!," SORT BY: "_$P(X0,U,3)
W ?40,"DATA MODEL: "_$S($P(X0,U,6)="S":"SDA",$P(X0,U,6)="F":"FHIR",1:"")
D PG Q:$D(DIRUT)
W !," FILTER BY: "_$P(X0,U,4)
W ?41,"READ ONLY: "_$S($P(X0,U,5):"YES",1:"NO")
D PG Q:$D(DIRUT)
D MCODE(" SCREEN: ",$G(^DDE(+DDENT,5.1))) Q:$D(DIRUT)
D PG Q:$D(DIRUT) W !,"QUERY ROUTINE: "_$G(^DDE(+DDENT,5)),!
D MCODE(" ENTRY ACTION: ",$G(^DDE(+DDENT,2))) Q:$D(DIRUT)
D MCODE(" ID ACTION: ",$G(^DDE(+DDENT,4))) Q:$D(DIRUT)
D MCODE(" EXIT ACTION: ",$G(^DDE(+DDENT,3))) Q:$D(DIRUT)
Q
;
ITEM(DA,NUM,LVL) ; -- print single item
N X0,X1,TYPE,FN,FLD,TAB,CDA,CNM,I,NM
S LVL=+$G(LVL),TAB=$S(LVL:$$REPEAT^XLFSTR(" ",(LVL*9)),1:"")
S X0=$G(^DDE(+DDENT,1,DA,0)),X1=$G(^(1)),TYPE=$P(X0,U,3)
D PG Q:$D(DIRUT) W !!,TAB,$$LJ^XLFSTR($G(NUM),9),"NAME: "_$P(X0,U)
S TAB=TAB_" "
D PG Q:$D(DIRUT) W !,TAB,"TYPE: "_$$TYPE(TYPE,+X1)
;
S FN=$P(X0,U,4),FLD=$P(X0,U,5) I FLD D Q:$D(DIRUT)
. D PG Q:$D(DIRUT)
. W !,TAB,"FIELD: "_$$GET1^DID(FN,FLD,,"LABEL")_" (#"_FLD_")"
. I $P(X0,U,6) D ;extended ptr
.. N GBL S GBL=U_$$GET1^DID(FN,FLD,,"POINTER")_"0)"
.. S FN=+$P(@GBL,U,2),FLD=$P(X0,U,6)
.. W " > "_$$GET1^DID(FN,FLD,,"LABEL")_" (#"_FLD_")"
. I $P(X0,U,7) W " [internal]"
. I TYPE="W",$P(X0,U,9) W " [word wrap]"
. Q:FN=+DDEFILE
. D PG Q:$D(DIRUT) W !,TAB," in "_$$NAME(FN)_" (#"_FN_")"
;
I 'FLD,TYPE="L",FN,FN'=+DDEFILE D Q:$D(DIRUT)
. I +X1=1 D PG Q:$D(DIRUT) W !,TAB,"FILE: "_$$NAME(FN)_" (#"_FN_")"
. I +X1=2 D PG Q:$D(DIRUT) W !,TAB,"SUBFILE: "_$$NAME(FN)_" (#"_FN_")"
. I $L($P(X1,U,3)) D PG Q:$D(DIRUT) W !,TAB,"XREF: "_$P(X1,U,3)
. I $L($P(X1,U,4)) D PG Q:$D(DIRUT) W !,TAB,"FILTER: "_$P(X1,U,4)
;
I $L($G(^DDE(+DDENT,1,DA,6))) D MCODE(TAB_"ACTION: ",^(6)) Q:$D(DIRUT)
I TYPE="F" D:$L($G(^DDE(+DDENT,1,DA,2))) Q
. D PG Q:$D(DIRUT)
. W !,TAB,"VALUE: "_^DDE(+DDENT,1,DA,2)
I $L($G(^DDE(+DDENT,1,DA,4))) D MCODE(TAB_"XFORM: ",^(4)) Q:$D(DIRUT)
I $P(X0,U,8) D PG Q:$D(DIRUT) W !,TAB,"ENTITY: "_$P($G(^DDE(+$P(X0,U,8),0)),U)
I TYPE="L",$L($P(X1,U,2)) D PG Q:$D(DIRUT) W !,TAB,"TAG: "_$P(X1,U,2)
;
I TYPE="C"!((TYPE="L")&(+X1=3)) D Q:$D(DIRUT)
. D PG Q:$D(DIRUT) W !!,TAB,"Group Item"
. D PG Q:$D(DIRUT) W !,TAB,"Order Properties"
. D PG Q:$D(DIRUT) W !,TAB,"----- ----------"
. S CSEQ=0 F S CSEQ=$O(^DDE(+DDENT,1,DA,3,"B",CSEQ)) Q:'CSEQ D Q:$D(DIRUT)
.. S I=$O(^DDE(+DDENT,1,DA,3,"B",CSEQ,0))
.. S NM=$P(^DDE(+DDENT,1,DA,3,I,0),U,2) Q:NM=""
.. S CDA=+$O(^DDE(+DDENT,1,"B",NM,0))
.. I CDA<1!'$D(^DDE(+DDENT,1,CDA,0)) Q
.. D ITEM(CDA,CSEQ,(LVL+1))
Q
;
TYPE(X,L) ; -- return display name of item type X
N Y S X=$G(X),Y=""
I X="I" S Y="ID"
I X="F" S Y="FIXED STRING"
I X="W" S Y="FIELD/WP"
I X="S" S Y="FIELD"
I X="C" S Y="GROUP"
I X="E" S Y="ENTITY"
I X="L" S Y="LIST",L=+$G(L) D
. S Y=$S(L=1:"FILE ",L=2:"SUB-FILE ",L=3:"GROUP AS A ",1:"")_Y
Q Y
;
NAME(NUM) ; -- return name of sub/file
Q $O(^DD(+$G(NUM),0,"NM",""))
;
MCODE(CAPTION,CODE) ; -- print code fields
N WIDTH S WIDTH=79-$L(CAPTION)
D PG Q:$D(DIRUT)
W !,CAPTION,$E(CODE,1,WIDTH) Q:$L(CODE)'>WIDTH
S CAPTION=$$REPEAT^XLFSTR(" ",$L(CAPTION))
F S CODE=$E(CODE,WIDTH+1,999) Q:CODE="" D PG Q:$D(DIRUT) W !,CAPTION,$E(CODE,1,WIDTH)
Q
;
PG ; -- check line count for new page
I $Y+3'<IOSL D HEADER Q:$D(DIRUT)
Q
;
I DDECRT D Q:$D(DIRUT)
. N DIR,X,Y
. S DIR(0)="E" W ! D ^DIR
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1 Q
HDR1 ;first header for CRTs
W @IOF
HDR2 ;first header for non-CRTs
N X1,X2,Y S DDEPG=$G(DDEPG)+1
S X1="ENTITY: "_$P(DDENT,U,2)_" (#"_+DDENT_")"
S X2=" FILE: "_$P(DDEFILE,U,2)_" (#"_+DDEFILE_")"
S Y=DDEDT_" PAGE "_DDEPG
W X1,!,X2,$$RJ^XLFSTR(Y,79-$L(X2))
W !,$$REPEAT^XLFSTR("-",79)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDEPRT 7140 printed Apr 09, 2024@21:53:41 Page 2
DDEPRT ;SLC/MKB -- Entity Print Utilities ;09/18/18 4:36pm
+1 ;;22.2;VA FileMan;**16,17**;Jan 05, 2016;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; %ZIS 10086
+7 ; %ZTLOAD 10063
+8 ; XLFDT 10103
+9 ; XLFSTR 10104
+10 ;
EN ; -- enter here to print a SDA entity
+1 NEW DDENT,DDEFMT
+2 DO ENTITY(.DDENT)
if "^"[DDENT
QUIT
+3 SET DDEFMT=$$FORMAT
if "^"[DDEFMT
QUIT
+4 ;
+5 ;Device
+6 SET %ZIS=$SELECT($DATA(^%ZTSK):"Q",1:"")
+7 WRITE !
DO ^%ZIS
KILL %ZIS
IF $GET(POP)
KILL POP
QUIT
+8 KILL POP
+9 ;
+10 ;Queue report?
+11 IF $DATA(IO("Q"))
IF $DATA(^%ZTSK)
Begin DoDot:1
+12 NEW ZTRTN,ZTDESC,ZTSAVE
+13 SET ZTRTN="ENP^DDEPRT"
+14 SET ZTDESC="Report of Entity "_$PIECE(DDENT,U,2)
+15 SET ZTSAVE("DDENT")=""
SET ZTSAVE("DDEFMT")=""
+16 DO ^%ZTLOAD
+17 IF $DATA(ZTSK)#2
WRITE !,"Report queued!",!,"Task number: "_$GET(ZTSK),!
+18 IF '$TEST
WRITE !,"Report canceled!",!
+19 KILL ZTSK
+20 SET IOP="HOME"
DO ^%ZIS
End DoDot:1
GOTO END
+21 ;
+22 USE IO
+23 ;
ENP ; -- entry point for [queued] report
+1 NEW DDEFN,DDEFILE,DDEDT,DDEPG,DDECRT
+2 ;
+3 SET DDEFN=+$PIECE($GET(DDENT(0)),U,2)
SET DDEDT=$$FMTE^XLFDT($$NOW^XLFDT)
+4 SET DDEFILE=$SELECT(DDEFN:DDEFN_U_$$NAME(DDEFN),1:"")
+5 SET DDECRT=$EXTRACT(IOST,1,2)="C-"
SET DDEPG=0
+6 KILL DIRUT,DUOUT,DTOUT
+7 ;
+8 DO @("HDR"_(2-DDECRT))
+9 DO @DDEFMT
END ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$TEST
XECUTE $GET(^%ZIS("C"))
+3 KILL DIRUT,DUOUT,DTOUT
+4 QUIT
+5 ;
ENTITY(Y) ; -- select an entity
+1 NEW X,DIC
+2 SET DIC=1.5
SET DIC(0)="AEQMZ"
DO ^DIC
+3 IF Y<1
SET Y="^"
+4 QUIT Y
+5 ;
FORMAT() ; -- summary or details?
+1 NEW X,Y,DIR,DUOUT,DTOUT,DIRUT
+2 SET DIR(0)="SA^SUM:Summary;DET:Detailed;"
+3 SET DIR("A")="Print item summary or details? "
+4 SET DIR("?")="Select Summary for a simple list of item names in sequence"
+5 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+6 QUIT Y
+7 ;
SUM ; -- print summary of ENTity
+1 NEW DSEQ,DITM
+2 DO MAIN
if $DATA(DIRUT)
QUIT
+3 WRITE !!,"Seq Item Type Field Sub/File Entity"
+4 WRITE !,$$REPEAT^XLFSTR("-",79)
+5 SET DSEQ=0
FOR
SET DSEQ=$ORDER(^DDE(+DDENT,1,"SEQ",DSEQ))
if 'DSEQ
QUIT
Begin DoDot:1
+6 SET DITM=0
FOR
SET DITM=$ORDER(^DDE(+DDENT,1,"SEQ",DSEQ,DITM))
if 'DITM
QUIT
DO LINE(DITM)
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+7 QUIT
+8 ;
LINE(DA) ; -- print single item row
+1 NEW X0
SET X0=$GET(^DDE(+DDENT,1,DA,0))
+2 DO PG
if $DATA(DIRUT)
QUIT
+3 WRITE !,$PIECE(X0,U,2),?5,$PIECE(X0,U),?35,$PIECE(X0,U,3),$$RJ^XLFSTR($PIECE(X0,U,5),7)," ",$PIECE(X0,U,4)
+4 if $PIECE(X0,U,8)
WRITE ?56,$EXTRACT($PIECE($GET(^DDE(+$PIECE(X0,U,8),0)),U),1,24)
+5 ; look for complex items
+6 IF $PIECE(X0,U,3)="C"
Begin DoDot:1
+7 NEW CSEQ,CITM
+8 SET CSEQ=0
FOR
SET CSEQ=$ORDER(^DDE(+DDENT,1,DA,3,"B",CSEQ))
if CSEQ<1
QUIT
Begin DoDot:2
+9 SET CITM=0
FOR
SET CITM=$ORDER(^DDE(+DDENT,1,DA,3,"B",CSEQ,CITM))
if CITM<1
QUIT
Begin DoDot:3
+10 SET CNM=$PIECE($GET(^DDE(+DDENT,1,DA,3,CITM,0)),U,2)
if CNM=""
QUIT
+11 SET CDA=$ORDER(^DDE(+DDENT,1,"B",CNM,0))
DO LINE(CDA)
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
DET ; -- print details of ENTity
+1 NEW DDELN,DSEQ,DITM
+2 DO DESC
if $DATA(DIRUT)
QUIT
+3 DO MAIN
if $DATA(DIRUT)
QUIT
+4 WRITE !!,"Seq Item",!,"Number Properties",!,"------ ----------"
+5 SET DSEQ=0
FOR
SET DSEQ=$ORDER(^DDE(+DDENT,1,"SEQ",DSEQ))
if 'DSEQ
QUIT
Begin DoDot:1
+6 SET DITM=0
FOR
SET DITM=$ORDER(^DDE(+DDENT,1,"SEQ",DSEQ,DITM))
if 'DITM
QUIT
DO ITEM(DITM,DSEQ)
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+7 QUIT
+8 ;
DESC ; -- description
+1 NEW I
SET I=0
+2 FOR
SET I=$ORDER(^DDE(+DDENT,19,I))
if I<1
QUIT
DO PG
if $DATA(DIRUT)
QUIT
WRITE !,$GET(^(I,0))
+3 QUIT
+4 ;
MAIN ; -- main Entity properties
+1 NEW X0
SET X0=$GET(DDENT(0))
DO PG
if $DATA(DIRUT)
QUIT
+2 WRITE !!," DISPLAY NAME: "_$GET(^DDE(+DDENT,.1))
+3 DO PG
if $DATA(DIRUT)
QUIT
+4 WRITE !!," SORT BY: "_$PIECE(X0,U,3)
+5 WRITE ?40,"DATA MODEL: "_$SELECT($PIECE(X0,U,6)="S":"SDA",$PIECE(X0,U,6)="F":"FHIR",1:"")
+6 DO PG
if $DATA(DIRUT)
QUIT
+7 WRITE !," FILTER BY: "_$PIECE(X0,U,4)
+8 WRITE ?41,"READ ONLY: "_$SELECT($PIECE(X0,U,5):"YES",1:"NO")
+9 DO PG
if $DATA(DIRUT)
QUIT
+10 DO MCODE(" SCREEN: ",$GET(^DDE(+DDENT,5.1)))
if $DATA(DIRUT)
QUIT
+11 DO PG
if $DATA(DIRUT)
QUIT
WRITE !,"QUERY ROUTINE: "_$GET(^DDE(+DDENT,5)),!
+12 DO MCODE(" ENTRY ACTION: ",$GET(^DDE(+DDENT,2)))
if $DATA(DIRUT)
QUIT
+13 DO MCODE(" ID ACTION: ",$GET(^DDE(+DDENT,4)))
if $DATA(DIRUT)
QUIT
+14 DO MCODE(" EXIT ACTION: ",$GET(^DDE(+DDENT,3)))
if $DATA(DIRUT)
QUIT
+15 QUIT
+16 ;
ITEM(DA,NUM,LVL) ; -- print single item
+1 NEW X0,X1,TYPE,FN,FLD,TAB,CDA,CNM,I,NM
+2 SET LVL=+$GET(LVL)
SET TAB=$SELECT(LVL:$$REPEAT^XLFSTR(" ",(LVL*9)),1:"")
+3 SET X0=$GET(^DDE(+DDENT,1,DA,0))
SET X1=$GET(^(1))
SET TYPE=$PIECE(X0,U,3)
+4 DO PG
if $DATA(DIRUT)
QUIT
WRITE !!,TAB,$$LJ^XLFSTR($GET(NUM),9),"NAME: "_$PIECE(X0,U)
+5 SET TAB=TAB_" "
+6 DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"TYPE: "_$$TYPE(TYPE,+X1)
+7 ;
+8 SET FN=$PIECE(X0,U,4)
SET FLD=$PIECE(X0,U,5)
IF FLD
Begin DoDot:1
+9 DO PG
if $DATA(DIRUT)
QUIT
+10 WRITE !,TAB,"FIELD: "_$$GET1^DID(FN,FLD,,"LABEL")_" (#"_FLD_")"
+11 ;extended ptr
IF $PIECE(X0,U,6)
Begin DoDot:2
+12 NEW GBL
SET GBL=U_$$GET1^DID(FN,FLD,,"POINTER")_"0)"
+13 SET FN=+$PIECE(@GBL,U,2)
SET FLD=$PIECE(X0,U,6)
+14 WRITE " > "_$$GET1^DID(FN,FLD,,"LABEL")_" (#"_FLD_")"
End DoDot:2
+15 IF $PIECE(X0,U,7)
WRITE " [internal]"
+16 IF TYPE="W"
IF $PIECE(X0,U,9)
WRITE " [word wrap]"
+17 if FN=+DDEFILE
QUIT
+18 DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB," in "_$$NAME(FN)_" (#"_FN_")"
End DoDot:1
if $DATA(DIRUT)
QUIT
+19 ;
+20 IF 'FLD
IF TYPE="L"
IF FN
IF FN'=+DDEFILE
Begin DoDot:1
+21 IF +X1=1
DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"FILE: "_$$NAME(FN)_" (#"_FN_")"
+22 IF +X1=2
DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"SUBFILE: "_$$NAME(FN)_" (#"_FN_")"
+23 IF $LENGTH($PIECE(X1,U,3))
DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"XREF: "_$PIECE(X1,U,3)
+24 IF $LENGTH($PIECE(X1,U,4))
DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"FILTER: "_$PIECE(X1,U,4)
End DoDot:1
if $DATA(DIRUT)
QUIT
+25 ;
+26 IF $LENGTH($GET(^DDE(+DDENT,1,DA,6)))
DO MCODE(TAB_"ACTION: ",^(6))
if $DATA(DIRUT)
QUIT
+27 IF TYPE="F"
if $LENGTH($GET(^DDE(+DDENT,1,DA,2)))
Begin DoDot:1
+28 DO PG
if $DATA(DIRUT)
QUIT
+29 WRITE !,TAB,"VALUE: "_^DDE(+DDENT,1,DA,2)
End DoDot:1
QUIT
+30 IF $LENGTH($GET(^DDE(+DDENT,1,DA,4)))
DO MCODE(TAB_"XFORM: ",^(4))
if $DATA(DIRUT)
QUIT
+31 IF $PIECE(X0,U,8)
DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"ENTITY: "_$PIECE($GET(^DDE(+$PIECE(X0,U,8),0)),U)
+32 IF TYPE="L"
IF $LENGTH($PIECE(X1,U,2))
DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"TAG: "_$PIECE(X1,U,2)
+33 ;
+34 IF TYPE="C"!((TYPE="L")&(+X1=3))
Begin DoDot:1
+35 DO PG
if $DATA(DIRUT)
QUIT
WRITE !!,TAB,"Group Item"
+36 DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"Order Properties"
+37 DO PG
if $DATA(DIRUT)
QUIT
WRITE !,TAB,"----- ----------"
+38 SET CSEQ=0
FOR
SET CSEQ=$ORDER(^DDE(+DDENT,1,DA,3,"B",CSEQ))
if 'CSEQ
QUIT
Begin DoDot:2
+39 SET I=$ORDER(^DDE(+DDENT,1,DA,3,"B",CSEQ,0))
+40 SET NM=$PIECE(^DDE(+DDENT,1,DA,3,I,0),U,2)
if NM=""
QUIT
+41 SET CDA=+$ORDER(^DDE(+DDENT,1,"B",NM,0))
+42 IF CDA<1!'$DATA(^DDE(+DDENT,1,CDA,0))
QUIT
+43 DO ITEM(CDA,CSEQ,(LVL+1))
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+44 QUIT
+45 ;
TYPE(X,L) ; -- return display name of item type X
+1 NEW Y
SET X=$GET(X)
SET Y=""
+2 IF X="I"
SET Y="ID"
+3 IF X="F"
SET Y="FIXED STRING"
+4 IF X="W"
SET Y="FIELD/WP"
+5 IF X="S"
SET Y="FIELD"
+6 IF X="C"
SET Y="GROUP"
+7 IF X="E"
SET Y="ENTITY"
+8 IF X="L"
SET Y="LIST"
SET L=+$GET(L)
Begin DoDot:1
+9 SET Y=$SELECT(L=1:"FILE ",L=2:"SUB-FILE ",L=3:"GROUP AS A ",1:"")_Y
End DoDot:1
+10 QUIT Y
+11 ;
NAME(NUM) ; -- return name of sub/file
+1 QUIT $ORDER(^DD(+$GET(NUM),0,"NM",""))
+2 ;
MCODE(CAPTION,CODE) ; -- print code fields
+1 NEW WIDTH
SET WIDTH=79-$LENGTH(CAPTION)
+2 DO PG
if $DATA(DIRUT)
QUIT
+3 WRITE !,CAPTION,$EXTRACT(CODE,1,WIDTH)
if $LENGTH(CODE)'>WIDTH
QUIT
+4 SET CAPTION=$$REPEAT^XLFSTR(" ",$LENGTH(CAPTION))
+5 FOR
SET CODE=$EXTRACT(CODE,WIDTH+1,999)
if CODE=""
QUIT
DO PG
if $DATA(DIRUT)
QUIT
WRITE !,CAPTION,$EXTRACT(CODE,1,WIDTH)
+6 QUIT
+7 ;
PG ; -- check line count for new page
+1 IF $Y+3'<IOSL
DO HEADER
if $DATA(DIRUT)
QUIT
+2 QUIT
+3 ;
+1 IF DDECRT
Begin DoDot:1
+2 NEW DIR,X,Y
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
End DoDot:1
if $DATA(DIRUT)
QUIT
+4 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DIRUT)=1
QUIT
HDR1 ;first header for CRTs
+1 WRITE @IOF
HDR2 ;first header for non-CRTs
+1 NEW X1,X2,Y
SET DDEPG=$GET(DDEPG)+1
+2 SET X1="ENTITY: "_$PIECE(DDENT,U,2)_" (#"_+DDENT_")"
+3 SET X2=" FILE: "_$PIECE(DDEFILE,U,2)_" (#"_+DDEFILE_")"
+4 SET Y=DDEDT_" PAGE "_DDEPG
+5 WRITE X1,!,X2,$$RJ^XLFSTR(Y,79-$LENGTH(X2))
+6 WRITE !,$$REPEAT^XLFSTR("-",79)
+7 QUIT
