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

VPRDTIU.m

Go to the documentation of this file.
  1. VPRDTIU ;SLC/MKB -- TIU extract ;8/2/11 15:29
  1. ;;1.0;VIRTUAL PATIENT RECORD;**1,2,4,5,32**;Sep 01, 2011;Build 6
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; External References DBIA#
  1. ; ------------------- -----
  1. ; ^SC( 10040
  1. ; ^TIU(8925.1 2321,5677
  1. ; ^TIU(8926.1 5678
  1. ; ^VA(200 10060
  1. ; DIQ 2056
  1. ; RAO7PC1 2043
  1. ; TIUCNSLT 5546
  1. ; TIUCP 3568
  1. ; TIULQ 2693
  1. ; TIULX 3058
  1. ; TIUSROI 5676
  1. ; TIUSRVLO 2834,2865
  1. ; TIUSRVR1 2944
  1. ; XLFSTR 10104
  1. ;
  1. ; ------------ Get documents from VistA ------------
  1. ;
  1. EN(DFN,BEG,END,MAX,ID) ; -- find patient's documents
  1. N VPRITM,VPRN,VPRX,VPRY,VPRCNT
  1. S DFN=+$G(DFN) Q:$G(DFN)<1
  1. S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
  1. ;
  1. ; get one document
  1. I $L($G(ID)),ID[";" D G ENQ
  1. . I ID D RPT1^VPRDMC(DFN,ID,.VPRITM),XML(.VPRITM) Q ;CP
  1. . D RPT1^VPRDLRA(DFN,ID,.VPRITM),XML(.VPRITM) Q ;Lab
  1. I $G(ID),ID["-" D G ENQ ;Radiology
  1. . S (BEG,END)=9999999.9999-+ID D EN1^RAO7PC1(DFN,BEG,END,"99P")
  1. . D RPT1^VPRDRA(DFN,ID,.VPRITM),XML(.VPRITM)
  1. . K ^TMP($J,"RAE1")
  1. I $G(ID) D EN1(ID,.VPRITM),XML(.VPRITM):$D(VPRITM) G ENQ
  1. ;
  1. ; get all documents
  1. N CLASS,SUBCLASS,TITLE,SERVICE,SUBJECT,NOTSUBJ,STATUS,VPRC,CLS,VPRS,CTXT
  1. D SETUP S VPRCNT=0 ;define search criteria
  1. I CLASS="CP" D RPTS^VPRDMC(DFN,BEG,END,MAX) Q
  1. I CLASS="RA" D RPTS^VPRDRA(DFN,BEG,END,MAX) Q
  1. I CLASS="LR" D RPTS^VPRDLRA(DFN,BEG,END,MAX) Q
  1. F VPRC=1:1:$L(CLASS,U) S CLS=$P(CLASS,U,VPRC) D Q:VPRCNT'<MAX
  1. . F VPRS=1:1:$L(STATUS,U) S CTXT=$P(STATUS,U,VPRS) D Q:VPRCNT'<MAX
  1. .. D CONTEXT^TIUSRVLO(.VPRY,CLS,CTXT,DFN,BEG,END,,,,1)
  1. .. S VPRN=0 F S VPRN=$O(@VPRY@(VPRN)) Q:VPRN<1 D Q:VPRCNT'<MAX
  1. ... S VPRX=$G(@VPRY@(VPRN)) Q:'$$MATCH(VPRX)
  1. ... K VPRITM D EN1(VPRX,.VPRITM) Q:'$D(VPRITM)
  1. ... D XML(.VPRITM) S VPRCNT=VPRCNT+1
  1. .. K @VPRY
  1. ENQ ; end
  1. K ^TMP("VPRTEXT",$J)
  1. Q
  1. ;
  1. EN1(VPRX,DOC) ; -- return a document in DOC("attribute")=value
  1. ; Expects DFN, VPRX=IEN^$$RESOLVE^TIUSRVLO(IEN)
  1. N IEN,X,NAME,VPRTIU,ES,I,VPRY
  1. K DOC,^TMP("VPRTEXT",$J)
  1. S IEN=+$G(VPRX) Q:IEN<1 ;invalid ien
  1. I +VPRX=VPRX D ;get data string, if needed
  1. . N SHOWADD,DA S SHOWADD=1,DA=+VPRX
  1. . S VPRX=DA_U_$$RESOLVE^TIUSRVLO(DA)
  1. Q:"UNKNOWN"[$P($G(VPRX),U,2) ;null or invalid
  1. S NAME=$P(VPRX,U,2) ;I $P(VPRX,U,14),$P(NAME," ")="Addendum" Q
  1. S DOC("id")=IEN,DOC("localTitle")=NAME
  1. D EXTRACT^TIULQ(IEN,"VPRTIU",,".01:.04;1501:1508")
  1. S X=$$GET1^DIQ(8925,IEN_",",".01:1501","I") I X D
  1. . N IENS,TIU,Y,FNUM
  1. . S IENS=X_"," D GETS^DIQ(8926.1,IENS,"*","IE","TIU")
  1. . S DOC("nationalTitle")=$G(TIU(8926.1,IENS,99.99,"E"))_U_$G(TIU(8926.1,IENS,.01,"E"))
  1. . F I=".04^Subject^2",".05^Role^3",".06^Setting^4",".07^Service^5",".08^Type^6" D
  1. .. S Y=+$G(TIU(8926.1,IENS,+I,"I")) Q:Y'>0
  1. .. S FNUM="8926."_+$P(I,U,3)
  1. .. S DOC("nationalTitle"_$P(I,U,2))=$$VUID^VPRD(Y,FNUM)_U_$G(TIU(8926.1,IENS,+I,"E"))
  1. S:$G(FILTER("loinc")) DOC("loinc")=$P(FILTER("loinc"),U)
  1. S X=+$G(VPRTIU(IEN,.01,"I")),X=$$CATG(X),(DOC("type"),DOC("category"))=X
  1. S DOC("documentClass")=$S(X="LR":"LR LABORATORY REPORTS",X="SR":"SURGICAL REPORTS",X="CP":"CLINICAL PROCEDURES",X="DS":"DISCHARGE SUMMARY",1:"PROGRESS NOTES")
  1. S DOC("referenceDateTime")=$P(VPRX,U,3)
  1. S X=$P(VPRX,U,6) D ;S:$L(X) DOC("location")=X
  1. . N LOC S LOC=$S($L(X):+$O(^SC("B",X,0)),1:0)
  1. . S DOC("facility")=$$FAC^VPRD(LOC)
  1. S X=$P(VPRX,U,7) S:$L(X) DOC("status")=X
  1. S:$P(VPRX,U,11) DOC("images")=+$P(VPRX,U,11)
  1. S:$L($P(VPRX,U,12)) DOC("subject")=$P(VPRX,U,12)
  1. ; X=$S($P(VPRX,U,13)[">":"C",$P(VPRX,U,13)["<":"I",1:"") ;componentType
  1. I $P(VPRX,U,14)>5 S DOC("parent")=$P(VPRX,U,14) ;ID notes
  1. S DOC("encounter")=$G(VPRTIU(IEN,.03,"I"))
  1. S:$G(VPRTEXT) DOC("content")=$$TEXT(IEN)
  1. ; providers &/or signatures
  1. S X=$P(VPRX,U,5),I=0 ;author
  1. S:X I=I+1,DOC("clinician",I)=+X_U_$P(X,";",3)_"^A^^^"_$$PROVSPC^VPRD(+X)
  1. M ES=VPRTIU(IEN) I ES(1501,"I") D ;signed
  1. . S I=I+1,X=ES(1502,"I")
  1. . S DOC("clinician",I)=X_U_ES(1502,"E")_"^S^"_ES(1501,"I")_U_$$SIG(X)_U_$$PROVSPC^VPRD(X)
  1. I ES(1507,"I") D ;cosigned
  1. . S I=I+1,X=ES(1508,"I")
  1. . S DOC("clinician",I)=X_U_ES(1508,"E")_"^C^"_ES(1507,"I")_U_$$SIG(X)_U_$$PROVSPC^VPRD(X)
  1. Q
  1. ;
  1. CATG(DA) ; -- Return a code for document type #8925.1 DA
  1. N X
  1. D ISCNSLT^TIUCNSLT(.X,DA) I X Q "CR" ;consult result
  1. I $$ISA^TIULX(DA,25) Q "A" ;CWAD note/Allergy
  1. I $$ISA^TIULX(DA,27) Q "D" ;CWAD note/Advance Directive
  1. I $$ISA^TIULX(DA,30) Q "C" ;CWAD note/Crisis Note
  1. I $$ISA^TIULX(DA,31) Q "W" ;CWAD note/Clinical Warning
  1. I $$ISA^TIULX(DA,3) Q "PN" ;progress note
  1. ;
  1. I $$ISA^TIULX(DA,244) Q "DS" ;discharge summary
  1. D ISCP^TIUCP(.X,DA) I X Q "CP" ;clinical procedure
  1. D ISSURG^TIUSROI(.X,DA) I X Q "SR" ;surgery
  1. I $$ISA^TIULX(DA,$$LR) Q "LR" ;laboratory
  1. Q ""
  1. ;
  1. LR() ; -- Return ien of Lab class
  1. N Y S Y=+$O(^TIU(8925.1,"B","LR LABORATORY REPORTS",0))
  1. I Y>0,$S($P($G(^TIU(8925.1,Y,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S Y=0
  1. Q Y
  1. ;
  1. SIG(X) ; -- Return Signature Block Name_Title
  1. N X20,Y S X20=$G(^VA(200,+$G(X),20))
  1. S Y=$P(X20,U,2)_" "_$P(X20,U,3)
  1. Q Y
  1. ;
  1. RPT(VPRY,IFN) ; -- Return text of document in @VPRY@(n)
  1. N I,J ;protect for calling loops
  1. D TGET^TIUSRVR1(.VPRY,IFN)
  1. Q
  1. ;
  1. TEXT(VPRIFN) ; -- Get document IFN text, return temp array name
  1. N VPRY,Y
  1. N IEN,IFN,CLASS,STATUS,CNT,X0,X,I,J ;protect for calling loops
  1. S VPRIFN=+$G(VPRIFN) D TGET^TIUSRVR1(.VPRY,VPRIFN)
  1. M ^TMP("VPRTEXT",$J,VPRIFN)=@VPRY K @VPRY
  1. S Y=$NA(^TMP("VPRTEXT",$J,VPRIFN))
  1. Q Y
  1. ;
  1. INFO(IFN) ; -- Returns ien^localTitle^natlTitle^VUID
  1. ; or -1^STATUS if not viewable
  1. N X,Y,VPRTIU,VPRERR,LT,NT,VUID,I,J S IFN=+$G(IFN)
  1. ;I '$D(^TIU(8925,IFN,0)) Q "-1^DELETED"
  1. D EXTRACT^TIULQ(IFN,"VPRTIU",.VPRERR,".01;.05")
  1. I $G(VPRERR) Q "-1^ERROR"
  1. I VPRTIU(IFN,.05,"I")<7!(VPRTIU(IFN,.05,"I")>13) Q "-1^"_VPRTIU(IFN,.05,"E")
  1. S LT=$G(VPRTIU(IFN,.01,"E")),VUID=""
  1. I $P(LT," ")="Addendum" Q "-1^ADDENDUM"
  1. S NT=$P($G(^TIU(8925.1,+$G(VPRTIU(IFN,.01,"I")),15)),U) I NT D
  1. . S VUID=$$VUID^VPRD(+NT,8926.1)
  1. . S NT=$$GET1^DIQ(8926.1,+NT_",",.01)
  1. S Y=IFN_U_LT_U_NT_U_VUID
  1. Q Y
  1. ;
  1. ; ------------ Return data to middle tier ------------
  1. ;
  1. XML(DOC) ; -- Return patient documents as XML
  1. N ATT,X,Y,NAMES,TYPE,I
  1. D ADD("<document>") S VPRTOTL=$G(VPRTOTL)+1
  1. S ATT="" F S ATT=$O(DOC(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
  1. . I $O(DOC(ATT,0)) D S Y="" Q ;multiples
  1. .. D ADD("<"_ATT_"s>")
  1. .. S I=0 F S I=$O(DOC(ATT,I)) Q:I<1 D
  1. ... S X=$G(DOC(ATT,I)),NAMES=""
  1. ... I ATT="clinician" S NAMES="code^name^role^dateTime^signature^"_$$PROVTAGS^VPRD_"^Z"
  1. ... S Y="<"_ATT_" "_$$LOOP_"/>" D ADD(Y)
  1. .. D ADD("</"_ATT_"s>")
  1. . S X=$G(DOC(ATT)),Y="" Q:'$L(X)
  1. . I ATT="content" D S Y="" Q ;text
  1. .. S Y="<content xml:space='preserve'>" D ADD(Y)
  1. .. S I=0 F S I=$O(@X@(I)) Q:I<1 S Y=$$ESC^VPRD(@X@(I)) D ADD(Y)
  1. .. D ADD("</content>")
  1. . I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
  1. . I $L(X)>1 S NAMES="code^name^Z",Y="<"_ATT_" "_$$LOOP_"/>"
  1. D ADD("</document>")
  1. Q
  1. ;
  1. LOOP() ; -- build sub-items string from NAMES and X
  1. N STR,P,TAG S STR=""
  1. F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
  1. Q STR
  1. ;
  1. ADD(X) ; Add a line @VPR@(n)=X
  1. S VPRI=$G(VPRI)+1
  1. S @VPR@(VPRI)=X
  1. Q
  1. ;
  1. ; ------------ Get/apply search criteria ------------
  1. ;
  1. SETUP ; -- convert FILTER("attribute") = value to TIU criteria
  1. ; Expects: FILTER("category") = code (see $$CATG)
  1. ; FILTER("loinc") = LOINC
  1. ; FILTER("status") = 'all','completed','unsigned'
  1. ; Returns CLASS,[SUBCLASS,TITLE,SERVICE,SUBJECT,STATUS]
  1. ;
  1. N LOINC,TYPE,STS,CP
  1. S LOINC=+$G(FILTER("loinc")),TYPE=$$UP^XLFSTR($G(FILTER("category")))
  1. S CLASS="3^244",(SUBCLASS,TITLE,SERVICE,SUBJECT,NOTSUBJ,STATUS)=""
  1. ;
  1. ; status [default='complete']
  1. S STS=$$LOW^XLFSTR($G(FILTER("status")))
  1. S STATUS=$S(STS?1"unsig".E:2,STS="all":"5^2",1:5) ;TIUSRVLO statuses
  1. ;
  1. ; progress notes
  1. I TYPE="PN" S CLASS=3 Q
  1. I TYPE="CR"!(LOINC=11488) S CLASS=3,SUBCLASS=+$$CLASS^TIUCNSLT Q
  1. ; LOINC=26442 S CLASS=3,SUBJECT="^114^" Q ;OB/GYN
  1. I LOINC=34117 S CLASS=3,SERVICE="^88^" Q ;H&P
  1. I TYPE="CWAD" S CLASS=3,SUBCLASS="25^27^30^31" Q ;CWAD
  1. I TYPE="C" S CLASS=3,SUBCLASS=30 Q ;Crisis Note
  1. I TYPE="W" S CLASS=3,SUBCLASS=31 Q ;Clinical Warning
  1. I TYPE="A" S CLASS=3,SUBCLASS=25 Q ;Allergy Note
  1. I TYPE="D"!(LOINC=42348) S CLASS=3,SUBCLASS=27 Q ;Advance Directive
  1. ;
  1. ; discharge summaries
  1. I TYPE="DS"!(LOINC=18842) S CLASS=244 Q
  1. ;
  1. ; procedures
  1. I TYPE="SR"!(LOINC=29752) S CLASS=+$$CLASS^TIUSROI("SURGICAL REPORTS") Q
  1. D CPCLASS^TIUCP(.CP)
  1. I TYPE="CP" S CLASS=$S(STATUS=2:CP,1:"CP") Q ;CLINICAL PROCEDURES
  1. I LOINC=26441 D Q ;CARDIOLOGY
  1. . S CLASS=CP_"^3"
  1. . S SUBJECT="^18^142^174^",SERVICE="^75^76^115^"
  1. I LOINC=27896 D Q ;PULMONARY
  1. . S CLASS=CP_"^3"
  1. . S SUBJECT="^23^142^",SERVICE="^75^76^115^"
  1. I LOINC=27895 D Q ;GASTROENTEROLOGY
  1. . S CLASS=CP_"^3"
  1. . S SUBJECT="^20^",SERVICE="^75^76^115^"
  1. I LOINC=27897 D Q ;NEUROLOGY
  1. . S CLASS=CP_"^3"
  1. . S SUBJECT="^44^45^52^111^112^143^146^",SERVICE="^75^76^115^"
  1. I LOINC=28619 D Q ;OPHTH/OPTOMETRY
  1. . S CLASS=CP_"^3"
  1. . S SUBJECT="^13^14^103^",SERVICE="^75^76^115^"
  1. I LOINC=28634 D Q ;MISC/ALL OTHERS
  1. . S CLASS=CP_"^3",SERVICE="^75^76^115^"
  1. . S NOTSUBJ="^18^142^174^23^142^20^44^45^52^111^112^143^146^13^14^103^"
  1. I LOINC=28570 D Q ;UNSPECIFIED/ALL
  1. . S CLASS=CP_"^3"
  1. . S SERVICE="^75^76^115^"
  1. ;
  1. ; pathology/lab
  1. I TYPE="LR"!(LOINC=27898) S CLASS=$S(STATUS=2:$$LR,1:"LR") Q
  1. ;
  1. ; radiology
  1. I TYPE="RA"!(LOINC=18726) S CLASS="RA" Q
  1. ;
  1. ; unknown
  1. I $L(TYPE)!LOINC S CLASS=0
  1. Q
  1. ;
  1. MATCH(DOC) ; -- Return 1 or 0, if document DA matches search criteria
  1. N Y,DA,LOCAL,NATL,X0,OK S Y=0
  1. S DA=+$G(DOC) G:DA<1 MQ
  1. ; both parent + addenda returned by TIU if any match search criteria
  1. ; include addenda if pulling only unsigned items:
  1. I $P(DOC,U,2)?1"Addendum ".E,STATUS'=2 G MQ
  1. ; skip any child if getting text, unless unsigned
  1. ; piece 14 = parent ien, or context (1-5) if no parent
  1. I $P(DOC,U,14)>5,$G(VPRTEXT),STATUS'=2 G MQ
  1. ; remove completed parent notes from TIU unsigned list:
  1. I CTXT=2,$P(DOC,U,7)'="unsigned" G MQ
  1. ; remove Uncosigned notes from 'complete' view:
  1. I STATUS=5,$P(DOC,U,7)="uncosigned" G MQ
  1. ; Check title & attributes for a match ...
  1. S LOCAL=$$GET1^DIQ(8925,DA_",",.01,"I") ;local Title 8925.1 ien
  1. I $L(SUBCLASS) D G:'OK MQ
  1. . N I,X S OK=0
  1. . F I=1:1:$L(SUBCLASS,"^") S X=$P(SUBCLASS,U,I) I $$ISA^TIULX(LOCAL,X) S OK=1 Q
  1. S NATL=+$$GET1^DIQ(8925.1,LOCAL_",",1501,"I") ;Natl Title 8926.1 ien
  1. I $L(TITLE) G:TITLE'[(U_+NATL_U) MQ
  1. S X0=$G(^TIU(8926.1,NATL,0))
  1. I $L(SERVICE) G:SERVICE'[(U_+$P(X0,U,7)_U) MQ
  1. I $L(SUBJECT) G:SUBJECT'[(U_+$P(X0,U,4)_U) MQ
  1. I $L(NOTSUBJ) G:NOTSUBJ[(U_+$P(X0,U,4)_U) MQ
  1. S Y=1
  1. MQ Q Y