- DIPTED ;SFISC/GFT-EDIT PRINT TEMPLATE ;02/24/2009
- ;;22.0;VA FileMan;**97,160**;Mar 30, 1999;Build 23
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- 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
- X ^%ZOSF("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 ^%ZOSF("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*$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
- DIPTED ;SFISC/GFT-EDIT PRINT TEMPLATE ;02/24/2009
- +1 ;;22.0;VA FileMan;**97,160**;Mar 30, 1999;Build 23
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 NEW DIC,DIPT,DIPTED,DRK,DIPTEDTY,I,J
- +5 SET DIC=.4
- SET DIC(0)="AEQ"
- SET DIC("S")="I $PTED_source.html#xP">P(^(0),U,8)=7!'$PTED_source.html#xP">P(^(0),U,8)"
- DO ^DIC
- IF Y<1
- QUIT
- +6 KILL DIC
- +7 SET DIPT=+Y
- DO E
- +8 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 XECUTE ^%ZOSF("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 ^%ZOSF("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*$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 $PTED_source.html#xP">P(^(0),U,4)=DIPTED_source.html#xP">PTEDFI,$PTED_source.html#xP">P(^(0),U,8)=DIPTED_source.html#xP">PTEDTY"
- +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 $PTED_source.html#xP">P(^(0),U,4)=DRK,$PTED_source.html#xP">P(^(0),U,8)=DIPTED_source.html#xP">PTEDTY"
- +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
