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

ACRFACC.m

Go to the documentation of this file. 
  1. ACRFACC ;IHS/OIRM/DSD/THL,AEF - DEFINE ARMS USER BY ACCESS LEVEL;  [ 11/01/2001   9:44 AM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
  1.  ;;ALLOWS SYSTEMS MANAGER TO DEFINE ACCESS LEVEL FOR ARMS USER
  1.  ;;SECURITY KEYS ARE ASSIGNED ACCORDING TO ACCESS LEVEL
  1. EN ;EP;FOR MULTIPLE USER SETUP
  1.  F  D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
  1. EXIT K ACRI,ACRJ,ACRZ,ACRLVL,ACRLVLDA,ACRTXDA,DINUM,ACRQUIT,ACR,ACRNWLVL,ACRACC,ACRII,ACRDEPT,ACRY
  1.  Q
  1. EN1 W @IOF
  1. EN11 ;EP;
  1.  W !?22,"ESTABLISH USER ACCESS LEVEL"
  1.  W !?22,"==========================="
  1.  W !
  1.  S DIC="^VA(200,"
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="EMPLOYEE............: "
  1.  D DIC^ACRFDIC
  1.  I +Y<1 S ACRQUIT="" Q
  1.  S ACRDUZ=+Y
  1.  S ACRUSER=Y(0,0)
  1.  S ACRUSER=$P(ACRUSER,",",2)_" "_$P(ACRUSER,",")
  1. EN2 ;EP;FOR SINGLE USER SETUP, USER MUST BE DEFINED PER:
  1.  ;ACRDUZ = DUZ OF PERSON BEING ASSIGNED ACCESS LEVEL
  1.  ;ACRUSER = NAME OF           "
  1.  D DISPLAY
  1.  D ACCLVL
  1.  W !!?5,ACRUSER," has been assigned "
  1.  W $S($D(ACRLVL):ACRLVL,1:"NO")," access to ARMS."
  1.  H 2
  1.  D EXIT
  1.  Q
  1. DISPLAY ;DISPLAYS ESTABLISHED ACCESS LEVELS
  1.  W !!?10,"CODE"
  1.  W ?16,"LEVEL"
  1.  W ?26,"LEVEL NAME"
  1.  W !?10,"----"
  1.  W ?16,"--------"
  1.  W ?26,"------------------------------"
  1.  S ACR=0
  1.  F  S ACR=$O(^ACRACC("C",ACR)) Q:'ACR  D
  1.  .S ACRDA=0
  1.  .F  S ACRDA=$O(^ACRACC("C",ACR,ACRDA)) Q:'ACRDA  D
  1.  ..S ACRACC=^ACRACC(ACRDA,0)
  1.  ..W !?10,$P(ACRACC,U,2)
  1.  ..W ?16,$P(ACRACC,U)
  1.  ..W ?26,$P(ACRACC,U,3)
  1.  Q
  1. ACCLVL ;SELECTS ACCESS LEVEL
  1.  I $D(^ACRUAL("LVL",ACRDUZ)) D OLDLVL Q:$D(ACRLVLDA)
  1.  I '$D(^ACRUAL("LVL",ACRDUZ)),$D(^ACRUAL(ACRDUZ,0)) D
  1.  .S ACRNWLVL=""
  1.  .D ACCESS
  1.  .K ACRNWLVL
  1.  S DIR(0)="LOA^1:10:1"
  1.  S:'$D(^ACRUAL("LVL",DUZ,3)) DIR(0)="LOA^1:9:1"
  1.  S DIR("A")="Access level(S)....:  "
  1.  W !
  1.  D DIR^ACRFDIC
  1.  Q:+Y<1
  1.  S ACRX=Y
  1.  F ACRJ=1:1 S ACRZ=$P(ACRX,",",ACRJ) Q:ACRZ=""  D
  1.  .S ACRLVL=ACRZ
  1.  .S ACRLVLDA=$O(^ACRACC("C",ACRLVL,0))
  1.  .D:ACRLVLDA SET
  1.  Q
  1. SET ;EP;TO KILL OLD ACCESS LEVEL AND DELETE USER AS HOLDER OF SECURITY KEYS
  1.  ;AND TO SET NEW LEVEL AND ADD USER AS HOLDER OF SECURITY KEYS
  1.  D SETKILL
  1. ACCESS ;EP;TO SET ACCESS LEVEL
  1.  S:$D(^ACRUAL("LVL",ACRDUZ,3)) ACRLVL=3
  1.  S (X,DA,DINUM)=ACRDUZ
  1.  S ACRD=$S('$D(ACRNWLVL):"FILE",1:"DIK")
  1.  S (DIC,DIK)="^ACRUAL("
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02////"_ACRLVLDA
  1.  D @ACRD^ACRFDIC
  1.  K:$D(ACRNWLVL) ^ACRUAL("LVL",ACRDUZ)
  1.  S:$G(ACRLVLDA)=3 ^ACRUAL("LVL",ACRDUZ,3,ACRDUZ)=""
  1.  S ^ACRUAL("LVL",ACRDUZ,ACRLVLDA,ACRDUZ)=""
  1.  K ACRNWLVL,ACRLVLDA,DR,ACRD
  1.  Q
  1. OLDLVL ;DISPLAYS EXISTING ACCESS LEVEL AND QUERIES TO CHANGE ACCESS LEVEL
  1.  S ACRLVLDA=$O(^ACRUAL("LVL",ACRDUZ,""))
  1.  I 'ACRLVLDA K ^ACRUAL("LVL",ACRDUZ),ACRLVLDA Q
  1.  I '$D(^ACRUAL(ACRDUZ,0)) K ^ACRUAL("LVL",ACRDUZ),ACRLVLDA Q
  1.  S ACRLVL=$P(^ACRACC(ACRLVLDA,0),U)
  1.  W !!?5,ACRUSER," has ",ACRLVL," access"
  1.  I $O(^ACRUAL("LVL",ACRDUZ,ACRLVLDA)) D
  1.  .N X
  1.  .S X=ACRLVLDA
  1.  .F  S X=$O(^ACRUAL("LVL",ACRDUZ,X)) Q:'X  D
  1.  ..W !?($L(ACRUSER)+6),"and ",$P($G(^ACRACC(X,0)),U)," access"
  1.  S DIR(0)="YO"
  1.  S DIR("B")="NO"
  1.  S DIR("A")="     Want to change this level"
  1.  D DIR^ACRFDIC
  1.  I Y'=1 K ACRQUIT Q
  1.  K ^ACRUAL("LVL",ACRDUZ)
  1.  S ACRNWLVL=""
  1.  D SET
  1.  K ACRNWLVL,ACRLVLDA,DR
  1.  Q
  1. SETSEC ; ASSIGN XUSR THIS SECURITY KEY
  1.  S (X,DINUM)=ACRI
  1.  S DA(1)=ACRDUZ
  1.  S DIC="^VA(200,"_DA(1)_",51,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")="1////.5;2////"_DT_";3////"_DT
  1.  I '$D(^VA(200,DA(1),51,X,0)) D
  1.  .S:'$D(@(DIC_"0)")) @(DIC_"0)")="^200.051PA"
  1.  .D FILE^ACRFDIC
  1.  Q
  1. KILLSEC ;EP;DELETES USER AS HOLDER OF THE SECURITY KEY
  1.  N ACRI
  1.  S ACRI=0
  1.  F  S ACRI=$O(^VA(200,ACRDUZ,51,ACRI)) Q:'ACRI  D
  1.  .I $D(^VA(200,ACRDUZ,51,ACRI,0)),$E($G(^DIC(19.1,ACRI,0)),1,4)="ACRZ" D
  1.  ..S DA(1)=ACRDUZ
  1.  ..S DA=ACRI
  1.  ..S DIK="^VA(200,"_ACRDUZ_",51,"
  1.  ..D DIK^ACRFDIC
  1.  ..K ^DIC(19.1,"D",ACRDUZ,ACRI)
  1.  Q
  1. SETKILL ;EP;
  1.  I '$D(ACRNWLVL)&$D(ACRLVL)#2 D
  1.  .W !!,"ACCESS LEVEL ",ACRLVL," BEING ASSIGNED..."
  1.  K DR
  1.  S ACRI=0
  1.  F  S ACRI=$O(^ACRACC(ACRLVLDA,"SEC",ACRI)) Q:'ACRI  D
  1.  .D SETSEC:'$D(ACRNWLVL)
  1.  .D KILLSEC:$D(ACRNWLVL)
  1.  Q
  1. DELETE ;EP;TO DELETE USERS ACCESS TO ARMS INCLUDING ACCESS LEVEL, SECURITY
  1.  ;KEYS AND ACCOUNT ACCESS
  1.  S:'$D(^ACRPO(1,50,0))#2 ^ACRPO(1,50,0)="^9002199.4501P"
  1.  S X=DUZ
  1.  S DIC="^ACRPO(1,50,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02///NOW",DA(1)=1
  1.  D FILE^ACRFDIC
  1.  S ACRAAUD=+Y
  1.  D WARNING^ACRFWARN
  1.  W !!,"The following procedure will delete all access this users has to ARMS."
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Are you certain this is what you want to do"
  1.  S DIR("B")="NO"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  Q:Y'=1
  1.  S DA=ACRAAUD
  1.  S DIE="^ACRPO(1,50,"
  1.  S DR=".03////1;.04////"_ACRDUZ
  1.  D DIE^ACRFDIC
  1.  S ACRNWLVL=""
  1.  S ACRLVLDA=3
  1.  W !!,"ARMS related SECURITY KEYS being withdrawn."
  1.  D SETKILL
  1.  W !,"ARMS APPROVAL AUTHORITIES being deleted."
  1.  S ACRDA=0
  1.  F  S ACRDA=$O(^ACRAPL("B",ACRDUZ,ACRDA)) Q:'ACRDA  D
  1.  .S DA=ACRDA
  1.  .S DIK="^ACRAPL("
  1.  .D DIK^ACRFDIC
  1.  W !,"Authority to sign as an ALTERNATE for someone else being deleted."
  1.  S ACRDA=0
  1.  F  S ACRDA=$O(^ACRAPL("SEC",ACRDUZ,ACRDA)) Q:'ACRDA  D
  1.  .S DA=ACRDA
  1.  .S DIE="^ACRAPL("
  1.  .F X=1:1:4 D:$P(^ACRAPL(DA,"DT"),U,X)=ACRDUZ
  1.  ..S DR=$G(DR)_X_"///@;"
  1.  .D DIE^ACRFDIC
  1.  W !,"ARMS ACCESS LEVEL being deleted."
  1.  S ACRDA=0
  1.  F  S ACRDA=$O(^ACRUAL("B",ACRDUZ,ACRDA)) Q:'ACRDA  D
  1.  .S DA=ACRDA
  1.  .S DIK="^ACRUAL("
  1.  .D DIK^ACRFDIC
  1.  K ^ACRUAL("LVL",ACRDUZ)
  1.  W !,"ARMS DEPARTMENT ACCOUNT access being deleted."
  1.  I $D(^ACRPA("B",ACRDUZ)) D
  1.  .S DA=$O(^ACRPA("B",ACRDUZ,0))
  1.  .S DIK="^ACRPA("
  1.  .D DIK^ACRFDIC:DA
  1.  S ACRDA(1)=0
  1.  F  S ACRDA(1)=$O(^ACRLOCB("SEC",ACRDUZ,ACRDA(1))) Q:'ACRDA(1)  D
  1.  .S ACRDA=0
  1.  .F  S ACRDA=$O(^ACRLOCB("SEC",ACRDUZ,ACRDA(1),ACRDA)) Q:'ACRDA  D
  1.  ..S DA(1)=ACRDA(1)
  1.  ..S DA=ACRDA
  1.  ..S DIK="^ACRLOCB("_DA(1)_",""SC"","
  1.  ..D DIK^ACRFDIC
  1.  F ACRXREF="CALLER","SSTAFF" D
  1.  .S ACRDA(1)=0
  1.  .F  S ACRDA(1)=$O(^ACRDOC(ACRXREF,ACRDUZ,ACRDA(1))) Q:'ACRDA(1)  D
  1.  ..S ACRDA=0
  1.  ..F  S ACRDA=$O(^ACRDOC(ACRXREF,ACRDUZ,ACRDA(1),ACRDA)) Q:'ACRDA  D
  1.  ...S DA(1)=ACRDA(1)
  1.  ...S DA=ACRDA
  1.  ...S DIK="^ACRDOC("_DA(1)_",31,"
  1.  ...D DIK^ACRFDIC
  1.  W !!,"Withdrawal of ALL ARMS access has been completed."
  1.  D PAUSE^ACRFWARN
  1.  Q
  1. BPA ;EP;TO ASSIGN MULTIPLE BPA'S TO A USER
  1.  N ACRJ,ACRDOCDA,ACRDOC0,ACRY,ACRX,ACRYY,ACRVDA
  1.  S ACRDOCDA=0
  1.  F  S ACRDOCDA=$O(^ACRDOC("T",ACRDOCDA)) Q:'ACRDOCDA!$D(ACRQUIT)!$D(ACROUT)  D
  1.  .Q:'$P(^ACRDOC(ACRDOCDA,0),U,23)
  1.  .I $P($G(^ACRDOC(ACRDOCDA,15)),U,11) Q:$P(^(15),U,11)<DT
  1.  .S ACRDOC0=^ACRDOC(ACRDOCDA,0)
  1.  .S ACRJ=$G(ACRJ)+1
  1.  .D BPAH:ACRJ=1
  1.  .S ACRJ(ACRJ)=ACRDOCDA
  1.  .S ACRVDA=$P(^ACRDOC(ACRDOCDA,"PO"),U,5)
  1.  .I ACRVDA S ACRVDA=$P($G(^AUTTVNDR(ACRVDA,0)),U)
  1.  .E  S ACRVDA="NOT STATED"
  1.  .W !,ACRJ
  1.  .W ?5,$P(ACRDOC0,U)
  1.  .W ?23,$P(ACRDOC0,U,2)
  1.  .W ?37,ACRVDA
  1.  .I $Y+4>IOSL D
  1.  ..D PAUSE^ACRFWARN
  1.  ..D BPAH
  1.  Q:$D(ACROUT)
  1.  I '$G(ACRJ) D  Q
  1.  .W !!,"There are no active BPA's on file."
  1.  .D PAUSE^ACRFWARN
  1.  K ACRQUIT
  1.  S DIR(0)="LO^1:"_ACRJ
  1.  S DIR("A")="Assign which BPA's to this user"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  Q:$D(ACRQUIT)!+Y<1
  1.  S ACRYY=Y
  1.  F ACRJ=1:1 S ACRX=$P(ACRYY,",",ACRJ) Q:ACRX=""  D BPA1
  1.  Q
  1. BPA1 ;ADD USER AS CALLER TO A BPA
  1.  Q:'$D(ACRJ(ACRX))
  1.  S (DA(1),ACRDOCDA)=ACRJ(ACRX)
  1.  S X=ACRDUZ
  1.  S DIC="^ACRDOC("_DA(1)_",6,"
  1.  S DIC(0)="L"
  1.  D FILE^ACRFDIC
  1.  Q
  1. BPAH ;HEADER FOR BPA LISTING
  1.  W @IOF
  1.  W !,"ACTIVE BLANKET PURCHASE AGREEMENTS"
  1.  W !,"NO."
  1.  W ?5,"REQUISITION NO."
  1.  W ?23,"PO NUMBER"
  1.  W ?37,"VENDOR/CONTRACTOR"
  1.  W !,"---"
  1.  W ?5,"---------------"
  1.  W ?23,"------------"
  1.  W ?37,"-----------------------------"
  1.  Q