EDPLAB ;SLC/MKB - EDIS lab result utilities ; 9/1/22 9:27am
;;2.0;EMERGENCY DEPARTMENT;**6,20**;May 2, 2012;Build 7
;External reference ^ORX8 supported by DBIA 871
;
EN(EDPRES,PARAM) ; -- Return lab results as XML in EDPRES
; Required: "patient" identifier (DFN)
; Optional: "start"-"stop" date range
; "total" - total number of accessions
; "list" - 1 for list of testID's only
; "testID"s for result history of test(s)
;
K @EDPRES
;D ADD^EDPHIST("<results>")
;N ARRAY,EDPARR S ARRAY=$NA(EDPARR("results",1))
N ARRAY,EDPARR S ARRAY=$NA(^TMP("EDPLAB",$J,"results",1)) K @ARRAY
;
;
; validate input parameters
N DFN,TEST,TESTIDS,BEG,END,MAX,X,I,LIST,TSEQ,TIDT
S DFN=+$$VAL("patient") I DFN<1 D G ENQ
. ;D XML^EDPX("<error msg='Missing or invalid patient identifier' />")
. S @ARRAY@("error",1,"msg")="Missing or invalid patient identifier"
;S I=0 F S I=$O(PARAM("testID",I)) Q:I<1 S X=+PARAM("testID",I),TEST(X)=""
S TESTIDS=$$VAL("testID")
I $L(TESTIDS) D
.F I=1:1 S X=$P(TESTIDS,U,I) Q:'$L(X) D
..S TSEQ=$P(X,";"),TIDT=$P(X,";",2) Q:'TSEQ!('$L(TIDT))
..I X S TEST(TIDT,TSEQ)=""
;
; get optional date range, max# accessions
S BEG=$$VAL("start"),END=$$VAL("stop"),MAX=$$VAL("total"),LIST=$$VAL("list")
I BEG,END,END<BEG N X S X=BEG,BEG=END,END=X ;switch
I END,$L(END,".")<2 S END=END_".24"
; search Lab for results
N ACNT,ICNT,DONE,SUB,IDT,SEQ,MORE
K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,BEG,END)
S (ACNT,ICNT,DONE)=0
S SUB="" F S SUB=$O(^TMP("LRRR",$J,DFN,SUB)) G:SUB="" ENQ D
.; BWF 2/2/2012 - for now we are only returning CH (chemistry)
.Q:SUB'="CH"
.S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1 D Q:DONE
.. I $D(TEST) Q:'$D(TEST(IDT))
.. S (MORE,SEQ)=0
.. F S SEQ=$O(^TMP("LRRR",$J,DFN,SUB,IDT,SEQ)) Q:SEQ<1 S X=$G(^(SEQ)) D
... I $D(TEST) Q:'$D(TEST(IDT,SEQ))
... K EDPX
... I '$G(LIST) S EDPX("id")=SUB_";"_IDT_";"_SEQ
... S MORE=1
... D TMP(.EDPX,DFN,SUB,IDT,SEQ,LIST) ;parse into EDPX("att")=value
... S ICNT=ICNT+1 M @ARRAY@("item",ICNT)=EDPX
... ;D ADDA^EDPHIST("item",.EDPX)
.. S:MORE ACNT=ACNT+1 I $G(MAX),ACNT'<MAX S DONE=1
Q
;
ENQ ;end
D TOXMLG^EDPXML(ARRAY,EDPRES)
Q
;
ORD(EDPRES,PARAM) ; -- Return results history for lab orders
K EDPRES ;D ADD^EDPHIST("<results>")
D ADD^EDPHIST("<results>")
N ARRAY,EDPARR S ARRAY=$NA(EDPARR("results",1))
;
; validate input parameters
N DFN,LOG,IN,MAX
S DFN=+$$VAL("patient") I DFN<1 D G ORQ
. S @ARRAY@("error",1,"msg")="Missing or invalid patient identifier"
S LOG=+$O(^EDP(230,"APA",DFN,0)),IN=$P($G(^EDP(230,LOG,0)),U,8)
S MAX=$$VAL("total")
;
K ^TMP("LRRR",$J) D RR^LR7OR1(DFN)
;
; get results for tests in each order
N EDPI,ORIFN,EDPY,EDPTST,ORPK,SUB,IDT,SEQ,EDPX,X,ORUPCHUK
S EDPI=0 F S EDPI=$O(PARAM("order",EDPI)) Q:EDPI<1 D
. ; add order info
. S ORIFN=+$G(PARAM("order",EDPI)) Q:ORIFN<1 K EDPX
. S EDPX("id")=ORIFN,X=$$GET1^DIQ(100,ORIFN_",",5,"I")
. S EDPX("statusId")=X,EDPX("statusName")=$$STATUS(X,ORIFN)
. S X=$P($$OI^ORX8(ORIFN),U,2),EDPX("name")=$$ESC(X) ;if null?
. D EN^ORX8(ORIFN)
. S X=ORUPCHUK("ORSTRT")
. I 'X S X=ORUPCHUK("ORODT")
. S EDPX("collectedTS")=X,EDPX("ack")=$$ACK^EDPHIST(ORIFN)
. M @ARRAY@("order",1)=EDPX
. ;
. ; add order results from visit
. S ORPK=$$PKGID^ORX8(ORIFN) Q:$L(ORPK,";")'>3 ;no results
. S SUB=$P(ORPK,";",4),IDT=$P(ORPK,";",5) K EDPTST
. S SEQ=0 F S SEQ=$O(^TMP("LRRR",$J,DFN,SUB,IDT,SEQ)) Q:SEQ<1 D
.. K EDPX S EDPX("id")=SUB_";"_IDT_";"_SEQ
.. D TMP^EDPLAB(.EDPX,DFN,SUB,IDT,SEQ) ;parse into EDPX("att")=value
.. M @ARRAY@("visit",1,"item",1)=EDPX
.. S X=$G(EDPX("testID")) S:X EDPTST(X)=""
. ;
. ; add prior results of same tests [up to MAX# collections]
. N ACNT,ICNT,DONE,MATCH S (ACNT,ICNT,DONE)=0
. F S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1 D Q:DONE
.. S SEQ=0,MATCH=0
.. F S SEQ=$O(^TMP("LRRR",$J,DFN,SUB,IDT,SEQ)) Q:SEQ<1 S X=$G(^(SEQ)) D
... Q:'$D(EDPTST(+X)) ;not a matching test
... K EDPX S EDPX("id")=SUB_";"_IDT_";"_SEQ,MATCH=1
... ;K EDPX S EDPX("id")="CH;"_IDT_";"_SEQ,MATCH=1
... ;D TMP^EDPLAB(.EDPX,DFN,"CH",IDT,SEQ) ;parse into EDPX("att")=value
... D TMP^EDPLAB(.EDPX,DFN,SUB,IDT,SEQ) ;parse into EDPX("att")=value
... S ICNT=ICNT+1 M @ARRAY@("history",1,"item",ICNT)=EDPX
.. S:MATCH ACNT=ACNT+1 I $G(MAX),ACNT'<MAX S DONE=1
ORQ ; end
;D ADD("</results>")
D TOXML^EDPXML(.EDPARR,.EDPRES)
Q
;
VAL(X) Q $G(PARAM(X,1))
;
ESC(X) ; -- escape outgoing XML
; Q $ZCONVERT(X,"O","HTML") ; uncomment for fastest performance on Cache
;
N I,Y,QOT S QOT=""""
S Y=$P(X,"&") F I=2:1:$L(X,"&") S Y=Y_"&"_$P(X,"&",I)
S X=Y,Y=$P(X,"<") F I=2:1:$L(X,"<") S Y=Y_"<"_$P(X,"<",I)
S X=Y,Y=$P(X,">") F I=2:1:$L(X,">") S Y=Y_">"_$P(X,">",I)
S X=Y,Y=$P(X,"'") F I=2:1:$L(X,"'") S Y=Y_"'"_$P(X,"'",I)
S X=Y,Y=$P(X,QOT) F I=2:1:$L(X,QOT) S Y=Y_"""_$P(X,QOT,I)
Q Y
;
STATUS(STS,ORDER) ; -- Return result status for ORDER status
N Y,X
S STS=+$G(STS),ORDER=+$G(ORDER)
I STS=1 S Y="Order discontinued" D:ORDER ;look for reason
. S X=$$GET1^DIQ(100,ORDER_",",65) S:'$L(X) X=$$GET1^DIQ(100,ORDER_",",64)
. I $L(X) S Y=Y_" ("_X_")"
I STS=2 S Y="Results"_$S($$ACKD^EDPHIST(ORDER):" acknowledged",1:" available")
I STS=3 S Y="On hold"
I STS=5 S Y="Order pending"
I STS=6 S Y="Specimen in lab" ;"Active"
I STS=7 S Y="Order expired"
I STS=8 S Y="Scheduled"
I STS=9 S Y="Partial results available"
I STS=10!(STS=11) S Y="Order not released"
I STS=12 S Y="Order discontinued (changed)"
I STS=13 S Y="Order cancelled"
I STS=14 S Y="Order discontinued (lapsed)"
I STS=15 S Y="Order renewed"
Q Y
;
TMP(Y,DFN,SUB,IDT,SEQ,LIST) ; -- Return ^TMP("LRRR",$J,DFN,SUB,IDT,SEQ) data
; in Y("attribute")=value
; I SUB = MI or BB ??
N X0,X,XC,FAC,ACK
S X0=$G(^TMP("LRRR",$J,DFN,SUB,IDT,SEQ))
;
; BWF 2/2/2012 - Due to errors occuring on the client side when too much data
; is retrieved from this call, an initial call can now be made that will return
; a list of the available labs. The client side will then be able to call back in
; with a list of labs being requested in smaller chunks.
; If LIST is passed as '1', only pass back the list of testID's and collected date
I $G(LIST) S Y("testID")=SEQ_";"_IDT Q
;
S Y("subscript")=SUB,Y("accession")=SUB_";"_IDT
;S Y("collectedTS")=$$FMTHL7^XLFDT(9999999-IDT)
S Y("collectedTS")=(9999999-IDT)
; BWF 6/14/13 - Added $$ESC for testName
S Y("testID")=+X0,Y("testName")=$$ESC($P($G(^LAB(60,+X0,0)),U)),X=+$P($G(^(.1)),U,6)
S Y("printOrder")=$S(X:+X,1:SEQ/1000000)
S:$L($P(X0,U,2)) Y("result")=$P(X0,U,2)
I $G(Y("result"))'="" D
.I Y("result")["<" S Y("result")=$$ESC(Y("result"))
.I Y("result")[">" S Y("result")=$$ESC(Y("result"))
S:$L($P(X0,U,4)) Y("units")=$$ESC($P(X0,U,4))
S:$L($P(X0,U,3)) Y("deviation")=$$ESC($P(X0,U,3))
S X=$P(X0,U,5) I $L(X),X["-" S Y("low")=$$ESC($P(X,"-")),Y("high")=$$ESC($P(X,"-",2))
S Y("printName")=$$ESC($P(X0,U,15))
S Y("number")=$P(X0,U,16)
S X=+$P(X0,U,19) D ;sample & specimen
. N SPC,CS,LRDFN
. S:X<1 LRDFN=+$G(^DPT(DFN,"LR")),X=+$P($G(^LR(LRDFN,SUB,IDT,0)),U,5)
. S SPC=$G(^LAB(61,X,0)) Q:'$L(SPC)
. S Y("specimen")=$P(SPC,U),CS=+$P(SPC,U,6)
. S:CS Y("sample")=$P($G(^LAB(62,CS,0)),U)
S X=+$P(X0,U,17),XC=$Q(^LRO(69,"C",X))
I $P(XC,",",1,3)=("^LRO(69,""C"","_X) D ;get Lab Order info
. N LRO,LR3
. S LRO=$G(^LRO(69,+$P(XC,",",4),1,+$P(XC,",",5),0)),LR3=$G(^(3))
. ;S X=+$P(LRO,U,6) S:X Y("provider")=X_U_$P($G(^VA(200,X,0)),U)
. S X=+$P(LRO,U,11) ;S:X Y("order")=X
. S ACK=$$ACK^EDPHIST(X,1)
. ;S Y("ack")=$P(ACK,U),Y("ackdt")=$P(ACK,U,2)
. ;S X=$P(LR3,U,2) S:X Y("resultedTS")=$$FMTHL7^XLFDT(X)
. S X=$P(LR3,U,2) S:X Y("resultedTS")=(X)
S FAC=$$SITE^VASITE S:FAC Y("stnNum")=$P(FAC,U,3),Y("stnName")=$P(FAC,U,2)
; bwf 12/21/2011 removed setting of 'comments' to bypass errors occuring with the parser on client side
;I $D(^TMP("LRRR",$J,DFN,SUB,IDT,"N")) D ;M Y("comment")=^("N")
;. N I S I=1,X=$G(^TMP("LRRR",$J,DFN,SUB,IDT,"N",I))
;. F S I=$O(^TMP("LRRR",$J,DFN,SUB,IDT,"N",I)) Q:I<1 S X=X_$C(13,10)_^(I)
;. S Y("comment")=$$ESC(X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEDPLAB 8282 printed Jan 18, 2025@02:53:12 Page 2
EDPLAB ;SLC/MKB - EDIS lab result utilities ; 9/1/22 9:27am
+1 ;;2.0;EMERGENCY DEPARTMENT;**6,20**;May 2, 2012;Build 7
+2 ;External reference ^ORX8 supported by DBIA 871
+3 ;
EN(EDPRES,PARAM) ; -- Return lab results as XML in EDPRES
+1 ; Required: "patient" identifier (DFN)
+2 ; Optional: "start"-"stop" date range
+3 ; "total" - total number of accessions
+4 ; "list" - 1 for list of testID's only
+5 ; "testID"s for result history of test(s)
+6 ;
+7 KILL @EDPRES
+8 ;D ADD^EDPHIST("<results>")
+9 ;N ARRAY,EDPARR S ARRAY=$NA(EDPARR("results",1))
+10 NEW ARRAY,EDPARR
SET ARRAY=$NAME(^TMP("EDPLAB",$JOB,"results",1))
KILL @ARRAY
+11 ;
+12 ;
+13 ; validate input parameters
+14 NEW DFN,TEST,TESTIDS,BEG,END,MAX,X,I,LIST,TSEQ,TIDT
+15 SET DFN=+$$VAL("patient")
IF DFN<1
Begin DoDot:1
+16 ;D XML^EDPX("<error msg='Missing or invalid patient identifier' />")
+17 SET @ARRAY@("error",1,"msg")="Missing or invalid patient identifier"
End DoDot:1
GOTO ENQ
+18 ;S I=0 F S I=$O(PARAM("testID",I)) Q:I<1 S X=+PARAM("testID",I),TEST(X)=""
+19 SET TESTIDS=$$VAL("testID")
+20 IF $LENGTH(TESTIDS)
Begin DoDot:1
+21 FOR I=1:1
SET X=$PIECE(TESTIDS,U,I)
if '$LENGTH(X)
QUIT
Begin DoDot:2
+22 SET TSEQ=$PIECE(X,";")
SET TIDT=$PIECE(X,";",2)
if 'TSEQ!('$LENGTH(TIDT))
QUIT
+23 IF X
SET TEST(TIDT,TSEQ)=""
End DoDot:2
End DoDot:1
+24 ;
+25 ; get optional date range, max# accessions
+26 SET BEG=$$VAL("start")
SET END=$$VAL("stop")
SET MAX=$$VAL("total")
SET LIST=$$VAL("list")
+27 ;switch
IF BEG
IF END
IF END<BEG
NEW X
SET X=BEG
SET BEG=END
SET END=X
+28 IF END
IF $LENGTH(END,".")<2
SET END=END_".24"
+29 ; search Lab for results
+30 NEW ACNT,ICNT,DONE,SUB,IDT,SEQ,MORE
+31 KILL ^TMP("LRRR",$JOB)
DO RR^LR7OR1(DFN,,BEG,END)
+32 SET (ACNT,ICNT,DONE)=0
+33 SET SUB=""
FOR
SET SUB=$ORDER(^TMP("LRRR",$JOB,DFN,SUB))
if SUB=""
GOTO ENQ
Begin DoDot:1
+34 ; BWF 2/2/2012 - for now we are only returning CH (chemistry)
+35 if SUB'="CH"
QUIT
+36 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT))
if IDT<1
QUIT
Begin DoDot:2
+37 IF $DATA(TEST)
if '$DATA(TEST(IDT))
QUIT
+38 SET (MORE,SEQ)=0
+39 FOR
SET SEQ=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT,SEQ))
if SEQ<1
QUIT
SET X=$GET(^(SEQ))
Begin DoDot:3
+40 IF $DATA(TEST)
if '$DATA(TEST(IDT,SEQ))
QUIT
+41 KILL EDPX
+42 IF '$GET(LIST)
SET EDPX("id")=SUB_";"_IDT_";"_SEQ
+43 SET MORE=1
+44 ;parse into EDPX("att")=value
DO TMP(.EDPX,DFN,SUB,IDT,SEQ,LIST)
+45 SET ICNT=ICNT+1
MERGE @ARRAY@("item",ICNT)=EDPX
+46 ;D ADDA^EDPHIST("item",.EDPX)
End DoDot:3
+47 if MORE
SET ACNT=ACNT+1
IF $GET(MAX)
IF ACNT'<MAX
SET DONE=1
End DoDot:2
if DONE
QUIT
End DoDot:1
+48 QUIT
+49 ;
ENQ ;end
+1 DO TOXMLG^EDPXML(ARRAY,EDPRES)
+2 QUIT
+3 ;
ORD(EDPRES,PARAM) ; -- Return results history for lab orders
+1 ;D ADD^EDPHIST("<results>")
KILL EDPRES
+2 DO ADD^EDPHIST("<results>")
+3 NEW ARRAY,EDPARR
SET ARRAY=$NAME(EDPARR("results",1))
+4 ;
+5 ; validate input parameters
+6 NEW DFN,LOG,IN,MAX
+7 SET DFN=+$$VAL("patient")
IF DFN<1
Begin DoDot:1
+8 SET @ARRAY@("error",1,"msg")="Missing or invalid patient identifier"
End DoDot:1
GOTO ORQ
+9 SET LOG=+$ORDER(^EDP(230,"APA",DFN,0))
SET IN=$PIECE($GET(^EDP(230,LOG,0)),U,8)
+10 SET MAX=$$VAL("total")
+11 ;
+12 KILL ^TMP("LRRR",$JOB)
DO RR^LR7OR1(DFN)
+13 ;
+14 ; get results for tests in each order
+15 NEW EDPI,ORIFN,EDPY,EDPTST,ORPK,SUB,IDT,SEQ,EDPX,X,ORUPCHUK
+16 SET EDPI=0
FOR
SET EDPI=$ORDER(PARAM("order",EDPI))
if EDPI<1
QUIT
Begin DoDot:1
+17 ; add order info
+18 SET ORIFN=+$GET(PARAM("order",EDPI))
if ORIFN<1
QUIT
KILL EDPX
+19 SET EDPX("id")=ORIFN
SET X=$$GET1^DIQ(100,ORIFN_",",5,"I")
+20 SET EDPX("statusId")=X
SET EDPX("statusName")=$$STATUS(X,ORIFN)
+21 ;if null?
SET X=$PIECE($$OI^ORX8(ORIFN),U,2)
SET EDPX("name")=$$ESC(X)
+22 DO EN^ORX8(ORIFN)
+23 SET X=ORUPCHUK("ORSTRT")
+24 IF 'X
SET X=ORUPCHUK("ORODT")
+25 SET EDPX("collectedTS")=X
SET EDPX("ack")=$$ACK^EDPHIST(ORIFN)
+26 MERGE @ARRAY@("order",1)=EDPX
+27 ;
+28 ; add order results from visit
+29 ;no results
SET ORPK=$$PKGID^ORX8(ORIFN)
if $LENGTH(ORPK,";")'>3
QUIT
+30 SET SUB=$PIECE(ORPK,";",4)
SET IDT=$PIECE(ORPK,";",5)
KILL EDPTST
+31 SET SEQ=0
FOR
SET SEQ=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT,SEQ))
if SEQ<1
QUIT
Begin DoDot:2
+32 KILL EDPX
SET EDPX("id")=SUB_";"_IDT_";"_SEQ
+33 ;parse into EDPX("att")=value
DO TMP^EDPLAB(.EDPX,DFN,SUB,IDT,SEQ)
+34 MERGE @ARRAY@("visit",1,"item",1)=EDPX
+35 SET X=$GET(EDPX("testID"))
if X
SET EDPTST(X)=""
End DoDot:2
+36 ;
+37 ; add prior results of same tests [up to MAX# collections]
+38 NEW ACNT,ICNT,DONE,MATCH
SET (ACNT,ICNT,DONE)=0
+39 FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT))
if IDT<1
QUIT
Begin DoDot:2
+40 SET SEQ=0
SET MATCH=0
+41 FOR
SET SEQ=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT,SEQ))
if SEQ<1
QUIT
SET X=$GET(^(SEQ))
Begin DoDot:3
+42 ;not a matching test
if '$DATA(EDPTST(+X))
QUIT
+43 KILL EDPX
SET EDPX("id")=SUB_";"_IDT_";"_SEQ
SET MATCH=1
+44 ;K EDPX S EDPX("id")="CH;"_IDT_";"_SEQ,MATCH=1
+45 ;D TMP^EDPLAB(.EDPX,DFN,"CH",IDT,SEQ) ;parse into EDPX("att")=value
+46 ;parse into EDPX("att")=value
DO TMP^EDPLAB(.EDPX,DFN,SUB,IDT,SEQ)
+47 SET ICNT=ICNT+1
MERGE @ARRAY@("history",1,"item",ICNT)=EDPX
End DoDot:3
+48 if MATCH
SET ACNT=ACNT+1
IF $GET(MAX)
IF ACNT'<MAX
SET DONE=1
End DoDot:2
if DONE
QUIT
End DoDot:1
ORQ ; end
+1 ;D ADD("</results>")
+2 DO TOXML^EDPXML(.EDPARR,.EDPRES)
+3 QUIT
+4 ;
VAL(X) QUIT $GET(PARAM(X,1))
+1 ;
ESC(X) ; -- escape outgoing XML
+1 ; Q $ZCONVERT(X,"O","HTML") ; uncomment for fastest performance on Cache
+2 ;
+3 NEW I,Y,QOT
SET QOT=""""
+4 SET Y=$PIECE(X,"&")
FOR I=2:1:$LENGTH(X,"&")
SET Y=Y_"&"_$PIECE(X,"&",I)
+5 SET X=Y
SET Y=$PIECE(X,"<")
FOR I=2:1:$LENGTH(X,"<")
SET Y=Y_"<"_$PIECE(X,"<",I)
+6 SET X=Y
SET Y=$PIECE(X,">")
FOR I=2:1:$LENGTH(X,">")
SET Y=Y_">"_$PIECE(X,">",I)
+7 SET X=Y
SET Y=$PIECE(X,"'")
FOR I=2:1:$LENGTH(X,"'")
SET Y=Y_"'"_$PIECE(X,"'",I)
+8 SET X=Y
SET Y=$PIECE(X,QOT)
FOR I=2:1:$LENGTH(X,QOT)
SET Y=Y_"""_$PIECE(X,QOT,I)
+9 QUIT Y
+10 ;
STATUS(STS,ORDER) ; -- Return result status for ORDER status
+1 NEW Y,X
+2 SET STS=+$GET(STS)
SET ORDER=+$GET(ORDER)
+3 ;look for reason
IF STS=1
SET Y="Order discontinued"
if ORDER
Begin DoDot:1
+4 SET X=$$GET1^DIQ(100,ORDER_",",65)
if '$LENGTH(X)
SET X=$$GET1^DIQ(100,ORDER_",",64)
+5 IF $LENGTH(X)
SET Y=Y_" ("_X_")"
End DoDot:1
+6 IF STS=2
SET Y="Results"_$SELECT($$ACKD^EDPHIST(ORDER):" acknowledged",1:" available")
+7 IF STS=3
SET Y="On hold"
+8 IF STS=5
SET Y="Order pending"
+9 ;"Active"
IF STS=6
SET Y="Specimen in lab"
+10 IF STS=7
SET Y="Order expired"
+11 IF STS=8
SET Y="Scheduled"
+12 IF STS=9
SET Y="Partial results available"
+13 IF STS=10!(STS=11)
SET Y="Order not released"
+14 IF STS=12
SET Y="Order discontinued (changed)"
+15 IF STS=13
SET Y="Order cancelled"
+16 IF STS=14
SET Y="Order discontinued (lapsed)"
+17 IF STS=15
SET Y="Order renewed"
+18 QUIT Y
+19 ;
TMP(Y,DFN,SUB,IDT,SEQ,LIST) ; -- Return ^TMP("LRRR",$J,DFN,SUB,IDT,SEQ) data
+1 ; in Y("attribute")=value
+2 ; I SUB = MI or BB ??
+3 NEW X0,X,XC,FAC,ACK
+4 SET X0=$GET(^TMP("LRRR",$JOB,DFN,SUB,IDT,SEQ))
+5 ;
+6 ; BWF 2/2/2012 - Due to errors occuring on the client side when too much data
+7 ; is retrieved from this call, an initial call can now be made that will return
+8 ; a list of the available labs. The client side will then be able to call back in
+9 ; with a list of labs being requested in smaller chunks.
+10 ; If LIST is passed as '1', only pass back the list of testID's and collected date
+11 IF $GET(LIST)
SET Y("testID")=SEQ_";"_IDT
QUIT
+12 ;
+13 SET Y("subscript")=SUB
SET Y("accession")=SUB_";"_IDT
+14 ;S Y("collectedTS")=$$FMTHL7^XLFDT(9999999-IDT)
+15 SET Y("collectedTS")=(9999999-IDT)
+16 ; BWF 6/14/13 - Added $$ESC for testName
+17 SET Y("testID")=+X0
SET Y("testName")=$$ESC($PIECE($GET(^LAB(60,+X0,0)),U))
SET X=+$PIECE($GET(^(.1)),U,6)
+18 SET Y("printOrder")=$SELECT(X:+X,1:SEQ/1000000)
+19 if $LENGTH($PIECE(X0,U,2))
SET Y("result")=$PIECE(X0,U,2)
+20 IF $GET(Y("result"))'=""
Begin DoDot:1
+21 IF Y("result")["<"
SET Y("result")=$$ESC(Y("result"))
+22 IF Y("result")[">"
SET Y("result")=$$ESC(Y("result"))
End DoDot:1
+23 if $LENGTH($PIECE(X0,U,4))
SET Y("units")=$$ESC($PIECE(X0,U,4))
+24 if $LENGTH($PIECE(X0,U,3))
SET Y("deviation")=$$ESC($PIECE(X0,U,3))
+25 SET X=$PIECE(X0,U,5)
IF $LENGTH(X)
IF X["-"
SET Y("low")=$$ESC($PIECE(X,"-"))
SET Y("high")=$$ESC($PIECE(X,"-",2))
+26 SET Y("printName")=$$ESC($PIECE(X0,U,15))
+27 SET Y("number")=$PIECE(X0,U,16)
+28 ;sample & specimen
SET X=+$PIECE(X0,U,19)
Begin DoDot:1
+29 NEW SPC,CS,LRDFN
+30 if X<1
SET LRDFN=+$GET(^DPT(DFN,"LR"))
SET X=+$PIECE($GET(^LR(LRDFN,SUB,IDT,0)),U,5)
+31 SET SPC=$GET(^LAB(61,X,0))
if '$LENGTH(SPC)
QUIT
+32 SET Y("specimen")=$PIECE(SPC,U)
SET CS=+$PIECE(SPC,U,6)
+33 if CS
SET Y("sample")=$PIECE($GET(^LAB(62,CS,0)),U)
End DoDot:1
+34 SET X=+$PIECE(X0,U,17)
SET XC=$QUERY(^LRO(69,"C",X))
+35 ;get Lab Order info
IF $PIECE(XC,",",1,3)=("^LRO(69,""C"","_X)
Begin DoDot:1
+36 NEW LRO,LR3
+37 SET LRO=$GET(^LRO(69,+$PIECE(XC,",",4),1,+$PIECE(XC,",",5),0))
SET LR3=$GET(^(3))
+38 ;S X=+$P(LRO,U,6) S:X Y("provider")=X_U_$P($G(^VA(200,X,0)),U)
+39 ;S:X Y("order")=X
SET X=+$PIECE(LRO,U,11)
+40 SET ACK=$$ACK^EDPHIST(X,1)
+41 ;S Y("ack")=$P(ACK,U),Y("ackdt")=$P(ACK,U,2)
+42 ;S X=$P(LR3,U,2) S:X Y("resultedTS")=$$FMTHL7^XLFDT(X)
+43 SET X=$PIECE(LR3,U,2)
if X
SET Y("resultedTS")=(X)
End DoDot:1
+44 SET FAC=$$SITE^VASITE
if FAC
SET Y("stnNum")=$PIECE(FAC,U,3)
SET Y("stnName")=$PIECE(FAC,U,2)
+45 ; bwf 12/21/2011 removed setting of 'comments' to bypass errors occuring with the parser on client side
+46 ;I $D(^TMP("LRRR",$J,DFN,SUB,IDT,"N")) D ;M Y("comment")=^("N")
+47 ;. N I S I=1,X=$G(^TMP("LRRR",$J,DFN,SUB,IDT,"N",I))
+48 ;. F S I=$O(^TMP("LRRR",$J,DFN,SUB,IDT,"N",I)) Q:I<1 S X=X_$C(13,10)_^(I)
+49 ;. S Y("comment")=$$ESC(X)
+50 QUIT
