- 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 Jan 18, 2025@03:43:38 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