source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYL.m@ 1764

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

initial load of FOIAVistA 6/30/08 version

File size: 4.8 KB
Line 
1RMPRPIYL ;HINES OIFO/ODJ - PIP - DL - DEACTIVATE LOCATION ;9/19/02 08:22
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ;***** DL - Replaces DL option in old PIP (cf RMPR5NDL)
6 ; Callable from VISTA menu, no vars required other than
7 ; global VISTA vars (DUZ, etc)
8 ;
9DL N RMPRERR,RMPRSTN,RMPRLCN,RMPREXC,RMPR5,RMPR5U,DIR,X,Y,DA
10 I '$D(DUZ) W !,"VISTA User parameter (DUZ) does not exist, can't continue with this option" R RMPRERR:3 G DLX
11 ;
12 ;***** STN - prompt for Site/Station
13STN S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
14 I RMPRERR G DLX
15 I RMPREXC'="" G DLX
16 ;
17 ;***** LOCN - prompt for Location
18LOCN W @IOF,!!,"Deactivate an Inventory Location.....",!
19 W !,"This option requires the electronic signatures of 2 users"
20 W !,"holding the RMPRMANAGER key to be entered before a location"
21 W !,"will be deactivated.",!
22 ;
23 D LOCNM^RMPRPIY7(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
24 I RMPREXC="T"!(RMPREXC="^") G DLX
25 I RMPREXC="P" G STN
26 ;
27 ; display stock position and get esigs. to confirm deactivation
28CHK D STOCK(RMPRSTN("IEN"),RMPR5("IEN")) ;display stock position
29OSIG I '$$GETO(DUZ) G DLX ;get other signature, exit if not OK
30ESIG I $D(XQUSER) D
31 . W !!,XQUSER," please..."
32 . Q
33 E D
34 . W !!,$$GETUSR^RMPRPIU0(DUZ)," please..."
35 . Q
36 D SIG^XUSESIG G:X1="" DLX ;get electronic sig. of main user
37DEL ;delete a location
38 S DIR(0)="Y",DIR("B")="N"
39 W !
40 S DIR("A")="Are you sure you want to DEACTIVATE this LOCATION (Y/N) "
41 D ^DIR
42 I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !,"Nothing Deactivated.." H 2 G DLX
43 ;
44ZERO ;***** zeroed all item in a location.
45 ;
46 N RI,RH,RD,RV,R6
47 S RS=RMPRSTN("IEN")
48 S RL=RMPR5("IEN")
49 S RH=""
50 F S RH=$O(^RMPR(661.7,"XSLHIDS",RS,RL,RH)) Q:RH="" F RI=0:0 S RI=$O(^RMPR(661.7,"XSLHIDS",RS,RL,RH,RI)) Q:RI'>0 F RD=0:0 S RD=$O(^RMPR(661.7,"XSLHIDS",RS,RL,RH,RI,RD)) Q:RD'>0 D
51 .S RMPR11("STATION")=RS
52 .S RMPR11("STATION IEN")=RS
53 .S RMPR6("QUANTITY")=0
54 .Q:'$G(RD)!(RD="")
55 .Q:'$D(^RMPR(661.6,"ASLD",RS,RL,RD))
56 .S R6=$O(^RMPR(661.6,"ASLD",RS,RL,RD,0)) I $D(^RMPR(661.6,R6,0)) S RV=$P(^RMPR(661.6,R6,0),U,12)
57 .Q:'$G(RV)
58 .S RMPR6("VENDOR")=RV
59 .S RMPR6("VENDOR IEN")=RV
60 .S RMPR11("HCPCS")=RH,RMPR11("ITEM")=RI,RMPR5("IEN")=RL
61 .S RMPRERR=$$REC^RMPRPIU9(.RMPR6,.RMPR11,.RMPR5)
62 .I RMPRERR=1 W !!,"*** ERROR IN API RMPRPIU9 ***",!
63 .K R6,RV
64 ;
65 ;***** TRANS - Now deactivate the location
66TRANS K RMPR5U
67 S RMPR5U("IEN")=RMPR5("IEN")
68 S RMPR5U("STATUS")="I"
69 D NOW^%DTC
70 S RMPR5U("STATUS DATE")=$P(%,".",1)
71 S RMPRERR=$$UPD^RMPRPIX5(.RMPR5U)
72 I 'RMPRERR D
73 . W !,"Location is deactivated" H 2
74 . Q
75 E D
76 . W !,"There was a problem deactivating the location" H 2
77 . Q
78DLX D KILL^XUSCLEAN
79 Q
80 ;
81 ;***** STOCK - get and display the total number of items
82 ; quantity and cost at a location
83 ;
84STOCK(RMPRSTN,RMPRLCN) ;
85 N RMPRQ,RMPRH,RMPRI,RMPRERR,RMPRIC,RMPRTQ,RMPRTC
86 S RMPRIC=0 ;item count
87 S RMPRTC=0 ;total cost
88 S RMPRTQ=0 ;total quantity
89 S RMPRH=""
90 F S RMPRH=$O(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRH)) Q:RMPRH="" D
91 . S RMPRI=""
92 . F S RMPRI=$O(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRH,RMPRI)) Q:RMPRI="" D
93 .. K RMPRQ
94 .. S RMPRQ("STATION IEN")=RMPRSTN
95 .. S RMPRQ("LOCATION IEN")=RMPRLCN
96 .. S RMPRQ("HCPCS")=RMPRH
97 .. S RMPRQ("ITEM")=RMPRI
98 .. S RMPRQ("VENDOR IEN")=""
99 .. S RMPRERR=$$STOCK^RMPRPIUE(.RMPRQ)
100 .. S RMPRIC=RMPRIC+1
101 .. S RMPRTQ=RMPRTQ+RMPRQ("QOH")
102 .. S RMPRTC=RMPRTC+(RMPRQ("QOH")*RMPRQ("UNIT COST"))
103 .. Q
104 . Q
105 W !,"The above location contains "_RMPRIC_" types of items"
106 I RMPRIC=0 D
107 . W "."
108 . Q
109 E D
110 . W ", ",!,"with a total quantity of ",RMPRTQ
111 . W " and cost of $",RMPRTC,"."
112 . Q
113 W !
114 Q
115 ;
116 ;***** GETO - prompt for a 2nd user's electronic signature
117GETO(RMPRDUZ) ;
118 N RMPRMGR,RMPROK,RMPRUSR1,RMPRUSR2,X,X1,DUZ,RMPRKEYS
119 W !!,"Pease ask another user with the RMPRMANAGER key to"
120 W !,"enter their user name and electronic signature.",!
121 S RMPROK=0
122 S RMPRKEYS("RMPRMANAGER")=""
123 S RMPRUSR1("DUZ")=RMPRDUZ
124 I $$GETUSR2(.RMPRUSR2,.RMPRKEYS,.RMPRUSR1)'="" G GETOKX
125 S DUZ=RMPRUSR2("DUZ")
126 W !,RMPRUSR2("NAME")," please..."
127 D SIG^XUSESIG I X1="" G GETOKX
128 S RMPROK=1
129GETOKX Q RMPROK
130 ;
131 ; Get 2nd User and ensure they have RMPRMANAGER key
132GETUSR2(RMPRUSR2,RMPRKEYS,RMPRUSR1) ;
133 N DIC,X,Y,DLAYGO,DTOUT,DUOUT,RMPREXC,RMPRKEY,DUZ
134 S DUZ=RMPRUSR1("DUZ")
135USR2E K RMPRUSR2
136 S DIC="^VA(200,"
137 S DIC(0)="ABEQ"
138 S DIC("A")="Enter user name of 2nd manager:"
139 D ^DIC
140 I Y=-1 S RMPREXC="^" G USR2X
141 S RMPRUSR2("DUZ")=$P(Y,U,1)
142 ;
143 ; User 2 can't be same as user 1
144 I RMPRUSR2("DUZ")=RMPRUSR1("DUZ") D G USR2E
145 . W !,"The 2nd manager must be different to the manager logged on."
146 . Q
147 ;
148 ; User 2 must have defined security keys
149 S RMPRKEY=""
150 F S RMPRKEY=$O(RMPRKEYS(RMPRKEY)) Q:RMPRKEY="" Q:$D(^XUSEC(RMPRKEY,RMPRUSR2("DUZ")))
151 I RMPRKEY="" D G USR2E
152 . W !,"The 2nd manager does not have the correct security key set up."
153 . Q
154 ;
155 ; User 2 verified
156 S RMPRUSR2("NAME")=$P(Y,U,2)
157 S RMPREXC=""
158USR2X Q RMPREXC
Note: See TracBrowser for help on using the repository browser.