TIULX ; SLC/JER - CROSS-REFERENCE LIBRARY FUNCTIONS ;03/07/23 12:32
;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136,219,255,326,355**;Jun 20, 1997;Build 11
;Per VHA Directive 2004-038, this routine should not be modified
;
; External reference to File ^VA supported by IA 10060
; External reference to ^ORD(101 supported by IA 872
; External reference to ^DISV supported by IA 510
;
Q
ALOCP(DA) ; Should record be included in daily print queue by location?
; Receives DA = record # in 8925
Q +$$ISPN(+$G(^TIU(8925,+DA,0)))
APTP(DA) ; Should record be included in daily print queue by patient?
; Receives DA = record # in 8925
Q +$$ISPN(+$G(^TIU(8925,+DA,0)))
AAUP(DA) ; Should record be included in daily print queue by author?
; Receives DA = record # in 8925
Q +$$ISPN(+$G(^TIU(8925,+DA,0)))
BELONGS(TIUDA,CLASS) ; Evaluate whether a given document belongs to a
; particular document class
N TIUY
I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA=+$P($G(^TIU(8925,+TIUDA,0)),U,6)
S TIUY=+$$ISA(+$G(^TIU(8925,+TIUDA,0)),CLASS)
Q TIUY
ISA(DA,CLASS) ; Evaluate whether a given document type is a member of a
; particular document class
; Receives DA = record # in 8925.1, and
; CLASS = record # of class in 8925.1
N TIUI,TIUY S (TIUI,TIUY)=0
F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D
. I TIUI=CLASS S TIUY=1 Q
. S TIUY=$$ISA(TIUI,CLASS)
Q TIUY
ISPN(DA) ; Evaluate whether a given document is a Progress Note
; Receives DA = record # in 8925.1
N TIUI,TIUY S (TIUI,TIUY)=0
F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D
. I TIUI=3 S TIUY=1 Q
. S TIUY=$$ISPN(TIUI)
Q TIUY
ISCWAD(DA) ; Evaluate whether a given title is a CWAD
;Is the given title in a CWAD document class?
;New for ID notes
; Receives DA = record # in 8925.1
Q $S($$ISA(DA,25):1,$$ISA(DA,27):1,$$ISA(DA,30):1,$$ISA(DA,31):1,1:0)
ISDS(DA) ; Evaluate whether a given document is a Discharge Summary
; Receives DA = record # in 8925.1
N TIUI,TIUY S (TIUI,TIUY)=0
F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D
. I TIUI=244 S TIUY=1 Q
. S TIUY=$$ISDS(TIUI)
Q TIUY
TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field
N XFORM
S FLD=$O(^TIU(8925.1,+RTYPE("TYPE"),"HEAD","D",+FLD,0))
I +FLD'>0 G TRNSFRMX
S XFORM=$G(^TIU(8925.1,+RTYPE("TYPE"),"HEAD",+FLD,1))
I XFORM']"" G TRNSFRMX
X XFORM
TRNSFRMX Q X
N TIUI,TIUPREF S TIUPREF=$$PERSPRF^TIULE(DUZ),TIUI=0
F S TIUI=$O(^DISV(DUZ,"VALMMENU",TIUI)) Q:+TIUI'>0 D
. I $P($G(^ORD(101,+TIUI,0)),U)["TIU" S ^DISV(DUZ,"VALMMENU",TIUI)=$S($P(TIUPREF,U,5)=0:0,1:1)
Q
XTRASIGN(TIUY,TIUDA) ; Get list of extra signers for a document
N TIUI,TIUJ,TIUL,DA,DR,DIC,DIQ,TIUXTRA S (TIUI,TIUJ,TIUL)=0
S DIC="^TIU(8925.7,",DIQ="TIUXTRA"
F S TIUI=$O(^TIU(8925.7,"B",TIUDA,TIUI)) Q:+TIUI'>0 D
. N TIUX,TIUSGNR
. S DA=TIUI,DR=".03;.04" D EN^DIQ1 Q:+$D(TIUXTRA)'>9
. I $L($G(TIUXTRA(8925.7,DA,.04))) Q
. S TIUJ=+$G(TIUJ)+1,TIUL=+$G(TIUL)+1
. S TIUSGNR=$G(TIUXTRA(8925.7,DA,.03))
. S TIUX=$$SETSTR^VALM1($G(TIUJ)_") "_TIUSGNR,$G(TIUX),1,39)
. S TIUY(TIUL)=DA_U_TIUX
Q
ASKSIGN(TIUY) ; Identify which Signature to edit
N I,L,Y
W !!,"Please Indicate Which Expected Signer to Change:",!
S (I,L,Y)=0 F S I=$O(TIUY(I)) Q:+I'>0!+Y D
. W:$P(TIUY(I),U)]"" !,$P(TIUY(I),U,2)
. I I#20=0 S Y=$P($$PICK(1,I,"Select Signer","NO"),U)
. S L=I
I L#20,'+Y S Y=$P($$PICK(1,L,"Select Signer","NO"),U)
I +Y,+$G(TIUY(+Y)) S Y=+$G(TIUY(+Y))
Q Y
PICK(LOW,HIGH,PROMPT,TYPE) ; List selection
N X,Y S PROMPT=$G(PROMPT,"Select Item"),TYPE=$G(TYPE,"LO")
W !
S Y=$$READ^TIUU(TYPE_U_LOW_":"_HIGH,PROMPT)
W !
Q Y
CWAD ; Entry action for CWAD protocol
N GMRPALG,GMRPCWAD,GMRPDFN,GMRPOPT,GMRPEN,GMRPAGE,GMRPCWAD,GMRPDOB
N GMRPLOC,GMRPRB,GMRPSSN,GMRPQT
I $G(TIUGLINK) W !,"Please finish attaching the interdisciplinay note before displaying alerts.",! H 3 Q
D FULL^VALM1
I '+$G(DFN),'+$G(ORVP) D Q
. W !!,"No Patient Selected...",!
. I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
. S VALMBCK="R"
D PAT^GMRPNOR1 I $D(GMRPQT) S VALMBCK="R" Q
S Y=GMRPDFN,GMRPOPT=1,GMRPEN=1 W !!,"** Current Patient: "_$P(Y,U,2)
D ENPAT^GMRPNCW S VALMBCK="R"
Q
IDSIGNRS(TIUY,TIUDA,LIST) ; add/remove additional signers (#8925.7) ajb *355
; .TIUY return location, pass by reference
; TIUDA document IEN from #8925
; LIST(#) IEN^name^[REMOVE]
N D0,FDA,I,TIUPRM0,TIUPRM1 S I=0 F S I=$O(LIST(I)) Q:'+I D
. N ENTRY,USER S USER=+LIST(I),ENTRY=+$O(^TIU(8925.7,"AE",TIUDA,USER,0))
. N NODE0 S NODE0=$S(+ENTRY:$G(^TIU(8925.7,ENTRY,0)),1:"")
. I +ENTRY,+$P(NODE0,U,4)!($P(LIST(I),U,3)'="REMOVE") Q ; user already signed or previously added
. I $P(LIST(I),U,3)="REMOVE" D REMSIGNR(TIUDA,USER) Q ; remove user from #8925.7
. N FDA S FDA(8925.7,"+1,",.01)=TIUDA
. S FDA(8925.7,"+1,",.02)=0
. S FDA(8925.7,"+1,",.03)=USER
. D UPDATE^DIE("","FDA") ; add new entry
. S TIUY=$G(TIUY)_$S($G(TIUY)'="":U,1:"")_+LIST(I)
I $O(LIST(0)) D SEND^TIUALRT(TIUDA) ; update alert
Q
REMSIGNR(TIUDA,TIUDUZ) ; remove user from TIU MULTIPLE SIGNATURE (#8925.7)
N %,D,D0,DA,DI,DIC,DIDEL,DIE,DR,X,Y
S DA=+$O(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0)) Q:+DA'>0
K ^TIU(8925.7,"AC",+$G(^TIU(8925,TIUDA,12),U),TIUDA,DA) ; remove "AC" index
S (DIDEL,DIE)=8925.7,DR=".01///@" D ^DIE
Q
GETSIGNR(TIUY,TIUDA) ; RPC to Get list of extra signers for a document
N TIUI,DA,DR,DIC,DIQ,TIUXTRA,TIUD12,TIUAU,TIUEC S (DA,TIUI)=0
S DIC="^TIU(8925.7,",DIQ="TIUXTRA"
F S DA=$O(^TIU(8925.7,"B",TIUDA,DA)) Q:+DA'>0 D
. N TIUX,TIUSGNR
. S DR=".03;.04",DIQ(0)="IE" D EN^DIQ1 Q:+$D(TIUXTRA)'>9
. I +$G(TIUXTRA(8925.7,DA,.04,"I")) Q
. S TIUI=+$G(TIUI)+1
. S TIUY(TIUI)=$G(TIUXTRA(8925.7,DA,.03,"I"))_U_$G(TIUXTRA(8925.7,DA,.03,"E"))
S TIUD12=$G(^TIU(8925,TIUDA,12))
S TIUAU=$P(TIUD12,U,4),TIUEC=$P(TIUD12,U,8)
S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUAU_U_$$PERSNAME^TIULC1(TIUAU)_U_"AUTHOR"
I +TIUEC'>0 Q
I '$$FIND1^DIC(200,"","","`"_+TIUEC) D CLEAN^DILF Q
S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUEC_U_$$PERSNAME^TIULC1(TIUEC)_U_"EXPECTED COSIGNER"
Q
HASDS(DFN,VSTR) ; Does an admission have a Discharge Summary?
N TITLE,TIUDA S (TIUDA,TITLE)=0
F S TITLE=$O(^TIU(8925,"APTLD",DFN,TITLE)) Q:+TITLE'>0 D Q:+TIUDA>0
. N STATUS,CONTEXT S TIUDA=0
. I '+$$ISDS(TITLE) S TIUDA=0_U_0 Q
. F S TIUDA=$O(^TIU(8925,"APTLD",DFN,TITLE,VSTR,+TIUDA)) Q:+TIUDA'>0 D Q:+$P(TIUDA,U,2)
. . S STATUS=+$P($G(^TIU(8925,+TIUDA,0)),U,5)
. . S CONTEXT=$S(STATUS=0:0,STATUS>13:0,STATUS'>5:2,1:1)
. . S TIUDA=TIUDA_U_CONTEXT
I '+TIUDA,($L(TIUDA,U)<2) S TIUDA=TIUDA_U_0
Q TIUDA
NEEDSIG(TIUY,USER,CLASS) ; Get list of documents for which USER is an additional signer
N TIUDA,TIUI,TIUJ S (TIUDA,TIUJ)=0
S USER=$G(USER,DUZ),CLASS=$G(CLASS,38),TIUY=$NA(^TMP("TIUSIGN",$J))
K @TIUY ; Clear out return array before query
F S TIUDA=$O(^TIU(8925.7,"AES",USER,TIUDA)) Q:+TIUDA'>0 D
. S TIUI=0 F S TIUI=$O(^TIU(8925.7,"AES",USER,TIUDA,TIUI)) Q:+TIUI'>0 D
. . N TIUD0 S TIUD0=$G(^TIU(8925.7,TIUI,0)) Q:+$P(TIUD0,U,4)
. . Q:'+$$ISA(+$G(^TIU(8925,TIUDA,0)),CLASS)
. . S TIUJ=+$G(TIUJ)+1,@TIUY@(TIUJ)=TIUDA
Q
TITLIENS ; Get IENs of DDEF entries that have type Title
; in Document Definition file 8925.1
;Creates array ^TMP("TIUTLS,$J,TLIEN)=
;Caller must kill ^TMP("TIUTLS",$J) when finished with the global.
N TIUIDX S TIUIDX=0 K ^TMP("TIUTLS",$J)
F S TIUIDX=$O(^TIU(8925.1,"AT","DOC",TIUIDX)) Q:TIUIDX'>0 D
. S ^TMP("TIUTLS",$J,TIUIDX)=""
Q
HASDOCMT(DFN) ;Does patient have ANY entries in TIU DOCUMENT file 8925?
;Any entries includes original documents, addenda, components
;(like S in SOAP notes), "deleted" documents, retracted documents, etc!
Q $O(^TIU(8925,"C",+$G(DFN),0))>0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULX 7912 printed Apr 09, 2024@21:45:17 Page 2
TIULX ; SLC/JER - CROSS-REFERENCE LIBRARY FUNCTIONS ;03/07/23 12:32
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136,219,255,326,355**;Jun 20, 1997;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
+4 ; External reference to File ^VA supported by IA 10060
+5 ; External reference to ^ORD(101 supported by IA 872
+6 ; External reference to ^DISV supported by IA 510
+7 ;
+8 QUIT
ALOCP(DA) ; Should record be included in daily print queue by location?
+1 ; Receives DA = record # in 8925
+2 QUIT +$$ISPN(+$GET(^TIU(8925,+DA,0)))
APTP(DA) ; Should record be included in daily print queue by patient?
+1 ; Receives DA = record # in 8925
+2 QUIT +$$ISPN(+$GET(^TIU(8925,+DA,0)))
AAUP(DA) ; Should record be included in daily print queue by author?
+1 ; Receives DA = record # in 8925
+2 QUIT +$$ISPN(+$GET(^TIU(8925,+DA,0)))
BELONGS(TIUDA,CLASS) ; Evaluate whether a given document belongs to a
+1 ; particular document class
+2 NEW TIUY
+3 IF +$$ISADDNDM^TIULC1(TIUDA)
SET TIUDA=+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,6)
+4 SET TIUY=+$$ISA(+$GET(^TIU(8925,+TIUDA,0)),CLASS)
+5 QUIT TIUY
ISA(DA,CLASS) ; Evaluate whether a given document type is a member of a
+1 ; particular document class
+2 ; Receives DA = record # in 8925.1, and
+3 ; CLASS = record # of class in 8925.1
+4 NEW TIUI,TIUY
SET (TIUI,TIUY)=0
+5 FOR
SET TIUI=$ORDER(^TIU(8925.1,"AD",DA,TIUI))
if +TIUI'>0!(TIUY=1)
QUIT
Begin DoDot:1
+6 IF TIUI=CLASS
SET TIUY=1
QUIT
+7 SET TIUY=$$ISA(TIUI,CLASS)
End DoDot:1
+8 QUIT TIUY
ISPN(DA) ; Evaluate whether a given document is a Progress Note
+1 ; Receives DA = record # in 8925.1
+2 NEW TIUI,TIUY
SET (TIUI,TIUY)=0
+3 FOR
SET TIUI=$ORDER(^TIU(8925.1,"AD",DA,TIUI))
if +TIUI'>0!(TIUY=1)
QUIT
Begin DoDot:1
+4 IF TIUI=3
SET TIUY=1
QUIT
+5 SET TIUY=$$ISPN(TIUI)
End DoDot:1
+6 QUIT TIUY
ISCWAD(DA) ; Evaluate whether a given title is a CWAD
+1 ;Is the given title in a CWAD document class?
+2 ;New for ID notes
+3 ; Receives DA = record # in 8925.1
+4 QUIT $SELECT($$ISA(DA,25):1,$$ISA(DA,27):1,$$ISA(DA,30):1,$$ISA(DA,31):1,1:0)
ISDS(DA) ; Evaluate whether a given document is a Discharge Summary
+1 ; Receives DA = record # in 8925.1
+2 NEW TIUI,TIUY
SET (TIUI,TIUY)=0
+3 FOR
SET TIUI=$ORDER(^TIU(8925.1,"AD",DA,TIUI))
if +TIUI'>0!(TIUY=1)
QUIT
Begin DoDot:1
+4 IF TIUI=244
SET TIUY=1
QUIT
+5 SET TIUY=$$ISDS(TIUI)
End DoDot:1
+6 QUIT TIUY
TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field
+1 NEW XFORM
+2 SET FLD=$ORDER(^TIU(8925.1,+RTYPE("TYPE"),"HEAD","D",+FLD,0))
+3 IF +FLD'>0
GOTO TRNSFRMX
+4 SET XFORM=$GET(^TIU(8925.1,+RTYPE("TYPE"),"HEAD",+FLD,1))
+5 IF XFORM']""
GOTO TRNSFRMX
+6 XECUTE XFORM
TRNSFRMX QUIT X
+1 NEW TIUI,TIUPREF
SET TIUPREF=$$PERSPRF^TIULE(DUZ)
SET TIUI=0
+2 FOR
SET TIUI=$ORDER(^DISV(DUZ,"VALMMENU",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^ORD(101,+TIUI,0)),U)["TIU"
SET ^DISV(DUZ,"VALMMENU",TIUI)=$SELECT($PIECE(TIUPREF,U,5)=0:0,1:1)
End DoDot:1
+4 QUIT
XTRASIGN(TIUY,TIUDA) ; Get list of extra signers for a document
+1 NEW TIUI,TIUJ,TIUL,DA,DR,DIC,DIQ,TIUXTRA
SET (TIUI,TIUJ,TIUL)=0
+2 SET DIC="^TIU(8925.7,"
SET DIQ="TIUXTRA"
+3 FOR
SET TIUI=$ORDER(^TIU(8925.7,"B",TIUDA,TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+4 NEW TIUX,TIUSGNR
+5 SET DA=TIUI
SET DR=".03;.04"
DO EN^DIQ1
if +$DATA(TIUXTRA)'>9
QUIT
+6 IF $LENGTH($GET(TIUXTRA(8925.7,DA,.04)))
QUIT
+7 SET TIUJ=+$GET(TIUJ)+1
SET TIUL=+$GET(TIUL)+1
+8 SET TIUSGNR=$GET(TIUXTRA(8925.7,DA,.03))
+9 SET TIUX=$$SETSTR^VALM1($GET(TIUJ)_") "_TIUSGNR,$GET(TIUX),1,39)
+10 SET TIUY(TIUL)=DA_U_TIUX
End DoDot:1
+11 QUIT
ASKSIGN(TIUY) ; Identify which Signature to edit
+1 NEW I,L,Y
+2 WRITE !!,"Please Indicate Which Expected Signer to Change:",!
+3 SET (I,L,Y)=0
FOR
SET I=$ORDER(TIUY(I))
if +I'>0!+Y
QUIT
Begin DoDot:1
+4 if $PIECE(TIUY(I),U)]""
WRITE !,$PIECE(TIUY(I),U,2)
+5 IF I#20=0
SET Y=$PIECE($$PICK(1,I,"Select Signer","NO"),U)
+6 SET L=I
End DoDot:1
+7 IF L#20
IF '+Y
SET Y=$PIECE($$PICK(1,L,"Select Signer","NO"),U)
+8 IF +Y
IF +$GET(TIUY(+Y))
SET Y=+$GET(TIUY(+Y))
+9 QUIT Y
PICK(LOW,HIGH,PROMPT,TYPE) ; List selection
+1 NEW X,Y
SET PROMPT=$GET(PROMPT,"Select Item")
SET TYPE=$GET(TYPE,"LO")
+2 WRITE !
+3 SET Y=$$READ^TIUU(TYPE_U_LOW_":"_HIGH,PROMPT)
+4 WRITE !
+5 QUIT Y
CWAD ; Entry action for CWAD protocol
+1 NEW GMRPALG,GMRPCWAD,GMRPDFN,GMRPOPT,GMRPEN,GMRPAGE,GMRPCWAD,GMRPDOB
+2 NEW GMRPLOC,GMRPRB,GMRPSSN,GMRPQT
+3 IF $GET(TIUGLINK)
WRITE !,"Please finish attaching the interdisciplinay note before displaying alerts.",!
HANG 3
QUIT
+4 DO FULL^VALM1
+5 IF '+$GET(DFN)
IF '+$GET(ORVP)
Begin DoDot:1
+6 WRITE !!,"No Patient Selected...",!
+7 ; pause
IF $$READ^TIUU("EA","Press RETURN to continue...")
+8 SET VALMBCK="R"
End DoDot:1
QUIT
+9 DO PAT^GMRPNOR1
IF $DATA(GMRPQT)
SET VALMBCK="R"
QUIT
+10 SET Y=GMRPDFN
SET GMRPOPT=1
SET GMRPEN=1
WRITE !!,"** Current Patient: "_$PIECE(Y,U,2)
+11 DO ENPAT^GMRPNCW
SET VALMBCK="R"
+12 QUIT
IDSIGNRS(TIUY,TIUDA,LIST) ; add/remove additional signers (#8925.7) ajb *355
+1 ; .TIUY return location, pass by reference
+2 ; TIUDA document IEN from #8925
+3 ; LIST(#) IEN^name^[REMOVE]
+4 NEW D0,FDA,I,TIUPRM0,TIUPRM1
SET I=0
FOR
SET I=$ORDER(LIST(I))
if '+I
QUIT
Begin DoDot:1
+5 NEW ENTRY,USER
SET USER=+LIST(I)
SET ENTRY=+$ORDER(^TIU(8925.7,"AE",TIUDA,USER,0))
+6 NEW NODE0
SET NODE0=$SELECT(+ENTRY:$GET(^TIU(8925.7,ENTRY,0)),1:"")
+7 ; user already signed or previously added
IF +ENTRY
IF +$PIECE(NODE0,U,4)!($PIECE(LIST(I),U,3)'="REMOVE")
QUIT
+8 ; remove user from #8925.7
IF $PIECE(LIST(I),U,3)="REMOVE"
DO REMSIGNR(TIUDA,USER)
QUIT
+9 NEW FDA
SET FDA(8925.7,"+1,",.01)=TIUDA
+10 SET FDA(8925.7,"+1,",.02)=0
+11 SET FDA(8925.7,"+1,",.03)=USER
+12 ; add new entry
DO UPDATE^DIE("","FDA")
+13 SET TIUY=$GET(TIUY)_$SELECT($GET(TIUY)'="":U,1:"")_+LIST(I)
End DoDot:1
+14 ; update alert
IF $ORDER(LIST(0))
DO SEND^TIUALRT(TIUDA)
+15 QUIT
REMSIGNR(TIUDA,TIUDUZ) ; remove user from TIU MULTIPLE SIGNATURE (#8925.7)
+1 NEW %,D,D0,DA,DI,DIC,DIDEL,DIE,DR,X,Y
+2 SET DA=+$ORDER(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0))
if +DA'>0
QUIT
+3 ; remove "AC" index
KILL ^TIU(8925.7,"AC",+$GET(^TIU(8925,TIUDA,12),U),TIUDA,DA)
+4 SET (DIDEL,DIE)=8925.7
SET DR=".01///@"
DO ^DIE
+5 QUIT
GETSIGNR(TIUY,TIUDA) ; RPC to Get list of extra signers for a document
+1 NEW TIUI,DA,DR,DIC,DIQ,TIUXTRA,TIUD12,TIUAU,TIUEC
SET (DA,TIUI)=0
+2 SET DIC="^TIU(8925.7,"
SET DIQ="TIUXTRA"
+3 FOR
SET DA=$ORDER(^TIU(8925.7,"B",TIUDA,DA))
if +DA'>0
QUIT
Begin DoDot:1
+4 NEW TIUX,TIUSGNR
+5 SET DR=".03;.04"
SET DIQ(0)="IE"
DO EN^DIQ1
if +$DATA(TIUXTRA)'>9
QUIT
+6 IF +$GET(TIUXTRA(8925.7,DA,.04,"I"))
QUIT
+7 SET TIUI=+$GET(TIUI)+1
+8 SET TIUY(TIUI)=$GET(TIUXTRA(8925.7,DA,.03,"I"))_U_$GET(TIUXTRA(8925.7,DA,.03,"E"))
End DoDot:1
+9 SET TIUD12=$GET(^TIU(8925,TIUDA,12))
+10 SET TIUAU=$PIECE(TIUD12,U,4)
SET TIUEC=$PIECE(TIUD12,U,8)
+11 SET TIUI=+$GET(TIUI)+1
SET TIUY(TIUI)=TIUAU_U_$$PERSNAME^TIULC1(TIUAU)_U_"AUTHOR"
+12 IF +TIUEC'>0
QUIT
+13 IF '$$FIND1^DIC(200,"","","`"_+TIUEC)
DO CLEAN^DILF
QUIT
+14 SET TIUI=+$GET(TIUI)+1
SET TIUY(TIUI)=TIUEC_U_$$PERSNAME^TIULC1(TIUEC)_U_"EXPECTED COSIGNER"
+15 QUIT
HASDS(DFN,VSTR) ; Does an admission have a Discharge Summary?
+1 NEW TITLE,TIUDA
SET (TIUDA,TITLE)=0
+2 FOR
SET TITLE=$ORDER(^TIU(8925,"APTLD",DFN,TITLE))
if +TITLE'>0
QUIT
Begin DoDot:1
+3 NEW STATUS,CONTEXT
SET TIUDA=0
+4 IF '+$$ISDS(TITLE)
SET TIUDA=0_U_0
QUIT
+5 FOR
SET TIUDA=$ORDER(^TIU(8925,"APTLD",DFN,TITLE,VSTR,+TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:2
+6 SET STATUS=+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,5)
+7 SET CONTEXT=$SELECT(STATUS=0:0,STATUS>13:0,STATUS'>5:2,1:1)
+8 SET TIUDA=TIUDA_U_CONTEXT
End DoDot:2
if +$PIECE(TIUDA,U,2)
QUIT
End DoDot:1
if +TIUDA>0
QUIT
+9 IF '+TIUDA
IF ($LENGTH(TIUDA,U)<2)
SET TIUDA=TIUDA_U_0
+10 QUIT TIUDA
NEEDSIG(TIUY,USER,CLASS) ; Get list of documents for which USER is an additional signer
+1 NEW TIUDA,TIUI,TIUJ
SET (TIUDA,TIUJ)=0
+2 SET USER=$GET(USER,DUZ)
SET CLASS=$GET(CLASS,38)
SET TIUY=$NAME(^TMP("TIUSIGN",$JOB))
+3 ; Clear out return array before query
KILL @TIUY
+4 FOR
SET TIUDA=$ORDER(^TIU(8925.7,"AES",USER,TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:1
+5 SET TIUI=0
FOR
SET TIUI=$ORDER(^TIU(8925.7,"AES",USER,TIUDA,TIUI))
if +TIUI'>0
QUIT
Begin DoDot:2
+6 NEW TIUD0
SET TIUD0=$GET(^TIU(8925.7,TIUI,0))
if +$PIECE(TIUD0,U,4)
QUIT
+7 if '+$$ISA(+$GET(^TIU(8925,TIUDA,0)),CLASS)
QUIT
+8 SET TIUJ=+$GET(TIUJ)+1
SET @TIUY@(TIUJ)=TIUDA
End DoDot:2
End DoDot:1
+9 QUIT
TITLIENS ; Get IENs of DDEF entries that have type Title
+1 ; in Document Definition file 8925.1
+2 ;Creates array ^TMP("TIUTLS,$J,TLIEN)=
+3 ;Caller must kill ^TMP("TIUTLS",$J) when finished with the global.
+4 NEW TIUIDX
SET TIUIDX=0
KILL ^TMP("TIUTLS",$JOB)
+5 FOR
SET TIUIDX=$ORDER(^TIU(8925.1,"AT","DOC",TIUIDX))
if TIUIDX'>0
QUIT
Begin DoDot:1
+6 SET ^TMP("TIUTLS",$JOB,TIUIDX)=""
End DoDot:1
+7 QUIT
HASDOCMT(DFN) ;Does patient have ANY entries in TIU DOCUMENT file 8925?
+1 ;Any entries includes original documents, addenda, components
+2 ;(like S in SOAP notes), "deleted" documents, retracted documents, etc!
+3 QUIT $ORDER(^TIU(8925,"C",+$GET(DFN),0))>0
