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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1IBCEMU2 ;ALB/DSM - IB MRA Utility ;01-MAY-2003
2 ;;2.0;INTEGRATED BILLING;**155,320,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6 ;
7QMRA ; This is a background procedure that is spun off of the IB BATCH
8 ; Print option. This process scans a queue in ^XTMP("IBMRA"_#,$J) and checks
9 ; each Bill to see if a printable MRA exist, if so, prints them. MRA's print
10 ; on the device associated with the 'Bill Addendum' Form Type.
11 ; This process doesn't interact with users.
12 ;
13 ; IB*2*320: MCS - Resubmit by Print produces a scratch global also
14 ; ^XTMP("IBCFP6",$J,.... for MRA's to print here
15 ;
16 ; Input:
17 ; IBJ = $J of starting job
18 ; IBFTP = "IBMRA"_# (ien of form type) or "IBCFP6"
19 ;
20 N IBS1,IBS2,IBS3,IBIFN,IBQ,IBPGN
21 S (IBS1,IBIFN,IBQ)=0
22 F S IBS1=$O(^XTMP(IBFTP,IBJ,IBS1)) Q:IBS1="" D I IBQ Q
23 . S IBS2=0 F S IBS2=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2)) Q:IBS2="" D I IBQ Q
24 . . S IBS3=0 F S IBS3=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3)) Q:IBS3="" D I IBQ Q
25 . . . S IBIFN=0 F S IBIFN=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3,IBIFN)) Q:IBIFN="" D I $$STOP S IBQ=1 Q
26 . . . . I $$MRAEXIST^IBCEMU1(IBIFN) D PROC^IBCEMRAA W @IOF ;must have IBIFN set
27 K ^XTMP(IBFTP,IBJ) S ZTREQ="@"
28 Q ;QMRA
29 ;
30STOP() ;determine if user has requested the queued report to stop
31 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
32 Q +$G(ZTSTOP)
33 ;
34 ;
35STAT(IBIFN,STATUS,MRAONLY) ; Update the review status in the EOB file
36 ; This procedure updates field .16 in file 361.1 for all EOB's for
37 ; the given bill#
38 ;
39 ; IBIFN - Internal Bill# (required)
40 ; STATUS - Internal Value of the Review Status field (required)
41 ; MRAONLY - Optional Flag with a default of 0 if not passed in
42 ; 1:only update MRA EOB's for this bill
43 ; 0:update all EOB's for this bill
44 ;
45 NEW RESULT,IBEOB,IBM
46 NEW DIE,DA,DR,D,D0,DI,DIC,DICR,DIG,DIH,DISYS,DIU,DIV,DIW,DQ,DIERR,X,Y
47 S IBIFN=+$G(IBIFN),STATUS=$G(STATUS)
48 S MRAONLY=$G(MRAONLY,0)
49 ;
50 I '$D(^IBM(361.1,"B",IBIFN)) G STATX ; no EOB's for this bill
51 D CHK^DIE(361.1,.16,,STATUS,.RESULT)
52 I RESULT="^" G STATX ; invalid status passed in
53 ;
54 S IBEOB=0 ; loop thru all EOB's for the bill
55 F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D
56 . S IBM=$G(^IBM(361.1,IBEOB,0))
57 . I $P(IBM,U,16)=STATUS Q ; no change
58 . I MRAONLY,'$P(IBM,U,4) Q ; skip because of parameter
59 . S DIE=361.1,DA=IBEOB,DR=".16////"_STATUS D ^DIE
60 . Q
61 ;
62STATX ;
63 Q
64 ;
65MRAWL(IBIFN) ; Do any MRA EOB's for this bill appear on the worklist?
66 ;
67 ; This function returns 1 if at least one MRA EOB for the given bill
68 ; appears on the MRA management worklist. Otherwise, this function
69 ; returns 0.
70 ;
71 NEW OK,IBEOB
72 S OK=0,IBIFN=+$G(IBIFN)
73 I '$D(^IBM(361.1,"B",IBIFN)) G MRAWLX ; no EOB's for this bill
74 S IBEOB=0 ; loop thru all EOB's for the bill
75 F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D Q:OK
76 . I $$ELIG^IBCECOB1(IBEOB) S OK=1
77 . Q
78MRAWLX ;
79 Q OK
80 ;
81TXSTS(IBIFN,IB364,REJFLG,IBZ) ; Claim transmission status information
82 ; Input IBIFN - required
83 ; IB364 - optional (defaults to most recent transmission#)
84 ; Output REJFLG (pass by reference) - 1/0 flag if any rejection status
85 ; messages on file
86 ; IBZ (pass by reference) - array of information
87 ;
88 NEW IEN,SMCNT,SEV,BCH,BCHD0,BCHD1
89 S REJFLG=0 K IBZ
90 S IBIFN=+$G(IBIFN) I 'IBIFN G TXSTSX
91 S IB364=+$G(IB364)
92 I 'IB364 S IB364=$$LAST364^IBCEF4(IBIFN) I 'IB364 G TXSTSX
93 I $P($G(^IBA(364,IB364,0)),U,1)'=IBIFN G TXSTSX
94 S IEN=0,SMCNT=0
95 F S IEN=$O(^IBM(361,"AERR",IB364,IEN)) Q:'IEN D
96 . S SMCNT=SMCNT+1
97 . S SEV=$P($G(^IBM(361,IEN,0)),U,3) ; status message severity
98 . I SEV="R" S REJFLG=1
99 . Q
100 S BCH=+$P($G(^IBA(364,IB364,0)),U,2) ; batch ien
101 S BCHD0=$G(^IBA(364.1,BCH,0))
102 S BCHD1=$G(^IBA(364.1,BCH,1))
103 S IBZ("DATE LAST SENT")=$P(BCHD1,U,3)
104 S IBZ("NUMBER OF STATUS MESSAGES")=SMCNT
105 S IBZ("BATCH NUMBER")=$P(BCHD0,U,1)
106 S IBZ("TRANSMISSION STATUS")=$P($G(^IBA(364,IB364,0)),U,3)
107TXSTSX ;
108 Q
109 ;
110MRACALC(IBEOB,IBIFN,AR,PRCASV) ; Calculates Two Amounts:
111 ; Unreimbursable Medicare Expense and Medicare Contract Adjustment
112 ; Amount for a given EOB.
113 ;
114 ; Input IBIFN= ien of Claim file 399 - Required
115 ; IBEOB= ien of EOB file 361.1 - Required
116 ; AR= Flag indicating this was called from AR function
117 ; Input/Output PRCASV= array with the two calculated values
118 ; PRCASV("MEDURE")=Unreimbursable Medicare Expense
119 ; PRCASV("MEDCA")=Medicare Contract Adjustment Amount
120 ;
121 ; For multiple EOB's, add up the calculated values across EOB's
122 ;
123 N I,LNLVL,EOBADJ,IBCOBN,INPAT,FRMTYP
124 ;
125 S FRMTYP=$$FT^IBCEF(IBIFN) ;Form Type 2=1500; 3=UB
126 S INPAT=$$INPAT^IBCEF(IBIFN) ;Inpat/Outpat Flag
127 S AR=$G(AR,0) ;initialize AR flag
128 F I=0,1,2 S IBEOB(I)=$G(^IBM(361.1,IBEOB,I))
129 I $P(IBEOB(0),U,4)'=1 Q ;make sure it's an MRA
130 S IBCOBN=$$COBN^IBCEF(IBIFN) ;get current bill sequence
131 ; Make sure we're on the right insurance sequence when AR flag is on
132 I AR I $P(IBEOB(0),U,15)'=(IBCOBN-1) Q
133 ;
134 ; Unreimburseable Medicare Expense (same calc regardless of form type)
135 ; For multiple EOB's, add up the amounts across EOB's
136 S PRCASV("MEDURE")=$G(PRCASV("MEDURE"))+IBEOB(1)
137 ;
138 ; Handle CMS-1500 Form Type Next:
139 I FRMTYP=2 D MEDCARE(IBEOB,.PRCASV) Q
140 ;
141 ; Handle UB Form Type Next:
142 ; If Inpatient Calculate from Claim level data
143 I INPAT D Q ;
144 . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
145 . S PRCASV("MEDCA")=$G(PRCASV("MEDCA"))+$$CALCMCA(.EOBADJ)
146 ;
147 ; If Outpatient Calculate from Service Line level data
148 D MEDCARE(IBEOB,.PRCASV)
149 Q ;MRACALC
150 ;
151MEDCARE(IBEOB,PRCASV) ; If Outpatient Calculate from Service Line level data
152 N LNLVL,EOBADJ
153 S LNLVL=0
154 F S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL D ;
155 . K EOBADJ
156 . M EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1)
157 . ; Total up the Medicare Contract Adjustment across ALL Service Lines
158 . S PRCASV("MEDCA")=$G(PRCASV("MEDCA"))+$$CALCMCA(.EOBADJ)
159 Q ;MEDCARE
160 ;
161CALCMCA(EOBADJ) ; FUNCTION - Calculate Medicare Contract Adjustment
162 ; Sums up Amounts on ALL Reason Codes under ALL Group Codes = 'CO' and
163 ; returns that value (which is Medicare Contract Adjustment).
164 ;
165 ; Input EOBADJ = Array of Group Codes & Reason Codes from either the Claim
166 ; Level (10) or Service Line Level (15) of EOB file (#361.1)
167 ; Output returns Medicare Contract Adjustment
168 ;
169 N GRPLVL,RSNLVL,RSNAMT,MCA
170 S (GRPLVL,MCA)=0
171 F S GRPLVL=$O(EOBADJ(GRPLVL)) Q:'GRPLVL D ;
172 . I $P($G(EOBADJ(GRPLVL,0)),U)'="CO" Q
173 . S RSNLVL=0
174 . F S RSNLVL=$O(EOBADJ(GRPLVL,1,RSNLVL)) Q:'RSNLVL D ;
175 . . S RSNAMT=$P($G(EOBADJ(GRPLVL,1,RSNLVL,0)),U,2)
176 . . S MCA=MCA+RSNAMT
177 Q MCA ;CALCMCA
178 ;
179ALLOWED(IBEOB) ; Returns Total Allowed Amount by summing up all Allowed Amounts
180 ; from Line Level Adjustment
181 ; Input: IBEOB = ien of EOB file (361.1)
182 ;
183 N LNLVL,LNLVLD,ALWD,TOTALWD
184 S (LNLVL,TOTALWD)=0
185 F S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL S LNLVLD=^(LNLVL,0) D
186 . S ALWD=$P(LNLVLD,U,13),TOTALWD=TOTALWD+ALWD ; Allowed Amount
187 Q TOTALWD ;ALLOWED
188 ;
189MRATYPE(BILL,ARDATE) ; Function - determines the MRA Receivable Type for a Third
190 ; Party Receivable. This is accomplished by comparing DATE MRA FIRST ACTIVATED
191 ; with AR Activation Date for the Bill.
192 ;
193 ; Input BILL= ien of a given Bill Number (Required)
194 ; ARDATE= Date Account Receivable was Activated - date only (Required)
195 ;
196 ; Output - Possible Types:
197 ; 1 = Pre-MRA implementation
198 ; 2 = Post MRA Medicare Receivable
199 ; 3 = Post MRA non-Medicare Receivable
200 ;
201 N MRADTACT,MRAMT
202 I '$G(ARDATE)!'$G(BILL) Q 1
203 ;
204 ; get DATE MRA FIRST ACTIVATED at site
205 S MRADTACT=$$MRADTACT()
206 ;
207 ; MRA not Activated at site
208 I MRADTACT="" Q 1 ;MRATYPE
209 ;
210 ; Bill from pre-MRA implementation era
211 I ARDATE<MRADTACT Q 1 ;MRATYPE
212 ;
213 ; Post-MRA Medicare bill; get Medicare amounts
214 S MRAMT=$G(^PRCA(430,BILL,13))
215 ; check Medicare Contractual Adjustment Amount
216 I $P(MRAMT,U,1) Q 2 ;MRATYPE
217 ; check Medicare Unreimburseable Amout
218 I $P(MRAMT,U,2) Q 2 ;MRATYPE
219 ; check if bill is a Medicare one
220 I $$MRAEXIST^IBCEMU1(BILL) Q 2 ;MRATYPE
221 ; check if bill is a Medicare Supplemental one
222 I $P($$CRIT^IBRFN2(BILL),U)=2 Q 2 ;MRATYPE
223 ;
224 ; all others are Post-MRA non-Medicare bills
225 Q 3 ;MRATYPE
226 ;
227MRADTACT() ; Function - returns DATE MRA FIRST ACTIVATED at site
228 Q $P($G(^IBE(350.9,1,8)),U,13)
229 ;
Note: See TracBrowser for help on using the repository browser.