DIKCP1 ;SFISC/MKO-PRINT INDEX(ES) ;2015-01-02 2:55 PM
;;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.
;
PRINDEX ;Come here from PRINDEX^DIKCP
Q:'$G(XR)
N XR0
I $G(FLAG)'["i" N LM,TYP,TS,WID D INIT^DIKCP
S XR0=$G(^DD("IX",XR,0)) Q:XR0?."^"
;
;Print first line of information
D FL(XR0,WID,LM,TS,TYP,.PAGE) Q:PAGE(U)
I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
;
;Print Keys with this Uniqueness Index
D KEY(XR,WID,LM,TS,.PAGE) Q:PAGE(U)
;
;Print short description
I $P(XR0,U,3)]"" D Q:PAGE(U)
. D WLP("Short Descr: ",$P(XR0,U,3),WID,LM+TS,0,.PAGE)
;
;Print description
I $O(^DD("IX",XR,.1,0)) D Q:PAGE(U)
. D WRWP($NA(^DD("IX",XR,.1)),LM,WID,"Description: ",TS,.PAGE)
I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
;
;Print logic
I FLAG'["N" D Q:PAGE(U)
. D LOGIC(XR,WID,LM,TS,FLAG,.PAGE) Q:PAGE(U)
. I FLAG'["S" D WRLN("",0,.PAGE)
;
;Print Cross Reference Values
D CRV(XR,WID,LM,TS,FLAG,.PAGE)
NOREIN I $G(^DD("IX",XR,"NOREINDEX")) W !?9,"NO RE-INDEXING ALLOWED!"
Q
;
FL(XR0,WID,LM,TS,TYP,PAGE) ;Print first line
N ACT,EXEC,NAME,RTYP,SP,TYPE,TXT,USE
;
S SP=$J("",4)
S EXEC=$$EXTERNAL^DILFD(.11,.4,"",$P(XR0,U,6))
S NAME=$P(XR0,U,2)_" (#"_XR_")"
S TYPE=$$EXTERNAL^DILFD(.11,.2,"",$P(XR0,U,4))
S ACT=$P(XR0,U,7)
S USE=$TR($$EXTERNAL^DILFD(.11,.42,"",$P(XR0,U,14))," ",$C(0))
S RTYP=$P(XR0,U,8) S:"I"[RTYP RTYP=""
S:RTYP]"" RTYP=$TR($$EXTERNAL^DILFD(.11,.5,"",RTYP)," ",$C(0))
S:RTYP]"" RTYP=SP_RTYP_$C(0)_"(#"_$P(XR0,U)_")"
;
;Print first line
I TYP=1 D
. S TXT=EXEC_" INDEX: ",TXT=TXT_$J("",TS-$L(TXT))
. S TXT=TXT_NAME_SP_TYPE_SP_ACT_SP_USE_RTYP
E S TXT=NAME_SP_EXEC_SP_TYPE_SP_ACT_SP_USE_RTYP
;
D WRPHI(TXT,WID,LM,TS,0,.PAGE)
Q
;
KEY(XR,WID,LM,TS,PAGE) ;Print keys that have XR as Uniqueness Index
Q:'$D(^DD("KEY","AU",XR))
N KEY,KEY0,KEYLN,TXT
;
S TXT=0,TXT(0)=""
S KEY=0 F S KEY=$O(^DD("KEY","AU",XR,KEY)) Q:'KEY D
. S KEY0=$G(^DD("KEY",KEY,0)) Q:KEY0?."^"
. S KEYLN="Key "_$P(KEY0,U,2)_" (#"_KEY_"), File #"_$P(KEY0,U)
. S:$G(TXT(TXT))]"" TXT(TXT)=TXT(TXT)_"; "
. D ADDSTR($TR(KEYLN," ",$C(0)),.TXT)
Q:$G(TXT(0))=""
D WLP("Unique for: ",.TXT,WID,LM+TS,0,.PAGE)
Q
;
LOGIC(XR,WID,LM,TS,FLAG,PAGE) ;Print set and kill logic
N CD,LN
S CD=$G(^DD("IX",XR,1))
I CD'?."^" D Q:PAGE(U)
. D WLP("Set Logic: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
. S LN=0 F S LN=$O(^DD("IX",XR,1.2,LN)) Q:LN'=+LN D Q:PAGE(U)
.. S CD=$G(^DD("IX",XR,1.2,LN,1))
.. I CD'?."^" D WLP(LN_") ",CD,WID,LM+TS,1,.PAGE)
S CD=$G(^DD("IX",XR,1.4))
I CD'?."^" D WLP("Set Cond: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
;
S CD=$G(^DD("IX",XR,2))
I CD'?."^" D Q:PAGE(U)
. D WLP("Kill Logic: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
. S LN=0 F S LN=$O(^DD("IX",XR,2.2,LN)) Q:LN'=+LN D Q:PAGE(U)
.. S CD=$G(^DD("IX",XR,2.2,LN,2))
.. I CD'?."^" D WLP(LN_") ",CD,WID,LM+TS,1,.PAGE)
S CD=$G(^DD("IX",XR,2.4))
I CD'?."^" D WLP("Kill Cond: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
S CD=$G(^DD("IX",XR,2.5))
I CD'?."^" D WLP("Whole Kill: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
Q
;
CRV(XR,WID,LM,TS,FLAG,PAGE) ;Print cross reference values
N CD,CV,CV0,FL,FD,LAB,ORD,TXT
S ORD="" F S ORD=$O(^DD("IX",XR,11.1,"B",ORD)) Q:ORD="" D Q:PAGE(U)
. S CV=$O(^DD("IX",XR,11.1,"B",ORD,0)) Q:'CV
. Q:$G(^DD("IX",XR,11.1,CV,0))?."^" S CV0=^(0)
. S LAB=$S(FLAG'["N":"X("_ORD_"): ",1:ORD_": ")
. ;
. ;Field-type values
. I $P(CV0,U,2)="F" D Q:PAGE(U)
.. S FL=$P(CV0,U,3),FD=$P(CV0,U,4)
.. I FL,FD S TXT=$P($G(^DD(FL,FD,0)),U)_" ("_FL_","_FD_")"
.. E S TXT="<undefined file/field>"
.. D CRVOTH(CV0,.TXT)
.. D WLP(LAB,TXT,WID,LM+TS,"",.PAGE)
. ;
. ;Computed-type values
. E D Q:PAGE(U)
.. S CD=$G(^DD("IX",XR,11.1,CV,1.5))
.. I CD'?."^" D
... S TXT=$S(FLAG["N":"<computed>",1:"Computed Code: "_CD)
.. E S TXT="<undefined computed code>"
.. D WLP(LAB,TXT,WID,LM+TS,1,.PAGE) Q:PAGE(U)
.. S TXT=""
.. D CRVOTH(CV0,.TXT)
.. D WLP("",TXT,WID,LM+TS,"",.PAGE)
. ;
. ;Lookup prompt
. I $P(CV0,U,8)]"" D Q:PAGE(U)
.. D WLP("Lookup Prompt: ",$P(CV0,U,8),WID-18,LM+TS+18,"",.PAGE)
. ;
. ;Transform
. I FLAG'["N" D
.. S CD=$G(^DD("IX",XR,11.1,CV,2))
.. I CD'?."^" D WLP("Transform (Storage): ",CD,WID-24,LM+TS+24,1,.PAGE)
.. S CD=$G(^DD("IX",XR,11.1,CV,4))
.. I CD'?."^" D WLP(" Transform (Lookup): ",CD,WID-24,LM+TS+24,1,.PAGE)
.. S CD=$G(^DD("IX",XR,11.1,CV,3))
.. I CD'?."^" D WLP("Transform (Display): ",CD,WID-24,LM+TS+24,1,.PAGE)
Q
;
CRVOTH(CV0,TXT) ;Get other attributes of Cross Reference Value
S:$P(CV0,U,6) TXT=TXT_" (Subscr"_$C(0)_$P(CV0,U,6)_")"
S:$P(CV0,U,5) TXT=TXT_" (Len"_$C(0)_$P(CV0,U,5)_")"
I $P(CV0,U,7)]"" D
. S TXT=TXT_" ("_$$EXTERNAL^DILFD(.114,7,"",$P(CV0,U,7))_")"
Q
;
ADDSTR(X,TXT) ;Add string X to the TXT array
I $L(TXT(TXT))+$L(X)>200 S TXT=TXT+1,TXT(TXT)=""
S TXT(TXT)=TXT(TXT)_X
Q
;
WRPHI(TXT,WID,LM,TS,COD,PAGE) ;Write a paragraph with a hanging indent
N LAB,LN,TAB
S:$D(TXT(0))[0 TXT(0)=$G(TXT)
S LAB=$E(TXT(0),1,$G(TS)),TXT(0)=$E(TXT(0),$G(TS)+1,999)
D WRAP^DIKCU2(.TXT,WID,"",$G(COD))
D WRLN($G(LAB)_TXT(0),$G(LM),.PAGE) Q:PAGE(U)
F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),$G(LM)+$G(TS),.PAGE) Q:PAGE(U)
Q
;
WLP(LAB,TXT,WID,TAB,COD,PAGE,WFLAG) ;Write a labeled paragraph
N LN
S:$D(TXT(0))[0 TXT(0)=$G(TXT)
D WRAP^DIKCU2(.TXT,WID,"",$G(COD))
D WRLN($G(LAB)_TXT(0),TAB-$L(LAB),.PAGE) Q:PAGE(U)
F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),TAB,.PAGE) Q:PAGE(U)
S WFLAG=LN>1
Q
;
WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
;See ^DIKCP for documentation
N X
S PAGE(U)=""
;
;Do paging, if necessary
I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y S $Y=0 D Q:PAGE(U)
. I PAGE("H")?1"W ".E X PAGE("H") Q
. I $E($G(IOST,"C"))="C" D Q:PAGE(U)
.. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1
. W @$G(IOF,"#"),PAGE("H")
;
;Write text
W !?$G(TAB),$TR($G(TXT),$C(0)," ")
Q
;
WRWP(ROOT,LM,WID,LAB,TS,PAGE) ;Call DIWP/DIWW to format a wp field.
;Then write the formatted lines.
Q:$G(ROOT)="" Q:'$D(@ROOT)
N DIWF,DIWL,DIWR,LN,X
N DIW,DIWI,DIWT,DIWTC,DIWX,DN,I,Z
K ^UTILITY($J,"W")
;
S LM=$G(LM)\1,WID=$G(WID)\1,TS=$G(TS)\1,LAB=$G(LAB)
I 'WID S WID=$G(IOM,80)-1-LM-TS S:WID<1 WID=1
S DIWL=0,DIWR=WID,DIWF="|"
S LN=0 F S LN=$O(@ROOT@(LN)) Q:'LN S X=$G(@ROOT@(LN,0)) D ^DIWP
;
D WRLN($G(LAB)_$G(^UTILITY($J,"W",DIWL,1,0)),LM+TS-$L(LAB),.PAGE)
G:$G(PAGE(U)) WRWPQ
;
S LN=1 F S LN=$O(^UTILITY($J,"W",DIWL,LN)) Q:'LN D Q:$G(PAGE(U))
. D WRLN(^UTILITY($J,"W",DIWL,LN,0),LM+TS,.PAGE)
;
WRWPQ ;Cleanup and quit
K ^UTILITY($J,"W")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCP1 6922 printed Sep 23, 2025@20:24:53 Page 2
DIKCP1 ;SFISC/MKO-PRINT INDEX(ES) ;2015-01-02 2:55 PM
+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 ;
PRINDEX ;Come here from PRINDEX^DIKCP
+1 if '$GET(XR)
QUIT
+2 NEW XR0
+3 IF $GET(FLAG)'["i"
NEW LM,TYP,TS,WID
DO INIT^DIKCP
+4 SET XR0=$GET(^DD("IX",XR,0))
if XR0?."^"
QUIT
+5 ;
+6 ;Print first line of information
+7 DO FL(XR0,WID,LM,TS,TYP,.PAGE)
if PAGE(U)
QUIT
+8 IF FLAG'["S"
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+9 ;
+10 ;Print Keys with this Uniqueness Index
+11 DO KEY(XR,WID,LM,TS,.PAGE)
if PAGE(U)
QUIT
+12 ;
+13 ;Print short description
+14 IF $PIECE(XR0,U,3)]""
Begin DoDot:1
+15 DO WLP("Short Descr: ",$PIECE(XR0,U,3),WID,LM+TS,0,.PAGE)
End DoDot:1
if PAGE(U)
QUIT
+16 ;
+17 ;Print description
+18 IF $ORDER(^DD("IX",XR,.1,0))
Begin DoDot:1
+19 DO WRWP($NAME(^DD("IX",XR,.1)),LM,WID,"Description: ",TS,.PAGE)
End DoDot:1
if PAGE(U)
QUIT
+20 IF FLAG'["S"
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+21 ;
+22 ;Print logic
+23 IF FLAG'["N"
Begin DoDot:1
+24 DO LOGIC(XR,WID,LM,TS,FLAG,.PAGE)
if PAGE(U)
QUIT
+25 IF FLAG'["S"
DO WRLN("",0,.PAGE)
End DoDot:1
if PAGE(U)
QUIT
+26 ;
+27 ;Print Cross Reference Values
+28 DO CRV(XR,WID,LM,TS,FLAG,.PAGE)
NOREIN IF $GET(^DD("IX",XR,"NOREINDEX"))
WRITE !?9,"NO RE-INDEXING ALLOWED!"
+1 QUIT
+2 ;
FL(XR0,WID,LM,TS,TYP,PAGE) ;Print first line
+1 NEW ACT,EXEC,NAME,RTYP,SP,TYPE,TXT,USE
+2 ;
+3 SET SP=$JUSTIFY("",4)
+4 SET EXEC=$$EXTERNAL^DILFD(.11,.4,"",$PIECE(XR0,U,6))
+5 SET NAME=$PIECE(XR0,U,2)_" (#"_XR_")"
+6 SET TYPE=$$EXTERNAL^DILFD(.11,.2,"",$PIECE(XR0,U,4))
+7 SET ACT=$PIECE(XR0,U,7)
+8 SET USE=$TRANSLATE($$EXTERNAL^DILFD(.11,.42,"",$PIECE(XR0,U,14))," ",$CHAR(0))
+9 SET RTYP=$PIECE(XR0,U,8)
if "I"[RTYP
SET RTYP=""
+10 if RTYP]""
SET RTYP=$TRANSLATE($$EXTERNAL^DILFD(.11,.5,"",RTYP)," ",$CHAR(0))
+11 if RTYP]""
SET RTYP=SP_RTYP_$CHAR(0)_"(#"_$PIECE(XR0,U)_")"
+12 ;
+13 ;Print first line
+14 IF TYP=1
Begin DoDot:1
+15 SET TXT=EXEC_" INDEX: "
SET TXT=TXT_$JUSTIFY("",TS-$LENGTH(TXT))
+16 SET TXT=TXT_NAME_SP_TYPE_SP_ACT_SP_USE_RTYP
End DoDot:1
+17 IF '$TEST
SET TXT=NAME_SP_EXEC_SP_TYPE_SP_ACT_SP_USE_RTYP
+18 ;
+19 DO WRPHI(TXT,WID,LM,TS,0,.PAGE)
+20 QUIT
+21 ;
KEY(XR,WID,LM,TS,PAGE) ;Print keys that have XR as Uniqueness Index
+1 if '$DATA(^DD("KEY","AU",XR))
QUIT
+2 NEW KEY,KEY0,KEYLN,TXT
+3 ;
+4 SET TXT=0
SET TXT(0)=""
+5 SET KEY=0
FOR
SET KEY=$ORDER(^DD("KEY","AU",XR,KEY))
if 'KEY
QUIT
Begin DoDot:1
+6 SET KEY0=$GET(^DD("KEY",KEY,0))
if KEY0?."^"
QUIT
+7 SET KEYLN="Key "_$PIECE(KEY0,U,2)_" (#"_KEY_"), File #"_$PIECE(KEY0,U)
+8 if $GET(TXT(TXT))]""
SET TXT(TXT)=TXT(TXT)_"; "
+9 DO ADDSTR($TRANSLATE(KEYLN," ",$CHAR(0)),.TXT)
End DoDot:1
+10 if $GET(TXT(0))=""
QUIT
+11 DO WLP("Unique for: ",.TXT,WID,LM+TS,0,.PAGE)
+12 QUIT
+13 ;
LOGIC(XR,WID,LM,TS,FLAG,PAGE) ;Print set and kill logic
+1 NEW CD,LN
+2 SET CD=$GET(^DD("IX",XR,1))
+3 IF CD'?."^"
Begin DoDot:1
+4 DO WLP("Set Logic: ",CD,WID,LM+TS,1,.PAGE)
if PAGE(U)
QUIT
+5 SET LN=0
FOR
SET LN=$ORDER(^DD("IX",XR,1.2,LN))
if LN'=+LN
QUIT
Begin DoDot:2
+6 SET CD=$GET(^DD("IX",XR,1.2,LN,1))
+7 IF CD'?."^"
DO WLP(LN_") ",CD,WID,LM+TS,1,.PAGE)
End DoDot:2
if PAGE(U)
QUIT
End DoDot:1
if PAGE(U)
QUIT
+8 SET CD=$GET(^DD("IX",XR,1.4))
+9 IF CD'?."^"
DO WLP("Set Cond: ",CD,WID,LM+TS,1,.PAGE)
if PAGE(U)
QUIT
+10 ;
+11 SET CD=$GET(^DD("IX",XR,2))
+12 IF CD'?."^"
Begin DoDot:1
+13 DO WLP("Kill Logic: ",CD,WID,LM+TS,1,.PAGE)
if PAGE(U)
QUIT
+14 SET LN=0
FOR
SET LN=$ORDER(^DD("IX",XR,2.2,LN))
if LN'=+LN
QUIT
Begin DoDot:2
+15 SET CD=$GET(^DD("IX",XR,2.2,LN,2))
+16 IF CD'?."^"
DO WLP(LN_") ",CD,WID,LM+TS,1,.PAGE)
End DoDot:2
if PAGE(U)
QUIT
End DoDot:1
if PAGE(U)
QUIT
+17 SET CD=$GET(^DD("IX",XR,2.4))
+18 IF CD'?."^"
DO WLP("Kill Cond: ",CD,WID,LM+TS,1,.PAGE)
if PAGE(U)
QUIT
+19 SET CD=$GET(^DD("IX",XR,2.5))
+20 IF CD'?."^"
DO WLP("Whole Kill: ",CD,WID,LM+TS,1,.PAGE)
if PAGE(U)
QUIT
+21 QUIT
+22 ;
CRV(XR,WID,LM,TS,FLAG,PAGE) ;Print cross reference values
+1 NEW CD,CV,CV0,FL,FD,LAB,ORD,TXT
+2 SET ORD=""
FOR
SET ORD=$ORDER(^DD("IX",XR,11.1,"B",ORD))
if ORD=""
QUIT
Begin DoDot:1
+3 SET CV=$ORDER(^DD("IX",XR,11.1,"B",ORD,0))
if 'CV
QUIT
+4 if $GET(^DD("IX",XR,11.1,CV,0))?."^"
QUIT
SET CV0=^(0)
+5 SET LAB=$SELECT(FLAG'["N":"X("_ORD_"): ",1:ORD_": ")
+6 ;
+7 ;Field-type values
+8 IF $PIECE(CV0,U,2)="F"
Begin DoDot:2
+9 SET FL=$PIECE(CV0,U,3)
SET FD=$PIECE(CV0,U,4)
+10 IF FL
IF FD
SET TXT=$PIECE($GET(^DD(FL,FD,0)),U)_" ("_FL_","_FD_")"
+11 IF '$TEST
SET TXT="<undefined file/field>"
+12 DO CRVOTH(CV0,.TXT)
+13 DO WLP(LAB,TXT,WID,LM+TS,"",.PAGE)
End DoDot:2
if PAGE(U)
QUIT
+14 ;
+15 ;Computed-type values
+16 IF '$TEST
Begin DoDot:2
+17 SET CD=$GET(^DD("IX",XR,11.1,CV,1.5))
+18 IF CD'?."^"
Begin DoDot:3
+19 SET TXT=$SELECT(FLAG["N":"<computed>",1:"Computed Code: "_CD)
End DoDot:3
+20 IF '$TEST
SET TXT="<undefined computed code>"
+21 DO WLP(LAB,TXT,WID,LM+TS,1,.PAGE)
if PAGE(U)
QUIT
+22 SET TXT=""
+23 DO CRVOTH(CV0,.TXT)
+24 DO WLP("",TXT,WID,LM+TS,"",.PAGE)
End DoDot:2
if PAGE(U)
QUIT
+25 ;
+26 ;Lookup prompt
+27 IF $PIECE(CV0,U,8)]""
Begin DoDot:2
+28 DO WLP("Lookup Prompt: ",$PIECE(CV0,U,8),WID-18,LM+TS+18,"",.PAGE)
End DoDot:2
if PAGE(U)
QUIT
+29 ;
+30 ;Transform
+31 IF FLAG'["N"
Begin DoDot:2
+32 SET CD=$GET(^DD("IX",XR,11.1,CV,2))
+33 IF CD'?."^"
DO WLP("Transform (Storage): ",CD,WID-24,LM+TS+24,1,.PAGE)
+34 SET CD=$GET(^DD("IX",XR,11.1,CV,4))
+35 IF CD'?."^"
DO WLP(" Transform (Lookup): ",CD,WID-24,LM+TS+24,1,.PAGE)
+36 SET CD=$GET(^DD("IX",XR,11.1,CV,3))
+37 IF CD'?."^"
DO WLP("Transform (Display): ",CD,WID-24,LM+TS+24,1,.PAGE)
End DoDot:2
End DoDot:1
if PAGE(U)
QUIT
+38 QUIT
+39 ;
CRVOTH(CV0,TXT) ;Get other attributes of Cross Reference Value
+1 if $PIECE(CV0,U,6)
SET TXT=TXT_" (Subscr"_$CHAR(0)_$PIECE(CV0,U,6)_")"
+2 if $PIECE(CV0,U,5)
SET TXT=TXT_" (Len"_$CHAR(0)_$PIECE(CV0,U,5)_")"
+3 IF $PIECE(CV0,U,7)]""
Begin DoDot:1
+4 SET TXT=TXT_" ("_$$EXTERNAL^DILFD(.114,7,"",$PIECE(CV0,U,7))_")"
End DoDot:1
+5 QUIT
+6 ;
ADDSTR(X,TXT) ;Add string X to the TXT array
+1 IF $LENGTH(TXT(TXT))+$LENGTH(X)>200
SET TXT=TXT+1
SET TXT(TXT)=""
+2 SET TXT(TXT)=TXT(TXT)_X
+3 QUIT
+4 ;
WRPHI(TXT,WID,LM,TS,COD,PAGE) ;Write a paragraph with a hanging indent
+1 NEW LAB,LN,TAB
+2 if $DATA(TXT(0))[0
SET TXT(0)=$GET(TXT)
+3 SET LAB=$EXTRACT(TXT(0),1,$GET(TS))
SET TXT(0)=$EXTRACT(TXT(0),$GET(TS)+1,999)
+4 DO WRAP^DIKCU2(.TXT,WID,"",$GET(COD))
+5 DO WRLN($GET(LAB)_TXT(0),$GET(LM),.PAGE)
if PAGE(U)
QUIT
+6 FOR LN=1:1
if '$DATA(TXT(LN))
QUIT
DO WRLN(TXT(LN),$GET(LM)+$GET(TS),.PAGE)
if PAGE(U)
QUIT
+7 QUIT
+8 ;
WLP(LAB,TXT,WID,TAB,COD,PAGE,WFLAG) ;Write a labeled paragraph
+1 NEW LN
+2 if $DATA(TXT(0))[0
SET TXT(0)=$GET(TXT)
+3 DO WRAP^DIKCU2(.TXT,WID,"",$GET(COD))
+4 DO WRLN($GET(LAB)_TXT(0),TAB-$LENGTH(LAB),.PAGE)
if PAGE(U)
QUIT
+5 FOR LN=1:1
if '$DATA(TXT(LN))
QUIT
DO WRLN(TXT(LN),TAB,.PAGE)
if PAGE(U)
QUIT
+6 SET WFLAG=LN>1
+7 QUIT
+8 ;
WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
+1 ;See ^DIKCP for documentation
+2 NEW X
+3 SET PAGE(U)=""
+4 ;
+5 ;Do paging, if necessary
+6 IF $DATA(PAGE("H"))#2
IF $GET(IOSL,24)-2-$GET(PAGE("B"))-$GET(KWN)'>$Y
SET $Y=0
Begin DoDot:1
+7 IF PAGE("H")?1"W ".E
XECUTE PAGE("H")
QUIT
+8 IF $EXTRACT($GET(IOST,"C"))="C"
Begin DoDot:2
+9 WRITE $CHAR(7)
READ X:$GET(DTIME,300)
IF X=U!'$TEST
SET PAGE(U)=1
End DoDot:2
if PAGE(U)
QUIT
+10 WRITE @$GET(IOF,"#"),PAGE("H")
End DoDot:1
if PAGE(U)
QUIT
+11 ;
+12 ;Write text
+13 WRITE !?$GET(TAB),$TRANSLATE($GET(TXT),$CHAR(0)," ")
+14 QUIT
+15 ;
WRWP(ROOT,LM,WID,LAB,TS,PAGE) ;Call DIWP/DIWW to format a wp field.
+1 ;Then write the formatted lines.
+2 if $GET(ROOT)=""
QUIT
if '$DATA(@ROOT)
QUIT
+3 NEW DIWF,DIWL,DIWR,LN,X
+4 NEW DIW,DIWI,DIWT,DIWTC,DIWX,DN,I,Z
+5 KILL ^UTILITY($JOB,"W")
+6 ;
+7 SET LM=$GET(LM)\1
SET WID=$GET(WID)\1
SET TS=$GET(TS)\1
SET LAB=$GET(LAB)
+8 IF 'WID
SET WID=$GET(IOM,80)-1-LM-TS
if WID<1
SET WID=1
+9 SET DIWL=0
SET DIWR=WID
SET DIWF="|"
+10 SET LN=0
FOR
SET LN=$ORDER(@ROOT@(LN))
if 'LN
QUIT
SET X=$GET(@ROOT@(LN,0))
DO ^DIWP
+11 ;
+12 DO WRLN($GET(LAB)_$GET(^UTILITY($JOB,"W",DIWL,1,0)),LM+TS-$LENGTH(LAB),.PAGE)
+13 if $GET(PAGE(U))
GOTO WRWPQ
+14 ;
+15 SET LN=1
FOR
SET LN=$ORDER(^UTILITY($JOB,"W",DIWL,LN))
if 'LN
QUIT
Begin DoDot:1
+16 DO WRLN(^UTILITY($JOB,"W",DIWL,LN,0),LM+TS,.PAGE)
End DoDot:1
if $GET(PAGE(U))
QUIT
+17 ;
WRWPQ ;Cleanup and quit
+1 KILL ^UTILITY($JOB,"W")
+2 QUIT
