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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1IBAECM1 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 20-FEB-02
2 ;;2.0;INTEGRATED BILLING;**176**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;Input: IBMDS1 - array with month info
6 ;IBMDS1 (0)-first day of the month
7 ;IBMDS1 (1)-last day of the month
8 ;IBMDS1 (2)-yyymm in Fileman format (like 30201 - for Jan 2002)
9MJT ;entry for Monthly Calculation Process
10 ;(array IBMDS1 must be specified outside!)
11 Q:'$D(IBMDS1)
12 ;------ variables
13 N IBCLKAD1 ; variable to return back from PROCPAT info for clock adjustment
14 N IBDFN
15 N IBCLKIE1
16 N IBONCE ;to detect "more than 1 active clock" case for the patient
17 N IBCLKDAT ;clock data
18 N IBSTRTD ;EFFECTIVE DATE
19 S IBSTRTD=$$BILDATE^IBAECN1()
20 K ^TMP($J,"IBMJERR")
21 K ^TMP($J,"IBMJINP")
22 K ^TMP($J,"IBMJOUT")
23 ;go thru all patients in #351.81
24 S IBDFN1=0
25 ;for each patient in file 351.81
26 F S IBDFN1=$O(^IBA(351.81,"C",IBDFN1)) Q:+IBDFN1=0 D
27 . S IBCLKIE1=0,IBERR="",IBONCE=0
28 . F S IBCLKIE1=+$O(^IBA(351.81,"C",IBDFN1,IBCLKIE1)) Q:+IBCLKIE1=0 D
29 . . S IBCLKDAT=^IBA(351.81,IBCLKIE1,0)
30 . . ; quit if STATUS'=OPEN
31 . . Q:$P(IBCLKDAT,"^",5)'=1
32 . . ; quit if CURRENT EVENTS DATE="" i.e. no LTC events happend
33 . . ; this month for the patient
34 . . Q:$P(IBCLKDAT,"^",7)=""
35 . . ; quit if CURRENT EVENTS DATE>last day of previous month
36 . . ; i.e. this patient has been already processed. Probably when MJ already has been run and then crushed.
37 . . ;in such cases NJ runs MJ again next day. SO we don't need to charge the patient again.
38 . . Q:$P(IBCLKDAT,"^",7)>IBMDS1(1)
39 . . ; if error save it in ^TMP for further e-mail
40 . . I IBONCE>0 D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBCLKIE1),"Clocks","Patient has more than one OPEN LTC clocks") Q
41 . . S IBONCE=1
42 . . S IBCLKAD1=""
43 . . ;process the patient
44 . . I $$PROCPAT^IBAECM2(.IBMDS1,IBDFN1,IBSTRTD,IBCLKIE1)=-1 D
45 . . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBCLKIE1),"Charge","Error with LTC clock creation occured during calculation, no proper charges have been created") Q
46 ;send all errors to user group
47 D SENDERR^IBAECU5 ;send all errors
48 ;if we reach this place that means that we processed everybody
49 ;and we stamp the date into IB SITE PARAMETERS
50 S $P(^IBE(350.9,1,0),"^",16)=$$TODAY^IBAECN1()
51 ;if Nightly Job founds that date $P(^IBE(350.9,1,0),"^",16)
52 ;is less that begining of current month than NJ runs MJ again and MJ will
53 ;process a rest patients
54 Q
55 ;
56 ;-----
57 ;180 clock days issue
58 ;calculates proper LTC Monthly Copay Amount:
59 ;IBDFN2 -patient's ien in file #2
60 ;IBINF - admission info
61 ;IBENROL - enrollment info (returned by $$COPAY^EASECCAL)
62 ;IBADMLEN - admission lenght
63 ;returns:
64 ; 0- if patient does not have >180 days of continious LTC
65 ; 1- if patient has >180 days of continious LTC (only stay days are counted)
66 ;IBAMOUNT - returns back proper amount
67MONTHMAX(IBDFN2,IBINF,IBENROL,IBADMLEN,IBAMOUNT) ;
68 N IB180DS
69 S IBAMOUNT=+$P(IBENROL,"^",3) ;by default is "<=180 days" amount
70 ;if less or equal 180 days -quit
71 I IBADMLEN=1 Q 0 ;>>QUIT
72 ; how many stay days in this admission:
73 S IB180DS=$$STAYDS^IBAECU2(IBINF(1),IBINF(3),IBINF,IBINF(2))
74 ;if stay days <= 180 then quit & return
75 I IB180DS<181 Q 0 ;>>QUIT
76 ;if stay days > 180 then we have to check if any treating
77 ;specialty change breaks this 181+ continious period
78 ; Analyse all this admission period to find out any 180 days clock
79 ; breaks related to changing specialty.
80 ;MORE180(IBDFN,IBADM,IBLSTDAY,IBDISCH)
81 I $$MORE180^IBAECU2(IBDFN2,IBINF,IBINF(3),IBINF(2))=0 Q 0 ;>>QUIT
82 ; If there is no any non-LTC specialties during 180 days of stay before
83 ; discharge or last day of the processing month and stay days >180 :
84 S IBAMOUNT=+$P(IBENROL,"^",4) ;amount for 181+ days
85 Q 1
86 ;---
87 ;finds the length of active LTC admission that started before IBFRST
88 ;IBFRST - first date of the date frame
89 ;IBLAST - last date of the date frame
90 ;IBDFN - ien of the patient in #2
91 ;IBLBL - ^TMP identifier
92 ;returns number of days if found such admission
93 ;returns 1 if not found
94 ;.IBINF returns:
95 ;IBINF - #405 ien
96 ;IBINF(0) total days of admission
97 ;IBINF(1) first day of admission
98 ;IBINF(2) discharge date of admission
99 ;IBINF(3) last_date_of_admission or last date of
100 ; this period if vet is not discharged yet
101DAYS180(IBFRST,IBLAST,IBDFN,IBLBL,IBINF) ;
102 N IBV1,IBV2,IBFL,IB405
103 S IBFL=0
104 S IB405=0
105 F S IB405=+$O(^TMP($J,IBLBL,IBDFN,IB405)) Q:IB405=0!(IBFL>0) D
106 . ;quit if admission started this month
107 . I +$G(^TMP($J,IBLBL,IBDFN,IB405))'<IBFRST Q
108 . S IBV1=+$O(^TMP($J,IBLBL,IBDFN,IB405,"SD",0))
109 . ;if found stay day in the first day and this is LTC service then quit
110 . I IBV1=IBFRST,$P($G(^TMP($J,IBLBL,IBDFN,IB405,"SD",IBV1)),"^",1)="L" S IBFL=IB405 Q
111 . S IBV1=+$O(^TMP($J,IBLBL,IBDFN,IB405,"LD",0))
112 . ;if found leave day in the first day and this is LTC service then quit
113 . I IBV1=IBFRST,$P($G(^TMP($J,IBLBL,IBDFN,IB405,"LD",IBV1)),"^",1)="L" S IBFL=IB405 Q
114 I IBFL=0 Q 1 ;not found >>QUIT
115 ;if found
116 S IBV1=$G(^TMP($J,IBLBL,IBDFN,IBFL))
117 Q:IBV1="" 1 ;error >>QUIT
118 S IBINF=IBFL ;ien of #405
119 S IBINF(0)=+$P(IBV1,"^",6) ;total number of inpatient days
120 I IBINF(0)>0 D Q IBINF(0) ;found >>QUIT
121 . ;first day of admission
122 . S IBINF(1)=+$P(IBV1,"^",1)
123 . ;discharge date of admission
124 . S IBINF(2)=+$P(IBV1,"^",2)
125 . ;last_date_of_admission
126 . S IBINF(3)=+$P(IBV1,"^",3)
127 . ;if no discharge then last day is IBLAST
128 . ;otherwise last day = discharge
129 . S:IBINF(2)=0 IBINF(3)=IBLAST
130 Q 1
131 ;
132 ;clean all ^TMP related to the patient
133CLEAN(IBDFN2) ;
134 K ^TMP($J,"IBLTCARR",IBDFN2)
135 K ^TMP($J,"IBMJINP",IBDFN2)
136 K ^TMP($J,"IBMJOUT",IBDFN2)
137 ;K ^TMP($J,"IB180",IBDFN1)
138 Q
139 ;--
140 ;Returns the last day (in FM format) of the previous month
141PREVMNTH() ;
142 N X,X1,X2
143 D NOW^%DTC
144 S X1=$E(X,1,5)_"01"
145 S X2=-1
146 D C^%DTC
147 Q X
148 ;
149 ;
150 ;runs for each day of the month for the patient
151 ;checks LTC clock and makes necessary adjustments
152 ;Input:
153 ;IBCLIEN Ien of #351.81
154 ;IBDT Date in FM format
155 ;IBDFN Patient's ien of #2
156 ;Output:
157 ;returns current IEN or new one if #351.81 entry has been created
158 ;returns 0 if fatal error
159CH21BFR(IBCLIEN,IBDT,IBDFN) ;
160 N IBCLDATA,IB1,IB2,IBLCKER
161 S IBLCKER=0
162 S IBCLIEN=+IBCLIEN
163 S IB1=IBCLIEN
164 S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
165 I IBCLDATA=""!($P(IBCLDATA,"^",1)="")!($P(IBCLDATA,"^",2)="")!($P(IBCLDATA,"^",3)="") D Q 0
166 . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","0-node data corrupted in LTC clock")
167 ; Check clock expiration date
168 ; if there is no exp date then set it
169 I $P(IBCLDATA,"^",4)="" D
170 . S IB2=+$P(IBCLDATA,"^",3)
171 . S:IB2=0 IB2=IBDT
172 . L +^IBA(351.81,0):10 I '$T D S IBLCKER=1 Q ;quit
173 . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not reset")
174 . D RESET21^IBAECU4(IBCLIEN,IB2,IBDFN) ;set EXPIRATION DATE
175 . D FIX21CLK^IBAECU4(IBCLIEN)
176 . D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
177 . L -^IBA(351.81,0)
178 . S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
179 Q:IBLCKER=1 IBCLIEN
180 ;if clock expired close existent and set new one
181 I IBDT>$P(IBCLDATA,"^",4) D
182 . L +^IBA(351.81,0):10 I '$T D Q ;quit
183 . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not closed")
184 . D CLOSECLK^IBAECU4(IBCLIEN,IBDFN)
185 . D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
186 . S IBCLIEN=$$NEWCLK^IBAECU4(IBDFN,IBDT)
187 . I IBCLIEN=0 D L -^IBA(351.81,0) Q
188 . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not created")
189 . D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN)
190 . D FIX21CLK^IBAECU4(IBCLIEN)
191 . D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
192 . L -^IBA(351.81,0)
193 Q IBCLIEN
194 ;add new free day to 21 clock
195 ;Input:
196 ;IBCLIEN Ien of #351.81
197 ;IBDT Date in FM format
198 ;IBDFN Patient's ien of #2
199ADD21DAY(IBCLIEN,IBDT,IBDFN) ;
200 N IBCLDATA,IB1,IB2
201 S IBCLIEN=+IBCLIEN
202 S IB1=IBCLIEN
203 S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
204 I IBCLDATA="" D Q
205 . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","0-node data corrupted in LTC clock")
206 ;if clock is not expired & still DAYS REMAINING>0 - do not charge,
207 ;add exempt day to clock
208 I $P(IBCLDATA,"^",4)="" D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN),FIX21CLK^IBAECU4(IBCLIEN)
209 I +$P(IBCLDATA,"^",6)=21,+$P(IBCLDATA,"^",3)'=IBDT D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN) ;if begin date'=1st free day, then fix begin & expir. dates
210 I $P(IBCLDATA,"^",4)'<IBDT,$P(IBCLDATA,"^",6)>0 D
211 . L +^IBA(351.81,0):10 I '$T D Q ;quit
212 . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: new free day not added")
213 . D ADDEXDAY^IBAECU4(IBCLIEN,IBDT,IBDFN)
214 . D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
215 . L -^IBA(351.81,0)
216 Q
217 ;
218 ;entry point ONLY for testing purposes:
219 ;prepare date range for current month
220 ;dates,days for processing month
221TESTMJ ;
222 D NOW^%DTC
223 ;if you want to test MJ for specific month then
224 ;set X to specific date and run TESTX
225TESTX ;
226 S $P(^IBE(350.9,1,0),"^",16)=0
227THEMONTH ;
228 S IBMDS1(1)=$$LASTDT^IBAECU(X)
229 S IBMDS1(2)=$E(IBMDS1(1),1,5)
230 S IBMDS1(0)=IBMDS1(2)_"01",IBMDS1=$E(IBMDS1(1),6,7)
231 ;run MJ with date range specified outside (above) using MJT entry point
232 D MJT
233 ;set LAST LTC COMPLETION DATE to 0 to allow event handlers to update LTC clock file;
234 S $P(^IBE(350.9,1,0),"^",16)=0
235 Q
236 ;
Note: See TracBrowser for help on using the repository browser.