DIPTED ;SFISC/GFT-EDIT PRINT TEMPLATE ;2013-07-10 2:34 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.
;
N DIC,DIPT,DIPTED,DRK,DIPTEDTY,I,J
S DIC=.4,DIC(0)="AEQ",DIC("S")="I $P(^(0),U,8)=7!'$P(^(0),U,8)" D ^DIC Q:Y<1
K DIC
S DIPT=+Y D E
D PUT
K K ^TMP("DIPTED",$J),^UTILITY("DIP2",$J)
Q
;
EDIT(DIPT) ; EDIT PRINT TEMPLATE 'DIPT' VIA VA FILEMAN SCREEN EDITOR
N DIPTED,DRK,DIPTEDTY,I,J
E N DA,D0,DUOUT,DTOUT,DIPTEDER,DIPTH,L,DY,Y,DIPTX,D,C,Q,DIPTROW,DCL,DXS,DNP,DHD,DISH,DV,DJ,DL,DK,DIL
D:'$D(DISYS) OS^DII X ^DD("OS",DISYS,"EON")
I '$D(^DIPT(DIPT,0)) W !,"NO TEMPLATE SELECTED",! Q
S DIPTED="Print",DIPTEDTY=$P(^(0),U,8) I DIPTEDTY=7 S DIPTED="EXPORT FIELDS"
S DIPTED=DIPTED_" Template """_$P(^(0),U)_""""
D GET("^TMP(""DIPTED"",$J)")
S DIPTH="Editing "_DIPTED,DIPTROW=1
DDW D EDIT^DDW("^TMP(""DIPTED"",$J)","M",DIPTH,"(File "_DRK_")",DIPTROW)
K ^UTILITY($J,0),^UTILITY("DIP2",$J),I,J
I $D(DTOUT)!$D(DUOUT) K ^TMP("DIPTED",$J) W $C(7),$$EZBLD^DIALOG(8077) Q
S (DV,DNP)="",(DIL,DJ)=0,(DL,DXS)=1,DK=DRK,J(0)=DK,I(0)=^DIC(DK,0,"GL")
D PROCESS("^TMP(""DIPTED"",$J)")
X ^DD("OS",DISYS,"EON")
S DIPTROW=$O(DIPTEDER(0)) I DIPTROW W " ",DIPTEDER(DIPTROW) H 2 S DIPTH="ERROR! Re-editing "_DIPTED K DIPTEDER G DDW
I '$D(^UTILITY("DIP2",$J)) W "<NOTHING TO SAVE>",$C(7) G K
S DDSCHG=1
I $D(DXS)>9 M ^UTILITY("DIP2",$J,U,"DXS")=DXS
M ^UTILITY("DIP2",$J,U,"DCL")=DCL
I $D(DNP) S ^UTILITY("DIP2",$J,U,"DNP")=1
I $G(DISH) S ^("SUB")=1
I $G(DHD)]"" S ^("H")=DHD
Q
;
GET(DIPTA,DIT) ;put displayable template into @DIPTA
N DS,DIWD,D9,D0
K @DIPTA
I '$D(DIT) S DIT=$NA(^DIPT(DIPT)),D0=DIPT
E S D0=-1
S (DRK,J(0))=$P(@DIT@(0),U,4),L=0,D(L)="0FIELD",C=",",D9="",Y=2,Q="""",DHD=$G(^("H")),DISH=$D(^("SUB"))
F DS(1)=0:0 S DS(1)=$O(@DIT@("F",DS(1))) Q:DS(1)="" S DY=^(DS(1)) D Y^DIPT
D:D9]"" UP^DIPT
F D=2:1 Q:'$D(DS(D)) S @DIPTA@(D-1)=$J("",D>2*$E($G(DIWD(D)))*3)_DS(D) ;indentation showing level of subfiles
Q
;
PROCESS(DIPTA) ;puts nodes into ^UTILITY("DIP2")
N D0,DM,DQI,DA,ERR,P,S,LINE,X,DIETAB
S DIETAB=0
F LINE=1:1 Q:'$D(@DIPTA@(LINE)) K ERR S X=^(LINE) D
.I X?1"^".E S LINE=999999999 K ^UTILITY("DIP2",$J) Q
.S X=$$LINE(X) I X]"" S ^($O(^UTILITY("DIP2",$J,""),-1)+1)=X Q
.I $D(ERR) W "LINE ",LINE S DIPTEDER(LINE)=ERR,LINE=-LINE Q ;stop if we find one error
I LINE<0 W " ERROR!" Q
Q
;
LINE(X) ;returns X as component of Template. DD number is currently 'DK'
N DIC,DICMX,DATE,Y,DICOMPX,DICOMP,DP,DJ
I X?." " Q ""
F P=$L(X):-1:1 Q:$A(X,P)>32 S X=$E(X,1,P-1) ;strip off trailing spaces
F P=0:1 Q:$A(X)-32 S X=$E(X,2,999) ;strip off 'P' leading spaces
I P<DIETAB,DL>1 F D U I DL-1*3'>P Q ;pop Up (MAYBE SEVERAL LEVELS) if we find outdentation
S DIETAB=P
F S (P,S)=""
LIT I $E(X)="""",$L(X,"""")#2 F I=3:2:$L(X,"""") Q:$P(X,"""",I)]""&($E($P(X,"""",I)'=$C(95)))
I I $P($P(X,"""",I),";")="" G DJ
S DIC="^DD(DK,",DIC(0)="ZO"
DIC I X="NUMBER" S Y=0 G S
D ^DIC G GF:Y>0
I X="" D U:DL>2 Q X
STRIP I DIPTEDTY-7 D G:'$D(D) DIC S X=$RE(X) D S X=$RE(X) G:'$D(D) DIC ;from beginning, then end
.F D="+","#","*","&","!" I $E(X)=D S P=D,X=$E(X,2,999) K D Q
I X[";" G EXP:DIPTEDTY=7 S S=";"_$P(X,";",2,99)_S,X=$P(X,";") G DIC
HARD S DM=X,DQI="DIP(",DA="DXS("_DXS_C,S=S_";Z;"""_X_"""",DICOMP=DIL_$E("?",''L)_"TI",DICOMPX=""
I X'?.E1":" S DICMX="X DICMX" D EN^DICOMP G QQ:'$D(X) D FLY^DIP22 S X=S G DJ
G EXP:DIPTEDTY=7 S DICMX="S DIXX=DIXX("_DL_") D M" D ^DICOMPW
I $D(X) D S S=U_$P(DP,U,2)_U_$E(1,Y["m")_U_S,DIL(DL)=DIL,DV(DL)=DV,DL(DL)=DK,DK=+DP,DV=DV_-DP_C,DL=DL+1,DIL=+Y,Y=0,X=DV_S K P G VAL3 ;relational jump
.N Y D OVFL^DIP22,F^DIP22
QQ S ERR="" Q ""
;
GF I $P(Y(0),U,2) D D S X=$P($P(Y(0),U,4),";"),I(DIL)=$S(+X=X:X,1:Q_X_Q),J(DIL)=DK G WORD:$P($G(^DD(DK,.01,0)),U,2)["W" Q "" ;down to a multiple
I +Y=.001 S Y=0
S S X=+Y_S
DJ S X=DV_X
VAL3 I DIPTEDTY'=7!(S'[";W"&(S'[";m")) S S="" D P Q X
EXP S ERR="NOT ALLOWED WHEN SELECTING EXPORT FIELDS" Q ""
;
P D:$D(P) Q
.I P="" K DNP Q
.I P="*" S DCL=$G(DCL)+1
.S DCL(DK_U_+Y)=$S($T:DCL_P,1:P)
;
D S DIL(DL)=DIL,DV(DL)=DV,DL(DL)=DK,DK=+$P(^DD(DK,+Y,0),U,2),DL=DL+1,DIL=DIL+1,DV=DV_+Y_C,Y=0 Q ;go Down a level
;
WORD I DIPTEDTY=7 G EXP
S Y=.01 D P S X=DV_Y_S D U Q X
;
U S DL=DL-1,DV=DV(DL),DK=DL(DL),DIL=DIL(DL) F %=DIL:0 S %=$O(I(%)) Q:%="" K I(%),J(%)
Q
;
SAVEFLDS(Y) ;POST-SAVE OF 'DIPTED' SCREENMAN FORM
N DMAX,J,X
Q:'$D(^UTILITY("DIP2",$J))!'$G(Y)
CLEAR S $X=0,$Y=0 I $G(IOXY)]"" N DX,DY S (DY,DX)=0 X IOXY W $C(27,91,74)
S Y=$$CLONE(Y) Q:'Y ;ASK 'SAVE AS'
D NOW^%DTC S $P(^DIPT(Y,0),U,2)=+$J(%,0,4)
S $P(^DIPT(Y,0),U,5)=$G(DUZ)
K ^DIPT(Y,"F") S J="" D D J
.F %=1:1 Q:'$D(^UTILITY("DIP2",$J,%)) S X=^(%) I X]"" D
..I $L(J)+$L(X)>150 D J S J=""
..S J=J_X_$C(126)
K ^DIPT(Y,"DXS"),^("DCL"),^("DNP")
M ^DIPT(Y)=^UTILITY("DIP2",$J,U)
I $D(^DIPT(Y,"ROU")) K ^("ROU") I $D(^("IOM")) S IOM=^("IOM") K ^("IOM") I $D(^("ROUOLD")) S X=^("ROUOLD") I X]"",$G(DISYS),$D(^DD("OS",DISYS,"ZS")) S DMAX=^DD("ROU") D ENZ^DIPZ I $D(^DIPT(DIPZ,"H")) S DHD=^("H")
D K
Q
;
J S ^($O(^DIPT(+Y,"F",""),-1)+1)=J Q
;
CLONE(DA) ;
N DIC,DIPTEDTY,DIPTEDFI,X,Y,DIPTEDNM,DDS
I '$D(^DIPT(DA,0)) Q 0
S (DIPTEDNM,DIC("B"))=$P(^(0),U)
ASK S DIPTEDFI=$P(^DIPT(DA,0),U,4),DIPTEDTY=$P(^(0),U,8) I 'DIPTEDFI Q 0
S DIC=.4,DIC("A")="Save revised Print Template "_DIPTEDNM_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DIPTEDFI,$P(^(0),U,8)=DIPTEDTY"
D ^DIC I Y<0 Q 0
I +Y=DA Q DA
I $O(^DIPT(+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 K DIC G ASK:%=2 Q 0
L +^DIPT(+Y):5 E W !,$C(7),"Sorry. Another user is editing this template." Q 0
S ^DIPT("F"_DIPTEDFI,$P(Y,U,2),+Y)=1
S $P(^DIPT(+Y,0),U,4)=DIPTEDFI,$P(^(0),U,8)=DIPTEDTY
L -^DIPT(+Y)
Q +Y
;
;
PUT ;save template from ^UTILITY
I '$D(^UTILITY("DIP2",$J)) Q
N DIC,DIPZ
S DIC("B")=DIPT
SAVEAS S DIC=.4,DIC("A")="Save revised "_DIPTED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK,$P(^(0),U,8)=DIPTEDTY"
D ^DIC
Q:Y<0 I $O(^DIPT(+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 +^DIPT(+Y):5 E W !,$C(7),"Sorry. Another user is editing this template." Q
S ^DIPT("F"_J(0),$P(Y,U,2),+Y)=1
S $P(^DIPT(+Y,0),U,4)=J(0),$P(^(0),U,8)=DIPTEDTY
L -^DIPT(+Y)
D SAVEFLDS(+Y)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIPTED 6698 printed Sep 23, 2025@20:29:34 Page 2
DIPTED ;SFISC/GFT-EDIT PRINT TEMPLATE ;2013-07-10 2:34 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 ;
+7 NEW DIC,DIPT,DIPTED,DRK,DIPTEDTY,I,J
+8 SET DIC=.4
SET DIC(0)="AEQ"
SET DIC("S")="I $P(^(0),U,8)=7!'$P(^(0),U,8)"
DO ^DIC
if Y<1
QUIT
+9 KILL DIC
+10 SET DIPT=+Y
DO E
+11 DO PUT
K KILL ^TMP("DIPTED",$JOB),^UTILITY("DIP2",$JOB)
+1 QUIT
+2 ;
EDIT(DIPT) ; EDIT PRINT TEMPLATE 'DIPT' VIA VA FILEMAN SCREEN EDITOR
+1 NEW DIPTED,DRK,DIPTEDTY,I,J
E NEW DA,D0,DUOUT,DTOUT,DIPTEDER,DIPTH,L,DY,Y,DIPTX,D,C,Q,DIPTROW,DCL,DXS,DNP,DHD,DISH,DV,DJ,DL,DK,DIL
+1 if '$DATA(DISYS)
DO OS^DII
XECUTE ^DD("OS",DISYS,"EON")
+2 IF '$DATA(^DIPT(DIPT,0))
WRITE !,"NO TEMPLATE SELECTED",!
QUIT
+3 SET DIPTED="Print"
SET DIPTEDTY=$PIECE(^(0),U,8)
IF DIPTEDTY=7
SET DIPTED="EXPORT FIELDS"
+4 SET DIPTED=DIPTED_" Template """_$PIECE(^(0),U)_""""
+5 DO GET("^TMP(""DIPTED"",$J)")
+6 SET DIPTH="Editing "_DIPTED
SET DIPTROW=1
DDW DO EDIT^DDW("^TMP(""DIPTED"",$J)","M",DIPTH,"(File "_DRK_")",DIPTROW)
+1 KILL ^UTILITY($JOB,0),^UTILITY("DIP2",$JOB),I,J
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL ^TMP("DIPTED",$JOB)
WRITE $CHAR(7),$$EZBLD^DIALOG(8077)
QUIT
+3 SET (DV,DNP)=""
SET (DIL,DJ)=0
SET (DL,DXS)=1
SET DK=DRK
SET J(0)=DK
SET I(0)=^DIC(DK,0,"GL")
+4 DO PROCESS("^TMP(""DIPTED"",$J)")
+5 XECUTE ^DD("OS",DISYS,"EON")
+6 SET DIPTROW=$ORDER(DIPTEDER(0))
IF DIPTROW
WRITE " ",DIPTEDER(DIPTROW)
HANG 2
SET DIPTH="ERROR! Re-editing "_DIPTED
KILL DIPTEDER
GOTO DDW
+7 IF '$DATA(^UTILITY("DIP2",$JOB))
WRITE "<NOTHING TO SAVE>",$CHAR(7)
GOTO K
+8 SET DDSCHG=1
+9 IF $DATA(DXS)>9
MERGE ^UTILITY("DIP2",$JOB,U,"DXS")=DXS
+10 MERGE ^UTILITY("DIP2",$JOB,U,"DCL")=DCL
+11 IF $DATA(DNP)
SET ^UTILITY("DIP2",$JOB,U,"DNP")=1
+12 IF $GET(DISH)
SET ^("SUB")=1
+13 IF $GET(DHD)]""
SET ^("H")=DHD
+14 QUIT
+15 ;
GET(DIPTA,DIT) ;put displayable template into @DIPTA
+1 NEW DS,DIWD,D9,D0
+2 KILL @DIPTA
+3 IF '$DATA(DIT)
SET DIT=$NAME(^DIPT(DIPT))
SET D0=DIPT
+4 IF '$TEST
SET D0=-1
+5 SET (DRK,J(0))=$PIECE(@DIT@(0),U,4)
SET L=0
SET D(L)="0FIELD"
SET C=","
SET D9=""
SET Y=2
SET Q=""""
SET DHD=$GET(^("H"))
SET DISH=$DATA(^("SUB"))
+6 FOR DS(1)=0:0
SET DS(1)=$ORDER(@DIT@("F",DS(1)))
if DS(1)=""
QUIT
SET DY=^(DS(1))
DO Y^DIPT
+7 if D9]""
DO UP^DIPT
+8 ;indentation showing level of subfiles
FOR D=2:1
if '$DATA(DS(D))
QUIT
SET @DIPTA@(D-1)=$JUSTIFY("",D>2*$EXTRACT($GET(DIWD(D)))*3)_DS(D)
+9 QUIT
+10 ;
PROCESS(DIPTA) ;puts nodes into ^UTILITY("DIP2")
+1 NEW D0,DM,DQI,DA,ERR,P,S,LINE,X,DIETAB
+2 SET DIETAB=0
+3 FOR LINE=1:1
if '$DATA(@DIPTA@(LINE))
QUIT
KILL ERR
SET X=^(LINE)
Begin DoDot:1
+4 IF X?1"^".E
SET LINE=999999999
KILL ^UTILITY("DIP2",$JOB)
QUIT
+5 SET X=$$LINE(X)
IF X]""
SET ^($ORDER(^UTILITY("DIP2",$JOB,""),-1)+1)=X
QUIT
+6 ;stop if we find one error
IF $DATA(ERR)
WRITE "LINE ",LINE
SET DIPTEDER(LINE)=ERR
SET LINE=-LINE
QUIT
End DoDot:1
+7 IF LINE<0
WRITE " ERROR!"
QUIT
+8 QUIT
+9 ;
LINE(X) ;returns X as component of Template. DD number is currently 'DK'
+1 NEW DIC,DICMX,DATE,Y,DICOMPX,DICOMP,DP,DJ
+2 IF X?." "
QUIT ""
+3 ;strip off trailing spaces
FOR P=$LENGTH(X):-1:1
if $ASCII(X,P)>32
QUIT
SET X=$EXTRACT(X,1,P-1)
+4 ;strip off 'P' leading spaces
FOR P=0:1
if $ASCII(X)-32
QUIT
SET X=$EXTRACT(X,2,999)
+5 ;pop Up (MAYBE SEVERAL LEVELS) if we find outdentation
IF P<DIETAB
IF DL>1
FOR
DO U
IF DL-1*3'>P
QUIT
+6 SET DIETAB=P
F SET (P,S)=""
LIT IF $EXTRACT(X)=""""
IF $LENGTH(X,"""")#2
FOR I=3:2:$LENGTH(X,"""")
if $PIECE(X,"""",I)]""&($EXTRACT($PIECE(X,"""",I)'=$CHAR(95)))
QUIT
+1 IF $TEST
IF $PIECE($PIECE(X,"""",I),";")=""
GOTO DJ
+2 SET DIC="^DD(DK,"
SET DIC(0)="ZO"
DIC IF X="NUMBER"
SET Y=0
GOTO S
+1 DO ^DIC
if Y>0
GOTO GF
+2 IF X=""
if DL>2
DO U
QUIT X
STRIP ;from beginning, then end
IF DIPTEDTY-7
Begin DoDot:1
+1 FOR D="+","#","*","&","!"
IF $EXTRACT(X)=D
SET P=D
SET X=$EXTRACT(X,2,999)
KILL D
QUIT
End DoDot:1
if '$DATA(D)
GOTO DIC
SET X=$REVERSE(X)
Begin DoDot:1
End DoDot:1
SET X=$REVERSE(X)
if '$DATA(D)
GOTO DIC
+2 IF X[";"
if DIPTEDTY=7
GOTO EXP
SET S=";"_$PIECE(X,";",2,99)_S
SET X=$PIECE(X,";")
GOTO DIC
HARD SET DM=X
SET DQI="DIP("
SET DA="DXS("_DXS_C
SET S=S_";Z;"""_X_""""
SET DICOMP=DIL_$EXTRACT("?",''L)_"TI"
SET DICOMPX=""
+1 IF X'?.E1":"
SET DICMX="X DICMX"
DO EN^DICOMP
if '$DATA(X)
GOTO QQ
DO FLY^DIP22
SET X=S
GOTO DJ
+2 if DIPTEDTY=7
GOTO EXP
SET DICMX="S DIXX=DIXX("_DL_") D M"
DO ^DICOMPW
+3 ;relational jump
IF $DATA(X)
Begin DoDot:1
+4 NEW Y
DO OVFL^DIP22
DO F^DIP22
End DoDot:1
SET S=U_$PIECE(DP,U,2)_U_$EXTRACT(1,Y["m")_U_S
SET DIL(DL)=DIL
SET DV(DL)=DV
SET DL(DL)=DK
SET DK=+DP
SET DV=DV_-DP_C
SET DL=DL+1
SET DIL=+Y
SET Y=0
SET X=DV_S
KILL P
GOTO VAL3
QQ SET ERR=""
QUIT ""
+1 ;
GF ;down to a multiple
IF $PIECE(Y(0),U,2)
DO D
SET X=$PIECE($PIECE(Y(0),U,4),";")
SET I(DIL)=$SELECT(+X=X:X,1:Q_X_Q)
SET J(DIL)=DK
if $PIECE($GET(^DD(DK,.01,0)),U,2)["W"
GOTO WORD
QUIT ""
+1 IF +Y=.001
SET Y=0
S SET X=+Y_S
DJ SET X=DV_X
VAL3 IF DIPTEDTY'=7!(S'[";W"&(S'[";m"))
SET S=""
DO P
QUIT X
EXP SET ERR="NOT ALLOWED WHEN SELECTING EXPORT FIELDS"
QUIT ""
+1 ;
P if $DATA(P)
Begin DoDot:1
+1 IF P=""
KILL DNP
QUIT
+2 IF P="*"
SET DCL=$GET(DCL)+1
+3 SET DCL(DK_U_+Y)=$SELECT($TEST:DCL_P,1:P)
End DoDot:1
QUIT
+4 ;
D ;go Down a level
SET DIL(DL)=DIL
SET DV(DL)=DV
SET DL(DL)=DK
SET DK=+$PIECE(^DD(DK,+Y,0),U,2)
SET DL=DL+1
SET DIL=DIL+1
SET DV=DV_+Y_C
SET Y=0
QUIT
+1 ;
WORD IF DIPTEDTY=7
GOTO EXP
+1 SET Y=.01
DO P
SET X=DV_Y_S
DO U
QUIT X
+2 ;
U SET DL=DL-1
SET DV=DV(DL)
SET DK=DL(DL)
SET DIL=DIL(DL)
FOR %=DIL:0
SET %=$ORDER(I(%))
if %=""
QUIT
KILL I(%),J(%)
+1 QUIT
+2 ;
SAVEFLDS(Y) ;POST-SAVE OF 'DIPTED' SCREENMAN FORM
+1 NEW DMAX,J,X
+2 if '$DATA(^UTILITY("DIP2",$JOB))!'$GET(Y)
QUIT
CLEAR SET $X=0
SET $Y=0
IF $GET(IOXY)]""
NEW DX,DY
SET (DY,DX)=0
XECUTE IOXY
WRITE $CHAR(27,91,74)
+1 ;ASK 'SAVE AS'
SET Y=$$CLONE(Y)
if 'Y
QUIT
+2 DO NOW^%DTC
SET $PIECE(^DIPT(Y,0),U,2)=+$JUSTIFY(%,0,4)
+3 SET $PIECE(^DIPT(Y,0),U,5)=$GET(DUZ)
+4 KILL ^DIPT(Y,"F")
SET J=""
Begin DoDot:1
+5 FOR %=1:1
if '$DATA(^UTILITY("DIP2",$JOB,%))
QUIT
SET X=^(%)
IF X]""
Begin DoDot:2
+6 IF $LENGTH(J)+$LENGTH(X)>150
DO J
SET J=""
+7 SET J=J_X_$CHAR(126)
End DoDot:2
End DoDot:1
DO J
+8 KILL ^DIPT(Y,"DXS"),^("DCL"),^("DNP")
+9 MERGE ^DIPT(Y)=^UTILITY("DIP2",$JOB,U)
+10 IF $DATA(^DIPT(Y,"ROU"))
KILL ^("ROU")
IF $DATA(^("IOM"))
SET IOM=^("IOM")
KILL ^("IOM")
IF $DATA(^("ROUOLD"))
SET X=^("ROUOLD")
IF X]""
IF $GET(DISYS)
IF $DATA(^DD("OS",DISYS,"ZS"))
SET DMAX=^DD("ROU")
DO ENZ^DIPZ
IF $DATA(^DIPT(DIPZ,"H"))
SET DHD=^("H")
+11 DO K
+12 QUIT
+13 ;
J SET ^($ORDER(^DIPT(+Y,"F",""),-1)+1)=J
QUIT
+1 ;
CLONE(DA) ;
+1 NEW DIC,DIPTEDTY,DIPTEDFI,X,Y,DIPTEDNM,DDS
+2 IF '$DATA(^DIPT(DA,0))
QUIT 0
+3 SET (DIPTEDNM,DIC("B"))=$PIECE(^(0),U)
ASK SET DIPTEDFI=$PIECE(^DIPT(DA,0),U,4)
SET DIPTEDTY=$PIECE(^(0),U,8)
IF 'DIPTEDFI
QUIT 0
+1 SET DIC=.4
SET DIC("A")="Save revised Print Template "_DIPTEDNM_" as: "
SET DIC(0)="AEQL"
SET DIC("S")="I $P(^(0),U,4)=DIPTEDFI,$P(^(0),U,8)=DIPTEDTY"
+2 DO ^DIC
IF Y<0
QUIT 0
+3 IF +Y=DA
QUIT DA
+4 IF $ORDER(^DIPT(+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
KILL DIC
if %=2
GOTO ASK
QUIT 0
+5 LOCK +^DIPT(+Y):5
IF '$TEST
WRITE !,$CHAR(7),"Sorry. Another user is editing this template."
QUIT 0
+6 SET ^DIPT("F"_DIPTEDFI,$PIECE(Y,U,2),+Y)=1
+7 SET $PIECE(^DIPT(+Y,0),U,4)=DIPTEDFI
SET $PIECE(^(0),U,8)=DIPTEDTY
+8 LOCK -^DIPT(+Y)
+9 QUIT +Y
+10 ;
+11 ;
PUT ;save template from ^UTILITY
+1 IF '$DATA(^UTILITY("DIP2",$JOB))
QUIT
+2 NEW DIC,DIPZ
+3 SET DIC("B")=DIPT
SAVEAS SET DIC=.4
SET DIC("A")="Save revised "_DIPTED_" as: "
SET DIC(0)="AEQL"
SET DIC("S")="I $P(^(0),U,4)=DRK,$P(^(0),U,8)=DIPTEDTY"
+1 DO ^DIC
+2 if Y<0
QUIT
IF $ORDER(^DIPT(+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 +^DIPT(+Y):5
IF '$TEST
WRITE !,$CHAR(7),"Sorry. Another user is editing this template."
QUIT
+4 SET ^DIPT("F"_J(0),$PIECE(Y,U,2),+Y)=1
+5 SET $PIECE(^DIPT(+Y,0),U,4)=J(0)
SET $PIECE(^(0),U,8)=DIPTEDTY
+6 LOCK -^DIPT(+Y)
+7 DO SAVEFLDS(+Y)
+8 QUIT
