Routine: VBECA6

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECA6   2945     printed  Mar 13, 2025@21:48:48                                                                                                                                                                                                      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

VBECA6.m