VBECRPCB ;HOIFO/BNT - ORDER LOOKUP BY UID ;03/24/2004
;;2.0;VBECS;;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 CHECKUID^LRWU4 supported by IA #4636
; Reference to LABORATORY TEST file 60 supported by IA #10054
; Reference to LAB ORDER ENTRY file 69 supported by IA #4774
; Reference to ACCESSION file 68 supported by IA #4773
; Reference to PATIENT file 2 supported by IA #10035
; Reference to $$FMTHL7^XLFDT supported by IA #10103
;
QUIT
;
; -----------------------------------------------------------------------
; Private Method supports IA #4633
; -----------------------------------------------------------------------
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 VB68=$$CHECKUID^LRWU4(VBUID)
I '+VB68!('$L($P(VB68,"^",2))) D Q
. D ERROR^VBECRPC("No accession associated with UID '"_VBUID_"'")
. D ENDROOT^VBECRPC("UIDLookup")
;
I $P($G(^LRO(68,$P(VB68,"^",2),0)),"^",2)'="BB" D Q
. D ERROR^VBECRPC("No Blood Bank accession area associated with UID '"_VBUID_"'")
. D ENDROOT^VBECRPC("UIDLookup")
;
S VBACC=$P(VB68,"^",2)
S VBA=$P(VB68,"^",3)
S VBB=$P(VB68,"^",4)
;
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)
;Add Collection Date/Time
S VBCOLDT=$P($G(^LRO(68,VBACC,1,VBA,1,VBB,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 collection date/time
D ADD^VBECRPC("<CollectionDateTime>"_$$CHARCHK^XOBVLIB($$FMTHL7^XLFDT(VBCOLDT))_"</CollectionDateTime>")
;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
;
; -----------------------------------------------------------------------
; Private Method supports IA #4614
; -----------------------------------------------------------------------
ORDNUM(RESULTS,LROIEN) ;
;
N TEST,QUIT,VBA,VBB
S (VBECCNT,QUIT)=0
S RESULTS=$NA(^TMP("VBECS_ORDLOOKUP",$J))
K @RESULTS
D BEGROOT^VBECRPC("UIDLookup")
I LROIEN']"" D Q
. D ERROR^VBECRPC("No Lab Order Number provided")
. D ENDROOT^VBECRPC("UIDLookup")
;
I '$D(^LRO(69,"C",LROIEN)) D Q
. D ERROR^VBECRPC("Lab Order Number "_LROIEN_" not found in file 69")
. D ENDROOT^VBECRPC("UIDLookup")
S VBA=0 F S VBA=$O(^LRO(69,"C",LROIEN,VBA)) Q:'VBA D Q:QUIT
. S VBB=0 F S VBB=$O(^LRO(69,"C",LROIEN,VBA,VBB)) Q:'VBB D
. . i $p($g(^LRO(69,VBA,1,VBB,1)),"^",4)'="C" s QUIT=1 q ;Collection status
. . ; Order has been merged.
. . IF $P($G(^LRO(69,VBA,1,VBB,1)),"^",7)]"" S QUIT=1 Q
. . D BEGROOT^VBECRPC("LabTests")
. . S VBC=0 F S VBC=$O(^LRO(69,VBA,1,VBB,2,VBC)) Q:'VBC D
. . . D BEGROOT^VBECRPC("LabTest")
. . . S VBLR0=^LRO(69,VBA,1,VBB,2,VBC,0)
. . . S LRDFN=$P(^LRO(69,VBA,1,VBB,0),"^",1),DFN=$P($G(^LR(LRDFN,0)),"^",3)
. . . S VBNAME=$$GET1^DIQ(2,DFN,.01)
. . . S VBTEST=$P($G(VBLR0),"^")
. . . S VBTNM=$$GET1^DIQ(60,VBTEST,.01)
. . . I $P($G(^LRO(69,VBA,1,VBB,2,VBC,0)),"^",3)']"" D Q
. . . . S QUIT=1
. . . . D ERROR^VBECRPC("Lab Test "_VBTNM_" on order number "_LROIEN_" has not been accessioned")
. . . . D ENDROOT^VBECRPC("LabTest")
. . . S VBUID=$G(^LRO(69,VBA,1,VBB,2,VBC,.3))
. . . S VBCOLDT=$P($G(^LRO(68,$P($G(VBLR0),"^",4),1,$P($G(VBLR0),"^",3),1,$P($G(VBLR0),"^",5),3)),"^")
. . . S VBACCN=$G(^LRO(68,$P($G(VBLR0),"^",4),1,$P($G(VBLR0),"^",3),1,$P($G(VBLR0),"^",5),.2))
. . .;Add DFN and Name
. . . D ADD^VBECRPC("<PatientName>"_$$CHARCHK^XOBVLIB(VBNAME)_"</PatientName>")
. . . D ADD^VBECRPC("<VistaPatientId>"_$$CHARCHK^XOBVLIB(DFN)_"</VistaPatientId>")
. . . D ADD^VBECRPC("<LabOrderNumber>"_$$CHARCHK^XOBVLIB(LROIEN)_"</LabOrderNumber>")
. . . D ADD^VBECRPC("<LabTestID>"_$$CHARCHK^XOBVLIB(VBTEST)_"</LabTestID>")
. . . D ADD^VBECRPC("<LabTestName>"_$$CHARCHK^XOBVLIB(VBTNM)_"</LabTestName>")
. . . D ADD^VBECRPC("<SpecimenAccessionNumber>"_$$CHARCHK^XOBVLIB(VBACCN)_"</SpecimenAccessionNumber>")
. . . D ADD^VBECRPC("<SpecimenUID>"_$$CHARCHK^XOBVLIB(VBUID)_"</SpecimenUID>")
. . . ;Add collection date/time
. . . D ADD^VBECRPC("<CollectionDateTime>"_$$CHARCHK^XOBVLIB($$FMTHL7^XLFDT(VBCOLDT))_"</CollectionDateTime>")
. . . D ENDROOT^VBECRPC("LabTest")
. . . Q
. . D ENDROOT^VBECRPC("LabTests")
. . Q
. Q
D ENDROOT^VBECRPC("UIDLookup")
K DFN,LRDFN,VBA,VBACC,VBB,VBECCNT,VBNAME,VBORDN,VBTEST,VBTNM,VBUID,VBUID68,VBACCN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECRPCB 6381 printed Nov 22, 2024@17:54:23 Page 2
VBECRPCB ;HOIFO/BNT - ORDER LOOKUP BY UID ;03/24/2004
+1 ;;2.0;VBECS;;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 CHECKUID^LRWU4 supported by IA #4636
+12 ; Reference to LABORATORY TEST file 60 supported by IA #10054
+13 ; Reference to LAB ORDER ENTRY file 69 supported by IA #4774
+14 ; Reference to ACCESSION file 68 supported by IA #4773
+15 ; Reference to PATIENT file 2 supported by IA #10035
+16 ; Reference to $$FMTHL7^XLFDT supported by IA #10103
+17 ;
+18 QUIT
+19 ;
+20 ; -----------------------------------------------------------------------
+21 ; Private Method supports IA #4633
+22 ; -----------------------------------------------------------------------
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 ;D FIND^DIC(68,,.01,,"BLOOD BANK",,,,,"TEST","ERROR")
+14 SET VB68=$$CHECKUID^LRWU4(VBUID)
+15 IF '+VB68!('$LENGTH($PIECE(VB68,"^",2)))
Begin DoDot:1
+16 DO ERROR^VBECRPC("No accession associated with UID '"_VBUID_"'")
+17 DO ENDROOT^VBECRPC("UIDLookup")
End DoDot:1
QUIT
+18 ;
+19 IF $PIECE($GET(^LRO(68,$PIECE(VB68,"^",2),0)),"^",2)'="BB"
Begin DoDot:1
+20 DO ERROR^VBECRPC("No Blood Bank accession area associated with UID '"_VBUID_"'")
+21 DO ENDROOT^VBECRPC("UIDLookup")
End DoDot:1
QUIT
+22 ;
+23 SET VBACC=$PIECE(VB68,"^",2)
+24 SET VBA=$PIECE(VB68,"^",3)
+25 SET VBB=$PIECE(VB68,"^",4)
+26 ;
+27 ;Add parameter for 67 if necessary
if $PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,0)),"^",2)'=2
QUIT
+28 SET LRDFN=$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,0)),"^")
SET DFN=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+29 ;Add Collection Date/Time
+30 SET VBCOLDT=$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,3)),"^")
+31 SET VBNAME=$$GET1^DIQ(2,DFN,.01)
+32 ;Add DFN and Name
+33 DO ADD^VBECRPC("<PatientName>"_$$CHARCHK^XOBVLIB(VBNAME)_"</PatientName>")
+34 DO ADD^VBECRPC("<VistaPatientId>"_$$CHARCHK^XOBVLIB(DFN)_"</VistaPatientId>")
+35 ;Add Accession number
+36 SET VBACCN=$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,.2)),"^")
+37 DO ADD^VBECRPC("<SpecimenAccessionNumber>"_$$CHARCHK^XOBVLIB(VBACCN)_"</SpecimenAccessionNumber>")
+38 SET VBORDN=+$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,.1)),"^")
+39 ;Add Order Number
+40 DO ADD^VBECRPC("<LabOrderNumber>"_$$CHARCHK^XOBVLIB(VBORDN)_"</LabOrderNumber>")
+41 ;Add UID from file 68
+42 SET VBUID68=$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,.3)),"^")
+43 DO ADD^VBECRPC("<SpecimenUID>"_$$CHARCHK^XOBVLIB(VBUID68)_"</SpecimenUID>")
+44 ;Add collection date/time
+45 DO ADD^VBECRPC("<CollectionDateTime>"_$$CHARCHK^XOBVLIB($$FMTHL7^XLFDT(VBCOLDT))_"</CollectionDateTime>")
+46 ;Add Tests
+47 DO BEGROOT^VBECRPC("LabTests")
+48 SET VBC=0
FOR
SET VBC=$ORDER(^LRO(68,VBACC,1,VBA,1,VBB,4,VBC))
if 'VBC
QUIT
Begin DoDot:1
+49 SET VBTEST=+$PIECE($GET(^LRO(68,VBACC,1,VBA,1,VBB,4,VBC,0)),"^")
+50 SET VBTNM=$$GET1^DIQ(60,VBTEST,.01)
+51 ;Add Test Name
+52 DO BEGROOT^VBECRPC("LabTest")
+53 DO ADD^VBECRPC("<LabTestID>"_$$CHARCHK^XOBVLIB(VBTEST)_"</LabTestID>")
+54 DO ADD^VBECRPC("<LabTestName>"_$$CHARCHK^XOBVLIB(VBTNM)_"</LabTestName>")
+55 DO ENDROOT^VBECRPC("LabTest")
End DoDot:1
+56 ;Close Tests
+57 DO ENDROOT^VBECRPC("LabTests")
+58 DO ENDROOT^VBECRPC("UIDLookup")
+59 KILL DFN,LRDFN,TEST,VBA,VBACC,VBB,VBC,VBECCNT,VBNAME,VBORDN,VBTEST,VBTNM,VBUID,VBUID68,VBACCN
+60 QUIT
+61 ;
+62 ; -----------------------------------------------------------------------
+63 ; Private Method supports IA #4614
+64 ; -----------------------------------------------------------------------
ORDNUM(RESULTS,LROIEN) ;
+1 ;
+2 NEW TEST,QUIT,VBA,VBB
+3 SET (VBECCNT,QUIT)=0
+4 SET RESULTS=$NAME(^TMP("VBECS_ORDLOOKUP",$JOB))
+5 KILL @RESULTS
+6 DO BEGROOT^VBECRPC("UIDLookup")
+7 IF LROIEN']""
Begin DoDot:1
+8 DO ERROR^VBECRPC("No Lab Order Number provided")
+9 DO ENDROOT^VBECRPC("UIDLookup")
End DoDot:1
QUIT
+10 ;
+11 IF '$DATA(^LRO(69,"C",LROIEN))
Begin DoDot:1
+12 DO ERROR^VBECRPC("Lab Order Number "_LROIEN_" not found in file 69")
+13 DO ENDROOT^VBECRPC("UIDLookup")
End DoDot:1
QUIT
+14 SET VBA=0
FOR
SET VBA=$ORDER(^LRO(69,"C",LROIEN,VBA))
if 'VBA
QUIT
Begin DoDot:1
+15 SET VBB=0
FOR
SET VBB=$ORDER(^LRO(69,"C",LROIEN,VBA,VBB))
if 'VBB
QUIT
Begin DoDot:2
+16 ;Collection status
