VBECRPCM ;HOIFO/BNT - MAINTENANCE USE CASE RPCs ; JULY 19, 2017@14:43
;;2.0;VBEC;**1**;Jun 05, 2015;Build 13
;
; 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 2343 - $$ACTIVE^XUSER
; Reference DBIA 10060 - NEW PERSON FILE
; Reference DBIA 4090 - $$CHARCHK^XOBVLIB
; Reference DBIA 10076 - XUSEC GLOBAL READ
; Reference DBIA 10090 - INSTITUTION FILE FILEMAN READ
; Reference DBIA 2817 - MEDICAL CENTER DIVISION FILE "AD" X-REF
; Reference DBIA 1963 - ACCESSION FILE GLOBAL READ
; Reference to GETS^DIQ() supported by IA #2056
; Reference to LIST^DIC supported by DBIA #2051
; Call to ^VA(200 is supported by IA: 10060
; Call to GETS^DIQ is supported by IA: 2056
; Reference to ^DIC(4 supported by IA #10090
; Reference to ^DG(40.8 supported by IA #2817
; Reference to ^LRO(68 supported by IA #1963
;
;
QUIT
;
; ---------------------------------------------------------------
; Private Method supports IA 4608
; ---------------------------------------------------------------
BBUSER(RESULTS) ; Look up and return all BB users
;
;
; Input: RESULTS = Passed by reference used to return data to VistALink
; as XML.
;
; Screen Logic: Only returns users from file 200 that hold either the
; LRBLOODBANK or LRBLSUPER Security Key and do not have a
; TERMINATION DATE prior to the current date.
;
;S VBECCNT=0
;S RESULTS=$NA(^TMP("VBECS_USER",$J))
;K @RESULTS
;D BEGROOT^VBECRPC("BloodBankUsers")
;
;D USRSRCH
;
;D ENDROOT^VBECRPC("BloodBankUsers")
N VBIEN,VBXUSEC,CNT,VBXU,VBU
S RESULTS=$NA(^TMP("BBUSERS",$J)),VBECCNT=0
K @RESULTS
D BEGROOT^VBECRPC("BloodBankUsers")
D ADD^VBECRPC("<Record count='0' >")
F VBXUSEC="LRBLOODBANK","LRBLSUPER" S VBXU=0 F S VBXU=$O(^XUSEC(VBXUSEC,VBXU)) Q:VBXU="" D
. Q:'+$$ACTIVE^XUSER(VBXU)
. S VBU(VBXU)=""
. Q
S (CNT,VBIEN)=0
F S VBIEN=$O(VBU(VBIEN)) Q:VBIEN="" D
. S CNT=CNT+1
. D BEGROOT^VBECRPC("BloodBankUser")
. D ADD^VBECRPC("<UserName>"_$$CHARCHK^XOBVLIB($P(^VA(200,VBIEN,0),"^",1))_"</UserName>")
. D ADD^VBECRPC("<UserDUZ>"_$$CHARCHK^XOBVLIB(VBIEN)_"</UserDUZ>")
. D ADD^VBECRPC("<UserInitials>"_$$CHARCHK^XOBVLIB($P(^VA(200,VBIEN,0),"^",2))_"</UserInitials>")
. D BBUSRDIV(VBIEN)
. D ENDROOT^VBECRPC("BloodBankUser")
S @RESULTS@(2)="<Record count='"_CNT_"' >"
D ENDROOT^VBECRPC("Record")
D ENDROOT^VBECRPC("BloodBankUsers")
K VBECCNT
Q
;
USRSRCH ; Search for valid Blood Bank users
;
N DD,DIVSUB,VBUSRDUZ,VBUSRNME,VBUSRINI,IENS,BBUSRDIV,DIVERR
S DD=200,DIVSUB="200.02"
S SCREEN="I $$USRSCR^VBECRPCM(+Y)"
D LIST^DIC(DD,"","@;.01;1","P","","","","",.SCREEN,"","","ERR")
;
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("BloodBankUser")
. ; User Name
. S VBUSRNME=$P(^TMP("DILIST",$J,X,0),U,2)
. ; User DUZ
. S VBUSRDUZ=+$P(^TMP("DILIST",$J,X,0),U)
. ; User Initials
. S VBUSRINI=$P(^TMP("DILIST",$J,X,0),U,3)
. ;
. D ADD^VBECRPC("<UserName>"_$$CHARCHK^XOBVLIB(VBUSRNME)_"</UserName>")
. D ADD^VBECRPC("<UserDUZ>"_$$CHARCHK^XOBVLIB(VBUSRDUZ)_"</UserDUZ>")
. D ADD^VBECRPC("<UserInitials>"_$$CHARCHK^XOBVLIB(VBUSRINI)_"</UserInitials>")
. ;
. ; Get all Divisions for this user.
. D BBUSRDIV(VBUSRDUZ)
. ;
. D ENDROOT^VBECRPC("BloodBankUser")
. Q
D ENDROOT^VBECRPC("Record")
Q
;
BBUSRDIV(VBDUZ) ; Gets the divisions for the user and creates the XML
;
N X,DIV,DIVIEN,OUT
; Must be active user
S X=$$DIV4^XUSER(.DIV,VBDUZ)
Q:'X
D BEGROOT^VBECRPC("Divisions")
S DIV=0
F S DIV=$O(DIV(DIV)) Q:DIV="" D
. D GETDIV(.OUT,DIV)
. I '+$P(OUT,U) S ERR=$P(OUT,U,2) D ERROR(ERR) Q
. Q:'$D(OUT)
. S DIVIEN=DIV_","
. ; Check if division is active
. I $G(OUT(4,DIVIEN,101))=1 Q
. ;
. ;D BEGROOT^VBECRPC("Division")
. ;D ADD^VBECRPC("<DivisionName>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,.01))_"</DivisionName>")
. D ADD^VBECRPC("<Division divisionCode="""_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,99))_""" />")
. ;D ENDROOT^VBECRPC("Division")
. Q
D ENDROOT^VBECRPC("Divisions")
Q
;
USRSCR(IEN) ; Screens for valid Blood Bank Users
Q:(IEN']"")!(IEN<0) 0
Q:('$D(^XUSEC("LRBLOODBANK",IEN)))&('$D(^XUSEC("LRBLSUPER",IEN))) 0
Q +$$ACTIVE^XUSER(IEN)
;
; ---------------------------------------------------------------
; Private Method supports IA 4609
; ---------------------------------------------------------------
DIV(RESULTS) ; Lookup and return all Divisions associated with a medical center
;
N DD,OUT,ERR,DIV,DIVIEN
S VBECCNT=0
S RESULTS=$NA(^TMP("VBECS_DIVISIONS",$J))
K @RESULTS
D BEGROOT^VBECRPC("Divisions")
;
S DIV=0
F S DIV=$O(^DG(40.8,"AD",DIV)) Q:DIV="" D Q:$D(ERR)
. D GETDIV(.OUT,DIV)
. I '+$P(OUT,U) S ERR=$P(OUT,U,2) D ERROR(ERR) Q
. Q:'$D(OUT)
. S DIVIEN=DIV_","
. ; See DR - 1670 / VistA MR 006
. ; Removed check if division is a medical center
. ; Added screen for station numbers greater than 5
. ;I $L(OUT(4,DIVIEN,99))>5 Q ;RLM 050817
. I $G(OUT(4,DIVIEN,99))="" Q
. ; Check if division is active
. I $G(OUT(4,DIVIEN,101))="INACTIVE" Q
. D BEGROOT^VBECRPC("Division")
. D ADD^VBECRPC("<DivisionCode>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,99))_"</DivisionCode>")
. D ADD^VBECRPC("<DivisionName>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,.01))_"</DivisionName>")
. D ENDROOT^VBECRPC("Division")
D ENDROOT^VBECRPC("Divisions")
;
K VBECCNT
Q
;
GETDIV(OUT,INST) ;
; Returns data associated with a Division represented by the
; Institution pointer
;
; Input: OUT = Passed by reference used to return array
; INST = Pointer to Institution file
;
; Returns: Output from LIST^DIC in the OUT array containing data from
; fields .01, 99 and 101
;
N ERR
S OUT="1^"
I INST']"" S OUT="0^Pointer to Institutuion file not found"
I INST'["," S INST=INST_","
D GETS^DIQ(4,INST,".01;99;101",,"OUT","ERR")
I $D(ERR) S OUT="0^"_ERR("DIERR",1,"TEXT",1)
Q
;
; ---------------------------------------------------------------
; Private Method Supports IA 4607
; ---------------------------------------------------------------
ACNAREA(RESULTS) ; Gets the Blood Bank Accession Areas from the Accession file
; Supporst MUC_02 Configure Division
;
N X,VBECARY
S (VBECCNT,X)=0
S RESULTS=$NA(^TMP("VBECS_ACCESSION_AREAS",$J))
K @RESULTS
D BEGROOT^VBECRPC("AccessionAreas")
F S X=$O(^LRO(68,X)) Q:X'?1N.N D
. Q:$P(^LRO(68,X,0),"^",2)'="BB"
. S VBECARY(X)=$P(^LRO(68,X,0),"^")
. D BEGROOT^VBECRPC("AccessionArea")
. D ADD^VBECRPC("<AccessionAreaName>"_$$CHARCHK^XOBVLIB($P(^LRO(68,X,0),"^"))_"</AccessionAreaName>")
. D ADD^VBECRPC("<AccessionAreaId>"_$$CHARCHK^XOBVLIB(X)_"</AccessionAreaId>")
. D ENDROOT^VBECRPC("AccessionArea")
D ENDROOT^VBECRPC("AccessionAreas")
;
K VBECCNT
Q
;
ERROR(TEXT) ;
D ERROR^VBECRPC(TEXT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECRPCM 7210 printed Sep 23, 2025@20:20:43 Page 2
VBECRPCM ;HOIFO/BNT - MAINTENANCE USE CASE RPCs ; JULY 19, 2017@14:43
+1 ;;2.0;VBEC;**1**;Jun 05, 2015;Build 13
+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 2343 - $$ACTIVE^XUSER
+9 ; Reference DBIA 10060 - NEW PERSON FILE
+10 ; Reference DBIA 4090 - $$CHARCHK^XOBVLIB
+11 ; Reference DBIA 10076 - XUSEC GLOBAL READ
+12 ; Reference DBIA 10090 - INSTITUTION FILE FILEMAN READ
+13 ; Reference DBIA 2817 - MEDICAL CENTER DIVISION FILE "AD" X-REF
+14 ; Reference DBIA 1963 - ACCESSION FILE GLOBAL READ
+15 ; Reference to GETS^DIQ() supported by IA #2056
+16 ; Reference to LIST^DIC supported by DBIA #2051
+17 ; Call to ^VA(200 is supported by IA: 10060
+18 ; Call to GETS^DIQ is supported by IA: 2056
+19 ; Reference to ^DIC(4 supported by IA #10090
+20 ; Reference to ^DG(40.8 supported by IA #2817
+21 ; Reference to ^LRO(68 supported by IA #1963
+22 ;
+23 ;
+24 QUIT
+25 ;
+26 ; ---------------------------------------------------------------
+27 ; Private Method supports IA 4608
+28 ; ---------------------------------------------------------------
BBUSER(RESULTS) ; Look up and return all BB users
+1 ;
+2 ;
+3 ; Input: RESULTS = Passed by reference used to return data to VistALink
+4 ; as XML.
+5 ;
+6 ; Screen Logic: Only returns users from file 200 that hold either the
+7 ; LRBLOODBANK or LRBLSUPER Security Key and do not have a
+8 ; TERMINATION DATE prior to the current date.
+9 ;
+10 ;S VBECCNT=0
+11 ;S RESULTS=$NA(^TMP("VBECS_USER",$J))
+12 ;K @RESULTS
+13 ;D BEGROOT^VBECRPC("BloodBankUsers")
+14 ;
+15 ;D USRSRCH
+16 ;
+17 ;D ENDROOT^VBECRPC("BloodBankUsers")
+18 NEW VBIEN,VBXUSEC,CNT,VBXU,VBU
+19 SET RESULTS=$NAME(^TMP("BBUSERS",$JOB))
SET VBECCNT=0
+20 KILL @RESULTS
+21 DO BEGROOT^VBECRPC("BloodBankUsers")
+22 DO ADD^VBECRPC("<Record count='0' >")
+23 FOR VBXUSEC="LRBLOODBANK","LRBLSUPER"
SET VBXU=0
FOR
SET VBXU=$ORDER(^XUSEC(VBXUSEC,VBXU))
if VBXU=""
QUIT
Begin DoDot:1
+24 if '+$$ACTIVE^XUSER(VBXU)
QUIT
+25 SET VBU(VBXU)=""
+26 QUIT
End DoDot:1
+27 SET (CNT,VBIEN)=0
+28 FOR
SET VBIEN=$ORDER(VBU(VBIEN))
if VBIEN=""
QUIT
Begin DoDot:1
+29 SET CNT=CNT+1
+30 DO BEGROOT^VBECRPC("BloodBankUser")
+31 DO ADD^VBECRPC("<UserName>"_$$CHARCHK^XOBVLIB($PIECE(^VA(200,VBIEN,0),"^",1))_"</UserName>")
+32 DO ADD^VBECRPC("<UserDUZ>"_$$CHARCHK^XOBVLIB(VBIEN)_"</UserDUZ>")
+33 DO ADD^VBECRPC("<UserInitials>"_$$CHARCHK^XOBVLIB($PIECE(^VA(200,VBIEN,0),"^",2))_"</UserInitials>")
+34 DO BBUSRDIV(VBIEN)
+35 DO ENDROOT^VBECRPC("BloodBankUser")
End DoDot:1
+36 SET @RESULTS@(2)="<Record count='"_CNT_"' >"
+37 DO ENDROOT^VBECRPC("Record")
+38 DO ENDROOT^VBECRPC("BloodBankUsers")
+39 KILL VBECCNT
+40 QUIT
+41 ;
USRSRCH ; Search for valid Blood Bank users
+1 ;
+2 NEW DD,DIVSUB,VBUSRDUZ,VBUSRNME,VBUSRINI,IENS,BBUSRDIV,DIVERR
+3 SET DD=200
SET DIVSUB="200.02"
+4 SET SCREEN="I $$USRSCR^VBECRPCM(+Y)"
+5 DO LIST^DIC(DD,"","@;.01;1","P","","","","",.SCREEN,"","","ERR")
+6 ;
+7 DO ADD^VBECRPC("<Record count='"_$$CHARCHK^XOBVLIB(+$PIECE(^TMP("DILIST",$JOB,0),U))_"' >")
+8 SET X=0
+9 FOR
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if X=""
QUIT
Begin DoDot:1
+10 DO BEGROOT^VBECRPC("BloodBankUser")
+11 ; User Name
+12 SET VBUSRNME=$PIECE(^TMP("DILIST",$JOB,X,0),U,2)
+13 ; User DUZ
+14 SET VBUSRDUZ=+$PIECE(^TMP("DILIST",$JOB,X,0),U)
+15 ; User Initials
+16 SET VBUSRINI=$PIECE(^TMP("DILIST",$JOB,X,0),U,3)
+17 ;
+18 DO ADD^VBECRPC("<UserName>"_$$CHARCHK^XOBVLIB(VBUSRNME)_"</UserName>")
+19 DO ADD^VBECRPC("<UserDUZ>"_$$CHARCHK^XOBVLIB(VBUSRDUZ)_"</UserDUZ>")
+20 DO ADD^VBECRPC("<UserInitials>"_$$CHARCHK^XOBVLIB(VBUSRINI)_"</UserInitials>")
+21 ;
+22 ; Get all Divisions for this user.
+23 DO BBUSRDIV(VBUSRDUZ)
+24 ;
+25 DO ENDROOT^VBECRPC("BloodBankUser")
+26 QUIT
End DoDot:1
+27 DO ENDROOT^VBECRPC("Record")
+28 QUIT
+29 ;
BBUSRDIV(VBDUZ) ; Gets the divisions for the user and creates the XML
+1 ;
+2 NEW X,DIV,DIVIEN,OUT
+3 ; Must be active user
+4 SET X=$$DIV4^XUSER(.DIV,VBDUZ)
+5 if 'X
QUIT
+6 DO BEGROOT^VBECRPC("Divisions")
+7 SET DIV=0
+8 FOR
SET DIV=$ORDER(DIV(DIV))
if DIV=""
QUIT
Begin DoDot:1
+9 DO GETDIV(.OUT,DIV)
+10 IF '+$PIECE(OUT,U)
SET ERR=$PIECE(OUT,U,2)
DO ERROR(ERR)
QUIT
+11 if '$DATA(OUT)
QUIT
+12 SET DIVIEN=DIV_","
+13 ; Check if division is active
+14 IF $GET(OUT(4,DIVIEN,101))=1
QUIT
+15 ;
+16 ;D BEGROOT^VBECRPC("Division")
+17 ;D ADD^VBECRPC("<DivisionName>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,.01))_"</DivisionName>")
+18 DO ADD^VBECRPC("<Division divisionCode="""_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,99))_""" />")
+19 ;D ENDROOT^VBECRPC("Division")
+20 QUIT
End DoDot:1
+21 DO ENDROOT^VBECRPC("Divisions")
+22 QUIT
+23 ;
USRSCR(IEN) ; Screens for valid Blood Bank Users
+1 if (IEN']"")!(IEN<0)
QUIT 0
+2 if ('$DATA(^XUSEC("LRBLOODBANK",IEN)))&('$DATA(^XUSEC("LRBLSUPER",IEN)))
QUIT 0
+3 QUIT +$$ACTIVE^XUSER(IEN)
+4 ;
+5 ; ---------------------------------------------------------------
+6 ; Private Method supports IA 4609
+7 ; ---------------------------------------------------------------
DIV(RESULTS) ; Lookup and return all Divisions associated with a medical center
+1 ;
+2 NEW DD,OUT,ERR,DIV,DIVIEN
+3 SET VBECCNT=0
+4 SET RESULTS=$NAME(^TMP("VBECS_DIVISIONS",$JOB))
+5 KILL @RESULTS
+6 DO BEGROOT^VBECRPC("Divisions")
+7 ;
+8 SET DIV=0
+9 FOR
SET DIV=$ORDER(^DG(40.8,"AD",DIV))
if DIV=""
QUIT
Begin DoDot:1
+10 DO GETDIV(.OUT,DIV)
+11 IF '+$PIECE(OUT,U)
SET ERR=$PIECE(OUT,U,2)
DO ERROR(ERR)
QUIT
+12 if '$DATA(OUT)
QUIT
+13 SET DIVIEN=DIV_","
+14 ; See DR - 1670 / VistA MR 006
+15 ; Removed check if division is a medical center
+16 ; Added screen for station numbers greater than 5
+17 ;I $L(OUT(4,DIVIEN,99))>5 Q ;RLM 050817
+18 IF $GET(OUT(4,DIVIEN,99))=""
QUIT
+19 ; Check if division is active
+20 IF $GET(OUT(4,DIVIEN,101))="INACTIVE"
QUIT
+21 DO BEGROOT^VBECRPC("Division")
+22 DO ADD^VBECRPC("<DivisionCode>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,99))_"</DivisionCode>")
+23 DO ADD^VBECRPC("<DivisionName>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,.01))_"</DivisionName>")
+24 DO ENDROOT^VBECRPC("Division")
End DoDot:1
if $DATA(ERR)
QUIT
+25 DO ENDROOT^VBECRPC("Divisions")
+26 ;
+27 KILL VBECCNT
+28 QUIT
+29 ;
GETDIV(OUT,INST) ;
+1 ; Returns data associated with a Division represented by the
+2 ; Institution pointer
+3 ;
+4 ; Input: OUT = Passed by reference used to return array
+5 ; INST = Pointer to Institution file
+6 ;
+7 ; Returns: Output from LIST^DIC in the OUT array containing data from
+8 ; fields .01, 99 and 101
+9 ;
+10 NEW ERR
+11 SET OUT="1^"
+12 IF INST']""
SET OUT="0^Pointer to Institutuion file not found"
+13 IF INST'[","
SET INST=INST_","
+14 DO GETS^DIQ(4,INST,".01;99;101",,"OUT","ERR")
+15 IF $DATA(ERR)
SET OUT="0^"_ERR("DIERR",1,"TEXT",1)
+16 QUIT
+17 ;
+18 ; ---------------------------------------------------------------
+19 ; Private Method Supports IA 4607
+20 ; ---------------------------------------------------------------
ACNAREA(RESULTS) ; Gets the Blood Bank Accession Areas from the Accession file
+1 ; Supporst MUC_02 Configure Division
+2 ;
+3 NEW X,VBECARY
+4 SET (VBECCNT,X)=0
+5 SET RESULTS=$NAME(^TMP("VBECS_ACCESSION_AREAS",$JOB))
+6 KILL @RESULTS
+7 DO BEGROOT^VBECRPC("AccessionAreas")
+8 FOR
SET X=$ORDER(^LRO(68,X))
if X'?1N.N
QUIT
Begin DoDot:1
+9 if $PIECE(^LRO(68,X,0),"^",2)'="BB"
QUIT
+10 SET VBECARY(X)=$PIECE(^LRO(68,X,0),"^")
+11 DO BEGROOT^VBECRPC("AccessionArea")
+12 DO ADD^VBECRPC("<AccessionAreaName>"_$$CHARCHK^XOBVLIB($PIECE(^LRO(68,X,0),"^"))_"</AccessionAreaName>")
+13 DO ADD^VBECRPC("<AccessionAreaId>"_$$CHARCHK^XOBVLIB(X)_"</AccessionAreaId>")
+14 DO ENDROOT^VBECRPC("AccessionArea")
End DoDot:1
+15 DO ENDROOT^VBECRPC("AccessionAreas")
+16 ;
+17 KILL VBECCNT
+18 QUIT
+19 ;
ERROR(TEXT) ;
+1 DO ERROR^VBECRPC(TEXT)
+2 QUIT
