TIUSRVP ;SLC/JER - RPCs for CREATE & UPDATE ;12/08/2017 14:40
;;1.0;TEXT INTEGRATION UTILITIES;**1,7,19,28,47,89,104,100,115,109,167,113,112,175,157,184,239,271,290**;Jun 20, 1997;Build 548
MAKE(SUCCESS,DFN,TITLE,VDT,VLOC,VSIT,TIUX,VSTR,SUPPRESS,NOASF) ; New Document
; SUCCESS = (by ref) TIU DOCUMENT # (PTR to 8925)
; = 0^Explanatory message if no SUCCESS
; DFN = Patient (#2)
; TITLE = TIU Document Definition (#8925.1)
; [VDT] = Date(/Time) of Visit
; [VLOC] = Visit Location (HOSPITAL LOCATION)
; [VSIT] = Visit file ien (#9000010)
; [VSTR] = Visit string (i.e., VLOC;VDT;VTYPE)
; [NOASF] = if 1=Do Not Set ASAVE cross-reference
; TIUX = (by ref) array containing field data and document body
;
N TIU,TIUDA,LDT,NEWREC
S SUCCESS=0
I +$G(VSIT) S VSTR=$$VSTRBLD(+VSIT)
I $L($G(VSTR)) D
. S VDT=$S(+$G(VDT):+$G(VDT),1:$P(VSTR,";",2))
. S LDT=$S(+$G(VDT):$$FMADD^XLFDT(VDT,"","",1),1:"")
. S VLOC=$S(+$G(VLOC):+$G(VLOC),1:$P(VSTR,";"))
. ; If note is for Ward Location, call MAIN^TIUMOVE
. I $P($G(^SC(+VLOC,0)),U,3)="W" D MAIN^TIUMOVE(.TIU,DFN,"",VDT,LDT,1,"LAST",0,+VLOC) Q
. ; Otherwise, call PATVADPT^TIULV
. D PATVADPT^TIULV(.TIU,DFN,"",VSTR)
I '+$G(VSIT),'$L($G(VSTR)),+$G(VDT),+$G(VLOC) D
. S VDT=$G(VDT),LDT=$S(+$G(VDT):$$FMADD^XLFDT(VDT,"","",1),1:"")
. ; If note is for Ward Location, call MAIN^TIUMOVE
. I $P($G(^SC(+VLOC,0)),U,3)="W" D MAIN^TIUMOVE(.TIU,DFN,"",VDT,LDT,1,"LAST",0,+VLOC) Q
. ; Otherwise, call MAIN^TIUVSIT
. D MAIN^TIUVSIT(.TIU,DFN,"",VDT,LDT,"LAST",0,VLOC)
I '+$G(TIU("VSTR")) D
. D EVENT^TIUSRVP1(.TIU,DFN)
S TIU("INST")=$$DIVISION^TIULC1(+TIU("LOC"))
I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,1:0) S SUCCESS="0^"_$$EZBLD^DIALOG(89250001) Q
;
S TIUDA=$$GETREC(DFN,.TIU,TITLE,.NEWREC)
I +TIUDA'>0 S SUCCESS="0^"_$$EZBLD^DIALOG(89250002) Q
S SUCCESS=+TIUDA
D STUFREC^TIUSRVP1(+TIUDA,.TIUX,DFN,,TITLE,.TIU)
S:'+$G(NOASF) ^TIU(8925,"ASAVE",DUZ,TIUDA)=""
K ^TIU(8925,+TIUDA,"TEMP")
M ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT") K TIUX("TEXT")
D SETXT0(TIUDA)
D FILE(.SUCCESS,+TIUDA,.TIUX,+$G(SUPPRESS))
I +SUCCESS'>0 D DIK^TIURB2(TIUDA) Q
I +$O(^TIU(8925,+TIUDA,"TEMP",0)) D MERGTEXT^TIUEDI1(+TIUDA,.TIU)
I +$G(TIU("STOP")) D DEFER^TIUVSIT(TIUDA,TIU("STOP")) I 1
E D QUE^TIUPXAP1
I '+$G(SUPPRESS) D
. D RELEASE^TIUT(TIUDA,1)
. D UPDTIRT^TIUDIRT(.TIU,TIUDA)
K ^TIU(8925,+TIUDA,"TEMP")
Q
VSTRBLD(VSIT) ; Given Visit ien, build Visit-Descriptor String
N TIUY,VSIT0,VLOC,VDT,VSVCAT
S VSIT0=$G(^AUPNVSIT(+VSIT,0)),VDT=+$P(VSIT0,U),VLOC=+$P(VSIT0,U,22)
S VSVCAT=$P(VSIT0,U,7)
S TIUY=VLOC_";"_VDT_";"_VSVCAT
Q TIUY
SETXT0(TIUDA) ; Set root node of "TEMP" WP-field
N TIUC,TIUI S (TIUC,TIUI)=0
F S TIUI=$O(^TIU(8925,TIUDA,"TEMP",TIUI)) Q:+TIUI'>0 D
. S:$D(^TIU(8925,TIUDA,"TEMP",TIUI,0)) TIUC=TIUC+1
S ^TIU(8925,TIUDA,"TEMP",0)="^^"_TIUC_U_TIUC_U_DT_"^^"
Q
MAKEADD(TIUDADD,TIUDA,TIUX,SUPPRESS) ; Create addendum
; For backward compatibility
; Use MAKEADD^TIUSRVP2 now, please
D MAKEADD^TIUSRVP2(.TIUDADD,TIUDA,.TIUX,+$G(SUPPRESS))
Q
UPDATE(SUCCESS,TIUDA,TIUX,SUPPRESS) ; Update existing Document
N TIU,TIUI,TIUC,TIUD0,TIUD12,TIUD14,TIUD15,TIUCPF,TITLE,PRFUNLNK,TIUY,TIUCC,TIUFLAG S TIUFLAG=0
I $S(+$G(TIUDA)'>0:1,'$D(^TIU(8925,+TIUDA,0)):1,1:0) D Q
. S SUCCESS="0^ Cannot update a non-existent document..."
I +$P($G(^TIU(8925,+TIUDA,0)),U,5)>6 D Q
. S SUCCESS="0^ TIU Document #"_TIUDA_" is already signed..."
I $D(TIUX("TEXT")) D
. K ^TIU(8925,+TIUDA,"TEMP")
. M ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT")
. S (TIUC,TIUI)=0
. F S TIUI=$O(^TIU(8925,+TIUDA,"TEMP",TIUI)) Q:+TIUI'>0 D
. . S TIUC=TIUC+1
. I +TIUC>0 S ^TIU(8925,+TIUDA,"TEMP",0)="^^"_TIUC_U_TIUC_U_DT_"^^"
. K TIUX("TEXT")
I +$O(TIUX(""))'>0 S:+$G(SUPPRESS) SUCCESS=+TIUDA Q
S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD12=$G(^(12)),TIUD14=$G(^(14)),TITLE=+TIUD0
;Set a flag to indicate whether or not a Title is a member of the
;Clinical Procedures Class (1=Yes and 0=No)
S TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP)
D SETCOS^TIUSRVP2(TIUDA,.TIUX,TIUD0,TIUD12)
; Consult association changed? If so, rollback to Active status. VM/RJT - *239
S TIUCC=$P($G(TIUD14),"^",5)
I +$G(TIUX("1405"))>0,+$G(TIUCC)>0,(+$G(TIUX("1405"))'=+TIUCC) D ROLLBACK^TIUCNSLT(TIUDA) S TIUFLAG=1
; Title changed? Refile DC
I +$G(TIUX(.01))>0,(+$G(TIUX(.01))'=+TIUD0) D
. S TIUX(.04)=$$DOCCLASS^TIULC1(+$G(TIUX(.01)))
. S TIUY=0 D ISCNSLT^TIUCNSLT(.TIUY,TITLE)
. I $G(TIUY),TIUFLAG=0 D ROLLBACK^TIUCNSLT(TIUDA) ; if changed to Non-Consult title - VMP/RJT - *239
. ; If change title from PRF to nonPRF, set flg to unlink note:
. I $$ISPFTTL^TIUPRFL(TITLE),'$$ISPFTTL^TIUPRFL(+$G(TIUX(.01))) S PRFUNLNK=1
D FILE(.SUCCESS,+TIUDA,.TIUX,+$G(SUPPRESS),TIUCPF)
I +SUCCESS'>0 K ^TIU(8925,+TIUDA,"TEMP") Q
I $G(PRFUNLNK) D UNLINK^TIUPRF1(TIUDA)
D GETTIU^TIULD(.TIU,TIUDA)
I $D(^TIU(8925,+TIUDA,"TEMP")) D
. K ^TIU(8925,+TIUDA,"TEXT")
. D MERGTEXT^TIUEDI1(+TIUDA,.TIU)
. K ^TIU(8925,+TIUDA,"TEMP")
. S:'+$G(SUCCESS) SUCCESS=+TIUDA
; If signed, re-file /ES/
S TIUD15=$G(^TIU(8925,+TIUDA,15))
I +TIUD15 D
. N TIUBY,DR,DIE,DA,X,Y S TIUBY=$P(TIUD15,U,2) Q:+TIUBY'>0
. S DR="1503///^S X=$$SIGNAME^TIULS("_TIUBY_");1504///^S X=$$SIGTITL^TIULS("_TIUBY_")"
. S DA=TIUDA,DIE=8925 D ^DIE
; send alerts
I '+$G(SUPPRESS) D
. I +$P(TIUD0,U,5)<5,'$D(TIUX(.05)) D UPDSTAT(TIUDA,+$G(TIUD0))
. D SEND^TIUALRT(TIUDA),SENDID^TIUALRT1(TIUDA):+$G(^TIU(8925,+TIUDA,21))
. D UPDTIRT^TIUDIRT(.TIU,TIUDA)
Q
SETCOS(TIUDA,TIUX,TIUD0,TIUD12) ; set cosig req
; For backward compatibility
; Use SETCOS^TIUSRVP2 now, please
D SETCOS^TIUSRVP2(TIUDA,.TIUX,TIUD0,TIUD12)
Q
UPDSTAT(DA,TITLE) ; Update status on commit
N DR,DIE S DR=".05////"_$$STATUS^TIUSRVP1(DA,0,TITLE)
I '+$P($G(^TIU(8925,DA,13)),U,4) S DR=DR_";1304////^S X=$$NOW^XLFDT"
S DIE=8925
D ^DIE
Q
GETREC(DFN,TIU,TITLE,TIUNEW) ; Get/create document record
N DA,DIC,DIE,DLAYGO,DR,X,Y,TIUDPRM,TIUFPRIV,TIUHIT,TIUSCAT
S (TIUHIT,DA)=0,TIUFPRIV=1
S (DIC,DLAYGO)=8925,DIC(0)="FL"
S X=""""_"`"_+TITLE_"""" D ^DIC K DIC("S")
I +Y'>0 Q Y_U_" Insufficient data to create a new record."
S DA=+Y,TIUNEW=+$P(Y,U,3)
N DIE,DR,TIUVISIT S DIE=8925
S TIUVISIT=$S(+$G(TIU("VISIT")):+$G(TIU("VISIT")),1:"")
S TIUSCAT=$S(+$L($P($G(TIU("CAT")),U)):$P($G(TIU("CAT")),U),+$L($P($G(TIU("VSTR")),";",3)):$P($G(TIU("VSTR")),";",3),1:"")
S DR=".04////"_$$DOCCLASS^TIULC1(+$P(Y,U,2))_";.13////"_TIUSCAT_";1205////"_$P($G(TIU("LOC")),U)_";1211////"_$P($G(TIU("VLOC")),U)_";1212////"_$P($G(TIU("INST")),U)
D ^DIE
Q +$G(DA)
FILE(SUCCESS,TIUDA,TIUX,SUPPRESS,TIUCPF) ; Call FM Filer & commit
N FDA,FDARR,IENS,FLAGS,TIUMSG,TIUCMMTX
S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS=""
I +$G(TIUX(1202)) S TIUX(1204)=+$G(TIUX(1202))
I +$G(TIUX(1209)) S TIUX(1208)=+$G(TIUX(1209))
;If the document is a member of the Clinical Procedures Class, set the
;Entered By field to the Author/Dictator field
I $G(TIUCPF),+$G(TIUX(1202)) S TIUX(1302)=+$G(TIUX(1202))
;*271 Prevent string date in 1301
S:$G(TIUX(1301)) TIUX(1301)=+TIUX(1301)
M @FDARR=TIUX
D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
I $D(TIUMSG)>9 S SUCCESS=0_U_$G(TIUMSG("DIERR",1,"TEXT",1)) Q
S SUCCESS=TIUDA
I '+$G(SUPPRESS) D
. N DA
. S DA=TIUDA
. S TIUCMMTX=$$COMMIT^TIULC1(+$G(^TIU(8925,+TIUDA,0)))
. I TIUCMMTX]"" X TIUCMMTX
. K ^TIU(8925,"ASAVE",DUZ,TIUDA)
Q
SIGN(ERR,TIUDA,TIUX) ; API for /es/
; For backward compatibility
; Use SIGN^TIUSRVP2 now, please
D SIGN^TIUSRVP2(.ERR,TIUDA,.TIUX)
Q
DELETE(ERR,TIUDA,TIURSN,OVRRIDE) ; delete document
N TIUDEL,TIUD0,TIU S ERR=0
I '+$G(OVRRIDE) D Q:+$G(TIUDEL)'>0
. S TIUDEL=$$CANDO^TIULP(TIUDA,"DELETE RECORD")
. I TIUDEL'>0 S ERR="89250003^"_$$EZBLD^DIALOG(89250003)
D GETTIU^TIULD(.TIU,TIUDA)
S TIUD0=$G(^TIU(8925,+TIUDA,0))
I +$P(TIUD0,U,5)'<6 D Q
. S TIURSN=$G(TIURSN,"A")
. D DELTEXT^TIURB2(TIUDA,TIURSN)
D DIK^TIURB2(TIUDA)
D DELAUDIT^TIUEDI1(TIUDA)
D NOTIFY^TIUUTL("DELETE",+$P(TIUD0,U,2),,.TIU,TIUDA)
Q
ANPKGMSG(RETURN,TIUDA,TIUACT) ; return ancillary packages' message(s)
S TIUDA=+$G(TIUDA),TIUACT=$G(TIUACT)
I 'TIUDA S RETURN(0)="Invalid parameter: TIUDA="_TIUDA Q
I "^DELETE^REASSIGN^"'[(U_TIUACT_U) S RETURN(0)="Invalid parameter: TIUACT="""_TIUACT_""""
N TIUD0,TIUJUST
S TIUD0=$G(^TIU(8925,+TIUDA,0))
I TIUD0="" S RETURN(0)="Invalid document number: "_TIUDA Q
I TIUACT="DELETE" D
.D NEEDJUST^TIUSRVA(.TIUJUST,TIUDA)
.I TIUJUST S TIUACT="RETRACT"
D ANPKGMSG^TIUUTL(+$P(TIUD0,U,2),+$P(TIUD0,U,3),TIUDA_U_$P($G(^TIU(8925.1,+$P(TIUD0,U),0)),U),TIUACT)
N TIUAPKG,TIUMLINE,TIULINE
S TIUMLINE=0
S TIUAPKG="" F S TIUAPKG=$O(^TMP("TIUDOCDIS",$J,"MESSAGES",TIUAPKG)) Q:TIUAPKG="" D
.S RETURN(TIUMLINE)="~NPKG"_U_TIUAPKG_":",TIUMLINE=1+TIUMLINE
.S TIULINE=0 F S TIULINE=$O(^TMP("TIUDOCDIS",$J,"MESSAGES",TIUAPKG,TIULINE)) Q:'+TIULINE D
..S RETURN(TIUMLINE)=$G(^TMP("TIUDOCDIS",$J,"MESSAGES",TIUAPKG,TIULINE)),TIUMLINE=1+TIUMLINE
K ^TMP("TIUDOCDIS",$J)
Q
LOCK(ERR,TIUDA) ; Bid for lock on a TIU Document record
L +^TIU(8925,+TIUDA):1 I S ERR=0
E S ERR="1^ Another session has this record locked."
Q
UNLOCK(ERR,TIUDA) ; Decrement Lock on a TIU Document record
L -^TIU(8925,+TIUDA) S ERR=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVP 9362 printed Apr 09, 2024@21:42:07 Page 2
TIUSRVP ;SLC/JER - RPCs for CREATE & UPDATE ;12/08/2017 14:40
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1,7,19,28,47,89,104,100,115,109,167,113,112,175,157,184,239,271,290**;Jun 20, 1997;Build 548
MAKE(SUCCESS,DFN,TITLE,VDT,VLOC,VSIT,TIUX,VSTR,SUPPRESS,NOASF) ; New Document
+1 ; SUCCESS = (by ref) TIU DOCUMENT # (PTR to 8925)
+2 ; = 0^Explanatory message if no SUCCESS
+3 ; DFN = Patient (#2)
+4 ; TITLE = TIU Document Definition (#8925.1)
+5 ; [VDT] = Date(/Time) of Visit
+6 ; [VLOC] = Visit Location (HOSPITAL LOCATION)
+7 ; [VSIT] = Visit file ien (#9000010)
+8 ; [VSTR] = Visit string (i.e., VLOC;VDT;VTYPE)
+9 ; [NOASF] = if 1=Do Not Set ASAVE cross-reference
+10 ; TIUX = (by ref) array containing field data and document body
+11 ;
+12 NEW TIU,TIUDA,LDT,NEWREC
+13 SET SUCCESS=0
+14 IF +$GET(VSIT)
SET VSTR=$$VSTRBLD(+VSIT)
+15 IF $LENGTH($GET(VSTR))
Begin DoDot:1
+16 SET VDT=$SELECT(+$GET(VDT):+$GET(VDT),1:$PIECE(VSTR,";",2))
+17 SET LDT=$SELECT(+$GET(VDT):$$FMADD^XLFDT(VDT,"","",1),1:"")
+18 SET VLOC=$SELECT(+$GET(VLOC):+$GET(VLOC),1:$PIECE(VSTR,";"))
+19 ; If note is for Ward Location, call MAIN^TIUMOVE
+20 IF $PIECE($GET(^SC(+VLOC,0)),U,3)="W"
DO MAIN^TIUMOVE(.TIU,DFN,"",VDT,LDT,1,"LAST",0,+VLOC)
QUIT
+21 ; Otherwise, call PATVADPT^TIULV
+22 DO PATVADPT^TIULV(.TIU,DFN,"",VSTR)
End DoDot:1
+23 IF '+$GET(VSIT)
IF '$LENGTH($GET(VSTR))
IF +$GET(VDT)
IF +$GET(VLOC)
Begin DoDot:1
+24 SET VDT=$GET(VDT)
SET LDT=$SELECT(+$GET(VDT):$$FMADD^XLFDT(VDT,"","",1),1:"")
+25 ; If note is for Ward Location, call MAIN^TIUMOVE
+26 IF $PIECE($GET(^SC(+VLOC,0)),U,3)="W"
DO MAIN^TIUMOVE(.TIU,DFN,"",VDT,LDT,1,"LAST",0,+VLOC)
QUIT
+27 ; Otherwise, call MAIN^TIUVSIT
+28 DO MAIN^TIUVSIT(.TIU,DFN,"",VDT,LDT,"LAST",0,VLOC)
End DoDot:1
+29 IF '+$GET(TIU("VSTR"))
Begin DoDot:1
+30 DO EVENT^TIUSRVP1(.TIU,DFN)
End DoDot:1
+31 SET TIU("INST")=$$DIVISION^TIULC1(+TIU("LOC"))
+32 IF $SELECT($DATA(TIU)'>9:1,+$GET(DFN)'>0:1,1:0)
SET SUCCESS="0^"_$$EZBLD^DIALOG(89250001)
QUIT
+33 ;
+34 SET TIUDA=$$GETREC(DFN,.TIU,TITLE,.NEWREC)
+35 IF +TIUDA'>0
SET SUCCESS="0^"_$$EZBLD^DIALOG(89250002)
QUIT
+36 SET SUCCESS=+TIUDA
+37 DO STUFREC^TIUSRVP1(+TIUDA,.TIUX,DFN,,TITLE,.TIU)
+38 if '+$GET(NOASF)
SET ^TIU(8925,"ASAVE",DUZ,TIUDA)=""
+39 KILL ^TIU(8925,+TIUDA,"TEMP")
+40 MERGE ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT")
KILL TIUX("TEXT")
+41 DO SETXT0(TIUDA)
+42 DO FILE(.SUCCESS,+TIUDA,.TIUX,+$GET(SUPPRESS))
+43 IF +SUCCESS'>0
DO DIK^TIURB2(TIUDA)
QUIT
+44 IF +$ORDER(^TIU(8925,+TIUDA,"TEMP",0))
DO MERGTEXT^TIUEDI1(+TIUDA,.TIU)
+45 IF +$GET(TIU("STOP"))
DO DEFER^TIUVSIT(TIUDA,TIU("STOP"))
IF 1
+46 IF '$TEST
DO QUE^TIUPXAP1
+47 IF '+$GET(SUPPRESS)
Begin DoDot:1
+48 DO RELEASE^TIUT(TIUDA,1)
+49 DO UPDTIRT^TIUDIRT(.TIU,TIUDA)
End DoDot:1
+50 KILL ^TIU(8925,+TIUDA,"TEMP")
+51 QUIT
VSTRBLD(VSIT) ; Given Visit ien, build Visit-Descriptor String
+1 NEW TIUY,VSIT0,VLOC,VDT,VSVCAT
+2 SET VSIT0=$GET(^AUPNVSIT(+VSIT,0))
SET VDT=+$PIECE(VSIT0,U)
SET VLOC=+$PIECE(VSIT0,U,22)
+3 SET VSVCAT=$PIECE(VSIT0,U,7)
+4 SET TIUY=VLOC_";"_VDT_";"_VSVCAT
+5 QUIT TIUY
SETXT0(TIUDA) ; Set root node of "TEMP" WP-field
+1 NEW TIUC,TIUI
SET (TIUC,TIUI)=0
+2 FOR
SET TIUI=$ORDER(^TIU(8925,TIUDA,"TEMP",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+3 if $DATA(^TIU(8925,TIUDA,"TEMP",TIUI,0))
SET TIUC=TIUC+1
End DoDot:1
+4 SET ^TIU(8925,TIUDA,"TEMP",0)="^^"_TIUC_U_TIUC_U_DT_"^^"
+5 QUIT
MAKEADD(TIUDADD,TIUDA,TIUX,SUPPRESS) ; Create addendum
+1 ; For backward compatibility
+2 ; Use MAKEADD^TIUSRVP2 now, please
+3 DO MAKEADD^TIUSRVP2(.TIUDADD,TIUDA,.TIUX,+$GET(SUPPRESS))
+4 QUIT
UPDATE(SUCCESS,TIUDA,TIUX,SUPPRESS) ; Update existing Document
+1 NEW TIU,TIUI,TIUC,TIUD0,TIUD12,TIUD14,TIUD15,TIUCPF,TITLE,PRFUNLNK,TIUY,TIUCC,TIUFLAG
SET TIUFLAG=0
+2 IF $SELECT(+$GET(TIUDA)'>0:1,'$DATA(^TIU(8925,+TIUDA,0)):1,1:0)
Begin DoDot:1
+3 SET SUCCESS="0^ Cannot update a non-existent document..."
End DoDot:1
QUIT
+4 IF +$PIECE($GET(^TIU(8925,+TIUDA,0)),U,5)>6
Begin DoDot:1
+5 SET SUCCESS="0^ TIU Document #"_TIUDA_" is already signed..."
End DoDot:1
QUIT
+6 IF $DATA(TIUX("TEXT"))
Begin DoDot:1
+7 KILL ^TIU(8925,+TIUDA,"TEMP")
+8 MERGE ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT")
+9 SET (TIUC,TIUI)=0
+10 FOR
SET TIUI=$ORDER(^TIU(8925,+TIUDA,"TEMP",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:2
+11 SET TIUC=TIUC+1
End DoDot:2
+12 IF +TIUC>0
SET ^TIU(8925,+TIUDA,"TEMP",0)="^^"_TIUC_U_TIUC_U_DT_"^^"
+13 KILL TIUX("TEXT")
End DoDot:1
+14 IF +$ORDER(TIUX(""))'>0
if +$GET(SUPPRESS)
SET SUCCESS=+TIUDA
QUIT
+15 SET TIUD0=$GET(^TIU(8925,TIUDA,0))
SET TIUD12=$GET(^(12))
SET TIUD14=$GET(^(14))
SET TITLE=+TIUD0
+16 ;Set a flag to indicate whether or not a Title is a member of the
+17 ;Clinical Procedures Class (1=Yes and 0=No)
+18 SET TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP)
+19 DO SETCOS^TIUSRVP2(TIUDA,.TIUX,TIUD0,TIUD12)
+20 ; Consult association changed? If so, rollback to Active status. VM/RJT - *239
+21 SET TIUCC=$PIECE($GET(TIUD14),"^",5)
+22 IF +$GET(TIUX("1405"))>0
IF +$GET(TIUCC)>0
IF (+$GET(TIUX("1405"))'=+TIUCC)
DO ROLLBACK^TIUCNSLT(TIUDA)
SET TIUFLAG=1
+23 ; Title changed? Refile DC
+24 IF +$GET(TIUX(.01))>0
IF (+$GET(TIUX(.01))'=+TIUD0)
Begin DoDot:1
+25 SET TIUX(.04)=$$DOCCLASS^TIULC1(+$GET(TIUX(.01)))
+26 SET TIUY=0
DO ISCNSLT^TIUCNSLT(.TIUY,TITLE)
+27 ; if changed to Non-Consult title - VMP/RJT - *239
IF $GET(TIUY)
IF TIUFLAG=0
DO ROLLBACK^TIUCNSLT(TIUDA)
+28 ; If change title from PRF to nonPRF, set flg to unlink note:
+29 IF $$ISPFTTL^TIUPRFL(TITLE)
IF '$$ISPFTTL^TIUPRFL(+$GET(TIUX(.01)))
SET PRFUNLNK=1
End DoDot:1
+30 DO FILE(.SUCCESS,+TIUDA,.TIUX,+$GET(SUPPRESS),TIUCPF)
+31 IF +SUCCESS'>0
KILL ^TIU(8925,+TIUDA,"TEMP")
QUIT
+32 IF $GET(PRFUNLNK)
DO UNLINK^TIUPRF1(TIUDA)
+33 DO GETTIU^TIULD(.TIU,TIUDA)
+34 IF $DATA(^TIU(8925,+TIUDA,"TEMP"))
Begin DoDot:1
+35 KILL ^TIU(8925,+TIUDA,"TEXT")
+36 DO MERGTEXT^TIUEDI1(+TIUDA,.TIU)
+37 KILL ^TIU(8925,+TIUDA,"TEMP")
+38 if '+$GET(SUCCESS)
SET SUCCESS=+TIUDA
End DoDot:1
+39 ; If signed, re-file /ES/
+40 SET TIUD15=$GET(^TIU(8925,+TIUDA,15))
+41 IF +TIUD15
Begin DoDot:1
+42 NEW TIUBY,DR,DIE,DA,X,Y
SET TIUBY=$PIECE(TIUD15,U,2)
if +TIUBY'>0
QUIT
+43 SET DR="1503///^S X=$$SIGNAME^TIULS("_TIUBY_");1504///^S X=$$SIGTITL^TIULS("_TIUBY_")"
+44 SET DA=TIUDA
SET DIE=8925
DO ^DIE
End DoDot:1
+45 ; send alerts
+46 IF '+$GET(SUPPRESS)
Begin DoDot:1
+47 IF +$PIECE(TIUD0,U,5)<5
IF '$DATA(TIUX(.05))
DO UPDSTAT(TIUDA,+$GET(TIUD0))
+48 DO SEND^TIUALRT(TIUDA)
if +$GET(^TIU(8925,+TIUDA,21))
DO SENDID^TIUALRT1(TIUDA)
+49 DO UPDTIRT^TIUDIRT(.TIU,TIUDA)
End DoDot:1
+50 QUIT
SETCOS(TIUDA,TIUX,TIUD0,TIUD12) ; set cosig req
+1 ; For backward compatibility
+2 ; Use SETCOS^TIUSRVP2 now, please
+3 DO SETCOS^TIUSRVP2(TIUDA,.TIUX,TIUD0,TIUD12)
+4 QUIT
UPDSTAT(DA,TITLE) ; Update status on commit
+1 NEW DR,DIE
SET DR=".05////"_$$STATUS^TIUSRVP1(DA,0,TITLE)
+2 IF '+$PIECE($GET(^TIU(8925,DA,13)),U,4)
SET DR=DR_";1304////^S X=$$NOW^XLFDT"
+3 SET DIE=8925
+4 DO ^DIE
+5 QUIT
GETREC(DFN,TIU,TITLE,TIUNEW) ; Get/create document record
+1 NEW DA,DIC,DIE,DLAYGO,DR,X,Y,TIUDPRM,TIUFPRIV,TIUHIT,TIUSCAT
+2 SET (TIUHIT,DA)=0
SET TIUFPRIV=1
+3 SET (DIC,DLAYGO)=8925
SET DIC(0)="FL"
+4 SET X=""""_"`"_+TITLE_""""
DO ^DIC
KILL DIC("S")
+5 IF +Y'>0
QUIT Y_U_" Insufficient data to create a new record."
+6 SET DA=+Y
SET TIUNEW=+$PIECE(Y,U,3)
+7 NEW DIE,DR,TIUVISIT
SET DIE=8925
+8 SET TIUVISIT=$SELECT(+$GET(TIU("VISIT")):+$GET(TIU("VISIT")),1:"")
+9 SET TIUSCAT=$SELECT(+$LENGTH($PIECE($GET(TIU("CAT")),U)):$PIECE($GET(TIU("CAT")),U),+$LENGTH($PIECE($GET(TIU("VSTR")),";",3)):$PIECE($GET(TIU("VSTR")),";",3),1:"")
+10 SET DR=".04////"_$$DOCCLASS^TIULC1(+$PIECE(Y,U,2))_";.13////"_TIUSCAT_";1205////"_$PIECE($GET(TIU("LOC")),U)_";1211////"_$PIECE($GET(TIU("VLOC")),U)_";1212////"_$PIECE($GET(TIU("INST")),U)
+11 DO ^DIE
+12 QUIT +$GET(DA)
FILE(SUCCESS,TIUDA,TIUX,SUPPRESS,TIUCPF) ; Call FM Filer & commit
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG,TIUCMMTX
+2 SET IENS=""""_TIUDA_","""
SET FDARR="FDA(8925,"_IENS_")"
SET FLAGS=""
+3 IF +$GET(TIUX(1202))
SET TIUX(1204)=+$GET(TIUX(1202))
+4 IF +$GET(TIUX(1209))
SET TIUX(1208)=+$GET(TIUX(1209))
+5 ;If the document is a member of the Clinical Procedures Class, set the
+6 ;Entered By field to the Author/Dictator field
+7 IF $GET(TIUCPF)
IF +$GET(TIUX(1202))
SET TIUX(1302)=+$GET(TIUX(1202))
+8 ;*271 Prevent string date in 1301
+9 if $GET(TIUX(1301))
SET TIUX(1301)=+TIUX(1301)
+10 MERGE @FDARR=TIUX
+11 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+12 IF $DATA(TIUMSG)>9
SET SUCCESS=0_U_$GET(TIUMSG("DIERR",1,"TEXT",1))
QUIT
+13 SET SUCCESS=TIUDA
+14 IF '+$GET(SUPPRESS)
Begin DoDot:1
+15 NEW DA
+16 SET DA=TIUDA
+17 SET TIUCMMTX=$$COMMIT^TIULC1(+$GET(^TIU(8925,+TIUDA,0)))
+18 IF TIUCMMTX]""
XECUTE TIUCMMTX
+19 KILL ^TIU(8925,"ASAVE",DUZ,TIUDA)
End DoDot:1
+20 QUIT
SIGN(ERR,TIUDA,TIUX) ; API for /es/
+1 ; For backward compatibility
+2 ; Use SIGN^TIUSRVP2 now, please
+3 DO SIGN^TIUSRVP2(.ERR,TIUDA,.TIUX)
+4 QUIT
DELETE(ERR,TIUDA,TIURSN,OVRRIDE) ; delete document
+1 NEW TIUDEL,TIUD0,TIU
SET ERR=0
+2 IF '+$GET(OVRRIDE)
Begin DoDot:1
+3 SET TIUDEL=$$CANDO^TIULP(TIUDA,"DELETE RECORD")
+4 IF TIUDEL'>0
SET ERR="89250003^"_$$EZBLD^DIALOG(89250003)
End DoDot:1
if +$GET(TIUDEL)'>0
QUIT
+5 DO GETTIU^TIULD(.TIU,TIUDA)
+6 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
+7 IF +$PIECE(TIUD0,U,5)'<6
Begin DoDot:1
+8 SET TIURSN=$GET(TIURSN,"A")
+9 DO DELTEXT^TIURB2(TIUDA,TIURSN)
End DoDot:1
QUIT
+10 DO DIK^TIURB2(TIUDA)
+11 DO DELAUDIT^TIUEDI1(TIUDA)
+12 DO NOTIFY^TIUUTL("DELETE",+$PIECE(TIUD0,U,2),,.TIU,TIUDA)
+13 QUIT
ANPKGMSG(RETURN,TIUDA,TIUACT) ; return ancillary packages' message(s)
+1 SET TIUDA=+$GET(TIUDA)
SET TIUACT=$GET(TIUACT)
+2 IF 'TIUDA
SET RETURN(0)="Invalid parameter: TIUDA="_TIUDA
QUIT
+3 IF "^DELETE^REASSIGN^"'[(U_TIUACT_U)
SET RETURN(0)="Invalid parameter: TIUACT="""_TIUACT_""""
+4 NEW TIUD0,TIUJUST
+5 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
+6 IF TIUD0=""
SET RETURN(0)="Invalid document number: "_TIUDA
QUIT
+7 IF TIUACT="DELETE"
Begin DoDot:1
+8 DO NEEDJUST^TIUSRVA(.TIUJUST,TIUDA)
+9 IF TIUJUST
SET TIUACT="RETRACT"
End DoDot:1
+10 DO ANPKGMSG^TIUUTL(+$PIECE(TIUD0,U,2),+$PIECE(TIUD0,U,3),TIUDA_U_$PIECE($GET(^TIU(8925.1,+$PIECE(TIUD0,U),0)),U),TIUACT)
+11 NEW TIUAPKG,TIUMLINE,TIULINE
+12 SET TIUMLINE=0
+13 SET TIUAPKG=""
FOR
SET TIUAPKG=$ORDER(^TMP("TIUDOCDIS",$JOB,"MESSAGES",TIUAPKG))
if TIUAPKG=""
QUIT
Begin DoDot:1
+14 SET RETURN(TIUMLINE)="~NPKG"_U_TIUAPKG_":"
SET TIUMLINE=1+TIUMLINE
+15 SET TIULINE=0
FOR
SET TIULINE=$ORDER(^TMP("TIUDOCDIS",$JOB,"MESSAGES",TIUAPKG,TIULINE))
if '+TIULINE
QUIT
Begin DoDot:2
+16 SET RETURN(TIUMLINE)=$GET(^TMP("TIUDOCDIS",$JOB,"MESSAGES",TIUAPKG,TIULINE))
SET TIUMLINE=1+TIUMLINE
End DoDot:2
End DoDot:1
+17 KILL ^TMP("TIUDOCDIS",$JOB)
+18 QUIT
LOCK(ERR,TIUDA) ; Bid for lock on a TIU Document record
+1 LOCK +^TIU(8925,+TIUDA):1
IF $TEST
SET ERR=0
+2 IF '$TEST
SET ERR="1^ Another session has this record locked."
+3 QUIT
UNLOCK(ERR,TIUDA) ; Decrement Lock on a TIU Document record
+1 LOCK -^TIU(8925,+TIUDA)
SET ERR=0
+2 QUIT
