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

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

initial load of WorldVistAEHR
File size: 9.2 KB
Line 
1IBAECM2 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 20-FEB-02
2 ;;2.0;INTEGRATED BILLING;**176,198,188**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6 ;Copay calculation for the patient
7 ;Input:
8 ;IBMDS - days array
9 ; IBMDS(0)-first day of the month
10 ; IBMDS(1)-last day of the month
11 ; IBMDS(2)-yyymm (like 30201 - for Jan 2002)
12 ;IBDFN - dfn
13 ;IBSTART - date to start calclation from,
14 ; normally it is the first day of the month,
15 ; but for very first time it will be the effective date
16 ;IBCLKIEN - 351.81 ien
17 ;returns 0 if no charges for any reason
18 ;otherwise returns 1
19PROCPAT(IBMDS,IBDFN,IBSTART,IBCLKIEN) ;
20 ;IBCHRG - charge array, is used for SEND2AR, contains all charges for
21 ;the patient for this month
22 ;one day may contain only one rate (charge), that prevents duplications
23 ; "A",IBDAY,"R"=rate^ien_of_#350.1(i.e.IB action type)
24 ; "A",IBDAY,"T"=type or care^source^date
25 ;where
26 ; outpatient:
27 ; type or care - 1
28 ; source - ien of #409.68
29 ; date - date of service
30 ; inpatient:
31 ; type or care - 2
32 ; source - ien of #405
33 ; date - date of admission
34 N IBCHRG
35 N IBDAY,IBDATE,IBINPAT,IBOUTPAT,IBRET,IBCMCA
36 N IBINPINF,IBADM1,IBVISIT,IBCOMPEN,IBV1,IBV2
37 N IBLDINP,IB40968,IBFDAY
38 S IBCHRG=0,IBLDINP="^"
39 D CLEAN^IBAECM1(IBDFN)
40 ; determine first day (IBFDAY) of FOR cycle:
41 S IBFDAY=1 ;default
42 S IBSTART=+$G(IBSTART)
43 ;if effective date is greater than the last day of this month, then do nothing
44 Q:IBSTART>IBMDS(1) IBCHRG
45 ;if effective date is in current month, then cycle starts from
46 ;this day of the month
47 S IBFDAY=+$E(IBSTART,6,7)
48 ;if effective date is less than this month, then starts from
49 ;the first day of the month
50 S:IBSTART<IBMDS(0) IBFDAY=1
51 ;----
52 ; use LOS=1 to get patient status
53 S IBRET=+$$LTCST^IBAECU(IBDFN,IBMDS(1),1)
54 ;** EXEMPTION from co-pay **
55 I IBRET=1 Q IBCHRG ;>>QUIT
56 ;
57 ;get all data about all inpatient episodes
58 ;IBINPAT'=0 - there are inpatient episodes
59 S IBINPAT=$$INPINFO^IBAECU2(IBMDS(0),IBMDS(1),IBDFN,"IBMJINP",1)
60 ;get all data about all outpatient episodes
61 ;IBOUTPAT'=0 - there are outpatient episodes
62 S IBOUTPAT=$$OUTPINFO^IBAECU3(IBMDS(0),IBMDS(1),IBDFN,"IBMJOUT")
63 ;no 1010EC - send e-mail and quit
64 I IBRET=0 D Q IBCHRG ;>>QUIT
65 . S IBV1=$O(^TMP($J,"IBMJINP",IBDFN,0))
66 . I +IBV1>0 S IBV1=+$G(^TMP($J,"IBMJINP",IBDFN,IBV1))
67 . I +IBV1=0 S IBV1=$O(^TMP($J,"IBMJOUT",IBDFN,IBV1))
68 . I +IBV1=0 S IBV1=IBMDS(0)
69 . ; changed in 188 to eliminate some messages when nothing there
70 . I IBINPAT'=0!(IBOUTPAT'=0) D MESS10EC^IBAECU5(IBDFN,IBV1)
71 . D CLEAN^IBAECM1(IBDFN)
72 . ; update or clean out current events date
73 . S DR=".07///"_$S($D(^DPT(IBDFN,.1)):$E(DT,1,5)_"01",1:"@")
74 . S DIE="^IBA(351.81,",DA=IBCLKIEN D ^DIE
75 ;
76 ; if no inpatient, no outpatient episodes and still 21 free days
77 ; remain - someone cancelled episodes and we cancel the clock
78 I IBINPAT=0,IBOUTPAT=0,$P($G(^IBA(351.81,IBCLKIEN,0)),"^",6)=21 D Q IBCHRG ;>>QUIT
79 . D CLCKADJ^IBAECU4("C",IBCLKIEN,IBDFN,"^",IBMDS(1))
80 . S IBCHRG("A")=0 ; no charges
81 . D CLEAN^IBAECM1(IBDFN)
82 ;
83 ; check correctness of 21 days clock if error then fix it and notify the users
84 S IBV2=$$CHKDSERR^IBAECU4(IBCLKIEN,IBDFN)
85 I IBV2<0 D FIX21CLK^IBAECU4(IBCLKIEN)
86 ; ==============Go thru each day =============================
87 F IBDAY=IBFDAY:1:IBMDS Q:IBCLKIEN=0 S IBDATE=$$MKDATE^IBAECU4(IBMDS(2),IBDAY) D
88 . ;***** Gathering all necessary info ******
89 . ; C&P status
90 . S IBCOMPEN=$$ISCOMPEN^IBAECU5(IBDFN,IBDATE)
91 . ; INPATIENT episodes
92 . S IBADM1=0 ;adm ien
93 . S IBINPINF="" K IBINPINF("M"),IBINPINF("L")
94 . ; is any inpatient LTC this day?
95 . S IBINPINF=$$ISINPAT^IBAECU2(IBDFN,IBDATE,"IBMJINP",.IBINPINF)
96 . ;
97 . ; if the patient has inpatient service in the last day of the
98 . ; processed month, then "CURRENT EVENTS DATE" in LTC clock (#351.81)
99 . ; must be set to the 1st day of the following month to indicate that
100 . ; the patient must be checked for LTC copay by MJ next month.
101 . ; Thus if so we set IBLDINP to IBINPINF (calcualted for the last day
102 . ; of the processed month)(see CLCKADJ)
103 . I IBMDS(1)=IBDATE S IBLDINP=IBINPINF
104 . ; OUTPATIENT episodes
105 . S IB40968=0
106 . S IBVISIT="" K IBVISIT("M"),IBVISIT("L")
107 . ;is there any outp episode with this day?
108 . S IBVISIT=$$ISOUTP^IBAECU3(IBDFN,IBDATE,"IBMJOUT",.IBVISIT)
109 . ; If there is LTC event this day (IBDATE) and if current
110 . ; CLOCK BEGIN DATE > IBDATE then change it to IBDATE
111 . ; (& reset its expiration date)
112 . I +IBVISIT!(+IBINPINF) I $P($G(^IBA(351.81,IBCLKIEN,0)),"^",3)>IBDATE D RESET21^IBAECU4(IBCLKIEN,IBDATE,IBDFN)
113 . ;*****************************************
114 . ; check 21 days clock file
115 . ; check expiration date,etc of 21 clock
116 . S IBCLKIEN=$$CH21BFR^IBAECM1(IBCLKIEN,IBDATE,IBDFN) ;
117 . I IBCLKIEN=0 Q ;ERROR - new entry in #351.81 was not created - quit !
118 . ;
119 . ; 1. LTC inpatient in bed - ALWAYS charge him
120 . S IBADM1=+$O(IBINPINF("L","SD",0))
121 . I IBADM1>0 D Q ;>>>>QUIT - GO to NEXT DAY
122 . . ;look for and cancel Means Test Outpatient charges for this date
123 . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
124 . . ; check expiration date,etc of 21 clock
125 . . ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
126 . . ; 1 - if exempted, don't charge the patient
127 . . I $$EXEMPT21^IBAECU4(IBCLKIEN)=1 D Q
128 . . . ;add new exempt day to LTC clock
129 . . . D ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
130 . . ; otherwise no 21 clock exemption - cretae a charge
131 . . ;get rate for this treating specialty
132 . . S IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(2,+$G(IBINPINF("L","SD",IBADM1)),IBDATE)_"^"_$P($G(IBINPINF("L","SD",IBADM1)),"^",2)
133 . . S IBCHRG("A",IBDAY,"T")="2^"_IBADM1_"^"_$P($G(IBINPINF("L","SD",IBADM1)),"^",3) ;inpatient
134 . . S IBCHRG=IBCHRG+1
135 . ;
136 . ; 2. MeansTest inpatient in bed or in AA,UA or ASIH
137 . ; do not charge vet for LTC outpatient visit
138 . ; - MT inpatient care has precedence on LTC outpatient visit if vet is in bed.
139 . ; - if MT inpatient in AA,UA,ASIH, the current MT rule don't allow to charge him
140 . ; for MT outpatien visits in AA,UA&ASIH. It was decided to applied the same rules
141 . ; to LTC outpatient visits
142 . S IBADM1=+$O(IBINPINF("M",0))
143 . Q:IBADM1>0 ;............................>>>>QUIT - GO to NEXT DAY
144 . ;
145 . ; 3. LTC inpatient in AA,UA or ASIH
146 . ; do not charge for any (MT or LTC) outpatient visits (see explanation for 2.)
147 . S IBADM1=+$O(IBINPINF("L","LD",0))
148 . I IBADM1>0 D Q ;>>>>QUIT - GO to NEXT DAY
149 . . ;look for and cancel Means Test Outpatient charges for this date
150 . . ;(at this point can be only outpatient MT charges,
151 . . ;because inpatient MT has gone earlier in 2.)
152 . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
153 . ;
154 . ; 4. C&P exam
155 . ; if C&P exam then any outpatient visits are exempted,no charge,goto NEXT DAY
156 . Q:IBCOMPEN=1 ;............................>>>>QUIT - GO to NEXT DAY
157 . ;
158 . ; 5. LTC outpatient visit
159 . ;check if vet has a LTC outpatient visit
160 . S IB40968=+$O(IBVISIT("L",0))
161 . I IB40968>0 D
162 . . ;look for and cancel Means Test Outpatient charges for this date
163 . . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
164 . . ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
165 . . ; 1 - if exempted, don't charge the patient
166 . . I $$EXEMPT21^IBAECU4(IBCLKIEN)=1 D Q
167 . . . ;add new exempt day to LTC clock
168 . . . D ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
169 . . ; otherwise no 21 clock exemption - cretae a charge
170 . . ;get rate for LTC visit on this date
171 . . S IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(1,+$G(IBVISIT("L",IB40968)),IBDATE)_"^"_$P($G(IBVISIT("L",IB40968)),"^",2)
172 . . S IBCHRG("A",IBDAY,"T")="1^"_IB40968_"^"_$$MKDATE^IBAECU4(IBMDS(2),IBDAY) ;outpatient
173 . . S IBCHRG=IBCHRG+1
174 . Q
175 ;=============================================================
176 I IBCLKIEN=0 Q -1 ;error
177 ;return month copay
178 S IBCMCA=$$CLCK180(IBDFN,$S(IBSTART>IBMDS(0):IBSTART,1:IBMDS(0)),IBMDS(1),"IBMJINP")
179 ; create charges for
180 ; check expiration date,etc of 21 clock
181 I IBCHRG>0 D SEND2AR^IBAECU5(IBDFN,.IBCHRG,.IBMDS,+IBCMCA)
182 ;clock adjustment
183 D CLCKADJ^IBAECU4("P",IBCLKIEN,IBDFN,IBLDINP,IBMDS(1))
184 D CLEAN^IBAECM1(IBDFN)
185 Q IBCHRG
186 ;
187 ;returns "max_monthly_calculated_copay"^"is_181+_case"
188 ;determine 181+ case (takes care about 30 days "gap" between
189 ;prior 181+ and current admission)
190CLCK180(IBDFN,IBBEGDT,IBENDDT,IBLBL) ;
191 ;array for adm info
192 N IBLNGADM,IBADMINF,IBRET1,IBCMC,IS180CLK,IBFL5,IB30BACK
193 S IBADMINF="^"
194 ; if we have active admission that started before IBMDS(0) then
195 ; What is the length of this admission?
196 ; we need IBLNGADM to call $$COPAY^EASECCAL; If there is
197 ; no admission started before IBMDS(0) then sets IBLNGADM=1
198 S IBLNGADM=$$DAYS180^IBAECM1(IBBEGDT,IBENDDT,IBDFN,IBLBL,.IBADMINF)
199 ; if none then check if another admission 30 days before (see SDD)
200 I IBLNGADM=1 D
201 . S IBFL5=$$ISLTC^IBAECU5(IBDFN,IBLBL)
202 . Q:IBFL5=0
203 . K ^TMP($J,"180DAYS")
204 . S IB30BACK=$$CHNGDATE^IBAECU4(IBFL5,-30)
205 . I $$INPINFO^IBAECU2(IB30BACK,IBFL5,IBDFN,"180DAYS",1)=0 Q
206 . K IBADMINF S IBADMINF="^"
207 . S IBLNGADM=$$DAYS180^IBAECM1(IB30BACK,IBFL5,IBDFN,"180DAYS",.IBADMINF)
208 ; get patient status
209 S IBRET1=$$LTCST^IBAECU(IBDFN,IBENDDT,IBLNGADM)
210 ;calculate a proper LTC Monthly Copay Amount and put it in IBCMC
211 ;(max amount patient should pay monthly)
212 ;IS180CLK =1 if patient has >180 days of continious LTC
213 S IS180CLK=$$MONTHMAX^IBAECM1(IBDFN,.IBADMINF,IBRET1,IBLNGADM,.IBCMC)
214 K ^TMP($J,"180DAYS")
215 Q +IBCMC_"^"_IS180CLK
216 ;
Note: See TracBrowser for help on using the repository browser.