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