HMPDLR ;SLC/MKB,ASMR/RRB - Laboratory extract;Nov 05, 2015 19:21:53
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;Sep 01, 2011;Build 63
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^LAB(61 524
; ^LRO(69 2407
; ^LR 525
; DIC 2051
; DIQ 2056
; LR7OR1,^TMP("LRRR",$J) 2503
; XUAF4 2171
Q
; ------------ Get results from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results, DE2818
N HMPSUB,HMPIDT,HMPN,HMPITM,LRDFN,SUB
S DFN=+$G(DFN) Q:$G(DFN)<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
K ^TMP("LRRR",$J,DFN)
S LRDFN=$$LRDFN^HMPXGLAB(DFN),HMPSUB="CH" ;DE2818, (#63) LABORATORY REFERENCE
;
; get result(s)
I $L($G(ID)) D Q:HMPN ;done
. S HMPSUB=$P(ID,";"),HMPIDT=+$P(ID,";",2),(BEG,END)=9999999-HMPIDT
. S HMPN=$P(ID,";",3) I HMPN D ;skip loop - single result
.. D RR^LR7OR1(DFN,,BEG,END,HMPSUB)
.. S SUB=$S("CH^MI"[HMPSUB:HMPSUB,1:"AP")_"(.HMPITM)"
.. D @SUB,XML(.HMPITM)
.. K ^TMP("LRRR",$J,DFN)
;
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 D
.. S HMPN=0 F S HMPN=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT,HMPN)) Q:HMPN<1 D
... K HMPITM S SUB=$S("CH^MI"[HMPSUB:HMPSUB,1:"AP")_"(.HMPITM)"
... D @SUB,XML(.HMPITM)
K ^TMP("LRRR",$J,DFN)
Q
;
CH(LAB) ; -- return a Chemistry result in LAB("attribute")=value
; Expects ^TMP("LRRR",$J,DFN,"CH",HMPIDT,HMPN),LRDFN
N CDT,LR0,LRI,X0,X,LOINC,ORD,CMMT K LAB
S LAB("id")="CH;"_HMPIDT_";"_HMPN,LAB("type")="CH"
S CDT=9999999-HMPIDT,LAB("collected")=CDT
S LR0=$G(^LR(LRDFN,"CH",HMPIDT,0)),LRI=$G(^(HMPN))
S LAB("status")="completed",LAB("resulted")=$P(LR0,U,3)
S X0=$G(^TMP("LRRR",$J,DFN,"CH",HMPIDT,HMPN))
S LAB("test")=$$LABTSTNM^HMPXGLAB(+X0) ; DE2818
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")=$P(X,"-"),LAB("high")=$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,HMPY S IENS=X_","
. D GETS^DIQ(61,IENS,".01;2",,"HMPY")
. S LAB("specimen")=$G(HMPY(61,IENS,2))_U_$G(HMPY(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^HMPD(+LOINC,95.3)
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^HMPD ;local stn#^name
I $D(^TMP("LRRR",$J,DFN,"CH",HMPIDT,"N")) M CMMT=^("N") S LAB("comment")=$$STRING^HMPD(.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",HMPIDT,HMPN),LRDFN
N ID,CDT,X0,X,CMMT,LR0 K LAB
S X0=$G(^TMP("LRRR",$J,DFN,"MI",HMPIDT,HMPN)) Q:$L($P(X0,U))'>1
S LAB("id")="MI;"_HMPIDT_"#"_HMPN,LAB("status")="completed"
S LAB("type")="MI",CDT=9999999-HMPIDT,LAB("collected")=CDT
S LR0=$G(^LR(LRDFN,"MI",HMPIDT,0)),LAB("resulted")=$P(LR0,U,3)
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,HMPY S IENS=X_","
. D GETS^DIQ(61,IENS,".01;2",,"HMPY")
. S LAB("specimen")=$G(HMPY(61,IENS,2))_U_$G(HMPY(61,IENS,.01)) ;SNOMED^name
. S LAB("sample")=$$GET1^DIQ(61,X_",",4.1) ;name
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^HMPD ;local stn#^name
I $D(^TMP("LRRR",$J,DFN,"MI",HMPIDT,"N")) M CMMT=^("N") S LAB("comment")=$$STRING^HMPD(.CMMT)
Q
;
AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
K LAB ;implemented in HMPDLRA
Q
;
; ------------ Return data to middle tier ------------
;
XML(LAB) ; -- Return result as XML in @HMP@(#)
N ATT,X,Y,P,NAMES,TAG
D ADD("<lab>") S HMPTOTL=$G(HMPTOTL)+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^HMPD(X)_"</"_ATT_">" Q
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />" Q
. I $L(X)>1 D S Y=""
.. S Y="<"_ATT_" ",NAMES="code^name^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^HMPD($P(X,U,P))_"' "
.. S Y=Y_"/>" D ADD(Y)
D ADD("</lab>")
Q
;
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[HHMPDLR 5312 printed Nov 22, 2024@17:03:48 Page 2
HMPDLR ;SLC/MKB,ASMR/RRB - Laboratory extract;Nov 05, 2015 19:21:53
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;Sep 01, 2011;Build 63
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^LAB(61 524
+7 ; ^LRO(69 2407
+8 ; ^LR 525
+9 ; DIC 2051
+10 ; DIQ 2056
+11 ; LR7OR1,^TMP("LRRR",$J) 2503
+12 ; XUAF4 2171
+13 QUIT
+14 ; ------------ Get results from VistA ------------
+15 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results, DE2818
+1 NEW HMPSUB,HMPIDT,HMPN,HMPITM,LRDFN,SUB
+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 KILL ^TMP("LRRR",$JOB,DFN)
+5 ;DE2818, (#63) LABORATORY REFERENCE
SET LRDFN=$$LRDFN^HMPXGLAB(DFN)
SET HMPSUB="CH"
+6 ;
+7 ; get result(s)
+8 ;done
IF $LENGTH($GET(ID))
Begin DoDot:1
+9 SET HMPSUB=$PIECE(ID,";")
SET HMPIDT=+$PIECE(ID,";",2)
SET (BEG,END)=9999999-HMPIDT
+10 ;skip loop - single result
SET HMPN=$PIECE(ID,";",3)
IF HMPN
Begin DoDot:2
+11 DO RR^LR7OR1(DFN,,BEG,END,HMPSUB)
+12 SET SUB=$SELECT("CH^MI"[HMPSUB:HMPSUB,1:"AP")_"(.HMPITM)"
+13 DO @SUB
DO XML(.HMPITM)
+14 KILL ^TMP("LRRR",$JOB,DFN)
End DoDot:2
End DoDot:1
if HMPN
QUIT
+15 ;
+16 DO RR^LR7OR1(DFN,,BEG,END,HMPSUB,,,MAX)
+17 SET HMPSUB=""
FOR
SET HMPSUB=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB))
if HMPSUB=""
QUIT
Begin DoDot:1
+18 SET HMPIDT=0
FOR
SET HMPIDT=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB,HMPIDT))
if HMPIDT<1
QUIT
Begin DoDot:2
+19 SET HMPN=0
FOR
SET HMPN=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB,HMPIDT,HMPN))
if HMPN<1
QUIT
Begin DoDot:3
+20 KILL HMPITM
SET SUB=$SELECT("CH^MI"[HMPSUB:HMPSUB,1:"AP")_"(.HMPITM)"
+21 DO @SUB
DO XML(.HMPITM)
End DoDot:3
End DoDot:2
End DoDot:1
+22 KILL ^TMP("LRRR",$JOB,DFN)
+23 QUIT
+24 ;
CH(LAB) ; -- return a Chemistry result in LAB("attribute")=value
+1 ; Expects ^TMP("LRRR",$J,DFN,"CH",HMPIDT,HMPN),LRDFN
+2 NEW CDT,LR0,LRI,X0,X,LOINC,ORD,CMMT
KILL LAB
+3 SET LAB("id")="CH;"_HMPIDT_";"_HMPN
SET LAB("type")="CH"
+4 SET CDT=9999999-HMPIDT
SET LAB("collected")=CDT
+5 SET LR0=$GET(^LR(LRDFN,"CH",HMPIDT,0))
SET LRI=$GET(^(HMPN))
+6 SET LAB("status")="completed"
SET LAB("resulted")=$PIECE(LR0,U,3)
+7 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"CH",HMPIDT,HMPN))
+8 ; DE2818
SET LAB("test")=$$LABTSTNM^HMPXGLAB(+X0)
+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")=$PIECE(X,"-")
SET LAB("high")=$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,HMPY
SET IENS=X_","
+17 DO GETS^DIQ(61,IENS,".01;2",,"HMPY")
+18 ;SNOMED^name
SET LAB("specimen")=$GET(HMPY(61,IENS,2))_U_$GET(HMPY(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^HMPD(+LOINC,95.3)
+24 SET X=$PIECE(LR0,U,14)
+25 if X
SET LAB("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+26 ;local stn#^name
IF 'X
SET LAB("facility")=$$FAC^HMPD
+27 IF $DATA(^TMP("LRRR",$JOB,DFN,"CH",HMPIDT,"N"))
MERGE CMMT=^("N")
SET LAB("comment")=$$STRING^HMPD(.CMMT)
+28 QUIT
+29 ;
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",HMPIDT,HMPN),LRDFN
+2 NEW ID,CDT,X0,X,CMMT,LR0
KILL LAB
+3 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"MI",HMPIDT,HMPN))
if $LENGTH($PIECE(X0,U))'>1
QUIT
+4 SET LAB("id")="MI;"_HMPIDT_"#"_HMPN
SET LAB("status")="completed"
+5 SET LAB("type")="MI"
SET CDT=9999999-HMPIDT
SET LAB("collected")=CDT
+6 SET LR0=$GET(^LR(LRDFN,"MI",HMPIDT,0))
SET LAB("resulted")=$PIECE(LR0,U,3)
+7 if $LENGTH($PIECE(X0,U,2))
SET LAB("result")=$PIECE(X0,U,2)
+8 if $LENGTH($PIECE(X0,U,4))
SET LAB("units")=$PIECE(X0,U,4)
+9 if $LENGTH($PIECE(X0,U,3))
SET LAB("interpretation")=$PIECE(X0,U,3)
+10 SET (LAB("test"),LAB("localName"))=$PIECE(X0,U,15)
+11 ;specimen
SET X=+$PIECE(X0,U,19)
IF X
Begin DoDot:1
+12 NEW IENS,HMPY
SET IENS=X_","
+13 DO GETS^DIQ(61,IENS,".01;2",,"HMPY")
+14 ;SNOMED^name
SET LAB("specimen")=$GET(HMPY(61,IENS,2))_U_$GET(HMPY(61,IENS,.01))
+15 ;name
SET LAB("sample")=$$GET1^DIQ(61,X_",",4.1)
End DoDot:1
+16 SET X=$PIECE(LR0,U,14)
+17 if X
SET LAB("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+18 ;local stn#^name
IF 'X
SET LAB("facility")=$$FAC^HMPD
+19 IF $DATA(^TMP("LRRR",$JOB,DFN,"MI",HMPIDT,"N"))
MERGE CMMT=^("N")
SET LAB("comment")=$$STRING^HMPD(.CMMT)
+20 QUIT
+21 ;
AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
+1 ;implemented in HMPDLRA
KILL LAB
+2 QUIT
+3 ;
+4 ; ------------ Return data to middle tier ------------
+5 ;
XML(LAB) ; -- Return result as XML in @HMP@(#)
+1 NEW ATT,X,Y,P,NAMES,TAG
+2 DO ADD("<lab>")
SET HMPTOTL=$GET(HMPTOTL)+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^HMPD(X)_"</"_ATT_">"
QUIT
+6 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />"
QUIT
+7 IF $LENGTH(X)>1
Begin DoDot:2
+8 SET Y="<"_ATT_" "
SET NAMES="code^name^Z"
+9 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^HMPD($PIECE(X,U,P))_"' "
+10 SET Y=Y_"/>"
DO ADD(Y)
End DoDot:2
SET Y=""
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+11 DO ADD("</lab>")
+12 QUIT
+13 ;
ADD(X) ; -- Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
+4 ;
