source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAODI.m@ 1261

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

initial load of WorldVistAEHR
File size: 6.7 KB
RevLine 
[613]1PRCPAODI ;WOIFO/CC-enter/edit On-Demand users ; 2/8/07 4:15pm
2 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;
6ENT ;
7 I '$$KEY^PRCPUREP("PRCPODI",DUZ) D EN^DDIOL("You are not authorized to make managers On-Demand Users.") Q
8 ;
9 N %,D,DIC,PRCF,PRCP,PRCPIN,PRCPINPT,PRCPMAN,PRCPNAME,X,Y
10 ;
11 ; Prompt for user
12USER S DIC="^VA(200,",DIC(0)="AEQMOZ",DIC("A")="INVENTORY POINT MANAGER: ",D="B"
13 D IX^DIC
14 K DIC,D I Y<0 Q
15 S PRCPMAN=+Y
16 L +^PRCPAODI(PRCPMAN):0 I $T=0 D EN^DDIOL(">>File in Use. Please try again later.") W ! G USER
17 ;
18 ; Verify user is active
19 S X=$$GET1^DIQ(200,PRCPMAN_",","9.2","I") ; termination date
20 I X,X'>DT D EN^DDIOL(">>This user has been terminated and cannot be selected.") W ! D EXIT G USER
21 ; Verify user has primary and/or secondary manager key
22 S PRCPMAN(1)=0,PRCPMAN(2)=0
23 S PRCPMAN(1)=$$KEY^PRCPUREP("PRCP MGRKEY",PRCPMAN)
24 S PRCPMAN(2)=$$KEY^PRCPUREP("PRCP2 MGRKEY",PRCPMAN)
25 I 'PRCPMAN(1),'PRCPMAN(2),'$O(^PRCP(445,"AJ",PRCPMAN,"")) D EN^DDIOL(">>User must be a manager of a Primary or Secondary Inventory Point") W ! D EXIT G USER
26 ;
27 ; Display ODI access to primary points
28 S PRCPNAME=$$GET1^DIQ(200,PRCPMAN_",",".01")
29 W ! D CHKPM
30 ;
31 ; Prompt for Site
32 S %=0 F I="FY","PARAM","PER","QTR","SITE" S %=1 Q
33 I % S PRCF("X")="S" D ^PRCFSITE I '$G(PRC("SITE")) K PRC,PRCP G EXIT
34 ;
35 ; Prompt for inventory point
36IP S DIC="^PRCP(445,",DIC(0)="AEQMOZ"
37 S DIC("S")="I +^(0)=PRC(""SITE"")"
38 S DIC("A")="SELECT INVENTORY POINT: "
39 S D="C",PRCPPRIV=1
40 D IX^DIC K PRCPPRIV,D,DIC
41 I Y<0 G EXIT
42 S PRCP("I")=Y Q:'$G(PRCP("I"))
43 S PRCPINPT=$P(PRCP("I"),"^",2)
44 S PRCP("DPTYPE")=$P(^PRCP(445,+PRCP("I"),0),U,3)
45 I PRCP("DPTYPE")="W" D EN^DDIOL(" >>The warehouse has no On-Demand items - needs no On-Demand User.") W ! G IP
46 ;
47 D INIT(+PRCP("I"))
48 ;
49 ;Process Users that don't qualify
50 I 'PRCPMAN(3) D D:PRCP("DPTYPE")="P" CHKDP G IP
51 . D EN^DDIOL(">>"_PRCPNAME_" is not a "_PRCPMAN(3)_" of this inventory point")
52 . ; if user is not in node 9, give message - not added
53 . I 'PRCPIN D EN^DDIOL(" and therefore cannot be an On-Demand User") W !
54 . ; delete if user is set up in node 9 - show 'deleted'
55 . I PRCPIN D Q
56 . . D DEL(+PRCP("I"),PRCPIN) ; Delete entry
57 . . D EN^DDIOL(">>Removed as On-Demand User for: "_PRCPINPT) W !
58 ;
59 ; If user is already On-Demand, ask if they should be removed???
60 I PRCPIN D G IP
61 . D ASK(2,+PRCP("I"),PRCPMAN)
62 . I PRCP("DPTYPE")="P" D CHKDP
63 ;
64 ; Ask if user should be added to IP's list of On-Demand users
65 D ASK(1,+PRCP("I"),PRCPMAN)
66 I PRCP("DPTYPE")="P" D CHKDP
67 G IP
68 ;
69 Q
70 ;
71 ; Does user qualify?
72INIT(PRCPINP) ;PRCPINP=inventory point being checked
73 S PRCPMAN(3)=1 ; assume user is OK
74 ; Verify user has manager key for type of IP selected
75 I PRCP("DPTYPE")="P",'PRCPMAN(1) S PRCPMAN(3)="manager"
76 I PRCP("DPTYPE")="S",'PRCPMAN(2) S PRCPMAN(3)="manager"
77 ; Verify user is a user of that IP
78 I '$D(^PRCP(445,+PRCPINP,4,PRCPMAN)) D
79 . I PRCPMAN(3)=1 S PRCPMAN(3)="user" Q
80 . S PRCPMAN(3)="manager nor user"
81 ;
82 ; set flag if user is already in list
83 S PRCPIN=""
84 S PRCPIN=$O(^PRCP(445,+PRCPINP,9,"B",PRCPMAN,PRCPIN))
85 Q
86 ;
87DEL(PRCPINP,PRCPUSER) ; delete On-Demand authorization
88 ; also called from PRCPXTRM for user termination from VISTA
89 ;
90 ; PRCPINP inventory point from which user is being removed
91 ; PRCPUSER ien of user in the list
92 ;
93 N DA,DIK
94 S DIK="^PRCP(445,"_PRCPINP_",9,",DA(1)=+PRCPINP,DA=+PRCPUSER D ^DIK
95 Q
96 ;
97ADD(PRCPINP,PRCPUSER) ; Add user to On-Demand Users
98 ;
99 ; PRCPINP
100 ; PRCPUSER
101 ;
102 ; save user in On-Demand Users list
103 N PRCPIEN,PRCPARRY,PRCPREC
104 S PRCPREC(1)=+PRCPMAN ; dinumed file
105 S PRCPIEN="+1,"_+PRCPINP_","
106 S PRCPARRY(445.027,PRCPIEN,.01)=+PRCPMAN
107 D UPDATE^DIE("","PRCPARRY","PRCPREC")
108 Q
109 ;
110 ; Find all distribution points
111CHKDP N PRCPIN,PRCPIP,PRCPDA,PRCPDX,PRCPNM,FLAG,X
112 D EN^DDIOL("Checking distribution points for "_PRCPINPT_"...") W !
113 S PRCPIP=0,FLAG=1
114 S PRCP("DPTYPE")="S"
115 F S PRCPIP=$O(^PRCP(445,+PRCP("I"),2,PRCPIP)) Q:'+PRCPIP D
116 . S PRCPNM=$$INVNAME^PRCPUX1(PRCPIP),X=$P(PRCPNM,"-",2,99)
117 . I $E(X,1,12)="***INACTIVE_" Q ; IP not active
118 . I $P($G(^PRCP(445,PRCPIP,0)),"^",3)'="S" Q
119 . S FLAG=0 D INIT(PRCPIP)
120 . I 'PRCPMAN(3) D Q
121 . . I PRCPIN S PRCPDX(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN Q
122 . S PRCPDA(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN
123 ;
124 I FLAG=1 D EN^DDIOL("There are no distribution points on this primary") W ! Q
125 ;
126 ; check for IPs where the user is On-Demand
127 I $O(PRCPDA("")) D
128 . N PRCPD,X S PRCPD=""
129 . D EN^DDIOL(PRCPNAME_" is a User and Manager on the following Inventory Points:") W !
130 . F S PRCPD=$O(PRCPDA(PRCPD)) Q:'PRCPD D
131 . . S X=$P(PRCPDA(PRCPD),"^",2)
132 . . S X=X_$E(" ",$L(X),35)
133 . . S X=X_$S($P(PRCPDA(PRCPD),"^",3):"On-Demand User",1:"Not On-Demand User")
134 . . D EN^DDIOL(X)
135 . W !
136 ;
137 I $O(PRCPDX("")) D REMOVE(.PRCPDX)
138 ;
139 I '$O(PRCPDA("")),'$O(PRCPDX("")) D W !
140 . I PRCPMAN(2)'=1 D EN^DDIOL(PRCPNAME_" is not a manager of any distribution point") Q
141 . D EN^DDIOL(PRCPNAME_" is not a user of the distribution points found")
142 ;
143ASK(PRCPOPT,PRCPIPT,PRCPUSER) ; Should user's authorization be removed?
144 ;
145 ; PRCPOPT 1 if add , 2 if delete
146 ; PRCPIPT Inventory Point ien
147 ; PRCPUSER DUZ of User
148 ;
149 N CNT,DIR,DIRUT,DIROUT,DTOUT,DUOUT,I,X,PRCPDP
150 S CNT=1,PRCPDP="",X=""
151 S DIR(0)="Y"
152 S DIR("A")="Add as an On-Demand User"
153 I PRCPOPT=2 S DIR("A")="Remove as an On-Demand User"
154 D ^DIR K DIR
155 I Y=0!$D(DTOUT)!$D(DUOUT) S X=" <<not added>>" S:PRCPOPT=2 X=" <<not removed>>" D EN^DDIOL(X) W ! Q
156 ; IF YES, LOOP THROUGH AND DELETE USER FROM ALL
157 I Y=1 D
158 . I PRCPOPT=2 D
159 . . D DEL(PRCPIPT,PRCPIN)
160 . . D EN^DDIOL(" <<Removed>>") W !
161 . I PRCPOPT=1 D
162 . . D ADD(PRCPIPT,PRCPUSER)
163 . . I $D(^TMP("DIERR",$J)) D EN^DDIOL(" <<Unable to Add - possible system problems>>") W ! Q
164 . . D EN^DDIOL(" <<Added>>") W !
165 Q
166 ;
167REMOVE(PRCPDX) ; Auto remove ODI authorization
168 I $O(PRCPDX("")) D
169 . N PRCPD,X S PRCPD=""
170 . D EN^DDIOL("On-Demand Access was removed from the following:") W !
171 . F S PRCPD=$O(PRCPDX(PRCPD)) Q:'PRCPD D
172 . . D DEL(PRCPD,$P(PRCPDX(PRCPD),"^",3))
173 . . S X=$P(PRCPDX(PRCPD),"^",2) D EN^DDIOL(X)
174 . W !
175 Q
176 ;
177CHKPM ; DISPLAY IPs User can access
178 N PRCPIN,PRCPIP,FLAG,PRCPDX,PRCPNM
179 S PRCPIP="",FLAG="",PRCP("DPTYPE")="P"
180 F S PRCPIP=$O(^PRCP(445,"AC","P",PRCPIP)) Q:'PRCPIP D
181 . I '$O(^PRCP(445,PRCPIP,9,"B",PRCPMAN,"")) Q
182 . D INIT(PRCPIP)
183 . S PRCPNM=$$INVNAME^PRCPUX1(PRCPIP),X=$P(PRCPNM,"-",2,99)
184 . I $E(X,1,12)="***INACTIVE_" Q ; IP not active
185 . I 'PRCPMAN(3) D Q
186 . . I PRCPIN S PRCPDX(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN Q
187 . I 'FLAG S FLAG=1 D EN^DDIOL(PRCPNAME_" is an On-Demand User in these Primary Inventory Points:")
188 . D EN^DDIOL(PRCPNM)
189 I $O(PRCPDX("")) W ! D REMOVE(.PRCPDX)
190 I 'FLAG D EN^DDIOL(">>"_PRCPNAME_" is not an On-Demand User in any Primary Inventory Point")
191 W !
192 Q
193 ;
194EXIT L -^PRCPAODI(PRCPMAN)
195 Q
Note: See TracBrowser for help on using the repository browser.