ACRFACC ;IHS/OIRM/DSD/THL,AEF - DEFINE ARMS USER BY ACCESS LEVEL; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;ALLOWS SYSTEMS MANAGER TO DEFINE ACCESS LEVEL FOR ARMS USER
;;SECURITY KEYS ARE ASSIGNED ACCORDING TO ACCESS LEVEL
EN ;EP;FOR MULTIPLE USER SETUP
F D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
EXIT K ACRI,ACRJ,ACRZ,ACRLVL,ACRLVLDA,ACRTXDA,DINUM,ACRQUIT,ACR,ACRNWLVL,ACRACC,ACRII,ACRDEPT,ACRY
Q
EN1 W @IOF
EN11 ;EP;
W !?22,"ESTABLISH USER ACCESS LEVEL"
W !?22,"==========================="
W !
S DIC="^VA(200,"
S DIC(0)="AEMQZ"
S DIC("A")="EMPLOYEE............: "
D DIC^ACRFDIC
I +Y<1 S ACRQUIT="" Q
S ACRDUZ=+Y
S ACRUSER=Y(0,0)
S ACRUSER=$P(ACRUSER,",",2)_" "_$P(ACRUSER,",")
EN2 ;EP;FOR SINGLE USER SETUP, USER MUST BE DEFINED PER:
;ACRDUZ = DUZ OF PERSON BEING ASSIGNED ACCESS LEVEL
;ACRUSER = NAME OF "
D DISPLAY
D ACCLVL
W !!?5,ACRUSER," has been assigned "
W $S($D(ACRLVL):ACRLVL,1:"NO")," access to ARMS."
H 2
D EXIT
Q
DISPLAY ;DISPLAYS ESTABLISHED ACCESS LEVELS
W !!?10,"CODE"
W ?16,"LEVEL"
W ?26,"LEVEL NAME"
W !?10,"----"
W ?16,"--------"
W ?26,"------------------------------"
S ACR=0
F S ACR=$O(^ACRACC("C",ACR)) Q:'ACR D
.S ACRDA=0
.F S ACRDA=$O(^ACRACC("C",ACR,ACRDA)) Q:'ACRDA D
..S ACRACC=^ACRACC(ACRDA,0)
..W !?10,$P(ACRACC,U,2)
..W ?16,$P(ACRACC,U)
..W ?26,$P(ACRACC,U,3)
Q
ACCLVL ;SELECTS ACCESS LEVEL
I $D(^ACRUAL("LVL",ACRDUZ)) D OLDLVL Q:$D(ACRLVLDA)
I '$D(^ACRUAL("LVL",ACRDUZ)),$D(^ACRUAL(ACRDUZ,0)) D
.S ACRNWLVL=""
.D ACCESS
.K ACRNWLVL
S DIR(0)="LOA^1:10:1"
S:'$D(^ACRUAL("LVL",DUZ,3)) DIR(0)="LOA^1:9:1"
S DIR("A")="Access level(S)....: "
W !
D DIR^ACRFDIC
Q:+Y<1
S ACRX=Y
F ACRJ=1:1 S ACRZ=$P(ACRX,",",ACRJ) Q:ACRZ="" D
.S ACRLVL=ACRZ
.S ACRLVLDA=$O(^ACRACC("C",ACRLVL,0))
.D:ACRLVLDA SET
Q
SET ;EP;TO KILL OLD ACCESS LEVEL AND DELETE USER AS HOLDER OF SECURITY KEYS
;AND TO SET NEW LEVEL AND ADD USER AS HOLDER OF SECURITY KEYS
D SETKILL
ACCESS ;EP;TO SET ACCESS LEVEL
S:$D(^ACRUAL("LVL",ACRDUZ,3)) ACRLVL=3
S (X,DA,DINUM)=ACRDUZ
S ACRD=$S('$D(ACRNWLVL):"FILE",1:"DIK")
S (DIC,DIK)="^ACRUAL("
S DIC(0)="L"
S DIC("DR")=".02////"_ACRLVLDA
D @ACRD^ACRFDIC
K:$D(ACRNWLVL) ^ACRUAL("LVL",ACRDUZ)
S:$G(ACRLVLDA)=3 ^ACRUAL("LVL",ACRDUZ,3,ACRDUZ)=""
S ^ACRUAL("LVL",ACRDUZ,ACRLVLDA,ACRDUZ)=""
K ACRNWLVL,ACRLVLDA,DR,ACRD
Q
OLDLVL ;DISPLAYS EXISTING ACCESS LEVEL AND QUERIES TO CHANGE ACCESS LEVEL
S ACRLVLDA=$O(^ACRUAL("LVL",ACRDUZ,""))
I 'ACRLVLDA K ^ACRUAL("LVL",ACRDUZ),ACRLVLDA Q
I '$D(^ACRUAL(ACRDUZ,0)) K ^ACRUAL("LVL",ACRDUZ),ACRLVLDA Q
S ACRLVL=$P(^ACRACC(ACRLVLDA,0),U)
W !!?5,ACRUSER," has ",ACRLVL," access"
I $O(^ACRUAL("LVL",ACRDUZ,ACRLVLDA)) D
.N X
.S X=ACRLVLDA
.F S X=$O(^ACRUAL("LVL",ACRDUZ,X)) Q:'X D
..W !?($L(ACRUSER)+6),"and ",$P($G(^ACRACC(X,0)),U)," access"
S DIR(0)="YO"
S DIR("B")="NO"
S DIR("A")=" Want to change this level"
D DIR^ACRFDIC
I Y'=1 K ACRQUIT Q
K ^ACRUAL("LVL",ACRDUZ)
S ACRNWLVL=""
D SET
K ACRNWLVL,ACRLVLDA,DR
Q
SETSEC ; ASSIGN XUSR THIS SECURITY KEY
S (X,DINUM)=ACRI
S DA(1)=ACRDUZ
S DIC="^VA(200,"_DA(1)_",51,"
S DIC(0)="L"
S DIC("DR")="1////.5;2////"_DT_";3////"_DT
I '$D(^VA(200,DA(1),51,X,0)) D
.S:'$D(@(DIC_"0)")) @(DIC_"0)")="^200.051PA"
.D FILE^ACRFDIC
Q
KILLSEC ;EP;DELETES USER AS HOLDER OF THE SECURITY KEY
N ACRI
S ACRI=0
F S ACRI=$O(^VA(200,ACRDUZ,51,ACRI)) Q:'ACRI D
.I $D(^VA(200,ACRDUZ,51,ACRI,0)),$E($G(^DIC(19.1,ACRI,0)),1,4)="ACRZ" D
..S DA(1)=ACRDUZ
..S DA=ACRI
..S DIK="^VA(200,"_ACRDUZ_",51,"
..D DIK^ACRFDIC
..K ^DIC(19.1,"D",ACRDUZ,ACRI)
Q
SETKILL ;EP;
I '$D(ACRNWLVL)&$D(ACRLVL)#2 D
.W !!,"ACCESS LEVEL ",ACRLVL," BEING ASSIGNED..."
K DR
S ACRI=0
F S ACRI=$O(^ACRACC(ACRLVLDA,"SEC",ACRI)) Q:'ACRI D
.D SETSEC:'$D(ACRNWLVL)
.D KILLSEC:$D(ACRNWLVL)
Q
DELETE ;EP;TO DELETE USERS ACCESS TO ARMS INCLUDING ACCESS LEVEL, SECURITY
;KEYS AND ACCOUNT ACCESS
S:'$D(^ACRPO(1,50,0))#2 ^ACRPO(1,50,0)="^9002199.4501P"
S X=DUZ
S DIC="^ACRPO(1,50,"
S DIC(0)="L"
S DIC("DR")=".02///NOW",DA(1)=1
D FILE^ACRFDIC
S ACRAAUD=+Y
D WARNING^ACRFWARN
W !!,"The following procedure will delete all access this users has to ARMS."
S DIR(0)="YO"
S DIR("A")="Are you certain this is what you want to do"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
Q:Y'=1
S DA=ACRAAUD
S DIE="^ACRPO(1,50,"
S DR=".03////1;.04////"_ACRDUZ
D DIE^ACRFDIC
S ACRNWLVL=""
S ACRLVLDA=3
W !!,"ARMS related SECURITY KEYS being withdrawn."
D SETKILL
W !,"ARMS APPROVAL AUTHORITIES being deleted."
S ACRDA=0
F S ACRDA=$O(^ACRAPL("B",ACRDUZ,ACRDA)) Q:'ACRDA D
.S DA=ACRDA
.S DIK="^ACRAPL("
.D DIK^ACRFDIC
W !,"Authority to sign as an ALTERNATE for someone else being deleted."
S ACRDA=0
F S ACRDA=$O(^ACRAPL("SEC",ACRDUZ,ACRDA)) Q:'ACRDA D
.S DA=ACRDA
.S DIE="^ACRAPL("
.F X=1:1:4 D:$P(^ACRAPL(DA,"DT"),U,X)=ACRDUZ
..S DR=$G(DR)_X_"///@;"
.D DIE^ACRFDIC
W !,"ARMS ACCESS LEVEL being deleted."
S ACRDA=0
F S ACRDA=$O(^ACRUAL("B",ACRDUZ,ACRDA)) Q:'ACRDA D
.S DA=ACRDA
.S DIK="^ACRUAL("
.D DIK^ACRFDIC
K ^ACRUAL("LVL",ACRDUZ)
W !,"ARMS DEPARTMENT ACCOUNT access being deleted."
I $D(^ACRPA("B",ACRDUZ)) D
.S DA=$O(^ACRPA("B",ACRDUZ,0))
.S DIK="^ACRPA("
.D DIK^ACRFDIC:DA
S ACRDA(1)=0
F S ACRDA(1)=$O(^ACRLOCB("SEC",ACRDUZ,ACRDA(1))) Q:'ACRDA(1) D
.S ACRDA=0
.F S ACRDA=$O(^ACRLOCB("SEC",ACRDUZ,ACRDA(1),ACRDA)) Q:'ACRDA D
..S DA(1)=ACRDA(1)
..S DA=ACRDA
..S DIK="^ACRLOCB("_DA(1)_",""SC"","
..D DIK^ACRFDIC
F ACRXREF="CALLER","SSTAFF" D
.S ACRDA(1)=0
.F S ACRDA(1)=$O(^ACRDOC(ACRXREF,ACRDUZ,ACRDA(1))) Q:'ACRDA(1) D
..S ACRDA=0
..F S ACRDA=$O(^ACRDOC(ACRXREF,ACRDUZ,ACRDA(1),ACRDA)) Q:'ACRDA D
...S DA(1)=ACRDA(1)
...S DA=ACRDA
...S DIK="^ACRDOC("_DA(1)_",31,"
...D DIK^ACRFDIC
W !!,"Withdrawal of ALL ARMS access has been completed."
D PAUSE^ACRFWARN
Q
BPA ;EP;TO ASSIGN MULTIPLE BPA'S TO A USER
N ACRJ,ACRDOCDA,ACRDOC0,ACRY,ACRX,ACRYY,ACRVDA
S ACRDOCDA=0
F S ACRDOCDA=$O(^ACRDOC("T",ACRDOCDA)) Q:'ACRDOCDA!$D(ACRQUIT)!$D(ACROUT) D
.Q:'$P(^ACRDOC(ACRDOCDA,0),U,23)
.I $P($G(^ACRDOC(ACRDOCDA,15)),U,11) Q:$P(^(15),U,11)<DT
.S ACRDOC0=^ACRDOC(ACRDOCDA,0)
.S ACRJ=$G(ACRJ)+1
.D BPAH:ACRJ=1
.S ACRJ(ACRJ)=ACRDOCDA
.S ACRVDA=$P(^ACRDOC(ACRDOCDA,"PO"),U,5)
.I ACRVDA S ACRVDA=$P($G(^AUTTVNDR(ACRVDA,0)),U)
.E S ACRVDA="NOT STATED"
.W !,ACRJ
.W ?5,$P(ACRDOC0,U)
.W ?23,$P(ACRDOC0,U,2)
.W ?37,ACRVDA
.I $Y+4>IOSL D
..D PAUSE^ACRFWARN
..D BPAH
Q:$D(ACROUT)
I '$G(ACRJ) D Q
.W !!,"There are no active BPA's on file."
.D PAUSE^ACRFWARN
K ACRQUIT
S DIR(0)="LO^1:"_ACRJ
S DIR("A")="Assign which BPA's to this user"
W !
D DIR^ACRFDIC
Q:$D(ACRQUIT)!+Y<1
S ACRYY=Y
F ACRJ=1:1 S ACRX=$P(ACRYY,",",ACRJ) Q:ACRX="" D BPA1
Q
BPA1 ;ADD USER AS CALLER TO A BPA
Q:'$D(ACRJ(ACRX))
S (DA(1),ACRDOCDA)=ACRJ(ACRX)
S X=ACRDUZ
S DIC="^ACRDOC("_DA(1)_",6,"
S DIC(0)="L"
D FILE^ACRFDIC
Q
BPAH ;HEADER FOR BPA LISTING
W @IOF
W !,"ACTIVE BLANKET PURCHASE AGREEMENTS"
W !,"NO."
W ?5,"REQUISITION NO."
W ?23,"PO NUMBER"
W ?37,"VENDOR/CONTRACTOR"
W !,"---"
W ?5,"---------------"
W ?23,"------------"
W ?37,"-----------------------------"
Q
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
+2 ;;ALLOWS SYSTEMS MANAGER TO DEFINE ACCESS LEVEL FOR ARMS USER
+3 ;;SECURITY KEYS ARE ASSIGNED ACCORDING TO ACCESS LEVEL
EN ;EP;FOR MULTIPLE USER SETUP
+1 FOR
DO EN1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
EXIT KILL ACRI,ACRJ,ACRZ,ACRLVL,ACRLVLDA,ACRTXDA,DINUM,ACRQUIT,ACR,ACRNWLVL,ACRACC,ACRII,ACRDEPT,ACRY
+1 QUIT
EN1 WRITE @IOF
EN11 ;EP;
+1 WRITE !?22,"ESTABLISH USER ACCESS LEVEL"
+2 WRITE !?22,"==========================="
+3 WRITE !
+4 SET DIC="^VA(200,"
+5 SET DIC(0)="AEMQZ"
+6 SET DIC("A")="EMPLOYEE............: "
+7 DO DIC^ACRFDIC
+8 IF +Y<1
SET ACRQUIT=""
QUIT
+9 SET ACRDUZ=+Y
+10 SET ACRUSER=Y(0,0)
+11 SET ACRUSER=$PIECE(ACRUSER,",",2)_" "_$PIECE(ACRUSER,",")
EN2 ;EP;FOR SINGLE USER SETUP, USER MUST BE DEFINED PER:
+1 ;ACRDUZ = DUZ OF PERSON BEING ASSIGNED ACCESS LEVEL
+2 ;ACRUSER = NAME OF "
+3 DO DISPLAY
+4 DO ACCLVL
+5 WRITE !!?5,ACRUSER," has been assigned "
+6 WRITE $SELECT($DATA(ACRLVL):ACRLVL,1:"NO")," access to ARMS."
+7 HANG 2
+8 DO EXIT
+9 QUIT
DISPLAY ;DISPLAYS ESTABLISHED ACCESS LEVELS
+1 WRITE !!?10,"CODE"
+2 WRITE ?16,"LEVEL"
+3 WRITE ?26,"LEVEL NAME"
+4 WRITE !?10,"----"
+5 WRITE ?16,"--------"
+6 WRITE ?26,"------------------------------"
+7 SET ACR=0
+8 FOR
SET ACR=$ORDER(^ACRACC("C",ACR))
IF 'ACR
QUIT
Begin DoDot:1
+9 SET ACRDA=0
+10 FOR
SET ACRDA=$ORDER(^ACRACC("C",ACR,ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:2
+11 SET ACRACC=^ACRACC(ACRDA,0)
+12 WRITE !?10,$PIECE(ACRACC,U,2)
+13 WRITE ?16,$PIECE(ACRACC,U)
+14 WRITE ?26,$PIECE(ACRACC,U,3)
End DoDot:2
End DoDot:1
+15 QUIT
ACCLVL ;SELECTS ACCESS LEVEL
+1 IF $DATA(^ACRUAL("LVL",ACRDUZ))
DO OLDLVL
IF $DATA(ACRLVLDA)
QUIT
+2 IF '$DATA(^ACRUAL("LVL",ACRDUZ))
IF $DATA(^ACRUAL(ACRDUZ,0))
Begin DoDot:1
+3 SET ACRNWLVL=""
+4 DO ACCESS
+5 KILL ACRNWLVL
End DoDot:1
+6 SET DIR(0)="LOA^1:10:1"
+7 IF '$DATA(^ACRUAL("LVL",DUZ,3))
SET DIR(0)="LOA^1:9:1"
+8 SET DIR("A")="Access level(S)....: "
+9 WRITE !
+10 DO DIR^ACRFDIC
+11 IF +Y<1
QUIT
+12 SET ACRX=Y
+13 FOR ACRJ=1:1
SET ACRZ=$PIECE(ACRX,",",ACRJ)
IF ACRZ=""
QUIT
Begin DoDot:1
+14 SET ACRLVL=ACRZ
+15 SET ACRLVLDA=$ORDER(^ACRACC("C",ACRLVL,0))
+16 IF ACRLVLDA
DO SET
End DoDot:1
+17 QUIT
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
+2 DO SETKILL
ACCESS ;EP;TO SET ACCESS LEVEL
+1 IF $DATA(^ACRUAL("LVL",ACRDUZ,3))
SET ACRLVL=3
+2 SET (X,DA,DINUM)=ACRDUZ
+3 SET ACRD=$SELECT('$DATA(ACRNWLVL):"FILE",1:"DIK")
+4 SET (DIC,DIK)="^ACRUAL("
+5 SET DIC(0)="L"
+6 SET DIC("DR")=".02////"_ACRLVLDA
+7 DO @ACRD^ACRFDIC
+8 IF $DATA(ACRNWLVL)
KILL ^ACRUAL("LVL",ACRDUZ)
+9 IF $GET(ACRLVLDA)=3
SET ^ACRUAL("LVL",ACRDUZ,3,ACRDUZ)=""
+10 SET ^ACRUAL("LVL",ACRDUZ,ACRLVLDA,ACRDUZ)=""
+11 KILL ACRNWLVL,ACRLVLDA,DR,ACRD
+12 QUIT
OLDLVL ;DISPLAYS EXISTING ACCESS LEVEL AND QUERIES TO CHANGE ACCESS LEVEL
+1 SET ACRLVLDA=$ORDER(^ACRUAL("LVL",ACRDUZ,""))
+2 IF 'ACRLVLDA
KILL ^ACRUAL("LVL",ACRDUZ),ACRLVLDA
QUIT
+3 IF '$DATA(^ACRUAL(ACRDUZ,0))
KILL ^ACRUAL("LVL",ACRDUZ),ACRLVLDA
QUIT
+4 SET ACRLVL=$PIECE(^ACRACC(ACRLVLDA,0),U)
+5 WRITE !!?5,ACRUSER," has ",ACRLVL," access"
+6 IF $ORDER(^ACRUAL("LVL",ACRDUZ,ACRLVLDA))
Begin DoDot:1
+7 NEW X
+8 SET X=ACRLVLDA
+9 FOR
SET X=$ORDER(^ACRUAL("LVL",ACRDUZ,X))
IF 'X
QUIT
Begin DoDot:2
+10 WRITE !?($LENGTH(ACRUSER)+6),"and ",$PIECE($GET(^ACRACC(X,0)),U)," access"
End DoDot:2
End DoDot:1
+11 SET DIR(0)="YO"
+12 SET DIR("B")="NO"
+13 SET DIR("A")=" Want to change this level"
+14 DO DIR^ACRFDIC
+15 IF Y'=1
KILL ACRQUIT
QUIT
+16 KILL ^ACRUAL("LVL",ACRDUZ)
+17 SET ACRNWLVL=""
+18 DO SET
+19 KILL ACRNWLVL,ACRLVLDA,DR
+20 QUIT
SETSEC ; ASSIGN XUSR THIS SECURITY KEY
+1 SET (X,DINUM)=ACRI
+2 SET DA(1)=ACRDUZ
+3 SET DIC="^VA(200,"_DA(1)_",51,"
+4 SET DIC(0)="L"
+5 SET DIC("DR")="1////.5;2////"_DT_";3////"_DT
+6 IF '$DATA(^VA(200,DA(1),51,X,0))
Begin DoDot:1
+7 IF '$DATA(@(DIC_"0)"))
SET @(DIC_"0)")="^200.051PA"
+8 DO FILE^ACRFDIC
End DoDot:1
+9 QUIT
KILLSEC ;EP;DELETES USER AS HOLDER OF THE SECURITY KEY
+1 NEW ACRI
+2 SET ACRI=0
+3 FOR
SET ACRI=$ORDER(^VA(200,ACRDUZ,51,ACRI))
IF 'ACRI
QUIT
Begin DoDot:1
+4 IF $DATA(^VA(200,ACRDUZ,51,ACRI,0))
IF $EXTRACT($GET(^DIC(19.1,ACRI,0)),1,4)="ACRZ"
Begin DoDot:2
+5 SET DA(1)=ACRDUZ
+6 SET DA=ACRI
+7 SET DIK="^VA(200,"_ACRDUZ_",51,"
+8 DO DIK^ACRFDIC
+9 KILL ^DIC(19.1,"D",ACRDUZ,ACRI)
End DoDot:2
End DoDot:1
+10 QUIT
SETKILL ;EP;
+1 IF '$DATA(ACRNWLVL)&$DATA(ACRLVL)#2
Begin DoDot:1
+2 WRITE !!,"ACCESS LEVEL ",ACRLVL," BEING ASSIGNED..."
End DoDot:1
+3 KILL DR
+4 SET ACRI=0
+5 FOR
SET ACRI=$ORDER(^ACRACC(ACRLVLDA,"SEC",ACRI))
IF 'ACRI
QUIT
Begin DoDot:1
+6 IF '$DATA(ACRNWLVL)
DO SETSEC
+7 IF $DATA(ACRNWLVL)
DO KILLSEC
End DoDot:1
+8 QUIT
DELETE ;EP;TO DELETE USERS ACCESS TO ARMS INCLUDING ACCESS LEVEL, SECURITY
+1 ;KEYS AND ACCOUNT ACCESS
+2 IF '$DATA(^ACRPO(1,50,0))#2
SET ^ACRPO(1,50,0)="^9002199.4501P"
+3 SET X=DUZ
+4 SET DIC="^ACRPO(1,50,"
+5 SET DIC(0)="L"
+6 SET DIC("DR")=".02///NOW"
SET DA(1)=1
+7 DO FILE^ACRFDIC
+8 SET ACRAAUD=+Y
+9 DO WARNING^ACRFWARN
+10 WRITE !!,"The following procedure will delete all access this users has to ARMS."
+11 SET DIR(0)="YO"
+12 SET DIR("A")="Are you certain this is what you want to do"
+13 SET DIR("B")="NO"
+14 WRITE !
+15 DO DIR^ACRFDIC
+16 IF Y'=1
QUIT
+17 SET DA=ACRAAUD
+18 SET DIE="^ACRPO(1,50,"
+19 SET DR=".03////1;.04////"_ACRDUZ
+20 DO DIE^ACRFDIC
+21 SET ACRNWLVL=""
+22 SET ACRLVLDA=3
+23 WRITE !!,"ARMS related SECURITY KEYS being withdrawn."
+24 DO SETKILL
+25 WRITE !,"ARMS APPROVAL AUTHORITIES being deleted."
+26 SET ACRDA=0
+27 FOR
SET ACRDA=$ORDER(^ACRAPL("B",ACRDUZ,ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+28 SET DA=ACRDA
+29 SET DIK="^ACRAPL("
+30 DO DIK^ACRFDIC
End DoDot:1
+31 WRITE !,"Authority to sign as an ALTERNATE for someone else being deleted."
+32 SET ACRDA=0
+33 FOR
SET ACRDA=$ORDER(^ACRAPL("SEC",ACRDUZ,ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+34 SET DA=ACRDA
+35 SET DIE="^ACRAPL("
+36 FOR X=1:1:4
IF $PIECE(^ACRAPL(DA,"DT"),U,X)=ACRDUZ
Begin DoDot:2
+37 SET DR=$GET(DR)_X_"///@;"
End DoDot:2
+38 DO DIE^ACRFDIC
End DoDot:1
+39 WRITE !,"ARMS ACCESS LEVEL being deleted."
+40 SET ACRDA=0
+41 FOR
SET ACRDA=$ORDER(^ACRUAL("B",ACRDUZ,ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+42 SET DA=ACRDA
+43 SET DIK="^ACRUAL("
+44 DO DIK^ACRFDIC
End DoDot:1
+45 KILL ^ACRUAL("LVL",ACRDUZ)
+46 WRITE !,"ARMS DEPARTMENT ACCOUNT access being deleted."
+47 IF $DATA(^ACRPA("B",ACRDUZ))
Begin DoDot:1
+48 SET DA=$ORDER(^ACRPA("B",ACRDUZ,0))
+49 SET DIK="^ACRPA("
+50 IF DA
DO DIK^ACRFDIC
End DoDot:1
+51 SET ACRDA(1)=0
+52 FOR
SET ACRDA(1)=$ORDER(^ACRLOCB("SEC",ACRDUZ,ACRDA(1)))
IF 'ACRDA(1)
QUIT
Begin DoDot:1
+53 SET ACRDA=0
+54 FOR
SET ACRDA=$ORDER(^ACRLOCB("SEC",ACRDUZ,ACRDA(1),ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:2
+55 SET DA(1)=ACRDA(1)
+56 SET DA=ACRDA
+57 SET DIK="^ACRLOCB("_DA(1)_",""SC"","
+58 DO DIK^ACRFDIC
End DoDot:2
End DoDot:1
+59 FOR ACRXREF="CALLER","SSTAFF"
Begin DoDot:1
+60 SET ACRDA(1)=0
+61 FOR
SET ACRDA(1)=$ORDER(^ACRDOC(ACRXREF,ACRDUZ,ACRDA(1)))
IF 'ACRDA(1)
QUIT
Begin DoDot:2
+62 SET ACRDA=0
+63 FOR
SET ACRDA=$ORDER(^ACRDOC(ACRXREF,ACRDUZ,ACRDA(1),ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:3
+64 SET DA(1)=ACRDA(1)
+65 SET DA=ACRDA
+66 SET DIK="^ACRDOC("_DA(1)_",31,"
+67 DO DIK^ACRFDIC
End DoDot:3
End DoDot:2
End DoDot:1
+68 WRITE !!,"Withdrawal of ALL ARMS access has been completed."
+69 DO PAUSE^ACRFWARN
+70 QUIT
BPA ;EP;TO ASSIGN MULTIPLE BPA'S TO A USER
+1 NEW ACRJ,ACRDOCDA,ACRDOC0,ACRY,ACRX,ACRYY,ACRVDA
+2 SET ACRDOCDA=0
+3 FOR
SET ACRDOCDA=$ORDER(^ACRDOC("T",ACRDOCDA))
IF 'ACRDOCDA!$DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
Begin DoDot:1
+4 IF '$PIECE(^ACRDOC(ACRDOCDA,0),U,23)
QUIT
+5 IF $PIECE($GET(^ACRDOC(ACRDOCDA,15)),U,11)
IF $PIECE(^(15),U,11)<DT
QUIT
+6 SET ACRDOC0=^ACRDOC(ACRDOCDA,0)
+7 SET ACRJ=$GET(ACRJ)+1
+8 IF ACRJ=1
DO BPAH
+9 SET ACRJ(ACRJ)=ACRDOCDA
+10 SET ACRVDA=$PIECE(^ACRDOC(ACRDOCDA,"PO"),U,5)
+11 IF ACRVDA
SET ACRVDA=$PIECE($GET(^AUTTVNDR(ACRVDA,0)),U)
+12 IF '$TEST
SET ACRVDA="NOT STATED"
+13 WRITE !,ACRJ
+14 WRITE ?5,$PIECE(ACRDOC0,U)
+15 WRITE ?23,$PIECE(ACRDOC0,U,2)
+16 WRITE ?37,ACRVDA
+17 IF $Y+4>IOSL
Begin DoDot:2
+18 DO PAUSE^ACRFWARN
+19 DO BPAH
End DoDot:2
End DoDot:1
+20 IF $DATA(ACROUT)
QUIT
+21 IF '$GET(ACRJ)
Begin DoDot:1
+22 WRITE !!,"There are no active BPA's on file."
+23 DO PAUSE^ACRFWARN
End DoDot:1
QUIT
+24 KILL ACRQUIT
+25 SET DIR(0)="LO^1:"_ACRJ
+26 SET DIR("A")="Assign which BPA's to this user"
+27 WRITE !
+28 DO DIR^ACRFDIC
+29 IF $DATA(ACRQUIT)!+Y<1
QUIT
+30 SET ACRYY=Y
+31 FOR ACRJ=1:1
SET ACRX=$PIECE(ACRYY,",",ACRJ)
IF ACRX=""
QUIT
DO BPA1
+32 QUIT
BPA1 ;ADD USER AS CALLER TO A BPA
+1 IF '$DATA(ACRJ(ACRX))
QUIT
+2 SET (DA(1),ACRDOCDA)=ACRJ(ACRX)
+3 SET X=ACRDUZ
+4 SET DIC="^ACRDOC("_DA(1)_",6,"
+5 SET DIC(0)="L"
+6 DO FILE^ACRFDIC
+7 QUIT
BPAH ;HEADER FOR BPA LISTING
+1 WRITE @IOF
+2 WRITE !,"ACTIVE BLANKET PURCHASE AGREEMENTS"
+3 WRITE !,"NO."
+4 WRITE ?5,"REQUISITION NO."
+5 WRITE ?23,"PO NUMBER"
+6 WRITE ?37,"VENDOR/CONTRACTOR"
+7 WRITE !,"---"
+8 WRITE ?5,"---------------"
+9 WRITE ?23,"------------"
+10 WRITE ?37,"-----------------------------"
+11 QUIT
