VBECRPCA ;DALOI/RLM - VBECS Lab Services Lookups ;10 April 2003
;;2.0;VBEC;;Jun 05, 2015;Build 4
;
; Note: This routine supports data exchange with an FDA registered
; medical device. As such, it may not be changed in any way without
; prior written approval from the medical device manufacturer.
;
; Integration Agreements:
; Reference to $$FIND^DIC supported by IA #2051
; Reference to $$GET1^DIQ supported by IA #2056
; Reference to GETS^DIQ supported by IA #2056
; Reference to $$CPT^ICPTCOD supported by IA #1995
; Reference to Laboratory Test file #60 supported by IA #10054
; Reference to RR^LR7OR1 supported by IA #2503
; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
; Reference to $$FMTHL7^XLFDT supported by IA #10103
; Reference to $$HL7TFM^XLFDT supported by IA #10103
; Reference to ^DIR supported by IA #10026
; Reference to ^LAM supported by IA #4779
;
QUIT
;
LOOK60 ;
S VBECCNT=0
D BEGROOT^VBECRPC("Root")
I DATA="" F S DATA=$O(^LAB(60,"B",DATA)) Q:DATA="" D L60
I DATA]"" D L60
D ENDROOT^VBECRPC("Root")
Q
L60 D KILL
;Test names may contain leading and/or trailing spaces.
I $$WSTEST(DATA) D ADD^VBECRPC("<Labtest>*Invalid Test Name*"_$$CHARCHK^XOBVLIB(DATA)_"*</Labtest>") Q
D FIND^DIC(60,,".01",,DATA,,,,,"VBOUT","ERROR")
S VBA=0 F S VBA=$O(VBOUT("DILIST",2,VBA)) Q:'VBA S VBB=VBOUT("DILIST",2,VBA) D
. ;NAME - .01, NATIONAL VA LAB CODE - 64, RESULT NLT CODE - 64.1
. D GETS^DIQ(60,VBB,".01;64;64.1","EI","VBOUT2","ERROR2")
. I $O(^LAB(60,VBB,2,0)) Q ;It's a panel
. S VBC=0 F S VBC=$O(^LAB(60,VBB,1,VBC)) Q:'VBC D
. . ;SITE/SPECIMEN - .01, UNITS - 6, LOINC CODE - 95.3
. . D GETS^DIQ(60.01,VBC_","_VBB_",",".01;6;95.3","E","VBOUT3","ERROR3")
;CONVERT
K VBOUT
S VBA=0 F S VBA=$O(VBOUT3(60.01,VBA)) Q:VBA="" D
. S VBB=$P(VBA,","),VBAC=$P(VBA,",",2),VBOUT4(VBAC,VBB)=VBOUT3(60.01,VBA,.01,"E")_"^"_VBOUT3(60.01,VBA,6,"E")_"^"_VBOUT3(60.01,VBA,95.3,"E")
K VBOUT3
S VBA=0 F S VBA=$O(VBOUT2(60,VBA)) Q:VBA="" D
. S NLT1=$$GET1^DIQ(64,VBOUT2(60,VBA,64,"I"),1)
. S NLT2=$$GET1^DIQ(64,VBOUT2(60,VBA,64.1,"I"),1)
. ;Convert name and nlt codes to smaller local array
. S VBOUT5(+VBA,.01)=VBOUT2(60,VBA,.01,"E")_"^"_NLT1_"^"_NLT2
. ;Retrieve CPT codes from file 64
. I VBOUT2(60,VBA,64,"I")]"" S CPTA=0 F S CPTA=$O(^LAM(VBOUT2(60,VBA,64,"I"),4,CPTA)) Q:'CPTA D
. . D GETS^DIQ(64.018,CPTA_","_VBOUT2(60,VBA,64,"I")_",",.01,"I","VBOUT6("_+VBA_")","CPTERR")
. I VBOUT2(60,VBA,64.1,"I")]"" S CPTA=0 F S CPTA=$O(^LAM(VBOUT2(60,VBA,64.1,"I"),4,CPTA)) Q:'CPTA D
. . D GETS^DIQ(64.018,CPTA_","_VBOUT2(60,VBA,64.1,"I")_",",.01,"I","VBOUT7("_+VBA_")","CPTERR")
K VBOUT2
;Convert internal CPT reference to external
S CPTA=0 F S CPTA=$O(VBOUT6(CPTA)) Q:'CPTA S CPTB="" F S CPTB=$O(VBOUT6(CPTA,64.018,CPTB)) Q:CPTB="" D
. S CPT=VBOUT6(CPTA,64.018,CPTB,.01,"I")
. ;Only active CPT's
. Q:'$P($$CPT^ICPTCOD(+CPT),"^",7)
. Q:CPT'["ICPT"
. S VBOUT8(CPTA,+CPTB)=$$GET1^DIQ(81,+CPT,.01)
S CPTA=0 F S CPTA=$O(VBOUT7(CPTA)) Q:'CPTA S CPTB="" F S CPTB=$O(VBOUT7(CPTA,64.018,CPTB)) Q:CPTB="" D
. S CPT=VBOUT7(CPTA,64.018,CPTB,.01,"I")
. ;Only active CPT's
. Q:'$P($$CPT^ICPTCOD(+CPT),"^",7)
. Q:CPT'["ICPT"
. S VBOUT9(CPTA,+CPTB)=$$GET1^DIQ(81,+CPT,.01)
K VBOUT6,VBOUT7
; Build XML
S VBXA=0
D ADD^VBECRPC("<Labtest>"_$$CHARCHK^XOBVLIB(DATA))
F S VBXA=$O(VBOUT5(VBXA)) Q:'VBXA I '$$WSTEST($P(VBOUT5(VBXA,.01),"^")) D D ADD^VBECRPC("</Testname>")
. D ADD^VBECRPC("<Testname>"_$$CHARCHK^XOBVLIB($P(VBOUT5(VBXA,.01),"^")))
. I $D(VBOUT4(VBXA)) S VBXI="" F S VBXI=$O(VBOUT4(VBXA,VBXI)) Q:VBXI="" D
. . ;Specimen names may contain leading and/or trailing spaces.
. . I $P($G(VBOUT4(VBXA,VBXI)),"^",1)]"",$$WSTEST($P(VBOUT4(VBXA,VBXI),"^",1)) D ADD^VBECRPC("<Specimen>*Invalid Specimen*"_$$CHARCHK^XOBVLIB($P(VBOUT4(VBXA,VBXI),"^",1))_"*</Specimen>") Q
. . I $P($G(VBOUT4(VBXA,VBXI)),"^",1)]"" D ADD^VBECRPC("<Specimen>"_$$CHARCHK^XOBVLIB($P(VBOUT4(VBXA,VBXI),"^",1)))
. . ;Units are free text and may contain spaces
. . I $P($G(VBOUT4(VBXA,VBXI)),"^",2)]"" D ADD^VBECRPC("<Units>"_$$WSTRIP($$CHARCHK^XOBVLIB($P(VBOUT4(VBXA,VBXI),"^",2)))_"</Units>")
. . I $P($G(VBOUT4(VBXA,VBXI)),"^",3)]"" D ADD^VBECRPC("<LOINC>"_$$CHARCHK^XOBVLIB($P(VBOUT4(VBXA,VBXI),"^",3)))
. . I $P($G(VBOUT5(VBXA,.01)),"^",2)]"" D ADD^VBECRPC("<NLT>"_$$CHARCHK^XOBVLIB($P(VBOUT5(VBXA,.01),"^",2)))
. . I $D(VBOUT8(VBXA)) S VBXJ=0 F S VBXJ=$O(VBOUT8(VBXA,VBXJ)) Q:'VBXJ D ADD^VBECRPC("<CPT>"_$$CHARCHK^XOBVLIB(VBOUT8(VBXA,VBXJ))_"</CPT>")
. . I $P($G(VBOUT5(VBXA,.01)),"^",2)]"" D ADD^VBECRPC("</NLT>")
. . I $P($G(VBOUT5(VBXA,.01)),"^",3)]"" D ADD^VBECRPC("<ResNLT>"_$$CHARCHK^XOBVLIB($P(VBOUT5(VBXA,.01),"^",3)))
. . I $D(VBOUT9(VBXA)) S VBXJ=0 F S VBXJ=$O(VBOUT9(VBXA,VBXJ)) Q:'VBXJ D ADD^VBECRPC("<RnCPT>"_$$CHARCHK^XOBVLIB(VBOUT9(VBXA,VBXJ))_"</RnCPT>")
. . I $P($G(VBOUT5(VBXA,.01)),"^",3)]"" D ADD^VBECRPC("</ResNLT>")
. . I $P($G(VBOUT4(VBXA,VBXI)),"^",3)]"" D ADD^VBECRPC("</LOINC>")
. . I $P($G(VBOUT4(VBXA,VBXI)),"^",1)]"" D ADD^VBECRPC("</Specimen>")
D ADD^VBECRPC("</Labtest>")
KILL ;
K CPT,CPTA,CPTB,NLT1,NLT2,VBA,VBAC,VBB,VBC,VBOUT,VBOUT2,VBOUT3,VBOUT4,VBOUT5,VBOUT6,VBOUT7,VBOUT8,VBOUT9,VBXA,VBXI,VBXJ
Q
WSTEST(VBWST) ;White space test
I $E(VBWST,1)=" "!($E(VBWST,$L(VBWST))=" ") Q 1
Q 0
WSTRIP(VBDATA) ;Strip White Space
F Q:$E(VBDATA,$L(VBDATA))'=" " S VBDATA=$E(VBDATA,1,$L(VBDATA)-1)
F Q:$E(VBDATA,1)'=" " S VBDATA=$E(VBDATA,2,$L(VBDATA))
Q VBDATA
WSCONV(VBDATA) ;Convert White Space
F Q:$E(VBDATA,$L(VBDATA))'=" " S VBDATA=$E(VBDATA,1,$L(VBDATA)-1)_"%20"
F Q:$E(VBDATA,1)'=" " S VBDATA="%20"_$E(VBDATA,2,$L(VBDATA))
Q VBDATA
;
; ----------------------------------------------------------------
; Private Method supports IA #4611
; ----------------------------------------------------------------
LABTEST(RESULTS,DATA) ; Main entry for VBECS LABORATORY TEST LOOKUP RPC
;
N X,IEN,SITE,NAME,SPEC,CNT,ARR60,ERR,LIST
S VBECCNT=0
S RESULTS=$NA(^TMP("VBEC_LABTEST_LOOKUP",$J))
K @RESULTS
D BEGROOT^VBECRPC("LabTests")
I '$D(DATA) D Q
. D ADD^VBECRPC("<LabTest><Name>No search criteria provided</Name><IEN></IEN><Specimen></Specimen></LabTest>")
. D ENDROOT^VBECRPC("LabTests")
;
D FIND^DIC(60,,"@;.01","BP",DATA,"","","","","ARR60","ERR")
I '$D(ARR60("DILIST",1,0))!($D(ERR)) D Q
. D ADD^VBECRPC("<LabTest><Name>No Lab test found for ("_$$CHARCHK^XOBVLIB(DATA)_")</Name><IEN></IEN><Specimen></Specimen></LabTest>")
. D ENDROOT^VBECRPC("LabTests")
;
S X=0
F S X=$O(ARR60("DILIST",X)) Q:X="" D
. S IEN=$P(ARR60("DILIST",X,0),"^")
. S NAME=$P(ARR60("DILIST",X,0),"^",2)
. S (SITE,CNT,LIST,SPEC)=0
. F S SITE=$O(^LAB(60,IEN,1,"B",SITE)) Q:SITE="" D
. . S CNT=CNT+1,SPEC=1
. . S SPEC(CNT)=$P(^LAB(61,SITE,0),"^")
. I 'SPEC D Q
. . D ADD^VBECRPC("<LabTest><Name>"_$$CHARCHK^XOBVLIB(NAME)_"</Name><IEN>"_$$CHARCHK^XOBVLIB(IEN)_"</IEN><Specimen></Specimen></LabTest>")
. F S LIST=$O(SPEC(LIST)) Q:LIST="" D
. . D ADD^VBECRPC("<LabTest><Name>"_$$CHARCHK^XOBVLIB(NAME)_"</Name><IEN>"_$$CHARCHK^XOBVLIB(IEN)_"</IEN>")
. . D ADD^VBECRPC("<Specimen>"_$$CHARCHK^XOBVLIB(SPEC(LIST))_"</Specimen></LabTest>")
. . I (SPEC(LIST)="BLOOD")!(SPEC(LIST)="SERUM")!(SPEC(LIST)="PLASMA") D
. . . I $G(VBECTST) W !,NAME_"^"_IEN_"^"_SPEC(LIST)
. Q
D ENDROOT^VBECRPC("LabTests")
K VBECCNT
Q
;
; --------------------------------------------------------------
; Private Method supports IA #4612
; --------------------------------------------------------------
TSTRSLT(RESULTS,SDATE,EDATE,DIV,TESTS,PATS) ;
; Main entry for VBECS LAB TEST RESULTS LOOKUP RPC
;
N VBRSX,X,Y,DFN,TEST,BDT,EDT,TESTNAME,TSTRES
S VBECCNT=0,EDT="",BDT=""
S RESULTS=$NA(^TMP("VBEC_LABRES",$J))
K @RESULTS
IF $D(SDATE) S BDT=$$HL7TFM^XLFDT(SDATE)
IF $D(EDATE) S EDT=$$HL7TFM^XLFDT(EDATE)
D BEGROOT^VBECRPC("LabTests")
S VBRSX=0
F S VBRSX=$O(PATS(VBRSX)) Q:VBRSX="" D
. S DFN=PATS(VBRSX) Q:DFN=""
. ; No tests passed in, get all test result available
. IF '$D(TESTS) D Q
. . D RR^LR7OR1(DFN,,BDT,EDT,,,,,,)
. . IF $D(^TMP("LRRR",$J,DFN)) D RESXML(DFN)
. . Q
. S Y=0 F S Y=$O(TESTS(Y)) Q:Y="" D
. . S TEST=TESTS(Y) Q:TEST=""
. . D RR^LR7OR1(DFN,,BDT,EDT,,TEST,,,,)
. . I $D(^TMP("LRRR",$J,DFN)) D RESXML(DFN)
. . Q
D ENDROOT^VBECRPC("LabTests")
;M ^XTMP("VBECLABRES",$J)=^TMP("VBEC_LABRES",$J)
Q
;
RESXML(DFN) ; Subroutine to extract Lab Test result and build return XML
Q:'$D(^TMP("LRRR",$J,DFN))
N TESTCODE,RES,TESTNAME,SUB,INVDT,SEQ,OUTPUT
S SUB=0
F S SUB=$O(^TMP("LRRR",$J,DFN,SUB)) Q:SUB']"" D
. S INVDT=0
. F S INVDT=$O(^TMP("LRRR",$J,DFN,SUB,INVDT)) Q:INVDT']"" D
. . S SEQ=0
. . F S SEQ=$O(^TMP("LRRR",$J,DFN,SUB,INVDT,SEQ)) Q:SEQ']"" D
. . . S OUTPUT=$G(^TMP("LRRR",$J,DFN,SUB,INVDT,SEQ))
. . . Q:OUTPUT']""
. . . ; Lab Test code
. . . S TESTCODE=$P(OUTPUT,"^")
. . . ; Lab Test result
. . . S RES=$P(OUTPUT,"^",2)
. . . ; Lab Test name
. . . S TESTNAME=$P(OUTPUT,"^",15)
. . . ; Date result completed converted to HL7 date/time format
. . . S COMPDATE=$$FMTHL7^XLFDT($P(^LR($$LRDFN^LR7OR1(DFN),SUB,INVDT,0),"^",3))
. . . D BEGROOT^VBECRPC("LabTest")
. . . D ADD^VBECRPC("<VistaPatientId>"_$$CHARCHK^XOBVLIB(DFN)_"</VistaPatientId>")
. . . D ADD^VBECRPC("<LabTestId>"_$$CHARCHK^XOBVLIB(TESTCODE)_"</LabTestId>")
. . . D ADD^VBECRPC("<TestPrintName>"_$$CHARCHK^XOBVLIB(TESTNAME)_"</TestPrintName>")
. . . D ADD^VBECRPC("<TestResult>"_$$CHARCHK^XOBVLIB(RES)_"</TestResult>")
. . . D ADD^VBECRPC("<TestDate>"_$$CHARCHK^XOBVLIB(COMPDATE)_"</TestDate>")
. . . D ENDROOT^VBECRPC("LabTest")
. . . Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECRPCA 9847 printed Apr 09, 2024@21:45:50 Page 2
VBECRPCA ;DALOI/RLM - VBECS Lab Services Lookups ;10 April 2003
+1 ;;2.0;VBEC;;Jun 05, 2015;Build 4
+2 ;
+3 ; Note: This routine supports data exchange with an FDA registered
+4 ; medical device. As such, it may not be changed in any way without
+5 ; prior written approval from the medical device manufacturer.
+6 ;
+7 ; Integration Agreements:
+8 ; Reference to $$FIND^DIC supported by IA #2051
+9 ; Reference to $$GET1^DIQ supported by IA #2056
+10 ; Reference to GETS^DIQ supported by IA #2056
+11 ; Reference to $$CPT^ICPTCOD supported by IA #1995
+12 ; Reference to Laboratory Test file #60 supported by IA #10054
+13 ; Reference to RR^LR7OR1 supported by IA #2503
+14 ; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
+15 ; Reference to $$FMTHL7^XLFDT supported by IA #10103
+16 ; Reference to $$HL7TFM^XLFDT supported by IA #10103
+17 ; Reference to ^DIR supported by IA #10026
+18 ; Reference to ^LAM supported by IA #4779
+19 ;
+20 QUIT
+21 ;
LOOK60 ;
+1 SET VBECCNT=0
+2 DO BEGROOT^VBECRPC("Root")
+3 IF DATA=""
FOR
SET DATA=$ORDER(^LAB(60,"B",DATA))
if DATA=""
QUIT
DO L60
+4 IF DATA]""
DO L60
+5 DO ENDROOT^VBECRPC("Root")
+6 QUIT
L60 DO KILL
+1 ;Test names may contain leading and/or trailing spaces.
+2 IF $$WSTEST(DATA)
DO ADD^VBECRPC("<Labtest>*Invalid Test Name*"_$$CHARCHK^XOBVLIB(DATA)_"*</Labtest>")
QUIT
+3 DO FIND^DIC(60,,".01",,DATA,,,,,"VBOUT","ERROR")
+4 SET VBA=0
FOR
SET VBA=$ORDER(VBOUT("DILIST",2,VBA))
if 'VBA
QUIT
SET VBB=VBOUT("DILIST",2,VBA)
Begin DoDot:1
+5 ;NAME - .01, NATIONAL VA LAB CODE - 64, RESULT NLT CODE - 64.1
+6 DO GETS^DIQ(60,VBB,".01;64;64.1","EI","VBOUT2","ERROR2")
+7 ;It's a panel
IF $ORDER(^LAB(60,VBB,2,0))
QUIT
+8 SET VBC=0
FOR
SET VBC=$ORDER(^LAB(60,VBB,1,VBC))
if 'VBC
QUIT
Begin DoDot:2
+9 ;SITE/SPECIMEN - .01, UNITS - 6, LOINC CODE - 95.3
+10 DO GETS^DIQ(60.01,VBC_","_VBB_",",".01;6;95.3","E","VBOUT3","ERROR3")
End DoDot:2
End DoDot:1
+11 ;CONVERT
+12 KILL VBOUT
+13 SET VBA=0
FOR
SET VBA=$ORDER(VBOUT3(60.01,VBA))
if VBA=""
QUIT
Begin DoDot:1
+14 SET VBB=$PIECE(VBA,",")
SET VBAC=$PIECE(VBA,",",2)
SET VBOUT4(VBAC,VBB)=VBOUT3(60.01,VBA,.01,"E")_"^"_VBOUT3(60.01,VBA,6,"E")_"^"_VBOUT3(60.01,VBA,95.3,"E")
End DoDot:1
+15 KILL VBOUT3
+16 SET VBA=0
FOR
SET VBA=$ORDER(VBOUT2(60,VBA))
if VBA=""
QUIT
Begin DoDot:1
+17 SET NLT1=$$GET1^DIQ(64,VBOUT2(60,VBA,64,"I"),1)
+18 SET NLT2=$$GET1^DIQ(64,VBOUT2(60,VBA,64.1,"I"),1)
+19 ;Convert name and nlt codes to smaller local array
+20 SET VBOUT5(+VBA,.01)=VBOUT2(60,VBA,.01,"E")_"^"_NLT1_"^"_NLT2
+21 ;Retrieve CPT codes from file 64
+22 IF VBOUT2(60,VBA,64,"I")]""
SET CPTA=0
FOR
SET CPTA=$ORDER(^LAM(VBOUT2(60,VBA,64,"I"),4,CPTA))
if 'CPTA
QUIT
Begin DoDot:2
+23 DO GETS^DIQ(64.018,CPTA_","_VBOUT2(60,VBA,64,"I")_",",.01,"I","VBOUT6("_+VBA_")","CPTERR")
End DoDot:2
+24 IF VBOUT2(60,VBA,64.1,"I")]""
SET CPTA=0
FOR
SET CPTA=$ORDER(^LAM(VBOUT2(60,VBA,64.1,"I"),4,CPTA))
if 'CPTA
QUIT
Begin DoDot:2
+25 DO GETS^DIQ(64.018,CPTA_","_VBOUT2(60,VBA,64.1,"I")_",",.01,"I","VBOUT7("_+VBA_")","CPTERR")
End DoDot:2
End DoDot:1
+26 KILL VBOUT2
+27 ;Convert internal CPT reference to external
+28 SET CPTA=0
FOR
SET CPTA=$ORDER(VBOUT6(CPTA))
if 'CPTA
QUIT
SET CPTB=""
FOR
SET CPTB=$ORDER(VBOUT6(CPTA,64.018,CPTB))
if CPTB=""
QUIT
Begin DoDot:1
+29 SET CPT=VBOUT6(CPTA,64.018,CPTB,.01,"I")
+30 ;Only active CPT's
+31 if '$PIECE($$CPT^ICPTCOD(+CPT),"^",7)
QUIT
+32 if CPT'["ICPT"
QUIT
+33 SET VBOUT8(CPTA,+CPTB)=$$GET1^DIQ(81,+CPT,.01)
End DoDot:1
+34 SET CPTA=0
FOR
SET CPTA=$ORDER(VBOUT7(CPTA))
if 'CPTA
QUIT
SET CPTB=""
FOR
SET CPTB=$ORDER(VBOUT7(CPTA,64.018,CPTB))
if CPTB=""
QUIT
Begin DoDot:1
+35 SET CPT=VBOUT7(CPTA,64.018,CPTB,.01,"I")
+36 ;Only active CPT's
+37 if '$PIECE($$CPT^ICPTCOD(+CPT),"^",7)
QUIT
+38 if CPT'["ICPT"
QUIT
+39 SET VBOUT9(CPTA,+CPTB)=$$GET1^DIQ(81,+CPT,.01)
End DoDot:1
+40 KILL VBOUT6,VBOUT7
+41 ; Build XML
+42 SET VBXA=0
+43 DO ADD^VBECRPC("<Labtest>"_$$CHARCHK^XOBVLIB(DATA))
+44 FOR
SET VBXA=$ORDER(VBOUT5(VBXA))
if 'VBXA
QUIT
IF '$$WSTEST($PIECE(VBOUT5(VBXA,.01),"^"))
Begin DoDot:1
+45 DO ADD^VBECRPC("<Testname>"_$$CHARCHK^XOBVLIB($PIECE(VBOUT5(VBXA,.01),"^")))
+46 IF $DATA(VBOUT4(VBXA))
SET VBXI=""
FOR
SET VBXI=$ORDER(VBOUT4(VBXA,VBXI))
if VBXI=""
QUIT
Begin DoDot:2
+47 ;Specimen names may contain leading and/or trailing spaces.
+48 IF $PIECE($GET(VBOUT4(VBXA,VBXI)),"^",1)]""
IF $$WSTEST($PIECE(VBOUT4(VBXA,VBXI),"^",1))
DO ADD^VBECRPC("<Specimen>*Invalid Specimen*"_$$CHARCHK^XOBVLIB($PIECE(VBOUT4(VBXA,VBXI),"^",1))_"*</Specimen>")
QUIT
+49 IF $PIECE($GET(VBOUT4(VBXA,VBXI)),"^",1)]""
DO ADD^VBECRPC("<Specimen>"_$$CHARCHK^XOBVLIB($PIECE(VBOUT4(VBXA,VBXI),"^",1)))
+50 ;Units are free text and may contain spaces
+51 IF $PIECE($GET(VBOUT4(VBXA,VBXI)),"^",2)]""
DO ADD^VBECRPC("<Units>"_$$WSTRIP($$CHARCHK^XOBVLIB($PIECE(VBOUT4(VBXA,VBXI),"^",2)))_"</Units>")
+52 IF $PIECE($GET(VBOUT4(VBXA,VBXI)),"^",3)]""
DO ADD^VBECRPC("<LOINC>"_$$CHARCHK^XOBVLIB($PIECE(VBOUT4(VBXA,VBXI),"^",3)))
+53 IF $PIECE($GET(VBOUT5(VBXA,.01)),"^",2)]""
DO ADD^VBECRPC("<NLT>"_$$CHARCHK^XOBVLIB($PIECE(VBOUT5(VBXA,.01),"^",2)))
+54 IF $DATA(VBOUT8(VBXA))
SET VBXJ=0
FOR
SET VBXJ=$ORDER(VBOUT8(VBXA,VBXJ))
if 'VBXJ
QUIT
DO ADD^VBECRPC("<CPT>"_$$CHARCHK^XOBVLIB(VBOUT8(VBXA,VBXJ))_"</CPT>")
+55 IF $PIECE($GET(VBOUT5(VBXA,.01)),"^",2)]""
DO ADD^VBECRPC("</NLT>")
+56 IF $PIECE($GET(VBOUT5(VBXA,.01)),"^",3)]""
DO ADD^VBECRPC("<ResNLT>"_$$CHARCHK^XOBVLIB($PIECE(VBOUT5(VBXA,.01),"^",3)))
+57 IF $DATA(VBOUT9(VBXA))
SET VBXJ=0
FOR
SET VBXJ=$ORDER(VBOUT9(VBXA,VBXJ))
if 'VBXJ
QUIT
DO ADD^VBECRPC("<RnCPT>"_$$CHARCHK^XOBVLIB(VBOUT9(VBXA,VBXJ))_"</RnCPT>")
+58 IF $PIECE($GET(VBOUT5(VBXA,.01)),"^",3)]""
DO ADD^VBECRPC("</ResNLT>")
+59 IF $PIECE($GET(VBOUT4(VBXA,VBXI)),"^",3)]""
DO ADD^VBECRPC("</LOINC>")
+60 IF $PIECE($GET(VBOUT4(VBXA,VBXI)),"^",1)]""
DO ADD^VBECRPC("</Specimen>")
End DoDot:2
End DoDot:1
DO ADD^VBECRPC("</Testname>")
+61 DO ADD^VBECRPC("</Labtest>")
KILL ;
+1 KILL CPT,CPTA,CPTB,NLT1,NLT2,VBA,VBAC,VBB,VBC,VBOUT,VBOUT2,VBOUT3,VBOUT4,VBOUT5,VBOUT6,VBOUT7,VBOUT8,VBOUT9,VBXA,VBXI,VBXJ
+2 QUIT
WSTEST(VBWST) ;White space test
+1 IF $EXTRACT(VBWST,1)=" "!($EXTRACT(VBWST,$LENGTH(VBWST))=" ")
QUIT 1
+2 QUIT 0
WSTRIP(VBDATA) ;Strip White Space
+1 FOR
if $EXTRACT(VBDATA,$LENGTH(VBDATA))'=" "
QUIT
SET VBDATA=$EXTRACT(VBDATA,1,$LENGTH(VBDATA)-1)
+2 FOR
if $EXTRACT(VBDATA,1)'=" "
QUIT
SET VBDATA=$EXTRACT(VBDATA,2,$LENGTH(VBDATA))
+3 QUIT VBDATA
WSCONV(VBDATA) ;Convert White Space
+1 FOR
if $EXTRACT(VBDATA,$LENGTH(VBDATA))'=" "
QUIT
SET VBDATA=$EXTRACT(VBDATA,1,$LENGTH(VBDATA)-1)_"%20"
+2 FOR
if $EXTRACT(VBDATA,1)'=" "
QUIT
SET VBDATA="%20"_$EXTRACT(VBDATA,2,$LENGTH(VBDATA))
+3 QUIT VBDATA
+4 ;
+5 ; ----------------------------------------------------------------
+6 ; Private Method supports IA #4611
+7 ; ----------------------------------------------------------------
LABTEST(RESULTS,DATA) ; Main entry for VBECS LABORATORY TEST LOOKUP RPC
+1 ;
+2 NEW X,IEN,SITE,NAME,SPEC,CNT,ARR60,ERR,LIST
+3 SET VBECCNT=0
+4 SET RESULTS=$NAME(^TMP("VBEC_LABTEST_LOOKUP",$JOB))
+5 KILL @RESULTS
+6 DO BEGROOT^VBECRPC("LabTests")
+7 IF '$DATA(DATA)
Begin DoDot:1
+8 DO ADD^VBECRPC("<LabTest><Name>No search criteria provided</Name><IEN></IEN><Specimen></Specimen></LabTest>")
+9 DO ENDROOT^VBECRPC("LabTests")
End DoDot:1
QUIT
+10 ;
+11 DO FIND^DIC(60,,"@;.01","BP",DATA,"","","","","ARR60","ERR")
+12 IF '$DATA(ARR60("DILIST",1,0))!($DATA(ERR))
Begin DoDot:1
+13 DO ADD^VBECRPC("<LabTest><Name>No Lab test found for ("_$$CHARCHK^XOBVLIB(DATA)_")</Name><IEN></IEN><Specimen></Specimen></LabTest>")
+14 DO ENDROOT^VBECRPC("LabTests")
End DoDot:1
QUIT
+15 ;
+16 SET X=0
+17 FOR
SET X=$ORDER(ARR60("DILIST",X))
if X=""
QUIT
Begin DoDot:1
+18 SET IEN=$PIECE(ARR60("DILIST",X,0),"^")
+19 SET NAME=$PIECE(ARR60("DILIST",X,0),"^",2)
+20 SET (SITE,CNT,LIST,SPEC)=0
+21 FOR
SET SITE=$ORDER(^LAB(60,IEN,1,"B",SITE))
if SITE=""
QUIT
Begin DoDot:2
+22 SET CNT=CNT+1
SET SPEC=1
+23 SET SPEC(CNT)=$PIECE(^LAB(61,SITE,0),"^")
End DoDot:2
+24 IF 'SPEC
Begin DoDot:2
+25 DO ADD^VBECRPC("<LabTest><Name>"_$$CHARCHK^XOBVLIB(NAME)_"</Name><IEN>"_$$CHARCHK^XOBVLIB(IEN)_"</IEN><Specimen></Specimen></LabTest>")
End DoDot:2
QUIT
+26 FOR
SET LIST=$ORDER(SPEC(LIST))
if LIST=""
QUIT
Begin DoDot:2
+27 DO ADD^VBECRPC("<LabTest><Name>"_$$CHARCHK^XOBVLIB(NAME)_"</Name><IEN>"_$$CHARCHK^XOBVLIB(IEN)_"</IEN>")
+28 DO ADD^VBECRPC("<Specimen>"_$$CHARCHK^XOBVLIB(SPEC(LIST))_"</Specimen></LabTest>")
+29 IF (SPEC(LIST)="BLOOD")!(SPEC(LIST)="SERUM")!(SPEC(LIST)="PLASMA")
Begin DoDot:3
+30 IF $GET(VBECTST)
WRITE !,NAME_"^"_IEN_"^"_SPEC(LIST)
End DoDot:3
End DoDot:2
+31 QUIT
End DoDot:1
+32 DO ENDROOT^VBECRPC("LabTests")
+33 KILL VBECCNT
+34 QUIT
+35 ;
+36 ; --------------------------------------------------------------
+37 ; Private Method supports IA #4612
+38 ; --------------------------------------------------------------
TSTRSLT(RESULTS,SDATE,EDATE,DIV,TESTS,PATS) ;
+1 ; Main entry for VBECS LAB TEST RESULTS LOOKUP RPC
+2 ;
+3 NEW VBRSX,X,Y,DFN,TEST,BDT,EDT,TESTNAME,TSTRES
+4 SET VBECCNT=0
SET EDT=""
SET BDT=""
+5 SET RESULTS=$NAME(^TMP("VBEC_LABRES",$JOB))
+6 KILL @RESULTS
+7 IF $DATA(SDATE)
SET BDT=$$HL7TFM^XLFDT(SDATE)
+8 IF $DATA(EDATE)
SET EDT=$$HL7TFM^XLFDT(EDATE)
+9 DO BEGROOT^VBECRPC("LabTests")
+10 SET VBRSX=0
+11 FOR
SET VBRSX=$ORDER(PATS(VBRSX))
if VBRSX=""
QUIT
Begin DoDot:1
+12 SET DFN=PATS(VBRSX)
if DFN=""
QUIT
+13 ; No tests passed in, get all test result available
+14 IF '$DATA(TESTS)
Begin DoDot:2
+15 DO RR^LR7OR1(DFN,,BDT,EDT,,,,,,)
+16 IF $DATA(^TMP("LRRR",$JOB,DFN))
DO RESXML(DFN)
+17 QUIT
End DoDot:2
QUIT
+18 SET Y=0
FOR
SET Y=$ORDER(TESTS(Y))
if Y=""
QUIT
Begin DoDot:2
+19 SET TEST=TESTS(Y)
if TEST=""
QUIT
+20 DO RR^LR7OR1(DFN,,BDT,EDT,,TEST,,,,)
+21 IF $DATA(^TMP("LRRR",$JOB,DFN))
DO RESXML(DFN)
+22 QUIT
End DoDot:2
End DoDot:1
+23 DO ENDROOT^VBECRPC("LabTests")
+24 ;M ^XTMP("VBECLABRES",$J)=^TMP("VBEC_LABRES",$J)
+25 QUIT
+26 ;
RESXML(DFN) ; Subroutine to extract Lab Test result and build return XML
+1 if '$DATA(^TMP("LRRR",$JOB,DFN))
QUIT
+2 NEW TESTCODE,RES,TESTNAME,SUB,INVDT,SEQ,OUTPUT
+3 SET SUB=0
+4 FOR
SET SUB=$ORDER(^TMP("LRRR",$JOB,DFN,SUB))
if SUB']""
QUIT
Begin DoDot:1
+5 SET INVDT=0
+6 FOR
SET INVDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,INVDT))
if INVDT']""
QUIT
Begin DoDot:2
+7 SET SEQ=0
+8 FOR
SET SEQ=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,INVDT,SEQ))
if SEQ']""
QUIT
Begin DoDot:3
+9 SET OUTPUT=$GET(^TMP("LRRR",$JOB,DFN,SUB,INVDT,SEQ))
+10 if OUTPUT']""
QUIT
+11 ; Lab Test code
+12 SET TESTCODE=$PIECE(OUTPUT,"^")
+13 ; Lab Test result
+14 SET RES=$PIECE(OUTPUT,"^",2)
+15 ; Lab Test name
+16 SET TESTNAME=$PIECE(OUTPUT,"^",15)
+17 ; Date result completed converted to HL7 date/time format
+18 SET COMPDATE=$$FMTHL7^XLFDT($PIECE(^LR($$LRDFN^LR7OR1(DFN),SUB,INVDT,0),"^",3))
+19 DO BEGROOT^VBECRPC("LabTest")
+20 DO ADD^VBECRPC("<VistaPatientId>"_$$CHARCHK^XOBVLIB(DFN)_"</VistaPatientId>")
+21 DO ADD^VBECRPC("<LabTestId>"_$$CHARCHK^XOBVLIB(TESTCODE)_"</LabTestId>")
+22 DO ADD^VBECRPC("<TestPrintName>"_$$CHARCHK^XOBVLIB(TESTNAME)_"</TestPrintName>")
+23 DO ADD^VBECRPC("<TestResult>"_$$CHARCHK^XOBVLIB(RES)_"</TestResult>")
+24 DO ADD^VBECRPC("<TestDate>"_$$CHARCHK^XOBVLIB(COMPDATE)_"</TestDate>")
+25 DO ENDROOT^VBECRPC("LabTest")
+26 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
