source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPSSQA.m@ 1078

Last change on this file since 1078 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1PRCPSSQA ;WISC/CC-Enter/edit privileged secondary IP users ;04/01
2V ;;5.1;IFCAP;**24**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6AC ;I 'application coordinator W "You do not have access to this option" Q
7 I '$$KEY^PRCPUREP("PRCPAQOH",DUZ) D EN^DDIOL("You are not authorized to give staff access to replace quantities.") Q
8 ;
9 N D,D0,D1,DA,DIC,DIDEL,DIE,DIK,DLAYGO,DQ,DR,INVPT,PRCF,PRCPPRIV,USER,X,Y,%
10 ; ask site
11 S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q
12 I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q
13 ;
14 ; ask inventory point
15 I '$D(PRCP("DPTYPE")) S PRCP("DPTYPE")="S"
16 S DIC="^PRCP(445,",DIC(0)="AEQMOZ"
17 S DIC("S")="I +^(0)=PRC(""SITE"")"
18 S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)"
19 S DIC("A")="Select Secondary Inventory Point: "
20 S D="C",PRCPPRIV=1
21 D IX^DIC K PRCPPRIV,DIC
22 I Y<0 K PRC,PRCP Q
23 S INVPT=Y Q:'$G(INVPT)
24 I PRCP("DPTYPE")'="S" Q
25 I '$D(^PRCP(445,+INVPT,0)) Q
26 I $P($G(^PRCP(445,+INVPT,5)),"^",1)']"" D EN^DDIOL("This secondary is not linked to a supply station") Q
27 ;
28 L +^PRCP(445,+INVPT,8):3 I $T=0 D EN^DDIOL("The authorized user file is busy. Please try again later.") Q
29 ;
30 ; purge inappropriate users
31 S USER=0
32 F S USER=$O(^PRCP(445,+INVPT,8,USER)) Q:'+USER D
33 . S X=USER D CHK(+INVPT,.X) I X="" D
34 . . D EN^DDIOL("Removing "_$P(^VA(200,USER,0),"^")_".....")
35 . . S DIK="^PRCP(445,"_+INVPT_",8,",DA(1)=+INVPT,DA=+USER D ^DIK K DIK
36 . . W "User DELETED !"
37 ;
38USERS ; ask users
39 I '$D(^PRCP(445,+INVPT,0)) D EN^DDIOL("This inventory point is not on file") Q
40 I '$D(^PRCP(445,+INVPT,8,0)) S ^(0)="^445.026P^^"
41 S DIC(0)="AEMQO"
42 S DA=+INVPT,(DIC,DIE)="^PRCP(445,",DIDEL=445,DR=26,PRCPPRIV=1
43 D ^DIE K PRCPPRIV,DIC,DIE
44 Q
45 ;
46 ;
47 ; invoked from this routine and input transform of .01 field in file 445.026
48CHK(INVPT,USER) ; verify user has proper qualifications
49 ; INVPT is the ien to file 445 (Inventory Point)
50 ; USER is the ien to file 200
51 ;
52 I $P($G(^VA(200,USER,0)),"^",11),$P(^(0),"^",11)<DT D EN^DDIOL("You cannot ADD a terminated user.") S USER="" Q
53 I '$D(^PRCP(445,INVPT,4,USER)) D EN^DDIOL("User has no access to this inventory point. Contact the manager.") S USER="" Q
54 I '$$KEY^PRCPUREP("PRCP2 MGRKEY",USER) S USER="" D EN^DDIOL("User needs the PRCP2 MGRKEY.") Q
55 I '$$KEY^PRCPUREP("PRCPSSQOH",USER) S USER="" D EN^DDIOL("User needs the PRCPSSQOH key.") Q
56 ;
57EXIT L -^PRCP(445,+INVPT,8)
58 Q
Note: See TracBrowser for help on using the repository browser.