source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPI4.m@ 1006

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

initial load of WorldVistAEHR
File size: 7.7 KB
RevLine 
[613]1IBJPI4 ;DAOU/BHS - IBJP IIV MOST POPULAR PAYER LIST SCREEN ;25-NOV-2003
2 ;;2.0;INTEGRATED BILLING;**271**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; IIV - Insurance Identification and Verification Interface
6 ;
7 Q ; Must be called at a tag
8 ;
9ADD ; Add entry
10 N IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBIEN,IBI
11 ; Refresh screen
12 S VALMBCK="R"
13 ; Find highest pos in list (1-10)
14 S IBCT=+$O(^TMP($J,"IBJPI3-LIST",11),-1)
15 ; Quit if count = 10
16 I IBCT=10 D Q
17 . D EN^DDIOL("Cannot add entry as all ten positions are populated!")
18 . D EN^DDIOL("Please modify an entry or delete an entry, if necessary!")
19 . D PAUSE^VALM1
20 ; Select pos for new entry
21 S IBPOS=$S(IBCT=0:1,1:$$SEL(IBCT+1,"",IBCT+1)) Q:'(IBPOS>0)
22 ; Full screen
23 D FULL^VALM1
24 ; Select Payer
25 S IBIEN=$$PYRLKUP(IBPOS,1) Q:'(IBIEN>0)
26 ; Quit, if dup
27 I $D(^TMP($J,"IBJPI3-IENS",IBIEN)) D Q
28 . D EN^DDIOL("Payer already in list, please try again!")
29 . D PAUSE^VALM1
30 ; Add entry and shift others following down by one
31 F IBI=IBCT:-1:IBPOS S ^TMP($J,"IBJPI3-LIST",IBI+1)=^TMP($J,"IBJPI3-LIST",IBI)
32 S ^TMP($J,"IBJPI3-LIST",IBPOS)=IBIEN
33 S ^TMP($J,"IBJPI3-IENS",IBIEN)=""
34 S ^TMP($J,"IBJPI3-MODS")=""
35 ; Kill header to force refresh
36 K VALMHDR
37 ; Rebuild display
38 D DISP^IBJPI3
39 Q
40 ;
41DELETE ; Delete entry
42 N IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBIEN,IBI
43 ; Refresh screen
44 S VALMBCK="R"
45 ; Find highest pos in list (1-10)
46 S IBCT=+$O(^TMP($J,"IBJPI3-LIST",11),-1)
47 ; Quit, if list is empty
48 I IBCT=0 D Q
49 . D EN^DDIOL("Cannot delete entry as list is empty!")
50 . D PAUSE^VALM1
51 ; Select pos to delete
52 S IBPOS=$S(IBCT=1:1,1:$$SEL(IBCT)) Q:'(IBPOS>0)
53 ; Display Payer Name
54 W " ",$E($P($G(^IBE(365.12,+$G(^TMP($J,"IBJPI3-LIST",IBPOS)),0)),U,1),1,40)
55 ; Confirm deletion
56 S DIR(0)="Y"
57 S DIR("A")="Please confirm deletion of this entry"
58 S DIR("B")="NO"
59 D ^DIR
60 I $D(DIRUT)!'Y Q
61 ; Save IEN to delete
62 S IBIEN=$G(^TMP($J,"IBJPI3-LIST",IBPOS))
63 ; Shift entries in list following deleted entry up by one
64 F IBI=IBPOS:1:IBCT-1 S ^TMP($J,"IBJPI3-LIST",IBI)=^TMP($J,"IBJPI3-LIST",IBI+1)
65 K ^TMP($J,"IBJPI3-IENS",IBIEN)
66 K ^TMP($J,"IBJPI3-LIST",IBCT)
67 S ^TMP($J,"IBJPI3-MODS")=""
68 ; Kill header to force refresh
69 K VALMHDR
70 ; Build display
71 D DISP^IBJPI3
72 Q
73 ;
74MODIFY ; Modify entry
75 N IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBNIEN,IBOIEN,IBI
76 ; Refresh screen
77 S VALMBCK="R"
78 ; Find highest pos in list (1-10)
79 S IBCT=+$O(^TMP($J,"IBJPI3-LIST",11),-1)
80 ; Quit, if list is empty
81 I IBCT=0 D Q
82 . D EN^DDIOL("Cannot modify entry as list is empty!")
83 . D PAUSE^VALM1
84 ; Select pos to modify
85 S IBPOS=$S(IBCT=1:1,1:$$SEL(IBCT)) Q:'(IBPOS>0)
86 ; Display Payer Name
87 W " ",$E($P($G(^IBE(365.12,+$G(^TMP($J,"IBJPI3-LIST",IBPOS)),0)),U,1),1,40)
88 ; Full screen
89 D FULL^VALM1
90 ; Select payer
91 S IBNIEN=$$PYRLKUP(IBPOS,0) Q:'(IBNIEN>0)
92 ; Orig IEN
93 S IBOIEN=$G(^TMP($J,"IBJPI3-LIST",IBPOS))
94 I IBOIEN=IBNIEN D Q
95 . D EN^DDIOL("No change, please try again!")
96 . D PAUSE^VALM1
97 ; Quit, if dup
98 I $D(^TMP($J,"IBJPI3-IENS",IBNIEN)),$G(^TMP($J,"IBJPI3-LIST",IBPOS))'=IBNIEN D Q
99 . D EN^DDIOL("Payer already in list, please try again!")
100 . D PAUSE^VALM1
101 ; Update list and IEN index
102 S ^TMP($J,"IBJPI3-LIST",IBPOS)=IBNIEN
103 S ^TMP($J,"IBJPI3-IENS",IBNIEN)=""
104 ; Kill orig IEN entry
105 K ^TMP($J,"IBJPI3-IENS",IBOIEN)
106 S ^TMP($J,"IBJPI3-MODS")=""
107 ; Kill header to force refresh
108 K VALMHDR
109 ; Rebuild display
110 D DISP^IBJPI3
111 Q
112 ;
113REORDER ; Reorder entry
114 N IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBNPOS,IBOPOS,IBI
115 N IBOIEN
116 ; Refresh screen
117 S VALMBCK="R"
118 ; Find highest pos in list (1-10)
119 S IBCT=+$O(^TMP($J,"IBJPI3-LIST",11),-1)
120 ; Quit, if list is empty
121 I IBCT<2 D Q
122 . D EN^DDIOL("Cannot reorder entries as list is too small!")
123 . D PAUSE^VALM1
124 ; Select pos to reorder
125 S IBOPOS=$$SEL(IBCT) Q:'(IBOPOS>0)
126 ; Display Payer Name
127 W " ",$E($P($G(^IBE(365.12,+$G(^TMP($J,"IBJPI3-LIST",IBOPOS)),0)),U,1),1,40)
128 ; Select new pos
129 S IBNPOS=$$SEL(IBCT,1) Q:'(IBNPOS>0)
130 ; Quit, if no change
131 I IBOPOS=IBNPOS D Q
132 . D EN^DDIOL("New Position = Original Position, please try again!")
133 . D PAUSE^VALM1
134 ; Reorder to lower pos
135 I IBOPOS<IBNPOS D
136 . ; Orig IEN
137 . S IBOIEN=$G(^TMP($J,"IBJPI3-LIST",IBOPOS))
138 . ; Shift entries following orig entry up by one
139 . F IBI=IBOPOS:1:IBNPOS-1 S ^TMP($J,"IBJPI3-LIST",IBI)=^TMP($J,"IBJPI3-LIST",IBI+1)
140 . ; Set orig IEN in new pos
141 . S ^TMP($J,"IBJPI3-LIST",IBNPOS)=IBOIEN
142 ; Reorder to higher pos
143 I IBNPOS<IBOPOS D
144 . ; Save orig IEN
145 . S IBOIEN=$G(^TMP($J,"IBJPI3-LIST",IBOPOS))
146 . ; Shift entries before original entry down by one
147 . F IBI=IBOPOS:-1:IBNPOS+1 S ^TMP($J,"IBJPI3-LIST",IBI)=^TMP($J,"IBJPI3-LIST",IBI-1)
148 . ; Set orig IEN in new pos
149 . S ^TMP($J,"IBJPI3-LIST",IBNPOS)=IBOIEN
150 S ^TMP($J,"IBJPI3-MODS")=""
151 ; Kill header to force refresh
152 K VALMHDR
153 ; Rebuild display
154 D DISP^IBJPI3
155 Q
156 ;
157RESTORE ; Restore list from site params
158 N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
159 ; Refresh screen
160 S VALMBCK="R"
161 I '$D(^TMP($J,"IBJPI3-MODS")) D Q
162 . D EN^DDIOL("No actions have been performed, restore unnecessary.")
163 . D PAUSE^VALM1
164 ; Confirm restore
165 S DIR(0)="Y"
166 S DIR("A")="Please confirm restore of the last saved list"
167 S DIR("B")="NO"
168 D ^DIR
169 I $D(DIRUT)!'Y Q
170 ; Kill header to force refresh
171 K VALMHDR
172 ; Build list with site params
173 D BLD^IBJPI3
174 K ^TMP($J,"IBJPI3-MODS")
175 ; Rebuild display
176 D DISP^IBJPI3
177 Q
178 ;
179SAVE ; Save list to Site Params file
180 N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
181 ; Refresh screen
182 S VALMBCK="R"
183 ; Temp until file is updated
184 ;Q
185 I '$D(^TMP($J,"IBJPI3-MODS")) D Q
186 . D EN^DDIOL("No actions have been performed, save unnecessary.")
187 . D PAUSE^VALM1
188 ; Confirm save to site params
189 S DIR(0)="Y"
190 S DIR("A")="Please confirm save of the current list"
191 S DIR("B")="NO"
192 D ^DIR
193 I $D(DIRUT)!'Y Q
194 ; File changes
195 D FILE
196 ; Kill header to force refresh
197 K VALMHDR
198 ; Build list with site params
199 D BLD^IBJPI3
200 K ^TMP($J,"IBJPI3-MODS")
201 ; Rebuild display
202 D DISP^IBJPI3
203 Q
204 ;
205FILE ; Delete orig list and file new one
206 ; Temp until file is updated
207 ;Q
208 N DIK,DA,IBCT,FDA
209 ; Kill existing list entries
210 S DIK="^IBE(350.9,1,51.18,",DA(1)=1
211 F DA=1:1:10 I $D(^IBE(350.9,1,51.18,DA)) D ^DIK
212 ; Loop thru list entries and update 350.9 mult fld for most pop
213 F IBCT=1:1:10 I $D(^TMP($J,"IBJPI3-LIST",IBCT)) S FDA(350.9003,"+1,1,",.01)=$P($G(^TMP($J,"IBJPI3-LIST",IBCT)),U,1) D UPDATE^DIE("","FDA")
214 ; Init FDA array
215 K FDA
216 ; Update List start and end dts and compile dt
217 S FDA(350.9,"1,",51.11)=""
218 S FDA(350.9,"1,",51.12)=""
219 S FDA(350.9,"1,",51.21)=$$NOW^XLFDT
220 ; Save data to File (350.9)
221 D FILE^DIE("","FDA")
222 ;
223 Q
224 ;
225SEL(MAX,NWFLG,DFLT) ; Select Position
226 ; Input: MAX - upper bound > 0, NWFLG - opt param for 'New' prompt
227 ; Output: -1 (time out or '^') OR n (1<=n<=MAX) OR 0
228 N DIR,DIRUT,DTOUT,DUOUT,IBX,X,Y
229 ; Init output
230 S IBX=0
231 ; Validate MAX
232 I '(MAX>0) Q IBX
233 ; Init flag
234 S NWFLG=$G(NWFLG,0)
235 S DFLT=$G(DFLT)
236 ; Select (New) Position
237 S DIR(0)="NOA^1:"_MAX_":0^K:X'>0!(X>"_MAX_") X"
238 S DIR("A")="Select "_$S(NWFLG:"New ",1:"")_"Position (1-"_MAX_"): "
239 I DFLT>0 S DIR("B")=DFLT
240 S DIR("?")="Please enter a valid position between 1 and "_MAX
241 D ^DIR
242 S IBX=$S($D(DIRUT):-1,+Y:+Y,1:0)
243 Q IBX
244 ;
245PYRLKUP(IBPOS,ADDFLG) ; Lookup Payer IEN
246 N DIC,DTOUT,DUOUT,X,Y,PYRIEN
247 ;
248 S DIC=365.12
249 S DIC(0)="ABEV"
250 S DIC("A")="Enter Payer #"_IBPOS_": "
251 S DIC("?")=" Please enter a partial payer name to select a payer."
252 S DIC("S")="I $$PYRFLTR^IBCNEUT6"
253 S DIC("W")="W $$DSPLINE^IBCNEUT6"
254 S PYRIEN=$G(^TMP($J,"IBJPI3-LIST",IBPOS))
255 ;
256 ; Set default if not adding
257 I PYRIEN,'$G(ADDFLG) S DIC("B")=PYRIEN
258 D ^DIC
259 Q +Y
260 ;
261EXIT ; Exit action
262 S VALMBCK="R"
263 ; If the list has been acted upon, prompt for save
264 I $D(^TMP($J,"IBJPI3-MODS")) D
265 . D EN^DDIOL("Unsaved changes exist!")
266 . D SAVE
267 ; Call Fast Exit at this point
268 D FASTEXIT^IBJU1
269 Q
270 ;
271 ;
Note: See TracBrowser for help on using the repository browser.