VPRDLR ;SLC/MKB -- Laboratory extract ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**2,5**;Sep 01, 2011;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; ^LAB(60 10054
; ^LAB(61 524
; ^LRO(69 2407
; ^LR 525
; DIC 2051
; DIQ 2056
; LR7OR1,^TMP("LRRR",$J) 2503
; LRPXAPIU 4246
; XUAF4 2171
;
; ------------ Get results from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
N VPRSUB,VPRIDT,VPRN,VPRP,VPRITM,LRDFN,SUB,X
S DFN=+$G(DFN) Q:$G(DFN)<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
S LRDFN=$G(^DPT(DFN,"LR")),VPRSUB=$G(FILTER("type"),"CH")
K ^TMP("LRRR",$J,DFN)
;
; get result(s)
I $L($G(ID)) D ;reset for LR7OR1
. S VPRSUB=$P(ID,";"),VPRIDT=+$P(ID,";",2)
. S:VPRIDT (BEG,END)=9999999-VPRIDT
;
D RR^LR7OR1(DFN,,BEG,END,VPRSUB,,,MAX)
S VPRSUB="" F S VPRSUB=$O(^TMP("LRRR",$J,DFN,VPRSUB)) Q:VPRSUB="" D
. S VPRIDT=0 F S VPRIDT=$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT)) Q:VPRIDT<1 D
.. S VPRP=0 F S VPRP=$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT,VPRP)) Q:VPRP<1 S X=+$G(^(VPRP)) D
... S VPRN=$$LRDN^LRPXAPIU(X) I $L($G(ID),";")>2,VPRN'=$P(ID,";",3) Q
... K VPRITM S SUB=$S("CH^MI"[VPRSUB:VPRSUB,1:"AP")_"(.VPRITM)"
... D @SUB,XML(.VPRITM):$D(VPRITM)
K ^TMP("LRRR",$J,DFN)
Q
;
CH(LAB) ; -- return a Chemistry result in LAB("attribute")=value
; Expects ^TMP("LRRR",$J,DFN,"CH",VPRIDT,VPRP),VPRN,LRDFN
N X0,CDT,LR0,LRI,X,LOINC,ORD,CMMT K LAB
S X0=$G(^TMP("LRRR",$J,DFN,"CH",VPRIDT,VPRP))
S LAB("id")="CH;"_VPRIDT_";"_VPRN,LAB("type")="CH"
S CDT=9999999-VPRIDT,LAB("collected")=CDT
S LR0=$G(^LR(LRDFN,"CH",VPRIDT,0)),LRI=$G(^(VPRN))
S LAB("status")="completed",LAB("resulted")=$P(LR0,U,3)
S LAB("test")=$P($G(^LAB(60,+X0,0)),U) ;$P(X0,U,10)?
S:$L($P(X0,U,2)) LAB("result")=$P(X0,U,2)
S:$L($P(X0,U,4)) LAB("units")=$P(X0,U,4)
S:$L($P(X0,U,3)) LAB("interpretation")=$P(X0,U,3)
S X=$P(X0,U,5) I $L(X),X["-" S LAB("low")=$$TRIM^XLFSTR($P(X,"-")),LAB("high")=$$TRIM^XLFSTR($P(X,"-",2))
S LAB("localName")=$S($L($P(X0,U,15)):$P(X0,U,15),1:LAB("test"))
S LAB("groupName")=$P(X0,U,16) ;accession#
S X=+$P(X0,U,19) I X D ;specimen
. N IENS,VPRY S IENS=X_","
. D GETS^DIQ(61,IENS,".01;2",,"VPRY")
. S LAB("specimen")=$G(VPRY(61,IENS,2))_U_$G(VPRY(61,IENS,.01)) ;SNOMED^name
. S LAB("sample")=$$GET1^DIQ(61,X_",",4.1) ;name
S ORD=+$P(X0,U,17) S:ORD LAB("labOrderID")=ORD
S X=$$ORDER(ORD,+X0) S:X LAB("orderID")=X
S X=$P($P(LRI,U,3),"!",3) S:X LOINC=$$GET1^DIQ(95.3,X_",",.01)
I $G(LOINC) S LAB("loinc")=LOINC,LAB("vuid")=$$VUID^VPRD(+LOINC,95.3)
S X=$P(LRI,U,9) S:X LAB("performingLab")=$$NAME^XUAF4(X)
S X=+$P(LR0,U,10) S:X LAB("provider")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
S X=$P(LR0,U,14) S:X LAB("facility")=$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U)
I 'X S LAB("facility")=$$FAC^VPRD ;local stn#^name
I $D(^TMP("LRRR",$J,DFN,"CH",VPRIDT,"N")) M CMMT=^("N") S LAB("comment")=$$STRING^VPRD(.CMMT)
Q
;
ORDER(LABORD,TEST) ; -- return #100 order for Lab order# & Test
N Y,D,S,T S Y=""
S D=$O(^LRO(69,"C",LABORD,0)) I D D
. S S=0 F S S=$O(^LRO(69,"C",LABORD,D,S)) Q:S<1 D
.. S T=0 F S T=$O(^LRO(69,D,1,S,2,T)) Q:T<1 I +$G(^(T,0))=TEST S Y=+$P(^(0),U,7)
Q Y
;
MI(LAB) ; -- return a Microbiology result in LAB("attribute")=value
; Expects ^TMP("LRRR",$J,DFN,"MI",VPRIDT,VPRP),LRDFN
N ID,CDT,X0,X,CMMT,LR0 K LAB
S X0=$G(^TMP("LRRR",$J,DFN,"MI",VPRIDT,VPRP)) Q:$L($P(X0,U))'>1
S LAB("id")="MI;"_VPRIDT_"#"_VPRP,LAB("status")="completed"
S LAB("type")="MI",CDT=9999999-VPRIDT,LAB("collected")=CDT
S LR0=$G(^LR(LRDFN,"MI",VPRIDT,0)),LAB("resulted")=$P(LR0,U,3)
I '$P(LR0,U,3) S LAB("status")="incomplete"
S:$L($P(X0,U,2)) LAB("result")=$P(X0,U,2)
S:$L($P(X0,U,4)) LAB("units")=$P(X0,U,4)
S:$L($P(X0,U,3)) LAB("interpretation")=$P(X0,U,3)
S (LAB("test"),LAB("localName"))=$P(X0,U,15)
S X=+$P(X0,U,19) I X D ;specimen
. N IENS,VPRY S IENS=X_","
. D GETS^DIQ(61,IENS,".01;2",,"VPRY")
. S LAB("specimen")=$G(VPRY(61,IENS,2))_U_$G(VPRY(61,IENS,.01)) ;SNOMED^name
. S LAB("sample")=$$GET1^DIQ(61,X_",",4.1) ;name
S X=+$P(LR0,U,7) S:X LAB("provider")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
S X=$P(LR0,U,14)
S:X LAB("facility")=$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U)
I 'X S LAB("facility")=$$FAC^VPRD ;local stn#^name
I $D(^TMP("LRRR",$J,DFN,"MI",VPRIDT,"N")) M CMMT=^("N") S LAB("comment")=$$STRING^VPRD(.CMMT)
Q
;
AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
K LAB ;implemented in VPRDLRA
Q
;
LOINC(DFN,ORPK,TEST) ; -- return LOINC code for ordered TEST
N LRDT,LRN,Y Q:$P(ORPK,";",4)'="CH" ""
S LRDT=$$LRIDT^LRPXAPIU($P(ORPK,";",5)),Y=""
D VALUE^LRPXAPI(.LRN,DFN,LRDT,TEST) ;LRN="" if panel
S X=$P($P(LRN,U,3),"!",3) S:X Y=$$GET1^DIQ(95.3,X_",",.01)
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(LAB) ; -- Return result as XML in @VPR@(#)
N ATT,X,Y,P,NAMES,TAG
D ADD("<lab>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(LAB(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S X=$G(LAB(ATT)),Y="" Q:'$L(X)
. I ATT="comment" S Y="<"_ATT_" xml:space='preserve'>"_$$ESC^VPRD(X)_"</"_ATT_">" Q
. ;
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
. I $L(X)>1 D S Y=""
.. S Y="<"_ATT_" ",NAMES="code^name^Z"
.. S:ATT="provider" NAMES="code^name^"_$$PROVTAGS^VPRD_"^Z"
.. F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S Y=Y_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
.. S Y=Y_"/>" D ADD(Y)
D ADD("</lab>")
Q
;
ADD(X) ; -- Add a line @VPR@(n)=X
S VPRI=$G(VPRI)+1
S @VPR@(VPRI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDLR 5953 printed Dec 13, 2024@02:44:47 Page 2
VPRDLR ;SLC/MKB -- Laboratory extract ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2,5**;Sep 01, 2011;Build 21
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; ^LAB(60 10054
+8 ; ^LAB(61 524
+9 ; ^LRO(69 2407
+10 ; ^LR 525
+11 ; DIC 2051
+12 ; DIQ 2056
+13 ; LR7OR1,^TMP("LRRR",$J) 2503
+14 ; LRPXAPIU 4246
+15 ; XUAF4 2171
+16 ;
+17 ; ------------ Get results from VistA ------------
+18 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
+1 NEW VPRSUB,VPRIDT,VPRN,VPRP,VPRITM,LRDFN,SUB,X
+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 SET LRDFN=$GET(^DPT(DFN,"LR"))
SET VPRSUB=$GET(FILTER("type"),"CH")
+5 KILL ^TMP("LRRR",$JOB,DFN)
+6 ;
+7 ; get result(s)
+8 ;reset for LR7OR1
IF $LENGTH($GET(ID))
Begin DoDot:1
+9 SET VPRSUB=$PIECE(ID,";")
SET VPRIDT=+$PIECE(ID,";",2)
+10 if VPRIDT
SET (BEG,END)=9999999-VPRIDT
End DoDot:1
+11 ;
+12 DO RR^LR7OR1(DFN,,BEG,END,VPRSUB,,,MAX)
+13 SET VPRSUB=""
FOR
SET VPRSUB=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB))
if VPRSUB=""
QUIT
Begin DoDot:1
+14 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:2
+15 SET VPRP=0
FOR
SET VPRP=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT,VPRP))
if VPRP<1
QUIT
SET X=+$GET(^(VPRP))
Begin DoDot:3
+16 SET VPRN=$$LRDN^LRPXAPIU(X)
IF $LENGTH($GET(ID),";")>2
IF VPRN'=$PIECE(ID,";",3)
QUIT
+17 KILL VPRITM
SET SUB=$SELECT("CH^MI"[VPRSUB:VPRSUB,1:"AP")_"(.VPRITM)"
+18 DO @SUB
if $DATA(VPRITM)
DO XML(.VPRITM)
End DoDot:3
End DoDot:2
End DoDot:1
+19 KILL ^TMP("LRRR",$JOB,DFN)
+20 QUIT
+21 ;
CH(LAB) ; -- return a Chemistry result in LAB("attribute")=value
+1 ; Expects ^TMP("LRRR",$J,DFN,"CH",VPRIDT,VPRP),VPRN,LRDFN
+2 NEW X0,CDT,LR0,LRI,X,LOINC,ORD,CMMT
KILL LAB
+3 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"CH",VPRIDT,VPRP))
+4 SET LAB("id")="CH;"_VPRIDT_";"_VPRN
SET LAB("type")="CH"
+5 SET CDT=9999999-VPRIDT
SET LAB("collected")=CDT
+6 SET LR0=$GET(^LR(LRDFN,"CH",VPRIDT,0))
SET LRI=$GET(^(VPRN))
+7 SET LAB("status")="completed"
SET LAB("resulted")=$PIECE(LR0,U,3)
+8 ;$P(X0,U,10)?
SET LAB("test")=$PIECE($GET(^LAB(60,+X0,0)),U)
+9 if $LENGTH($PIECE(X0,U,2))
SET LAB("result")=$PIECE(X0,U,2)
+10 if $LENGTH($PIECE(X0,U,4))
SET LAB("units")=$PIECE(X0,U,4)
+11 if $LENGTH($PIECE(X0,U,3))
SET LAB("interpretation")=$PIECE(X0,U,3)
+12 SET X=$PIECE(X0,U,5)
IF $LENGTH(X)
IF X["-"
SET LAB("low")=$$TRIM^XLFSTR($PIECE(X,"-"))
SET LAB("high")=$$TRIM^XLFSTR($PIECE(X,"-",2))
+13 SET LAB("localName")=$SELECT($LENGTH($PIECE(X0,U,15)):$PIECE(X0,U,15),1:LAB("test"))
+14 ;accession#
SET LAB("groupName")=$PIECE(X0,U,16)
+15 ;specimen
SET X=+$PIECE(X0,U,19)
IF X
Begin DoDot:1
+16 NEW IENS,VPRY
SET IENS=X_","
+17 DO GETS^DIQ(61,IENS,".01;2",,"VPRY")
+18 ;SNOMED^name
SET LAB("specimen")=$GET(VPRY(61,IENS,2))_U_$GET(VPRY(61,IENS,.01))
+19 ;name
SET LAB("sample")=$$GET1^DIQ(61,X_",",4.1)
End DoDot:1
+20 SET ORD=+$PIECE(X0,U,17)
if ORD
SET LAB("labOrderID")=ORD
+21 SET X=$$ORDER(ORD,+X0)
if X
SET LAB("orderID")=X
+22 SET X=$PIECE($PIECE(LRI,U,3),"!",3)
if X
SET LOINC=$$GET1^DIQ(95.3,X_",",.01)
+23 IF $GET(LOINC)
SET LAB("loinc")=LOINC
SET LAB("vuid")=$$VUID^VPRD(+LOINC,95.3)
+24 SET X=$PIECE(LRI,U,9)
if X
SET LAB("performingLab")=$$NAME^XUAF4(X)
+25 SET X=+$PIECE(LR0,U,10)
if X
SET LAB("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
+26 SET X=$PIECE(LR0,U,14)
if X
SET LAB("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+27 ;local stn#^name
IF 'X
SET LAB("facility")=$$FAC^VPRD
+28 IF $DATA(^TMP("LRRR",$JOB,DFN,"CH",VPRIDT,"N"))
MERGE CMMT=^("N")
SET LAB("comment")=$$STRING^VPRD(.CMMT)
+29 QUIT
+30 ;
ORDER(LABORD,TEST) ; -- return #100 order for Lab order# & Test
+1 NEW Y,D,S,T
SET Y=""
+2 SET D=$ORDER(^LRO(69,"C",LABORD,0))
IF D
Begin DoDot:1
+3 SET S=0
FOR
SET S=$ORDER(^LRO(69,"C",LABORD,D,S))
if S<1
QUIT
Begin DoDot:2
+4 SET T=0
FOR
SET T=$ORDER(^LRO(69,D,1,S,2,T))
if T<1
QUIT
IF +$GET(^(T,0))=TEST
SET Y=+$PIECE(^(0),U,7)
End DoDot:2
End DoDot:1
+5 QUIT Y
+6 ;
MI(LAB) ; -- return a Microbiology result in LAB("attribute")=value
+1 ; Expects ^TMP("LRRR",$J,DFN,"MI",VPRIDT,VPRP),LRDFN
+2 NEW ID,CDT,X0,X,CMMT,LR0
KILL LAB
+3 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"MI",VPRIDT,VPRP))
if $LENGTH($PIECE(X0,U))'>1
QUIT
+4 SET LAB("id")="MI;"_VPRIDT_"#"_VPRP
SET LAB("status")="completed"
+5 SET LAB("type")="MI"
SET CDT=9999999-VPRIDT
SET LAB("collected")=CDT
+6 SET LR0=$GET(^LR(LRDFN,"MI",VPRIDT,0))
SET LAB("resulted")=$PIECE(LR0,U,3)
+7 IF '$PIECE(LR0,U,3)
SET LAB("status")="incomplete"
+8 if $LENGTH($PIECE(X0,U,2))
SET LAB("result")=$PIECE(X0,U,2)
+9 if $LENGTH($PIECE(X0,U,4))
SET LAB("units")=$PIECE(X0,U,4)
+10 if $LENGTH($PIECE(X0,U,3))
SET LAB("interpretation")=$PIECE(X0,U,3)
+11 SET (LAB("test"),LAB("localName"))=$PIECE(X0,U,15)
+12 ;specimen
SET X=+$PIECE(X0,U,19)
IF X
Begin DoDot:1
+13 NEW IENS,VPRY
SET IENS=X_","
+14 DO GETS^DIQ(61,IENS,".01;2",,"VPRY")
+15 ;SNOMED^name
SET LAB("specimen")=$GET(VPRY(61,IENS,2))_U_$GET(VPRY(61,IENS,.01))
+16 ;name
SET LAB("sample")=$$GET1^DIQ(61,X_",",4.1)
End DoDot:1
+17 SET X=+$PIECE(LR0,U,7)
if X
SET LAB("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
+18 SET X=$PIECE(LR0,U,14)
+19 if X
SET LAB("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+20 ;local stn#^name
IF 'X
SET LAB("facility")=$$FAC^VPRD
+21 IF $DATA(^TMP("LRRR",$JOB,DFN,"MI",VPRIDT,"N"))
MERGE CMMT=^("N")
SET LAB("comment")=$$STRING^VPRD(.CMMT)
+22 QUIT
+23 ;
AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
+1 ;implemented in VPRDLRA
KILL LAB
+2 QUIT
+3 ;
LOINC(DFN,ORPK,TEST) ; -- return LOINC code for ordered TEST
+1 NEW LRDT,LRN,Y
if $PIECE(ORPK,";",4)'="CH"
QUIT ""
+2 SET LRDT=$$LRIDT^LRPXAPIU($PIECE(ORPK,";",5))
SET Y=""
+3 ;LRN="" if panel
DO VALUE^LRPXAPI(.LRN,DFN,LRDT,TEST)
+4 SET X=$PIECE($PIECE(LRN,U,3),"!",3)
if X
SET Y=$$GET1^DIQ(95.3,X_",",.01)
+5 QUIT Y
+6 ;
+7 ; ------------ Return data to middle tier ------------
+8 ;
XML(LAB) ; -- Return result as XML in @VPR@(#)
+1 NEW ATT,X,Y,P,NAMES,TAG
+2 DO ADD("<lab>")
SET VPRTOTL=$GET(VPRTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(LAB(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 SET X=$GET(LAB(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+5 IF ATT="comment"
SET Y="<"_ATT_" xml:space='preserve'>"_$$ESC^VPRD(X)_"</"_ATT_">"
QUIT
+6 ;
+7 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+8 IF $LENGTH(X)>1
Begin DoDot:2
+9 SET Y="<"_ATT_" "
SET NAMES="code^name^Z"
+10 if ATT="provider"
SET NAMES="code^name^"_$$PROVTAGS^VPRD_"^Z"
+11 FOR P=1:1
SET TAG=$PIECE(NAMES,U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET Y=Y_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
+12 SET Y=Y_"/>"
DO ADD(Y)
End DoDot:2
SET Y=""
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+13 DO ADD("</lab>")
+14 QUIT
+15 ;
ADD(X) ; -- Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
