Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQISYKEY

BQISYKEY.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1. 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
  1.  NEW FINAL,FKY,MSG,RESULT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQISYKEY",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYKEY D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
  1.  S RLIST=$G(RLIST,"")
  1.  I RLIST="" D
  1.  . S LIST="",BN=""
  1.  . F  S BN=$O(RLIST(BN)) Q:BN=""  S LIST=LIST_RLIST(BN)
  1.  . K RLIST
  1.  . S RLIST=LIST
  1.  . K LIST
  1.  ;
  1.  F BQ=1:1:$L(RLIST,$C(28)) D
  1.  . S PDATA=$P(RLIST,$C(28),BQ)
  1.  . S BKEY=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
  1.  . I VALUE="Y" D ADD Q
  1.  . I VALUE="N" D REM
  1.  . Q
  1.  ;
  1.  S FINAL=1,FKY="",MSG=""
  1.  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)_"; "
  1.  I $G(MSG)'="" S MSG=$$TKO^BQIUL1(MSG,"; ")
  1.  S II=II+1,@DATA@(II)=FINAL_U_$G(MSG)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ADD ;EP - Add ROLE to user
  1.  NEW RIEN,ROLE,BKIEN,Y
  1.  S RIEN=$O(^BQI(90505.2,"C",BKEY,"")) I RIEN="" Q
  1.  S ROLE=$P(^BQI(90505.2,RIEN,0),U,1)
  1.  S BKIEN=$O(^DIC(19.1,"B",BKEY,""))
  1.  I $D(^XUSEC(BKEY,USER)) Q
  1.  I BKIEN="" Q
  1.  NEW DIC
  1.  S DIC(0)="NMQ",DIC("P")="200.051PA"
  1.  S DIC="^VA(200,"_USER_",51,",DA(1)=USER,X=BKIEN,DINUM=X
  1.  K DO,DD D FILE^DICN
  1.  I Y<0 S RESULT(BKEY)="-1^Unable to add role "_ROLE Q
  1.  S RESULT(BKEY)=1
  1.  Q
  1.  ;
  1. REM ;EP - Remove ROLE from user
  1.  NEW RIEN
  1.  S RIEN=$O(^BQI(90505.2,"C",BKEY,"")) I RIEN="" Q
  1.  S ROLE=$P(^BQI(90505.2,RIEN,0),U,1)
  1.  S BKIEN=$O(^DIC(19.1,"B",BKEY,""))
  1.  I '$D(^XUSEC(BKEY,USER)) Q
  1.  NEW DIK,DA
  1.  S DIK="^VA(200,"_USER_",51,",DA(1)=USER,DA=BKIEN
  1.  D ^DIK
  1.  S RESULT(BKEY)=1
  1.  Q
  1.  ;
  1. RET(DATA,USER,ROLE) ; EP - BQI GET USER ROLES
  1.  ;
  1.  ;Parameters:
  1.  ;USER (optional) = DUZ of specific user to report on
  1.  ;ROLE (optional) = Specific role that user(s) must have to return information
  1.  ;
  1.  NEW UID,II,BKEY,BKIEN,OKEY,HDR,RIEN,BQROLE,NPOS
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQISYKG",UID))
  1.  K @DATA
  1.  S ROLE=$G(ROLE,""),USER=$G(USER,"")
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYKEY D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S HDR="T00050BQIUSER^T00001EDIT_CANDIDATE^T00001TAX_CANDIDATE^T00001BQIZCUSR^"
  1.  S HDR=HDR_"T00001BQIRPC^T00001BQIZCMED^T00001BQIZTXED^T00001BQIZMGR^T00001BTPWZCMGR^"
  1.  S HDR=HDR_"T00001BQIZBHUSR^T00001BQIZMUMGR^T00001BQIZEMPHLTH^T00001BQIZIPCMGR^"
  1.  S HDR=HDR_"T00001BQIZDSPM^T00001BQIZBHCA"
  1.  S @DATA@(II)=HDR_$C(30)
  1.  ;
  1.  K BQROLE
  1.  ;
  1.  ;Define all roles, put a 1 for any to look for
  1.  S RIEN=0
  1.  F  S RIEN=$O(^BQI(90505.2,RIEN)) Q:'RIEN  D
  1.  . S BKEY=$P(^BQI(90505.2,RIEN,0),U,2)
  1.  . S BQROLE(BKEY)=$P(^BQI(90505.2,RIEN,0),U,3)_U_RIEN_U_$S(ROLE="":1,1:"")
  1.  ;
  1.  ;If a role was passed in, set it up with a 1
  1.  I ROLE'="" D
  1.  . S RIEN=$O(^BQI(90505.2,"B",ROLE,"")) Q:RIEN=""
  1.  . S BKEY=$P(^BQI(90505.2,RIEN,0),U,2) Q:BKEY=""
  1.  . S BQROLE(BKEY)=$P(^BQI(90505.2,RIEN,0),U,3)_U_RIEN_U_"1"
  1.  ;
  1.  D ROL(USER,.BQROLE)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ROL(BUSER,BQROLE) ;EP - Assemble User Information Based on input User/Role
  1.  ;
  1.  NEW BQUSER,BUSR,POS
  1.  ;
  1.  ;Handle single user request
  1.  I BUSER'="" D  Q:'$D(BQUSER(BUSER))
  1.  . N ASKY,BKEY,POS,RLIEN,RLCK,RLCNT,ROL,VAL
  1.  . ;
  1.  . ;Reset role flag and count
  1.  . S ROL="",RLCNT=0
  1.  . ;
  1.  . ;Skip corrupted entries
  1.  . I $G(^VA(200,BUSER,0))="" Q
  1.  . ;
  1.  . ;Set initial entry
  1.  . S BQUSER(BUSER)=""
  1.  . ;
  1.  . ;Loop through keys for user
  1.  . S BKEY="" F  S BKEY=$O(BQROLE(BKEY)) Q:BKEY=""  D
  1.  .. S VAL=$G(BQROLE(BKEY))
  1.  .. S POS=$P(VAL,U),RLIEN=$P(VAL,U,2),RLCK=$P(VAL,U,3)
  1.  .. I RLCK=1 S RLCNT=RLCNT+1        ;Keep track of # of roles to check
  1.  .. ;
  1.  .. I $D(^XUSEC(BKEY,BUSER)) D
  1.  ... S $P(BQUSER(BUSER),U,POS)="Y"  ;User has key
  1.  ... S:RLCK=1 ROL=1                 ;Set flag if role to check
  1.  .. ;
  1.  .. ;Check whether a candidate
  1.  .. S ASKY="" F  S ASKY=$O(^BQI(90505.2,RLIEN,10,"B",ASKY)) Q:ASKY=""  D
  1.  ... Q:'$D(^XUSEC(ASKY,BUSER))
  1.  ... I BKEY="BQIZCMED" S $P(BQUSER(BUSER),U,2)="Y"
  1.  ... I BKEY="BQIZTXED" S $P(BQUSER(BUSER),U,3)="Y"
  1.  ... I BKEY="BQIZBHUSR" S $P(BQUSER(BUSER),U,POS)="Y"
  1.  ... I BKEY="BQIZDSPM" S $P(BQUSER(BUSER),U,POS)="Y"
  1.  . ;
  1.  . ;If checking for a specific role and not found clear out entry
  1.  . ;(Role count for specific role check will be 1, otherwise >1)
  1.  . I ROL="",RLCNT=1 K BQUSER(BUSER) Q
  1.  . ;
  1.  . ;Check if iCare User
  1.  . S:$G(^BQICARE(BUSER,0))'="" $P(BQUSER(BUSER),U,4)="Y"
  1.  . ;
  1.  . ;Check for BQIRPC Secondary Menu
  1.  . D BQIRPC(BUSER,.BQROLE,.BQUSER)
  1.  ;
  1.  ;Handle blank (multiple) user request
  1.  I BUSER="" D  Q:'$D(BQUSER)
  1.  . N ASKY,BKEY,BUSR,POS,RLCK,RLCNT,RLIEN,ROL,VAL
  1.  . ;
  1.  . ;Reset role count
  1.  . S RLCNT=0
  1.  . ;
  1.  . ;Loop through keys
  1.  . S BKEY="" F  S BKEY=$O(BQROLE(BKEY)) Q:BKEY=""  D
  1.  .. S VAL=$G(BQROLE(BKEY))
  1.  .. S POS=$P(VAL,U),RLIEN=$P(VAL,U,2),RLCK=$P(VAL,U,3)
  1.  .. I RLCK=1 S RLCNT=RLCNT+1        ;Keep track of # of roles to check
  1.  .. ;
  1.  .. ;Loop through users holding that key
  1.  .. S BUSR="" F  S BUSR=$O(^XUSEC(BKEY,BUSR)) Q:BUSR=""  D
  1.  ... I $G(^VA(200,BUSR,0))="" Q
  1.  ... S $P(BQUSER(BUSR),U,POS)="Y"
  1.  ... I RLCK=1 S ROL(BUSR)="" ;Set flag if looking for this role
  1.  .. ;
  1.  .. ;Check whether candidate
  1.  .. S ASKY="" F  S ASKY=$O(^BQI(90505.2,RLIEN,10,"B",ASKY)) Q:ASKY=""  D
  1.  ... S BUSR="" F  S BUSR=$O(^XUSEC(ASKY,BUSR)) Q:BUSR=""  D
  1.  .... I $G(^VA(200,BUSR,0))="" Q
  1.  .... I $P($G(^VA(200,BUSR,0)),U,11)'="" Q
  1.  .... I BKEY="BQIZCMED" S $P(BQUSER(BUSR),U,2)="Y"
  1.  .... I BKEY="BQIZTXED" S $P(BQUSER(BUSR),U,3)="Y"
  1.  .... I BKEY="BQIZBHUSR" S $P(BQUSER(BUSR),U,POS)="Y"
  1.  .... I BKEY="BQIZDSPM" S $P(BQUSER(BUSR),U,POS)="Y"
  1.  . ;
  1.  . ;Check if iCare User
  1.  . S BUSR=0 F  S BUSR=$O(^BQICARE(BUSR)) Q:'BUSR  D
  1.  .. I $G(^VA(200,BUSR,0))="" Q
  1.  .. S $P(BQUSER(BUSR),U,4)="Y"
  1.  . ;
  1.  . ;Check for BQIRPC Secondary Menu
  1.  . D BQIRPC(BUSER,.BQROLE,.BQUSER)
  1.  . ;
  1.  . ;If checking for a specific role and not found clear out entries
  1.  . ;Role count for specific role check will be 1, otherwise >1
  1.  . I RLCNT=1 D
  1.  .. S BUSR="" F  S BUSR=$O(BQUSER(BUSR)) Q:BUSR=""  D
  1.  ... I '$D(ROL(BUSR)) K BQUSER(BUSR)
  1.  ;
  1.  ;Assemble records
  1.  S NPOS=$O(^BQI(90505.2,"AC",""),-1),NPOS=NPOS+1
  1.  S BUSR="" F  S BUSR=$O(BQUSER(BUSR)) Q:BUSR=""  D
  1.  . S $P(BQUSER(BUSR),U,1)=BUSR_$C(28)_$P(^VA(200,BUSR,0),U,1)
  1.  . F POS=2:1:NPOS I $P(BQUSER(BUSR),U,POS)="" S $P(BQUSER(BUSR),U,POS)="N"
  1.  . S POS=6 I $P(BQUSER(BUSR),U,POS)="Y" S $P(BQUSER(BUSR),U,2)="Y"  ; taxonomy edit candidate
  1.  . S POS=7 I $P(BQUSER(BUSR),U,POS)="Y" S $P(BQUSER(BUSR),U,3)="Y"  ; edit candidate
  1.  . I $P(BQUSER(BUSR),U,5)'="Y" K BQUSER(BUSR) Q
  1.  . S II=II+1,@DATA@(II)=BQUSER(BUSR)_$C(30)
  1.  Q
  1.  ;
  1. BQIRPC(BUSER,BQROLE,BQUSER) ;EP - Locate users with BQIRPC Sec. Menu Assigned
  1.  ;
  1.  ;Parameters:
  1.  ;  BUSER = DUZ of passed in user or Null
  1.  ; BQROLE = ROLE Array - if only one entry it was passed in by RPC
  1.  ; BQUSER = Array which gets updated (and possibly added to)
  1.  ;
  1.  NEW BQIEN,DIC,RL,RLCNT,X,Y
  1.  ;
  1.  ;Get BQIRPC secondary menu IEN
  1.  S DIC=19,DIC(0)="X",X="BQIRPC" D ^DIC Q:Y<0
  1.  S BQIEN=+Y
  1.  ;
  1.  ;No user or role was passed, new entries are allowed
  1.  S RL="",RLCNT=0 F  S RL=$O(BQROLE(RL)) Q:RL=""  I $P(BQROLE(RL),U,3)=1 S RLCNT=RLCNT+1
  1.  I $G(BUSER)="",$G(RLCNT)>1 D  Q  ;If a role was passed, there would only be 1
  1.  . ;
  1.  . ;Find all users with "BQIRPC" as a secondary menu
  1.  . S BUSER="" F  S BUSER=$O(^VA(200,"AD",BQIEN,BUSER)) Q:'BUSER  D
  1.  .. I $G(^VA(200,BUSER,0))=""!'$$ACTIVE^XUSER(BUSER) Q
  1.  .. S $P(BQUSER(BUSER),U,5)="Y"
  1.  . Q
  1.  ;
  1.  ;If either a user or role passed in, just update users already found
  1.  S BUSER="" F  S BUSER=$O(BQUSER(BUSER)) Q:BUSER=""  D
  1.  .I $O(^VA(200,BUSER,203,"B",BQIEN,""))]"" S $P(BQUSER(BUSER),U,5)="Y"
  1.  ;
  1.  Q