NHINVLR ;SLC/MKB -- Laboratory extract
;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; ^LAB(60 10054
; ^LRO(69 2407
; ^LR 525
; DIC 2051
; DIQ 2056
; LR7OR1,^TMP("LRRR",$J) 2503
;
; ------------ Get results from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
N NHSUB,NHIDT,NHI,NHITM,LRDFN,SUB
S DFN=+$G(DFN) Q:$G(DFN)<1
S BEG=$G(BEG,1410101),END=$G(END,9999998),MAX=$G(MAX,999999)
K ^TMP("LRRR",$J,DFN) S LRDFN=$G(^DPT(DFN,"LR")),NHSUB="CH"
;
; get result(s)
I $L($G(ID)) D Q:NHI ;done
. S NHSUB=$P(ID,";"),NHIDT=+$P(ID,";",2),(BEG,END)=9999999-NHIDT
. S NHI=$P(ID,";",3) I NHI D ;skip loop - single result
.. D RR^LR7OR1(DFN,,BEG,END,NHSUB)
.. S SUB=$S("CH^MI"[NHSUB:NHSUB,1:"AP")_"(.NHITM)"
.. D @SUB,XML(.NHITM)
.. K ^TMP("LRRR",$J,DFN)
;
D RR^LR7OR1(DFN,,BEG,END,NHSUB,,,MAX)
S NHSUB="" F S NHSUB=$O(^TMP("LRRR",$J,DFN,NHSUB)) Q:NHSUB="" D
. S NHIDT=0 F S NHIDT=$O(^TMP("LRRR",$J,DFN,NHSUB,NHIDT)) Q:NHIDT<1 D
.. S NHI=0 F S NHI=$O(^TMP("LRRR",$J,DFN,NHSUB,NHIDT,NHI)) Q:NHI<1 D
... K NHITM S SUB=$S("CH^MI"[NHSUB:NHSUB,1:"AP")_"(.NHITM)"
... D @SUB,XML(.NHITM)
K ^TMP("LRRR",$J,DFN)
Q
;
CH(LAB) ; -- return a Chemistry result in LAB("attribute")=value
; Expects ^TMP("LRRR",$J,DFN,"CH",NHIDT,NHI),LRDFN
N CDT,LR0,LRI,X0,X,LOINC,ORD,CMMT K LAB
S LAB("id")="CH;"_NHIDT_";"_NHI,LAB("type")="CH"
S CDT=9999999-NHIDT,LAB("collected")=CDT
S LR0=$G(^LR(LRDFN,"CH",NHIDT,0)),LRI=$G(^(NHI))
S LAB("status")="completed",LAB("resulted")=$P(LR0,U,3)
S X0=$G(^TMP("LRRR",$J,DFN,"CH",NHIDT,NHI))
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")=$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($P(LRI,U,3),"!",3) S:X LOINC=$$GET1^DIQ(95.3,X_",",.01)
S X=+$P(X0,U,19) I X D ;specimen
. N VUID,IENS,NHY S VUID="",IENS=X_","
. D GETS^DIQ(61,IENS,".01;2",,"NHY")
. S LAB("specimen")=$G(NHY(61,IENS,2))_U_$G(NHY(61,IENS,.01)) ;SNOMED^name
. S LAB("sample")=$$GET1^DIQ(61,X_",",4.1) ;name
. ; LOINC=+$G(^LAB(60,+X0,1,X,95.3))
. S:'$G(LOINC) LOINC=$$GET1^DIQ(60.01,X_","_+X0_",",95.3)
. I LOINC S LAB("loinc")=LOINC,VUID=$$VUID^NHINV(+LOINC,95.3)
. S:VUID LAB("vuid")=VUID
S ORD=+$P(X0,U,17) S:ORD LAB("labOrderID")=ORD
S X=$$ORDER(ORD,+X0) S:X LAB("orderID")=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^NHINV ;local stn#^name
I $D(^TMP("LRRR",$J,DFN,"CH",NHIDT,"N")) M CMMT=^("N") S LAB("comment")=$$STRING^NHINV(.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",NHIDT,NHI),LRDFN
N ID,CDT,X0,X,CMMT,LR0 K LAB
S X0=$G(^TMP("LRRR",$J,DFN,"MI",NHIDT,NHI)) Q:$L($P(X0,U))'>1
S LAB("id")="MI;"_NHIDT_"#"_NHI,LAB("status")="completed"
S LAB("type")="MI",CDT=9999999-NHIDT,LAB("collected")=CDT
S LR0=$G(^LR(LRDFN,"MI",NHIDT,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,NHY S IENS=X_","
. D GETS^DIQ(61,IENS,".01;2",,"NHY")
. S LAB("specimen")=$G(NHY(61,IENS,2))_U_$G(NHY(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^NHINV ;local stn#^name
I $D(^TMP("LRRR",$J,DFN,"MI",NHIDT,"N")) M CMMT=^("N") S LAB("comment")=$$STRING^NHINV(.CMMT)
Q
;
AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
K LAB ;not implemented yet
Q
;
TYPE(X) ; -- Return name of lab section
N NHIY,Y S Y=X
D FIND^DIC(68,,.01,"PQX",X,,"B",,,"NHIY")
S:$G(NHIY("DILIST",1,0)) Y=$P(NHIY("DILIST",1,0),U,2) ;name
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(LAB) ; -- Return result as XML in @NHIN@(#)
N ATT,X,Y,P,NAMES,TAG
D ADD("<lab>") S NHINTOTL=$G(NHINTOTL)+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^NHINV(X)_"</"_ATT_">" Q
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^NHINV(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^NHINV($P(X,U,P))_"' "
.. S Y=Y_"/>" D ADD(Y)
D ADD("</lab>")
Q
;
ADD(X) ; -- Add a line @NHIN@(n)=X
S NHINI=$G(NHINI)+1
S @NHIN@(NHINI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNHINVLR 5395 printed Apr 09, 2024@21:20:14 Page 2
NHINVLR ;SLC/MKB -- Laboratory extract
+1 ;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
+2 ;
+3 ; External References DBIA#
+4 ; ------------------- -----
+5 ; ^DPT 10035
+6 ; ^LAB(60 10054
+7 ; ^LRO(69 2407
+8 ; ^LR 525
+9 ; DIC 2051
+10 ; DIQ 2056
+11 ; LR7OR1,^TMP("LRRR",$J) 2503
+12 ;
+13 ; ------------ Get results from VistA ------------
+14 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
+1 NEW NHSUB,NHIDT,NHI,NHITM,LRDFN,SUB
+2 SET DFN=+$GET(DFN)
if $GET(DFN)<1
QUIT
+3 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,9999998)
SET MAX=$GET(MAX,999999)
+4 KILL ^TMP("LRRR",$JOB,DFN)
SET LRDFN=$GET(^DPT(DFN,"LR"))
SET NHSUB="CH"
+5 ;
+6 ; get result(s)
+7 ;done
IF $LENGTH($GET(ID))
Begin DoDot:1
+8 SET NHSUB=$PIECE(ID,";")
SET NHIDT=+$PIECE(ID,";",2)
SET (BEG,END)=9999999-NHIDT
+9 ;skip loop - single result
SET NHI=$PIECE(ID,";",3)
IF NHI
Begin DoDot:2
+10 DO RR^LR7OR1(DFN,,BEG,END,NHSUB)
+11 SET SUB=$SELECT("CH^MI"[NHSUB:NHSUB,1:"AP")_"(.NHITM)"
+12 DO @SUB
DO XML(.NHITM)
+13 KILL ^TMP("LRRR",$JOB,DFN)
End DoDot:2
End DoDot:1
if NHI
QUIT
+14 ;
+15 DO RR^LR7OR1(DFN,,BEG,END,NHSUB,,,MAX)
+16 SET NHSUB=""
FOR
SET NHSUB=$ORDER(^TMP("LRRR",$JOB,DFN,NHSUB))
if NHSUB=""
QUIT
Begin DoDot:1
+17 SET NHIDT=0
FOR
SET NHIDT=$ORDER(^TMP("LRRR",$JOB,DFN,NHSUB,NHIDT))
if NHIDT<1
QUIT
Begin DoDot:2
+18 SET NHI=0
FOR
SET NHI=$ORDER(^TMP("LRRR",$JOB,DFN,NHSUB,NHIDT,NHI))
if NHI<1
QUIT
Begin DoDot:3
+19 KILL NHITM
SET SUB=$SELECT("CH^MI"[NHSUB:NHSUB,1:"AP")_"(.NHITM)"
+20 DO @SUB
DO XML(.NHITM)
End DoDot:3
End DoDot:2
End DoDot:1
+21 KILL ^TMP("LRRR",$JOB,DFN)
+22 QUIT
+23 ;
CH(LAB) ; -- return a Chemistry result in LAB("attribute")=value
+1 ; Expects ^TMP("LRRR",$J,DFN,"CH",NHIDT,NHI),LRDFN
+2 NEW CDT,LR0,LRI,X0,X,LOINC,ORD,CMMT
KILL LAB
+3 SET LAB("id")="CH;"_NHIDT_";"_NHI
SET LAB("type")="CH"
+4 SET CDT=9999999-NHIDT
SET LAB("collected")=CDT
+5 SET LR0=$GET(^LR(LRDFN,"CH",NHIDT,0))
SET LRI=$GET(^(NHI))
+6 SET LAB("status")="completed"
SET LAB("resulted")=$PIECE(LR0,U,3)
+7 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"CH",NHIDT,NHI))
+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")=$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 SET X=$PIECE($PIECE(LRI,U,3),"!",3)
if X
SET LOINC=$$GET1^DIQ(95.3,X_",",.01)
+16 ;specimen
SET X=+$PIECE(X0,U,19)
IF X
Begin DoDot:1
+17 NEW VUID,IENS,NHY
SET VUID=""
SET IENS=X_","
+18 DO GETS^DIQ(61,IENS,".01;2",,"NHY")
+19 ;SNOMED^name
SET LAB("specimen")=$GET(NHY(61,IENS,2))_U_$GET(NHY(61,IENS,.01))
+20 ;name
SET LAB("sample")=$$GET1^DIQ(61,X_",",4.1)
+21 ; LOINC=+$G(^LAB(60,+X0,1,X,95.3))
+22 if '$GET(LOINC)
SET LOINC=$$GET1^DIQ(60.01,X_","_+X0_",",95.3)
+23 IF LOINC
SET LAB("loinc")=LOINC
SET VUID=$$VUID^NHINV(+LOINC,95.3)
+24 if VUID
SET LAB("vuid")=VUID
End DoDot:1
+25 SET ORD=+$PIECE(X0,U,17)
if ORD
SET LAB("labOrderID")=ORD
+26 SET X=$$ORDER(ORD,+X0)
if X
SET LAB("orderID")=X
+27 SET X=$PIECE(LR0,U,14)
+28 if X
SET LAB("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+29 ;local stn#^name
IF 'X
SET LAB("facility")=$$FAC^NHINV
+30 IF $DATA(^TMP("LRRR",$JOB,DFN,"CH",NHIDT,"N"))
MERGE CMMT=^("N")
SET LAB("comment")=$$STRING^NHINV(.CMMT)
+31 QUIT
+32 ;
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",NHIDT,NHI),LRDFN
+2 NEW ID,CDT,X0,X,CMMT,LR0
KILL LAB
+3 SET X0=$GET(^TMP("LRRR",$JOB,DFN,"MI",NHIDT,NHI))
if $LENGTH($PIECE(X0,U))'>1
QUIT
+4 SET LAB("id")="MI;"_NHIDT_"#"_NHI
SET LAB("status")="completed"
+5 SET LAB("type")="MI"
SET CDT=9999999-NHIDT
SET LAB("collected")=CDT
+6 SET LR0=$GET(^LR(LRDFN,"MI",NHIDT,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,NHY
SET IENS=X_","
+13 DO GETS^DIQ(61,IENS,".01;2",,"NHY")
+14 ;SNOMED^name
SET LAB("specimen")=$GET(NHY(61,IENS,2))_U_$GET(NHY(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^NHINV
+19 IF $DATA(^TMP("LRRR",$JOB,DFN,"MI",NHIDT,"N"))
MERGE CMMT=^("N")
SET LAB("comment")=$$STRING^NHINV(.CMMT)
+20 QUIT
+21 ;
AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
+1 ;not implemented yet
KILL LAB
+2 QUIT
+3 ;
TYPE(X) ; -- Return name of lab section
+1 NEW NHIY,Y
SET Y=X
+2 DO FIND^DIC(68,,.01,"PQX",X,,"B",,,"NHIY")
+3 ;name
if $GET(NHIY("DILIST",1,0))
SET Y=$PIECE(NHIY("DILIST",1,0),U,2)
+4 QUIT Y
+5 ;
+6 ; ------------ Return data to middle tier ------------
+7 ;
XML(LAB) ; -- Return result as XML in @NHIN@(#)
+1 NEW ATT,X,Y,P,NAMES,TAG
+2 DO ADD("<lab>")
SET NHINTOTL=$GET(NHINTOTL)+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^NHINV(X)_"</"_ATT_">"
QUIT
+6 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^NHINV(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^NHINV($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 @NHIN@(n)=X
+1 SET NHINI=$GET(NHINI)+1
+2 SET @NHIN@(NHINI)=X
+3 QUIT
