source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAECC.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.4 KB
Line 
1IBAECC ;LL/ELZ-LONG TERM CARE CLOCK MAINTANCE ; 05-FEB-02
2 ;;2.0;INTEGRATED BILLING;**176,199**;21-MAR-94
3 ;; Per VHA Directive 10-93-142, this routine should not be modified
4 ;
5 ; this routine will allow users to perform LTC copay clock
6 ; maintance. Every function for the user will be read and evaluated
7 ; before actually filed in the LTC Copay Clock.
8 ;
9OPT ; menu option main entry point
10 ;
11 N DIC,X,Y,DFN,IBLTCX,DTOUT,DUOUT,DIRUT,DIROUT,%,DIR,IBSTDT,IBCL,IBX,IBY,IBLTCZ
12 ;
13 ; select a patient (screen out patients with no LTC clock and are
14 ; not LTC patients.
15OPTA K DIC,X,Y,DFN,IBLTCX,VADP
16 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
17 S DIC="^DPT(",DIC(0)="AEMNQ",DIC("S")="I $$SCREEN^IBAECC(Y)" W ! D ^DIC G:Y<1 EX
18 S DFN=+Y D DEM^VADPT
19 ;
20 ; is there a clock, if not offer to add
21 I '$D(^IBA(351.81,"C",DFN)) D G:$G(IBLTCX)<1 OPTA
22 . W !!,"The patient ",VADM(1)," has no LTC clock on file."
23 . F W !,"Do you want to add one" S %=2 D YN^DICN Q:%'=0 W !," Answer with 'Yes' or 'No'"
24 . Q:%'=1
25 . ;
26 . ; start date
27 . W !,"You need to specify the clock start date"
28 . S DIR(0)="D^:"_DT D ^DIR Q:$D(DIRUT) S IBSTDT=+Y
29 . ;
30 . ; create clock entry
31 . S IBLTCX=+$$ADDCL^IBAECU(DFN,IBSTDT)
32 ;
33 ; choose a clock
34 I $G(IBLTCX)<1 S IBLTCX=$$ASKCLK^IBAECP(DFN,1) G:$G(IBLTCX)<1 OPTA
35 ;
36 S IBLTCZ=^IBA(351.81,IBLTCX,0) D DISPLAY,EDIT
37 G OPTA
38 ;
39EX ;
40 D KVAR^VADPT
41 ;
42 Q
43 ;
44DISPLAY ; display clock information
45 ; Temporary
46 N IBCLK
47 S IBCLK=IBLTCX
48 W @IOF
49 D REPORT^IBAECB1
50 Q
51 ;
52 ;
53EDIT ; edit either start date or free days
54 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
55AGAINE W ! F X=1:1:IOM W "-"
56 W !,"You can edit Start Date OR Days Not Subject To LTC Copay (Free Days)"
57 S DIR(0)="SO^S:Start Date;F:Free Days;" D ^DIR Q:$D(DIRUT)
58 D @$S(Y="S":"START",1:"FREE"),DISPLAY
59 G AGAINE
60 Q
61 ;
62START ; edit the start date
63 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBSTDT,DIE,DA,DR,IBZ
64 S DIR(0)="D",DIR("B")=$$FMTE^XLFDT($P(IBLTCZ,"^",3))
65 D ^DIR Q:$D(DIRUT) S IBSTDT=+Y
66 ;
67 ; no change
68 I IBSTDT=$P(IBLTCZ,"^",3) W !!?10,"No Change !!" H 3 Q
69 ;
70 ; make sure we don't start after a free day
71 S IBZ=0 F S IBZ=$O(^IBA(351.81,IBLTCX,1,IBZ)) Q:IBZ<1 I $P(^IBA(351.81,IBLTCX,1,IBZ,0),"^",2)<IBSTDT S IBSTDT=0 Q
72 I 'IBSTDT W !,"You must enter a date that is BEFORE all the Free Days" G START
73 ;
74 ; don't go less that 1 year before earliest free day
75 S IBZ=0 F S IBZ=$O(^IBA(351.81,IBLTCX,1,IBZ)) Q:IBZ<1 I '$$YR(IBSTDT,$P(^IBA(351.81,IBLTCX,1,IBZ,0),"^",2)) S IBSTDT=0 Q
76 I 'IBSTDT W !,"You entered a start date greater than 1 year before a Free Day" G START
77 ;
78 ; file new start date and exp date
79 S DIE="^IBA(351.81,",DA=IBLTCX,DR=".03///^S X=IBSTDT;.04///^S X=$$GETEXPDT^IBAECU4(IBSTDT)" D ^DIE
80 S IBLTCZ=^IBA(351.81,IBLTCX,0)
81 ;
82 D LASTED
83 ;
84 Q
85 ;
86FREE ; change the free days
87 N IBF,IBX,IBC,IBD,IBFREEX,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBOPT,IBFREEZ
88 N IBCLK
89 S IBCLK=IBLTCX
90 ;
91AGAINF ;
92 D REINDEX
93 ;
94 S (IBC,IBX)=0 F S IBX=$O(^IBA(351.81,IBLTCX,1,"AC",IBX)) Q:IBX<1 S IBC=IBC+1,IBF(IBX,IBC)=$O(^IBA(351.81,IBLTCX,1,"AC",IBX,0))
95 ;
96 ; display free days
97 ;W !,"These are the Free Days currently on file:",!
98 ;S IBD=0 F S IBD=$O(IBF(IBD)) Q:IBD<1 W !?5,$O(IBF(IBD,0)),?10,$$FMTE^XLFDT(IBD)
99 D FRDAYS^IBAECB1
100 ;
101 ; choose add, edit, or delete free day
102 S DIR(0)="SO^A:Add;E:Edit;D:Delete" D ^DIR Q:$D(DIRUT) S IBOPT=Y
103 ;
104 ; choose which one to change
105 I IBOPT'="A" S DIR(0)="NO^1:"_IBC_":0" D ^DIR Q:$D(DIRUT) S IBD=0 F S IBD=$O(IBF(IBD)) Q:IBD<1 I $D(IBF(IBD,+Y)) S IBFREEX=IBF(IBD,+Y),IBFREEZ=^IBA(351.81,IBLTCX,1,IBF(IBD,+Y),0) Q
106 ;
107 D @(IBOPT_"FREE")
108 ;
109 G AGAINF
110 ;
111 Q
112 ;
113AFREE ; add free days
114 N IBX,IBC,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBDT,DO,DIC,DINUM,DA,DIE,DR
115 ;
116 ; make sure there are not more than 21 already
117 S (IBX,IBC)=0 F S IBX=$O(^IBA(351.81,IBLTCX,1,IBX)) Q:IBX<1 S IBC=IBC+1
118 I IBC>20 W !,"Patients are only allowed 21 free days. ",!,VADM(1)," has ",IBC," already." Q
119 ;
120 ; what date do you want to add
121AFREEA S IBDT=$$DATE I IBDT<1 Q
122 ;
123 ; is that date already there
124 D ALREADY G:IBDT<1 AFREEA
125 ;
126 ; is free day before start date or > 1 year out
127 D BADDT I IBDT<1 G AFREEA
128 ;
129 ; file free day
130 F IBX=1:1:21 Q:'$D(^IBA(351.81,IBLTCX,1,IBX))
131 K DO S DIC="^IBA(351.81,"_IBLTCX_",1,",DIC(0)="",X=IBX,DINUM=X,DA(1)=IBLTCX,DIC("DR")=".02///^S X=IBDT" D FILE^DICN
132 ;
133 W ?40,"... ",$$FMTE^XLFDT(IBDT)," was ",$S(Y>0:"",1:"NOT "),"added."
134 I Y>0 S DIE="^IBA(351.81,",DA=IBLTCX,DR=".06///"_($P(IBLTCZ,"^",6)-1) D ^DIE S IBLTCZ=^IBA(351.81,IBLTCX,0)
135 ;
136 D LASTED,REINDEX
137 ;
138 ; allow adding more if they are not all used up.
139 G:$P(IBLTCZ,"^",6)>0 AFREEA
140 ;
141 Q
142 ;
143EFREE ; edit a free day IBFREEX
144 N IBDT,DIE,DA,DR
145 ;
146 ; what date do you want to change it to
147 S IBDT=$$DATE($$FMTE^XLFDT($P(IBFREEZ,"^",2))) I IBDT<1 Q
148 I IBDT=$P(IBFREEZ,"^",2) W !,"No change" Q
149 ;
150 ; is free day already there
151 D ALREADY Q:IBDT<1
152 ;
153 ; is free day before start date or > 1 year out
154 D BADDT Q:IBDT<1
155 ;
156 ; file free day
157 S DIE="^IBA(351.81,"_IBLTCX_",1,",DA(1)=IBLTCX,DA=IBFREEX,DR=".02///^S X=IBDT" D ^DIE
158 ;
159 D LASTED,REINDEX
160 ;
161 Q
162 ;
163DFREE ; delete a free day
164 N %,DA,DIK,DIE,DR
165 ;
166 ; are you sure
167 F W !,"Are you sure you want to delete this date" S %=2 D YN^DICN Q:%'=0 W !," Answer with 'Yes' or 'No'"
168 Q:%'=1
169 ;
170 ; delete it
171 S DIK="^IBA(351.81,"_IBLTCX_",1,",DA(1)=IBLTCX,DA=IBFREEX D ^DIK
172 S DIE="^IBA(351.81,",DA=IBLTCX,DR=".06///"_($P(IBLTCZ,"^",6)+1) D ^DIE S IBLTCZ=^IBA(351.81,IBLTCX,0)
173 ;
174 D LASTED,REINDEX
175 ;
176 Q
177 ;
178SCREEN(DFN) ; screen out non-LTC patients
179 N IBLTCST S IBLTCST=$$LTCST^IBAECU(DFN,DT,1)
180 Q $S($D(^IBA(351.81,"C",DFN)):1,+IBLTCST=2:1,1:0)
181 ;
182ALREADY ; checks to see if the free day is already there
183 N IBX
184 S IBX=0 F S IBX=$O(^IBA(351.81,IBLTCX,1,IBX)) Q:IBX<1 I $P(^IBA(351.81,IBLTCX,1,IBX,0),"^",2)=IBDT S IBDT="-1^"_IBDT Q
185 I IBDT<1 W !!,$$FMTE^XLFDT($P(IBDT,"^",2))," is already on file!"
186 Q
187 ;
188DATE(IBB) ; prompts for date selection (IBB is default)
189 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
190 S DIR(0)="DO^:"_DT S:$G(IBB) DIR("B")=IBB D ^DIR
191 Q +Y
192 ;
193BADDT ; checks out IBDT to make sure it is a valid date based upon start date
194 I IBDT<$P(IBLTCZ,"^",3) W !!,$$FMTE^XLFDT(IBDT)," is less than the clock start date of ",$$FMTE^XLFDT($P(IBLTCZ,"^",3)) S IBDT=0 Q
195 I '$$YR($P(IBLTCZ,"^",3),IBDT) W !!,$$FMTE^XLFDT(IBDT)," is greater than 1 year pased the clock start date." S IBDT=0 Q
196 ; if date is current month, don't allow
197 I $E(IBDT,1,5)=$E(DT,1,5) W !!,$$FMTE^XLFDT(IBDT)," is during the current month.",!,"You must allow the montly job to enter this date into the clock." S IBDT=0
198 Q
199 ;
200LASTED ; update last edited by and date fields
201 N DIE,DR,DA
202 S DIE="^IBA(351.81,",DA=IBLTCX,DR="4.03////^S X=DUZ;4.04///NOW" D ^DIE
203 Q
204YR(IBCLDT,IBFR) ; is the effective date of the clock too old?
205 ; Input: IBCLDT -- New Clock Effective Date
206 ; IBFR -- Event Date
207 ; Output: 1 -- Effective Date is too old
208 ; 0 -- Not
209 N IBNUM,IBYR
210 S IBNUM=$$FMDIFF^XLFDT(IBFR,IBCLDT),IBYR=$E(IBFR,1,3)
211 Q IBYR#4&(IBNUM<364)!(IBYR#4=0&(IBNUM<365))
212 ;
213REINDEX ; this will take a clock and re-index the free days in order
214 ; assumes IBLTCX
215 N IBX,DIK,DA,X,Y,IBZ
216 ;
217 ; clean out what is there
218 S IBX=0 F S IBX=$O(^IBA(351.81,IBLTCX,1,IBX)) Q:IBX<1 S IBZ($P(^IBA(351.81,IBLTCX,1,IBX,0),"^",2))="" S DIK="^IBA(351.81,"_IBLTCX_",1,",DA=IBX,DA(1)=IBLTCX D ^DIK
219 ;
220 ; place them back in - in order
221 S IBZ=0 F IBX=1:1 S IBZ=$O(IBZ(IBZ)) Q:IBZ<1 K DO S DIC="^IBA(351.81,"_IBLTCX_",1,",DIC(0)="",DA(1)=IBLTCX,X=IBX,DINUM=IBX,DIC("DR")=".02////^S X=IBZ" D FILE^DICN
222 Q
Note: See TracBrowser for help on using the repository browser.