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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1IBCEMSR ;WOIFO/AAT - MRA STATISTICS REPORT ;09/03/04
2 ;;2.0;INTEGRATED BILLING;**155,288,294,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ;
6 N IBQ,IBDIV,IBBDT,IBEDT,IBSUM,IBSCR
7 W !!,"Report requires 132 Columns"
8 S IBQ=0 ; quit flag
9 ; Prompts to the user:
10 D DIV Q:IBQ ; Division(s)
11 D SUM Q:IBQ ; Summary only?
12 W !!,"Normal processing time for a MRA is 10-12 days. If you select a date range of"
13 W !,"less than 2 weeks, do not expect to have received many MRAs."
14 D DTR Q:IBQ ; From-To date range
15 D DEVICE Q:IBQ
16 D RUN
17 Q
18 ;
19DIV N DIC,DIR,DIRUT,Y
20 W ! S DIR("B")="ALL",DIR("A")="Run this report for All divisions or Selected Divisions: "
21 S DIR(0)="SA^ALL:All divisions;S:Selected divisions" D ^DIR
22 I $D(DIRUT) S IBQ=1 Q
23 S IBDIV=Y Q:Y="ALL"
24 ; Collect divisions
25 F D Q:Y'>0
26 . W ! S DIC("A")="Division: ",DIC=40.8,DIC(0)="AEQM" D ^DIC
27 . I $D(DIRUT) S IBQ=1 Q
28 . I Y'>0 Q
29 . S IBDIV(+Y)=""
30 I $O(IBDIV(""))="" S IBQ=1 Q ; None selected
31 Q
32 ;
33DTR ;date range
34 N %DT,Y
35 S (IBBDT,IBEDT)=DT
36 S %DT="AEX"
37 S %DT("A")="Start with MRA Request Transmission Date: " ; No default,%DT("B")="TODAY"
38 W ! D ^%DT K %DT
39 I Y<0 S IBQ=1 Q
40 S IBBDT=+Y
41 S %DT="AEX"
42 S %DT("A")="Go to MRA Request Transmission Date: ",%DT("B")="TODAY"
43 D ^%DT K %DT
44 I Y<0 S IBQ=1 Q
45 S IBEDT=+Y
46 Q
47 ;
48SUM N DIR,DIRUT,Y
49 W ! S DIR("B")="YES",DIR("A")="Do you want to print a summary only? "
50 S DIR(0)="YA" D ^DIR
51 I $D(DIRUT) S IBQ=1 Q
52 S IBSUM=+Y
53 Q
54 ;
55DEVICE N %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
56 K IO("Q")
57 S %ZIS="QM"
58 W ! D ^%ZIS
59 I POP S IBQ=1 Q
60 S IBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
61 ;
62 I $D(IO("Q")) D S IBQ=1
63 . S ZTRTN="RUN^IBCEMSR"
64 . S ZTIO=ION
65 . S ZTSAVE("IB*")=""
66 . S ZTDESC="IB MRA STATISTICS REPORT"
67 . D ^%ZTLOAD
68 . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
69 . D HOME^%ZIS
70 U IO
71 Q
72 ;
73 ;
74RUN N REF
75 S REF=$NA(^TMP($J,"IBCEMSR"))
76 K @REF
77 D COLLECT ; Collect the data in ^TMP
78 U IO
79 D REPORT^IBCEMSR1
80 I 'IBSCR W !,@IOF
81 D ^%ZISC
82 K @REF
83 Q
84 ;
85COLLECT ; Collect Information
86 ; Input: IBDIV, IBBDT,IBEDT
87 N IBDT,IBBAT,IBTRAN,IBZ,MRAUSR,NUMDIV,IBDV,ALLDIV
88 S IBDV=0 F NUMDIV=0:1 S IBDV=$O(IBDIV(IBDV)) Q:'IBDV
89 S ALLDIV=" "
90 I IBDIV="ALL" S ALLDIV=" *** ALL DIVISIONS ***"
91 I NUMDIV>1 S ALLDIV=" *** ALL SELECTED DIVISIONS ***"
92 ;
93 S MRAUSR=$$MRAUSR^IBCEMU1() ;Auto-authorizer
94 S IBDT=IBBDT-.000001
95 F S IBDT=$O(^IBA(364.1,"ALT",IBDT)) Q:'IBDT Q:IBDT\1>IBEDT D
96 . S IBBAT=0 F S IBBAT=$O(^IBA(364.1,"ALT",IBDT,IBBAT)) Q:'IBBAT D
97 .. S IBTRAN=0 F S IBTRAN=$O(^IBA(364,"C",IBBAT,IBTRAN)) Q:'IBTRAN D
98 ... S IBZ=$G(^IBA(364,IBTRAN,0)) Q:IBZ=""
99 ... N IBIFN,IBSTAT,IBSEQ,IBBILZ,IBBILST,IBFORM,IBCLERK,IBDV,IBDVN,REFX,REFS,REFT,REFTX,MRACNT,IBREJECT
100 ... S IBIFN=+IBZ
101 ... I '$P($G(^DGCR(399,IBIFN,"S")),U,7) Q ; no MRA request
102 ... S IBSTAT=$P(IBZ,U,3)
103 ... S IBSEQ=$P(IBZ,U,8) Q:"T"[IBSEQ
104 ... I '$$WNRBILL^IBEFUNC(IBIFN,IBSEQ) Q ; payer sequence must be Medicare for this transmission
105 ... S IBBILZ=$G(^DGCR(399,IBIFN,0))
106 ... S IBBILST=$P(IBBILZ,U,13)
107 ... S IBFORM=+$P(IBBILZ,U,19)
108 ... I IBFORM'=2,IBFORM'=3 Q ; not 1500 or UB
109 ... S IBCLERK=+$P($G(^DGCR(399,IBIFN,"S")),U,8) ; Who requested MRA?
110 ... S IBCLERK=$P($G(^VA(200,IBCLERK,0)),U)
111 ... S:IBCLERK="" IBCLERK="UNKNOWN"
112 ... S IBDV=+$P(IBBILZ,U,22) ; Default division
113 ... S IBDVN=$P($G(^DG(40.8,IBDV,0)),U) ; Div name
114 ... S:IBDVN="" IBDVN="UNKNOWN"
115 ... I IBDIV'="ALL",'$D(IBDIV(IBDV)) Q ;Division filter
116 ... I 'IBSUM S REFX=$NA(@REF@(IBDVN,IBCLERK,IBFORM)) I NUMDIV'=1 S REFTX=$NA(@REF@(ALLDIV,IBCLERK,IBFORM)) ; all divisions detail
117 ... S REFS=$NA(@REF@(IBDVN,0,IBFORM)) ; Summary by division
118 ... I NUMDIV'=1 S REFT=$NA(@REF@(ALLDIV,0,IBFORM)) ; all divisions
119 ... D TXSTS^IBCEMU2(IBIFN,IBTRAN,.IBREJECT) ; rejected?
120 ... S MRACNT=$$MRACNT^IBCEMU1(IBIFN) ; how many MRAs?
121 ... D INC("ALL") ; total no of requests
122 ... I IBSTAT="C" D INC("ALLC") ;cancelled
123 ... I IBSTAT="R" D INC("ALLR") ;resubmitted
124 ... I '$D(@REFS@("TOT",IBIFN)) S ^(IBIFN)="" D INC("TOT") ;unique requests
125 ... ;no response?
126 ... I 'IBREJECT,'MRACNT,'$D(@REFS@("NON",IBIFN)) S ^(IBIFN)="" D INC("NON")
127 ... ;final reject?
128 ... I 'MRACNT,IBREJECT,'$D(@REFS@("REJF",IBIFN)),IBTRAN=$$LAST364^IBCEF4(IBIFN) D
129 .... S @REFS@("REJF",IBIFN)="" D INC("REJF")
130 .... ; MRA?
131 ... I MRACNT,'$D(@REFS@("MRA",IBIFN)) S ^(IBIFN)="" D
132 .... D INC("MRA")
133 .... I $$DENIED(IBIFN) D INC("MRAD")
134 ... ;any secondary claims?
135 ... D SECOND
136 Q
137 ;
138INC(NODE,VALUE) ;Increase the respective value in ^TMP
139 I 'IBSUM D
140 . S @REFX@(NODE)=$G(@REFX@(NODE))+$G(VALUE,1)
141 . I $D(REFTX) S @REFTX@(NODE)=$G(@REFTX@(NODE))+$G(VALUE,1)
142 . Q
143 S @REFS@(NODE)=$G(@REFS@(NODE))+$G(VALUE,1)
144 I $D(REFT) S @REFT@(NODE)=$G(@REFT@(NODE))+$G(VALUE,1)
145 Q
146 ;
147DENIED(IBIFN) ;MRA requests denied?
148 ; 361.1 for this bill#
149 ; if at least one request is 'processed' - MRA is NOT DENIED
150 N IBDEN,IEN,IBZ
151 S IBDEN=1
152 S IEN=0 F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D Q:'IBDEN
153 . S IBZ=$G(^IBM(361.1,IEN,0))
154 . I $P(IBZ,U,4)'=1 Q ; only MEDICARE
155 . I $P(IBZ,U,13)=1 S IBDEN=0
156 Q IBDEN
157 ;
158SECOND ;Secondary claims
159 N IBAUT,IBTX,IBCBPS,IBNEXT,IBBILS,IBTOT,IBUNR,IB2ND,IBNODE
160 I $D(@REFS@("SEC",IBIFN)) Q ; Already included
161 S IBCBPS=$P(IBBILZ,U,21) ; current bill sequence
162 S IBNEXT=$S(IBSEQ="S":"T",1:"S") ;Next (after MRA) sequence
163 I IBCBPS'=IBNEXT Q
164 ; Number of unique sec claims
165 S @REFS@("SEC",IBIFN)=""
166 D INC("SEC")
167 S IBBILS=$G(^DGCR(399,IBIFN,"S")) Q:'$P(IBBILS,U,10) ; Not even authorized
168 ; Authorized but not yet printed?
169 I $P(IBBILS,U,10),'$P(IBBILS,U,13) D Q
170 . I +$$TXMT^IBCEF4(IBIFN)'=1 D INC("AUT") ; Exclude transmittable
171 ; Check the field 'AUTHORIZER'
172 S IBAUT=($P(IBBILS,U,11)=MRAUSR) ; Auto-authorized?
173 S IBTX=$$TRANSM(IBIFN,IBNEXT) ; Transmitted? (present in 364?)
174 I IBAUT,IBTX S IBNODE="AT" ; Auto-gen Tx
175 I 'IBAUT,IBTX S IBNODE="MT" ; Manually Tx
176 I IBAUT,'IBTX S IBNODE="AP" ; Auto-gen Prn
177 I 'IBAUT,'IBTX S IBNODE="MP" ; Manually Prn
178 ;
179 ;Calculate amounts
180 S IBTOT=+$G(^DGCR(399,IBIFN,"U1"))
181 S IBUNR=$P($G(^PRCA(430,IBIFN,13)),U,2) ; Medicare Unreimbursable
182 S IB2ND=$$PREOBTOT^IBCEU0(IBIFN)
183 D INC(IBNODE)
184 D INC(IBNODE_"1",IBTOT)
185 D INC(IBNODE_"2",IBUNR)
186 D INC(IBNODE_"3",IB2ND)
187 Q
188 ;
189TRANSM(IBIFN,IBSEQ) ;was the claim ever transmitted?
190 ; Does the claim present in 364?
191 N RES,IBI
192 S RES=0
193 S IBI="" F S IBI=$O(^IBA(364,"B",IBIFN,IBI),-1) Q:IBI="" D Q:RES
194 . I $P($G(^IBA(364,IBI,0)),U,8)=IBSEQ S RES=1
195 Q RES
196 ;
Note: See TracBrowser for help on using the repository browser.