VPRDLRO ;SLC/MKB -- Lab extract by order/panel ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**2,5,7,11,33**;Sep 01, 2011;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; ^LAB(60 10054
; ^LR 525
; ^ORD(100.98 873
; ^VA(200 10060
; DIQ 2056
; LR7OR1,^TMP("LRRR",$J) 2503
; LR7OU1 2955
; LRPXAPIU 4246
; ORQ1,^TMP("ORR",$J) 3154
; ORQ12,^TMP("ORGOTIT",$J) 5704
; ORX8 2467,3071
; XUAF4 2171
;
; ------------ Get data from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's lab orders
N ORLIST,ORDG,ORFLG,ORIGVIEW,ORDER,VPRN,VPRITM,VPRCNT,LRDFN,LRSUB,CDT
S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
S LRDFN=$G(^DPT(DFN,"LR")),LRSUB=$G(FILTER("type"),"CH")
;
; get one lab order's results
I $G(IFN) D G ENQ
. N ORLST S ORLST=0,ORLIST=$H
. S ORIGVIEW=2 ;get original view of order
. D GET^ORQ12(+IFN,ORLIST,1) S VPRN=ORLST
. D EN1(VPRN,.VPRITM),XML(.VPRITM)
. K ^TMP("ORGOTIT",$J)
;
; get [all] lab orders with results
S ORDG=+$O(^ORD(100.98,"B","LAB",0))
S ORFLG=6 ;search by Released Orders, check collection time in loop
S ORIGVIEW=2 ;get original view of order
D EN^ORQ1(DFN_";DPT(",ORDG,ORFLG,,(BEG-20000),(END+20000),1) S VPRCNT=0
S VPRN=0 F S VPRN=$O(^TMP("ORR",$J,ORLIST,VPRN)) Q:VPRN<1 S ORDER=$G(^(VPRN)) D Q:VPRCNT'<MAX
. I $P($P(ORDER,U),";",2)>1 Q ;skip order actions
. I $P(ORDER,U,7)'="comp" Q ;completed only -- want results
. I $G(^OR(100,+ORDER,4))'[LRSUB Q ;apply type filter
. S CDT=$P(ORDER,U,4) I (CDT<BEG)!(CDT>END) Q
. K VPRITM D EN1(VPRN,.VPRITM) Q:'$D(VPRITM)
. D XML(.VPRITM) S VPRCNT=VPRCNT+1
ENQ ; end
K ^TMP("ORR",$J),^TMP("VPRTEXT",$J),^TMP("LRRR",$J,DFN)
Q
;
EN1(NUM,ORD) ; -- return an order in ORD("attribute")=value
; from EN: expects ^TMP("ORR",$J,ORLIST,VPRN),LRDFN
N ORPK,X0,IFN,OI,VPRSUB,VPRIDT,LR0,X,I,VPRL,VPRT
K ORD,^TMP("VPRTEXT",$J)
S X0=$G(^TMP("ORR",$J,ORLIST,NUM)),IFN=+X0
I '$$LAB(IFN) Q ; p33 make sure this is really a lab order
I $G(DFN),+$P($G(^OR(100,IFN,0)),U,2)'=DFN Q
S ORPK=$$PKGID^ORX8(+IFN) Q:'ORPK
S ORD("id")=IFN,ORD("labOrderID")=ORPK
S OI=$$OI^ORX8(+IFN),ORD("name")=$P(OI,U,2)
S ORD("order")=+IFN_U_$P(OI,U,2)
S ORD("ordered")=$P(X0,U,3)
;
K ^TMP("LRRR",$J,DFN) D RR^LR7OR1(DFN,ORPK)
S VPRSUB=$P(ORPK,";",4) Q:VPRSUB="" Q:"CH^MI"'[VPRSUB
S VPRIDT=$P(ORPK,";",5) Q:VPRIDT<1 Q:'$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT,0))
; I $G(ID),$P(ID,";",1,3)'=$P($P(X,U,3),";",1,3) Q ;single order/specimen
S ORD("type")=VPRSUB,ORD("status")="completed"
S ORD("collected")=9999999-VPRIDT
S LR0=$G(^LR(LRDFN,VPRSUB,VPRIDT,0))
S X=$P(LR0,U,3) I VPRSUB="MI",'X S ORD("status")="incomplete"
S ORD("resulted")=X,X=+$P(LR0,U,5) I X D ;specimen
. N IENS,VPRY S IENS=X_","
. D GETS^DIQ(61,IENS,".01:2",,"VPRY")
. S ORD("specimen")=$G(VPRY(61,IENS,2))_U_$G(VPRY(61,IENS,.01)) ;SNOMED^name
. S ORD("sample")=$$GET1^DIQ(61,X_",",4.1) ;name
S ORD("groupName")=$P(LR0,U,6),X=+$P(LR0,U,14)
S:X ORD("facility")=$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U)
I 'X S ORD("facility")=$$FAC^VPRD ;local stn#^name
S I=$S(VPRSUB="CH":10,1:7),X=+$P(LR0,U,I)
S:X ORD("provider")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
;
K VPRT D EXPAND^LR7OU1(+$P(OI,U,3),.VPRT) ;get individual tests
S VPRL=0 F S VPRL=$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT,VPRL)) Q:VPRL<1 S X=$G(^(VPRL)) D
. Q:'$D(VPRT(+X)) ;test not in order/panel
. S:VPRSUB="CH" ORD("value",VPRL)=$$CH(X)
. S:VPRSUB="MI" ORD("value",VPRL)=$$MI(X)
I $D(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT,"N")) K CMMT M CMMT=^("N") S ORD("comment")=$$STRING^VPRD(.CMMT)
Q
;
CH(X0) ; -- return a Chemistry result as:
; id^test^result^interpretation^units^low^high^loinc^vuid^performingLab
; Expects X0=^TMP("LRRR",$J,DFN,"CH",VPRIDT,VPRL),LRDFN
N P,X,Y,NODE,LOINC
S P=$$LRDN^LRPXAPIU(+X0) ;get LR node# for test
S NODE=$G(^LR(LRDFN,"CH",VPRIDT,P))
S X=$P($G(^LAB(60,+X0,0)),U)
S Y="CH;"_VPRIDT_";"_P_U_X_U_$P(X0,U,2,4)
S X=$P(X0,U,5) I $L(X),X["-" S X=$TR(X,"- ","^"),$P(Y,U,6,7)=X
S X=$P($P(NODE,U,3),"!",3) S:X LOINC=$$GET1^DIQ(95.3,X_",",.01)
S:$G(LOINC) $P(Y,U,8,9)=LOINC_U_$$VUID^VPRD(+LOINC,95.3)
S X=+$P(NODE,U,9) S:X $P(Y,U,10)=$$NAME^XUAF4(X) ;performing lab
Q Y
;
MI(X0) ; -- return a Microbiology result as:
; id^test^result^interpretation^units
; Expects X0=^TMP("LRRR",$J,DFN,"MI",VPRIDT,VPRL)
N Y S Y=""
S:$L($P(X0,U))>1 Y="MI;"_VPRIDT_";"_VPRL_U_$P(X0,U,1,4)
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(LAB) ; -- Return result as XML in @VPR@(#)
N ATT,X,Y,I,J,P,NAMES,TAG
D ADD("<panel>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(LAB(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. I $O(LAB(ATT,0)) D S Y="" Q
.. D ADD("<"_ATT_"s>")
.. I ATT="value" S NAMES="id^test^result^interpretation^units^low^high^loinc^vuid^performingLab^Z"
.. E S NAMES="code^name^Z"
.. S I=0 F S I=$O(LAB(ATT,I)) Q:I<1 D
... S X=$G(LAB(ATT,I)),Y="<"_ATT_" "_$$LOOP_"/>" D ADD(Y)
.. D ADD("</"_ATT_"s>")
. 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
. S NAMES="code^name"_$S(ATT="provider":U_$$PROVTAGS^VPRD,1:"")_"^Z"
. I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</panel>")
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
;
LAB(ORIFN) ; -- is order really a lab (non-LR order in display group)
N X,Y,PKG S Y=0
S X=$P($G(^OR(100,+$G(ORIFN),0)),U,14),PKG=$$GET1^DIQ(9.4,+X_",",1)
I $E(PKG,1,2)="LR" S Y=1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDLRO 6265 printed Apr 09, 2024@21:48:08 Page 2
VPRDLRO ;SLC/MKB -- Lab extract by order/panel ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2,5,7,11,33**;Sep 01, 2011;Build 8
+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 ; ^LR 525
+9 ; ^ORD(100.98 873
+10 ; ^VA(200 10060
+11 ; DIQ 2056
+12 ; LR7OR1,^TMP("LRRR",$J) 2503
+13 ; LR7OU1 2955
+14 ; LRPXAPIU 4246
+15 ; ORQ1,^TMP("ORR",$J) 3154
+16 ; ORQ12,^TMP("ORGOTIT",$J) 5704
+17 ; ORX8 2467,3071
+18 ; XUAF4 2171
+19 ;
+20 ; ------------ Get data from VistA ------------
+21 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's lab orders
+1 NEW ORLIST,ORDG,ORFLG,ORIGVIEW,ORDER,VPRN,VPRITM,VPRCNT,LRDFN,LRSUB,CDT
+2 ;invalid patient
SET DFN=+$GET(DFN)
if 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 LRSUB=$GET(FILTER("type"),"CH")
+5 ;
+6 ; get one lab order's results
+7 IF $GET(IFN)
Begin DoDot:1
+8 NEW ORLST
SET ORLST=0
SET ORLIST=$HOROLOG
+9 ;get original view of order
SET ORIGVIEW=2
+10 DO GET^ORQ12(+IFN,ORLIST,1)
SET VPRN=ORLST
+11 DO EN1(VPRN,.VPRITM)
DO XML(.VPRITM)
+12 KILL ^TMP("ORGOTIT",$JOB)
End DoDot:1
GOTO ENQ
+13 ;
+14 ; get [all] lab orders with results
+15 SET ORDG=+$ORDER(^ORD(100.98,"B","LAB",0))
+16 ;search by Released Orders, check collection time in loop
SET ORFLG=6
+17 ;get original view of order
SET ORIGVIEW=2
+18 DO EN^ORQ1(DFN_";DPT(",ORDG,ORFLG,,(BEG-20000),(END+20000),1)
SET VPRCNT=0
+19 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRN))
if VPRN<1
QUIT
SET ORDER=$GET(^(VPRN))
Begin DoDot:1
+20 ;skip order actions
IF $PIECE($PIECE(ORDER,U),";",2)>1
QUIT
+21 ;completed only -- want results
IF $PIECE(ORDER,U,7)'="comp"
QUIT
+22 ;apply type filter
IF $GET(^OR(100,+ORDER,4))'[LRSUB
QUIT
+23 SET CDT=$PIECE(ORDER,U,4)
IF (CDT<BEG)!(CDT>END)
QUIT
+24 KILL VPRITM
DO EN1(VPRN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+25 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:1
if VPRCNT'<MAX
QUIT
ENQ ; end
+1 KILL ^TMP("ORR",$JOB),^TMP("VPRTEXT",$JOB),^TMP("LRRR",$JOB,DFN)
+2 QUIT
+3 ;
EN1(NUM,ORD) ; -- return an order in ORD("attribute")=value
+1 ; from EN: expects ^TMP("ORR",$J,ORLIST,VPRN),LRDFN
+2 NEW ORPK,X0,IFN,OI,VPRSUB,VPRIDT,LR0,X,I,VPRL,VPRT
+3 KILL ORD,^TMP("VPRTEXT",$JOB)
+4 SET X0=$GET(^TMP("ORR",$JOB,ORLIST,NUM))
SET IFN=+X0
+5 ; p33 make sure this is really a lab order
IF '$$LAB(IFN)
QUIT
+6 IF $GET(DFN)
IF +$PIECE($GET(^OR(100,IFN,0)),U,2)'=DFN
QUIT
+7 SET ORPK=$$PKGID^ORX8(+IFN)
if 'ORPK
QUIT
+8 SET ORD("id")=IFN
SET ORD("labOrderID")=ORPK
+9 SET OI=$$OI^ORX8(+IFN)
SET ORD("name")=$PIECE(OI,U,2)
+10 SET ORD("order")=+IFN_U_$PIECE(OI,U,2)
+11 SET ORD("ordered")=$PIECE(X0,U,3)
+12 ;
+13 KILL ^TMP("LRRR",$JOB,DFN)
DO RR^LR7OR1(DFN,ORPK)
+14 SET VPRSUB=$PIECE(ORPK,";",4)
if VPRSUB=""
QUIT
if "CH^MI"'[VPRSUB
QUIT
+15 SET VPRIDT=$PIECE(ORPK,";",5)
if VPRIDT<1
QUIT
if '$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT,0))
QUIT
+16 ; I $G(ID),$P(ID,";",1,3)'=$P($P(X,U,3),";",1,3) Q ;single order/specimen
+17 SET ORD("type")=VPRSUB
SET ORD("status")="completed"
+18 SET ORD("collected")=9999999-VPRIDT
+19 SET LR0=$GET(^LR(LRDFN,VPRSUB,VPRIDT,0))
+20 SET X=$PIECE(LR0,U,3)
IF VPRSUB="MI"
IF 'X
SET ORD("status")="incomplete"
+21 ;specimen
SET ORD("resulted")=X
SET X=+$PIECE(LR0,U,5)
IF X
Begin DoDot:1
+22 NEW IENS,VPRY
SET IENS=X_","
+23 DO GETS^DIQ(61,IENS,".01:2",,"VPRY")
+24 ;SNOMED^name
SET ORD("specimen")=$GET(VPRY(61,IENS,2))_U_$GET(VPRY(61,IENS,.01))
+25 ;name
SET ORD("sample")=$$GET1^DIQ(61,X_",",4.1)
End DoDot:1
+26 SET ORD("groupName")=$PIECE(LR0,U,6)
SET X=+$PIECE(LR0,U,14)
+27 if X
SET ORD("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+28 ;local stn#^name
IF 'X
SET ORD("facility")=$$FAC^VPRD
+29 SET I=$SELECT(VPRSUB="CH":10,1:7)
SET X=+$PIECE(LR0,U,I)
+30 if X
SET ORD("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
+31 ;
+32 ;get individual tests
KILL VPRT
DO EXPAND^LR7OU1(+$PIECE(OI,U,3),.VPRT)
+33 SET VPRL=0
FOR
SET VPRL=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT,VPRL))
if VPRL<1
QUIT
SET X=$GET(^(VPRL))
Begin DoDot:1
+34 ;test not in order/panel
if '$DATA(VPRT(+X))
QUIT
+35 if VPRSUB="CH"
SET ORD("value",VPRL)=$$CH(X)
+36 if VPRSUB="MI"
SET ORD("value",VPRL)=$$MI(X)
End DoDot:1
+37 IF $DATA(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT,"N"))
KILL CMMT
MERGE CMMT=^("N")
SET ORD("comment")=$$STRING^VPRD(.CMMT)
+38 QUIT
+39 ;
CH(X0) ; -- return a Chemistry result as:
+1 ; id^test^result^interpretation^units^low^high^loinc^vuid^performingLab
+2 ; Expects X0=^TMP("LRRR",$J,DFN,"CH",VPRIDT,VPRL),LRDFN
+3 NEW P,X,Y,NODE,LOINC
+4 ;get LR node# for test
SET P=$$LRDN^LRPXAPIU(+X0)
+5 SET NODE=$GET(^LR(LRDFN,"CH",VPRIDT,P))
+6 SET X=$PIECE($GET(^LAB(60,+X0,0)),U)
+7 SET Y="CH;"_VPRIDT_";"_P_U_X_U_$PIECE(X0,U,2,4)
+8 SET X=$PIECE(X0,U,5)
IF $LENGTH(X)
IF X["-"
SET X=$TRANSLATE(X,"- ","^")
SET $PIECE(Y,U,6,7)=X
+9 SET X=$PIECE($PIECE(NODE,U,3),"!",3)
if X
SET LOINC=$$GET1^DIQ(95.3,X_",",.01)
+10 if $GET(LOINC)
SET $PIECE(Y,U,8,9)=LOINC_U_$$VUID^VPRD(+LOINC,95.3)
+11 ;performing lab
SET X=+$PIECE(NODE,U,9)
if X
SET $PIECE(Y,U,10)=$$NAME^XUAF4(X)
+12 QUIT Y
+13 ;
MI(X0) ; -- return a Microbiology result as:
+1 ; id^test^result^interpretation^units
+2 ; Expects X0=^TMP("LRRR",$J,DFN,"MI",VPRIDT,VPRL)
+3 NEW Y
SET Y=""
+4 if $LENGTH($PIECE(X0,U))>1
SET Y="MI;"_VPRIDT_";"_VPRL_U_$PIECE(X0,U,1,4)
+5 QUIT Y
+6 ;
+7 ; ------------ Return data to middle tier ------------
+8 ;
XML(LAB) ; -- Return result as XML in @VPR@(#)
+1 NEW ATT,X,Y,I,J,P,NAMES,TAG
+2 DO ADD("<panel>")
SET VPRTOTL=$GET(VPRTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(LAB(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 IF $ORDER(LAB(ATT,0))
Begin DoDot:2
+5 DO ADD("<"_ATT_"s>")
+6 IF ATT="value"
SET NAMES="id^test^result^interpretation^units^low^high^loinc^vuid^performingLab^Z"
+7 IF '$TEST
SET NAMES="code^name^Z"
+8 SET I=0
FOR
SET I=$ORDER(LAB(ATT,I))
if I<1
QUIT
Begin DoDot:3
+9 SET X=$GET(LAB(ATT,I))
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(LAB(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+12 IF ATT="comment"
SET Y="<"_ATT_" xml:space='preserve'>"_$$ESC^VPRD(X)_"</"_ATT_">"
QUIT
+13 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+14 SET NAMES="code^name"_$SELECT(ATT="provider":U_$$PROVTAGS^VPRD,1:"")_"^Z"
+15 IF $LENGTH(X)>1
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+16 DO ADD("</panel>")
+17 QUIT
+18 ;
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 ;
LAB(ORIFN) ; -- is order really a lab (non-LR order in display group)
+1 NEW X,Y,PKG
SET Y=0
+2 SET X=$PIECE($GET(^OR(100,+$GET(ORIFN),0)),U,14)
SET PKG=$$GET1^DIQ(9.4,+X_",",1)
+3 IF $EXTRACT(PKG,1,2)="LR"
SET Y=1
+4 QUIT Y
