DID1 ;SFISC/XAK,JLT,GFT - STD DD LIST ;25OCT2016
;;22.2;VA FileMan;**2,19**;Jan 05, 2016;Build 2
;;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.
;GFT;**7,76,105,152,999,1003,1004,1021,1039,1044,1046,1053**
;
S DJ(Z)=D0,DDL1=14,DDL2=32 G B
;
L S DJ(Z)=0
A S DJ(Z)=$O(^DD(F(Z),DJ(Z))) I DJ(Z)'>0 S:DJ(Z)="" DJ(Z)=-1 W !! S Z=Z-1 Q
B S N=^DD(F(Z),DJ(Z),0) K DDF I $D(DIGR),Z<2!(DJ(Z)-.01) X DIGR E G ND
D HD:$Y+$L(X)+6>IOSL Q:M=U
I $P(N,U,2)["W" S X="" G TYPE ;p19 subdd of WP, skip LABEL & WP, they were displayed at top level
W !!,F(Z),",",DJ(Z)
LABEL W ?(Z+Z+12),$P(N,U),?DDL2+4," "_$P(N,U,4)
F X=0:0 S X=$O(^DD(F(Z),DJ(Z),.008,X)) Q:'X S W=$P($G(^(X,0)),U) I W]"",$D(^DI(.85,X,0)) S I=$P(^(0),U,2)_": " W !?(Z+Z+12-$L(I)),I,W ;DISPLAY FOREIGN LABELS
S X=$P(N,U,2)
WP I X,$D(^DD(+X,.01,0)) S W=$P(^(0),U,2) I W["W" D S X=""
.D WPW("WORD-PROCESSING #"_+X) D:W["L" WPW("(NOWRAP)")
.D:W["X"!(W["x") WPW("(IGNORE ""|"")") D:W["I" WPW("(UNEDITABLE)") D:$G(^("AUDIT"))]"" WPW("(AUDITED)")
.Q
F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER","m","p" I X[$E(W) D VP^DIDX:$E(W)="V" S:W="K" W="MUMPS" S:W="p" W="POINTER" S:W="m" W="MULTIPLE" W ?40," "_W G ND:M=U
TYPE S W=+$P(X,"t",2) I W,$D(^DI(.81,W,0)) S W=" ("_$P(^(0),U)_" Data Type)" D W D G ND:M=U
.N X,Y F X=0:0 S X=$O(^DD(F(Z),DJ(Z),101,X)) Q:'X I $D(^DI(.86,X,0)) W !?DDL1,"PROPERTY: ",?DDL2,$P(^(0),U) D Q:M=U
..I $G(^DD(F(Z),DJ(Z),101,X,31))]"" S Y=^(31) X:$G(^DI(.86,X,41))=1 ^DD("DD") S W=" (Value = "_Y_")" D W
.F X=0:0 S X=$O(^DD(F(Z),DJ(Z),201,X)) Q:'X S Y=$G(^(X,31)) I Y]"",$D(^DI(.87,X,0)) W !?DDL1,$P(^(0),U),": ",Y
I +X S W=" Multiple" S W=W_" #"_+X D W G ND:M=U
I X["V" S I=0 F S I=$O(^DD(F(Z),D0,"V",I)) Q:I'>0 S %Y=$P(^(I,0),U) I $D(^DIC(%Y,0)),$D(@(^(0,"GL")_"0)")) S ^UTILITY($J,"P",$E($P(^(0),U),1,30),0)=%Y,^(F(Z),DJ(Z))=0
I 'X D
P .N Y,NM S:X["P" Y=U_$P(N,U,3),NM=+$P(X,"P",2) I X["C" S NM=+$P(X,"p",2) I NM S Y=$G(^DIC(NM,0,"GL"))
.Q:'$D(Y) N PF I Y[U,$D(@(Y_"0)")) S W=" TO "_$P(^(0),U)_" FILE (#"_NM_")",PF=$E($P(^(0),U),1,30)
.E S PF="UNDEFINED FILE"_$S(NM:" (#"_NM_")",1:""),W=" ***** TO AN "_PF_$S(Y[U:", STORED IN "_$$CREF^DILF(Y),1:"")_" *******",PF="}"_PF,NM="" W:($L(W)+$X)'<IOM !
.S ^UTILITY($J,"P",PF,0)=NM,^(F(Z),DJ(Z))=0
.D W
MP I X'["V" D RT^DIDX G:M=U ND
S I X["S" D G ND:M=U
.N N1,LANG
.S N1=$P(N,U,3) F %1=1:1 S Y=$P(N1,";",%1) Q:Y="" W ! S W="'"_$P(Y,":")_"' FOR "_$P(Y,":",2)_"; " D W Q:M=U D
..F LANG=0:0 S LANG=$O(^DD(F(Z),DJ(Z),.007,LANG)) Q:'LANG I $D(^(LANG,0)) W " (",$P(^(0),";",%1),")"
G RD:$D(DINM) I X["C" S W=$P(N,U,5,99) W !?DDL1,"MUMPS CODE: " D W G ND:M=U G RD
I "Q"'[$P(N,U,5) W !?DDL1,"INPUT TRANSFORM:" S W=$P(N,U,5,99) D W G ND:M=U
J S W=$P(N,U,2) I W'["N" S W=+$P(W,"J",2) I W W !?DDL1,"MAXIMUM LENGTH: " D W G ND:M=U
OT I $D(^DD(F(Z),DJ(Z),2))#2 W !?DDL1,"OUTPUT TRANSFORM:" D D W G ND:M=U
.I $P(^(0),U,2)'["O" S W="NOT EXECUTABLE!! -- SPECIFIER NEEDS AN ""O""!"
.E S W=$S($D(^DD(F(Z),DJ(Z),2.1)):^(2.1),1:^(2))
RD D ^DID2:$O(^DD(F(Z),DJ(Z),2.99))]"" G ND:M=U I 'X S W="" D G SUB:W,N ;p19 If WP, SUB will display Help & Desc. at subdd level
.I X["I" S W="UNEDITABLE" W ! D W Q
.S W=$$CHKWP(F(Z),DJ(Z)),X=$S(W:W,1:X) ;X=subdd for WP
I $O(^DD(+X,0,"ID",""))]"" W !?DDL1,"IDENTIFIED BY:" S W="" F %=0:0 S %=$O(^DD(+X,0,"ID",%)) S:%>0 W=W_$P(^DD(+X,%,0),U)_"(#"_%_")"_$S($P(^(0),U,2)["R":"[R]",1:"")_", " I %'>0 S:W?.E1", " W=$E(W,1,$L(W)-2) D W G ND:M=U Q
;
;Print "WRITE" identifiers
I '$D(DINM) S %=" " F S %=$O(^DD(+X,0,"ID",%)) Q:%="" D Q:M=U
. N DIDLN,DIDPG
. S DIDLN(1)=$G(^DD(+X,0,"ID",%)) Q:DIDLN(1)?."^"
. S DIDLN(0)=""""_%_""": "
. S DIDLN(0)=$J("",DDL2-DDL1-$L(DIDLN(0)))_DIDLN(0)
. S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1"
. D WRPHI^DIKCP1(.DIDLN,IOM-1-DDL2,DDL1,DDL2-DDL1,1,.DIDPG)
G:M=U ND
;
I $D(^DD("KEY","B",+X)) D G:M=U ND
. N DIDPG
. S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1"
. D PRINT^DIKKP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG)
I $D(^DD("IX","B",+X)) D G:M=U ND
. N DIDPG
. S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1"
. D LIST^DIKCP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG)
SUB S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X
D L
N K DDN1 I X["X" S DDN1=1 W !,?DDL1,"NOTES:",?DDL2,"XXXX--CAN'T BE ALTERED EXCEPT BY PROGRAMMER" W ! G ND:M=U
S W=0 I $O(^DD(F(Z),DJ(Z),5,W))'="",'$D(DDN1) W !?DDL1,"NOTES:"
TR S W=$O(^DD(F(Z),DJ(Z),5,W)) S:W="" W=-1 G IX:W'>0 S I=^(W,0),%=+I I '$D(^DD(%,$P(I,U,2),0))!$D(W(I)) K ^DD(F(Z),DJ(Z),5,W) G TR
S W(I)=0 S WS=W D WR^DIDH1 W ! S W=WS K WS G TR
IX S F=0 F G ND:M=U S F=$O(^DD(F(Z),DJ(Z),1,F)) Q:F'>0 W !?DDL1,"CROSS-REFERENCE:" D IX1
S:F="" F=-1
I $D(^DD("IX","F",F(Z),DJ(Z))) D S:M=U DN=0
. N DIDPG,DIDFLAG
. S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1"
. S DIDFLAG="L"_DDL1_"C"_(DDL2-DDL1)_"T1"
. D PRINT^DIKCP(F(Z),DJ(Z),$E("R",$G(DIDRANGE))_"FS"_DIDFLAG_$E("N",$D(DINM)#2),.DIDPG) Q:M=U
. D:'$G(DIDRANGE) LIST^DIKCP(F(Z),DJ(Z),"RS"_DIDFLAG,.DIDPG)
ND S X="" G:M'=U A:Z>1
Q
IX1 S W=^(F,0)_" " K DDF W ?DDL2,W,! G ND:M=U D TP:$P(W,U,3)["TRIG" I '$D(DINM) S X=0 F %=0:0 S X=$O(^DD(F(Z),DJ(Z),1,F,X)) Q:X="" I X'="%D",X'="DT" S W=^(X) S:$L(W)<248 W=X_")= "_W K:X=3 DDF D W W ! G ND:M=U
Q:'$D(^("%D"))
;
N DIDI,DIDN,DIDZ,DIWF,DIWL,DIWR,X
K ^UTILITY($J,"W")
S DIWF="W",DIWL=DDL2+1,DIWR=IOM,DIDZ=Z
S DIDN=$P($G(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",0)),U,3),DIDI=0
F S DIDI=$O(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",DIDI)) Q:'DIDI!(DIDN&(DIDI>DIDN)) S X=^(DIDI,0) D ^DIWP I $D(DN),'DN S M=U Q
I M'=U D ^DIWW I $D(DN),'DN S M=U
I M'=U W !
E K DIOEND
S Z=DIDZ
K ^UTILITY($J,"W")
Q
;
CHKWP(F,Z) ;F=file, Z=field - return subdd of WP or 0 ;p19
N W,Y
S W=$P($G(^DD(F,Z,0)),U,2) Q:'W 0
S Y=$P($G(^DD(W,.01,0)),U,2)
Q $S(Y["W":W,1:0)
;
TP ;TRIGGER POINTER. SHOULD BE A DO-DOT UNDER IX1
S X=+$P(^(0),U,4) I F(Z)-X,$D(^DIC(X,0))#2 S ^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=X,^(F(Z),DJ(Z))=6
Q
;
WPW(X) ;word processing write
W:$L(X)+$X+5>IOM !?18 W " ",X
Q
;
W F K=0:0 W:$D(DDF) ! S:(($L(W)+DDL2)>IOM) DDL2=32 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y,DDF=1
K:'X DDF Q:$Y+6<IOSL
HD S DC=DC+1 D ^DIDH Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDID1 6505 printed Jan 18, 2025@03:47:45 Page 2
DID1 ;SFISC/XAK,JLT,GFT - STD DD LIST ;25OCT2016
+1 ;;22.2;VA FileMan;**2,19**;Jan 05, 2016;Build 2
+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 ;GFT;**7,76,105,152,999,1003,1004,1021,1039,1044,1046,1053**
+7 ;
+8 SET DJ(Z)=D0
SET DDL1=14
SET DDL2=32
GOTO B
+9 ;
L SET DJ(Z)=0
A SET DJ(Z)=$ORDER(^DD(F(Z),DJ(Z)))
IF DJ(Z)'>0
if DJ(Z)=""
SET DJ(Z)=-1
WRITE !!
SET Z=Z-1
QUIT
B SET N=^DD(F(Z),DJ(Z),0)
KILL DDF
IF $DATA(DIGR)
IF Z<2!(DJ(Z)-.01)
XECUTE DIGR
IF '$TEST
GOTO ND
+1 if $Y+$LENGTH(X)+6>IOSL
DO HD
if M=U
QUIT
+2 ;p19 subdd of WP, skip LABEL & WP, they were displayed at top level
IF $PIECE(N,U,2)["W"
SET X=""
GOTO TYPE
+3 WRITE !!,F(Z),",",DJ(Z)
LABEL WRITE ?(Z+Z+12),$PIECE(N,U),?DDL2+4," "_$PIECE(N,U,4)
+1 ;DISPLAY FOREIGN LABELS
FOR X=0:0
SET X=$ORDER(^DD(F(Z),DJ(Z),.008,X))
if 'X
QUIT
SET W=$PIECE($GET(^(X,0)),U)
IF W]""
IF $DATA(^DI(.85,X,0))
SET I=$PIECE(^(0),U,2)_": "
WRITE !?(Z+Z+12-$LENGTH(I)),I,W
+2 SET X=$PIECE(N,U,2)
WP IF X
IF $DATA(^DD(+X,.01,0))
SET W=$PIECE(^(0),U,2)
IF W["W"
Begin DoDot:1
+1 DO WPW("WORD-PROCESSING #"_+X)
if W["L"
DO WPW("(NOWRAP)")
+2 if W["X"!(W["x")
DO WPW("(IGNORE ""|"")")
if W["I"
DO WPW("(UNEDITABLE)")
if $GET(^("AUDIT"))]""
DO WPW("(AUDITED)")
+3 QUIT
End DoDot:1
SET X=""
+4 FOR W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER","m","p"
IF X[$EXTRACT(W)
if $EXTRACT(W)="V"
DO VP^DIDX
if W="K"
SET W="MUMPS"
if W="p"
SET W="POINTER"
if W="m"
SET W="MULTIPLE"
WRITE ?40," "_W
if M=U
GOTO ND
TYPE SET W=+$PIECE(X,"t",2)
IF W
IF $DATA(^DI(.81,W,0))
SET W=" ("_$PIECE(^(0),U)_" Data Type)"
DO W
Begin DoDot:1
+1 NEW X,Y
FOR X=0:0
SET X=$ORDER(^DD(F(Z),DJ(Z),101,X))
if 'X
QUIT
IF $DATA(^DI(.86,X,0))
WRITE !?DDL1,"PROPERTY: ",?DDL2,$PIECE(^(0),U)
Begin DoDot:2
+2 IF $GET(^DD(F(Z),DJ(Z),101,X,31))]""
SET Y=^(31)
if $GET(^DI(.86,X,41))=1
XECUTE ^DD("DD")
SET W=" (Value = "_Y_")"
DO W
End DoDot:2
if M=U
QUIT
+3 FOR X=0:0
SET X=$ORDER(^DD(F(Z),DJ(Z),201,X))
if 'X
QUIT
SET Y=$GET(^(X,31))
IF Y]""
IF $DATA(^DI(.87,X,0))
WRITE !?DDL1,$PIECE(^(0),U),": ",Y
End DoDot:1
if M=U
GOTO ND
+4 IF +X
SET W=" Multiple"
SET W=W_" #"_+X
DO W
if M=U
GOTO ND
+5 IF X["V"
SET I=0
FOR
SET I=$ORDER(^DD(F(Z),D0,"V",I))
if I'>0
QUIT
SET %Y=$PIECE(^(I,0),U)
IF $DATA(^DIC(%Y,0))
IF $DATA(@(^(0,"GL")_"0)"))
SET ^UTILITY($JOB,"P",$EXTRACT($PIECE(^(0),U),1,30),0)=%Y
SET ^(F(Z),DJ(Z))=0
+6 IF 'X
Begin DoDot:1
P NEW Y,NM
if X["P"
SET Y=U_$PIECE(N,U,3)
SET NM=+$PIECE(X,"P",2)
IF X["C"
SET NM=+$PIECE(X,"p",2)
IF NM
SET Y=$GET(^DIC(NM,0,"GL"))
+1 if '$DATA(Y)
QUIT
NEW PF
IF Y[U
IF $DATA(@(Y_"0)"))
SET W=" TO "_$PIECE(^(0),U)_" FILE (#"_NM_")"
SET PF=$EXTRACT($PIECE(^(0),U),1,30)
+2 IF '$TEST
SET PF="UNDEFINED FILE"_$SELECT(NM:" (#"_NM_")",1:"")
SET W=" ***** TO AN "_PF_$SELECT(Y[U:", STORED IN "_$$CREF^DILF(Y),1:"")_" *******"
SET PF="}"_PF
SET NM=""
if ($LENGTH(W)+$X)'<IOM
WRITE !
+3 SET ^UTILITY($JOB,"P",PF,0)=NM
SET ^(F(Z),DJ(Z))=0
+4 DO W
End DoDot:1
MP IF X'["V"
DO RT^DIDX
if M=U
GOTO ND
S IF X["S"
Begin DoDot:1
+1 NEW N1,LANG
+2 SET N1=$PIECE(N,U,3)
FOR %1=1:1
SET Y=$PIECE(N1,";",%1)
if Y=""
QUIT
WRITE !
SET W="'"_$PIECE(Y,":")_"' FOR "_$PIECE(Y,":",2)_"; "
DO W
if M=U
QUIT
Begin DoDot:2
+3 FOR LANG=0:0
SET LANG=$ORDER(^DD(F(Z),DJ(Z),.007,LANG))
if 'LANG
QUIT
IF $DATA(^(LANG,0))
WRITE " (",$PIECE(^(0),";",%1),")"
End DoDot:2
End DoDot:1
if M=U
GOTO ND
+4 if $DATA(DINM)
GOTO RD
IF X["C"
SET W=$PIECE(N,U,5,99)
WRITE !?DDL1,"MUMPS CODE: "
DO W
if M=U
GOTO ND
GOTO RD
+5 IF "Q"'[$PIECE(N,U,5)
WRITE !?DDL1,"INPUT TRANSFORM:"
SET W=$PIECE(N,U,5,99)
DO W
if M=U
GOTO ND
J SET W=$PIECE(N,U,2)
IF W'["N"
SET W=+$PIECE(W,"J",2)
IF W
WRITE !?DDL1,"MAXIMUM LENGTH: "
DO W
if M=U
GOTO ND
OT IF $DATA(^DD(F(Z),DJ(Z),2))#2
WRITE !?DDL1,"OUTPUT TRANSFORM:"
Begin DoDot:1
+1 IF $PIECE(^(0),U,2)'["O"
SET W="NOT EXECUTABLE!! -- SPECIFIER NEEDS AN ""O""!"
+2 IF '$TEST
SET W=$SELECT($DATA(^DD(F(Z),DJ(Z),2.1)):^(2.1),1:^(2))
End DoDot:1
DO W
if M=U
GOTO ND
RD ;p19 If WP, SUB will display Help & Desc. at subdd level
if $ORDER(^DD(F(Z),DJ(Z),2.99))]""
DO ^DID2
if M=U
GOTO ND
IF 'X
SET W=""
Begin DoDot:1
+1 IF X["I"
SET W="UNEDITABLE"
WRITE !
DO W
QUIT
+2 ;X=subdd for WP
SET W=$$CHKWP(F(Z),DJ(Z))
SET X=$SELECT(W:W,1:X)
End DoDot:1
if W
GOTO SUB
GOTO N
+3 IF $ORDER(^DD(+X,0,"ID",""))]""
WRITE !?DDL1,"IDENTIFIED BY:"
SET W=""
FOR %=0:0
SET %=$ORDER(^DD(+X,0,"ID",%))
if %>0
SET W=W_$PIECE(^DD(+X,%,0),U)_"(#"_%_")"_$SELECT($PIECE(^(0),U,2)["R":"[R]",1:"")_", "
IF %'>0
if W?.E1", "
SET W=$EXTRACT(W,1,$LENGTH(W)-2)
DO W
if M=U
GOTO ND
QUIT
+4 ;
+5 ;Print "WRITE" identifiers
+6 IF '$DATA(DINM)
SET %=" "
FOR
SET %=$ORDER(^DD(+X,0,"ID",%))
if %=""
QUIT
Begin DoDot:1
+7 NEW DIDLN,DIDPG
+8 SET DIDLN(1)=$GET(^DD(+X,0,"ID",%))
if DIDLN(1)?."^"
QUIT
+9 SET DIDLN(0)=""""_%_""": "
+10 SET DIDLN(0)=$JUSTIFY("",DDL2-DDL1-$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-1-DDL2,DDL1,DDL2-DDL1,1,.DIDPG)
End DoDot:1
if M=U
QUIT
+13 if M=U
GOTO ND
+14 ;
+15 IF $DATA(^DD("KEY","B",+X))
Begin DoDot:1
+16 NEW DIDPG
+17 SET DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1"
+18 DO PRINT^DIKKP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG)
End DoDot:1
if M=U
GOTO ND
+19 IF $DATA(^DD("IX","B",+X))
Begin DoDot:1
+20 NEW DIDPG
+21 SET DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1"
+22 DO LIST^DIKCP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG)
End DoDot:1
if M=U
GOTO ND
SUB SET Z=Z+1
SET DDL1=DDL1+2
SET DDL2=DDL2+2
SET F(Z)=+X
+1 DO L
N KILL DDN1
IF X["X"
SET DDN1=1
WRITE !,?DDL1,"NOTES:",?DDL2,"XXXX--CAN'T BE ALTERED EXCEPT BY PROGRAMMER"
WRITE !
if M=U
GOTO ND
+1 SET W=0
IF $ORDER(^DD(F(Z),DJ(Z),5,W))'=""
IF '$DATA(DDN1)
WRITE !?DDL1,"NOTES:"
TR SET W=$ORDER(^DD(F(Z),DJ(Z),5,W))
if W=""
SET W=-1
if W'>0
GOTO IX
SET I=^(W,0)
SET %=+I
IF '$DATA(^DD(%,$PIECE(I,U,2),0))!$DATA(W(I))
KILL ^DD(F(Z),DJ(Z),5,W)
GOTO TR
+1 SET W(I)=0
SET WS=W
DO WR^DIDH1
WRITE !
SET W=WS
KILL WS
GOTO TR
IX SET F=0
FOR
if M=U
GOTO ND
SET F=$ORDER(^DD(F(Z),DJ(Z),1,F))
if F'>0
QUIT
WRITE !?DDL1,"CROSS-REFERENCE:"
DO IX1
+1 if F=""
SET F=-1
+2 IF $DATA(^DD("IX","F",F(Z),DJ(Z)))
Begin DoDot:1
+3 NEW DIDPG,DIDFLAG
+4 SET DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1"
+5 SET DIDFLAG="L"_DDL1_"C"_(DDL2-DDL1)_"T1"
+6 DO PRINT^DIKCP(F(Z),DJ(Z),$EXTRACT("R",$GET(DIDRANGE))_"FS"_DIDFLAG_$EXTRACT("N",$DATA(DINM)#2),.DIDPG)
if M=U
QUIT
+7 if '$GET(DIDRANGE)
DO LIST^DIKCP(F(Z),DJ(Z),"RS"_DIDFLAG,.DIDPG)
End DoDot:1
if M=U
SET DN=0
ND SET X=""
if M'=U
if Z>1
GOTO A
+1 QUIT
IX1 SET W=^(F,0)_" "
KILL DDF
WRITE ?DDL2,W,!
if M=U
GOTO ND
if $PIECE(W,U,3)["TRIG"
DO TP
IF '$DATA(DINM)
SET X=0
FOR %=0:0
SET X=$ORDER(^DD(F(Z),DJ(Z),1,F,X))
if X=""
QUIT
IF X'="%D"
IF X'="DT"
SET W=^(X)
if $LENGTH(W)<248
SET W=X_")= "_W
if X=3
KILL DDF
DO W
WRITE !
if M=U
GOTO ND
+1 if '$DATA(^("%D"))
QUIT
+2 ;
+3 NEW DIDI,DIDN,DIDZ,DIWF,DIWL,DIWR,X
+4 KILL ^UTILITY($JOB,"W")
+5 SET DIWF="W"
SET DIWL=DDL2+1
SET DIWR=IOM
SET DIDZ=Z
+6 SET DIDN=$PIECE($GET(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",0)),U,3)
SET DIDI=0
+7 FOR
SET DIDI=$ORDER(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",DIDI))
if 'DIDI!(DIDN&(DIDI>DIDN))
QUIT
SET X=^(DIDI,0)
DO ^DIWP
IF $DATA(DN)
IF 'DN
SET M=U
QUIT
+8 IF M'=U
DO ^DIWW
IF $DATA(DN)
IF 'DN
SET M=U
+9 IF M'=U
WRITE !
+10 IF '$TEST
KILL DIOEND
+11 SET Z=DIDZ
+12 KILL ^UTILITY($JOB,"W")
+13 QUIT
+14 ;
CHKWP(F,Z) ;F=file, Z=field - return subdd of WP or 0 ;p19
+1 NEW W,Y
+2 SET W=$PIECE($GET(^DD(F,Z,0)),U,2)
if 'W
QUIT 0
+3 SET Y=$PIECE($GET(^DD(W,.01,0)),U,2)
+4 QUIT $SELECT(Y["W":W,1:0)
+5 ;
TP ;TRIGGER POINTER. SHOULD BE A DO-DOT UNDER IX1
+1 SET X=+$PIECE(^(0),U,4)
IF F(Z)-X
IF $DATA(^DIC(X,0))#2
SET ^UTILITY($JOB,"P",$EXTRACT($PIECE(^(0),U,1),1,30),0)=X
SET ^(F(Z),DJ(Z))=6
+2 QUIT
+3 ;
WPW(X) ;word processing write
+1 if $LENGTH(X)+$X+5>IOM
WRITE !?18
WRITE " ",X
+2 QUIT
+3 ;
W FOR K=0:0
if $DATA(DDF)
WRITE !
if (($LENGTH(W)+DDL2)>IOM)
SET DDL2=32
WRITE ?DDL2
SET %Y=$EXTRACT(W,IOM-$X,999)
WRITE $EXTRACT(W,1,IOM-$X-1)
if %Y=""
QUIT
SET W=%Y
SET DDF=1
+1 if 'X
KILL DDF
if $Y+6<IOSL
QUIT
HD SET DC=DC+1
DO ^DIDH
QUIT
