TIULC1 ; SLC/JER - More computational functions ;11/01/03
;;1.0;TEXT INTEGRATION UTILITIES;**3,4,40,49,100,131,113,112**;Jun 20, 1997
; External References
; DBIA 2324 $$ISA^USRLM
; Any patch which makes ANY changes to this rtn must include a
;note in the patch desc reminding sites to update the Imaging
;Gateway. See IA # 3622.
; IN ADDITION, if changes are made to components used by Imaging,
;namely PNAME, backward compatibility may not be enough. If
;changes call additional rtns, TIU should consult with Imaging
;on need to add additional rtns to list of TIU rtns copied for
;Imaging Gateway.
; ****
;
ENCRYPT(X,X1,X2) ; Encrypt Text Strings
D EN^XUSHSHP
Q X
DECRYPT(X,X1,X2) ; Decrypt Text Strings
D DE^XUSHSHP
Q X
WHOSIGNS(DA) ; Evaluate who should be the expected signer
N Y,TIU12
S TIU12=$G(^TIU(8925,+DA,12))
I $P(TIU12,U,2)'=$P(TIU12,U,9) S Y=$P(TIU12,U,2)
E S Y=$P(TIU12,U,9)
Q Y
WHOCOSIG(DA) ; Evaluate who should be the expected cosigner
N Y,TIU12
S TIU12=$G(^TIU(8925,+DA,12))
I $P(TIU12,U,2)=$P(TIU12,U,9) D
. I $P(TIU12,U,8)]"" S Y="@"
. E S Y=""
E S Y=$P(TIU12,U,9)
Q Y
;
HASADDEN(DA,IDKIDFLG) ; Evaluate whether a given record has addenda
; **100**:
; If +IDKIDFLG, check interdisciplinary kids of DA, as well as DA.
N TIUI,TIUY,TIUJ,TIUK
S (TIUI,TIUJ,TIUY)=0
F S TIUI=$O(^TIU(8925,"DAD",+DA,TIUI)) Q:+TIUI'>0 D Q:TIUY
. I $P($G(^TIU(8925.1,+$G(^TIU(8925,+TIUI,0)),0)),U)["ADDENDUM" S TIUY=1
I TIUY!'$G(IDKIDFLG) G HASX
;**100** Check ID kids for addenda:
F S TIUJ=$O(^TIU(8925,"GDAD",+DA,TIUJ)) Q:+TIUJ'>0 D Q:TIUY
. S TIUK=0
. F S TIUK=$O(^TIU(8925,"DAD",TIUJ,TIUK)) Q:+TIUK'>0 D Q:TIUY
. . I $P($G(^TIU(8925.1,+$G(^TIU(8925,+TIUK,0)),0)),U)["ADDENDUM" S TIUY=1
HASX Q TIUY
;
ISADDNDM(DA) ; Evaluate whether a given record IS an addendum
N TIUY S TIUY=0
I $P($G(^TIU(8925.1,+$G(^TIU(8925,+DA,0)),0)),U)["ADDENDUM",+$P($G(^TIU(8925,+DA,0)),U,6)>0 S TIUY=1
Q TIUY
PNAME(DA) ; Receives pointer to 8925.1, returns display name of
; document class
N TIUY,TIUMOM S TIUMOM=0
I +$G(DA)'>0 Q "UNKNOWN"
S TIUMOM=$O(^TIU(8925.1,"AD",DA,TIUMOM))
I $P($G(^TIU(8925.1,+DA,0)),U,4)="CO" S TIUMOM=0
I +$P($G(^TIU(8925.1,+DA,0)),U,9)=0 S TIUMOM=0
I +TIUMOM>0 D
. S TIUY=$P($G(^TIU(8925.1,+TIUMOM,0)),U,3)
. I TIUY']"" S TIUY=$$MIXED^TIULS($P($G(^TIU(8925.1,+TIUMOM,0)),U))
I +TIUMOM'>0 D
. S TIUY=$P($G(^TIU(8925.1,+DA,0)),U,3)
. I TIUY']"" S TIUY=$$MIXED^TIULS($P($G(^TIU(8925.1,+DA,0)),U))
Q TIUY
ABBREV(DA) ; Get abbreviaton for a document type or class
Q $P($G(^TIU(8925.1,+DA,0)),U,2)
PERSNAME(USER) ; Receives pointer to 200, returns name field
N X S X=$$GET1^DIQ(200,USER,.01)
Q $S($L(X):X,1:"UNKNOWN")
BEEP(USER) ; Get beeper #'s
Q $P($G(^VA(200,+USER,.13)),U,7,8)
DOCPRM(TIUTYP,TIUDPRM,TIUDA) ; Get Document Parameters, support inheritance
N TIUI,TIUDAD
S (TIUDPRM(0),TIUDPRM(5))=""
I $P($G(^TIU(8925.1,+TIUTYP,0)),U)["ADDENDUM",+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
S TIUI=+$O(^TIU(8925.95,"B",+TIUTYP,0))
I +TIUI D Q
. S TIUDPRM(0)=$G(^TIU(8925.95,+TIUI,0))
. I +$O(^TIU(8925.95,+TIUI,5,0)) D
. . N TIUJ S TIUJ=0
. . F S TIUJ=$O(^TIU(8925.95,+TIUI,5,TIUJ)) Q:+TIUJ'>0 D
. . . S $P(TIUDPRM(5),U,TIUJ)=+$G(^TIU(8925.95,+TIUI,5,+TIUJ,0))
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD D DOCPRM(TIUDAD,.TIUDPRM)
Q
POSTFILE(TIUTYP) ; Get Post-filing Code, support inheritance
N TIUPOST,TIUDAD
S TIUPOST=$G(^TIU(8925.1,+TIUTYP,4.5))
I TIUPOST]"" G POSTFILX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIUPOST=$$POSTFILE(TIUDAD)
POSTFILX Q TIUPOST
FIXCODE(TIUTYP) ; Get Error Resolution Code, support inheritance
N TIUFIX,TIUDAD
S TIUFIX=$G(^TIU(8925.1,+TIUTYP,4.8))
I TIUFIX]"" G FIXCODX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
; Don't inherit PN code for consults: TIU*1*131
I +TIUTYP=$$CLASS^TIUCNSLT,TIUDAD=3 G FIXCODX
I +TIUDAD S TIUFIX=$$FIXCODE(TIUDAD)
FIXCODX Q TIUFIX
DOCCLASS(TIUTYP) ; Given a document type, find its parent document class
Q +$O(^TIU(8925.1,"AD",+TIUTYP,0))
CLINDOC(TIUTYP,TIUDA) ; Given a document type, find the Clinical Document
; subclass to which it belongs
N TIUI,TIUY S (TIUI,TIUY)=0
I +$G(TIUDA),+$$ISADDNDM(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
S TIUI=$O(^TIU(8925.1,"AD",+TIUTYP,TIUI))
I +TIUI'>0 G CLINDOX
I TIUI=38 S TIUY=TIUTYP
I TIUI'=38 S TIUY=$$CLINDOC(TIUI)
CLINDOX Q TIUY
REQVER(TIUTYP,TIUDA) ; Does a given document type require verification
N TIUDPRM,TIUY
I +$G(TIUDA),+$$ISADDNDM(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
D DOCPRM(TIUTYP,.TIUDPRM)
I +$P($G(TIUDPRM(0)),U,3) S TIUY=1
Q +$G(TIUY)
REFDATE(TIU,TIUDICDT) ; Identify Reference date
N TIURDT
I +$G(TIU("LDT")) S TIURDT=+$G(TIU("LDT"))_"^0"
I +$G(TIU("LDT"))'>0 D
. S TIURDT=$S(+$G(TIUDICDT):+$G(TIUDICDT),1:+$$NOW^TIULC)_"^1"
. S TIU("LDT")=TIURDT_U_$$DATE^TIULS(TIURDT,"AMTH DD, CCYY@HR:MIN:SEC")
Q TIURDT
WHATMPL(USER) ; What List Template should a given user get?
N TIUY
I +$$ISA^USRLM(USER,"PROVIDER") S TIUY="TIU BROWSE FOR CLINICIAN" G WHAX
I +$$ISA^USRLM(USER,"MEDICAL RECORDS TECHNICIAN") S TIUY="TIU BROWSE FOR MRT" G WHAX
I +$$ISA^USRLM(USER,"CHIEF, MIS") S TIUY="TIU BROWSE FOR MGR" G WHAX
I +$$ISA^USRLM(USER,"MEDICAL STUDENT") S TIUY="TIU BROWSE FOR CLINICIAN" G WHAX
S TIUY="TIU BROWSE FOR READ ONLY"
WHAX Q TIUY
SUPPVSIT(TIUTYP) ; Evaluate whether to suppress visit matching
N TIUI,TIUY S TIUY=0
I +$P($G(^TIU(8925.1,+TIUTYP,3)),U,3) S TIUY=1 G SUPPVSIX
I $L($P($G(^TIU(8925.1,+TIUTYP,3)),U,3)),($P($G(^(3)),U,3)=0) S TIUY=0 G SUPPVSIX ; ** SLC/JER - NOIS NYC-1298-11472
S TIUI=0 F S TIUI=$O(^TIU(8925.1,"AD",+TIUTYP,TIUI)) Q:+TIUI'>0!(+TIUY>0) D
. S TIUY=+$$SUPPVSIT(+TIUI)
SUPPVSIX Q TIUY
PTNAME(DFN) ; Resolve Patient Name
N TIUY S TIUY=$P($G(^DPT(DFN,0)),U)
S:TIUY']"" TIUY="NAME UNKNOWN"
Q TIUY
POSTSIGN(TIUTYP) ; Get Post-Signature Code, support inheritance
N TIUPOST,TIUDAD
S TIUPOST=$G(^TIU(8925.1,+TIUTYP,4.9))
I TIUPOST]"" G POSTSIGX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIUPOST=$$POSTSIGN(TIUDAD)
POSTSIGX Q TIUPOST
COMMIT(TIUTYP) ; Get Commitment action, support inheritance
N TIUCOMM,TIUDAD
S TIUCOMM=$G(^TIU(8925.1,+TIUTYP,4.1))
I TIUCOMM]"" G COMMITX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIUCOMM=$$COMMIT(TIUDAD)
COMMITX Q TIUCOMM
RELEASE(TIUTYP) ; Get Release Action, support inheritance
N TIUREL,TIUDAD
S TIUREL=$G(^TIU(8925.1,+TIUTYP,4.2))
I TIUREL]"" G RELEASX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIUREL=$$RELEASE(TIUDAD)
RELEASX Q TIUREL
VERIFY(TIUTYP) ; Get Verification action, support inheritance
N TIUVER,TIUDAD
S TIUVER=$G(^TIU(8925.1,+TIUTYP,4.3))
I TIUVER]"" G VERIFYX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIUVER=$$VERIFY(TIUDAD)
VERIFYX Q TIUVER
DELETE(TIUTYP) ; Get Delete Action, support inheritance
N TIUDEL,TIUDAD
S TIUDEL=$G(^TIU(8925.1,+TIUTYP,4.4))
I TIUDEL]"" G DELETEX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIUDEL=$$DELETE(TIUDAD)
DELETEX Q TIUDEL
REASSIGN(TIUTYP) ; Get Package Reassign Action, support inheritance
N TIUREASS,TIUDAD
S TIUREASS=$G(^TIU(8925.1,+TIUTYP,4.45))
I TIUREASS]"" G REASSIX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIUREASS=$$REASSIGN(TIUDAD)
REASSIX Q TIUREASS
ONBROWSE(TIUTYP) ; Get OnBrowse Event, support inheritance
N TIUBRWS,TIUDAD
S TIUBRWS=$G(^TIU(8925.1,+TIUTYP,6.5))
I TIUBRWS]"" G ONBRWSX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIUBRWS=$$ONBROWSE(TIUDAD)
ONBRWSX Q TIUBRWS
ONRTRCT(TIUTYP) ; Get OnRetract Event, support inheritance
N TIURTRCT,TIUDAD
S TIURTRCT=$G(^TIU(8925.1,+TIUTYP,6.51))
I TIURTRCT]"" G ONRTRX
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD S TIURTRCT=$$ONRTRCT(TIUDAD)
ONRTRX Q TIURTRCT
DIVISION(TIULOC) ; Get Division
; Input -- TIULOC HOSPITAL LOCATION file (#44) IEN
; Output -- TIUIN INSTITUTION file (#4) IEN^
; INSTITUTION file (#4) NAME
N TIUDVHL,TIUSTN,TIUIN
S TIUDVHL=$P($G(^SC(+TIULOC,0)),U,15)
I +TIUDVHL D
. S TIUSTN=$$SITE^VASITE(,TIUDVHL)
. I $P(TIUSTN,U)>0,($P(TIUSTN,U,2)]"") D
. . S TIUIN=$P(TIUSTN,U)_U_$P(TIUSTN,U,2)
I '$G(TIUIN) D
. S TIUIN=+$G(DUZ(2))_U_$P($$NS^XUAF4(+$G(DUZ(2))),U)
Q TIUIN
TIULC1 ; SLC/JER - More computational functions ;11/01/03
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**3,4,40,49,100,131,113,112**;Jun 20, 1997
+2 ; External References
+3 ; DBIA 2324 $$ISA^USRLM
+4 ; Any patch which makes ANY changes to this rtn must include a
+5 ;note in the patch desc reminding sites to update the Imaging
+6 ;Gateway. See IA # 3622.
+7 ; IN ADDITION, if changes are made to components used by Imaging,
+8 ;namely PNAME, backward compatibility may not be enough. If
+9 ;changes call additional rtns, TIU should consult with Imaging
+10 ;on need to add additional rtns to list of TIU rtns copied for
+11 ;Imaging Gateway.
+12 ; ****
+13 ;
ENCRYPT(X,X1,X2) ; Encrypt Text Strings
+1 DO EN^XUSHSHP
+2 QUIT X
DECRYPT(X,X1,X2) ; Decrypt Text Strings
+1 DO DE^XUSHSHP
+2 QUIT X
WHOSIGNS(DA) ; Evaluate who should be the expected signer
+1 NEW Y,TIU12
+2 SET TIU12=$GET(^TIU(8925,+DA,12))
+3 IF $PIECE(TIU12,U,2)'=$PIECE(TIU12,U,9)
SET Y=$PIECE(TIU12,U,2)
+4 IF '$TEST
SET Y=$PIECE(TIU12,U,9)
+5 QUIT Y
WHOCOSIG(DA) ; Evaluate who should be the expected cosigner
+1 NEW Y,TIU12
+2 SET TIU12=$GET(^TIU(8925,+DA,12))
+3 IF $PIECE(TIU12,U,2)=$PIECE(TIU12,U,9)
Begin DoDot:1
+4 IF $PIECE(TIU12,U,8)]""
SET Y="@"
+5 IF '$TEST
SET Y=""
End DoDot:1
+6 IF '$TEST
SET Y=$PIECE(TIU12,U,9)
+7 QUIT Y
+8 ;
HASADDEN(DA,IDKIDFLG) ; Evaluate whether a given record has addenda
+1 ; **100**:
+2 ; If +IDKIDFLG, check interdisciplinary kids of DA, as well as DA.
+3 NEW TIUI,TIUY,TIUJ,TIUK
+4 SET (TIUI,TIUJ,TIUY)=0
+5 FOR
SET TIUI=$ORDER(^TIU(8925,"DAD",+DA,TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^TIU(8925.1,+$GET(^TIU(8925,+TIUI,0)),0)),U)["ADDENDUM"
SET TIUY=1
End DoDot:1
IF TIUY
QUIT
+7 IF TIUY!'$GET(IDKIDFLG)
GOTO HASX
+8 ;**100** Check ID kids for addenda:
+9 FOR
SET TIUJ=$ORDER(^TIU(8925,"GDAD",+DA,TIUJ))
IF +TIUJ'>0
QUIT
Begin DoDot:1
+10 SET TIUK=0
+11 FOR
SET TIUK=$ORDER(^TIU(8925,"DAD",TIUJ,TIUK))
IF +TIUK'>0
QUIT
Begin DoDot:2
+12 IF $PIECE($GET(^TIU(8925.1,+$GET(^TIU(8925,+TIUK,0)),0)),U)["ADDENDUM"
SET TIUY=1
End DoDot:2
IF TIUY
QUIT
End DoDot:1
IF TIUY
QUIT
HASX QUIT TIUY
+1 ;
ISADDNDM(DA) ; Evaluate whether a given record IS an addendum
+1 NEW TIUY
SET TIUY=0
+2 IF $PIECE($GET(^TIU(8925.1,+$GET(^TIU(8925,+DA,0)),0)),U)["ADDENDUM"
IF +$PIECE($GET(^TIU(8925,+DA,0)),U,6)>0
SET TIUY=1
+3 QUIT TIUY
PNAME(DA) ; Receives pointer to 8925.1, returns display name of
+1 ; document class
+2 NEW TIUY,TIUMOM
SET TIUMOM=0
+3 IF +$GET(DA)'>0
QUIT "UNKNOWN"
+4 SET TIUMOM=$ORDER(^TIU(8925.1,"AD",DA,TIUMOM))
+5 IF $PIECE($GET(^TIU(8925.1,+DA,0)),U,4)="CO"
SET TIUMOM=0
+6 IF +$PIECE($GET(^TIU(8925.1,+DA,0)),U,9)=0
SET TIUMOM=0
+7 IF +TIUMOM>0
Begin DoDot:1
+8 SET TIUY=$PIECE($GET(^TIU(8925.1,+TIUMOM,0)),U,3)
+9 IF TIUY']""
SET TIUY=$$MIXED^TIULS($PIECE($GET(^TIU(8925.1,+TIUMOM,0)),U))
End DoDot:1
+10 IF +TIUMOM'>0
Begin DoDot:1
+11 SET TIUY=$PIECE($GET(^TIU(8925.1,+DA,0)),U,3)
+12 IF TIUY']""
SET TIUY=$$MIXED^TIULS($PIECE($GET(^TIU(8925.1,+DA,0)),U))
End DoDot:1
+13 QUIT TIUY
ABBREV(DA) ; Get abbreviaton for a document type or class
+1 QUIT $PIECE($GET(^TIU(8925.1,+DA,0)),U,2)
PERSNAME(USER) ; Receives pointer to 200, returns name field
+1 NEW X
SET X=$$GET1^DIQ(200,USER,.01)
+2 QUIT $SELECT($LENGTH(X):X,1:"UNKNOWN")
BEEP(USER) ; Get beeper #'s
+1 QUIT $PIECE($GET(^VA(200,+USER,.13)),U,7,8)
DOCPRM(TIUTYP,TIUDPRM,TIUDA) ; Get Document Parameters, support inheritance
+1 NEW TIUI,TIUDAD
+2 SET (TIUDPRM(0),TIUDPRM(5))=""
+3 IF $PIECE($GET(^TIU(8925.1,+TIUTYP,0)),U)["ADDENDUM"
IF +$GET(TIUDA)
SET TIUTYP=+$GET(^TIU(8925,+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,6),0))
+4 SET TIUI=+$ORDER(^TIU(8925.95,"B",+TIUTYP,0))
+5 IF +TIUI
Begin DoDot:1
+6 SET TIUDPRM(0)=$GET(^TIU(8925.95,+TIUI,0))
+7 IF +$ORDER(^TIU(8925.95,+TIUI,5,0))
Begin DoDot:2
+8 NEW TIUJ
SET TIUJ=0
+9 FOR
SET TIUJ=$ORDER(^TIU(8925.95,+TIUI,5,TIUJ))
IF +TIUJ'>0
QUIT
Begin DoDot:3
+10 SET $PIECE(TIUDPRM(5),U,TIUJ)=+$GET(^TIU(8925.95,+TIUI,5,+TIUJ,0))
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+11 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+12 IF +TIUDAD
DO DOCPRM(TIUDAD,.TIUDPRM)
+13 QUIT
POSTFILE(TIUTYP) ; Get Post-filing Code, support inheritance
+1 NEW TIUPOST,TIUDAD
+2 SET TIUPOST=$GET(^TIU(8925.1,+TIUTYP,4.5))
+3 IF TIUPOST]""
GOTO POSTFILX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIUPOST=$$POSTFILE(TIUDAD)
POSTFILX QUIT TIUPOST
FIXCODE(TIUTYP) ; Get Error Resolution Code, support inheritance
+1 NEW TIUFIX,TIUDAD
+2 SET TIUFIX=$GET(^TIU(8925.1,+TIUTYP,4.8))
+3 IF TIUFIX]""
GOTO FIXCODX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 ; Don't inherit PN code for consults: TIU*1*131
+6 IF +TIUTYP=$$CLASS^TIUCNSLT
IF TIUDAD=3
GOTO FIXCODX
+7 IF +TIUDAD
SET TIUFIX=$$FIXCODE(TIUDAD)
FIXCODX QUIT TIUFIX
DOCCLASS(TIUTYP) ; Given a document type, find its parent document class
+1 QUIT +$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
CLINDOC(TIUTYP,TIUDA) ; Given a document type, find the Clinical Document
+1 ; subclass to which it belongs
+2 NEW TIUI,TIUY
SET (TIUI,TIUY)=0
+3 IF +$GET(TIUDA)
IF +$$ISADDNDM(TIUDA)
SET TIUTYP=+$GET(^TIU(8925,+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,6),0))
+4 SET TIUI=$ORDER(^TIU(8925.1,"AD",+TIUTYP,TIUI))
+5 IF +TIUI'>0
GOTO CLINDOX
+6 IF TIUI=38
SET TIUY=TIUTYP
+7 IF TIUI'=38
SET TIUY=$$CLINDOC(TIUI)
CLINDOX QUIT TIUY
REQVER(TIUTYP,TIUDA) ; Does a given document type require verification
+1 NEW TIUDPRM,TIUY
+2 IF +$GET(TIUDA)
IF +$$ISADDNDM(TIUDA)
SET TIUTYP=+$GET(^TIU(8925,+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,6),0))
+3 DO DOCPRM(TIUTYP,.TIUDPRM)
+4 IF +$PIECE($GET(TIUDPRM(0)),U,3)
SET TIUY=1
+5 QUIT +$GET(TIUY)
REFDATE(TIU,TIUDICDT) ; Identify Reference date
+1 NEW TIURDT
+2 IF +$GET(TIU("LDT"))
SET TIURDT=+$GET(TIU("LDT"))_"^0"
+3 IF +$GET(TIU("LDT"))'>0
Begin DoDot:1
+4 SET TIURDT=$SELECT(+$GET(TIUDICDT):+$GET(TIUDICDT),1:+$$NOW^TIULC)_"^1"
+5 SET TIU("LDT")=TIURDT_U_$$DATE^TIULS(TIURDT,"AMTH DD, CCYY@HR:MIN:SEC")
End DoDot:1
+6 QUIT TIURDT
WHATMPL(USER) ; What List Template should a given user get?
+1 NEW TIUY
+2 IF +$$ISA^USRLM(USER,"PROVIDER")
SET TIUY="TIU BROWSE FOR CLINICIAN"
GOTO WHAX
+3 IF +$$ISA^USRLM(USER,"MEDICAL RECORDS TECHNICIAN")
SET TIUY="TIU BROWSE FOR MRT"
GOTO WHAX
+4 IF +$$ISA^USRLM(USER,"CHIEF, MIS")
SET TIUY="TIU BROWSE FOR MGR"
GOTO WHAX
+5 IF +$$ISA^USRLM(USER,"MEDICAL STUDENT")
SET TIUY="TIU BROWSE FOR CLINICIAN"
GOTO WHAX
+6 SET TIUY="TIU BROWSE FOR READ ONLY"
WHAX QUIT TIUY
SUPPVSIT(TIUTYP) ; Evaluate whether to suppress visit matching
+1 NEW TIUI,TIUY
SET TIUY=0
+2 IF +$PIECE($GET(^TIU(8925.1,+TIUTYP,3)),U,3)
SET TIUY=1
GOTO SUPPVSIX
+3 ; ** SLC/JER - NOIS NYC-1298-11472
IF $LENGTH($PIECE($GET(^TIU(8925.1,+TIUTYP,3)),U,3))
IF ($PIECE($GET(^(3)),U,3)=0)
SET TIUY=0
GOTO SUPPVSIX
+4 SET TIUI=0
FOR
SET TIUI=$ORDER(^TIU(8925.1,"AD",+TIUTYP,TIUI))
IF +TIUI'>0!(+TIUY>0)
QUIT
Begin DoDot:1
+5 SET TIUY=+$$SUPPVSIT(+TIUI)
End DoDot:1
SUPPVSIX QUIT TIUY
PTNAME(DFN) ; Resolve Patient Name
+1 NEW TIUY
SET TIUY=$PIECE($GET(^DPT(DFN,0)),U)
+2 IF TIUY']""
SET TIUY="NAME UNKNOWN"
+3 QUIT TIUY
POSTSIGN(TIUTYP) ; Get Post-Signature Code, support inheritance
+1 NEW TIUPOST,TIUDAD
+2 SET TIUPOST=$GET(^TIU(8925.1,+TIUTYP,4.9))
+3 IF TIUPOST]""
GOTO POSTSIGX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIUPOST=$$POSTSIGN(TIUDAD)
POSTSIGX QUIT TIUPOST
COMMIT(TIUTYP) ; Get Commitment action, support inheritance
+1 NEW TIUCOMM,TIUDAD
+2 SET TIUCOMM=$GET(^TIU(8925.1,+TIUTYP,4.1))
+3 IF TIUCOMM]""
GOTO COMMITX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIUCOMM=$$COMMIT(TIUDAD)
COMMITX QUIT TIUCOMM
RELEASE(TIUTYP) ; Get Release Action, support inheritance
+1 NEW TIUREL,TIUDAD
+2 SET TIUREL=$GET(^TIU(8925.1,+TIUTYP,4.2))
+3 IF TIUREL]""
GOTO RELEASX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIUREL=$$RELEASE(TIUDAD)
RELEASX QUIT TIUREL
VERIFY(TIUTYP) ; Get Verification action, support inheritance
+1 NEW TIUVER,TIUDAD
+2 SET TIUVER=$GET(^TIU(8925.1,+TIUTYP,4.3))
+3 IF TIUVER]""
GOTO VERIFYX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIUVER=$$VERIFY(TIUDAD)
VERIFYX QUIT TIUVER
DELETE(TIUTYP) ; Get Delete Action, support inheritance
+1 NEW TIUDEL,TIUDAD
+2 SET TIUDEL=$GET(^TIU(8925.1,+TIUTYP,4.4))
+3 IF TIUDEL]""
GOTO DELETEX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIUDEL=$$DELETE(TIUDAD)
DELETEX QUIT TIUDEL
REASSIGN(TIUTYP) ; Get Package Reassign Action, support inheritance
+1 NEW TIUREASS,TIUDAD
+2 SET TIUREASS=$GET(^TIU(8925.1,+TIUTYP,4.45))
+3 IF TIUREASS]""
GOTO REASSIX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIUREASS=$$REASSIGN(TIUDAD)
REASSIX QUIT TIUREASS
ONBROWSE(TIUTYP) ; Get OnBrowse Event, support inheritance
+1 NEW TIUBRWS,TIUDAD
+2 SET TIUBRWS=$GET(^TIU(8925.1,+TIUTYP,6.5))
+3 IF TIUBRWS]""
GOTO ONBRWSX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIUBRWS=$$ONBROWSE(TIUDAD)
ONBRWSX QUIT TIUBRWS
ONRTRCT(TIUTYP) ; Get OnRetract Event, support inheritance
+1 NEW TIURTRCT,TIUDAD
+2 SET TIURTRCT=$GET(^TIU(8925.1,+TIUTYP,6.51))
+3 IF TIURTRCT]""
GOTO ONRTRX
+4 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+5 IF +TIUDAD
SET TIURTRCT=$$ONRTRCT(TIUDAD)
ONRTRX QUIT TIURTRCT
DIVISION(TIULOC) ; Get Division
+1 ; Input -- TIULOC HOSPITAL LOCATION file (#44) IEN
+2 ; Output -- TIUIN INSTITUTION file (#4) IEN^
+3 ; INSTITUTION file (#4) NAME
+4 NEW TIUDVHL,TIUSTN,TIUIN
+5 SET TIUDVHL=$PIECE($GET(^SC(+TIULOC,0)),U,15)
+6 IF +TIUDVHL
Begin DoDot:1
+7 SET TIUSTN=$$SITE^VASITE(,TIUDVHL)
+8 IF $PIECE(TIUSTN,U)>0
IF ($PIECE(TIUSTN,U,2)]"")
Begin DoDot:2
+9 SET TIUIN=$PIECE(TIUSTN,U)_U_$PIECE(TIUSTN,U,2)
End DoDot:2
End DoDot:1
+10 IF '$GET(TIUIN)
Begin DoDot:1
+11 SET TIUIN=+$GET(DUZ(2))_U_$PIECE($$NS^XUAF4(+$GET(DUZ(2))),U)
End DoDot:1
+12 QUIT TIUIN
