Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIULX

TIULX.m

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