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

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

initial load of WorldVistAEHR
File size: 7.9 KB
Line 
1IBCECSA5 ;ALB/CXW - VIEW EOB SCREEN ;01-OCT-1999
2 ;;2.0;INTEGRATED BILLING;**137,135,263,280,155,349**;21-MAR-1994;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ; -- main entry point for VIEW EOB
6 N VALMCNT,VALMBG,VALMHDR
7 S VALMCNT=0,VALMBG=1
8 D EN^VALM("IBCEM VIEW EOB")
9 Q
10 ;
11INIT ; -- init variables and list array
12 I '$G(IBIFN) S VALMQUIT="" G INITQ ; bill# is required
13 D HDR^IBCEOB2 ; build the VALMHDR array
14 K IBCNT,IBONE,^TMP("IBCECSD",$J) ; kill vars and scratch global
15 ;
16 ; 8/13/03 - If variable IBEOBIFN is set, then this is the 361.1 ien
17 ; that the user selected from a list. Build the detail.
18 I $G(IBEOBIFN) S IBCNT=IBEOBIFN,IBONE=1 D BLD^IBCECSA6 G INITQ
19 ;
20 D BLD^IBCEOB2 ; build ^TMP("IBCEOB",$J) containing MRA/EOB lister
21 S IBONE=0
22 M ^TMP("IBCECSD",$J)=^TMP("IBCEOB",$J)
23 ;
24 ; 4/7/03 - If only 1 EOB record found for this bill, then set the
25 ; IBCNT variable, the IBONE one-time flag, and build the
26 ; detail sections of this list.
27 I $G(VALMCNT)=1 S IBCNT=$P($G(^TMP("IBCECSD",$J,1)),U,2),IBONE=1 I IBCNT D BLD^IBCECSA6
28 ;
29INITQ Q
30 ;
31HELP ; -- help code
32 S X="?" D DISP^XQORM1 W !!
33 Q
34 ;
35EXIT ; -- exit code
36 K ^TMP("IBCECSD",$J)
37 D CLEAR^VALM1,CLEAN^VALM10
38 Q
39MIN ;
40 N IBREC1,IBRM1,IBRM2,IBRM3,IBRM4,IBRM5,IBRL,IBTYPE,IBT,IBTX,IBD
41 ; flag for inpatient mra
42 S IBTYPE=$S($G(IBSRC):1,$$INPAT^IBCEF(+IBREC):1,1:0)
43 ;
44 S IB=$$SETSTR^VALM1("MEDICARE INFORMATION:","",1,50)
45 D SET(IB)
46 I '$G(IBSRC) D
47 . D CNTRL^VALM10(VALMCNT,1,21,IORVON,IORVOFF)
48 . S ^TMP("IBCECSD",$J,"X",5)=VALMCNT
49 I $G(IBSRC),'$D(^IBM(361.1,IBCNT,4)) Q
50 I '$G(IBSRC),'$$INPAT^IBCEF(+IBREC) Q
51 D SET(" INPATIENT:")
52 S IBREC1=$G(^IBM(361.1,IBCNT,4)),(IB,IBRL)=""
53 ;
54 F IBT=2:1 S IBTX=$P($T(MINDAT+IBT),";",3) Q:IBTX="" D
55 . S IBD=$P(IBREC1,"^",+IBTX)
56 . I $L($P(IBTX,"^",4)) X $P(IBTX,"^",4) E N IBFULL S IBFULL=1
57 . I $S(IBFULL:1,1:IBD) D
58 .. I $L($P(IBTX,"^",4)) X $P(IBTX,"^",4) I Q
59 .. X "S IBD="_$S($L($P(IBTX,"^",3)):$P(IBTX,"^",3),1:"$$A10(IBD)")
60 .. S IB=$$SETSTR^VALM1($P(IBTX,"^",2)_IBD,IB,$S('IBRL:4,1:37),$S('IBRL:41,1:38))
61 .. S IBRL=$S(IBRL:0,1:1)
62 .. I 'IBRL D SET(IB,IBRL) S IB=""
63 ;
64 D:IBRL'="" SET(IB)
65 D REMARK
66 Q
67 ;
68MINDAT ; data for MIN tag
69 ; format: piece^lable^special format code^special decision for disp
70 ;;1^Cov Days/Visit Ct : ^$$RJ(+IBD)^I $G(IBSRC)
71 ;;3^Claim DRG Amt :
72 ;;2^Lifetm Psych Dy Ct : ^$$RJ(IBD)
73 ;;5^Disprop Share Amt : ^^I IBTYPE
74 ;;4^Cap Exception Amt :
75 ;;7^PPS Capital Amt : ^^I IBTYPE
76 ;;6^MSP Pass Thru Amt :
77 ;;9^PPS Cap HSP-DRG Amt: ^^I IBTYPE
78 ;;8^PPS Cap FSP-DRG Amt: ^^I IBTYPE
79 ;;11^Old Capital Amt : ^^I IBTYPE
80 ;;10^PPS Cap DSH-DRG Amt: ^^I IBTYPE
81 ;;13^PPS Op Hos DRG Amt :
82 ;;12^PPS Capital IME Amt: ^^I IBTYPE
83 ;;15^PPS Op Fed DRG Amt : ^^I IBTYPE
84 ;;14^Cost Report Day Ct : ^$$RJ(IBD)^I IBTYPE
85 ;;17^Indirect Teach Amt : ^^I IBTYPE
86 ;;16^PPS Cap Outlier Amt: ^^I IBTYPE
87 ;;18^Non-Pay Prof Comp : ^$$RJ(IBD)
88 ;;19^Non-Covered Days Ct: ^$$RJ(+IBD)^I IBTYPE
89 ;;
90 ;
91REMARK ; set up remarks and line level details
92 N IBREC1,IBP,IBT,IBX,RCODE,RDESC,REXIST
93 Q:$G(IBREM) S IBREM=1
94 D SET(" ")
95 D SET(" Claim Level Remark Information")
96 D SET(" Code Description")
97 I '$G(IBSRC) D
98 . D CNTRL^VALM10(VALMCNT,4,4,IOUON,IOUOFF)
99 . D CNTRL^VALM10(VALMCNT,13,11,IOUON,IOUOFF)
100 . Q
101 ;
102 S IBREC1=$P($G(^IBM(361.1,IBCNT,3)),U,3,7)
103 I $P(IBREC1,U,1)="" S IBREC1=$P($G(^IBM(361.1,IBCNT,5)),U,1,5)
104 S REXIST=0
105 ;
106 F IBP=1:1:5 D
107 . S RCODE=$P(IBREC1,U,IBP)
108 . S RDESC=$G(^IBM(361.1,IBCNT,"RM"_IBP))
109 . I RCODE="",RDESC="" Q
110 . S REXIST=1
111 . K IBT
112 . S IBT(IBP)=RDESC
113 . D TXT1(.IBT,0,60)
114 . D SET(" "_$$LJ^XLFSTR(RCODE,6)_"- "_$G(IBT(1)))
115 . S IBX=1
116 . F S IBX=$O(IBT(IBX)) Q:'IBX D SET($J("",12)_IBT(IBX))
117 . Q
118 ;
119 I 'REXIST D SET(" No claim level remarks on file")
120 D SET(" ")
121 Q:$G(IBSRC) ; MRA Only
122 ;
123MRALLA S IB=$$SETSTR^VALM1("LINE LEVEL ADJUSTMENTS:","",1,50)
124 D SET(IB)
125 I '$G(IBSRC) D
126 . D CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF)
127 . S ^TMP("IBCECSD",$J,"X",7)=VALMCNT
128 I '$D(^IBM(361.1,IBCNT,15,0)) D SET("NONE") Q ; only if there is info
129 ;
130 ; look up all billed data
131 N IBZDATA,IBFORM,IBX2,IBX3,IBREC2,IBREC3,IBTX,IBT,IBRC,IBZ,IBTXL
132 S IBFORM=0 ; cms-1500
133 I $$FT^IBCEF(+IBREC)=3 S IBFORM=1 ; UB-04
134 D F^IBCEF("N-"_$S(IBFORM:"UB-04",1:"HCFA 1500")_" SERVICE LINE (EDI)","IBZDATA",,+IBREC)
135 ;
136 S IBX=0 F S IBX=$O(^IBM(361.1,IBCNT,15,IBX)) Q:IBX<1 S IBREC1=^IBM(361.1,IBCNT,15,IBX,0) D
137 . NEW RVL
138 . D SET(" # SV DT REVCD PROC MOD UNITS BILLED DEDUCT COINS ALLOW PYMT")
139 . S RVL=+$P(IBREC1,U,12) ; referenced Vista line#
140 . I 'RVL S RVL=IBX ; use the EOB line# if not there
141 . S IBT=$$RJ($P(IBREC1,"^"),3) ; line number
142 . S IBT=IBT_" "_$$DAT1^IBOUTL($P($P(IBREC1,"^",16),".")) ; service date
143 . S IBT=IBT_" "_$$RJ($$EXTERNAL^DILFD(361.115,.1,"",$P(IBREC1,"^",10)),6) ; revcd
144 . S IBT=IBT_" "_$$RJ($P(IBREC1,"^",4),5) ; procedure
145 . S IBT=IBT_" "_$$RJ($P($G(^IBM(361.1,IBCNT,15,IBX,2,1,0)),"^"),3)_$S($D(^IBM(361.1,IBCNT,15,IBX,2,2,0)):"+",1:" ") ; modifiers
146 . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",11),"",0),5) ; units
147 . S IBT=IBT_" "_$$RJ($FN($S(IBFORM:$P($G(IBZDATA(RVL)),"^",5),1:$P($G(IBZDATA(RVL)),"^",8)*$P($G(IBZDATA(RVL)),"^",9)),"",2),8) ; billed
148 . S IBT=IBT_" "_$$RJ($FN($P($G(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,+$O(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,"B",1,0)),0)),"^",2),"",2),7) ; deduct
149 . S IBT=IBT_" "_$$RJ($FN($P($G(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,+$O(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,"B",2,0)),0)),"^",2),"",2),6) ; coins
150 . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",13),"",2),8) ; allow
151 . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",3),"",2),8) ; payment
152 . D SET(IBT)
153 . S IBX2=0 F S IBX2=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2)) Q:IBX2<1 D
154 .. S IBREC2=^IBM(361.1,IBCNT,15,IBX,1,IBX2,0),IBX3=0
155 .. F S IBX3=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3)) Q:IBX3<1 D
156 ... S IBREC3=^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3,0)
157 ... ; line level adjustments; don't display kludges (esg 10/23/03)
158 ... I $P(IBREC2,U,1)="PR",$P(IBREC3,U,1)="AAA" Q
159 ... I $P(IBREC2,U,1)="OA",$P(IBREC3,U,1)="AB3" Q
160 ... I $P(IBREC2,U,1)="LQ" Q
161 ... S IBTX(1)="ADJ: "_$P(IBREC2,"^")_" "_$P(IBREC3,"^")_" "_$P(IBREC3,"^",4) D TXT1(.IBTX,0,79) S IBT=0 F S IBT=$O(IBTX(IBT)) Q:IBT<1 D SET(IBTX(IBT))
162 ... K IBTX
163 ... D SET("ADJ AMT: "_$FN($P(IBREC3,"^",2),"",2))
164 . S IBRC=0
165 . F S IBRC=$O(^IBM(361.1,IBCNT,15,IBX,4,IBRC)) Q:'IBRC S IBREC2=$G(^(IBRC,0)) I IBREC2 K IBTX,IBZ S IBTX(1)=" -REMARK CODE("_+IBREC2_"): ",IBTXL=$L(IBTX(1)) D
166 .. S IBTX(1)=IBTX(1)_$P(IBREC2,U,2)_" "_$P(IBREC2,U,3)
167 .. I $L(IBTX(1))>79 D
168 ... D TXT1(.IBTX,0,79) D SET(IBTX(1)) M IBZ=IBTX K IBTX S IBTX(1)="",IBT=1 F S IBT=$O(IBZ(IBT)) Q:'IBT S IBTX(1)=IBTX(1)_IBZ(IBT)_" "
169 .. E D
170 ... S IBTXL=0
171 .. D TXT1(.IBTX,IBTXL,79) S IBT=0 F S IBT=$O(IBTX(IBT)) Q:IBT<1 D SET(IBTX(IBT))
172 . D SET(" ")
173 D SET(" ")
174 Q
175 ;
176TXT(IBRM,IBLN,IBXY) ;display text over 79 chars
177 ;IBRM - text, IBLN - length, IBXY - position
178 S IBRM=$E(IBRM,IBLN+1,999)
179REP I $E(IBRM,1,IBLN)'="" S IB=$$SETSTR^VALM1($E(IBRM,1,IBLN),"",IBXY,IBLN) D SET(IB) S IBRM=$E(IBRM,IBLN+1,999) G REP
180 Q
181 ;
182SET(IB,IBSAV) ;
183 I '$G(IBSAV) D SET^IBCECSA6($G(IBSRC),IB,CNT,IBCNT)
184 Q
185 ;
186A10(X) ;
187 Q $$A10^IBCECSA6(X)
188 ;
189A7(X) ; returns a dollar amount right justified to 7 characters
190 Q $$RJ($FN(X,"",2),7)
191 ;
192TXT1(IBT,DIWL,DIWR) ; sets up text for over 79 chars
193 ; IBT - pass by ref, array of text to be formatted back in array
194 ; DIWL - left margin, DIWR = right margin
195 N IBX,X,DIWF,IBS K ^UTILITY($J,"W")
196 S DIWF="|I"_DIWL
197 S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 S X=IBT(IBX) D ^DIWP
198 K IBT F S IBX=$O(^UTILITY($J,"W",DIWL,IBX)) Q:IBX<1 S IBT(IBX)=^UTILITY($J,"W",DIWL,IBX,0)
199 K ^UTILITY($J,"W")
200 Q
201 ;
202RJ(X,Y) ; right just, default is 10
203 Q $$RJ^XLFSTR(X,$G(Y,10)," ")
204 ;
Note: See TracBrowser for help on using the repository browser.