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 Apr 09, 2024@21:48:14 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
