source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYC.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: 5.3 KB
Line 
1RMPRPIYC ;HINCIO/ODJ - PIP HCPCS Prompt utilities ;3/8/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ;***** HCPCS - Prompt for HCPCS called by reconciliation option
6 ; (RMPRPIYA)
7HCPCS(RMPR5,RMPR1,RMPR11,RMPREXC) ;
8 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN,RMPRLCN,RMPR1N
9 N RMPRYN
10 S DIR("A")="Select HCPCS to RECONCILE: "
11 S RMPRERR=0
12 S RMPREXC=""
13 S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
14 S RMPRSTN=RMPR5("STATION")
15 S RMPRLCN=RMPR5("IEN")
16 S DIR(0)="FOA"
17 S DIR("?")="^D QM^RMPRPIYC"
18 S DIR("??")="^D QM2^RMPRPIYC"
19HCPCS1 K RMPR1N D ^DIR
20 I $D(DTOUT) S RMPREXC="T" G HCPCSX
21 I $D(DIROUT) S RMPREXC="P" G HCPCSX
22 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
23 D LIKE^RMPRPIYC(RMPRSTN,X,.RMPREXC,.RMPR1N,.RMPR11)
24 I RMPREXC'="" G HCPCS1
25 I $G(RMPR1N("IEN"))'="" G HCPCSU
26 G HCPCS1
27HCPCSU K RMPR1 M RMPR1=RMPR1N
28HCPCSX Q RMPRERR
29 ;
30 ;***** QM - Single ? Help
31 ; RMPRSTN required (see below QM2)
32 ;
33QM D QM1 ; ask if want to list HCPCS
34 I RMPREXC'="" G QMX
35 I RMPRYN="N" G QMX
36 D QM2 ;list HCPCS
37QMX Q
38QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT
39 ;S DIR("A",1)=" Answer with PSAS HCPCS, or SHORT NAME, or CPT, or SYNONYM, or"
40 ;S DIR("A",2)=" DESCRIPTION"
41 S DIR("A",1)="This response must be a number."
42 S DIR("A")="Do you want the entire list of PSAS HCPCS in inventory "
43 S DIR("?")="^D QM1H^RMPRPIYC"
44 S DIR(0)="YO"
45 D ^DIR
46 I $D(DTOUT) S RMPREXC="T" G QM1X
47 I $D(DIROUT) S RMPREXC="P" G QM1X
48 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G QM1X
49 S RMPRYN="N" S:Y RMPRYN="Y"
50 S RMPREXC=""
51QM1X Q
52QM1H S %A="V",X="^"
53 Q
54 ;
55 ;***** QM2 - List HCPCS associated with a Location
56 ; called from a ?? help or Yes to the
57 ; question in the ? help.
58 ;
59 ; requires RMPRSTN - Station ien
60 ;
61QM2 D LIKE(RMPRSTN,"",.RMPREXC,.RMPR1N,.RMPR11)
62 I $G(RMPR1N("IEN"))'="" D QM1H
63QM2X Q
64 ;
65 ; ***** LIKE
66 ; Handle the various inputs from a HCPCS prompt where HCPCS is
67 ; being selected from PIP as opposed to the general
68 ; HCPCS file 661.1
69 ; This version uses the 661.11 file so any HCPCS that has been
70 ; used in inventory can be selected.
71 ;
72 ; Inputs:
73 ; RMPRSTN - Station ien
74 ; RMPRTXT - Text entered at HCPCS prompt (cannot be null)
75 ;
76 ; Outputs:
77 ; RMPREXC - exit condition
78 ; RMPR1 - array of HCPCS data from 661.1 file
79 ; RMPR1("IEN") - ien of HCPCS in 661.1 (null if not found)
80 ; RMPR1("HCPCS") - HCPCS code
81 ; RMPR1("SHORT DESC") - HCPCS short description
82 ; RMPR11 - array of Inventory Item data from 661.11 file
83 ;
84LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR1,RMPR11) ;
85 N RMPRMAX,RMPRLIN,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA,RMPRH
86 N RMPRERR,RMPRHA,RMPR1N,RMPRH2,RMPRHTXT,RMPRITXT
87 S RMPREXC=""
88 S (RMPR1("IEN"),RMPR11("IEN"))=""
89 S RMPRMAX=5
90 S RMPRLIN=0
91 S RMPRHTXT=$P(RMPRTXT,"-",1)
92 S RMPRITXT=""
93 I RMPRHTXT="" S RMPRH="" G LIKEA1
94 ;
95 ; Check for exact match and skip selection if it is
96 I $D(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHTXT)) D G LIKEG
97 . S RMPRITXT=$P(RMPRTXT,"-",2)
98 . Q
99 ;
100 ; Check for unique partial match and skip selection if it is
101 S RMPRH=$O(^RMPR(661.11,"ASHI",RMPRSTN,RMPRTXT))
102 I $E(RMPRH,1,$L(RMPRTXT))'=RMPRTXT G LIKEC
103 S RMPRH2=$O(^RMPR(661.11,"ASHI",RMPRSTN,RMPRH))
104 I $E(RMPRH2,1,$L(RMPRTXT))'=RMPRTXT D G LIKEG
105 . W $E(RMPRH,1+$L(RMPRTXT),$L(RMPRH))
106 . S RMPRHTXT=RMPRH
107 . Q
108 G LIKEA3
109 ;
110 ; List partial matches
111LIKEA1 S RMPRH=$O(^RMPR(661.11,"ASHI",RMPRSTN,RMPRH))
112 I RMPRH="" G:'RMPRLIN LIKEX G LIKEB
113 I $E(RMPRH,1,$L(RMPRTXT))'=RMPRTXT K DIR("A",1) G LIKEB
114LIKEA2 I RMPRLIN,'(RMPRLIN#RMPRMAX) D G LIKEB
115 . S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
116 . Q
117LIKEA3 K RMPRHA S RMPRHA("HCPCS")=RMPRH
118 S RMPRERR=$$HPACT^RMPRPIX1(.RMPRHA)
119 S RMPRLIN=RMPRLIN+1
120 W !?4,$J(RMPRLIN,2),?9,RMPRH,?19,RMPRHA("SHORT DESC")
121 S RMPRA(RMPRLIN)=RMPRH
122 G LIKEA1
123LIKEB S DIR(0)="NAO"
124 S DIR("A")="Choose 1 - "_RMPRLIN_" : "
125 ;S DIR("?")="^D LIKEH^RMPRPIYC"
126 D ^DIR
127 I $D(DTOUT) S RMPREXC="T" G LIKEX
128 I $D(DIROUT) S RMPREXC="P" G LIKEX
129 I X="",$D(DIR("A",1)) S RMPREXC="" K DIR("A",1) G LIKEA3
130 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G LIKEX
131 I $G(X),'$D(RMPRA(X)) W !!,"Please enter a number within the range." G LIKEB
132 I '$D(RMPRA(X)) W !!,"This response must be a number." G LIKEB
133 S RMPRHTXT=RMPRA(X)
134 ;
135 ; read in HCPCS and possibly Item as well
136LIKEG K RMPR1
137 S RMPR1("HCPCS")=RMPRHTXT
138 S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
139 I RMPRITXT'="",$D(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHTXT,RMPRITXT)) D
140 . K RMPR11
141 . S RMPR11("STATION")=RMPRSTN
142 . S RMPR11("HCPCS")=RMPRHTXT
143 . S RMPR11("ITEM")=RMPRITXT
144 . S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
145 . Q
146 G LIKEX
147 ;
148 ; If can't find HCPCS in PIP files use old DIC lookup
149LIKEC D HCDIC(RMPRSTN,RMPRTXT,.RMPR1N)
150 I $G(RMPR1N("IEN"))'="" K RMPR1 M RMPR1=RMPR1N
151 ;
152 ;exit
153LIKEX Q
154LIKEH D QM,QM1H
155 Q
156 ;
157 ; Call DIC to match on text if not a HCPCS code
158HCDIC(RMPRSTN,RMPRTXT,RMPR1) ;
159 N X,Y,DA,DIC
160 S DIC="^RMPR(661.1,"
161 S DIC(0)="EMQ"
162 S DIC("S")="I $$HCMAT^RMPRPIYC()"
163 S X=RMPRTXT
164 D ^DIC
165 I +Y'>0!($D(DTOUT))!($D(DUOUT)) G HCDICX
166 I $P(Y,"^",2)'="",$D(^RMPR(661.4,"XSHIL",RMPRSTN,$P(Y,"^",2))) D
167 . S RMPR1("HCPCS")=$P(Y,"^",2)
168 . S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
169 . Q
170HCDICX Q
171 ;
172 ;***** HCMAT - extrinsic called from DIC call to screen out
173 ; HCPCS not associated with PIP
174 ; RMPRSTN (station ien) must be set
175HCMAT() ;
176 N RMPRMAT
177 S RMPRMAT=0
178 I $D(^RMPR(661.4,"XSHIL",RMPRSTN,$P(^RMPR(661.1,Y,0),"^",1))) S RMPRMAT=1
179HCMATX Q RMPRMAT
Note: See TracBrowser for help on using the repository browser.