Routine: VBECRPCB

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

 ; -----------------------------------------------------------------------

 ;     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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECRPCB   6381     printed  Jun 11, 2024@22:29:05                                                                                                                                                                                                    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

VBECRPCB.m