DIETED ;SFISC/GFT - SCREEN EDIT AN INPUT TEMPLATE ; Nov 15, 2012
;;22.2;VA FileMan;**18**;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.
;
N DIC,DIET,DRK,DIETED,I,J,DDSCHG
S DIC=.402,DIC(0)="AEQ" D ^DIC Q:Y<1
S DIET=+Y D E
D PUT
K K ^UTILITY("DIETEDIAB",$J),^UTILITY("DIETED",$J)
Q
;
EDIT(DIET) ; Edit Template using Screen Editor
N DRK,DIETED,I,J
E N DUOUT,DTOUT,DP,DI,D0,DIETROW,DIETEDER,DIETH,DR,F,L,DB
D:'$D(DISYS) OS^DII X ^DD("OS",DISYS,"EON")
I '$D(^DIE(DIET,0)) W !,"NO TEMPLATE SELECTED",! Q
S DIETED="Input Template """_$P(^(0),U)_""""
W "..."
D GET("^TMP(""DIETED"",$J)")
S DIETH="Editing "_DIETED,DIETROW=1,DRK=$P(^DIE(DIET,0),U,4)
DDW D EDIT^DDW("^TMP(""DIETED"",$J)","M",DIETH,"(File "_DRK_")",DIETROW)
I $D(DUOUT)!$D(DTOUT) K DR G KL
D K K I,J
X ^DD("OS",DISYS,"EON") ;p18
D PROCESS("^TMP(""DIETED"",$J)")
S DIETROW=$O(DIETEDER(0)) I DIETROW S DIETH="ERROR! Re-editing "_DIETED K DIETEDER G DDW
S DDSCHG=1
KL K ^TMP("DIETED",$J)
I '$D(DR) W $C(7),$$EZBLD^DIALOG(8077) Q
M ^UTILITY("DIETED",$J)=DR
Q
;
GET(DIETA,DIT) ;put displayable template into @DIETA
N DIAO,DIETREL,DIETAD,DB,DIAT,I,J,L,DIAR,DIAB
K @DIETA
I '$D(DIT) S DIT=$NA(^DIE(DIET))
S (DR,DIAT)="",(DIETAD,L,DIAO,DB,DIAR)=0,F=-1
S J(0)=$P(@DIT@(0),U,4)
M DI=^("DIAB") S DI=J(0)
D DOWN
1 S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" S DB=DB+1 G 1
S %=+Y I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2),%=""
I %_"T~"=Y!(%_"t~"=Y),$P($G(^DD(DI,%,0)),U,2) S Y=% ;HWH-1103-40934 -- ignore TITLE of MULTIPLE
S DIETREL="",DIAB=$G(DI(DB,DIAR-1,DI,DIAO)) E S:Y?1"^".E DIETREL=Y S:DIAB]"" Y=DIAB
I Y?1"]".E S Y=$E(Y,2,999)
I DIAB="",%,$D(^DD(DI,%,0)) S Y=$P(^(0),U)_$P(Y,%,2,999)
S DB=DB+1,DIETAD=DIETAD+1,@DIETA@(DIETAD)=$J("",F*3)_Y I DIETREL]"" D G 1 ;Put it in!
.S L=L\100+1*100,(J(L),DI)=$P(DIETREL,U,2) D DOWN ;Relational jump
I % S %=+$P($G(^DD(DI,%,0)),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'["W" S L=L+1,(J(L),DI)=% D DOWN ;Down to a multiple
I Y="ALL" G UP
G 1
;
DOWN S F=F+1,DIAR(F)=DIAR,DIAR=DIAR+1,%=$P(DIAT,";",DB) S:%?1"^"1.NP DB=DB+1,DIAR=$P(%,U,2)
S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0
DIAT S DIAT=$G(@DIT@("DR",DIAR,DI),"ALL") Q
;
NDB I DIAO'<0 S DIAO=DIAO+1 I $D(@DIT@("DR",DIAR,DI,DIAO)) S DIAT=^(DIAO),DB=1 G 1
S DIAO=-1
UP Q:'F K I(L),J(L) S L=$O(J(L),-1)
S DIAR=DIAR(F),DB=DB(F),DIAO=DIAO(F),DI=J(L),DIAT=$S(DIAO<0:"",DIAO:@DIT@("DR",DIAR,J(L),DIAO),1:$G(@DIT@("DR",DIAR,DI))),F=F-1 G 1
;
;
;
;
PROCESS(DIETA) ;puts nodes into ^UTILITY("DIETED")
N DIAB,LINE,DXS,L,DIAP,DIETSL,DQI,DIETSAVE,DIETAB,ERR,DIAR
K DR S F=0,(DI,J(0))=DRK,I(0)=^DIC(J(0),0,"GL"),DIAP="",(L,DIETAB)=0,DXS=1,DIAR=1
F LINE=1:1 Q:'$D(@DIETA@(LINE)) K ERR S X=^(LINE) D
.I X?1"^".E S LINE=999999999 K DR Q
.D LINE(X)
.I $D(ERR) W !!,"LINE ",LINE S DIETEDER(LINE)=ERR,LINE=-LINE Q ;stop if we find one error
I LINE<0 D ;p18
. N %
. W " ERROR!",!!,"Press RETURN to continue" R:DTIME %
Q
;
LINE(X) ;Process one LINE from the screen
N D,DIC,DICMX,DV,DATE,Y,DICOMPX,DICOMP,DRR
F D=$L(X):-1:1 Q:$A(X,D)>32 S X=$E(X,1,D-1)
F D=0:1 Q:$A(X)-32 S X=$E(X,2,999) ;strip off 'D' leading spaces
Q:X=""
OUT I D<DIETAB,L K I(L),J(L) S L=$O(J(L),-1),DIAP=DIAP(F),DIAR=DIAR(F),DIETAB=$G(DIETAB(F),D),F=F-1,DI=J(L) G OUT ;out-dentation means go up a level (or more)
S DIETAB=D
I X?1"@"1.N S Y=X G DR
ALL D DICS^DIA I X="ALL" D Q
.S ^UTILITY("DIETEDIAB",$J,1,DIAR-1,DI,DIAP\1000)=X
.N D,DA,DG D RANGE^DIA1
S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-")=+X,J>X D G X:Y="",DR
.N D,DA,DG S D(F)=J D RANGE^DIA1 S Y=DA
SEMIC I X[";" S Y=X,X=$P(X,";") D G X:'$D(Y) S DIAB=Y
.F %=2:1:$L(Y,";") S D=$P(Y,";",%),D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),D="T":D,1:""),DV=D_$C(126)_DV I $A(D)>45&($A(D)<58)!(D[":")!(D="") K Y Q
DIC S DIC(0)="OZ",DIC="^DD(DI," D ^DIC
I Y>0 S Y=+Y_DV D DR S %=+$P(Y(0),U,2) D:% Q
.I $P($G(^DD(+%,.01,0)),U,2)["W" Q
.S L=L+1,(DI,J(L))=+%,I(L)=""""_$P($P(Y(0),U,4),";")_"""" D D
S (Y,DIETSAVE)=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) DR:X=DIETSAVE I DIETSAVE["//^",'$D(X) G X
F DIETSL="///+","//+","///","//" I DIETSAVE[DIETSL S DP=$P(DIETSAVE,DIETSL,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF
I DIETSAVE?.E1":" S:'$D(DIAB) DIAB=DIETSAVE K X S X=DIETSAVE,DICOMP=L_"WE",DQI="Y(",DA="DR(99,"_DXS_",",DICMX=1 D ^DICOMPW G L:$D(X) ;as in E^DIA3
X S ERR=1 Q
;
L I $D(X)>1 M DR(99,DXS)=X S DXS=DXS+1
S %=-1,L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")" K X
D DR S DI=+DP D D
Q
;
D N % S F=F+1,DIAR(F)=DIAR F %=F+1:.01 Q:'$D(DR(%,DI))
S:%["." @DRR=@DRR_U_%_";",DIAP=DIAP+1 S DIAR=%
S DIAP(F)=DIAP,DIAP=0,DIETAB(F)=DIETAB Q
;
DEF S X=DIETSAVE D S X=$P(DIETSAVE,DIETSL),DV=DV_DIETSL_DP G X:DV[";",DIC ;as in DEF^DIA3
.S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X
.S DICMX="S DWLC=DWLC+1,"_I(J)_X,DA="DR(99,"_DXS_",",X=DP,DQI="X(",DICOMP=L_"T?" ;p18
.D EN^DICOMP,DICS^DIA
XEC .I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") ;as in XEC^DIA3
.S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)")
.S Y=-1 I $D(X) S Y="Q",DXS=DXS+1,DP=U_X D
..D S:'$D(DIAB) DIAB=DIETSAVE ;assume "YOU MEAN as a VARIABLE"
...N DIAB D DR
.I DP="@",DIETSL="//" S DA=U_U
.Q
;
DR ;takes 'Y' and puts it into 'DR' array
N %,B
S (DRR,B)=$NA(DR(DIAR,DI)),%=$O(@DRR@(""),-1)
I % S DRR=$NA(@DRR@(%))
I '$D(@DRR) S @DRR="",DIAP=0
I $L(Y)+$L(@DRR)>230 S DRR=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@DRR=""
S @DRR=@DRR_Y_";"
S DIAP=DIAP+1
DIAB I $D(DIAB) S ^UTILITY("DIETEDIAB",$J,DIAP#1000,DIAR-1,DI,DIAP\1000)=DIAB K DIAB
Q
;
PUT ;save template
I '$D(^UTILITY("DIETED",$J)) Q
N DIC
S DIC("B")=DIET
SAVEAS S DIC=.402,DIC("A")="Save revised "_DIETED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK"
D ^DIC
Q:Y<0 I $O(^DIE(+Y,0))]"" W !,$C(7),"Are you sure you want to overwrite this '",$P(Y,U,2)," 'Template" S %=1 D YN^DICN I %-1 Q:%<2 K DIC("B") G SAVEAS
L +^DIE(+Y)
S ^DIE("F"_J(0),$P(Y,U,2),+Y)=1
S $P(^DIE(+Y,0),U,4)=J(0)
L -^DIE(+Y)
D SAVEFLDS(+Y)
Q
;
SAVEFLDS(Y) ;
N X,DP,DMAX
Q:'$D(^UTILITY("DIETED",$J))!'$G(Y)
NOW D NOW^%DTC S $P(^DIE(Y,0),U,2)=+$J(%,0,4)
S $P(^DIE(Y,0),U,5)=$G(DUZ)
K ^DIE(Y,"DR") M ^DIE(+Y,"DR")=^UTILITY("DIETED",$J)
K ^DIE(Y,"DIAB") M ^DIE(+Y,"DIAB")=^UTILITY("DIETEDIAB",$J)
S X=$S('$D(^DIE(+Y,"ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),DP=+$P(^(0),U,4),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ
D K
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIETED 6907 printed Dec 13, 2024@02:47:19 Page 2
DIETED ;SFISC/GFT - SCREEN EDIT AN INPUT TEMPLATE ; Nov 15, 2012
+1 ;;22.2;VA FileMan;**18**;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 ;
+7 NEW DIC,DIET,DRK,DIETED,I,J,DDSCHG
+8 SET DIC=.402
SET DIC(0)="AEQ"
DO ^DIC
if Y<1
QUIT
+9 SET DIET=+Y
DO E
+10 DO PUT
K KILL ^UTILITY("DIETEDIAB",$JOB),^UTILITY("DIETED",$JOB)
+1 QUIT
+2 ;
EDIT(DIET) ; Edit Template using Screen Editor
+1 NEW DRK,DIETED,I,J
E NEW DUOUT,DTOUT,DP,DI,D0,DIETROW,DIETEDER,DIETH,DR,F,L,DB
+1 if '$DATA(DISYS)
DO OS^DII
XECUTE ^DD("OS",DISYS,"EON")
+2 IF '$DATA(^DIE(DIET,0))
WRITE !,"NO TEMPLATE SELECTED",!
QUIT
+3 SET DIETED="Input Template """_$PIECE(^(0),U)_""""
+4 WRITE "..."
+5 DO GET("^TMP(""DIETED"",$J)")
+6 SET DIETH="Editing "_DIETED
SET DIETROW=1
SET DRK=$PIECE(^DIE(DIET,0),U,4)
DDW DO EDIT^DDW("^TMP(""DIETED"",$J)","M",DIETH,"(File "_DRK_")",DIETROW)
+1 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DR
GOTO KL
+2 DO K
KILL I,J
+3 ;p18
XECUTE ^DD("OS",DISYS,"EON")
+4 DO PROCESS("^TMP(""DIETED"",$J)")
+5 SET DIETROW=$ORDER(DIETEDER(0))
IF DIETROW
SET DIETH="ERROR! Re-editing "_DIETED
KILL DIETEDER
GOTO DDW
+6 SET DDSCHG=1
KL KILL ^TMP("DIETED",$JOB)
+1 IF '$DATA(DR)
WRITE $CHAR(7),$$EZBLD^DIALOG(8077)
QUIT
+2 MERGE ^UTILITY("DIETED",$JOB)=DR
+3 QUIT
+4 ;
GET(DIETA,DIT) ;put displayable template into @DIETA
+1 NEW DIAO,DIETREL,DIETAD,DB,DIAT,I,J,L,DIAR,DIAB
+2 KILL @DIETA
+3 IF '$DATA(DIT)
SET DIT=$NAME(^DIE(DIET))
+4 SET (DR,DIAT)=""
SET (DIETAD,L,DIAO,DB,DIAR)=0
SET F=-1
+5 SET J(0)=$PIECE(@DIT@(0),U,4)
+6 MERGE DI=^("DIAB")
SET DI=J(0)
+7 DO DOWN
1 SET Y=$PIECE(DIAT,";",DB)
IF "Q"[Y
if Y=""
GOTO NDB
SET DB=DB+1
GOTO 1
+1 SET %=+Y
IF Y?.NP
IF $PIECE(Y,":",2)
IF Y'["/"
SET Y=+Y_"-"_$PIECE(Y,":",2)
SET %=""
+2 ;HWH-1103-40934 -- ignore TITLE of MULTIPLE
IF %_"T~"=Y!(%_"t~"=Y)
IF $PIECE($GET(^DD(DI,%,0)),U,2)
SET Y=%
+3 SET DIETREL=""
SET DIAB=$GET(DI(DB,DIAR-1,DI,DIAO))
IF '$TEST
if Y?1"^".E
SET DIETREL=Y
if DIAB]""
SET Y=DIAB
+4 IF Y?1"]".E
SET Y=$EXTRACT(Y,2,999)
+5 IF DIAB=""
IF %
IF $DATA(^DD(DI,%,0))
SET Y=$PIECE(^(0),U)_$PIECE(Y,%,2,999)
+6 ;Put it in!
SET DB=DB+1
SET DIETAD=DIETAD+1
SET @DIETA@(DIETAD)=$JUSTIFY("",F*3)_Y
IF DIETREL]""
Begin DoDot:1
+7 ;Relational jump
SET L=L\100+1*100
SET (J(L),DI)=$PIECE(DIETREL,U,2)
DO DOWN
End DoDot:1
GOTO 1
+8 ;Down to a multiple
IF %
SET %=+$PIECE($GET(^DD(DI,%,0)),U,2)
IF %
IF $PIECE($GET(^DD(%,.01,0)),U,2)'["W"
SET L=L+1
SET (J(L),DI)=%
DO DOWN
+9 IF Y="ALL"
GOTO UP
+10 GOTO 1
+11 ;
DOWN SET F=F+1
SET DIAR(F)=DIAR
SET DIAR=DIAR+1
SET %=$PIECE(DIAT,";",DB)
if %?1"^"1.NP
SET DB=DB+1
SET DIAR=$PIECE(%,U,2)
+1 SET DB(F)=DB
SET DB=1
SET DIAO(F)=DIAO
SET DIAO=0
DIAT SET DIAT=$GET(@DIT@("DR",DIAR,DI),"ALL")
QUIT
+1 ;
NDB IF DIAO'<0
SET DIAO=DIAO+1
IF $DATA(@DIT@("DR",DIAR,DI,DIAO))
SET DIAT=^(DIAO)
SET DB=1
GOTO 1
+1 SET DIAO=-1
UP if 'F
QUIT
KILL I(L),J(L)
SET L=$ORDER(J(L),-1)
+1 SET DIAR=DIAR(F)
SET DB=DB(F)
SET DIAO=DIAO(F)
SET DI=J(L)
SET DIAT=$SELECT(DIAO<0:"",DIAO:@DIT@("DR",DIAR,J(L),DIAO),1:$GET(@DIT@("DR",DIAR,DI)))
SET F=F-1
GOTO 1
+2 ;
+3 ;
+4 ;
+5 ;
PROCESS(DIETA) ;puts nodes into ^UTILITY("DIETED")
+1 NEW DIAB,LINE,DXS,L,DIAP,DIETSL,DQI,DIETSAVE,DIETAB,ERR,DIAR
+2 KILL DR
SET F=0
SET (DI,J(0))=DRK
SET I(0)=^DIC(J(0),0,"GL")
SET DIAP=""
SET (L,DIETAB)=0
SET DXS=1
SET DIAR=1
+3 FOR LINE=1:1
if '$DATA(@DIETA@(LINE))
QUIT
KILL ERR
SET X=^(LINE)
Begin DoDot:1
+4 IF X?1"^".E
SET LINE=999999999
KILL DR
QUIT
+5 DO LINE(X)
+6 ;stop if we find one error
IF $DATA(ERR)
WRITE !!,"LINE ",LINE
SET DIETEDER(LINE)=ERR
SET LINE=-LINE
QUIT
End DoDot:1
+7 ;p18
IF LINE<0
Begin DoDot:1
+8 NEW %
+9 WRITE " ERROR!",!!,"Press RETURN to continue"
if DTIME
READ %
End DoDot:1
+10 QUIT
+11 ;
LINE(X) ;Process one LINE from the screen
+1 NEW D,DIC,DICMX,DV,DATE,Y,DICOMPX,DICOMP,DRR
+2 FOR D=$LENGTH(X):-1:1
if $ASCII(X,D)>32
QUIT
SET X=$EXTRACT(X,1,D-1)
+3 ;strip off 'D' leading spaces
FOR D=0:1
if $ASCII(X)-32
QUIT
SET X=$EXTRACT(X,2,999)
+4 if X=""
QUIT
OUT ;out-dentation means go up a level (or more)
IF D<DIETAB
IF L
KILL I(L),J(L)
SET L=$ORDER(J(L),-1)
SET DIAP=DIAP(F)
SET DIAR=DIAR(F)
SET DIETAB=$GET(DIETAB(F),D)
SET F=F-1
SET DI=J(L)
GOTO OUT
+1 SET DIETAB=D
+2 IF X?1"@"1.N
SET Y=X
GOTO DR
ALL DO DICS^DIA
IF X="ALL"
Begin DoDot:1
+1 SET ^UTILITY("DIETEDIAB",$JOB,1,DIAR-1,DI,DIAP\1000)=X
+2 NEW D,DA,DG
DO RANGE^DIA1
End DoDot:1
QUIT
+3 SET DV=""
SET J=$PIECE(X,"-",2)
IF +J=J
IF $PIECE(X,"-")=+X
IF J>X
Begin DoDot:1
+4 NEW D,DA,DG
SET D(F)=J
DO RANGE^DIA1
SET Y=DA
End DoDot:1
if Y=""
GOTO X
GOTO DR
SEMIC IF X[";"
SET Y=X
SET X=$PIECE(X,";")
Begin DoDot:1
+1 FOR %=2:1:$LENGTH(Y,";")
SET D=$PIECE(Y,";",%)
SET D=$SELECT(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$ASCII(D)=34:$EXTRACT(D,2,$FIND(D,"""",2)-2),D="T":D,1:"")
SET DV=D_$CHAR(126)_DV
IF $ASCII(D)>45&($ASCII(D)<58)!(D[":")!(D="")
KILL Y
QUIT
End DoDot:1
if '$DATA(Y)
GOTO X
SET DIAB=Y
DIC SET DIC(0)="OZ"
SET DIC="^DD(DI,"
DO ^DIC
+1 IF Y>0
SET Y=+Y_DV
DO DR
SET %=+$PIECE(Y(0),U,2)
if %
Begin DoDot:1
+2 IF $PIECE($GET(^DD(+%,.01,0)),U,2)["W"
QUIT
+3 SET L=L+1
SET (DI,J(L))=+%
SET I(L)=""""_$PIECE($PIECE(Y(0),U,4),";")_""""
DO D
End DoDot:1
QUIT
+4 SET (Y,DIETSAVE)=X
IF DUZ(0)="@"
IF X'?.E1":"
SET X=$SELECT(X["//^":$PIECE(X,"//^",2),1:X)
SET X=$SELECT(X[";":$PIECE(X,";"),1:X)
DO ^DIM
if $DATA(X)
if X=DIETSAVE
GOTO DR
IF DIETSAVE["//^"
IF '$DATA(X)
GOTO X
+5 FOR DIETSL="///+","//+","///","//"
IF DIETSAVE[DIETSL
SET DP=$PIECE(DIETSAVE,DIETSL,2,9)
IF DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@")
GOTO DEF
+6 ;as in E^DIA3
IF DIETSAVE?.E1":"
if '$DATA(DIAB)
SET DIAB=DIETSAVE
KILL X
SET X=DIETSAVE
SET DICOMP=L_"WE"
SET DQI="Y("
SET DA="DR(99,"_DXS_","
SET DICMX=1
DO ^DICOMPW
if $DATA(X)
GOTO L
X SET ERR=1
QUIT
+1 ;
L IF $DATA(X)>1
MERGE DR(99,DXS)=X
SET DXS=DXS+1
+1 SET %=-1
SET L=$SELECT(Y>L:+Y,1:L\100+1*100)
SET Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")"
KILL X
+2 DO DR
SET DI=+DP
DO D
+3 QUIT
+4 ;
D NEW %
SET F=F+1
SET DIAR(F)=DIAR
FOR %=F+1:.01
if '$DATA(DR(%,DI))
QUIT
+1 if %["."
SET @DRR=@DRR_U_%_";"
SET DIAP=DIAP+1
SET DIAR=%
+2 SET DIAP(F)=DIAP
SET DIAP=0
SET DIETAB(F)=DIETAB
QUIT
+3 ;
DEF ;as in DEF^DIA3
SET X=DIETSAVE
Begin DoDot:1
+1 SET X="DA,DV,DWLC,0)=X"
FOR J=L:-1
if I(J)[U
QUIT
SET X="DA("_(L-J+1)_"),"_I(J)_","_X
+2 ;p18
SET DICMX="S DWLC=DWLC+1,"_I(J)_X
SET DA="DR(99,"_DXS_","
SET X=DP
SET DQI="X("
SET DICOMP=L_"T?"
+3 DO EN^DICOMP
DO DICS^DIA
XEC ;as in XEC^DIA3
IF $DATA(X)
IF Y["m"
SET DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S")
+1 SET Y=0
FOR
SET Y=$ORDER(X(Y))
if Y=""
QUIT
SET @(DA_"Y)=X(Y)")
+2 SET Y=-1
IF $DATA(X)
SET Y="Q"
SET DXS=DXS+1
SET DP=U_X
Begin DoDot:2
+3 ;assume "YOU MEAN as a VARIABLE"
Begin DoDot:3
+4 NEW DIAB
DO DR
End DoDot:3
if '$DATA(DIAB)
SET DIAB=DIETSAVE
End DoDot:2
+5 IF DP="@"
IF DIETSL="//"
SET DA=U_U
+6 QUIT
End DoDot:1
SET X=$PIECE(DIETSAVE,DIETSL)
SET DV=DV_DIETSL_DP
if DV[";"
GOTO X
GOTO DIC
+7 ;
DR ;takes 'Y' and puts it into 'DR' array
+1 NEW %,B
+2 SET (DRR,B)=$NAME(DR(DIAR,DI))
SET %=$ORDER(@DRR@(""),-1)
+3 IF %
SET DRR=$NAME(@DRR@(%))
+4 IF '$DATA(@DRR)
SET @DRR=""
SET DIAP=0
+5 IF $LENGTH(Y)+$LENGTH(@DRR)>230
SET DRR=$NAME(@B@(%+1))
SET DIAP=DIAP\1000+1*1000
SET @DRR=""
+6 SET @DRR=@DRR_Y_";"
+7 SET DIAP=DIAP+1
DIAB IF $DATA(DIAB)
SET ^UTILITY("DIETEDIAB",$JOB,DIAP#1000,DIAR-1,DI,DIAP\1000)=DIAB
KILL DIAB
+1 QUIT
+2 ;
PUT ;save template
+1 IF '$DATA(^UTILITY("DIETED",$JOB))
QUIT
+2 NEW DIC
+3 SET DIC("B")=DIET
SAVEAS SET DIC=.402
SET DIC("A")="Save revised "_DIETED_" as: "
SET DIC(0)="AEQL"
SET DIC("S")="I $P(^(0),U,4)=DRK"
+1 DO ^DIC
+2 if Y<0
QUIT
IF $ORDER(^DIE(+Y,0))]""
WRITE !,$CHAR(7),"Are you sure you want to overwrite this '",$PIECE(Y,U,2)," 'Template"
SET %=1
DO YN^DICN
IF %-1
if %<2
QUIT
KILL DIC("B")
GOTO SAVEAS
+3 LOCK +^DIE(+Y)
+4 SET ^DIE("F"_J(0),$PIECE(Y,U,2),+Y)=1
+5 SET $PIECE(^DIE(+Y,0),U,4)=J(0)
+6 LOCK -^DIE(+Y)
+7 DO SAVEFLDS(+Y)
+8 QUIT
+9 ;
SAVEFLDS(Y) ;
+1 NEW X,DP,DMAX
+2 if '$DATA(^UTILITY("DIETED",$JOB))!'$GET(Y)
QUIT
NOW DO NOW^%DTC
SET $PIECE(^DIE(Y,0),U,2)=+$JUSTIFY(%,0,4)
+1 SET $PIECE(^DIE(Y,0),U,5)=$GET(DUZ)
+2 KILL ^DIE(Y,"DR")
MERGE ^DIE(+Y,"DR")=^UTILITY("DIETED",$JOB)
+3 KILL ^DIE(Y,"DIAB")
MERGE ^DIE(+Y,"DIAB")=^UTILITY("DIETEDIAB",$JOB)
+4 SET X=$SELECT('$DATA(^DIE(+Y,"ROU")):1,^("ROU")'[U:1,$DATA(^("ROUOLD")):^("ROUOLD"),1:1)
SET DP=+$PIECE(^(0),U,4)
SET DMAX=^DD("ROU")
IF X'=1
IF $DATA(^DD("OS",DISYS,"ZS"))
DO EN^DIEZ
+5 DO K
+6 QUIT
