- 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 Feb 19, 2025@00:10:15 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