- TIUSRVP ;SLC/JER - RPCs for CREATE & UPDATE ;Jan 31, 2024@07:30
- ;;1.0;TEXT INTEGRATION UTILITIES;**1,7,19,28,47,89,104,100,115,109,167,113,112,175,157,184,239,271,290,362**;Jun 20, 1997;Build 3
- ;
- ; Reference to File ^AUPNVSIT supported by ICR #3580
- ; Reference to File ^SC( supported by ICR #93
- ; Reference to *^DIALOG supported by ICR #2050
- ; Reference to ^DIC supported by ICR #10006
- ; Reference to ^DIE supported by ICR #10018
- ; Reference to FINDVISIT^PXUTLVST supported by ICR #7435
- ; Reference to *^XLFDT supported by ICR #10103
- ;
- Q
- 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
- ; *362 ajb, use first visit found
- I '+$G(VSIT),$L($G(VSTR)) D
- . N VISIT D FINDVISIT^PXUTLVST(DFN,$P(VSTR,";",2),+VSTR,$P(VSTR,";",3),"","","","",1,.VISIT)
- . S:+VISIT(0)>0 (VSIT,TIU("VISIT"))=VISIT(1)
- ; *362 ajb
- 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 9946 printed Jan 18, 2025@03:47:05 Page 2
- TIUSRVP ;SLC/JER - RPCs for CREATE & UPDATE ;Jan 31, 2024@07:30
- +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,362**;Jun 20, 1997;Build 3
- +2 ;
- +3 ; Reference to File ^AUPNVSIT supported by ICR #3580
- +4 ; Reference to File ^SC( supported by ICR #93
- +5 ; Reference to *^DIALOG supported by ICR #2050
- +6 ; Reference to ^DIC supported by ICR #10006
- +7 ; Reference to ^DIE supported by ICR #10018
- +8 ; Reference to FINDVISIT^PXUTLVST supported by ICR #7435
- +9 ; Reference to *^XLFDT supported by ICR #10103
- +10 ;
- +11 QUIT
- 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 ; *362 ajb, use first visit found
- +15 IF '+$GET(VSIT)
- IF $LENGTH($GET(VSTR))
- Begin DoDot:1
- +16 NEW VISIT
- DO FINDVISIT^PXUTLVST(DFN,$PIECE(VSTR,";",2),+VSTR,$PIECE(VSTR,";",3),"","","","",1,.VISIT)
- +17 if +VISIT(0)>0
- SET (VSIT,TIU("VISIT"))=VISIT(1)
- End DoDot:1
- +18 ; *362 ajb
- +19 IF +$GET(VSIT)
- SET VSTR=$$VSTRBLD(+VSIT)
- +20 IF $LENGTH($GET(VSTR))
- Begin DoDot:1
- +21 SET VDT=$SELECT(+$GET(VDT):+$GET(VDT),1:$PIECE(VSTR,";",2))
- +22 SET LDT=$SELECT(+$GET(VDT):$$FMADD^XLFDT(VDT,"","",1),1:"")
- +23 SET VLOC=$SELECT(+$GET(VLOC):+$GET(VLOC),1:$PIECE(VSTR,";"))
- +24 ; If note is for Ward Location, call MAIN^TIUMOVE
- +25 IF $PIECE($GET(^SC(+VLOC,0)),U,3)="W"
- DO MAIN^TIUMOVE(.TIU,DFN,"",VDT,LDT,1,"LAST",0,+VLOC)
- QUIT
- +26 ; Otherwise, call PATVADPT^TIULV
- +27 DO PATVADPT^TIULV(.TIU,DFN,"",VSTR)
- End DoDot:1
- +28 IF '+$GET(VSIT)
- IF '$LENGTH($GET(VSTR))
- IF +$GET(VDT)
- IF +$GET(VLOC)
- Begin DoDot:1
- +29 SET VDT=$GET(VDT)
- SET LDT=$SELECT(+$GET(VDT):$$FMADD^XLFDT(VDT,"","",1),1:"")
- +30 ; If note is for Ward Location, call MAIN^TIUMOVE
- +31 IF $PIECE($GET(^SC(+VLOC,0)),U,3)="W"
- DO MAIN^TIUMOVE(.TIU,DFN,"",VDT,LDT,1,"LAST",0,+VLOC)
- QUIT
- +32 ; Otherwise, call MAIN^TIUVSIT
- +33 DO MAIN^TIUVSIT(.TIU,DFN,"",VDT,LDT,"LAST",0,VLOC)
- End DoDot:1
- +34 IF '+$GET(TIU("VSTR"))
- Begin DoDot:1
- +35 DO EVENT^TIUSRVP1(.TIU,DFN)
- End DoDot:1
- +36 SET TIU("INST")=$$DIVISION^TIULC1(+TIU("LOC"))
- +37 IF $SELECT($DATA(TIU)'>9:1,+$GET(DFN)'>0:1,1:0)
- SET SUCCESS="0^"_$$EZBLD^DIALOG(89250001)
- QUIT
- +38 SET TIUDA=$$GETREC(DFN,.TIU,TITLE,.NEWREC)
- +39 IF +TIUDA'>0
- SET SUCCESS="0^"_$$EZBLD^DIALOG(89250002)
- QUIT
- +40 SET SUCCESS=+TIUDA
- +41 DO STUFREC^TIUSRVP1(+TIUDA,.TIUX,DFN,,TITLE,.TIU)
- +42 if '+$GET(NOASF)
- SET ^TIU(8925,"ASAVE",DUZ,TIUDA)=""
- +43 KILL ^TIU(8925,+TIUDA,"TEMP")
- +44 MERGE ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT")
- KILL TIUX("TEXT")
- +45 DO SETXT0(TIUDA)
- +46 DO FILE(.SUCCESS,+TIUDA,.TIUX,+$GET(SUPPRESS))
- +47 IF +SUCCESS'>0
- DO DIK^TIURB2(TIUDA)
- QUIT
- +48 IF +$ORDER(^TIU(8925,+TIUDA,"TEMP",0))
- DO MERGTEXT^TIUEDI1(+TIUDA,.TIU)
- +49 IF +$GET(TIU("STOP"))
- DO DEFER^TIUVSIT(TIUDA,TIU("STOP"))
- IF 1
- +50 IF '$TEST
- DO QUE^TIUPXAP1
- +51 IF '+$GET(SUPPRESS)
- Begin DoDot:1
- +52 DO RELEASE^TIUT(TIUDA,1)
- +53 DO UPDTIRT^TIUDIRT(.TIU,TIUDA)
- End DoDot:1
- +54 KILL ^TIU(8925,+TIUDA,"TEMP")
- +55 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