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

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

initial load of WorldVistAEHR
File size: 7.1 KB
RevLine 
[613]1IBCEMRAB ;ALB/DSM - MEDICARE REMITTANCE ADVICE DETAIL-PART B ; 12/29/05 9:58am
2 ;;2.0;INTEGRATED BILLING;**155,323,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q ; this routine must be called at an entry point
6 ;
7 ; This routine prints MRA Report for CMS-1500 (Part B) Form Type
8PRNT ;
9 ; Claim Level Adjustments
10 N DIC,Y,IBEOB,IBILL,IBILLU,IBTD,IBFD,TOT,PRFRMID
11 D GDATA,HDR
12 ;
13 ; Initialize Totals
14 S (TOT("ALWD"),TOT("SRVDED"),TOT("SRVCOIN"),TOT("SRVADJ"),TOT("PAID"))=0
15 ;
16 ; Service Line Level Adjustments
17 I $D(^IBM(361.1,IEN,15)) D SRVPRNT I IBQUIT Q
18 ;
19 ; Print Totals Line
20 D TOTAL
21 ;
22 ; Print Disclaimer
23 D DSCLMR^IBCEMRAX
24 ;
25 Q ;PRNT
26 ;
27GDATA ; Get MRA data
28 ;
29 N I
30 F I=0,1,2,3,6 S IBEOB(I)=$G(^IBM(361.1,IEN,I))
31 S IBILL=$G(^DGCR(399,$P(IBEOB(0),U),0)),IBILLU=$G(^DGCR(399,$P(IBEOB(0),U),"U"))
32 S IBTD=$$FMTE^XLFDT($P(IBILLU,U),5),IBFD=$$FMTE^XLFDT($P(IBILLU,U,2),5)
33 Q ;GDATA
34 ;
35HDR ; Print Header
36 I $E(IOST,1,2)["C-" W @IOF
37 S IBPGN=IBPGN+1
38 ;
39 ; Row 1,2,3
40 W !,?102,"Medicare-equivalent",!?104,"Remittance Advice",!
41 ; Row 7
42 W !!!!,"DEPT OF VETERANS AFFAIRS"
43 ;
44 N PRVDR,LVL,STATE,LINE,PTNM,PTLEN,RMKS,HIC
45 ; Retrieve the Provider data from IB Site Parameters file - ^IBE(350.9)
46 S PRVDR=$G(^IBE(350.9,1,2))
47 ; ProviderName^AgentCashierAddress^City^State^Zip
48 ;
49 F LVL=1:1:5 S PRVDR(LVL)=$P(PRVDR,U,LVL)
50 ; PRVDR(1) Provider Name (Agent Cashier Mail Symbol)
51 ; PRVDR(2) Agent Cashier Street Address
52 ; PRVDR(3) Agent Cashier City
53 ; PRVDR(4) Agent Cashier State
54 ; PRVDR(5) Agent Cashier Zip
55 ;
56 ; resolve the State File Pointer in PRVDR(4) & get State Abbreviation
57 S STATE=$S(PRVDR(4)'="":$P($G(^DIC(5,PRVDR(4),0)),U,2),1:"")
58 ;
59 ; Row 8
60 W !,PRVDR(2),?97,"PROVIDER #:",?111,"VA0"_$P($$SITE^VASITE,U,3)
61 ; Row 9
62 W !,PRVDR(1),?97,"PAGE #:",?111,$J(IBPGN,3)
63 ; Row 10
64 W !,PRVDR(3),", ",STATE," ",PRVDR(5),?97,"DATE:",?111,$$FMTE^XLFDT($P(IBEOB(0),U,6),5)
65 ; Row 14
66 W !!!!,"PERF PROV",?12,"SERV DATE",?25,"POS",?29,"NOS",?34,"PROC",?40,"MODS",?53,"BILLED",?63,"ALLOWED",?75,"DEDUCT"
67 W ?87,"COINS",?93,"GRP-RC",?107,"AMT",?114,"PROV PD"
68 ; Row 15
69 S $P(LINE,"-",122)="" W !,LINE
70 ;
71 ; format and standardize patient name for display
72 S PTNM("FILE")=2,PTNM("IENS")=$P(IBILL,U,2),PTNM("FIELD")=.01,PTLEN=23
73 S PTNM=$$BLDNAME^XLFNAME(.PTNM,PTLEN)
74 I $P(IBEOB(6),U,1)'="" S PTNM=$E($P(IBEOB(6),U,1),1,PTLEN)
75 ;
76 S HIC=$S($P(IBEOB(6),U,2)'="":$P(IBEOB(6),U,2),$$WNRBILL^IBEFUNC(IBIFN,1):$P($G(^DGCR(399,$P(IBEOB(0),U),"I1")),U,2),1:$P($G(^DGCR(399,$P(IBEOB(0),U),"I2")),U,2))
77 ; Row 17
78 ; Patient Name, HIC, ACNT, ICN, ASG
79 W !!,"NAME",?7,PTNM,?31,"HIC",?35,HIC
80 W ?49,"ACNT",?54,$P($$SITE^VASITE,U,3),"-",$P(IBILL,U),?76,"ICN",?80,$P(IBEOB(0),U,14)
81 W ?97,"ASG",?101,$S($P(IBILLU,U,6):"Y",1:"N")
82 ;
83 ; MOA: Medicare Outpatient Remarks Code
84 S RMKS=$P(IBEOB(3),U,3,7) I RMKS="" S RMKS="^^^^"
85 W ?104,"MOA " I RMKS'?1."^" W $P(RMKS,U,1)," ",$P(RMKS,U,2)
86 I $P(RMKS,U,3,5)'?1."^" S RMKS=$TR(RMKS,U," ") W !,RMKS
87 ; Secondary Performing Provider ID
88 ; On CMS-1500 Form Type reports, If Medicare WNR is Primary or Secondary, then set Performing Provider ID
89 I $$WNRBILL^IBEFUNC(IBIFN,1)!$$WNRBILL^IBEFUNC(IBIFN,2) S PRFRMID="V"_$$MCRSPEC^IBCEU4(IBIFN,1)_$P($$SITE^VASITE,U,3)
90 Q ;HDR
91 ;
92SRVPRNT ; Print Service Level Data of EOB file (#361.1 Level 15)
93 ;
94 N LNLVL,RLVL,RLVLD,LNLVLD,SRVFDT,SRVTDT,UNIT,PRCD,MOD,I
95 N ALWD,GLVL,GLVLD,GRPCD,OPRCD,PAID,RCNT,SRMKS,SRVCOIN
96 N SRVDED,SRVADJ,SRVCHRG,SRVDT,CLMLN,Z
97 ;
98 ; RLVLD=reason_code^amount^quantity^reason text
99 S LNLVL=0
100 F S LNLVL=$O(^IBM(361.1,IEN,15,LNLVL)) Q:'LNLVL S LNLVLD=^(LNLVL,0) D I IBQUIT Q
101 . I ($Y+4)>IOSL D I IBQUIT Q
102 . . D PAUSE^IBCEMRAX I IBQUIT Q
103 . . W @IOF D HDR
104 . ; From Service Date, To Service Date
105 . S SRVFDT=$P(LNLVLD,U,16),SRVTDT=$P(LNLVLD,U,17)
106 . S SRVFDT=$$FMTE^XLFDT(SRVFDT,5),SRVTDT=$$FMTE^XLFDT(SRVTDT,5)
107 . ; Get Units, Procedure Code, Original Procedure Code
108 . S UNIT=$P(LNLVLD,U,11),PRCD=$P(LNLVLD,U,4),OPRCD=$P(LNLVLD,U,15)
109 . S PAID=$P(LNLVLD,U,3),TOT("PAID")=TOT("PAID")+PAID ; Provider Paid Amount
110 . S ALWD=$P(LNLVLD,U,13),TOT("ALWD")=TOT("ALWD")+ALWD ; Allowed Amount
111 . ; Handle Multiple Paid Modifiers from the Service Line Level - string together
112 . K MOD M MOD=^IBM(361.1,IEN,15,LNLVL,2) S MOD="" F I=1:1:4 Q:'$D(MOD(I)) S MOD=MOD_MOD(I,0)
113 . ; Calculate Submitted Service Line Charge
114 . S CLMLN=$P(LNLVLD,U,12) ; use to match EOB line # to VistA Bill line#
115 . S SRVCHRG=$P($G(IBZDATA(CLMLN)),U,8)*$P($G(IBZDATA(CLMLN)),U,9)
116 . ; Service Line Level Remarks Codes
117 . S Z=0 F S Z=$O(^IBM(361.1,IEN,15,LNLVL,4,Z)) Q:'Z I $G(^(Z,0))'="" S SRMKS(Z)=$P(^(0),U,2)
118 . ; Get Service Level Group Code/Reason Code Data
119 . S (SRVDED,GLVL,RCNT,SRVCOIN)=0 K RSNCD
120 . F S GLVL=$O(^IBM(361.1,IEN,15,LNLVL,1,GLVL)) Q:'GLVL S GLVLD=^(GLVL,0) D ;
121 . . S GRPCD=$P(GLVLD,U),RLVL=0
122 . . F S RLVL=$O(^IBM(361.1,IEN,15,LNLVL,1,GLVL,1,RLVL)) Q:'RLVL S RLVLD=^(RLVL,0),RSNCD=$P(RLVLD,U) D ;
123 . . . I GRPCD="PR",RSNCD="AAA" Q ;exception
124 . . . I GRPCD="OA",RSNCD="AB3" Q ;exception
125 . . . I GRPCD="LQ" Q ;exception
126 . . . I GRPCD="PR",RSNCD=1 S SRVDED=SRVDED+$P(RLVLD,U,2),TOT("SRVDED")=TOT("SRVDED")+SRVDED Q ;deductible
127 . . . I GRPCD="PR",RSNCD=2 S SRVCOIN=$P(RLVLD,U,2),TOT("SRVCOIN")=TOT("SRVCOIN")+SRVCOIN Q ;coinsurance
128 . . . S SRVADJ=$P(RLVLD,U,2),TOT("SRVADJ")=TOT("SRVADJ")+SRVADJ ;adjustment
129 . . . S RCNT=RCNT+1,RSNCD(RCNT)=GRPCD_"-"_RSNCD_U_SRVADJ
130 . ; Performing Provider ID
131 . W !,$G(PRFRMID)
132 . ; From Date in MMDD (w/leading zero) format
133 . I SRVFDT'="" S SRVDT=$E("00",1,2-$L(+SRVFDT))_+SRVFDT_$E("00",1,2-$L($P(SRVFDT,"/",2)))_$P(SRVFDT,"/",2) W ?12,SRVDT
134 . ; To Date in MMDDYY (w/leading zero) format
135 . I SRVTDT'="" W ?17,$E("00",1,2-$L(+SRVTDT)),+SRVTDT,$E("00",1,2-$L($P(SRVTDT,"/",2))),$P(SRVTDT,"/",2),$E($P(SRVTDT,"/",3),3,4)
136 . ; If To Date is Null, Print From Date with year (if not Null)
137 . I SRVTDT="",SRVFDT'="" W ?17,SRVDT,$E($P(SRVFDT,"/",3),3,4)
138 . ; Place of Service - from 837 Extract from CMS-1500 Service Line Level
139 . W ?25,$P($G(IBZDATA(CLMLN)),U,3)
140 . ; Print Units, Procedure Code Paid, Modifiers, Submitted Line Charge, Allowed Amt, Deductable, Coinsurance
141 . W ?28,UNIT,?34,PRCD,?40,MOD,?49,$J(SRVCHRG,10,2),?60,$J(ALWD,10,2),?71,$J(SRVDED,10,2),?82,$J(SRVCOIN,10,2)
142 . ; Print 1st Line of Group Code-Reason Code, Adjustment Amount, Paid Amount
143 . W ?93,$P($G(RSNCD(1)),U),?100,$J($P($G(RSNCD(1)),U,2),10,2),?111,$J(PAID,10,2)
144 . ; print PRCD Submitted, Remarks if any
145 . I OPRCD'=""!$O(SRMKS(0)) W ! D ;
146 . . I OPRCD'="" W ?33,"(",OPRCD,")"
147 . . I $O(SRMKS(0)) W ?44,"REM: " S Z=0 F S Z=$O(SRMKS(Z)) Q:'Z W SRMKS(Z),$S($O(SRMKS(Z)):",",1:"")
148 . ; Print the rest of Group Code-Reason Code, Reason Code Amount
149 . F I=2:1:RCNT W !?93,$P(RSNCD(I),U),?100,$J($P(RSNCD(I),U,2),10,2)
150 Q ;SRVPRNT
151 ;
152TOTAL ; Print Totals
153 W !!,"PT RESP ",$J($P($G(IBEOB(1)),U,2),10,2) ;Patient Responsibility
154 ; Billed Amount, Allowed Amount, Deductable Amount
155 W ?35,"CLAIM TOTAL",?49,$J($P($G(IBEOB(2)),U,4),10,2),?60,$J(TOT("ALWD"),10,2),?71,$J(TOT("SRVDED"),10,2)
156 ; Coinsurance Amount, Adjustment Amount, Paid Amount
157 W ?82,$J(TOT("SRVCOIN"),10,2),?100,$J(TOT("SRVADJ"),10,2),?111,$J(TOT("PAID"),10,2)
158 Q ;TOTAL
159 ;
Note: See TracBrowser for help on using the repository browser.