TIUEDI4 ; SLC/JER - Enter/Edit a Document ;31-Dec-2012 14:43;DU
;;1.0;TEXT INTEGRATION UTILITIES;**100,109,1001,216,1011**;Jun 20, 1997;Build 13
;new rtn in TSC, created feb 2 from TIUEDIT
; 2/2: Moved LOADDFLT, BOIL, CANXEC, REPLACE, INSMULT to TIUEDI4
; 2/3 moved DIE, TEXTEDIT from TIUEDIT to TIUEDI4
; 3/2 moved SETTL, GETVST, ASKOK from TIUEDIT to TIUEDI4
;
;IHS/ITSC/LJF 02/26/2003 add call to edit visit
; removed space at end of global ref
; fix incremental lock code in DIE subroutine
;IHS/ITSC/LJF 01/12/2005 PATCH 1001 - New'ed DA under BOIL so INSMULT would have it to use
;
SETTL(TIUTYP,TIUCLASS,TIUTITLE) ; Set array TIUTYP w/ title info
; e.g. TIUTYP(1) = 1^113^CRISIS, where 113 is IFN of CRISIS title,
; TIUTYP = 1 if gotten from TIUTITLE
; TIUTYP = 113 if gotten from user
; Requires TIUCLASS
; Receives TIUTITLE - optional = Title DA or Title Name or DA^Name
N TIUDFLT
; -- Get title from TIUTITLE if it's there: --
I $G(TIUTITLE)]"",$S(+$G(NOSAVE):1,+$P(TIUTITLE,U,2):1,1:0) D I 1
. S TIUTYP=1,TIUTITLE=$P(TIUTITLE,U)
. S TIUTYP(1)=1_U_$S(+$G(TIUTITLE)>0:+$G(TIUTITLE),1:+$O(^TIU(8925.1,"B",TIUTITLE,0)))
. S $P(TIUTYP(1),U,3)=$$PNAME^TIULC1(+$P(TIUTYP(1),U,2))
; -- If not, ask user: --
E D
. S TIUDFLT="LAST" ; use user's preferred list of docmts
. D DOCSPICK^TIULA2(.TIUTYP,TIUCLASS,"1A",TIUDFLT,"","+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)")
I +$G(TIUTYP)'>0 S TIUOUT=1 Q
S TIUTYP=+$P($G(TIUTYP(1)),U,2)
Q
;
GETVST(DFN,TIUTYP,TIU,EVNTFLAG) ; Get visit, set array TIU
; -- If no eventflag & don't suppress visit, then execute
; visit linkage method: --
; Requires DFN
; Requires simple variable TIUTYP = title DA
; Optional EVNTFLAG
; Returns array TIU
N TIUVSUPP,TIULMETH
S TIUVSUPP=0
I '$G(EVNTFLAG) S TIUVSUPP=+$$SUPPVSIT^TIULC1(TIUTYP)
; -- execute visit linkage method for TIUTYP --
I 'TIUVSUPP,'$G(EVNTFLAG) D I 1
. S TIULMETH=$$GETLMETH^TIUEDI1(TIUTYP)
. I '$L(TIULMETH) D S TIUOUT=1 Q
. . W !,$C(7),"No Visit Linkage Method defined for "
. . W $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
. ; -- TIULMETH for PN: D ENPN^TIUVSIT(.TIU,.DFN,1) --
. X TIULMETH
; -- else create new historical "E" visit: --
E D EVENT^TIUSRVP1(.TIU,DFN)
I $S($D(DIROUT):1,$D(DTOUT):1,1:0) S TIUQUIT=1 Q
I '$D(TIU("VSTR")) D
. W !,$C(7),"Patient & Visit required." H 2
Q
;
ASKOK(TIUTYP,TIU,TIUBY,TIUASK) ; X Validation method.
; Receives and returns array TIU, simple var TIUTYP, [array TIUBY]
; Sets TIUASK = answer, = 0 for not OK or 1 for OK
N TIUVMETH
S TIUVMETH=$$GETVMETH^TIUEDI1(TIUTYP)
I '$L(TIUVMETH) D S TIUOUT=1 Q
. W !,$C(7),"No Validation Method defined for "
. W $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
; -- TIUVMETH for PN: S TIUASK=$$CHEKPN^TIULD(.TIU,.TIUBY) --
X TIUVMETH
; -- If finish without a visit, then quit: --
I '$D(TIU("VSTR")) D
. W !,$C(7),"Patient & Visit required." H 2
I $G(TIU("VISIT")) D VEDIT^BTIUED("") ;IHS/ITSC/LJF 02/26/2003 add visit edit call
Q
;
DIE(DA,TIUQUIT,TIUCHNG) ; Invoke ^DIE
N Y,DIE,DR
I '$D(TIUPREF) S TIUPREF=$$PERSPRF^TIULE(DUZ)
L +^TIU(8925,+DA):1
E D Q
. W !!?5,$C(7),"Another user is editing this entry.",! S TIUQUIT=2
. I $$READ^TIUU("FOA","Press RETURN to continue...") W ""
S ^TIU(8925,"ASAVE",DUZ,DA)=""
S DR=$$GETTMPL^TIUEDI1(+$P(^TIU(8925,+DA,0),U))
I DR']"" W !?5,$C(7),"No Edit template defined for ",$$PNAME^TIULC1(+$P(^TIU(8925,+DA,0),U)),! S TIUQUIT=2 Q
S DIE=8925 D ^DIE
I $D(Y)!($D(DTOUT)) S TIUQUIT=1
;I +$G(TIUQUIT)>0,+$G(TIUNEW)>0 Q ;IHS/ITSC/LJF 02/26/2003
I +$G(TIUQUIT)>0,+$G(TIUNEW)>0 D DIEQ Q ;IHS/ITSC/LJF 02/26/2003
D:+$G(TIUQUIT) UPDTIRT^TIUDIRT(.TIU,DA),SEND^TIUALRT(DA)
;Q:+$G(TIUQUIT) ;IHS/ITSC/LJF 02/26/2003
I +$G(TIUQUIT) D DIEQ Q ;IHS/ITSC/LJF 02/26/2003
D TEXTEDIT(DA,.TIUCHNG)
;I +$G(^TIU(8925,DA,0))'>0 S TIUQUIT=2 Q ;IHS/ITSC/LJF 02/26/2003
I +$G(^TIU(8925,DA,0))'>0 S TIUQUIT=2 D DIEQ Q ;IHS/ITSC/LJF 02/26/2003
S DR=".05///"_$$STATUS^TIULC(DA),DIE=8925 D ^DIE
D UPDTIRT^TIUDIRT(.TIU,DA),SEND^TIUALRT(DA)
DIEQ ;IHS/ITSC/LJF 02/26/2003 added line label
L -^TIU(8925,+DA)
Q
TEXTEDIT(DA,TIUCMMT,TIUCHNG) ; Call DIWE
N DIC,DIWE,DIWESUB,DIWPT,DR,DWHD,DWI,DWLC,DWLR,DWLW,DWO,DWPK,DDWRW
N TIUCKSM0,TIUCKSM1,TIUESNM,TIUESBLK
S TIUESNM=$$DECRYPT^TIULC1($P($G(^TIU(8925,DA,15)),U,3),1,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
S TIUESBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,DA,15)),U,4),1,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
W !!,"Calling text editor, please wait..." H 1
X:$L($G(TIUPRM3)) TIUPRM3
D BUFFER^TIUEDIU(DA) ; Load edit buffer to protect original from booboos
S TIUCKSM0=$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEMP"")")
I $D(^TIU(8925,+DA,"TEXT"))'>9 D LOADDFLT(DA,+$P(TIUTYP(1),U,2))
S DIWESUB="Patient: "_$G(TIU("PNM")),DIC="^TIU(8925,"_+DA_",""TEMP"","
I $G(VALMAR)="^TMP(""TIUVIEW"",$J)",(+$G(VALMBG)>5),(+$G(VALMBG)'>(+$P($G(^TIU(8925,+DA,"TEXT",0)),U,3)+4)) S DDWRW=+$G(VALMBG)-4
S DWPK=1,DWLW=74 D EN^DIWE
; DELETE if NOSAVE
I +$G(NOSAVE) D DELETE^TIUEDIT(DA,0) S TIUQUIT=2 Q
; Save edit buffer
S TIUCKSM1=$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEMP"")")
I TIUCKSM0'=TIUCKSM1 D I 1
. D COMMIT^TIUEDIU(DA),AUDIT^TIUEDI1(DA,TIUCKSM0,TIUCKSM1)
. S TIUCHNG=1
. ; re-file /es/-block
. I $L(TIUESNM) D
. . S DR="1503///^S X=TIUESNM;1504///^S X=TIUESBLK",DIE=8925
. . D ^DIE
E W !,"No changes made..." D COMMIT^TIUEDIU(DA,1) S TIUCHNG=0
S DIE=8925,DR=".1///"_$$LINECNT^TIULC(DA) D ^DIE
Q
;
LOADDFLT(DA,TIUTYP) ; Load bp text
N TIUI,TIUJ,TIUK,TIUL S TIUI=0
S TIUJ=+$P($G(^TIU(8925,+DA,"TEMP",0)),U,3)+1
; - Set comp hdr -
S ^TIU(8925,+DA,"TEMP",TIUJ,0)=$S($P($G(^TIU(8925.1,+TIUTYP,0)),U,4)="CO":$P(^TIU(8925.1,+TIUTYP,0),U)_": ",1:"")
I +TIUJ=1,($G(^TIU(8925,+DA,"TEMP",TIUJ,0))']"") K ^TIU(8925,+DA,"TEMP",TIUJ,0) S TIUJ=0
S ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
F S TIUI=$O(^TIU(8925.1,+TIUTYP,"DFLT",TIUI)) Q:+TIUI'>0 D
. S TIUJ=TIUJ+1,X=$G(^TIU(8925.1,+TIUTYP,"DFLT",TIUI,0))
. I $L($T(DOLMLINE^TIUSRVF1)),'$D(XWBOS),(X["{FLD:") S X=$$DOLMLINE^TIUSRVF1(X)
. I X["|" S X=$$BOIL(X,TIUJ)
. I X["~@" D INSMULT(X,"^TIU(8925,"_+DA_",""TEMP"")",.TIUJ) I 1
. E S ^TIU(8925,+DA,"TEMP",TIUJ,0)=X
. S ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
I +$O(^TIU(8925.1,+TIUTYP,10,0)) D
. N TIUFITEM,TIUI
. D ITEMS^TIUFLT(+TIUTYP)
. S TIUI=0 F S TIUI=$O(TIUFITEM(TIUI)) Q:+TIUI'>0 D
. . S TIUL=+$G(TIUFITEM(+TIUI)) D LOADDFLT(DA,TIUL)
Q
BOIL(LINE,COUNT) ; execute objects
N TIUI,DIC,X,Y,TIUFPRIV S TIUFPRIV=1
NEW DA ;IHS/ITSC/LJF 01/12/2005 can kill DA which INSMULT needs
N TIUOLDR,TIUNEWR,TIUOLDG,TIUNEWG
S DIC=8925.1,DIC(0)="FMXZ"
S DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
F TIUI=2:2:$L(LINE,"|") S X=$P(LINE,"|",TIUI) D
. D ^DIC
. I +Y'>0 S X="The OBJECT "_X_" was NOT found...Contact IRM."
. I +Y>0 D
. . I $D(^TIU(8925.1,+Y,9)),+$$CANXEC(+Y) X ^(9) S:X["~@" X=$$APPEND(X) I 1
. . E S X="The OBJECT "_X_" is INACTIVE...Contact IRM."
. . I X["~@" D
. . . I X'["^" D
. . . . S TIUOLDR=$P(X,"~@",2),TIUNEWR=TIUOLDR_TIUI
. . . . M @TIUNEWR=@TIUOLDR K @TIUOLDR
. . . . S $P(X,"~@",2)=TIUNEWR
. . . I X["^" D
. . . . S TIUOLDG=$P(X,"~@",2),TIUNEWG="^TMP("_"""TIU201"""_","_$J_","_TIUI_")"
. . . . M @TIUNEWG=@TIUOLDG
. . . . S $P(X,"~@",2)=TIUNEWG
. S LINE=$$REPLACE(LINE,X,TIUI)
Q $TR(LINE,"|","")
CANXEC(TIUODA) ; Eval Obj Status
N TIUOST,TIUY S TIUOST=+$P($G(^TIU(8925.1,+TIUODA,0)),U,7)
S TIUY=$S(TIUOST=11:1,+$G(NOSAVE):1,1:0)
Q +$G(TIUY)
REPLACE(LINE,X,TIUI) ; Replace TIUIth object in LINE
S $P(LINE,"|",TIUI)=X
Q LINE
INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
N TIUPC
F TIUPC=2:2:$L(LINE,"~@") D
. N TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
. S TIUSRC=$P(LINE,"~@",TIUPC)
. S TIUSRC=$TR(TIUSRC," ","") ;IHS/ITSC/LJF 02/26/2003 PATCH 1001 remove space at end of global ref
. S TIUTAIL=$P(LINE,"~@",TIUPC+1)
. S TIULINE=$P(LINE,"~@",(TIUPC-1)),(TIUI,TIUSCNT)=0
. I $E(TIULINE)=" ",(TIUPC>2) S $E(TIULINE)=""
. F S TIUI=$O(@TIUSRC@(TIUI)) Q:+TIUI'>0 D
. . N TIUSLINE
. . S TIUSCNT=TIUSCNT+1
. . S TIUSLINE=$G(@TIUSRC@(TIUI,0))
. . S:'+$O(@TIUSRC@(TIUI))&(TIUPC+2>$L(LINE,"~@")) TIUSLINE=TIUSLINE_TIUTAIL
. . I TIUSCNT=1,($L(TIULINE_TIUSLINE)>73) D Q
. . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
. . . S @TARGET@(TIULCNT,0)=TIULINE
. . . S TIULCNT=TIULCNT+1
. . . S @TARGET@(TIULCNT,0)=TIUSLINE
. . I TIUSCNT=1,($L(TIULINE_TIUSLINE)'>73) D Q
. . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
. . . S @TARGET@(TIULCNT,0)=TIULINE_TIUSLINE
. . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
. . S @TARGET@(TIULCNT,0)=$G(TIUSLINE)
. K @TIUSRC
Q
APPEND(X) ;
N TIUXL S TIUXL=$L(X)
I $E(X,TIUXL-1,TIUXL)'="~@" S X=X_"~@"
Q X
TIUEDI4 ; SLC/JER - Enter/Edit a Document ;31-Dec-2012 14:43;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**100,109,1001,216,1011**;Jun 20, 1997;Build 13
+2 ;new rtn in TSC, created feb 2 from TIUEDIT
+3 ; 2/2: Moved LOADDFLT, BOIL, CANXEC, REPLACE, INSMULT to TIUEDI4
+4 ; 2/3 moved DIE, TEXTEDIT from TIUEDIT to TIUEDI4
+5 ; 3/2 moved SETTL, GETVST, ASKOK from TIUEDIT to TIUEDI4
+6 ;
+7 ;IHS/ITSC/LJF 02/26/2003 add call to edit visit
+8 ; removed space at end of global ref
+9 ; fix incremental lock code in DIE subroutine
+10 ;IHS/ITSC/LJF 01/12/2005 PATCH 1001 - New'ed DA under BOIL so INSMULT would have it to use
+11 ;
SETTL(TIUTYP,TIUCLASS,TIUTITLE) ; Set array TIUTYP w/ title info
+1 ; e.g. TIUTYP(1) = 1^113^CRISIS, where 113 is IFN of CRISIS title,
+2 ; TIUTYP = 1 if gotten from TIUTITLE
+3 ; TIUTYP = 113 if gotten from user
+4 ; Requires TIUCLASS
+5 ; Receives TIUTITLE - optional = Title DA or Title Name or DA^Name
+6 NEW TIUDFLT
+7 ; -- Get title from TIUTITLE if it's there: --
+8 IF $GET(TIUTITLE)]""
IF $SELECT(+$GET(NOSAVE):1,+$PIECE(TIUTITLE,U,2):1,1:0)
Begin DoDot:1
+9 SET TIUTYP=1
SET TIUTITLE=$PIECE(TIUTITLE,U)
+10 SET TIUTYP(1)=1_U_$SELECT(+$GET(TIUTITLE)>0:+$GET(TIUTITLE),1:+$ORDER(^TIU(8925.1,"B",TIUTITLE,0)))
+11 SET $PIECE(TIUTYP(1),U,3)=$$PNAME^TIULC1(+$PIECE(TIUTYP(1),U,2))
End DoDot:1
IF 1
+12 ; -- If not, ask user: --
+13 IF '$TEST
Begin DoDot:1
+14 ; use user's preferred list of docmts
SET TIUDFLT="LAST"
+15 DO DOCSPICK^TIULA2(.TIUTYP,TIUCLASS,"1A",TIUDFLT,"","+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)")
End DoDot:1
+16 IF +$GET(TIUTYP)'>0
SET TIUOUT=1
QUIT
+17 SET TIUTYP=+$PIECE($GET(TIUTYP(1)),U,2)
+18 QUIT
+19 ;
GETVST(DFN,TIUTYP,TIU,EVNTFLAG) ; Get visit, set array TIU
+1 ; -- If no eventflag & don't suppress visit, then execute
+2 ; visit linkage method: --
+3 ; Requires DFN
+4 ; Requires simple variable TIUTYP = title DA
+5 ; Optional EVNTFLAG
+6 ; Returns array TIU
+7 NEW TIUVSUPP,TIULMETH
+8 SET TIUVSUPP=0
+9 IF '$GET(EVNTFLAG)
SET TIUVSUPP=+$$SUPPVSIT^TIULC1(TIUTYP)
+10 ; -- execute visit linkage method for TIUTYP --
+11 IF 'TIUVSUPP
IF '$GET(EVNTFLAG)
Begin DoDot:1
+12 SET TIULMETH=$$GETLMETH^TIUEDI1(TIUTYP)
+13 IF '$LENGTH(TIULMETH)
Begin DoDot:2
+14 WRITE !,$CHAR(7),"No Visit Linkage Method defined for "
+15 WRITE $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
End DoDot:2
SET TIUOUT=1
QUIT
+16 ; -- TIULMETH for PN: D ENPN^TIUVSIT(.TIU,.DFN,1) --
+17 XECUTE TIULMETH
End DoDot:1
IF 1
+18 ; -- else create new historical "E" visit: --
+19 IF '$TEST
DO EVENT^TIUSRVP1(.TIU,DFN)
+20 IF $SELECT($DATA(DIROUT):1,$DATA(DTOUT):1,1:0)
SET TIUQUIT=1
QUIT
+21 IF '$DATA(TIU("VSTR"))
Begin DoDot:1
+22 WRITE !,$CHAR(7),"Patient & Visit required."
HANG 2
End DoDot:1
+23 QUIT
+24 ;
ASKOK(TIUTYP,TIU,TIUBY,TIUASK) ; X Validation method.
+1 ; Receives and returns array TIU, simple var TIUTYP, [array TIUBY]
+2 ; Sets TIUASK = answer, = 0 for not OK or 1 for OK
+3 NEW TIUVMETH
+4 SET TIUVMETH=$$GETVMETH^TIUEDI1(TIUTYP)
+5 IF '$LENGTH(TIUVMETH)
Begin DoDot:1
+6 WRITE !,$CHAR(7),"No Validation Method defined for "
+7 WRITE $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
End DoDot:1
SET TIUOUT=1
QUIT
+8 ; -- TIUVMETH for PN: S TIUASK=$$CHEKPN^TIULD(.TIU,.TIUBY) --
+9 XECUTE TIUVMETH
+10 ; -- If finish without a visit, then quit: --
+11 IF '$DATA(TIU("VSTR"))
Begin DoDot:1
+12 WRITE !,$CHAR(7),"Patient & Visit required."
HANG 2
End DoDot:1
+13 ;IHS/ITSC/LJF 02/26/2003 add visit edit call
IF $GET(TIU("VISIT"))
DO VEDIT^BTIUED("")
+14 QUIT
+15 ;
DIE(DA,TIUQUIT,TIUCHNG) ; Invoke ^DIE
+1 NEW Y,DIE,DR
+2 IF '$DATA(TIUPREF)
SET TIUPREF=$$PERSPRF^TIULE(DUZ)
+3 LOCK +^TIU(8925,+DA):1
+4 IF '$TEST
Begin DoDot:1
+5 WRITE !!?5,$CHAR(7),"Another user is editing this entry.",!
SET TIUQUIT=2
+6 IF $$READ^TIUU("FOA","Press RETURN to continue...")
WRITE ""
End DoDot:1
QUIT
+7 SET ^TIU(8925,"ASAVE",DUZ,DA)=""
+8 SET DR=$$GETTMPL^TIUEDI1(+$PIECE(^TIU(8925,+DA,0),U))
+9 IF DR']""
WRITE !?5,$CHAR(7),"No Edit template defined for ",$$PNAME^TIULC1(+$PIECE(^TIU(8925,+DA,0),U)),!
SET TIUQUIT=2
QUIT
+10 SET DIE=8925
DO ^DIE
+11 IF $DATA(Y)!($DATA(DTOUT))
SET TIUQUIT=1
+12 ;I +$G(TIUQUIT)>0,+$G(TIUNEW)>0 Q ;IHS/ITSC/LJF 02/26/2003
+13 ;IHS/ITSC/LJF 02/26/2003
IF +$GET(TIUQUIT)>0
IF +$GET(TIUNEW)>0
DO DIEQ
QUIT
+14 IF +$GET(TIUQUIT)
DO UPDTIRT^TIUDIRT(.TIU,DA)
DO SEND^TIUALRT(DA)
+15 ;Q:+$G(TIUQUIT) ;IHS/ITSC/LJF 02/26/2003
+16 ;IHS/ITSC/LJF 02/26/2003
IF +$GET(TIUQUIT)
DO DIEQ
QUIT
+17 DO TEXTEDIT(DA,.TIUCHNG)
+18 ;I +$G(^TIU(8925,DA,0))'>0 S TIUQUIT=2 Q ;IHS/ITSC/LJF 02/26/2003
+19 ;IHS/ITSC/LJF 02/26/2003
IF +$GET(^TIU(8925,DA,0))'>0
SET TIUQUIT=2
DO DIEQ
QUIT
+20 SET DR=".05///"_$$STATUS^TIULC(DA)
SET DIE=8925
DO ^DIE
+21 DO UPDTIRT^TIUDIRT(.TIU,DA)
DO SEND^TIUALRT(DA)
DIEQ ;IHS/ITSC/LJF 02/26/2003 added line label
+1 LOCK -^TIU(8925,+DA)
+2 QUIT
TEXTEDIT(DA,TIUCMMT,TIUCHNG) ; Call DIWE
+1 NEW DIC,DIWE,DIWESUB,DIWPT,DR,DWHD,DWI,DWLC,DWLR,DWLW,DWO,DWPK,DDWRW
+2 NEW TIUCKSM0,TIUCKSM1,TIUESNM,TIUESBLK
+3 SET TIUESNM=$$DECRYPT^TIULC1($PIECE($GET(^TIU(8925,DA,15)),U,3),1,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
+4 SET TIUESBLK=$$DECRYPT^TIULC1($PIECE($GET(^TIU(8925,DA,15)),U,4),1,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
+5 WRITE !!,"Calling text editor, please wait..."
HANG 1
+6 IF $LENGTH($GET(TIUPRM3))
XECUTE TIUPRM3
+7 ; Load edit buffer to protect original from booboos
DO BUFFER^TIUEDIU(DA)
+8 SET TIUCKSM0=$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEMP"")")
+9 IF $DATA(^TIU(8925,+DA,"TEXT"))'>9
DO LOADDFLT(DA,+$PIECE(TIUTYP(1),U,2))
+10 SET DIWESUB="Patient: "_$GET(TIU("PNM"))
SET DIC="^TIU(8925,"_+DA_",""TEMP"","
+11 IF $GET(VALMAR)="^TMP(""TIUVIEW"",$J)"
IF (+$GET(VALMBG)>5)
IF (+$GET(VALMBG)'>(+$PIECE($GET(^TIU(8925,+DA,"TEXT",0)),U,3)+4))
SET DDWRW=+$GET(VALMBG)-4
+12 SET DWPK=1
SET DWLW=74
DO EN^DIWE
+13 ; DELETE if NOSAVE
+14 IF +$GET(NOSAVE)
DO DELETE^TIUEDIT(DA,0)
SET TIUQUIT=2
QUIT
+15 ; Save edit buffer
+16 SET TIUCKSM1=$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEMP"")")
+17 IF TIUCKSM0'=TIUCKSM1
Begin DoDot:1
+18 DO COMMIT^TIUEDIU(DA)
DO AUDIT^TIUEDI1(DA,TIUCKSM0,TIUCKSM1)
+19 SET TIUCHNG=1
+20 ; re-file /es/-block
+21 IF $LENGTH(TIUESNM)
Begin DoDot:2
+22 SET DR="1503///^S X=TIUESNM;1504///^S X=TIUESBLK"
SET DIE=8925
+23 DO ^DIE
End DoDot:2
End DoDot:1
IF 1
+24 IF '$TEST
WRITE !,"No changes made..."
DO COMMIT^TIUEDIU(DA,1)
SET TIUCHNG=0
+25 SET DIE=8925
SET DR=".1///"_$$LINECNT^TIULC(DA)
DO ^DIE
+26 QUIT
+27 ;
LOADDFLT(DA,TIUTYP) ; Load bp text
+1 NEW TIUI,TIUJ,TIUK,TIUL
SET TIUI=0
+2 SET TIUJ=+$PIECE($GET(^TIU(8925,+DA,"TEMP",0)),U,3)+1
+3 ; - Set comp hdr -
+4 SET ^TIU(8925,+DA,"TEMP",TIUJ,0)=$SELECT($PIECE($GET(^TIU(8925.1,+TIUTYP,0)),U,4)="CO":$PIECE(^TIU(8925.1,+TIUTYP,0),U)_": ",1:"")
+5 IF +TIUJ=1
IF ($GET(^TIU(8925,+DA,"TEMP",TIUJ,0))']"")
KILL ^TIU(8925,+DA,"TEMP",TIUJ,0)
SET TIUJ=0
+6 SET ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
+7 FOR
SET TIUI=$ORDER(^TIU(8925.1,+TIUTYP,"DFLT",TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+8 SET TIUJ=TIUJ+1
SET X=$GET(^TIU(8925.1,+TIUTYP,"DFLT",TIUI,0))
+9 IF $LENGTH($TEXT(DOLMLINE^TIUSRVF1))
IF '$DATA(XWBOS)
IF (X["{FLD:")
SET X=$$DOLMLINE^TIUSRVF1(X)
+10 IF X["|"
SET X=$$BOIL(X,TIUJ)
+11 IF X["~@"
DO INSMULT(X,"^TIU(8925,"_+DA_",""TEMP"")",.TIUJ)
IF 1
+12 IF '$TEST
SET ^TIU(8925,+DA,"TEMP",TIUJ,0)=X
+13 SET ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
End DoDot:1
+14 IF +$ORDER(^TIU(8925.1,+TIUTYP,10,0))
Begin DoDot:1
+15 NEW TIUFITEM,TIUI
+16 DO ITEMS^TIUFLT(+TIUTYP)
+17 SET TIUI=0
FOR
SET TIUI=$ORDER(TIUFITEM(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:2
+18 SET TIUL=+$GET(TIUFITEM(+TIUI))
DO LOADDFLT(DA,TIUL)
End DoDot:2
End DoDot:1
+19 QUIT
BOIL(LINE,COUNT) ; execute objects
+1 NEW TIUI,DIC,X,Y,TIUFPRIV
SET TIUFPRIV=1
+2 ;IHS/ITSC/LJF 01/12/2005 can kill DA which INSMULT needs
NEW DA
+3 NEW TIUOLDR,TIUNEWR,TIUOLDG,TIUNEWG
+4 SET DIC=8925.1
SET DIC(0)="FMXZ"
+5 SET DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
+6 FOR TIUI=2:2:$LENGTH(LINE,"|")
SET X=$PIECE(LINE,"|",TIUI)
Begin DoDot:1
+7 DO ^DIC
+8 IF +Y'>0
SET X="The OBJECT "_X_" was NOT found...Contact IRM."
+9 IF +Y>0
Begin DoDot:2
+10 IF $DATA(^TIU(8925.1,+Y,9))
IF +$$CANXEC(+Y)
XECUTE ^(9)
IF X["~@"
SET X=$$APPEND(X)
IF 1
+11 IF '$TEST
SET X="The OBJECT "_X_" is INACTIVE...Contact IRM."
+12 IF X["~@"
Begin DoDot:3
+13 IF X'["^"
Begin DoDot:4
+14 SET TIUOLDR=$PIECE(X,"~@",2)
SET TIUNEWR=TIUOLDR_TIUI
+15 MERGE @TIUNEWR=@TIUOLDR
KILL @TIUOLDR
+16 SET $PIECE(X,"~@",2)=TIUNEWR
End DoDot:4
+17 IF X["^"
Begin DoDot:4
+18 SET TIUOLDG=$PIECE(X,"~@",2)
SET TIUNEWG="^TMP("_"""TIU201"""_","_$JOB_","_TIUI_")"
+19 MERGE @TIUNEWG=@TIUOLDG
+20 SET $PIECE(X,"~@",2)=TIUNEWG
End DoDot:4
End DoDot:3
End DoDot:2
+21 SET LINE=$$REPLACE(LINE,X,TIUI)
End DoDot:1
+22 QUIT $TRANSLATE(LINE,"|","")
CANXEC(TIUODA) ; Eval Obj Status
+1 NEW TIUOST,TIUY
SET TIUOST=+$PIECE($GET(^TIU(8925.1,+TIUODA,0)),U,7)
+2 SET TIUY=$SELECT(TIUOST=11:1,+$GET(NOSAVE):1,1:0)
+3 QUIT +$GET(TIUY)
REPLACE(LINE,X,TIUI) ; Replace TIUIth object in LINE
+1 SET $PIECE(LINE,"|",TIUI)=X
+2 QUIT LINE
INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
+1 NEW TIUPC
+2 FOR TIUPC=2:2:$LENGTH(LINE,"~@")
Begin DoDot:1
+3 NEW TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
+4 SET TIUSRC=$PIECE(LINE,"~@",TIUPC)
+5 ;IHS/ITSC/LJF 02/26/2003 PATCH 1001 remove space at end of global ref
SET TIUSRC=$TRANSLATE(TIUSRC," ","")
+6 SET TIUTAIL=$PIECE(LINE,"~@",TIUPC+1)
+7 SET TIULINE=$PIECE(LINE,"~@",(TIUPC-1))
SET (TIUI,TIUSCNT)=0
+8 IF $EXTRACT(TIULINE)=" "
IF (TIUPC>2)
SET $EXTRACT(TIULINE)=""
+9 FOR
SET TIUI=$ORDER(@TIUSRC@(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:2
+10 NEW TIUSLINE
+11 SET TIUSCNT=TIUSCNT+1
+12 SET TIUSLINE=$GET(@TIUSRC@(TIUI,0))
+13 IF '+$ORDER(@TIUSRC@(TIUI))&(TIUPC+2>$LENGTH(LINE,"~@"))
SET TIUSLINE=TIUSLINE_TIUTAIL
+14 IF TIUSCNT=1
IF ($LENGTH(TIULINE_TIUSLINE)>73)
Begin DoDot:3
+15 IF $DATA(@TARGET@(TIULCNT,0))
SET TIULCNT=TIULCNT+1
+16 SET @TARGET@(TIULCNT,0)=TIULINE
+17 SET TIULCNT=TIULCNT+1
+18 SET @TARGET@(TIULCNT,0)=TIUSLINE
End DoDot:3
QUIT
+19 IF TIUSCNT=1
IF ($LENGTH(TIULINE_TIUSLINE)'>73)
Begin DoDot:3
+20 IF $DATA(@TARGET@(TIULCNT,0))
SET TIULCNT=TIULCNT+1
+21 SET @TARGET@(TIULCNT,0)=TIULINE_TIUSLINE
End DoDot:3
QUIT
+22 IF $DATA(@TARGET@(TIULCNT,0))
SET TIULCNT=TIULCNT+1
+23 SET @TARGET@(TIULCNT,0)=$GET(TIUSLINE)
End DoDot:2
+24 KILL @TIUSRC
End DoDot:1
+25 QUIT
APPEND(X) ;
+1 NEW TIUXL
SET TIUXL=$LENGTH(X)
+2 IF $EXTRACT(X,TIUXL-1,TIUXL)'="~@"
SET X=X_"~@"
+3 QUIT X
