HMPDLRA ;SLC/MKB,ASMR/RRB,BL - Laboratory extract by accession;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; ^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)
; LR7OSAP4 4989
; ORX8 2467
; PXAPI 1894
; XUAF4 2171
Q
; ------------ Get results from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
N HMPSUB,HMPIDT,HMPN,HMPITM,LRDFN,LR0,ORD,X
S DFN=+$G(DFN) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q ;DE4496 19 August 2016
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
S HMPSUB=$G(FILTER("type")),LRDFN=$$LRDFN^HMPXGLAB(DFN) ;DE2818, (#63) LABORATORY REFERENCE
K ^TMP("LRRR",$J,DFN)
;
; get result(s)
I $L($G(ID)) D ;reset search parameters
. S HMPSUB=$P(ID,";"),HMPIDT=+$P(ID,";",2)
. S:HMPIDT (BEG,END)=9999999-HMPIDT
;
D RR^LR7OR1(DFN,,BEG,END,HMPSUB,,,MAX)
S HMPSUB="" F S HMPSUB=$O(^TMP("LRRR",$J,DFN,HMPSUB)) Q:HMPSUB="" D
. S HMPIDT=0 F S HMPIDT=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT)) Q:HMPIDT<1 I $O(^(HMPIDT,0)) D
.. K HMPITM,ORD,CMMT,^TMP("HMPTEXT",$J)
.. I "CH^MI"'[HMPSUB D AP(.HMPITM),XML(.HMPITM) Q
.. S HMPITM("type")=HMPSUB,HMPITM("id")=HMPSUB_";"_HMPIDT
.. S HMPITM("collected")=9999999-HMPIDT,HMPITM("status")="completed"
.. S LR0=$G(^LR(LRDFN,HMPSUB,HMPIDT,0))
.. S HMPITM("resulted")=$P(LR0,U,3),X=+$P(LR0,U,5) I X D
... N IENS,HMPY S IENS=X_","
... D GETS^DIQ(61,IENS,".01;2;4.1",,"HMPY")
... S HMPITM("specimen")=$G(HMPY(61,IENS,2))_U_$G(HMPY(61,IENS,.01)) ;SNOMED^name
... S HMPITM("sample")=$G(HMPY(61,IENS,4.1)) ;name
.. S X=$P(LR0,U,6),HMPITM("name")=$$AREA(X),HMPITM("groupName")=X
.. S X=+$P(LR0,U,14) S:X HMPITM("facility")=$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U)
.. I 'X S HMPITM("facility")=$$FAC^HMPD ;local stn#^name
.. I HMPSUB="MI" D ;report
... S HMPITM("document",1)=HMPSUB_";"_HMPIDT_"^LR MICROBIOLOGY REPORT^LABORATORY NOTE"
... S:$G(HMPTEXT) HMPITM("document",1,"content")=$$TEXT(DFN,HMPSUB,HMPIDT)
.. S HMPN=0 F S HMPN=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT,HMPN)) Q:HMPN<1 D
... S X=$S(HMPSUB="MI":$$MI,1:$$CH)
... S:$L(X) HMPITM("value",HMPN)=X
... S:$G(ORD) HMPITM("labOrderID")=ORD
.. I $D(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT,"N")) M CMMT=^("N") S HMPITM("comment")=$$STRING^HMPD(.CMMT)
.. D XML(.HMPITM)
K ^TMP("LRRR",$J,DFN),^TMP("HMPTEXT",$J)
Q
;
CH() ; -- return a Chemistry result as:
; id^test^result^interpretation^units^low^high^localName^loinc^vuid^order
; Expects ^TMP("LRRR",$J,DFN,"CH",HMPIDT,HMPN),LRDFN
N X,Y,X0,NODE,CMMT,LOINC
S X0=$G(^TMP("LRRR",$J,DFN,"CH",HMPIDT,HMPN)),NODE=$G(^LR(LRDFN,"CH",HMPIDT,HMPN))
S X=$$LABTSTNM^HMPXGLAB(+X0) ; DE2818
S Y="CH;"_HMPIDT_";"_HMPN_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^HMPD(+LOINC,95.3)
S ORD=+$P(X0,U,17),X=$$ORDER(ORD,+X0) S:X $P(Y,U,11)=X
Q Y
;
MI() ; -- return a Microbiology result as:
; id^test^result^interpretation^units
; Expects ^TMP("LRRR",$J,DFN,"MI",HMPIDT,HMPN)
N Y,X0
S X0=$G(^TMP("LRRR",$J,DFN,"MI",HMPIDT,HMPN)),Y=""
S:$L($P(X0,U))>1 Y="MI;"_HMPIDT_";"_HMPN_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,HMPSUB,HMPIDT,0))
S LAB("type")=HMPSUB,LAB("id")=HMPSUB_";"_HMPIDT
S LAB("collected")=9999999-HMPIDT,LAB("status")="completed"
S LAB("resulted")=$P(LR0,U,11),LAB("groupName")=$P(LR0,U,6)
S X="",I=0 F S I=$O(^LR(LRDFN,HMPSUB,HMPIDT,.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^HMPD
S NODE=$S(HMPSUB="AU":$NA(^LR(LRDFN,101)),1:$NA(^LR(LRDFN,HMPSUB,HMPIDT,.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 LT,NT,HMPY
. S LT=$$GET1^DIQ(8925,+X_",",.01) Q:$P(LT," ")="Addendum"
. S NT=$$GET1^DIQ(8925,+X_",",".01:1501") S:NT="" NT="LABORATORY NOTE"
. S LAB("document",I)=+X_U_LT_U_NT
. S:$G(HMPTEXT) LAB("document",I,"content")=$$TEXT^HMPDTIU(+X)
I '$O(LAB("document",0)) D ;non-TIU reports
. S LAB("document",1)=HMPSUB_";"_HMPIDT_"^LR "_$$NAME(HMPSUB)_" REPORT^LABORATORY NOTE"
. S:$G(HMPTEXT) LAB("document",1,"content")=$$TEXT(DFN,HMPSUB,HMPIDT)
Q
;
ORDER(LABORD,TEST) ; -- return #100 order^name for Lab order# & Test
N Y,D,S,T
S D=$P(9999999-HMPIDT,"."),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)
;I Y S Y=Y_U_$P($$OI^ORX8(Y),U,2)
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,HMPA
S X=$P($G(ACCNUM)," "),Y=""
I $L(X) D FIND^DIC(68,,.01,"QX",X,,,,,"HMPA")
S Y=$G(HMPA("DILIST",1,1))
Q Y
;
; ------------ Get report(s) [via HMPDTIU] ------------
;
RPTS(DFN,BEG,END,MAX) ; -- find patient's lab reports
N HMPSUB,HMPIDT,HMPITM,HMPTIU,HMPXID,LRDFN,HMPN,DA
S DFN=+$G(DFN) Q:$G(DFN)<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
S LRDFN=$$LRDFN^HMPXGLAB(DFN) ;DE2818, (#63) LABORATORY REFERENCE
K ^TMP("LRRR",$J,DFN) D RR^LR7OR1(DFN,,BEG,END,"AP",,,MAX)
S HMPSUB="" F S HMPSUB=$O(^TMP("LRRR",$J,DFN,HMPSUB)) Q:HMPSUB="" D
. S HMPIDT=0 F S HMPIDT=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT)) Q:HMPIDT<1 I $O(^(HMPIDT,0)) D
.. S HMPTIU=$S(HMPSUB="AU":$NA(^LR(LRDFN,101)),1:$NA(^LR(LRDFN,HMPSUB,HMPIDT,.05)))
.. K HMPITM S HMPXID=HMPSUB_";"_HMPIDT
.. I '$O(@HMPTIU@(0)) D RPT1(DFN,HMPXID,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM) Q
.. S HMPN=0 F S HMPN=$O(@HMPTIU@(HMPN)) Q:HMPN<1 D
... S DA=+$P($G(@HMPTIU@(HMPN,0)),U,2) Q:DA<1 K HMPITM
... D EN1^HMPDTIU(DA,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM)
K ^TMP("LRRR",$J,DFN),^TMP("HMPTEXT",$J)
Q
;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
S DFN=+$G(DFN),ID=$G(ID) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q ;DE4496 19 August 2016
Q:'$L(ID)
N SUB,IDT,LRDFN,LR0,X,LOC
K RPT,^TMP("HMPTEXT",$J)
S SUB=$P(ID,";"),IDT=+$P(ID,";",2),LRDFN=$$LRDFN^HMPXGLAB(DFN) ;DE2818, (#63) LABORATORY REFERENCE
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")="COMPLETED"
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)) ;DE2818, ***fix needed to get location IEN***
S RPT("facility")=$$FAC^HMPD(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_$$GET1^DIQ(200,X_",",.01)_"^A" ;DE2818, changed global read to FileMan
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)
. ;DE2818, changed global read to FileMan - (#.01) NAME and (#1) INITIAL
. S RPT("clinician",2)=Y_U_$$GET1^DIQ(200,+Y_",",.01)_"^S^"_+X_U_$$GET1^DIQ(200,+Y_",",1)
S:$G(HMPTEXT) RPT("content")=$$TEXT(DFN,SUB,IDT)
Q
;
TEXT(DFN,SUB,IDT,LRDFN) ; -- Get report text, return temp array name
N DATE,NAME,HMPS,HMPY,I,X,Y
K ^TMP("LRC",$J),^TMP("LRH",$J),^TMP("LRT",$J)
S DATE=9999999-$G(IDT),NAME=$$NAME(SUB),HMPS(NAME)=""
;The ^LR7OSUM API is not returning correct data for all entries. The ^LR7OSAP4 API (which is what CPRS uses)
;does return correct entries where ^LR7OSUM fails, but it only returns data for lab result subscripts
;"EM", "SP", and "CY". Therefore, if we can, call the ^LR7OSAP4 API for data, and fall back to ^LR7OSUM
;otherwise.
S SUB=$G(SUB) D ; Make sure SUB is defined
. ;If LRDFN and SUB is correct, call new API
. I $G(LRDFN),SUB="EM"!(SUB="SP")!(SUB="CY") D EN^LR7OSAP4($NA(^TMP("LRC",$J)),LRDFN,SUB,IDT) Q
. ;Otherwise, call old API
. D EN^LR7OSUM(.HMPY,DFN,DATE,DATE,,,.HMPS)
S Y=$NA(^TMP("HMPTEXT",$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 @HMP@(#)
N ATT,X,Y,NAMES,I,J
D ADD("<accession>") S HMPTOTL=$G(HMPTOTL)+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^Z",ATT="value":"id^test^result^interpretation^units^low^high^localName^loinc^vuid^order^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^HMPD(@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^HMPD(X)_"</"_ATT_">" Q
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />" Q
. I $L(X)>1 D S Y=""
.. S NAMES="code^name^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^HMPD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; -- Add a line @HMP@(n)=X
S HMPI=$G(HMPI)+1
S @HMP@(HMPI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDLRA 10833 printed Sep 23, 2025@19:29:42 Page 2
HMPDLRA ;SLC/MKB,ASMR/RRB,BL - Laboratory extract by accession;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; ^LAB(61 524
+8 ; ^LRO(68 1963
+9 ; ^LRO(69 2407
+10 ; ^LR 525
+11 ; ^SC 10040
+12 ; ^VA(200 10060
+13 ; DIC 2051
+14 ; DIQ 2056
+15 ; LR7OR1,^TMP("LRRR",$J) 2503
+16 ; LR7OSUM,^TMP("LRC",$J), 2766
+17 ; ^TMP("LRH",$J),^TMP("LRT",$J)
+18 ; LR7OSAP4 4989
+19 ; ORX8 2467
+20 ; PXAPI 1894
+21 ; XUAF4 2171
+22 QUIT
+23 ; ------------ Get results from VistA ------------
+24 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
+1 NEW HMPSUB,HMPIDT,HMPN,HMPITM,LRDFN,LR0,ORD,X
+2 ;DE4496 19 August 2016
SET DFN=+$GET(DFN)
IF '(DFN>0)
DO LOGDPT^HMPLOG(DFN)
QUIT
+3 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+4 ;DE2818, (#63) LABORATORY REFERENCE
SET HMPSUB=$GET(FILTER("type"))
SET LRDFN=$$LRDFN^HMPXGLAB(DFN)
+5 KILL ^TMP("LRRR",$JOB,DFN)
+6 ;
+7 ; get result(s)
+8 ;reset search parameters
IF $LENGTH($GET(ID))
Begin DoDot:1
+9 SET HMPSUB=$PIECE(ID,";")
SET HMPIDT=+$PIECE(ID,";",2)
+10 if HMPIDT
SET (BEG,END)=9999999-HMPIDT
End DoDot:1
+11 ;
+12 DO RR^LR7OR1(DFN,,BEG,END,HMPSUB,,,MAX)
+13 SET HMPSUB=""
FOR
SET HMPSUB=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB))
if HMPSUB=""
QUIT
Begin DoDot:1
+14 SET HMPIDT=0
FOR
SET HMPIDT=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB,HMPIDT))
if HMPIDT<1
QUIT
IF $ORDER(^(HMPIDT,0))
Begin DoDot:2
+15 KILL HMPITM,ORD,CMMT,^TMP("HMPTEXT",$JOB)
+16 IF "CH^MI"'[HMPSUB
DO AP(.HMPITM)
DO XML(.HMPITM)
QUIT
+17 SET HMPITM("type")=HMPSUB
SET HMPITM("id")=HMPSUB_";"_HMPIDT
+18 SET HMPITM("collected")=9999999-HMPIDT
SET HMPITM("status")="completed"
+19 SET LR0=$GET(^LR(LRDFN,HMPSUB,HMPIDT,0))
+20 SET HMPITM("resulted")=$PIECE(LR0,U,3)
SET X=+$PIECE(LR0,U,5)
IF X
Begin DoDot:3
+21 NEW IENS,HMPY
SET IENS=X_","
+22 DO GETS^DIQ(61,IENS,".01;2;4.1",,"HMPY")
+23 ;SNOMED^name
SET HMPITM("specimen")=$GET(HMPY(61,IENS,2))_U_$GET(HMPY(61,IENS,.01))
+24 ;name
SET HMPITM("sample")=$GET(HMPY(61,IENS,4.1))
End DoDot:3
+25 SET X=$PIECE(LR0,U,6)
SET HMPITM("name")=$$AREA(X)
SET HMPITM("groupName")=X
+26 SET X=+$PIECE(LR0,U,14)
if X
SET HMPITM("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+27 ;local stn#^name
IF 'X
SET HMPITM("facility")=$$FAC^HMPD
+28 ;report
IF HMPSUB="MI"
Begin DoDot:3
+29 SET HMPITM("document",1)=HMPSUB_";"_HMPIDT_"^LR MICROBIOLOGY REPORT^LABORATORY NOTE"
+30 if $GET(HMPTEXT)
SET HMPITM("document",1,"content")=$$TEXT(DFN,HMPSUB,HMPIDT)
End DoDot:3
+31 SET HMPN=0
FOR
SET HMPN=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB,HMPIDT,HMPN))
if HMPN<1
QUIT
Begin DoDot:3
+32 SET X=$SELECT(HMPSUB="MI":$$MI,1:$$CH)
+33 if $LENGTH(X)
SET HMPITM("value",HMPN)=X
+34 if $GET(ORD)
SET HMPITM("labOrderID")=ORD
End DoDot:3
+35 IF $DATA(^TMP("LRRR",$JOB,DFN,HMPSUB,HMPIDT,"N"))
MERGE CMMT=^("N")
SET HMPITM("comment")=$$STRING^HMPD(.CMMT)
+36 DO XML(.HMPITM)
End DoDot:2
End DoDot:1
+37 KILL ^TMP("LRRR",$JOB,DFN),^TMP("HMPTEXT",$JOB)
+38 QUIT
+39 ;
CH() ; -- return a Chemistry result as:
+1 ; id^test^result^interpretation^units^low^high^localName^loinc^vuid^order
+2 ; Expects ^TMP("LRRR",$J,DFN,"CH",HMPIDT,HMPN),LRDFN
+3 NEW X,Y,X0,NODE,CMMT,LOINC
+4 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"CH",HMPIDT,HMPN))
SET NODE=$GET(^LR(LRDFN,"CH",HMPIDT,HMPN))
+5 ; DE2818
SET X=$$LABTSTNM^HMPXGLAB(+X0)
+6 SET Y="CH;"_HMPIDT_";"_HMPN_U_X_U_$PIECE(X0,U,2,4)
+7 SET X=$PIECE(X0,U,5)
IF $LENGTH(X)
IF X["-"
SET X=$TRANSLATE(X,"- ","^")
SET $PIECE(Y,U,6,7)=X
+8 ;test short name
SET $PIECE(Y,U,8)=$PIECE(X0,U,15)
+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,9,10)=LOINC_U_$$VUID^HMPD(+LOINC,95.3)
+11 SET ORD=+$PIECE(X0,U,17)
SET X=$$ORDER(ORD,+X0)
if X
SET $PIECE(Y,U,11)=X
+12 QUIT Y
+13 ;
MI() ; -- return a Microbiology result as:
+1 ; id^test^result^interpretation^units
+2 ; Expects ^TMP("LRRR",$J,DFN,"MI",HMPIDT,HMPN)
+3 NEW Y,X0
+4 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"MI",HMPIDT,HMPN))
SET Y=""
+5 if $LENGTH($PIECE(X0,U))>1
SET Y="MI;"_HMPIDT_";"_HMPN_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,HMPSUB,HMPIDT,0))
+3 SET LAB("type")=HMPSUB
SET LAB("id")=HMPSUB_";"_HMPIDT
+4 SET LAB("collected")=9999999-HMPIDT
SET LAB("status")="completed"
+5 SET LAB("resulted")=$PIECE(LR0,U,11)
SET LAB("groupName")=$PIECE(LR0,U,6)
+6 SET X=""
SET I=0
FOR
SET I=$ORDER(^LR(LRDFN,HMPSUB,HMPIDT,.1,I))
if I<1
QUIT
SET X=X_$SELECT($LENGTH(X):", ",1:"")_$PIECE($GET(^(I,0)),U)
+7 if $LENGTH(X)
SET LAB("specimen")=U_X
+8 SET LAB("facility")=$$FAC^HMPD
+9 SET NODE=$SELECT(HMPSUB="AU":$NAME(^LR(LRDFN,101)),1:$NAME(^LR(LRDFN,HMPSUB,HMPIDT,.05)))
+10 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
+11 NEW LT,NT,HMPY
+12 SET LT=$$GET1^DIQ(8925,+X_",",.01)
if $PIECE(LT," ")="Addendum"
QUIT
+13 SET NT=$$GET1^DIQ(8925,+X_",",".01:1501")
if NT=""
SET NT="LABORATORY NOTE"
+14 SET LAB("document",I)=+X_U_LT_U_NT
+15 if $GET(HMPTEXT)
SET LAB("document",I,"content")=$$TEXT^HMPDTIU(+X)
End DoDot:1
+16 ;non-TIU reports
IF '$ORDER(LAB("document",0))
Begin DoDot:1
+17 SET LAB("document",1)=HMPSUB_";"_HMPIDT_"^LR "_$$NAME(HMPSUB)_" REPORT^LABORATORY NOTE"
+18 if $GET(HMPTEXT)
SET LAB("document",1,"content")=$$TEXT(DFN,HMPSUB,HMPIDT)
End DoDot:1
+19 QUIT
+20 ;
ORDER(LABORD,TEST) ; -- return #100 order^name for Lab order# & Test
+1 NEW Y,D,S,T
+2 SET D=$PIECE(9999999-HMPIDT,".")
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 ;I Y S Y=Y_U_$P($$OI^ORX8(Y),U,2)
+6 QUIT Y
+7 ;
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,HMPA
+2 SET X=$PIECE($GET(ACCNUM)," ")
SET Y=""
+3 IF $LENGTH(X)
DO FIND^DIC(68,,.01,"QX",X,,,,,"HMPA")
+4 SET Y=$GET(HMPA("DILIST",1,1))
+5 QUIT Y
+6 ;
+7 ; ------------ Get report(s) [via HMPDTIU] ------------
+8 ;
RPTS(DFN,BEG,END,MAX) ; -- find patient's lab reports
+1 NEW HMPSUB,HMPIDT,HMPITM,HMPTIU,HMPXID,LRDFN,HMPN,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 ;DE2818, (#63) LABORATORY REFERENCE
SET LRDFN=$$LRDFN^HMPXGLAB(DFN)
+5 KILL ^TMP("LRRR",$JOB,DFN)
DO RR^LR7OR1(DFN,,BEG,END,"AP",,,MAX)
+6 SET HMPSUB=""
FOR
SET HMPSUB=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB))
if HMPSUB=""
QUIT
Begin DoDot:1
+7 SET HMPIDT=0
FOR
SET HMPIDT=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB,HMPIDT))
if HMPIDT<1
QUIT
IF $ORDER(^(HMPIDT,0))
Begin DoDot:2
+8 SET HMPTIU=$SELECT(HMPSUB="AU":$NAME(^LR(LRDFN,101)),1:$NAME(^LR(LRDFN,HMPSUB,HMPIDT,.05)))
+9 KILL HMPITM
SET HMPXID=HMPSUB_";"_HMPIDT
+10 IF '$ORDER(@HMPTIU@(0))
DO RPT1(DFN,HMPXID,.HMPITM)
if $DATA(HMPITM)
DO XML^HMPDTIU(.HMPITM)
QUIT
+11 SET HMPN=0
FOR
SET HMPN=$ORDER(@HMPTIU@(HMPN))
if HMPN<1
QUIT
Begin DoDot:3
+12 SET DA=+$PIECE($GET(@HMPTIU@(HMPN,0)),U,2)
if DA<1
QUIT
KILL HMPITM
+13 DO EN1^HMPDTIU(DA,.HMPITM)
if $DATA(HMPITM)
DO XML^HMPDTIU(.HMPITM)
End DoDot:3
End DoDot:2
End DoDot:1
+14 KILL ^TMP("LRRR",$JOB,DFN),^TMP("HMPTEXT",$JOB)
+15 QUIT
+16 ;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
+1 ;DE4496 19 August 2016
SET DFN=+$GET(DFN)
SET ID=$GET(ID)
IF '(DFN>0)
DO LOGDPT^HMPLOG(DFN)
QUIT
+2 if '$LENGTH(ID)
QUIT
+3 NEW SUB,IDT,LRDFN,LR0,X,LOC
+4 KILL RPT,^TMP("HMPTEXT",$JOB)
+5 ;DE2818, (#63) LABORATORY REFERENCE
SET SUB=$PIECE(ID,";")
SET IDT=+$PIECE(ID,";",2)
SET LRDFN=$$LRDFN^HMPXGLAB(DFN)
+6 SET LR0=$SELECT(SUB="AU":$GET(^LR(LRDFN,"AU")),1:$GET(^LR(LRDFN,SUB,IDT,0)))
+7 SET RPT("id")=ID
SET RPT("referenceDateTime")=9999999-IDT
+8 SET RPT("localTitle")="LR "_$$NAME(SUB)_" REPORT"
+9 SET RPT("documentClass")="LR LABORATORY REPORTS"
+10 SET RPT("nationalTitle")="4697105^LABORATORY NOTE"
+11 SET RPT("nationalTitleSubject")="4697104^LABORATORY"
+12 SET RPT("nationalTitleType")="4696120^NOTE"
+13 SET RPT("type")="LR"
SET RPT("status")="COMPLETED"
+14 if $GET(FILTER("loinc"))
SET RPT("loinc")=$PIECE(FILTER("loinc"),U)
+15 ;DE2818, ***fix needed to get location IEN***
SET X=$PIECE(LR0,U,$SELECT(SUB="AU":5,1:8))
SET LOC=""
if $LENGTH(X)
SET LOC=+$ORDER(^SC("B",X,0))
+16 SET RPT("facility")=$$FAC^HMPD(LOC)
+17 ;look-up visit
IF LOC
Begin DoDot:1
+18 NEW CDT
SET CDT=9999999-IDT
+19 SET X=$$GETENC^PXAPI(DFN,CDT,LOC)
+20 if X
SET RPT("encounter")=+X
End DoDot:1
+21 ;pathologist
SET X=+$PIECE(LR0,U,$SELECT(SUB="AU":10,1:2))
+22 ;DE2818, changed global read to FileMan
if X
SET RPT("clinician",1)=X_U_$$GET1^DIQ(200,X_",",.01)_"^A"
+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)
+25 ;DE2818, changed global read to FileMan - (#.01) NAME and (#1) INITIAL
+26 SET RPT("clinician",2)=Y_U_$$GET1^DIQ(200,+Y_",",.01)_"^S^"_+X_U_$$GET1^DIQ(200,+Y_",",1)
End DoDot:1
+27 if $GET(HMPTEXT)
SET RPT("content")=$$TEXT(DFN,SUB,IDT)
+28 QUIT
+29 ;
TEXT(DFN,SUB,IDT,LRDFN) ; -- Get report text, return temp array name
+1 NEW DATE,NAME,HMPS,HMPY,I,X,Y
+2 KILL ^TMP("LRC",$JOB),^TMP("LRH",$JOB),^TMP("LRT",$JOB)
+3 SET DATE=9999999-$GET(IDT)
SET NAME=$$NAME(SUB)
SET HMPS(NAME)=""
+4 ;The ^LR7OSUM API is not returning correct data for all entries. The ^LR7OSAP4 API (which is what CPRS uses)
+5 ;does return correct entries where ^LR7OSUM fails, but it only returns data for lab result subscripts
+6 ;"EM", "SP", and "CY". Therefore, if we can, call the ^LR7OSAP4 API for data, and fall back to ^LR7OSUM
+7 ;otherwise.
+8 ; Make sure SUB is defined
SET SUB=$GET(SUB)
Begin DoDot:1
+9 ;If LRDFN and SUB is correct, call new API
+10 IF $GET(LRDFN)
IF SUB="EM"!(SUB="SP")!(SUB="CY")
DO EN^LR7OSAP4($NAME(^TMP("LRC",$JOB)),LRDFN,SUB,IDT)
QUIT
+11 ;Otherwise, call old API
+12 DO EN^LR7OSUM(.HMPY,DFN,DATE,DATE,,,.HMPS)
End DoDot:1
+13 SET Y=$NAME(^TMP("HMPTEXT",$JOB,SUB_";"_IDT))
KILL @Y
+14 ;LRH=header
SET I=+$GET(^TMP("LRH",$JOB,NAME))
+15 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
+16 KILL ^TMP("LRC",$JOB),^TMP("LRH",$JOB),^TMP("LRT",$JOB)
+17 QUIT Y
+18 ;
+19 ; ------------ Return data to middle tier ------------
+20 ;
XML(LAB) ; -- Return result as XML in @HMP@(#)
+1 NEW ATT,X,Y,NAMES,I,J
+2 DO ADD("<accession>")
SET HMPTOTL=$GET(HMPTOTL)+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^Z",ATT="value":"id^test^result^interpretation^units^low^high^localName^loinc^vuid^order^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^HMPD(@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^HMPD(X)_"</"_ATT_">"
QUIT
+18 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />"
QUIT
+19 IF $LENGTH(X)>1
Begin DoDot:2
+20 SET NAMES="code^name^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^HMPD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; -- Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
