source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYH.m@ 1361

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1RMPRPIYH ;HINCIO/ODJ - PIP Stock Receipt Prompts ;3/8/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ;***** LOCNM - Prompt for receiving location
6 ; must be in 661.5 and active
7LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
8 N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
9 D NOW^%DTC S RMPRTDT=X ;today's date
10 S RMPREXC=""
11 S RMPRERR=0
12 S DIR(0)="FOA"
13 S DIR("A")="Enter Receiving Location: "
14 S DIR("?")="^D QM^RMPRPIYB"
15 S DIR("??")="^D QM2^RMPRPIYB"
16LOCNM1 D ^DIR
17 I $D(DTOUT) S RMPREXC="T" G LOCNMX
18 I $D(DIROUT) S RMPREXC="P" G LOCNMX
19 I X=""!(X["^") S RMPREXC="^" G LOCNMX
20 K RMPR5
21 S RMPR5("STATION")=RMPRSTN
22 S RMPR5("STATION IEN")=RMPRSTN
23 D LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5)
24 I RMPREXC'="" G LOCNM1
25 I $G(RMPR5("IEN"))="" D G LOCNM1
26 . W !,"Please enter a valid Location"
27 . Q
28 ;
29 ; exit
30LOCNMX Q RMPRERR
31 ;
32 ; Get OK
33OK(RMPRYN,RMPREXC) ;
34 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
35 S RMPREXC=""
36 S DIR("A")=" ...OK"
37 S DIR("B")="Yes"
38 S DIR(0)="Y"
39 D ^DIR
40 I $D(DTOUT) S RMPREXC="T" G OKX
41 I $D(DIROUT) S RMPREXC="P" G OKX
42 I X=""!(X["^") S RMPREXC="^" G OKX
43 S RMPRYN="N" S:Y RMPRYN="Y"
44OKX Q
45 ;
46 ;***** HCPCS - Get a HCPCS code from 661.4
47HCPCS(RMPR5,RMPR1,RMPREXC) ;
48 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN,RMPRLCN,RMPR1N
49 S DIR("A")="Select HCPCS to RECEIVE: "
50 S RMPRERR=0
51 S RMPREXC=""
52 S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
53 S RMPRSTN=RMPR5("STATION")
54 S RMPRLCN=RMPR5("IEN")
55 S DIR(0)="FOA"
56 S DIR("?")="^D QM^RMPRPIYC"
57 S DIR("??")="^D QM2^RMPRPIYC"
58HCPCS1 K RMPR1N D ^DIR
59 I $D(DTOUT) S RMPREXC="T" G HCPCSX
60 I $D(DIROUT) S RMPREXC="P" G HCPCSX
61 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
62 D LIKE^RMPRPIYC(RMPRSTN,RMPRLCN,X,.RMPREXC,.RMPR1N)
63 I RMPREXC'="" G HCPCS1
64 I $G(RMPR1N("IEN"))'="" G HCPCSU
65 G HCPCS1
66HCPCSU K RMPR1 M RMPR1=RMPR1N
67HCPCSX Q RMPRERR
68 ;
69 ;***** ITEM - Get an Item - restrict choice to Location and HCPC
70ITEM(RMPRSTN,RMPRLCN,RMPRHCPC,RMPR11,RMPR4,RMPREXC) ;
71 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRYN
72 S RMPRERR=0
73 S RMPREXC=""
74 I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX
75 I $G(RMPRLCN)="" S RMPRERR=2 G ITEMX
76 I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX
77 K RMPR11,RMPR4
78 S DIR(0)="FOA^1:50"
79 S DIR("A")="Enter Item to RECEIVE: "
80 S DIR("?")="^D QM^RMPRPIY8"
81 S DIR("??")="^D QQM^RMPRPIY8"
82ITEMA1 D ^DIR
83 I $D(DTOUT) S RMPREXC="T" G ITEMX
84 I $D(DIROUT) S RMPREXC="P" G ITEMX
85 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ITEMX
86 D LIKE^RMPRPIY8(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11,.RMPR4)
87 I RMPREXC="T" G ITEMX
88 I RMPREXC="P" G ITEMX
89 I RMPREXC="^" G ITEMA1
90 I RMPR4("IEN")="" D G ITEMA1
91 . W !,"Cannot locate ITEM with this sequence NUMBER"
92 . Q
93 W " ",RMPR11("HCPCS-ITEM")," ",RMPR11("DESCRIPTION")
94 D OK(.RMPRYN,.RMPREXC)
95 I RMPRYN'="Y" G ITEMA1
96 G ITEMX
97ITEMX Q RMPRERR
98 ;
99 ; Get Quantity
100QTY(RMPRQTY,RMPREXC) ;
101 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
102 S RMPRQTY=$G(RMPRQTY)
103 S RMPRERR=0
104 S DIR(0)="NA^1:99999:0"
105 S DIR("A")="Quantity to Receive: "
106 S:RMPRQTY'="" DIR("B")=RMPRQTY
107 D ^DIR
108 I $D(DTOUT) S RMPREXC="T" G QTYX
109 I $D(DIROUT) S RMPREXC="P" G QTYX
110 I X=""!(X["^") S RMPREXC="^" G QTYX
111 S RMPRQTY=Y
112QTYX Q RMPRERR
113 ;
114 ; Get total $ value
115TVAL(RMPRTVAL,RMPREXC) ;
116 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
117 S RMPRTVAL=$G(RMPRTVAL)
118 S RMPRERR=0
119 S DIR(0)="NOA^0:999999:2"
120 S DIR("A")="Total Cost of Item: "
121 D ^DIR
122 I $D(DTOUT) S RMPREXC="T" G TVALX
123 I $D(DIROUT) S RMPREXC="P" G TVALX
124 I X["^" S RMPREXC="^" G TVALX
125 I X="" G TVALX
126 S RMPRTVAL=Y
127TVALX Q RMPRERR
Note: See TracBrowser for help on using the repository browser.