VBECRPCE ;HOIFO/BNT-Lookup PROVIDERS based on DIVISION ;22 March 2004
;;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 10076 - XUSEC GLOBAL READ
; Reference DBIA 10060 - NEW PERSON FILE
; Reference DBIA 10090 - INSTITUTION FILE
; Reference DBIA 2051 - LIST^DIC
; Reference to $$UP^XLFSTR is supported by IA: 10104
; Reference to $$FIND1^DIC supported by IA #2051
; Reference to $$FIND1^DIC supported by IA #2051
; Reference to ^DIC(4 supported by IA #10090
;
; This routine should not be called from the top.
QUIT
;
; ----------------------------------------------------------------
; Private Method supports IA 4617
; ----------------------------------------------------------------
PROVIDER(RESULTS,DIV,DATA) ;
; Look up and return all active providers by division
;
; Input: RESULTS = Passed by reference used to return data to VistALink
; as XML.
; DIV = (Required) Station number of Division used to
; locate providers
; DATA = (Optional) Text string used to perform lookup. If
; null, will return all providers for division.
;
; Screen Logic: Only returns users from file 200 that hold the
; PROVIDER Security Key, do not have a TERMINATION
; DATE prior to the current date, and have access to
; the Division passed in the DIV parameter.
;
;
S VBECCNT=0
S RESULTS=$NA(^TMP("VBECS_PROVIDERS",$J))
K @RESULTS
D BEGROOT^VBECRPC("Providers")
;
; Get INSTITUTION file pointer for DIV parameter.
K ERR S DIVIEN=$$FIND1^DIC(4,,"QX",.DIV,"D",,"ERR")
I $D(ERR) D Q
. D ADD^VBECRPC("<Record count='0' >")
. D ERROR^VBECRPC(ERR("DIERR",1,"TEXT",1))
. D ENDROOT^VBECRPC("Record"),ENDROOT^VBECRPC("Providers")
. Q
; Perform the search
D PRVSRCH(DATA,DIVIEN)
;
D ENDROOT^VBECRPC("Providers")
D KILL
Q
;
PRVSRCH(DATA,DIVIEN) ;
; Get list of PROVIDER's based on DATA and DIVIEN input
;
;
N DD,ERR
I '$D(VBECCNT) S VBECCNT=0
S DD=200
I $D(DATA) S DATA=$$UP^XLFSTR(DATA)
S SCREEN="I $$PRVSCR^VBECRPCE(+Y)"
D LIST^DIC(DD,"","@;.01","P","","",.DATA,"B",.SCREEN,"","","ERR")
I $D(ERR) D Q
. D ADD^VBECRPC("<Record count='0' >")
. D ERROR^VBECRPC(ERR("DIERR",1,"TEXT",1))
. D ENDROOT^VBECRPC("Record")
. Q
;
D ADD^VBECRPC("<Record count='"_$$CHARCHK^XOBVLIB(+$P(^TMP("DILIST",$J,0),U))_"' >")
S X=0
F S X=$O(^TMP("DILIST",$J,X)) Q:X="" D
. D BEGROOT^VBECRPC("Provider")
. D ADD^VBECRPC("<ProviderIEN>"_$$CHARCHK^XOBVLIB(+$P(^TMP("DILIST",$J,X,0),U))_"</ProviderIEN>")
. D ADD^VBECRPC("<ProviderName>"_$$CHARCHK^XOBVLIB($P(^TMP("DILIST",$J,X,0),U,2))_"</ProviderName>")
. D ENDROOT^VBECRPC("Provider")
. Q
D ENDROOT^VBECRPC("Record")
Q
;
PRVSCR(IEN) ; Screens for valid providers
Q:(IEN']"")!(IEN<0)!('$D(^XUSEC("PROVIDER",IEN))) 0
Q:'$D(^VA(200,IEN,2,"B",DIVIEN)) 0
Q $$ACTIVE^XUSER(IEN)
;
KILL ; Kill variables
K VBECCNT,DIVIEN
K ^TMP("DILIST",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECRPCE 3292 printed Sep 23, 2025@20:20:41 Page 2
VBECRPCE ;HOIFO/BNT-Lookup PROVIDERS based on DIVISION ;22 March 2004
+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 10076 - XUSEC GLOBAL READ
+9 ; Reference DBIA 10060 - NEW PERSON FILE
+10 ; Reference DBIA 10090 - INSTITUTION FILE
+11 ; Reference DBIA 2051 - LIST^DIC
+12 ; Reference to $$UP^XLFSTR is supported by IA: 10104
+13 ; Reference to $$FIND1^DIC supported by IA #2051
+14 ; Reference to $$FIND1^DIC supported by IA #2051
+15 ; Reference to ^DIC(4 supported by IA #10090
+16 ;
+17 ; This routine should not be called from the top.
+18 QUIT
+19 ;
+20 ; ----------------------------------------------------------------
+21 ; Private Method supports IA 4617
+22 ; ----------------------------------------------------------------
PROVIDER(RESULTS,DIV,DATA) ;
+1 ; Look up and return all active providers by division
+2 ;
+3 ; Input: RESULTS = Passed by reference used to return data to VistALink
+4 ; as XML.
+5 ; DIV = (Required) Station number of Division used to
+6 ; locate providers
+7 ; DATA = (Optional) Text string used to perform lookup. If
+8 ; null, will return all providers for division.
+9 ;
+10 ; Screen Logic: Only returns users from file 200 that hold the
+11 ; PROVIDER Security Key, do not have a TERMINATION
+12 ; DATE prior to the current date, and have access to
+13 ; the Division passed in the DIV parameter.
+14 ;
+15 ;
+16 SET VBECCNT=0
+17 SET RESULTS=$NAME(^TMP("VBECS_PROVIDERS",$JOB))
+18 KILL @RESULTS
+19 DO BEGROOT^VBECRPC("Providers")
+20 ;
+21 ; Get INSTITUTION file pointer for DIV parameter.
+22 KILL ERR
SET DIVIEN=$$FIND1^DIC(4,,"QX",.DIV,"D",,"ERR")
+23 IF $DATA(ERR)
Begin DoDot:1
+24 DO ADD^VBECRPC("<Record count='0' >")
+25 DO ERROR^VBECRPC(ERR("DIERR",1,"TEXT",1))
+26 DO ENDROOT^VBECRPC("Record")
DO ENDROOT^VBECRPC("Providers")
+27 QUIT
End DoDot:1
QUIT
+28 ; Perform the search
+29 DO PRVSRCH(DATA,DIVIEN)
+30 ;
+31 DO ENDROOT^VBECRPC("Providers")
+32 DO KILL
+33 QUIT
+34 ;
PRVSRCH(DATA,DIVIEN) ;
+1 ; Get list of PROVIDER's based on DATA and DIVIEN input
+2 ;
+3 ;
+4 NEW DD,ERR
+5 IF '$DATA(VBECCNT)
SET VBECCNT=0
+6 SET DD=200
+7 IF $DATA(DATA)
SET DATA=$$UP^XLFSTR(DATA)
+8 SET SCREEN="I $$PRVSCR^VBECRPCE(+Y)"
+9 DO LIST^DIC(DD,"","@;.01","P","","",.DATA,"B",.SCREEN,"","","ERR")
+10 IF $DATA(ERR)
Begin DoDot:1
+11 DO ADD^VBECRPC("<Record count='0' >")
+12 DO ERROR^VBECRPC(ERR("DIERR",1,"TEXT",1))
+13 DO ENDROOT^VBECRPC("Record")
+14 QUIT
End DoDot:1
QUIT
+15 ;
+16 DO ADD^VBECRPC("<Record count='"_$$CHARCHK^XOBVLIB(+$PIECE(^TMP("DILIST",$JOB,0),U))_"' >")
+17 SET X=0
+18 FOR
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if X=""
QUIT
Begin DoDot:1
+19 DO BEGROOT^VBECRPC("Provider")
+20 DO ADD^VBECRPC("<ProviderIEN>"_$$CHARCHK^XOBVLIB(+$PIECE(^TMP("DILIST",$JOB,X,0),U))_"</ProviderIEN>")
+21 DO ADD^VBECRPC("<ProviderName>"_$$CHARCHK^XOBVLIB($PIECE(^TMP("DILIST",$JOB,X,0),U,2))_"</ProviderName>")
+22 DO ENDROOT^VBECRPC("Provider")
+23 QUIT
End DoDot:1
+24 DO ENDROOT^VBECRPC("Record")
+25 QUIT
+26 ;
PRVSCR(IEN) ; Screens for valid providers
+1 if (IEN']"")!(IEN<0)!('$DATA(^XUSEC("PROVIDER",IEN)))
QUIT 0
+2 if '$DATA(^VA(200,IEN,2,"B",DIVIEN))
QUIT 0
+3 QUIT $$ACTIVE^XUSER(IEN)
+4 ;
KILL ; Kill variables
+1 KILL VBECCNT,DIVIEN
+2 KILL ^TMP("DILIST",$JOB)
+3 QUIT
