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

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

revised back to 6/30/08 version

File size: 7.3 KB
Line 
1IBCEU1 ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99
2 ;;2.0;INTEGRATED BILLING;**137,155,296,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5CCOB1(IBIFN,NODE,SEQ) ; Extract Claim level COB data
6 ; for a bill IBIFN
7 ; NODE = the file 361.1 node(s) to be returned, separated by commas
8 ; SEQ = the specific insurance sequence you want returned. If not =
9 ; 1, 2, or 3, all are returned
10 ; Returns IBXDATA(COB,n,node) where COB = COB insurance sequence,
11 ; n is the entry number in file 361.1 and node is the node requested
12 ; = the requested node's data
13 ;
14 N IB,IBN,IBBILL,IBS,A,B,C
15 ;
16 K IBXDATA
17 ;
18 S:$G(NODE)="" NODE=1
19 S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
20 S:"123"'[$G(SEQ) SEQ=""
21 ;
22 F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C D
23 . I '$$EOBELIG(C) Q ; eob not eligible for secondary claim
24 . S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance sequence
25 . I $S('$G(SEQ):1,1:SEQ=IBS) D
26 .. F Z=1:1:$L(NODE,",") D
27 ... S A=$P(NODE,",",Z)
28 ... Q:A=""
29 ... S IBN=$G(^IBM(361.1,C,A))
30 ... I $TR(IBN,U)'="" S IBXDATA(IBS,C,A)=IBN
31 ;
32 Q
33 ;
34CCAS1(IBIFN,SEQ) ; Extract all MEDICARE COB claim level adjustment data
35 ; for a bill IBIFN (subfile 361.11 in file 361.1)
36 ; SEQ = the specific insurance sequence you want returned. If not =
37 ; 1, 2, or 3, all are returned
38 ; Returns IBXDATA(COB,n) where COB = COB insurance sequence,
39 ; n is the entry number in file 361.1 and
40 ; = the 0-node of the subfile entry (361.11)
41 ; and IBXDATA(COB,n,m) where m is a sequential # and
42 ; = this level's 0-node
43 N IB,IBA,IBS,IB0,IB00,IBBILL,B,C,D,E
44 ;
45 S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
46 S:"123"'[$G(SEQ) SEQ=""
47 ;
48 F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C D
49 . I '$$EOBELIG(C) Q ; eob not eligible for secondary claim
50 . S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance sequence
51 . I $S('$G(SEQ):1,1:SEQ=IBS) D
52 .. S (IBA,D)=0 F S D=$O(^IBM(361.1,C,10,D)) Q:'D S IB0=$G(^(D,0)) D
53 ... S IBXDATA(IBS,D)=IB0
54 ... S (IBA,E)=0
55 ... F S E=$O(^IBM(361.1,C,10,D,1,E)) Q:'E S IB00=$G(^(E,0)) D
56 .... S IBA=IBA+1
57 .... I $TR(IB00,U)'="" S IBXDATA(IBS,D,IBA)=IB00
58 ;
59 Q
60 ;
61SEQ(A) ; Translate sequence # A into corresponding letter representation
62 S A=$E("PST",A)
63 I $S(A'="":"PST"'[A,1:1) S A="P"
64 Q A
65 ;
66EOBTOT(IBIFN,IBCOBN) ; Total all EOB's for a bill's COB sequence
67 ; Function returns the total of all EOB's for a specific COB seq
68 ; IBIFN = ien of bill in file 399
69 ; IBCOBN = the # of the COB sequence you want EOB/MRA total for (1-3)
70 ;
71 N Z,Z0,IBTOT
72 S IBTOT=0
73 I $O(^IBM(361.1,"ABS",IBIFN,IBCOBN,0)) D
74 . ; Set up prior payment field here from MRA/EOB(s)
75 . S (IBTOT,Z)=0
76 . F S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z D
77 .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,2)
78 Q IBTOT
79 ;
80 ;
81LCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the line adjustment reasons COB
82 ; line # data for an electronic claim
83 ; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
84 ; pass by reference
85 ; COL = the column in the 837 flat file being output for LCAS record
86 N LINE,COBSEQ,RECCT,GRPCD,SEQ,RCCT,RCPC,DATA,RCREC,SEQLINE K IBXDATA
87 S (LINE,RECCT)=0
88 S RCPC=(COL#3) S:'RCPC RCPC=3
89 S RCREC=$S(COL'<4:COL-1\3,1:0)
90 ;S RCREC=$S(COL'<4:COL+5\6-1,1:0)
91 F S LINE=$O(IBXSAVE("LCOB",LINE)) Q:'LINE D
92 . S COBSEQ=0
93 . F S COBSEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ)) Q:'COBSEQ S SEQLINE=0 F S SEQLINE=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE)) Q:'SEQLINE S GRPCD="" F S GRPCD=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD)) Q:GRPCD="" D
94 .. S RECCT=RECCT+1
95 .. I COL=2 S IBXDATA(RECCT)=LINE,DATA=LINE D:RECCT>1 ID^IBCEF2(RECCT,"LCAS")
96 .. I COL=3 S IBXDATA(RECCT)=$TR(GRPCD," ")
97 .. S (SEQ,RCCT)=0
98 .. F S SEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)) Q:'SEQ I $TR($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U)'="" D
99 ... S RCCT=RCCT+1
100 ... Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6)
101 ... S DATA=$S(COL=2:LINE,COL=3:$TR(GRPCD," "),1:$P($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U,RCPC))
102 ... I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q
103 ... I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"LCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA
104 Q
105 ;
106CCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the claim adjustment reasons COB
107 ; data for an electronic claim
108 ; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
109 ; pass by reference
110 ; COL = the column in the 837 flat file being output for CCAS record
111 N COBSEQ,RECCT,GRPSEQ,SEQ,RCPC,RCCT,RCREC,DATA K IBXDATA
112 S RECCT=0
113 S RCPC=(COL#3) S:'RCPC RCPC=3
114 S RCREC=$S(COL'<4:COL+5\6-1,1:0)
115 S COBSEQ=0
116 F S COBSEQ=$O(IBXSAVE("CCAS",COBSEQ)) Q:'COBSEQ S GRPSEQ="" F S GRPSEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ)) Q:GRPSEQ="" D
117 . S RECCT=RECCT+1
118 . I COL=2 S IBXDATA(RECCT)=COBSEQ D:RECCT>1 ID^IBCEF2(RECCT,"CCAS")
119 . I COL=3 S IBXDATA(RECCT)=$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U)
120 . S (SEQ,RCCT)=0
121 . F S SEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)) Q:'SEQ I $TR($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U)'="" D
122 .. S RCCT=RCCT+1
123 .. Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6)
124 .. S DATA=$S(COL=2:COBSEQ,COL=3:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U),1:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U,RCPC))
125 .. I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q
126 .. I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"CCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA
127 Q
128 ;
129COBOUT(IBXSAVE,IBXDATA,CL) ;
130 N Z,M,N,P,PCCL
131 S (N,Z,P)=0 F S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z D
132 . S N=N+1
133 . S M=$O(IBXSAVE("LCOB",Z,"COB",""),-1) Q:'M
134 . S P=$O(IBXSAVE("LCOB",Z,"COB",M,""),-1) Q:'P
135 . S PCCL=$P($G(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL)
136 . S:PCCL'="" IBXDATA(N)=PCCL
137 . Q
138 Q
139 ;
140COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance company payer id
141 N CT,Z,N,NUM
142 K IBXDATA
143 I '$D(IBXSAVE("LCOB")) G COBPYRX
144 D ALLPAYID^IBCEF2(IBXIEN,.NUM,1)
145 S Z=$$COID^IBCEF2(IBXIEN),NUM=$G(NUM(1))
146 S:Z="" Z="0000"
147 S NUM=$E(NUM_$J("",5),1,5)_$E(Z_$J("",4),1,4)
148 S (CT,N)=0
149 F S N=$O(IBXSAVE("LCOB",N)) Q:'N S CT=CT+1,IBXDATA(CT)=NUM
150COBPYRX ;
151 Q
152 ;
153EOBELIG(IBEOB) ; EOB eligibility for secondary claim
154 ; Function to decide if EOB entry in file 361.1 (ien=IBEOB) is
155 ; eligible to be included for secondary claim creation process
156 ; The EOB is not eligible if the review status is not 3, or if there
157 ; is no insurance sequence indicator, or if the EOB has been DENIED
158 ; and the patient responsibility for that EOB is $0.
159 ;
160 NEW ELIG,IBDATA,PTRESP
161 S ELIG=0
162 I '$G(IBEOB) G EOBELIGX
163 S IBDATA=$G(^IBM(361.1,IBEOB,0))
164 I $P(IBDATA,U,4)'=1 G EOBELIGX ; Only MRA EOB's for now
165 I $P(IBDATA,U,16)'=3 G EOBELIGX ; review status - accepted-complete
166 I '$P(IBDATA,U,15) G EOBELIGX ; insurance sequence must exist
167 S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2) ; Pt Resp Amount for 1500s
168 I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(IBEOB) ; for UBs
169 I PTRESP'>0,$P(IBDATA,U,13)=2 G EOBELIGX ; Denied & No Pt. Resp.
170 I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX ; filing error
171 ;
172 S ELIG=1
173EOBELIGX ;
174 Q ELIG
175 ;
176EOBCNT(IBIFN) ; This function counts up the number of EOBs that are eligible
177 ; for the secondary claim creation process for a given bill#.
178 NEW CNT,IEN
179 S (CNT,IEN)=0
180 F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D
181 . I $$EOBELIG(IEN) S CNT=CNT+1
182 . Q
183EOBCNTX ;
184 Q CNT
185 ;
Note: See TracBrowser for help on using the repository browser.