VPRDLRA ;SLC/MKB -- Laboratory extract by accession ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1,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(68 1963
; ^LRO(69 2407
; ^LR 525
; ^SC 10040
; ^VA(200 10060
; DIC 2051
; DIQ 2056
; LR7OR1,^TMP("LRRR",$J) 2503
; LR7OSUM,^TMP("LRC",$J), 2766
; ^TMP("LRH",$J),^TMP("LRT",$J)
; LRPXAPIU 4246
; PXAPI 1894
; XUAF4 2171
;
; ------------ Get results from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
N VPRTYPE,SUB,VPRSUB,VPRIDT,VPRP,VPRITM,LRDFN,LR0,ORD,X,I
S DFN=+$G(DFN) Q:$G(DFN)<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
S VPRTYPE=$G(FILTER("type"),"CH;MI;CY;EM;SP;AU")
S LRDFN=$G(^DPT(DFN,"LR")),SUB=$$SUB(VPRTYPE)
K ^TMP("LRRR",$J,DFN)
;
; get result(s)
I $L($G(ID)) D ;reset search parameters
. S SUB=$P(ID,";"),VPRIDT=+$P(ID,";",2)
. S:VPRIDT (BEG,END)=9999999-VPRIDT
. S:"CH^MI"'[SUB SUB="AP"
;
D RR^LR7OR1(DFN,,BEG,END,SUB,,,MAX)
S VPRSUB="" F S VPRSUB=$O(^TMP("LRRR",$J,DFN,VPRSUB)) Q:VPRSUB="" D
. Q:$G(VPRTYPE)'[VPRSUB ;requested types only
. S VPRIDT=0 F S VPRIDT=$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT)) Q:VPRIDT<1 I $O(^(VPRIDT,0)) D
.. K VPRITM,ORD,CMMT,^TMP("VPRTEXT",$J)
.. I "CH^MI"'[VPRSUB D AP(.VPRITM),XML(.VPRITM) Q
.. S VPRITM("type")=VPRSUB,VPRITM("id")=VPRSUB_";"_VPRIDT
.. S VPRITM("collected")=9999999-VPRIDT,VPRITM("status")="completed"
.. S LR0=$G(^LR(LRDFN,VPRSUB,VPRIDT,0))
.. S VPRITM("resulted")=$P(LR0,U,3),X=+$P(LR0,U,5) I X D
... N IENS,VPRY S IENS=X_","
... D GETS^DIQ(61,IENS,".01;2;4.1",,"VPRY")
... S VPRITM("specimen")=$G(VPRY(61,IENS,2))_U_$G(VPRY(61,IENS,.01)) ;SNOMED^name
... S VPRITM("sample")=$G(VPRY(61,IENS,4.1)) ;name
.. S X=$P(LR0,U,6),VPRITM("name")=$$AREA(X),VPRITM("groupName")=X
.. S I=$S(VPRSUB="CH":10,1:7),X=+$P(LR0,U,I)
.. S:X VPRITM("provider")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
.. S X=+$P(LR0,U,14) S:X VPRITM("facility")=$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U)
.. I 'X S VPRITM("facility")=$$FAC^VPRD ;local stn#^name
.. I VPRSUB="MI" D ;report
... I '$P(LR0,U,3) S VPRITM("status")="incomplete" Q
... S VPRITM("document",1)=VPRSUB_";"_VPRIDT_"^LR MICROBIOLOGY REPORT^LABORATORY NOTE^4697105"
... S:$G(VPRTEXT) VPRITM("document",1,"content")=$$TEXT(DFN,VPRSUB,VPRIDT)
.. S VPRP=0 F S VPRP=$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT,VPRP)) Q:VPRP<1 D
... S X=$S(VPRSUB="MI":$$MI,1:$$CH)
... S:$L(X) VPRITM("value",VPRP)=X
... S:$G(ORD) VPRITM("labOrderID")=ORD
.. I $D(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT,"N")) M CMMT=^("N") S VPRITM("comment")=$$STRING^VPRD(.CMMT)
.. D XML(.VPRITM)
K ^TMP("LRRR",$J,DFN),^TMP("VPRTEXT",$J)
Q
;
CH() ; -- return a Chemistry result as:
; id^test^result^interpretation^units^low^high^localName^loinc^vuid^order^performingLab
; Expects ^TMP("LRRR",$J,DFN,"CH",VPRIDT,VPRP),LRDFN
N X,Y,X0,VPRN,NODE,CMMT,LOINC
S X0=$G(^TMP("LRRR",$J,DFN,"CH",VPRIDT,VPRP)),VPRN=$$LRDN^LRPXAPIU(+X0)
S NODE=$G(^LR(LRDFN,"CH",VPRIDT,VPRN))
S X=$P($G(^LAB(60,+X0,0)),U)
S Y="CH;"_VPRIDT_";"_VPRN_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 $P(Y,U,8)=$P(X0,U,15) ;test short name
S X=$P($P(NODE,U,3),"!",3) S:X LOINC=$$GET1^DIQ(95.3,X_",",.01)
S:$G(LOINC) $P(Y,U,9,10)=LOINC_U_$$VUID^VPRD(+LOINC,95.3)
S ORD=+$P(X0,U,17),X=$$ORDER(ORD,+X0) S:X $P(Y,U,11)=X
S X=+$P(NODE,U,9) S:X $P(Y,U,12)=$$NAME^XUAF4(X) ;performing lab
Q Y
;
MI() ; -- return a Microbiology result as:
; id^test^result^interpretation^units
; Expects ^TMP("LRRR",$J,DFN,"MI",VPRIDT,VPRP)
N Y,X0
S X0=$G(^TMP("LRRR",$J,DFN,"MI",VPRIDT,VPRP)),Y=""
S:$L($P(X0,U))>1 Y="MI;"_VPRIDT_";"_VPRP_U_$P(X0,U,1,4)
S ORD=+$P(X0,U,17)
Q Y
;
AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
N LR0,X,I,NODE
S LR0=$G(^LR(LRDFN,VPRSUB,VPRIDT,0)) I VPRSUB="AU" D
. N AU S AU=$G(^LR(LRDFN,"AU")) ;set pieces needed into LR0
. S LR0=+AU_U_$P(AU,U,10)_"^^^^"_$P(AU,U,6)_U_$P(AU,U,12)_"^^^^"_$P(AU,U,15)
S LAB("type")=VPRSUB,LAB("id")=VPRSUB_";"_VPRIDT
S LAB("collected")=9999999-VPRIDT,LAB("resulted")=$P(LR0,U,11)
S X=$P(LR0,U,6),LAB("groupName")=X,LAB("name")=$$AREA(X)
S X=+$P(LR0,U,2) S:X LAB("pathologist")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
S X=+$P(LR0,U,7) S:X LAB("provider")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
S LAB("status")=$S('$P(LR0,U,11):"incomplete",1:"completed")
S X="",I=0 F S I=$O(^LR(LRDFN,VPRSUB,VPRIDT,.1,I)) Q:I<1 S X=X_$S($L(X):", ",1:"")_$P($G(^(I,0)),U)
S:$L(X) LAB("specimen")=U_X
S LAB("facility")=$$FAC^VPRD
S NODE=$S(VPRSUB="AU":$NA(^LR(LRDFN,101)),1:$NA(^LR(LRDFN,VPRSUB,VPRIDT,.05)))
S I=0 F S I=$O(@NODE@(I)) Q:I<1 S X=+$P($G(@NODE@(I,0)),U,2) I X D
. N Y S Y=$$INFO^VPRDTIU(+X) Q:Y<1 ;draft or retracted
. S LAB("document",I)=Y
. S:$G(VPRTEXT) LAB("document",I,"content")=$$TEXT^VPRDTIU(+X)
I '$O(LAB("document",0)),$P(LR0,U,11) D ;non-TIU reports
. S LAB("document",1)=VPRSUB_";"_VPRIDT_"^LR "_$$NAME(VPRSUB)_" REPORT^LABORATORY NOTE^4697105"
. S:$G(VPRTEXT) LAB("document",1,"content")=$$TEXT(DFN,VPRSUB,VPRIDT)
Q
;
SUB(X) ; -- return string of type(s) needed for LR api
N Y S Y="",X=$G(X)
S:X["CH" Y=Y_"CH"
S:X["MI" Y=Y_"MI"
I X["AP"!(X["CY")!(X["EM")!(X["SP")!(X["AU") S Y=Y_"AP"
Q Y
;
ORDER(LABORD,TEST) ; -- return #100 order number for Lab order# & Test
N Y,D,S,T
S D=$P(9999999-VPRIDT,"."),Y=""
S S=0 F S S=$O(^LRO(69,"C",LABORD,D,S)) Q:S<1 D Q:Y
. S T=0 F S T=$O(^LRO(69,D,1,S,2,T)) Q:T<1 I 'TEST!(+$G(^(T,0))=TEST) S Y=+$P(^(0),U,7)
Q Y
;
NAME(X) ; -- Return name of subscript X
I X="AU" Q "AUTOPSY"
I X="BB" Q "BLOOD BANK"
I X="CH" Q "CHEM,HEM,TOX,RIA,SER,etc."
I X="CY" Q "CYTOPATHOLOGY"
I X="EM" Q "ELECTRON MICROSCOPY"
I X="MI" Q "MICROBIOLOGY"
I X="SP" Q "SURGICAL PATHOLOGY"
Q "ANATOMIC PATHOLOGY"
;
AREA(ACCNUM) ; -- Return name of accession area
N X,Y,VPRA
S X=$P($G(ACCNUM)," "),Y=""
I $L(X) D FIND^DIC(68,,.01,"QX",X,,,,,"VPRA")
S Y=$G(VPRA("DILIST",1,1))
Q Y
;
; ------------ Get report(s) [via VPRDTIU] ------------
;
RPTS(DFN,BEG,END,MAX) ; -- find patient's lab reports
N VPRSUB,VPRIDT,VPRITM,VPRTIU,LR0,VPRXID,LRDFN,VPRN,DA
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"))
K ^TMP("LRRR",$J,DFN) D RR^LR7OR1(DFN,,BEG,END,"AP",,,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 I $O(^(VPRIDT,0)) D
.. S VPRTIU=$S(VPRSUB="AU":$NA(^LR(LRDFN,101)),1:$NA(^LR(LRDFN,VPRSUB,VPRIDT,.05)))
.. S LR0=$S(VPRSUB="AU":$G(^LR(LRDFN,"AU")),1:$G(^LR(LRDFN,VPRSUB,VPRIDT,0)))
.. K VPRITM S VPRXID=VPRSUB_";"_VPRIDT
.. ; generate report from Lab if not in TIU
.. I '$O(@VPRTIU@(0)) D Q
... Q:'$P(LR0,U,$S(VPRSUB="AU":15,1:11)) ;Rpt Release Date
... D RPT1(DFN,VPRXID,.VPRITM),XML^VPRDTIU(.VPRITM):$D(VPRITM)
.. S VPRN=0 F S VPRN=$O(@VPRTIU@(VPRN)) Q:VPRN<1 D
... S DA=+$P($G(@VPRTIU@(VPRN,0)),U,2) Q:DA<1 K VPRITM
... Q:$$INFO^VPRDTIU(DA)<1 ;draft or retracted
... D EN1^VPRDTIU(DA,.VPRITM),XML^VPRDTIU(.VPRITM):$D(VPRITM)
K ^TMP("LRRR",$J,DFN),^TMP("VPRTEXT",$J)
Q
;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
S DFN=+$G(DFN),ID=$G(ID) Q:DFN<1 Q:'$L(ID)
N SUB,IDT,LRDFN,LR0,X,LOC
K RPT,^TMP("VPRTEXT",$J)
S SUB=$P(ID,";"),IDT=+$P(ID,";",2),LRDFN=$G(^DPT(DFN,"LR"))
S LR0=$S(SUB="AU":$G(^LR(LRDFN,"AU")),1:$G(^LR(LRDFN,SUB,IDT,0)))
S RPT("id")=ID,RPT("referenceDateTime")=9999999-IDT
S RPT("localTitle")="LR "_$$NAME(SUB)_" REPORT"
S RPT("documentClass")="LR LABORATORY REPORTS"
S RPT("nationalTitle")="4697105^LABORATORY NOTE"
S RPT("nationalTitleSubject")="4697104^LABORATORY"
S RPT("nationalTitleType")="4696120^NOTE"
S RPT("type")="LR",RPT("status")="UNRELEASED"
S:$G(FILTER("loinc")) RPT("loinc")=$P(FILTER("loinc"),U)
S X=$P(LR0,U,$S(SUB="AU":5,1:8)),LOC="" S:$L(X) LOC=+$O(^SC("B",X,0))
S RPT("facility")=$$FAC^VPRD(LOC)
I LOC D ;look-up visit
. N CDT S CDT=9999999-IDT
. S X=$$GETENC^PXAPI(DFN,CDT,LOC)
. S:X RPT("encounter")=+X
S X=+$P(LR0,U,$S(SUB="AU":10,1:2)) ;pathologist
S:X RPT("clinician",1)=X_U_$P($G(^VA(200,X,0)),U)_"^A^^^"_$$PROVSPC^VPRD(X)
; check if Report Released
S X=$S(SUB="AU":$P(LR0,U,15,16),1:$P(LR0,U,11)_U_$P(LR0,U,13)) I X D
. N Y S Y=$P(X,U,2),RPT("status")="COMPLETED"
. S RPT("clinician",2)=Y_U_$P($G(^VA(200,+Y,0)),U)_"^S^"_+X_U_$P($G(^VA(200,+Y,20)),U,2)_U_$$PROVSPC^VPRD(+Y)
. S:$G(VPRTEXT) RPT("content")=$$TEXT(DFN,SUB,IDT)
Q
;
TEXT(DFN,SUB,IDT) ; -- Get report text, return temp array name
N LRDFN,DATE,NAME,VPRS,VPRY,I,X,Y
K ^TMP("LRC",$J),^TMP("LRH",$J),^TMP("LRT",$J)
S DATE=9999999-+$G(IDT),NAME=$S(SUB="EM":"EM",1:$$NAME(SUB)),VPRS(NAME)=""
D EN^LR7OSUM(.VPRY,DFN,DATE,DATE,,,.VPRS)
S Y=$NA(^TMP("VPRTEXT",$J,SUB_";"_IDT)) K @Y
S I=+$G(^TMP("LRH",$J,NAME)) ;LRH=header
F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=$G(^(I,0)) Q:X?1."=" S @Y@(I)=X
K ^TMP("LRC",$J),^TMP("LRH",$J),^TMP("LRT",$J)
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(LAB) ; -- Return result as XML in @VPR@(#)
N ATT,X,Y,NAMES,I,J
D ADD("<accession>") 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>")
.. S NAMES=$S(ATT="document":"id^localTitle^nationalTitle^vuid^Z",ATT="value":"id^test^result^interpretation^units^low^high^localName^loinc^vuid^order^performingLab^Z",1:"code^name^Z")
.. S I=0 F S I=$O(LAB(ATT,I)) Q:I<1 D
... S X=$G(LAB(ATT,I))
... S Y="<"_ATT_" "_$$LOOP ;_"/>" D ADD(Y)
... S X=$G(LAB(ATT,I,"content")) I '$L(X) S Y=Y_"/>" D ADD(Y) Q
... S Y=Y_">" D ADD(Y)
... S Y="<content xml:space='preserve'>" D ADD(Y)
... S J=0 F S J=$O(@X@(J)) Q:J<1 S Y=$$ESC^VPRD(@X@(J)) D ADD(Y)
... D ADD("</content>"),ADD("</"_ATT_">")
.. 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
. I $L(X)>1 D S Y=""
.. S NAMES="code^name"_$S(ATT="provider"!(ATT="pathologist"):U_$$PROVTAGS^VPRD,1:"")_"^Z"
.. S Y="<"_ATT_" "_$$LOOP_"/>" D ADD(Y)
D ADD("</accession>")
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDLRA 11208 printed Sep 23, 2025@20:21:09 Page 2
VPRDLRA ;SLC/MKB -- Laboratory extract by accession ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,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(68 1963
+10 ; ^LRO(69 2407
+11 ; ^LR 525
+12 ; ^SC 10040
+13 ; ^VA(200 10060
+14 ; DIC 2051
+15 ; DIQ 2056
+16 ; LR7OR1,^TMP("LRRR",$J) 2503
+17 ; LR7OSUM,^TMP("LRC",$J), 2766
+18 ; ^TMP("LRH",$J),^TMP("LRT",$J)
+19 ; LRPXAPIU 4246
+20 ; PXAPI 1894
+21 ; XUAF4 2171
+22 ;
+23 ; ------------ Get results from VistA ------------
+24 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
+1 NEW VPRTYPE,SUB,VPRSUB,VPRIDT,VPRP,VPRITM,LRDFN,LR0,ORD,X,I
+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 VPRTYPE=$GET(FILTER("type"),"CH;MI;CY;EM;SP;AU")
+5 SET LRDFN=$GET(^DPT(DFN,"LR"))
SET SUB=$$SUB(VPRTYPE)
+6 KILL ^TMP("LRRR",$JOB,DFN)
+7 ;
+8 ; get result(s)
+9 ;reset search parameters
IF $LENGTH($GET(ID))
Begin DoDot:1
+10 SET SUB=$PIECE(ID,";")
SET VPRIDT=+$PIECE(ID,";",2)
+11 if VPRIDT
SET (BEG,END)=9999999-VPRIDT
+12 if "CH^MI"'[SUB
SET SUB="AP"
End DoDot:1
+13 ;
+14 DO RR^LR7OR1(DFN,,BEG,END,SUB,,,MAX)
+15 SET VPRSUB=""
FOR
SET VPRSUB=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB))
if VPRSUB=""
QUIT
Begin DoDot:1
+16 ;requested types only
if $GET(VPRTYPE)'[VPRSUB
QUIT
+17 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT))
if VPRIDT<1
QUIT
IF $ORDER(^(VPRIDT,0))
Begin DoDot:2
+18 KILL VPRITM,ORD,CMMT,^TMP("VPRTEXT",$JOB)
+19 IF "CH^MI"'[VPRSUB
DO AP(.VPRITM)
DO XML(.VPRITM)
QUIT
+20 SET VPRITM("type")=VPRSUB
SET VPRITM("id")=VPRSUB_";"_VPRIDT
+21 SET VPRITM("collected")=9999999-VPRIDT
SET VPRITM("status")="completed"
+22 SET LR0=$GET(^LR(LRDFN,VPRSUB,VPRIDT,0))
+23 SET VPRITM("resulted")=$PIECE(LR0,U,3)
SET X=+$PIECE(LR0,U,5)
IF X
Begin DoDot:3
+24 NEW IENS,VPRY
SET IENS=X_","
+25 DO GETS^DIQ(61,IENS,".01;2;4.1",,"VPRY")
+26 ;SNOMED^name
SET VPRITM("specimen")=$GET(VPRY(61,IENS,2))_U_$GET(VPRY(61,IENS,.01))
+27 ;name
SET VPRITM("sample")=$GET(VPRY(61,IENS,4.1))
End DoDot:3
+28 SET X=$PIECE(LR0,U,6)
SET VPRITM("name")=$$AREA(X)
SET VPRITM("groupName")=X
+29 SET I=$SELECT(VPRSUB="CH":10,1:7)
SET X=+$PIECE(LR0,U,I)
+30 if X
SET VPRITM("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
+31 SET X=+$PIECE(LR0,U,14)
if X
SET VPRITM("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+32 ;local stn#^name
IF 'X
SET VPRITM("facility")=$$FAC^VPRD
+33 ;report
IF VPRSUB="MI"
Begin DoDot:3
+34 IF '$PIECE(LR0,U,3)
SET VPRITM("status")="incomplete"
QUIT
+35 SET VPRITM("document",1)=VPRSUB_";"_VPRIDT_"^LR MICROBIOLOGY REPORT^LABORATORY NOTE^4697105"
+36 if $GET(VPRTEXT)
SET VPRITM("document",1,"content")=$$TEXT(DFN,VPRSUB,VPRIDT)
End DoDot:3
+37 SET VPRP=0
FOR
SET VPRP=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT,VPRP))
if VPRP<1
QUIT
Begin DoDot:3
+38 SET X=$SELECT(VPRSUB="MI":$$MI,1:$$CH)
+39 if $LENGTH(X)
SET VPRITM("value",VPRP)=X
+40 if $GET(ORD)
SET VPRITM("labOrderID")=ORD
End DoDot:3
+41 IF $DATA(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT,"N"))
MERGE CMMT=^("N")
SET VPRITM("comment")=$$STRING^VPRD(.CMMT)
+42 DO XML(.VPRITM)
End DoDot:2
End DoDot:1
+43 KILL ^TMP("LRRR",$JOB,DFN),^TMP("VPRTEXT",$JOB)
+44 QUIT
+45 ;
CH() ; -- return a Chemistry result as:
+1 ; id^test^result^interpretation^units^low^high^localName^loinc^vuid^order^performingLab
+2 ; Expects ^TMP("LRRR",$J,DFN,"CH",VPRIDT,VPRP),LRDFN
+3 NEW X,Y,X0,VPRN,NODE,CMMT,LOINC
+4 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"CH",VPRIDT,VPRP))
SET VPRN=$$LRDN^LRPXAPIU(+X0)
+5 SET NODE=$GET(^LR(LRDFN,"CH",VPRIDT,VPRN))
+6 SET X=$PIECE($GET(^LAB(60,+X0,0)),U)
+7 SET Y="CH;"_VPRIDT_";"_VPRN_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 ;test short name
SET $PIECE(Y,U,8)=$PIECE(X0,U,15)
+10 SET X=$PIECE($PIECE(NODE,U,3),"!",3)
if X
SET LOINC=$$GET1^DIQ(95.3,X_",",.01)
+11 if $GET(LOINC)
SET $PIECE(Y,U,9,10)=LOINC_U_$$VUID^VPRD(+LOINC,95.3)
+12 SET ORD=+$PIECE(X0,U,17)
SET X=$$ORDER(ORD,+X0)
if X
SET $PIECE(Y,U,11)=X
+13 ;performing lab
SET X=+$PIECE(NODE,U,9)
if X
SET $PIECE(Y,U,12)=$$NAME^XUAF4(X)
+14 QUIT Y
+15 ;
MI() ; -- return a Microbiology result as:
+1 ; id^test^result^interpretation^units
+2 ; Expects ^TMP("LRRR",$J,DFN,"MI",VPRIDT,VPRP)
+3 NEW Y,X0
+4 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"MI",VPRIDT,VPRP))
SET Y=""
+5 if $LENGTH($PIECE(X0,U))>1
SET Y="MI;"_VPRIDT_";"_VPRP_U_$PIECE(X0,U,1,4)
+6 SET ORD=+$PIECE(X0,U,17)
+7 QUIT Y
+8 ;
AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
+1 NEW LR0,X,I,NODE
+2 SET LR0=$GET(^LR(LRDFN,VPRSUB,VPRIDT,0))
IF VPRSUB="AU"
Begin DoDot:1
+3 ;set pieces needed into LR0
NEW AU
SET AU=$GET(^LR(LRDFN,"AU"))
+4 SET LR0=+AU_U_$PIECE(AU,U,10)_"^^^^"_$PIECE(AU,U,6)_U_$PIECE(AU,U,12)_"^^^^"_$PIECE(AU,U,15)
End DoDot:1
+5 SET LAB("type")=VPRSUB
SET LAB("id")=VPRSUB_";"_VPRIDT
+6 SET LAB("collected")=9999999-VPRIDT
SET LAB("resulted")=$PIECE(LR0,U,11)
+7 SET X=$PIECE(LR0,U,6)
SET LAB("groupName")=X
SET LAB("name")=$$AREA(X)
+8 SET X=+$PIECE(LR0,U,2)
if X
SET LAB("pathologist")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
+9 SET X=+$PIECE(LR0,U,7)
if X
SET LAB("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
+10 SET LAB("status")=$SELECT('$PIECE(LR0,U,11):"incomplete",1:"completed")
+11 SET X=""
SET I=0
FOR
SET I=$ORDER(^LR(LRDFN,VPRSUB,VPRIDT,.1,I))
if I<1
QUIT
SET X=X_$SELECT($LENGTH(X):", ",1:"")_$PIECE($GET(^(I,0)),U)
+12 if $LENGTH(X)
SET LAB("specimen")=U_X
+13 SET LAB("facility")=$$FAC^VPRD
+14 SET NODE=$SELECT(VPRSUB="AU":$NAME(^LR(LRDFN,101)),1:$NAME(^LR(LRDFN,VPRSUB,VPRIDT,.05)))
+15 SET I=0
FOR
SET I=$ORDER(@NODE@(I))
if I<1
QUIT
SET X=+$PIECE($GET(@NODE@(I,0)),U,2)
IF X
Begin DoDot:1
+16 ;draft or retracted
NEW Y
SET Y=$$INFO^VPRDTIU(+X)
if Y<1
QUIT
+17 SET LAB("document",I)=Y
+18 if $GET(VPRTEXT)
SET LAB("document",I,"content")=$$TEXT^VPRDTIU(+X)
End DoDot:1
+19 ;non-TIU reports
IF '$ORDER(LAB("document",0))
IF $PIECE(LR0,U,11)
Begin DoDot:1
+20 SET LAB("document",1)=VPRSUB_";"_VPRIDT_"^LR "_$$NAME(VPRSUB)_" REPORT^LABORATORY NOTE^4697105"
+21 if $GET(VPRTEXT)
SET LAB("document",1,"content")=$$TEXT(DFN,VPRSUB,VPRIDT)
End DoDot:1
+22 QUIT
+23 ;
SUB(X) ; -- return string of type(s) needed for LR api
+1 NEW Y
SET Y=""
SET X=$GET(X)
+2 if X["CH"
SET Y=Y_"CH"
+3 if X["MI"
SET Y=Y_"MI"
+4 IF X["AP"!(X["CY")!(X["EM")!(X["SP")!(X["AU")
SET Y=Y_"AP"
+5 QUIT Y
+6 ;
ORDER(LABORD,TEST) ; -- return #100 order number for Lab order# & Test
+1 NEW Y,D,S,T
+2 SET D=$PIECE(9999999-VPRIDT,".")
SET Y=""
+3 SET S=0
FOR
SET S=$ORDER(^LRO(69,"C",LABORD,D,S))
if S<1
QUIT
Begin DoDot:1
+4 SET T=0
FOR
SET T=$ORDER(^LRO(69,D,1,S,2,T))
if T<1
QUIT
IF 'TEST!(+$GET(^(T,0))=TEST)
SET Y=+$PIECE(^(0),U,7)
End DoDot:1
if Y
QUIT
+5 QUIT Y
+6 ;
NAME(X) ; -- Return name of subscript X
+1 IF X="AU"
QUIT "AUTOPSY"
+2 IF X="BB"
QUIT "BLOOD BANK"
+3 IF X="CH"
QUIT "CHEM,HEM,TOX,RIA,SER,etc."
+4 IF X="CY"
QUIT "CYTOPATHOLOGY"
+5 IF X="EM"
QUIT "ELECTRON MICROSCOPY"
+6 IF X="MI"
QUIT "MICROBIOLOGY"
+7 IF X="SP"
QUIT "SURGICAL PATHOLOGY"
+8 QUIT "ANATOMIC PATHOLOGY"
+9 ;
AREA(ACCNUM) ; -- Return name of accession area
+1 NEW X,Y,VPRA
+2 SET X=$PIECE($GET(ACCNUM)," ")
SET Y=""
+3 IF $LENGTH(X)
DO FIND^DIC(68,,.01,"QX",X,,,,,"VPRA")
+4 SET Y=$GET(VPRA("DILIST",1,1))
+5 QUIT Y
+6 ;
+7 ; ------------ Get report(s) [via VPRDTIU] ------------
+8 ;
RPTS(DFN,BEG,END,MAX) ; -- find patient's lab reports
+1 NEW VPRSUB,VPRIDT,VPRITM,VPRTIU,LR0,VPRXID,LRDFN,VPRN,DA
+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"))
+5 KILL ^TMP("LRRR",$JOB,DFN)
DO RR^LR7OR1(DFN,,BEG,END,"AP",,,MAX)
+6 SET VPRSUB=""
FOR
SET VPRSUB=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB))
if VPRSUB=""
QUIT
Begin DoDot:1
+7 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT))
if VPRIDT<1
QUIT
IF $ORDER(^(VPRIDT,0))
Begin DoDot:2
+8 SET VPRTIU=$SELECT(VPRSUB="AU":$NAME(^LR(LRDFN,101)),1:$NAME(^LR(LRDFN,VPRSUB,VPRIDT,.05)))
+9 SET LR0=$SELECT(VPRSUB="AU":$GET(^LR(LRDFN,"AU")),1:$GET(^LR(LRDFN,VPRSUB,VPRIDT,0)))
+10 KILL VPRITM
SET VPRXID=VPRSUB_";"_VPRIDT
+11 ; generate report from Lab if not in TIU
+12 IF '$ORDER(@VPRTIU@(0))
Begin DoDot:3
+13 ;Rpt Release Date
if '$PIECE(LR0,U,$SELECT(VPRSUB="AU"
QUIT
+14 DO RPT1(DFN,VPRXID,.VPRITM)
if $DATA(VPRITM)
DO XML^VPRDTIU(.VPRITM)
End DoDot:3
QUIT
+15 SET VPRN=0
FOR
SET VPRN=$ORDER(@VPRTIU@(VPRN))
if VPRN<1
QUIT
Begin DoDot:3
+16 SET DA=+$PIECE($GET(@VPRTIU@(VPRN,0)),U,2)
if DA<1
QUIT
KILL VPRITM
+17 ;draft or retracted
if $$INFO^VPRDTIU(DA)<1
QUIT
+18 DO EN1^VPRDTIU(DA,.VPRITM)
if $DATA(VPRITM)
DO XML^VPRDTIU(.VPRITM)
End DoDot:3
End DoDot:2
End DoDot:1
+19 KILL ^TMP("LRRR",$JOB,DFN),^TMP("VPRTEXT",$JOB)
+20 QUIT
+21 ;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
+1 SET DFN=+$GET(DFN)
SET ID=$GET(ID)
if DFN<1
QUIT
if '$LENGTH(ID)
QUIT
+2 NEW SUB,IDT,LRDFN,LR0,X,LOC
+3 KILL RPT,^TMP("VPRTEXT",$JOB)
+4 SET SUB=$PIECE(ID,";")
SET IDT=+$PIECE(ID,";",2)
SET LRDFN=$GET(^DPT(DFN,"LR"))
+5 SET LR0=$SELECT(SUB="AU":$GET(^LR(LRDFN,"AU")),1:$GET(^LR(LRDFN,SUB,IDT,0)))
+6 SET RPT("id")=ID
SET RPT("referenceDateTime")=9999999-IDT
+7 SET RPT("localTitle")="LR "_$$NAME(SUB)_" REPORT"
+8 SET RPT("documentClass")="LR LABORATORY REPORTS"
+9 SET RPT("nationalTitle")="4697105^LABORATORY NOTE"
+10 SET RPT("nationalTitleSubject")="4697104^LABORATORY"
+11 SET RPT("nationalTitleType")="4696120^NOTE"
+12 SET RPT("type")="LR"
SET RPT("status")="UNRELEASED"
+13 if $GET(FILTER("loinc"))
SET RPT("loinc")=$PIECE(FILTER("loinc"),U)
+14 SET X=$PIECE(LR0,U,$SELECT(SUB="AU":5,1:8))
SET LOC=""
if $LENGTH(X)
SET LOC=+$ORDER(^SC("B",X,0))
+15 SET RPT("facility")=$$FAC^VPRD(LOC)
+16 ;look-up visit
IF LOC
Begin DoDot:1
+17 NEW CDT
SET CDT=9999999-IDT
+18 SET X=$$GETENC^PXAPI(DFN,CDT,LOC)
+19 if X
SET RPT("encounter")=+X
End DoDot:1
+20 ;pathologist
SET X=+$PIECE(LR0,U,$SELECT(SUB="AU":10,1:2))
+21 if X
SET RPT("clinician",1)=X_U_$PIECE($GET(^VA(200,X,0)),U)_"^A^^^"_$$PROVSPC^VPRD(X)
+22 ; check if Report Released
+23 SET X=$SELECT(SUB="AU":$PIECE(LR0,U,15,16),1:$PIECE(LR0,U,11)_U_$PIECE(LR0,U,13))
IF X
Begin DoDot:1
+24 NEW Y
SET Y=$PIECE(X,U,2)
SET RPT("status")="COMPLETED"
+25 SET RPT("clinician",2)=Y_U_$PIECE($GET(^VA(200,+Y,0)),U)_"^S^"_+X_U_$PIECE($GET(^VA(200,+Y,20)),U,2)_U_$$PROVSPC^VPRD(+Y)
+26 if $GET(VPRTEXT)
SET RPT("content")=$$TEXT(DFN,SUB,IDT)
End DoDot:1
+27 QUIT
+28 ;
TEXT(DFN,SUB,IDT) ; -- Get report text, return temp array name
+1 NEW LRDFN,DATE,NAME,VPRS,VPRY,I,X,Y
+2 KILL ^TMP("LRC",$JOB),^TMP("LRH",$JOB),^TMP("LRT",$JOB)
+3 SET DATE=9999999-+$GET(IDT)
SET NAME=$SELECT(SUB="EM":"EM",1:$$NAME(SUB))
SET VPRS(NAME)=""
+4 DO EN^LR7OSUM(.VPRY,DFN,DATE,DATE,,,.VPRS)
+5 SET Y=$NAME(^TMP("VPRTEXT",$JOB,SUB_";"_IDT))
KILL @Y
+6 ;LRH=header
SET I=+$GET(^TMP("LRH",$JOB,NAME))
+7 FOR
SET I=$ORDER(^TMP("LRC",$JOB,I))
if I<1
QUIT
SET X=$GET(^(I,0))
if X?1."="
QUIT
SET @Y@(I)=X
+8 KILL ^TMP("LRC",$JOB),^TMP("LRH",$JOB),^TMP("LRT",$JOB)
+9 QUIT Y
+10 ;
+11 ; ------------ Return data to middle tier ------------
+12 ;
XML(LAB) ; -- Return result as XML in @VPR@(#)
+1 NEW ATT,X,Y,NAMES,I,J
+2 DO ADD("<accession>")
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 SET NAMES=$SELECT(ATT="document":"id^localTitle^nationalTitle^vuid^Z",ATT="value":"id^test^result^interpretation^units^low^high^localName^loinc^vuid^order^performingLab^Z",1:"code^name^Z")
+7 SET I=0
FOR
SET I=$ORDER(LAB(ATT,I))
if I<1
QUIT
Begin DoDot:3
+8 SET X=$GET(LAB(ATT,I))
+9 ;_"/>" D ADD(Y)
SET Y="<"_ATT_" "_$$LOOP
+10 SET X=$GET(LAB(ATT,I,"content"))
IF '$LENGTH(X)
SET Y=Y_"/>"
DO ADD(Y)
QUIT
+11 SET Y=Y_">"
DO ADD(Y)
+12 SET Y="<content xml:space='preserve'>"
DO ADD(Y)
+13 SET J=0
FOR
SET J=$ORDER(@X@(J))
if J<1
QUIT
SET Y=$$ESC^VPRD(@X@(J))
DO ADD(Y)
+14 DO ADD("</content>")
DO ADD("</"_ATT_">")
End DoDot:3
+15 DO ADD("</"_ATT_"s>")
End DoDot:2
SET Y=""
QUIT
+16 SET X=$GET(LAB(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+17 IF ATT="comment"
SET Y="<"_ATT_" xml:space='preserve'>"_$$ESC^VPRD(X)_"</"_ATT_">"
QUIT
+18 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+19 IF $LENGTH(X)>1
Begin DoDot:2
+20 SET NAMES="code^name"_$SELECT(ATT="provider"!(ATT="pathologist"):U_$$PROVTAGS^VPRD,1:"")_"^Z"
+21 SET Y="<"_ATT_" "_$$LOOP_"/>"
DO ADD(Y)
End DoDot:2
SET Y=""
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+22 DO ADD("</accession>")
+23 QUIT
+24 ;
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
