VBECA3 ;HINES IFO/DDA-API interfaces for CPRS ;9/20/00 12:44
;;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 DBIA 4619 - VBECS Order Entry
; Reference to GETS^DIQ() supported by IA #2056
; Reference to $$LRDFN^LR7OR1 supported by IA #2503
; Reference to EN^LR7OSBR supported by IA #3190-A
; Reference to EN1^LR7OSBR supported by IA #3190-B
; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
;
QUIT
;
EN(LRDFN) ; Call to encapsulate the extract of Blood Bank data for CPRS
; via the call EN^LR7OSBR. This call can be tested by invoking the
; routine BLR^ORWRP1(root,dfn), where root is the null string and
; DFN is the PATIENT FILE numeric internal entry number for the
; patient.
; Parameter LRDFN is the LAB numeric internal entry number for the
; LAB patient.
N X
S X="LR7OSBR" X ^%ZOSF("TEST") I '$T W !,"LR7OSBR does not exist in this environment." Q
D EN^LR7OSBR
Q
;
EN1(DFN) ; Call to encapsulate the extract of Blood Bank data for CPRS
; via the call EN1^LR7OSBR.
; Parameter DFN is the PATIENT FILE numeric internal entry number for
; the LAB patient.
N X
S X="LR7OSBR" X ^%ZOSF("TEST") I '$T W !,"LR7OSBR does not exist in this environment." Q
D EN1^LR7OSBR(DFN)
Q
;
; ------------------------------------------------------
; Private method supports IA #4766
; ------------------------------------------------------
OEAPI(ARR,DFN,DIV) ; CPRS query to return patient and component related
; data from VBECS through VistALink
IF DFN']"" SET ARR("ERROR")="1^No Patient ID Provided" QUIT
IF '$D(^DPT(DFN,0)) SET ARR("ERROR")="1^Undefined VistA Patient ID" QUIT
IF DIV']"" SET ARR("ERROR")="1^No Patient Division Provided" QUIT
;
NEW VBECY,VBECSTAT
SET ARR("ERROR")=0
DO INITV^VBECRPCC("VBECS Order Entry")
IF +VBECPRMS("ERROR") S ARR("ERROR")=VBECPRMS("ERROR") Q
SET VBECPRMS("PARAMS",1,"TYPE")="STRING"
SET VBECPRMS("PARAMS",1,"VALUE")=$$CHARCHK^XOBVLIB(DFN)
SET VBECPRMS("PARAMS",2,"TYPE")="STRING"
SET VBECPRMS("PARAMS",2,"VALUE")=$$CHARCHK^XOBVLIB(DIV)
;
SET VBECSTAT=$$EXECUTE^VBECRPCC(.VBECPRMS)
;
SET VBECY=$NA(^TMP("VBECS_XML_RES",$J))
KILL @VBECY
DO PARSE^VBECRPC1(.VBECPRMS,VBECY)
IF $D(@VBECY@("ERROR")) SET ARR("ERROR")="1^"_@VBECY@("ERROR") DO CLEANUP QUIT
DO EN^VBECA3C(.ARR,VBECY)
; Setting for debugging GUI
KILL ^XTMP("OEAPI")
M ^XTMP("OEAPI",$J,$P(^DPT(DFN,0),U),DIV)=ARR
M ^XTMP("OEAPI",$J,DFN,DIV)=^TMP("VBECS_XML_RES",$J)
;Q KILL @VBECY
;
;DO CLEANUP
QUIT
BBDATA(DFN) ;Retrieve data for CPRS reports
;File 63's somewhat unique storage method limits the usefulness
;of some of the Kernel database calls. It was necessary to determine
;the first subscript level in the BB node and call the Kernel
;API with this level predefined.
;All references (field name and values) are converted to the external
;format.
;Null values are not returned.
;Inverse date values are converted to normal format.
K ^TMP("VBHOLD",$J),^TMP("VBDATA",$J)
S LRDFN=$$LRDFN^LR7OR1(DFN)
F VBAA=0 F S VBAA=$O(^LR(LRDFN,"BB",VBAA)) Q:'VBAA S VBAAA=VBAA_","_LRDFN_"," D
. D GETS^DIQ(63.01,VBAAA,"**","ERN","^TMP(""VBHOLD"","_$J,"ERROR")
S VBAA=0 F S VBAA=$O(^TMP("VBHOLD",$J,VBAA)) Q:VBAA="" D
. S VBAB=0 F S VBAB=$O(^TMP("VBHOLD",$J,VBAA,VBAB)) Q:VBAB="" D
. . S VBAC=0 F S VBAC=$O(^TMP("VBHOLD",$J,VBAA,VBAB,VBAC)) Q:VBAC="" D
. . . I $L(VBAB,",")=3 S VBAD=$P(VBAB,",") I VBAD?7N1".".N S VBAD=9999999-VBAD
. . . I $L(VBAB,",")=4 S VBAD=$P(VBAB,",",2) I VBAD?7N1".".N S VBAD=9999999-VBAD
. . . S ^TMP("VBDATA",$J,VBAD,VBAC)=^TMP("VBHOLD",$J,VBAA,VBAB,VBAC,"E")
D GETS^DIQ(63,LRDFN,".084*","ERN","VBCMPRQ","ERROR")
S VBAA="" F S VBAA=$O(VBCMPRQ(63.084,VBAA)) Q:VBAA="" D
. S VBAB="" F S VBAB=$O(VBCMPRQ(63.084,VBAA,VBAB)) Q:VBAB="" D
. . S VBAC=$P(VBAA,",")
. . S ^TMP("VBDATA",$J,"COMPONENT REQUEST",VBAC,VBAB)=VBCMPRQ(63.084,VBAA,VBAB,"E")
K ^TMP("VBHOLD",$J),VBAA,VBAB,VBAC,VBAD,VBAAA,VBCMPRQ
Q
CLEANUP ;
KILL VBECPRMS,VBECSTAT
KILL ^TMP("VBECS_XML_RES",$J)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECA3 4334 printed Sep 23, 2025@20:19:51 Page 2
VBECA3 ;HINES IFO/DDA-API interfaces for CPRS ;9/20/00 12:44
+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 DBIA 4619 - VBECS Order Entry
+9 ; Reference to GETS^DIQ() supported by IA #2056
+10 ; Reference to $$LRDFN^LR7OR1 supported by IA #2503
+11 ; Reference to EN^LR7OSBR supported by IA #3190-A
+12 ; Reference to EN1^LR7OSBR supported by IA #3190-B
+13 ; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
+14 ;
+15 QUIT
+16 ;
EN(LRDFN) ; Call to encapsulate the extract of Blood Bank data for CPRS
+1 ; via the call EN^LR7OSBR. This call can be tested by invoking the
+2 ; routine BLR^ORWRP1(root,dfn), where root is the null string and
+3 ; DFN is the PATIENT FILE numeric internal entry number for the
+4 ; patient.
+5 ; Parameter LRDFN is the LAB numeric internal entry number for the
+6 ; LAB patient.
+7 NEW X
+8 SET X="LR7OSBR"
XECUTE ^%ZOSF("TEST")
IF '$TEST
WRITE !,"LR7OSBR does not exist in this environment."
QUIT
+9 DO EN^LR7OSBR
+10 QUIT
+11 ;
EN1(DFN) ; Call to encapsulate the extract of Blood Bank data for CPRS
+1 ; via the call EN1^LR7OSBR.
+2 ; Parameter DFN is the PATIENT FILE numeric internal entry number for
+3 ; the LAB patient.
+4 NEW X
+5 SET X="LR7OSBR"
XECUTE ^%ZOSF("TEST")
IF '$TEST
WRITE !,"LR7OSBR does not exist in this environment."
QUIT
+6 DO EN1^LR7OSBR(DFN)
+7 QUIT
+8 ;
+9 ; ------------------------------------------------------
+10 ; Private method supports IA #4766
+11 ; ------------------------------------------------------
OEAPI(ARR,DFN,DIV) ; CPRS query to return patient and component related
+1 ; data from VBECS through VistALink
+2 IF DFN']""
SET ARR("ERROR")="1^No Patient ID Provided"
QUIT
+3 IF '$DATA(^DPT(DFN,0))
SET ARR("ERROR")="1^Undefined VistA Patient ID"
QUIT
+4 IF DIV']""
SET ARR("ERROR")="1^No Patient Division Provided"
QUIT
+5 ;
+6 NEW VBECY,VBECSTAT
+7 SET ARR("ERROR")=0
+8 DO INITV^VBECRPCC("VBECS Order Entry")
+9 IF +VBECPRMS("ERROR")
SET ARR("ERROR")=VBECPRMS("ERROR")
QUIT
+10 SET VBECPRMS("PARAMS",1,"TYPE")="STRING"
+11 SET VBECPRMS("PARAMS",1,"VALUE")=$$CHARCHK^XOBVLIB(DFN)
+12 SET VBECPRMS("PARAMS",2,"TYPE")="STRING"
+13 SET VBECPRMS("PARAMS",2,"VALUE")=$$CHARCHK^XOBVLIB(DIV)
+14 ;
+15 SET VBECSTAT=$$EXECUTE^VBECRPCC(.VBECPRMS)
+16 ;
+17 SET VBECY=$NAME(^TMP("VBECS_XML_RES",$JOB))
+18 KILL @VBECY
+19 DO PARSE^VBECRPC1(.VBECPRMS,VBECY)
+20 IF $DATA(@VBECY@("ERROR"))
SET ARR("ERROR")="1^"_@VBECY@("ERROR")
DO CLEANUP
QUIT
+21 DO EN^VBECA3C(.ARR,VBECY)
+22 ; Setting for debugging GUI
+23 KILL ^XTMP("OEAPI")
+24 MERGE ^XTMP("OEAPI",$JOB,$PIECE(^DPT(DFN,0),U),DIV)=ARR
+25 MERGE ^XTMP("OEAPI",$JOB,DFN,DIV)=^TMP("VBECS_XML_RES",$JOB)
+26 ;Q KILL @VBECY
+27 ;
+28 ;DO CLEANUP
+29 QUIT
BBDATA(DFN) ;Retrieve data for CPRS reports
+1 ;File 63's somewhat unique storage method limits the usefulness
+2 ;of some of the Kernel database calls. It was necessary to determine
+3 ;the first subscript level in the BB node and call the Kernel
+4 ;API with this level predefined.
+5 ;All references (field name and values) are converted to the external
+6 ;format.
+7 ;Null values are not returned.
+8 ;Inverse date values are converted to normal format.
+9 KILL ^TMP("VBHOLD",$JOB),^TMP("VBDATA",$JOB)
+10 SET LRDFN=$$LRDFN^LR7OR1(DFN)
+11 FOR VBAA=0
FOR
SET VBAA=$ORDER(^LR(LRDFN,"BB",VBAA))
if 'VBAA
QUIT
SET VBAAA=VBAA_","_LRDFN_","
Begin DoDot:1
+12 DO GETS^DIQ(63.01,VBAAA,"**","ERN","^TMP(""VBHOLD"","_$JOB,"ERROR")
End DoDot:1
+13 SET VBAA=0
FOR
SET VBAA=$ORDER(^TMP("VBHOLD",$JOB,VBAA))
if VBAA=""
QUIT
Begin DoDot:1
+14 SET VBAB=0
FOR
SET VBAB=$ORDER(^TMP("VBHOLD",$JOB,VBAA,VBAB))
if VBAB=""
QUIT
Begin DoDot:2
+15 SET VBAC=0
FOR
SET VBAC=$ORDER(^TMP("VBHOLD",$JOB,VBAA,VBAB,VBAC))
if VBAC=""
QUIT
Begin DoDot:3
+16 IF $LENGTH(VBAB,",")=3
SET VBAD=$PIECE(VBAB,",")
IF VBAD?7N1".".N
SET VBAD=9999999-VBAD
+17 IF $LENGTH(VBAB,",")=4
SET VBAD=$PIECE(VBAB,",",2)
IF VBAD?7N1".".N
SET VBAD=9999999-VBAD
+18 SET ^TMP("VBDATA",$JOB,VBAD,VBAC)=^TMP("VBHOLD",$JOB,VBAA,VBAB,VBAC,"E")
End DoDot:3
End DoDot:2
End DoDot:1
+19 DO GETS^DIQ(63,LRDFN,".084*","ERN","VBCMPRQ","ERROR")
+20 SET VBAA=""
FOR
SET VBAA=$ORDER(VBCMPRQ(63.084,VBAA))
if VBAA=""
QUIT
Begin DoDot:1
+21 SET VBAB=""
FOR
SET VBAB=$ORDER(VBCMPRQ(63.084,VBAA,VBAB))
if VBAB=""
QUIT
Begin DoDot:2
+22 SET VBAC=$PIECE(VBAA,",")
+23 SET ^TMP("VBDATA",$JOB,"COMPONENT REQUEST",VBAC,VBAB)=VBCMPRQ(63.084,VBAA,VBAB,"E")
End DoDot:2
End DoDot:1
+24 KILL ^TMP("VBHOLD",$JOB),VBAA,VBAB,VBAC,VBAD,VBAAA,VBCMPRQ
+25 QUIT
CLEANUP ;
+1 KILL VBECPRMS,VBECSTAT
+2 KILL ^TMP("VBECS_XML_RES",$JOB)
+3 QUIT
