- 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 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