TIULX ; SLC/JER - Cross-reference library functions ; 10/1/10 2:31pm
;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136,219,255**;Jun 20, 1997;Build 2
; File 200 - IA 10060
; ^ORD(101 - IA 872
; ^DISV - IA 510
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,TIULIST) ; Add list of Add'l Signers for a TIU Document
; TIULIST(TIUI) [By Ref] = array of users to add/remove as signers
; TIUDA = IEN in ^TIU(8925,
N TIUI S TIUI=0
F S TIUI=$O(TIULIST(TIUI)) Q:+TIUI'>0 D
. N DA,DIC,DLAYGO,DIE,DR,X,Y
. N TIUSIG,TIUSN ;TIU*1.0*255
. ; if current user is already an additional signer, and current user
. ; is NOT being removed as an additional signer, then QUIT
. I +$O(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0)),($P(TIULIST(TIUI),U,3)'="REMOVE") Q
. ; if current user is being removed as a cosigner, then remove him
. ; TIU*255 Quit if attempting to remove someone who already signed
. ;I $P(TIULIST(TIUI),U,3)="REMOVE" D REMSIGNR(TIUDA,+TIULIST(TIUI)) Q
. S TIUSIG=$O(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0)) S:$G(TIUSIG) TIUSN=$P($G(^TIU(8925.7,TIUSIG,0)),"^",4)
. Q:$G(TIUSN) I $P(TIULIST(TIUI),U,3)="REMOVE" D REMSIGNR(TIUDA,+TIULIST(TIUI)) Q
. ; otherwise, add the current user as an additional signer
. S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.7,DIC(0)="LX" D ^DIC Q:+Y'>0
. S DIE=DIC,TIUY=$G(TIUY)_$S($G(TIUY)]"":U,1:"")_+TIULIST(TIUI)
. S DR=".02////"_0_";.03////"_+$G(TIULIST(TIUI))
. D ^DIE
. D SEND^TIUALRT(TIUDA)
Q
REMSIGNR(TIUDA,TIUDUZ) ; Remove user from additional signer list
N DA,DIE,DR,DIDEL
S DA=+$O(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0)) Q:+DA'>0
S (DIDEL,DIE)=8925.7,DR=".01///@" D ^DIE
D SEND^TIUALRT(TIUDA)
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
TIULX ; SLC/JER - Cross-reference library functions ; 10/1/10 2:31pm
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136,219,255**;Jun 20, 1997;Build 2
+2 ; File 200 - IA 10060
+3 ; ^ORD(101 - IA 872
+4 ; ^DISV - IA 510
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,TIULIST) ; Add list of Add'l Signers for a TIU Document
+1 ; TIULIST(TIUI) [By Ref] = array of users to add/remove as signers
+2 ; TIUDA = IEN in ^TIU(8925,
+3 NEW TIUI
SET TIUI=0
+4 FOR
SET TIUI=$ORDER(TIULIST(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+5 NEW DA,DIC,DLAYGO,DIE,DR,X,Y
+6 ;TIU*1.0*255
NEW TIUSIG,TIUSN
+7 ; if current user is already an additional signer, and current user
+8 ; is NOT being removed as an additional signer, then QUIT
+9 IF +$ORDER(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0))
IF ($PIECE(TIULIST(TIUI),U,3)'="REMOVE")
QUIT
+10 ; if current user is being removed as a cosigner, then remove him
+11 ; TIU*255 Quit if attempting to remove someone who already signed
+12 ;I $P(TIULIST(TIUI),U,3)="REMOVE" D REMSIGNR(TIUDA,+TIULIST(TIUI)) Q
+13 SET TIUSIG=$ORDER(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0))
IF $GET(TIUSIG)
SET TIUSN=$PIECE($GET(^TIU(8925.7,TIUSIG,0)),"^",4)
+14 IF $GET(TIUSN)
QUIT
IF $PIECE(TIULIST(TIUI),U,3)="REMOVE"
DO REMSIGNR(TIUDA,+TIULIST(TIUI))
QUIT
+15 ; otherwise, add the current user as an additional signer
+16 SET X=""""_"`"_TIUDA_""""
SET (DIC,DLAYGO)=8925.7
SET DIC(0)="LX"
DO ^DIC
IF +Y'>0
QUIT
+17 SET DIE=DIC
SET TIUY=$GET(TIUY)_$SELECT($GET(TIUY)]"":U,1:"")_+TIULIST(TIUI)
+18 SET DR=".02////"_0_";.03////"_+$GET(TIULIST(TIUI))
+19 DO ^DIE
+20 DO SEND^TIUALRT(TIUDA)
End DoDot:1
+21 QUIT
REMSIGNR(TIUDA,TIUDUZ) ; Remove user from additional signer list
+1 NEW DA,DIE,DR,DIDEL
+2 SET DA=+$ORDER(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0))
IF +DA'>0
QUIT
+3 SET (DIDEL,DIE)=8925.7
SET DR=".01///@"
DO ^DIE
+4 DO SEND^TIUALRT(TIUDA)
+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
+4
