source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY8.m@ 1005

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1RMPRPIY8 ;HINCIO/ODJ - Pick HCPCS Item ;3/8/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ; ? Help
6QM W ?4,"Answer with ITEM, or NUMBER, or DESCRIPTION"
7 W !?3,"Choose from:"
8 D QM2
9 Q
10 ;
11 ; ?? Help
12QQM W !?3,"Choose from:"
13 D QM2
14 Q
15QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
16 S RMPRMAX=5,RMPRLIN=0
17 S RMPREXC=""
18 S DIR(0)="EA"
19 S DIR("A")="'^' TO STOP: "
20 S RMPRI=""
21QM2A S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
22 I RMPRI="" G QM2X
23 K RMPR
24 S RMPR("STATION")=RMPRSTN
25 S RMPR("HCPCS")=RMPRHCPC
26 S RMPR("ITEM")=RMPRI
27 S RMPRERR=$$GET^RMPRPIX1(.RMPR)
28 S RMPRLIN=RMPRLIN+1
29 W !?3,RMPRLIN,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
30 I RMPRLIN'<RMPRMAX G QM2B
31 G QM2A
32QM2B D ^DIR
33 I $D(DTOUT) S RMPREXC="T" G QM2X
34 I $D(DIROUT) S RMPREXC="P" G QM2X
35 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G QM2X
36QM2X Q
37 ;
38 ;
39LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11,RMPR4) ;
40 N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
41 N RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA,RMPRI,RMPRIEN,RMPRH
42 S RMPREXC=""
43 S RMPRMAX=5
44 S RMPR4("IEN")=""
45 ;
46 ; NUMBER entered
47 ; loop on index until count=entered number
48 I RMPRTXT?1.N D G LIKEX
49 . S RMPRLIN=0
50 . S RMPRI=""
51 . F S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI)) Q:RMPRI="" D Q:RMPR4("IEN")'=""
52 .. S RMPRLIN=RMPRLIN+1
53 .. I RMPRLIN=RMPRTXT D
54 ... S RMPRIEN=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI,""))
55 ... S RMPR4("IEN")=RMPRIEN
56 ... K RMPR11
57 ... S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
58 ... S RMPR11("STATION")=RMPRSTN
59 ... S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
60 ... Q
61 .. Q
62 . Q
63 ;
64 ; ITEM entered (HCPCS-ITEM form eg. L5000-3)
65 S RMPRH=$P(RMPRTXT,"-",1)
66 I $E(RMPRHCPC,1,$L(RMPRH))=RMPRH G LIKEH1 ;use 661.4 index
67 ;
68 ; DESCRIPTION entered - use 661.11 index
69 S RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
70LIKEA1 K RMPRA S RMPRLIN=0
71LIKEA S RMPRGBL=$Q(@RMPRGBL)
72 I RMPRGBL="" G LIKEB
73 I $QS(RMPRGBL,1)'=661.11 G LIKEB
74 I $QS(RMPRGBL,2)'="ASHD" G LIKEB
75 I $QS(RMPRGBL,3)'=RMPRSTN G LIKEB
76 I $QS(RMPRGBL,4)'=RMPRHCPC G LIKEB
77 I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
78 K RMPR
79 S RMPR("IEN")=$QS(RMPRGBL,6)
80 S RMPRERR=$$GET^RMPRPIX1(.RMPR) ;read 661.11 file
81 I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"))) G LIKEA ;item not in selected location
82 S RMPRLIN=RMPRLIN+1
83 W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5),?40,RMPR("HCPCS-ITEM")
84 S RMPRIEN=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"),""))
85 S RMPRA(RMPRLIN)=RMPRIEN
86 I RMPRLIN'<RMPRMAX G LIKEB
87 G LIKEA
88LIKEB I RMPRLIN=0 G LIKEX
89 S DIR(0)="NAO^1:"_RMPRLIN_": "
90 S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
91 D ^DIR
92 W !
93 I $D(DTOUT) S RMPREXC="T" G LIKEX
94 I $D(DIROUT) S RMPREXC="P" G LIKEX
95 I X="" S RMPREXC="" G LIKEA
96 I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
97 K RMPR11
98 S RMPR4("IEN")=RMPRA(X)
99 S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
100 S RMPR11("STATION")=RMPRSTN
101 S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
102 G LIKEX
103 ;
104 ;
105LIKEH1 S RMPRI=$P(RMPRTXT,"-",2)
106 I RMPRI'="",$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI)) D G LIKEH9A
107 . S RMPR4("IEN")=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI,""))
108 . Q
109 S RMPRGBL="^RMPR(661.4,"_"""ASLHI"","_RMPRSTN_","_RMPRLCN_","""_RMPRH_""")"
110 K RMPRA S RMPRLIN=0
111LIKEH S RMPRGBL=$Q(@RMPRGBL)
112 I RMPRGBL="" G LIKEH9
113 I $QS(RMPRGBL,1)'=661.4 G LIKEH9
114 I $QS(RMPRGBL,2)'="ASLHI" G LIKEH9
115 I $QS(RMPRGBL,3)'=RMPRSTN G LIKEH9
116 I $QS(RMPRGBL,4)'=RMPRLCN G LIKEH9
117 I $QS(RMPRGBL,5)'=RMPRHCPC G LIKEH
118 S RMPR("IEN")=$QS(RMPRGBL,7)
119 K RMPR11
120 S RMPRERR=$$GET^RMPRPIX4(.RMPR,.RMPR11,)
121 S RMPR11("STATION")=RMPRSTN
122 S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
123 S RMPRLIN=RMPRLIN+1
124 W !?4,$J(RMPRLIN,2),?9,RMPR11("HCPCS-ITEM"),?23,RMPR11("DESCRIPTION")
125 S RMPRA(RMPRLIN)=$QS(RMPRGBL,7)
126 I RMPRLIN'<RMPRMAX G LIKEH9
127 G LIKEH
128LIKEH9 I RMPRLIN=0 G LIKEX
129 S DIR(0)="NAO^1:"_RMPRLIN_": "
130 S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
131 D ^DIR
132 W !
133 I $D(DTOUT) S RMPREXC="T" G LIKEX
134 I $D(DIROUT) S RMPREXC="P" G LIKEX
135 I X="" S RMPREXC="" G LIKEH
136 I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
137 S RMPR4("IEN")=RMPRA(X)
138LIKEH9A K RMPR11
139 S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
140 S RMPR11("STATION")=RMPRSTN
141 S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
142 G LIKEX
143 ;exit
144LIKEX Q
Note: See TracBrowser for help on using the repository browser.