source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYD.m@ 1259

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

initial load of WorldVistAEHR

File size: 7.0 KB
Line 
1RMPRPIYD ;HINES OIFO/ODJ - PIP RECONCILE - Pick HCPCS Item;3/8/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ; Get an Item - restrict choice to Location and HCPC
6ITEM(RMPRSTN,RMPRLCN,RMPR11,RMPREXC) ;
7 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRHCPC
8 S RMPRERR=0
9 S RMPREXC=""
10 I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX
11 I $G(RMPR11("HCPCS"))="" S RMPRERR=2 G ITEMX
12 S RMPR11("STATION")=RMPRSTN
13 S RMPR11("STATION IEN")=RMPRSTN
14 S RMPRHCPC=RMPR11("HCPCS")
15 S DIR(0)="FOA^1:50"
16 S DIR("A")="Enter Item to RECONCILE: "
17 S DIR("?")="^D QM^RMPRPIYD"
18 S DIR("??")="^D QQM^RMPRPIYD"
19ITEMA1 D ^DIR
20 I $D(DTOUT) S RMPREXC="T" G ITEMX
21 I $D(DIROUT) S RMPREXC="P" G ITEMX
22 I X=""!(X["^") S RMPREXC="^" G ITEMX
23 S RMPR11("IEN")=""
24 D LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11)
25 I RMPREXC="T" G ITEMX
26 I RMPREXC="P" G ITEMX
27 I RMPREXC="^" G ITEMA1
28 I RMPR11("IEN")="",$L(X)<3 G ITEMA1
29 I RMPR11("IEN")="" S RMPR11("DESCRIPTION")=X G ITEMX
30 G ITEMX
31ITEMX Q RMPRERR
32 ;
33 ; CHKN - Check an Item Number
34 ;
35 ; Inputs:
36 ; RMPR11 - array consisting of the following subscripts...
37 ; RMPR11("STATION") - Station ien (eg 499)
38 ; RMPR11("HCPCS") - HCPCS code (eg E0111)
39 ; RMPR11("ITEM") - HCPCS Item number (eg 1)
40 ;
41 ; Outputs:
42 ; RMPR11 - additional elements from 661.11 record if Item exists...
43 ; RMPR11("DESCRIPTION") - Item Description
44 ; RMPR11("HCPCS-ITEM") - Combined HCPCS Item code (eg E0111-1)
45 ; RMPR11("IEN") - ien of record
46 ; RMPR11("SOURCE") - Source (external format)
47 ; RMPR11("STATION") - Station Name (external format)
48 ; RMPR11("UNIT") - Unit of Measure (external format)
49 ; RMPR11("STATION IEN") - ien of input Station
50 ;
51 ; RMPRERR - exit condition (returned by function)
52 ; 0 - no erros
53 ; 1 - null station ien
54 ; 2 - null HCPCS code
55 ; 3 - HCPCS Item not valid number
56 ; 4 - Item does not exist
57 ; 99 - Problem with 661.11 file
58 ;
59CHKN(RMPR11) ;
60 N RMPRERR
61 S RMPRERR=0
62 I $G(RMPR11("STATION"))="" S RMPRERR=1 G CHKNX
63 S RMPR11("STATION IEN")=RMPR11("STATION")
64 I $G(RMPR11("HCPCS"))="" S RMPRERR=2 G CHKNX
65 I $G(RMPR11("ITEM"))'?1.N S RMPRERR=3 G CHKNX
66 I '$D(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"))) S RMPRERR=4 G CHKNX
67 S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
68 I RMPRERR S RMPRERR=99
69CHKNX Q RMPRERR
70 ;
71 ; CHKD - Check an Item Description
72 ;
73 ; Inputs:
74 ; RMPR11 - array consisting of the following subscripts...
75 ; RMPR11("STATION") - Station ien (eg 499)
76 ; RMPR11("HCPCS") - HCPCS code (eg E0111)
77 ; RMPR11("DESCRIPTION") - HCPCS Item Description
78 ;
79 ; Outputs:
80 ; RMPR11 - additional elements from 661.11 record if Item exists...
81 ; RMPR11("ITEM") - HCPCS Item number
82 ; RMPR11("HCPCS-ITEM") - Combined HCPCS Item code (eg E0111-1)
83 ; RMPR11("IEN") - ien of record
84 ; RMPR11("SOURCE") - Source (external format)
85 ; RMPR11("STATION") - Station Name (external format)
86 ; RMPR11("UNIT") - Unit of Measure (external format)
87 ; RMPR11("STATION IEN") - ien of input Station
88 ;
89 ; RMPRERR - exit condition (returned by function)
90 ; 0 - no erros
91 ; 1 - null station ien
92 ; 2 - null HCPCS code
93 ; 3 - null HCPCS Item Desc.
94 ; 4 - Item does not exist
95 ; 5 - Item does not exist, but there are items matching
96 ; the entered description text
97 ; 99 - Problem with 661.11 file
98 ;
99CHKD(RMPR11) ;
100 N RMPRERR,RMPRD
101 S RMPRERR=0
102 I $G(RMPR11("STATION"))="" S RMPRERR=1 G CHKDX
103 S RMPR11("STATION IEN")=RMPR11("STATION")
104 I $G(RMPR11("HCPCS"))="" S RMPRERR=2 G CHKDX
105 I $G(RMPR11("DESCRIPTION"))="" S RMPRERR=3 G CHKDX
106 I '$D(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPR11("DESCRIPTION"),RMPR11("HCPCS"))) D G CHKDX
107 . S RMPRERR=4
108 . S RMPRD=RMPR11("DESCRIPTION")
109 . S RMPRD=$O(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPRD))
110 . I $E(RMPRD,1,$L(RMPR11("DESCRIPTION")))=RMPR11("DESCRIPTION") S RMPRERR=5
111 . Q
112 S RMPR11("IEN")=$O(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPR11("DESCRIPTION"),RMPR11("HCPCS"),""))
113 S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
114 I RMPRERR S RMPRERR=99
115CHKDX Q RMPRERR
116 ;
117 ; Prompt if adding a new HCPCS Item
118OKADD(RMPR11,RMPRYN,RMPREXC) ;
119 N DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
120 S RMPREXC=""
121 S DIR(0)="Y"
122 S DIR("A")="Are you adding '"_RMPR11("DESCRIPTION")_"' as a new ITEM for this HCPCS"
123 D ^DIR
124 I $D(DTOUT) S RMPREXC="T" G ADDNMX
125 I $D(DIROUT) S RMPREXC="P" G ADDNMX
126 I X=""!(X["^") S RMPREXC="^" G ADDNMX
127 S RMPRYN="N" S:Y RMPRYN="Y"
128 S RMPREXC=""
129ADDNMX Q
130 ;
131 ; Single ? Help
132QM W ?4,"Answer with ITEM NUMBER or DESCRIPTION:"
133 D QM2
134 Q
135QQM D QM2
136 W !!?8,"You may enter a new ITEM, if you wish"
137 W !?8,"This is an Item or Appliance under PSAS HCPCS kept by local site in"
138 W !?8,"Prosthetics Inventory module."
139 Q
140QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
141 S RMPRMAX=19,RMPRLIN=0
142 S RMPREXC=""
143 S DIR(0)="EA"
144 S DIR("A")="'^' TO STOP: "
145 S RMPRI=""
146QM2A S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
147 I RMPRI="" G QM2X
148 K RMPR
149 S RMPR("STATION")=RMPRSTN
150 S RMPR("HCPCS")=RMPRHCPC
151 S RMPR("ITEM")=RMPRI
152 S RMPRERR=$$GET^RMPRPIX1(.RMPR)
153 W !?3,RMPRI,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
154 S RMPRLIN=RMPRLIN+1
155 I RMPRLIN'<RMPRMAX G QM2B
156 G QM2A
157QM2B D ^DIR
158 I $D(DTOUT) S RMPREXC="T" G QM2X
159 I $D(DIROUT) S RMPREXC="P" G QM2X
160 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G QM2X
161QM2X Q
162LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11) ;
163 N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
164 N RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA
165 S RMPREXC=""
166 S RMPRMAX=19
167 S RMPREXMA=""
168 I $D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT)) D
169 . S RMPREXMA=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,""))
170 . Q
171 S RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
172LIKEA1 K RMPRA S RMPRLIN=0
173LIKEA S RMPRGBL=$Q(@RMPRGBL)
174 I RMPRGBL="" G LIKEB
175 I $QS(RMPRGBL,1)'=661.11 G LIKEB
176 I $QS(RMPRGBL,2)'="ASHD" G LIKEB
177 I $QS(RMPRGBL,3)'=RMPRSTN G LIKEB
178 I $QS(RMPRGBL,4)'=RMPRHCPC G LIKEB
179 I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
180 K RMPR
181 S RMPR("IEN")=$QS(RMPRGBL,6)
182 S RMPRERR=$$GET^RMPRPIX1(.RMPR)
183 I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"))) G LIKEA
184 I RMPREXMA'="" D
185 . S RMPREXMA("IEN")=RMPREXMA
186 . S RMPRERR=$$GET^RMPRPIX1(.RMPREXMA)
187 . S RMPRLIN=RMPRLIN+1
188 . W !?4,$J(RMPRLIN,2),?9,RMPREXMA("DESCRIPTION")
189 . S RMPRA(RMPRLIN)=RMPREXMA("IEN")
190 . K RMPREXMA
191 . S RMPREXMA=""
192 . Q
193 S RMPRLIN=RMPRLIN+1
194 W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5)
195 S RMPRA(RMPRLIN)=$QS(RMPRGBL,6)
196 I RMPRLIN'<RMPRMAX G LIKEB
197 G LIKEA
198LIKEB I RMPRLIN=0 D G LIKEX
199 . Q:RMPREXMA=""
200 . S RMPR11("IEN")=RMPREXMA
201 . S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
202 . Q
203 S DIR(0)="NAO^1:"_RMPRLIN_": "
204 S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
205 D ^DIR
206 W !
207 I $D(DTOUT) S RMPREXC="T" G LIKEX
208 I $D(DIROUT) S RMPREXC="P" G LIKEX
209 I X="" S RMPREXC="" G LIKEX
210 I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
211 K RMPR11
212 S RMPR11("IEN")=RMPRA(X)
213 S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
214LIKEX Q
Note: See TracBrowser for help on using the repository browser.