source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYI.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1RMPRPIYI ;HINCIO/RVD-ISSUE FROM STOCK ;6/16/04 08:18
2 ;;3.0;PROSTHETICS;**61,128**;Feb 09, 1996
3 ; RVD #61 - phase IIIa of PIP
4 ;
5 S RMPR699("AMIS GROUPER")=""
6 S (RMPRG,RMPRF)="" D HOME^%ZIS W @IOF
7 I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EXIT^RMPRPIYJ
8 I $D(RMPRDFN),$D(^TMP($J,"RMPRPCE")) D LINK^RMPRS
9 I $D(RMPRDFN),'$D(^TMP($J,"RMPRPCE")) G EXIT^RMPRPIYJ
10 K ^TMP($J,"RMPRPCE")
11 D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT^RMPRPIYJ
12VIEW ;
13 N RMPRBAC1,RMDES,RMITQTY
14 S (RSTCK,RMPRBAC1)=1 D ^RMPRPAT K RMPRBAC1
15 I $D(RMPRKILL)!($D(DTOUT)) W $C(7),!,"Deleted..." G EXIT^RMPRPIYJ
16 S CK="W:$D(DUOUT) @IOF,!!!?28,$C(7),""Deleted..."" G EXIT^RMPRPIYJ"
17 S CK2="W @IOF,!!!?28,$C(7),""Deleted..."" H 2"
18 S CK1="W $C(7),!,""Timed-Out, Deleted..."" G EXIT^RMPRPIYJ"
19 S R3("D")=""
20 ;
21RES ;ENTRY POINT TO ADD ADDITIONAL ITEMS FOR ISSUE FROM STOCK
22 Q:$G(RMPRDFN)<1
23 K DA,DD,DIC,PRC,X,Y,RMSO,RMQTY,RMDAHC,RMLACO,RMITDA,RMHCOLD,RMPRVEN
24 K RMPR11IS,RMPR5SA,RMPR6SA
25 S (R1(1),R1(0),R3("D"),R4("D"),R1("AM"),RMPRI("AMS"),R1("D"),RMLOC)=""
26 S RMLODES=""
27 S (RMLOCOLD,R1,RMIT,RMHCNEW,RMHCOLD,RMITDESC,RMITIEN,R1(2))="",REDIT=0
28 S R1(0)=DT_U_RMPRDFN_U_DT,$P(R1(0),U,10)=RMPR("STA"),$P(R1(0),U,27)=DUZ
29 ;
301 ;ENTRY POINT TO EDIT ITEM ON ISSUE FROM STOCK
31 S (RMHCNEW,RMHCOLD)=$P(R1(1),U,4),RMLOCOLD=RMLOC,RMITOLD=RMIT
32 K RQUIT S RMHCFLG=0
33 W @IOF,!?30,RMPRNAM,!
34 W:$G(REDIT) !!,"Editing a Stock Item!!!"
35 W:'$G(REDIT) !!,"Entering a Stock Item!!!"
36 ;
37TRAN ;TYPE OF TRANSACTION
38 W !
39 ;S DIR(0)="660,2"
40 K DIR
41 S:$P(R1(0),U,4)?.E&($P(R3("D"),U,4)'="") DIR("B")=$P(R3("D"),U,4)
42 S DIR(0)="SO^I:INITIAL ISSUE;X:REPAIR;R:REPLACE;S:SPARE"
43 S DIR("A")="TYPE OF TRANSACTION"
44 D ^DIR
45 I (Y=""),($P(R3("D"),U,4)="") G ^RMPRPIYI
46 I $P(R3("D"),U,4)'=""&($D(DUOUT)) G LIST^RMPRPIYJ
47 I $D(DTOUT) X CK1 Q
48 I $D(DUOUT) G ^RMPRPIYI
49 S $P(R1(0),U,4)=Y K DIR
50 S $P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
51 ;
52PCAT ;
53 S DIR(0)="660,62" S:$P(R1("AM"),U,3)?1N.N DIR("B")=$P(R4("D"),U,3)
54 D ^DIR I $P(R1("AM"),U,3)'=""&($D(DUOUT)) G LIST^RMPRPIYJ
55 I $D(DTOUT) X CK1 Q
56 I $D(DUOUT) X CK2 G ^RMPRPIYI
57 S $P(R1("AM"),U,3)=Y,$P(R4("D"),U,3)=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"") K DIR
58 I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2
59 ;
60SPE I Y=4 S DIR(0)="660,63" S:$P(R1("AM"),U,4)?1N.N DIR("B")=$P(R4("D"),U,4) D ^DIR I $D(DTOUT) X CK1 Q
61 I $G(REDIT)&($D(DUOUT)) G LIST^RMPRPIYJ
62 I $D(DUOUT) X CK2 G ^RMPRPIYI
63 I $P(R1("AM"),U,3)=4 S $P(R1("AM"),U,4)=Y,$P(R4("D"),U,4)=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
64 ;
65 ; prompt for and scan barcode label
66 ; if scan is successful then all vars will be set and go to Edit prompt
672 I $G(REDIT),$D(RMPR11I) M RMPR11IS=RMPR11I,RMPR5SA=RMPR5,RMPR6SA=RMPR6
68 W ! D SCAN^RMPRPIYS
69 I $P(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P")) G LIST^RMPRPIYJ
70 I (RMPREXC="^"),$G(REDIT) G LIST^RMPRPIYJ
71 I RMPREXC="^" X CK2 G ^RMPRPIYI
72 I RMPREXC="P" G PCAT
73 I RMPREXC="T" X CK1 Q
74 I RMPRBARC="",$G(REDIT) M RMPR11I=RMPR11IS,RMPR5=RMPR5SA,RMPR6=RMPR6SA G ^RMPRPIYJ
75 I RMPRBARC="" G 2
76 D HCPCS3^RMPRPIY1
77 G ^RMPRPIYJ
78HCPCS ;HCPCS code
79 S (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
80 S RMPRHCPC="" I $D(RMHCPC) S RMPRHCPC=RMHCPC
81 D HCPCS^RMPRPIY1(RMPR("STA"),RMPRHCPC,.RMPR1,.RMPR11,.RMPREXC)
82 I RMPREXC="T" X CK1 Q
83 I RMPREXC="P" G 2
84 I $G(REDIT),(RMPREXC="^") G LIST^RMPRPIYJ
85 I RMPREXC="^" X CK2 G ^RMPRPIYI
86 W !
87 S RMITNO=RMPR11("ITEM")
88 S RMHCPC=RMPR1("HCPCS")
89 S (RMHCNEW,RMDAHC,RMHCDA)=RMPR1("IEN")
90 S RDESC=RMPR1("SHORT DESC")
91 K RMPR11I
92 S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
93 I RMPR11I("ITEM MASTER IEN")="" D G 2
94 . W !,"This item is not associated with an IFCAP Item.",!
95 . W "Please use the Edit Inventory option before trying to issue this item."
96 . W !
97 . Q
98 I '$D(^RMPR(661.7,"XSHIDS",RMPR("STA"),RMHCPC,RMITNO)) D G 2
99 . W !,"This HCPCS-ITEM is not associated with any Location."
100 . W !,"Please update your inventory!!.",!
101 . W !
102 . Q
103 S $P(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
104 S $P(R1(0),U,8)=$G(RMPR11("UNIT"))
105 S $P(R3("D"),U,6)=RMPR11("ITEM MASTER")
106 ;check for location if multiple then ask for LOCATION
107 S RMLCNT=0
108 F I=0:0 S I=$O(^RMPR(661.7,"XSLHIDS",RMPR("STA"),I)) Q:I'>0 I $D(^(I,RMHCPC)) S RMLCNT=RMLCNT+1,(RMPR5("IEN"),RMLOC)=I
109 I RMLCNT<2 G ITEM
110 ;
111ASKLOC ;ask for location
112 K DIC,Y,X,RQUIT,RMPR5
113 S DZ="??",D="B"
114 S DIC("S")="I ($P(^RMPR(661.5,+Y,0),U,2)=RMPR(""STA"")),($P(^(0),U,4)=""A""),($D(^RMPR(661.7,""XSLHIDS"",RMPR(""STA""),+Y,RMHCPC,RMITNO)))"
115 S:RMLOCOLD'="" DIC("B")=RMLOCOLD
116 S DIC="^RMPR(661.5,",DIC(0)="AEQMN"
117 S DIC("A")="Enter Pros Location: " D MIX^DIC1
118 I $G(REDIT)&$D(DUOUT) G LIST^RMPRPIYJ
119 I $D(DUOUT) G 2^RMPRPIYI
120 I $D(DTOUT) X CK1 Q
121 I X="" W !,"This is a mandatory field!!!",! G ASKLOC
122 S RMLOC=+Y
123 S RMPR5("IEN")=RMLOC
124 G:'$D(^RMPR(661.5,RMLOC,0)) ASKLOC
125 ;
126ITEM ;PSAS Item details.
127 K RMPR11I
128 S RMCHCK=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
129 I RMCHCK W !,"*** ERROR IN API RMPRPIX1 !!!!",! X CK1 Q
130 S RMIT=RMPR11("HCPCS-ITEM")
131 S $P(R1(2),U,1)=RMIT S $P(R1(2),U,2)=RMPR11("DESCRIPTION")
132 I RMDAHC=RMHCOLD S DIR("B")=$G(RMIT)
133 ;
134 ;call stock record in 661.7
135 S RMR("STATION IEN")=RMPR("STA")
136 S RMR("LOCATION IEN")=RMLOC
137 S RMR("HCPCS")=RMHCPC
138 S RMR("ITEM")=RMPR11("ITEM")
139 S RMR("VENDOR IEN")=$P(R1(0),U,9)
140 S RMCHCK=$$STOCK^RMPRPIUE(.RMR)
141 I RMCHCK W !,"*** ERROR IN API RMPRPIUE !!!!",! X CK1 Q
142 S (RMITDES,RMDES)=RMIT K DIC("B"),DIC("S")
143 S RMUBA=RMR("QOH")
144 I RMUBA<1 D LOWBA G 2
145 ;
146 I $D(RMLOC),$D(RMHCDA) S RMSO=RMPR11I("SOURCE")
147 I $D(RMSO),RMSO="" D MESSO G 2
148 S:$D(RMSO) $P(R1(0),U,14)=RMSO
149 S $P(R3("D"),U,14)=$S(RMSO="C":"COMMERCIAL",RMSO="V":"VA",1:"")
150 I $P(R1(1),U,4)'="",$D(DUOUT) G LIST^RMPRPIYJ
151 ;I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G 2
152 I $G(RMLOC),$G(RMHCDA) S RMPRUCST=RMR("UNIT COST")
153 I '$G(RMPRUCST) D MESSI G 2
154 S:$G(REDIT) $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7),$P(R3("D"),U,16)=RMPRUCST*$P(R1(0),U,7)
155 K DIC
156 ;
157CPT ;ask for CPT Modifier
158 D CPT^RMPRPIYS(RMDAHC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660)
159 I RMPREXC="T" X CK1 Q
160 I RMPREXC="^" G 2
161 I RMPREXC="P" G 2
162 ;
163VEN ;vendor
164 ;call routine RMPRPIYV for vendor from file 661.6.
165 S $P(R1(1),U,4)=RMDAHC,$P(R1(0),U,22)=$P(^RMPR(661.1,RMDAHC,0),U,4)
166 ;If there is only one vendor use it as a default.
167 K RMPRVEN
168 S RMERR=$$STOCK^RMPRPIUV(.RMR,.RMPRVEN)
169 I RMERR W !,"*** ERROR IN API RMPRPIUV !!!!",! X CK1 Q
170 I RMPRVEN=1 S DIC("B")=$O(RMPRVEN(0))
171 I $G(REDIT) S DIC("B")=$P(R1(0),U,9)
172 S DIC(0)="AEQM"
173 S DIC("A")="VENDOR: ",DIC=440,DIC("S")="I $D(RMPRVEN(+Y))"
174 D ^DIC I $P(R3("D"),U,9)'=""&$D(DUOUT) G LIST^RMPRPIYJ
175 I $D(DTOUT) X CK1 Q
176 I $D(DUOUT) G 2
177 I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G VEN
178 S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIC,Y,X
179 G ^RMPRPIYJ
180 ;
181 ;
182MESSI ;print message if COST is not defined in the inventory (661.5)
183 S:'$D(RMIT) RMIT=""
184 W !!,"***ITEM COST is not define @:"
185 W !," PSAS Item = ",RMIT
186 W !," Location = ",$P($G(^RMPR(661.5,RMLOC,0)),U,1)
187 W !,"***Fix your inventory or use a different PSAS ITEM!!",!!
188 Q
189 ;
190MESSO ;print message if SOURCE is not defined in the inventory (661.11)
191 W !!,"***PSAS ITEM has no SOURCE at this location..."
192 W !,"***Fix your inventory or use a different PSAS ITEM!!",!!
193 Q
194 ;
195INACT ;print message if HCPCS is inactive.
196 W !!,"*** You have selected an INACTIVE HCPCS..."
197 W !,"*** Please REMOVE this HCPCS from inventory..."
198 W !,"*** And use a different HCPCS!!!",!
199 Q
200 ;
201LOWBA ;print message if inventory balance is low.
202 S:'$D(RMUBA) RMUBA="" S:'$D(RMIT) RMIT=""
203 W !!,"*** PSAS Item ",RMIT," balance is = ",RMUBA
204 W !,"*** You are unable to use this PSAS ITEM..."
205 W !,"*** Please use a different HCPCS or PSAS Item !!!!",!
206 Q
207 ;
208LKP ;print a message if PSAS HCPCS not in PIP or invalid HCPCS.
209 Q:'$G(RMF)!(X=" ")
210 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
211 K RX
212 I $D(RSTCK),$D(^RMPR(661.7,"XSHIDS",RMPR("STA"),X)) S RX=1
213 I '$D(RSTCK),$D(^RMPR(661.11,"ASHD",RMPR("STA"),X)) S RX=1
214 I '$G(RX),$D(^RMPR(661.1,"B",X)) D EN^DDIOL("*** Only PSAS HCPCS in PIP can be accessed. Please verify your Location and PSAS HCPCS!!","","!!")
215 K RX
216 Q
Note: See TracBrowser for help on using the repository browser.