- DIETED ;SFISC/GFT SCREEN-EDIT AN INPUT TEMPLATE ;22MAY2006
- ;;22.0;VA FileMan;**111,159**;Mar 30, 1999;Build 8
- ;Per VHA Directive 2004-038, this routine should not be modified.
- 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
- X ^%ZOSF("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
- D PROCESS("^TMP(""DIETED"",$J)")
- X ^%ZOSF("EON")
- 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 W " ERROR!"
- 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"
- .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
- DIETED ;SFISC/GFT SCREEN-EDIT AN INPUT TEMPLATE ;22MAY2006
- +1 ;;22.0;VA FileMan;**111,159**;Mar 30, 1999;Build 8
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 NEW DIC,DIET,DRK,DIETED,I,J,DDSCHG
- +4 SET DIC=.402
- SET DIC(0)="AEQ"
- DO ^DIC
- IF Y<1
- QUIT
- +5 SET DIET=+Y
- DO E
- +6 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 XECUTE ^%ZOSF("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 DO PROCESS("^TMP(""DIETED"",$J)")
- +4 XECUTE ^%ZOSF("EON")
- +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 IF LINE<0
- WRITE " ERROR!"
- +8 QUIT
- +9 ;
- 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 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 DIETED_source.html#xD">DIC("S")="S %=$P(^(0),U,2) I %,$DIETED_source.html#xD">D(^DIETED_source.html#xD">DDIETED_source.html#xD">D(+%,.01,0)),$P(^(0),U,2)[""W"",$DIETED_source.html#xD">D(^DIETED_source.html#xD">DDIETED_source.html#xD">D(DIETED_source.html#xD">DI,Y,0)) "_DIETED_source.html#xD">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
