PRCPSSQA ;WISC/CC-Enter/edit privileged secondary IP users ;04/01
V ;;5.1;IFCAP;**24**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
AC ;I 'application coordinator W "You do not have access to this option" Q
I '$$KEY^PRCPUREP("PRCPAQOH",DUZ) D EN^DDIOL("You are not authorized to give staff access to replace quantities.") Q
;
N D,D0,D1,DA,DIC,DIDEL,DIE,DIK,DLAYGO,DQ,DR,INVPT,PRCF,PRCPPRIV,USER,X,Y,%
; ask site
S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q
I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q
;
; ask inventory point
I '$D(PRCP("DPTYPE")) S PRCP("DPTYPE")="S"
S DIC="^PRCP(445,",DIC(0)="AEQMOZ"
S DIC("S")="I +^(0)=PRC(""SITE"")"
S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)"
S DIC("A")="Select Secondary Inventory Point: "
S D="C",PRCPPRIV=1
D IX^DIC K PRCPPRIV,DIC
I Y<0 K PRC,PRCP Q
S INVPT=Y Q:'$G(INVPT)
I PRCP("DPTYPE")'="S" Q
I '$D(^PRCP(445,+INVPT,0)) Q
I $P($G(^PRCP(445,+INVPT,5)),"^",1)']"" D EN^DDIOL("This secondary is not linked to a supply station") Q
;
L +^PRCP(445,+INVPT,8):3 I $T=0 D EN^DDIOL("The authorized user file is busy. Please try again later.") Q
;
; purge inappropriate users
S USER=0
F S USER=$O(^PRCP(445,+INVPT,8,USER)) Q:'+USER D
. S X=USER D CHK(+INVPT,.X) I X="" D
. . D EN^DDIOL("Removing "_$P(^VA(200,USER,0),"^")_".....")
. . S DIK="^PRCP(445,"_+INVPT_",8,",DA(1)=+INVPT,DA=+USER D ^DIK K DIK
. . W "User DELETED !"
;
USERS ; ask users
I '$D(^PRCP(445,+INVPT,0)) D EN^DDIOL("This inventory point is not on file") Q
I '$D(^PRCP(445,+INVPT,8,0)) S ^(0)="^445.026P^^"
S DIC(0)="AEMQO"
S DA=+INVPT,(DIC,DIE)="^PRCP(445,",DIDEL=445,DR=26,PRCPPRIV=1
D ^DIE K PRCPPRIV,DIC,DIE
Q
;
;
; invoked from this routine and input transform of .01 field in file 445.026
CHK(INVPT,USER) ; verify user has proper qualifications
; INVPT is the ien to file 445 (Inventory Point)
; USER is the ien to file 200
;
I $P($G(^VA(200,USER,0)),"^",11),$P(^(0),"^",11)<DT D EN^DDIOL("You cannot ADD a terminated user.") S USER="" Q
I '$D(^PRCP(445,INVPT,4,USER)) D EN^DDIOL("User has no access to this inventory point. Contact the manager.") S USER="" Q
I '$$KEY^PRCPUREP("PRCP2 MGRKEY",USER) S USER="" D EN^DDIOL("User needs the PRCP2 MGRKEY.") Q
I '$$KEY^PRCPUREP("PRCPSSQOH",USER) S USER="" D EN^DDIOL("User needs the PRCPSSQOH key.") Q
;
EXIT L -^PRCP(445,+INVPT,8)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSSQA 2508 printed Dec 13, 2024@02:16:03 Page 2
PRCPSSQA ;WISC/CC-Enter/edit privileged secondary IP users ;04/01
V ;;5.1;IFCAP;**24**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
AC ;I 'application coordinator W "You do not have access to this option" Q
+1 IF '$$KEY^PRCPUREP("PRCPAQOH",DUZ)
DO EN^DDIOL("You are not authorized to give staff access to replace quantities.")
QUIT
+2 ;
+3 NEW D,D0,D1,DA,DIC,DIDEL,DIE,DIK,DLAYGO,DQ,DR,INVPT,PRCF,PRCPPRIV,USER,X,Y,%
+4 ; ask site
+5 SET %=0
FOR I="FY","PARAM","PER","QTR","SITE"
IF '+$GET(PRC(I))
SET %=1
QUIT
+6 IF %
SET PRCF("X")="S"
DO ^PRCFSITE
IF '+$GET(PRC("SITE"))
KILL PRC,PRCP
QUIT
+7 ;
+8 ; ask inventory point
+9 IF '$DATA(PRCP("DPTYPE"))
SET PRCP("DPTYPE")="S"
+10 SET DIC="^PRCP(445,"
SET DIC(0)="AEQMOZ"
+11 SET DIC("S")="I +^(0)=PRC(""SITE"")"
+12 SET DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)"
+13 SET DIC("A")="Select Secondary Inventory Point: "
+14 SET D="C"
SET PRCPPRIV=1
+15 DO IX^DIC
KILL PRCPPRIV,DIC
+16 IF Y<0
KILL PRC,PRCP
QUIT
+17 SET INVPT=Y
if '$GET(INVPT)
QUIT
+18 IF PRCP("DPTYPE")'="S"
QUIT
+19 IF '$DATA(^PRCP(445,+INVPT,0))
QUIT
+20 IF $PIECE($GET(^PRCP(445,+INVPT,5)),"^",1)']""
DO EN^DDIOL("This secondary is not linked to a supply station")
QUIT
+21 ;
+22 LOCK +^PRCP(445,+INVPT,8):3
IF $TEST=0
DO EN^DDIOL("The authorized user file is busy. Please try again later.")
QUIT
+23 ;
+24 ; purge inappropriate users
+25 SET USER=0
+26 FOR
SET USER=$ORDER(^PRCP(445,+INVPT,8,USER))
if '+USER
QUIT
Begin DoDot:1
+27 SET X=USER
DO CHK(+INVPT,.X)
IF X=""
Begin DoDot:2
+28 DO EN^DDIOL("Removing "_$PIECE(^VA(200,USER,0),"^")_".....")
+29 SET DIK="^PRCP(445,"_+INVPT_",8,"
SET DA(1)=+INVPT
SET DA=+USER
DO ^DIK
KILL DIK
+30 WRITE "User DELETED !"
End DoDot:2
End DoDot:1
+31 ;
USERS ; ask users
+1 IF '$DATA(^PRCP(445,+INVPT,0))
DO EN^DDIOL("This inventory point is not on file")
QUIT
+2 IF '$DATA(^PRCP(445,+INVPT,8,0))
SET ^(0)="^445.026P^^"
+3 SET DIC(0)="AEMQO"
+4 SET DA=+INVPT
SET (DIC,DIE)="^PRCP(445,"
SET DIDEL=445
SET DR=26
SET PRCPPRIV=1
+5 DO ^DIE
KILL PRCPPRIV,DIC,DIE
+6 QUIT
+7 ;
+8 ;
+9 ; invoked from this routine and input transform of .01 field in file 445.026
CHK(INVPT,USER) ; verify user has proper qualifications
+1 ; INVPT is the ien to file 445 (Inventory Point)
+2 ; USER is the ien to file 200
+3 ;
+4 IF $PIECE($GET(^VA(200,USER,0)),"^",11)
IF $PIECE(^(0),"^",11)<DT
DO EN^DDIOL("You cannot ADD a terminated user.")
SET USER=""
QUIT
+5 IF '$DATA(^PRCP(445,INVPT,4,USER))
DO EN^DDIOL("User has no access to this inventory point. Contact the manager.")
SET USER=""
QUIT
+6 IF '$$KEY^PRCPUREP("PRCP2 MGRKEY",USER)
SET USER=""
DO EN^DDIOL("User needs the PRCP2 MGRKEY.")
QUIT
+7 IF '$$KEY^PRCPUREP("PRCPSSQOH",USER)
SET USER=""
DO EN^DDIOL("User needs the PRCPSSQOH key.")
QUIT
+8 ;
EXIT LOCK -^PRCP(445,+INVPT,8)
+1 QUIT
