BQISYKEY ;VNGT/HS/ALA - Manage iCare Keys ; 12 Jun 2008 10:44 AM
;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
;
;
UPD(DATA,USER,RLIST) ; EP - BQI UPDATE USER ROLES
NEW UID,II,ROLE,RIEN,BKEY,BKIEN,OKEY,FLAG,BN,BQ,DINUM,PDATA,VALUE,X
NEW FINAL,FKY,MSG,RESULT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQISYKEY",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYKEY D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
S RLIST=$G(RLIST,"")
I RLIST="" D
. S LIST="",BN=""
. F S BN=$O(RLIST(BN)) Q:BN="" S LIST=LIST_RLIST(BN)
. K RLIST
. S RLIST=LIST
. K LIST
;
F BQ=1:1:$L(RLIST,$C(28)) D
. S PDATA=$P(RLIST,$C(28),BQ)
. S BKEY=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="Y" D ADD Q
. I VALUE="N" D REM
. Q
;
S FINAL=1,FKY="",MSG=""
F S FKY=$O(RESULT(FKY)) Q:FKY="" I $P(RESULT(FKY),U,1)=-1 S FINAL=-1,MSG=MSG_$P(RESULT(FKY),U,2)_"; "
I $G(MSG)'="" S MSG=$$TKO^BQIUL1(MSG,"; ")
S II=II+1,@DATA@(II)=FINAL_U_$G(MSG)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ADD ;EP - Add ROLE to user
NEW RIEN,ROLE,BKIEN,Y
S RIEN=$O(^BQI(90505.2,"C",BKEY,"")) I RIEN="" Q
S ROLE=$P(^BQI(90505.2,RIEN,0),U,1)
S BKIEN=$O(^DIC(19.1,"B",BKEY,""))
I $D(^XUSEC(BKEY,USER)) Q
I BKIEN="" Q
NEW DIC
S DIC(0)="NMQ",DIC("P")="200.051PA"
S DIC="^VA(200,"_USER_",51,",DA(1)=USER,X=BKIEN,DINUM=X
K DO,DD D FILE^DICN
I Y<0 S RESULT(BKEY)="-1^Unable to add role "_ROLE Q
S RESULT(BKEY)=1
Q
;
REM ;EP - Remove ROLE from user
NEW RIEN
S RIEN=$O(^BQI(90505.2,"C",BKEY,"")) I RIEN="" Q
S ROLE=$P(^BQI(90505.2,RIEN,0),U,1)
S BKIEN=$O(^DIC(19.1,"B",BKEY,""))
I '$D(^XUSEC(BKEY,USER)) Q
NEW DIK,DA
S DIK="^VA(200,"_USER_",51,",DA(1)=USER,DA=BKIEN
D ^DIK
S RESULT(BKEY)=1
Q
;
RET(DATA,USER,ROLE) ; EP - BQI GET USER ROLES
;
;Parameters:
;USER (optional) = DUZ of specific user to report on
;ROLE (optional) = Specific role that user(s) must have to return information
;
NEW UID,II,BKEY,BKIEN,OKEY,HDR,RIEN,BQROLE,NPOS
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQISYKG",UID))
K @DATA
S ROLE=$G(ROLE,""),USER=$G(USER,"")
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYKEY D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="T00050BQIUSER^T00001EDIT_CANDIDATE^T00001TAX_CANDIDATE^T00001BQIZCUSR^"
S HDR=HDR_"T00001BQIRPC^T00001BQIZCMED^T00001BQIZTXED^T00001BQIZMGR^T00001BTPWZCMGR^"
S HDR=HDR_"T00001BQIZBHUSR^T00001BQIZMUMGR^T00001BQIZEMPHLTH^T00001BQIZIPCMGR^"
S HDR=HDR_"T00001BQIZDSPM^T00001BQIZBHCA"
S @DATA@(II)=HDR_$C(30)
;
K BQROLE
;
;Define all roles, put a 1 for any to look for
S RIEN=0
F S RIEN=$O(^BQI(90505.2,RIEN)) Q:'RIEN D
. S BKEY=$P(^BQI(90505.2,RIEN,0),U,2)
. S BQROLE(BKEY)=$P(^BQI(90505.2,RIEN,0),U,3)_U_RIEN_U_$S(ROLE="":1,1:"")
;
;If a role was passed in, set it up with a 1
I ROLE'="" D
. S RIEN=$O(^BQI(90505.2,"B",ROLE,"")) Q:RIEN=""
. S BKEY=$P(^BQI(90505.2,RIEN,0),U,2) Q:BKEY=""
. S BQROLE(BKEY)=$P(^BQI(90505.2,RIEN,0),U,3)_U_RIEN_U_"1"
;
D ROL(USER,.BQROLE)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
ROL(BUSER,BQROLE) ;EP - Assemble User Information Based on input User/Role
;
NEW BQUSER,BUSR,POS
;
;Handle single user request
I BUSER'="" D Q:'$D(BQUSER(BUSER))
. N ASKY,BKEY,POS,RLIEN,RLCK,RLCNT,ROL,VAL
. ;
. ;Reset role flag and count
. S ROL="",RLCNT=0
. ;
. ;Skip corrupted entries
. I $G(^VA(200,BUSER,0))="" Q
. ;
. ;Set initial entry
. S BQUSER(BUSER)=""
. ;
. ;Loop through keys for user
. S BKEY="" F S BKEY=$O(BQROLE(BKEY)) Q:BKEY="" D
.. S VAL=$G(BQROLE(BKEY))
.. S POS=$P(VAL,U),RLIEN=$P(VAL,U,2),RLCK=$P(VAL,U,3)
.. I RLCK=1 S RLCNT=RLCNT+1 ;Keep track of # of roles to check
.. ;
.. I $D(^XUSEC(BKEY,BUSER)) D
... S $P(BQUSER(BUSER),U,POS)="Y" ;User has key
... S:RLCK=1 ROL=1 ;Set flag if role to check
.. ;
.. ;Check whether a candidate
.. S ASKY="" F S ASKY=$O(^BQI(90505.2,RLIEN,10,"B",ASKY)) Q:ASKY="" D
... Q:'$D(^XUSEC(ASKY,BUSER))
... I BKEY="BQIZCMED" S $P(BQUSER(BUSER),U,2)="Y"
... I BKEY="BQIZTXED" S $P(BQUSER(BUSER),U,3)="Y"
... I BKEY="BQIZBHUSR" S $P(BQUSER(BUSER),U,POS)="Y"
... I BKEY="BQIZDSPM" S $P(BQUSER(BUSER),U,POS)="Y"
. ;
. ;If checking for a specific role and not found clear out entry
. ;(Role count for specific role check will be 1, otherwise >1)
. I ROL="",RLCNT=1 K BQUSER(BUSER) Q
. ;
. ;Check if iCare User
. S:$G(^BQICARE(BUSER,0))'="" $P(BQUSER(BUSER),U,4)="Y"
. ;
. ;Check for BQIRPC Secondary Menu
. D BQIRPC(BUSER,.BQROLE,.BQUSER)
;
;Handle blank (multiple) user request
I BUSER="" D Q:'$D(BQUSER)
. N ASKY,BKEY,BUSR,POS,RLCK,RLCNT,RLIEN,ROL,VAL
. ;
. ;Reset role count
. S RLCNT=0
. ;
. ;Loop through keys
. S BKEY="" F S BKEY=$O(BQROLE(BKEY)) Q:BKEY="" D
.. S VAL=$G(BQROLE(BKEY))
.. S POS=$P(VAL,U),RLIEN=$P(VAL,U,2),RLCK=$P(VAL,U,3)
.. I RLCK=1 S RLCNT=RLCNT+1 ;Keep track of # of roles to check
.. ;
.. ;Loop through users holding that key
.. S BUSR="" F S BUSR=$O(^XUSEC(BKEY,BUSR)) Q:BUSR="" D
... I $G(^VA(200,BUSR,0))="" Q
... S $P(BQUSER(BUSR),U,POS)="Y"
... I RLCK=1 S ROL(BUSR)="" ;Set flag if looking for this role
.. ;
.. ;Check whether candidate
.. S ASKY="" F S ASKY=$O(^BQI(90505.2,RLIEN,10,"B",ASKY)) Q:ASKY="" D
... S BUSR="" F S BUSR=$O(^XUSEC(ASKY,BUSR)) Q:BUSR="" D
.... I $G(^VA(200,BUSR,0))="" Q
.... I $P($G(^VA(200,BUSR,0)),U,11)'="" Q
.... I BKEY="BQIZCMED" S $P(BQUSER(BUSR),U,2)="Y"
.... I BKEY="BQIZTXED" S $P(BQUSER(BUSR),U,3)="Y"
.... I BKEY="BQIZBHUSR" S $P(BQUSER(BUSR),U,POS)="Y"
.... I BKEY="BQIZDSPM" S $P(BQUSER(BUSR),U,POS)="Y"
. ;
. ;Check if iCare User
. S BUSR=0 F S BUSR=$O(^BQICARE(BUSR)) Q:'BUSR D
.. I $G(^VA(200,BUSR,0))="" Q
.. S $P(BQUSER(BUSR),U,4)="Y"
. ;
. ;Check for BQIRPC Secondary Menu
. D BQIRPC(BUSER,.BQROLE,.BQUSER)
. ;
. ;If checking for a specific role and not found clear out entries
. ;Role count for specific role check will be 1, otherwise >1
. I RLCNT=1 D
.. S BUSR="" F S BUSR=$O(BQUSER(BUSR)) Q:BUSR="" D
... I '$D(ROL(BUSR)) K BQUSER(BUSR)
;
;Assemble records
S NPOS=$O(^BQI(90505.2,"AC",""),-1),NPOS=NPOS+1
S BUSR="" F S BUSR=$O(BQUSER(BUSR)) Q:BUSR="" D
. S $P(BQUSER(BUSR),U,1)=BUSR_$C(28)_$P(^VA(200,BUSR,0),U,1)
. F POS=2:1:NPOS I $P(BQUSER(BUSR),U,POS)="" S $P(BQUSER(BUSR),U,POS)="N"
. S POS=6 I $P(BQUSER(BUSR),U,POS)="Y" S $P(BQUSER(BUSR),U,2)="Y" ; taxonomy edit candidate
. S POS=7 I $P(BQUSER(BUSR),U,POS)="Y" S $P(BQUSER(BUSR),U,3)="Y" ; edit candidate
. I $P(BQUSER(BUSR),U,5)'="Y" K BQUSER(BUSR) Q
. S II=II+1,@DATA@(II)=BQUSER(BUSR)_$C(30)
Q
;
BQIRPC(BUSER,BQROLE,BQUSER) ;EP - Locate users with BQIRPC Sec. Menu Assigned
;
;Parameters:
; BUSER = DUZ of passed in user or Null
; BQROLE = ROLE Array - if only one entry it was passed in by RPC
; BQUSER = Array which gets updated (and possibly added to)
;
NEW BQIEN,DIC,RL,RLCNT,X,Y
;
;Get BQIRPC secondary menu IEN
S DIC=19,DIC(0)="X",X="BQIRPC" D ^DIC Q:Y<0
S BQIEN=+Y
;
;No user or role was passed, new entries are allowed
S RL="",RLCNT=0 F S RL=$O(BQROLE(RL)) Q:RL="" I $P(BQROLE(RL),U,3)=1 S RLCNT=RLCNT+1
I $G(BUSER)="",$G(RLCNT)>1 D Q ;If a role was passed, there would only be 1
. ;
. ;Find all users with "BQIRPC" as a secondary menu
. S BUSER="" F S BUSER=$O(^VA(200,"AD",BQIEN,BUSER)) Q:'BUSER D
.. I $G(^VA(200,BUSER,0))=""!'$$ACTIVE^XUSER(BUSER) Q
.. S $P(BQUSER(BUSER),U,5)="Y"
. Q
;
;If either a user or role passed in, just update users already found
S BUSER="" F S BUSER=$O(BQUSER(BUSER)) Q:BUSER="" D
.I $O(^VA(200,BUSER,203,"B",BQIEN,""))]"" S $P(BQUSER(BUSER),U,5)="Y"
;
Q
BQISYKEY ;VNGT/HS/ALA - Manage iCare Keys ; 12 Jun 2008 10:44 AM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
+2 ;
+3 ;
UPD(DATA,USER,RLIST) ; EP - BQI UPDATE USER ROLES
+1 NEW UID,II,ROLE,RIEN,BKEY,BKIEN,OKEY,FLAG,BN,BQ,DINUM,PDATA,VALUE,X
+2 NEW FINAL,FKY,MSG,RESULT
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQISYKEY",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQISYKEY D UNWIND^%ZTER"
+9 ;
+10 SET @DATA@(II)="I00010RESULT^T01024MSG"_$CHAR(30)
+11 SET RLIST=$GET(RLIST,"")
+12 IF RLIST=""
Begin DoDot:1
+13 SET LIST=""
SET BN=""
+14 FOR
SET BN=$ORDER(RLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_RLIST(BN)
+15 KILL RLIST
+16 SET RLIST=LIST
+17 KILL LIST
End DoDot:1
+18 ;
+19 FOR BQ=1:1:$LENGTH(RLIST,$CHAR(28))
Begin DoDot:1
+20 SET PDATA=$PIECE(RLIST,$CHAR(28),BQ)
+21 SET BKEY=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+22 IF VALUE="Y"
DO ADD
QUIT
+23 IF VALUE="N"
DO REM
+24 QUIT
End DoDot:1
+25 ;
+26 SET FINAL=1
SET FKY=""
SET MSG=""
+27 FOR
SET FKY=$ORDER(RESULT(FKY))
IF FKY=""
QUIT
IF $PIECE(RESULT(FKY),U,1)=-1
SET FINAL=-1
SET MSG=MSG_$PIECE(RESULT(FKY),U,2)_"; "
+28 IF $GET(MSG)'=""
SET MSG=$$TKO^BQIUL1(MSG,"; ")
+29 SET II=II+1
SET @DATA@(II)=FINAL_U_$GET(MSG)_$CHAR(30)
+30 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+31 QUIT
+32 ;
ADD ;EP - Add ROLE to user
+1 NEW RIEN,ROLE,BKIEN,Y
+2 SET RIEN=$ORDER(^BQI(90505.2,"C",BKEY,""))
IF RIEN=""
QUIT
+3 SET ROLE=$PIECE(^BQI(90505.2,RIEN,0),U,1)
+4 SET BKIEN=$ORDER(^DIC(19.1,"B",BKEY,""))
+5 IF $DATA(^XUSEC(BKEY,USER))
QUIT
+6 IF BKIEN=""
QUIT
+7 NEW DIC
+8 SET DIC(0)="NMQ"
SET DIC("P")="200.051PA"
+9 SET DIC="^VA(200,"_USER_",51,"
SET DA(1)=USER
SET X=BKIEN
SET DINUM=X
+10 KILL DO,DD
DO FILE^DICN
+11 IF Y<0
SET RESULT(BKEY)="-1^Unable to add role "_ROLE
QUIT
+12 SET RESULT(BKEY)=1
+13 QUIT
+14 ;
REM ;EP - Remove ROLE from user
+1 NEW RIEN
+2 SET RIEN=$ORDER(^BQI(90505.2,"C",BKEY,""))
IF RIEN=""
QUIT
+3 SET ROLE=$PIECE(^BQI(90505.2,RIEN,0),U,1)
+4 SET BKIEN=$ORDER(^DIC(19.1,"B",BKEY,""))
+5 IF '$DATA(^XUSEC(BKEY,USER))
QUIT
+6 NEW DIK,DA
+7 SET DIK="^VA(200,"_USER_",51,"
SET DA(1)=USER
SET DA=BKIEN
+8 DO ^DIK
+9 SET RESULT(BKEY)=1
+10 QUIT
+11 ;
RET(DATA,USER,ROLE) ; EP - BQI GET USER ROLES
+1 ;
+2 ;Parameters:
+3 ;USER (optional) = DUZ of specific user to report on
+4 ;ROLE (optional) = Specific role that user(s) must have to return information
+5 ;
+6 NEW UID,II,BKEY,BKIEN,OKEY,HDR,RIEN,BQROLE,NPOS
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BQISYKG",UID))
+9 KILL @DATA
+10 SET ROLE=$GET(ROLE,"")
SET USER=$GET(USER,"")
+11 ;
+12 SET II=0
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQISYKEY D UNWIND^%ZTER"
+14 ;
+15 SET HDR="T00050BQIUSER^T00001EDIT_CANDIDATE^T00001TAX_CANDIDATE^T00001BQIZCUSR^"
+16 SET HDR=HDR_"T00001BQIRPC^T00001BQIZCMED^T00001BQIZTXED^T00001BQIZMGR^T00001BTPWZCMGR^"
+17 SET HDR=HDR_"T00001BQIZBHUSR^T00001BQIZMUMGR^T00001BQIZEMPHLTH^T00001BQIZIPCMGR^"
+18 SET HDR=HDR_"T00001BQIZDSPM^T00001BQIZBHCA"
+19 SET @DATA@(II)=HDR_$CHAR(30)
+20 ;
+21 KILL BQROLE
+22 ;
+23 ;Define all roles, put a 1 for any to look for
+24 SET RIEN=0
+25 FOR
SET RIEN=$ORDER(^BQI(90505.2,RIEN))
IF 'RIEN
QUIT
Begin DoDot:1
+26 SET BKEY=$PIECE(^BQI(90505.2,RIEN,0),U,2)
+27 SET BQROLE(BKEY)=$PIECE(^BQI(90505.2,RIEN,0),U,3)_U_RIEN_U_$SELECT(ROLE="":1,1:"")
End DoDot:1
+28 ;
+29 ;If a role was passed in, set it up with a 1
+30 IF ROLE'=""
Begin DoDot:1
+31 SET RIEN=$ORDER(^BQI(90505.2,"B",ROLE,""))
IF RIEN=""
QUIT
+32 SET BKEY=$PIECE(^BQI(90505.2,RIEN,0),U,2)
IF BKEY=""
QUIT
+33 SET BQROLE(BKEY)=$PIECE(^BQI(90505.2,RIEN,0),U,3)_U_RIEN_U_"1"
End DoDot:1
+34 ;
+35 DO ROL(USER,.BQROLE)
+36 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
ROL(BUSER,BQROLE) ;EP - Assemble User Information Based on input User/Role
+1 ;
+2 NEW BQUSER,BUSR,POS
+3 ;
+4 ;Handle single user request
+5 IF BUSER'=""
Begin DoDot:1
+6 NEW ASKY,BKEY,POS,RLIEN,RLCK,RLCNT,ROL,VAL
+7 ;
+8 ;Reset role flag and count
+9 SET ROL=""
SET RLCNT=0
+10 ;
+11 ;Skip corrupted entries
+12 IF $GET(^VA(200,BUSER,0))=""
QUIT
+13 ;
+14 ;Set initial entry
+15 SET BQUSER(BUSER)=""
+16 ;
+17 ;Loop through keys for user
+18 SET BKEY=""
FOR
SET BKEY=$ORDER(BQROLE(BKEY))
IF BKEY=""
QUIT
Begin DoDot:2
+19 SET VAL=$GET(BQROLE(BKEY))
+20 SET POS=$PIECE(VAL,U)
SET RLIEN=$PIECE(VAL,U,2)
SET RLCK=$PIECE(VAL,U,3)
+21 ;Keep track of # of roles to check
IF RLCK=1
SET RLCNT=RLCNT+1
+22 ;
+23 IF $DATA(^XUSEC(BKEY,BUSER))
Begin DoDot:3
+24 ;User has key
SET $PIECE(BQUSER(BUSER),U,POS)="Y"
+25 ;Set flag if role to check
IF RLCK=1
SET ROL=1
End DoDot:3
+26 ;
+27 ;Check whether a candidate
+28 SET ASKY=""
FOR
SET ASKY=$ORDER(^BQI(90505.2,RLIEN,10,"B",ASKY))
IF ASKY=""
QUIT
Begin DoDot:3
+29 IF '$DATA(^XUSEC(ASKY,BUSER))
QUIT
+30 IF BKEY="BQIZCMED"
SET $PIECE(BQUSER(BUSER),U,2)="Y"
+31 IF BKEY="BQIZTXED"
SET $PIECE(BQUSER(BUSER),U,3)="Y"
+32 IF BKEY="BQIZBHUSR"
SET $PIECE(BQUSER(BUSER),U,POS)="Y"
+33 IF BKEY="BQIZDSPM"
SET $PIECE(BQUSER(BUSER),U,POS)="Y"
End DoDot:3
End DoDot:2
+34 ;
+35 ;If checking for a specific role and not found clear out entry
+36 ;(Role count for specific role check will be 1, otherwise >1)
+37 IF ROL=""
IF RLCNT=1
KILL BQUSER(BUSER)
QUIT
+38 ;
+39 ;Check if iCare User
+40 IF $GET(^BQICARE(BUSER,0))'=""
SET $PIECE(BQUSER(BUSER),U,4)="Y"
+41 ;
+42 ;Check for BQIRPC Secondary Menu
+43 DO BQIRPC(BUSER,.BQROLE,.BQUSER)
End DoDot:1
IF '$DATA(BQUSER(BUSER))
QUIT
+44 ;
+45 ;Handle blank (multiple) user request
+46 IF BUSER=""
Begin DoDot:1
+47 NEW ASKY,BKEY,BUSR,POS,RLCK,RLCNT,RLIEN,ROL,VAL
+48 ;
+49 ;Reset role count
+50 SET RLCNT=0
+51 ;
+52 ;Loop through keys
+53 SET BKEY=""
FOR
SET BKEY=$ORDER(BQROLE(BKEY))
IF BKEY=""
QUIT
Begin DoDot:2
+54 SET VAL=$GET(BQROLE(BKEY))
+55 SET POS=$PIECE(VAL,U)
SET RLIEN=$PIECE(VAL,U,2)
SET RLCK=$PIECE(VAL,U,3)
+56 ;Keep track of # of roles to check
IF RLCK=1
SET RLCNT=RLCNT+1
+57 ;
+58 ;Loop through users holding that key
+59 SET BUSR=""
FOR
SET BUSR=$ORDER(^XUSEC(BKEY,BUSR))
IF BUSR=""
QUIT
Begin DoDot:3
+60 IF $GET(^VA(200,BUSR,0))=""
QUIT
+61 SET $PIECE(BQUSER(BUSR),U,POS)="Y"
+62 ;Set flag if looking for this role
IF RLCK=1
SET ROL(BUSR)=""
End DoDot:3
+63 ;
+64 ;Check whether candidate
+65 SET ASKY=""
FOR
SET ASKY=$ORDER(^BQI(90505.2,RLIEN,10,"B",ASKY))
IF ASKY=""
QUIT
Begin DoDot:3
+66 SET BUSR=""
FOR
SET BUSR=$ORDER(^XUSEC(ASKY,BUSR))
IF BUSR=""
QUIT
Begin DoDot:4
+67 IF $GET(^VA(200,BUSR,0))=""
QUIT
+68 IF $PIECE($GET(^VA(200,BUSR,0)),U,11)'=""
QUIT
+69 IF BKEY="BQIZCMED"
SET $PIECE(BQUSER(BUSR),U,2)="Y"
+70 IF BKEY="BQIZTXED"
SET $PIECE(BQUSER(BUSR),U,3)="Y"
+71 IF BKEY="BQIZBHUSR"
SET $PIECE(BQUSER(BUSR),U,POS)="Y"
+72 IF BKEY="BQIZDSPM"
SET $PIECE(BQUSER(BUSR),U,POS)="Y"
End DoDot:4
End DoDot:3
End DoDot:2
+73 ;
+74 ;Check if iCare User
+75 SET BUSR=0
FOR
SET BUSR=$ORDER(^BQICARE(BUSR))
IF 'BUSR
QUIT
Begin DoDot:2
+76 IF $GET(^VA(200,BUSR,0))=""
QUIT
+77 SET $PIECE(BQUSER(BUSR),U,4)="Y"
End DoDot:2
+78 ;
+79 ;Check for BQIRPC Secondary Menu
+80 DO BQIRPC(BUSER,.BQROLE,.BQUSER)
+81 ;
+82 ;If checking for a specific role and not found clear out entries
+83 ;Role count for specific role check will be 1, otherwise >1
+84 IF RLCNT=1
Begin DoDot:2
+85 SET BUSR=""
FOR
SET BUSR=$ORDER(BQUSER(BUSR))
IF BUSR=""
QUIT
Begin DoDot:3
+86 IF '$DATA(ROL(BUSR))
KILL BQUSER(BUSR)
End DoDot:3
End DoDot:2
End DoDot:1
IF '$DATA(BQUSER)
QUIT
+87 ;
+88 ;Assemble records
+89 SET NPOS=$ORDER(^BQI(90505.2,"AC",""),-1)
SET NPOS=NPOS+1
+90 SET BUSR=""
FOR
SET BUSR=$ORDER(BQUSER(BUSR))
IF BUSR=""
QUIT
Begin DoDot:1
+91 SET $PIECE(BQUSER(BUSR),U,1)=BUSR_$CHAR(28)_$PIECE(^VA(200,BUSR,0),U,1)
+92 FOR POS=2:1:NPOS
IF $PIECE(BQUSER(BUSR),U,POS)=""
SET $PIECE(BQUSER(BUSR),U,POS)="N"
+93 ; taxonomy edit candidate
SET POS=6
IF $PIECE(BQUSER(BUSR),U,POS)="Y"
SET $PIECE(BQUSER(BUSR),U,2)="Y"
+94 ; edit candidate
SET POS=7
IF $PIECE(BQUSER(BUSR),U,POS)="Y"
SET $PIECE(BQUSER(BUSR),U,3)="Y"
+95 IF $PIECE(BQUSER(BUSR),U,5)'="Y"
KILL BQUSER(BUSR)
QUIT
+96 SET II=II+1
SET @DATA@(II)=BQUSER(BUSR)_$CHAR(30)
End DoDot:1
+97 QUIT
+98 ;
BQIRPC(BUSER,BQROLE,BQUSER) ;EP - Locate users with BQIRPC Sec. Menu Assigned
+1 ;
+2 ;Parameters:
+3 ; BUSER = DUZ of passed in user or Null
+4 ; BQROLE = ROLE Array - if only one entry it was passed in by RPC
+5 ; BQUSER = Array which gets updated (and possibly added to)
+6 ;
+7 NEW BQIEN,DIC,RL,RLCNT,X,Y
+8 ;
+9 ;Get BQIRPC secondary menu IEN
+10 SET DIC=19
SET DIC(0)="X"
SET X="BQIRPC"
DO ^DIC
IF Y<0
QUIT
+11 SET BQIEN=+Y
+12 ;
+13 ;No user or role was passed, new entries are allowed
+14 SET RL=""
SET RLCNT=0
FOR
SET RL=$ORDER(BQROLE(RL))
IF RL=""
QUIT
IF $PIECE(BQROLE(RL),U,3)=1
SET RLCNT=RLCNT+1
+15 ;If a role was passed, there would only be 1
IF $GET(BUSER)=""
IF $GET(RLCNT)>1
Begin DoDot:1
+16 ;
+17 ;Find all users with "BQIRPC" as a secondary menu
+18 SET BUSER=""
FOR
SET BUSER=$ORDER(^VA(200,"AD",BQIEN,BUSER))
IF 'BUSER
QUIT
Begin DoDot:2
+19 IF $GET(^VA(200,BUSER,0))=""!'$$ACTIVE^XUSER(BUSER)
QUIT
+20 SET $PIECE(BQUSER(BUSER),U,5)="Y"
End DoDot:2
+21 QUIT
End DoDot:1
QUIT
+22 ;
+23 ;If either a user or role passed in, just update users already found
+24 SET BUSER=""
FOR
SET BUSER=$ORDER(BQUSER(BUSER))
IF BUSER=""
QUIT
Begin DoDot:1
+25 IF $ORDER(^VA(200,BUSER,203,"B",BQIEN,""))]""
SET $PIECE(BQUSER(BUSER),U,5)="Y"
End DoDot:1
+26 ;
+27 QUIT
