VBECA6 ;DALOI/RLM - ORDER LOOKUP BY UID ;05/14/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 #2052
; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
; Reference to CHKNAME^XQ5 supported by IA #????
;
ORDER(RESULTS,VBUID) ;
;Bring in UID and RESULTS parameters.
;UID will be the Universal Identifier for this order.
;RESULTS will be the array where the data will be stored.
N TEST,ERROR
S VBECCNT=0
S RESULTS=$NA(^TMP("VBECS_UIDLOOKUP",$J))
K @RESULTS
D BEGROOT^VBECRPC("UIDLookup")
I VBUID']"" D Q
. D ERROR^VBECRPC("No Specimen UID provided")
. D ENDROOT^VBECRPC("UIDLookup")
;
D FIND^DIC(68,,.01,,"BLOOD BANK",,,,,"TEST","ERROR")
S VBACC=TEST("DILIST",2,1)
I '$D(^LRO(68,"C",VBUID,VBACC)) D Q
. D ERROR^VBECRPC("No Blood Bank accession associated with UID '"_VBUID_"'")
. D ENDROOT^VBECRPC("UIDLookup")
;
S VBA=0 F S VBA=$O(^LRO(68,"C",VBUID,VBACC,VBA)) Q:'VBA D
. S VBB=0 F S VBB=$O(^LRO(68,"C",VBUID,VBACC,VBA,VBB)) Q:'VBB D
. . Q:$P($G(^LRO(68,VBACC,1,VBA,1,VBB,0)),"^",2)'=2 ;Add parameter for 67 if necessary
. . S LRDFN=$P($G(^LRO(68,VBACC,1,VBA,1,VBB,0)),"^"),DFN=$P($G(^LR(LRDFN,0)),"^",3)
. . S VBNAME=$$GET1^DIQ(2,DFN,.01)
. . ;Add DFN and Name
. . D ADD^VBECRPC("<PatientName>"_$$CHARCHK^XOBVLIB(VBNAME)_"</PatientName>")
. . D ADD^VBECRPC("<VistaPatientId>"_$$CHARCHK^XOBVLIB(DFN)_"</VistaPatientId>")
. . ;Add Accession number
. . S VBACCN=$P($G(^LRO(68,VBACC,1,VBA,1,VBB,.2)),"^")
. . D ADD^VBECRPC("<SpecimenAccessionNumber>"_$$CHARCHK^XOBVLIB(VBACCN)_"</SpecimenAccessionNumber>")
. . S VBORDN=+$P($G(^LRO(68,VBACC,1,VBA,1,VBB,.1)),"^")
. . ;Add Order Number
. . D ADD^VBECRPC("<LabOrderNumber>"_$$CHARCHK^XOBVLIB(VBORDN)_"</LabOrderNumber>")
. . ;Add UID from file 68
. . S VBUID68=$P($G(^LRO(68,VBACC,1,VBA,1,VBB,.3)),"^")
. . D ADD^VBECRPC("<SpecimenUID>"_$$CHARCHK^XOBVLIB(VBUID68)_"</SpecimenUID>")
. . ;Add Tests
. . D BEGROOT^VBECRPC("LabTests")
. . S VBC=0 F S VBC=$O(^LRO(68,VBACC,1,VBA,1,VBB,4,VBC)) Q:'VBC D
. . . S VBTEST=+$P($G(^LRO(68,VBACC,1,VBA,1,VBB,4,VBC,0)),"^")
. . . S VBTNM=$$GET1^DIQ(60,VBTEST,.01)
. . . ;Add Test Name
. . . D BEGROOT^VBECRPC("LabTest")
. . . D ADD^VBECRPC("<LabTestID>"_$$CHARCHK^XOBVLIB(VBTEST)_"</LabTestID>")
. . . D ADD^VBECRPC("<LabTestName>"_$$CHARCHK^XOBVLIB(VBTNM)_"</LabTestName>")
. . . D ENDROOT^VBECRPC("LabTest")
. . ;Close Tests
. . D ENDROOT^VBECRPC("LabTests")
D ENDROOT^VBECRPC("UIDLookup")
K DFN,LRDFN,TEST,VBA,VBACC,VBB,VBC,VBECCNT,VBNAME,VBORDN,VBTEST,VBTNM,VBUID,VBUID68,VBACCN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECA6 2945 printed Sep 23, 2025@20:19:58 Page 2
VBECA6 ;DALOI/RLM - ORDER LOOKUP BY UID ;05/14/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 #2052
+10 ; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
+11 ; Reference to CHKNAME^XQ5 supported by IA #????
+12 ;
ORDER(RESULTS,VBUID) ;
+1 ;Bring in UID and RESULTS parameters.
+2 ;UID will be the Universal Identifier for this order.
+3 ;RESULTS will be the array where the data will be stored.
+4 NEW TEST,ERROR
+5 SET VBECCNT=0
+6 SET RESULTS=$NAME(^TMP("VBECS_UIDLOOKUP",$JOB))
+7 KILL @RESULTS
+8 DO BEGROOT^VBECRPC("UIDLookup")
+9 IF VBUID']""
Begin DoDot:1
+10 DO ERROR^VBECRPC("No Specimen UID provided")
+11 DO ENDROOT^VBECRPC("UIDLookup")
End DoDot:1
QUIT
+12 ;
+13 DO FIND^DIC(68,,.01,,"BLOOD BANK",,,,,"TEST","ERROR")
+14 SET VBACC=TEST("DILIST",2,1)
+15 IF '$DATA(^LRO(68,"C",VBUID,VBACC))
Begin DoDot:1
+16 DO ERROR^VBECRPC("No Blood Bank accession associated with UID '"_VBUID_"'")
+17 DO ENDROOT^VBECRPC("UIDLookup")
End DoDot:1
QUIT
+18 ;
+19 SET VBA=0
FOR
SET VBA=$ORDER(^LRO(68,"C",VBUID,VBACC,VBA))
if 'VBA
QUIT
Begin DoDot:1
+20 SET VBB=0
FOR
SET VBB=$ORDER(^LRO(68,"C",VBUID,VBACC,VBA,VBB))
if 'VBB
QUIT
Begin DoDot:2
+21 ;Add parameter for 67 if necessary
if $PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,0)),"^",2)'=2
QUIT
+22 SET LRDFN=$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,0)),"^")
SET DFN=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+23 SET VBNAME=$$GET1^DIQ(2,DFN,.01)
+24 ;Add DFN and Name
+25 DO ADD^VBECRPC("<PatientName>"_$$CHARCHK^XOBVLIB(VBNAME)_"</PatientName>")
+26 DO ADD^VBECRPC("<VistaPatientId>"_$$CHARCHK^XOBVLIB(DFN)_"</VistaPatientId>")
+27 ;Add Accession number
+28 SET VBACCN=$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,.2)),"^")
+29 DO ADD^VBECRPC("<SpecimenAccessionNumber>"_$$CHARCHK^XOBVLIB(VBACCN)_"</SpecimenAccessionNumber>")
+30 SET VBORDN=+$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,.1)),"^")
+31 ;Add Order Number
+32 DO ADD^VBECRPC("<LabOrderNumber>"_$$CHARCHK^XOBVLIB(VBORDN)_"</LabOrderNumber>")
+33 ;Add UID from file 68
+34 SET VBUID68=$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,.3)),"^")
+35 DO ADD^VBECRPC("<SpecimenUID>"_$$CHARCHK^XOBVLIB(VBUID68)_"</SpecimenUID>")
+36 ;Add Tests
+37 DO BEGROOT^VBECRPC("LabTests")
+38 SET VBC=0
FOR
SET VBC=$ORDER(^LRO(68,VBACC,1,VBA,1,VBB,4,VBC))
if 'VBC
QUIT
Begin DoDot:3
+39 SET VBTEST=+$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,4,VBC,0)),"^")
+40 SET VBTNM=$$GET1^DIQ(60,VBTEST,.01)
+41 ;Add Test Name
+42 DO BEGROOT^VBECRPC("LabTest")
+43 DO ADD^VBECRPC("<LabTestID>"_$$CHARCHK^XOBVLIB(VBTEST)_"</LabTestID>")
+44 DO ADD^VBECRPC("<LabTestName>"_$$CHARCHK^XOBVLIB(VBTNM)_"</LabTestName>")
+45 DO ENDROOT^VBECRPC("LabTest")
End DoDot:3
+46 ;Close Tests
+47 DO ENDROOT^VBECRPC("LabTests")
End DoDot:2
End DoDot:1
+48 DO ENDROOT^VBECRPC("UIDLookup")
+49 KILL DFN,LRDFN,TEST,VBA,VBACC,VBB,VBC,VBECCNT,VBNAME,VBORDN,VBTEST,VBTNM,VBUID,VBUID68,VBACCN
+50 QUIT
