source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 7.3 KB
Line 
1IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005
2 ;;2.0;INTEGRATED BILLING;**320,348,377**;21-MAR-94;Build 23
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT
6 D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
7 Q
8 ;
9HDR ; -- header code
10 K VALMHDR
11 S VALMHDR(1)=" "
12 S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL")
13 Q
14 ;
15INIT ; -- init variables and list array
16 N DIR,Y
17 I '$G(IBINS) D I +Y<0 S VALMQUIT=1 Q
18 . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units"
19 . D ^DIR K DIR
20 . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q
21 . I Y>0 S IBINS=+Y Q
22 ;
23 D BLD
24 Q
25 ;
26BLD ;
27 D CLEAN^VALM10
28 K ^TMP("IBPRV_CU",$J)
29 N TAR,MSG,I,D0,IBCT,Z,DIV,SCREEN
30 ;
31 S VALMBG=1
32 ;
33 ; Get all care units for this insurance company that have a division
34 ; If there is no division, then it is part of the other care units code (IBCEP4)
35 ;
36 S SCREEN="I $P(^(0),U,4)'="""",$P(^(0),U,3)=IBINS"
37 D LIST^DIC(355.95,,"@;.01;.02;.04",,,,,,SCREEN,,"TAR")
38 ;
39 I '+TAR("DILIST",0) D
40 . D SET^VALM10(1,"No CARE UNITs found for this Insurance Company")
41 ;
42 I +TAR("DILIST",0) D
43 . S IBCT=0
44 . F VALMCNT=1:1:+TAR("DILIST",0) D
45 .. S ^TMP("IBPRV_CU",$J,"SORT",TAR("DILIST","ID",VALMCNT,.04),TAR("DILIST",2,VALMCNT))=VALMCNT
46 . S DIV="" F S DIV=$O(^TMP("IBPRV_CU",$J,"SORT",DIV)) Q:DIV="" D
47 .. S Z="Division: "_DIV
48 .. S IBCT=IBCT+1
49 .. D SET^VALM10(IBCT,Z)
50 .. S D0=0 F S D0=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,D0)) Q:'D0 D
51 ... S IN=^TMP("IBPRV_CU",$J,"SORT",DIV,D0)
52 ... S Z=$J("",2)
53 ... S Z=Z_$E(IN_" ",1,4)_$E(TAR("DILIST","ID",IN,.01),1,36)
54 ... S Z=Z_$J("",40-$L(Z))
55 ... S Z=Z_$E(TAR("DILIST","ID",IN,.02),1,38)
56 ... S IBCT=IBCT+1
57 ... D SET^VALM10(IBCT,Z)
58 ;
59 ; correct the VALMCNT variable - number of lines in the list (not entries)
60 S VALMCNT=+$O(@VALMAR@(""),-1)
61 Q
62 ;
63HELP ; -- help code
64 S X="?" D DISP^XQORM1 W !!
65 Q
66 ;
67EXIT ; -- exit code
68 D CLEAN^VALM10
69 K ^TMP("IBPRV_CU",$J)
70 Q
71 ;
72EXPND ; -- expand code
73 Q
74 ;
75NEW ; Add care unit
76 ; Assumes IBINS is defined as ins co ien (file 36)
77 ; IB = 0 or null if called from list manager, 1 if not
78 N DIC,DIR,X,Y,Z,D,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
79 ;
80 D FULL^VALM1
81 ; Add an entry - either new care unit/ins co or a combination for
82 ; existing care unit/ins co
83 ;
84 S MAIN=$$MAIN^IBCEP2B()
85 S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
86 S DIC=40.8,DIC("A")="Enter the Division for this Care Unit: ",DIC("B")=MAIN,DIC(0)="AEMQ"
87 S D="B^C"
88 D MIX^DIC1
89 I Y'>0 G NEWQ
90 S IBDIV=+Y
91 S IBDIVNM=$$EXTERNAL^DILFD(355.92,.05,"",IBDIV)
92 ;
93 N SCREEN,TAR,MESS,I
94 S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)"
95 D LIST^DIC(355.95,,.01,,,,,,SCREEN,,"TAR")
96 ;
97ACU K DIR
98 S I=0
99 I $G(TAR("DILIST",0)) D
100 . S DIR("?",1)="Current Entries are:"
101 . F I=2:1 Q:'$D(TAR("DILIST",1,I-1)) S DIR("?",I)=" "_TAR("DILIST",1,I-1)
102 . S DIR("?",I)=" "
103 ;
104 S DIR("?",I+1)="You may enter the name of a new Care Unit for this Insurance Company."
105 S DIR("?",I+2)="You can then define a Billing Provider Secondary ID - Billing Screen 3 - for"
106 S DIR("?")="this Care Unit and Insurance Company using the Insurance Company Editor."
107 S DIR("A")="Enter the Care Unit name"
108 S DIR(0)="FO^1:30"
109 D ^DIR
110 I X=""!$G(DUOUT)!$G(DTOUT)!$G(DIROUT) G NEWQ
111 S CAREUNIT=X
112 ;
113 ; At this point, we have X and it'a not a ? or ^
114 ;
115 K DIC
116 S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="EX"
117 D ^DIC
118 ;
119 ; Check if we have an exisitng entry and if so, get out of Dodge (This option was for new care units)
120 I Y>0 D G ACU
121 . D DISPMESS("This action is for adding new entries, not editing existing entries.")
122 ;
123 ; New entry , validate field
124 N TAR2
125 D FIELD^DID(355.95,.01,"N","INPUT TRANSFORM","TAR2")
126 S X=CAREUNIT
127 X TAR2("INPUT TRANSFORM")
128 I '$D(X) D G ACU ; Failed input transform
129 . D DISPMESS("Invalid Format.")
130 ;
131 K DIR
132 S DIR("A")="Are you adding '"_X_"' as a new Care Unit for '"_IBDIVNM_"'"
133 S DIR("B")="N"
134 S DIR(0)="Y"
135 D ^DIR
136 I Y=0 G ACU
137 I Y["^" G NEWQ
138 ;
139 ; If it got this far, we have an exact match or a new entry.
140 S X=CAREUNIT
141 S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="XL",DLAYGO=355.95
142 S DIC("DR")=".03////"_+$G(IBINS)_";.04////"_$G(IBDIV)
143 D ^DIC
144 I Y>0 D
145 . S DA=+Y,DIE="^IBA(355.95,"
146 . S DR=".02Enter the Care Unit Description"
147 . D ^DIE
148 D BLD
149 ;
150NEWQ S VALMBCK="R"
151 Q
152 ;
153CHANGE ; Edit care unit
154 ; Assumes IBINS is defined as ins co ien (file 36)
155 ;
156 D FULL^VALM1
157 ;
158 N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION,I
159 ;
160 S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
161 D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
162 ;
163 I '+$G(TAR("DILIST",0)) D G CHANGEQ
164 .D DISPMESS("No Care Units Defined for this insurance company.")
165 ;
166 ; Store all Divisons with at least one care unit in DIVISION array
167 F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04)) D
168 . S DIVISION(TAR("DILIST","ID",I,.04))=""
169 ;
170 ; Only allow divisions that have care units to be selected
171 S DIC=40.8
172 S DIC("A")="Enter the Division for this Care Unit: "
173 S DIC(0)="AEMQ"
174 S DIC("S")="I $D(DIVISION($P(^(0),U)))"
175 S D="B^C"
176 D MIX^DIC1
177 I Y'>0 G CHANGEQ
178 S IBDIV=+Y
179 S DA=$$SEL($P(Y,U,2)) I 'DA G CHANGEQ
180 S DIE=355.95
181 S DR=".01Care Unit;.04Division;.02Description"
182 D ^DIE
183 ;
184 D BLD
185 ;
186CHANGEQ S VALMBCK="R"
187 Q
188 ;
189DEL ; Delete a Care Unit
190 ; Assumes IBINS is defined as ins co ien (file 36)
191 ;
192 D FULL^VALM1
193 N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
194 ;
195 S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
196 D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
197 ;
198 I '+$G(TAR("DILIST",0)) D G DELQ
199 .D DISPMESS("No Care Units Defined for this insurance company.")
200 ;
201 ; Store all Divisons with at least one care unit in DIVISION array
202 F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04)) D
203 . S DIVISION(TAR("DILIST","ID",I,.04))=""
204 ;
205 ; Only allow divisions that have care units to be selected
206 S DIC=40.8
207 S DIC("A")="Enter the Division for this Care Unit: "
208 S DIC(0)="AEMQ"
209 S DIC("S")="I $D(DIVISION($P(^(0),U)))"
210 S D="B^C"
211 D MIX^DIC1
212 I Y'>0 G DELQ
213 S IBDIV=+Y
214 S CAREUNIT=$$SEL($P(Y,U,2)) I 'CAREUNIT G DELQ
215 ;
216 I $D(^IBA(355.92,"AC",+Y)) D G DELQ
217 . S DIR(0)="EA"
218 . S DIR("A",1)="IDs that are assigned to the Care Unit in the Insurance Company Editor must be"
219 . S DIR("A",2)="deleted before deleting the Care Unit."
220 . S DIR("A")="Press return to continue "
221 . W ! D ^DIR K DIR
222 ;
223 S DIR("A")="OK to Delete: "
224 S DIR("B")="No"
225 S DIR(0)="YAO"
226 D ^DIR
227 I '$G(Y) G DELQ
228 K DIR
229 ;
230 S DA=CAREUNIT
231 S DIK="^IBA("_355.95_","
232 D ^DIK
233 ;
234 D BLD
235 ;
236DELQ S VALMBCK="R"
237 Q
238 ;
239DISPMESS(MESS) ;
240 N DIR,X,Y
241 S DIR(0)="EA",DIR("A",1)=MESS
242 S DIR("A")="PRESS ENTER to continue "
243 D ^DIR
244 Q
245 ;
246SEL(DIV) ; select care unit for a given division
247 ; DIV - name of division
248 ; returns ien of selected care unit, or 0 if nothing is selected
249 N DIR,I,IEN,MIN,MAX,X,Y
250 I $G(DIV)="" Q 0
251 S IEN=0
252 S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,"")),MIN=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
253 S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,""),-1),MAX=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
254 I MIN=MAX S IEN=I
255 I MIN'=MAX D
256 .S DIR("A")="Select CARE UNITS",DIR(0)="N^"_MIN_":"_MAX_":0" D ^DIR
257 .Q:$D(DTOUT)!$D(DUOUT)
258 .S I="" F S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,I)) Q:I=""!(IEN>0) S:$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))=Y IEN=I
259 .Q
260 Q IEN
Note: See TracBrowser for help on using the repository browser.