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

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

initial load of WorldVistAEHR

File size: 8.7 KB
Line 
1IBCEF2 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;8/6/03 10:54am
2 ;;2.0;INTEGRATED BILLING;**52,85,51,137,232,155,296,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5HOS(IBIFN) ; Extract rev codes for inst. episode into IBXDATA
6 ; Moved for space
7 D HOS^IBCEF22(IBIFN)
8 Q
9 ;
10OTHINS(IBIFN) ;Determine 'other insurance' node (I1,I2)
11 ; If primary bill, other ins is secondary
12 ; If sec or tert bill, other ins is primary
13 ;IBIFN = bill ien
14 N Z
15 S Z=$$COBN^IBCEF(IBIFN)
16 Q "I"_$S(Z=1:2,1:1)
17 ;
18OTHINS1(IBIFN) ; Returns the COB #'s of all 'other insurance' as a string
19 ;IBIFN = bill ien
20 N IBC,Z
21 S Z=$$COBN^IBCEF(IBIFN)
22 I Z=1 S IBC=$S($D(^DGCR(399,IBIFN,"I2")):$S($D(^DGCR(399,IBIFN,"I3")):23,1:2),1:"") ;Primary=>2 or 23
23 I Z=2 S IBC="1"_$S($D(^DGCR(399,IBIFN,"I3")):3,1:"") ;Secondary=>1 or 13
24 I Z=3 S IBC="12" ;Tertiary =>12
25OTHQ Q IBC
26 ;
27RECVR(IBIFN) ; Returns the V.A. internal routing id of the current ins
28 ; co for 837
29 ;IBIFN = bill ien
30 N MCR,NUM,IBPH
31 S IBPH=$P("P^H",U,$$FT^IBCEF(IBIFN)-1)
32 S NUM="ENVOY"_IBPH
33 ; If rate type is CHAMPVA, send 'CHAMVA'
34 I $P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U)="CHAMPVA" S NUM="CHAMV"_IBPH
35 I NUM["ENVOY",$$MCRWNR^IBEFUNC(+$$CURR(IBIFN)) D
36 . S MCR=$P("B^A",U,$$FT^IBCEF(IBIFN)-1) ; PART A/B for MEDICARE
37 . S NUM="PART"_MCR
38 Q NUM
39 ;
40ALLPAYID(IBIFN,IBXDATA,SEQ) ; Returns clearinghouse id for all (SEQ="")
41 ; or a specific (SEQ=1,2,3) ins co's for 837 in IBXDATA(n) for bill ien
42 ; IBIFN
43 ; EJK *296* Add IBMRA - MRA Claim type.
44 ; EJK *296* Add IBEBI - Electronic Billing ID
45 N Z,Z0,Z1,A,IBM,IBINST,IBMCR,IBX,IBMRA,IBEBI
46 S IBXDATA="",IBM=$G(^DGCR(399,IBIFN,"M"))
47 F Z=1:1:3 I $S('$G(SEQ):1,1:Z=SEQ) S Z0=$P(IBM,U,Z) I Z0 D S:A'="" IBXDATA(Z)=A
48 . S A=""
49 . S IBINST=($$FT^IBCEF(IBIFN)=3) ;Is bill UB-04?
50 . ; EJK *296* Get IBEBI based on Prof. or Inst. claim
51 . I IBINST S IBEBI=$P($G(^DIC(36,Z0,3)),U,4)
52 . I 'IBINST S IBEBI=$P($G(^DIC(36,Z0,3)),U,2)
53 . S IBEBI=$$UP^XLFSTR(IBEBI)
54 . ; EJK *296* If this is a Medicare claim, it may be printed or transmitted.
55 . S IBMRA=$$MRASEC^IBCEF4(IBIFN) ;Is claim 2ndary to an MRA?
56 . S IBMCR=$$MCRONBIL^IBEFUNC(IBIFN),Z1=$G(^DGCR(399,IBIFN,"TX"))
57 . Q:$P(Z1,U,8)=1!$S('$P(Z1,U,9):0,1:$$MRASEC^IBCEF4(IBIFN)) ;Force local prnt
58 . S A=$S($P(Z1,U,8)'=2:$P($G(^DIC(36,Z0,3)),U,$S(IBINST:4,1:2)),1:"")
59 . S A=$$UP^XLFSTR(A)
60 . ;
61 . ; RPRNT = CMS-1500 Rx bills
62 . ; IPRNT = Inst MRA secondary claims
63 . ; PPRNT = Prof MRA secondary claims
64 . ; HPRNT = inst printed bills (non-MRA, force print at clearinghouse)
65 . ; SPRNT = prof printed bills (non-MRA, force print at clearinghouse)
66 . ;
67 . ; Default to appropriate 'xPRNT' if Rx bill or COB bill or forced to
68 . ; print - claims must print at clearinghouse
69 . ;
70 . ; Rx bills on CMS-1500
71 . I 'IBINST,$$ISRX^IBCEF1(IBIFN) S A="RPRNT" Q
72 . ;
73 . ; Claim forced to print at clearinghouse
74 . I $P(Z1,U,8)=2 S A=$S(IBINST:"H",1:"S")_"PRNT" Q
75 . ;
76 . ; EJK *296* Send IBEBI for MRA secondary claims if it exists
77 . I Z>1,IBMRA,IBEBI'="" S A=IBEBI Q
78 . ;
79 . ; MRA secondary claim
80 . I Z>1,IBMCR=1,$P(Z1,U,5)="C" S A=$S(IBINST:"I",1:"P")_"PRNT" Q
81 . ;
82 . ; Medicare is current payer (MRA request claim)
83 . I $$WNRBILL^IBEFUNC(IBIFN,Z) S A=$S(IBINST:"12M61",1:"SMTX1") Q
84 . ;
85 . ; IB*296 - Do not modify the payer ID for CHAMPVA (HAC)
86 . I A=84146 Q
87 . I A=84147 Q
88 . ;
89 . ; If not a primary bill force to print
90 . I Z>1,Z=$$COBN^IBCEF(IBIFN) S A=$S(IBINST:"H",1:"S")_"PRNT" Q
91 . Q
92 ;
93 Q
94 ;
95PAYERID(IBIFN) ; Returns clearinghouse id for current ins co
96 ; IBIFN = bill ien
97 N NUM,IBSEQ
98 ; Determine the current ins co's # to identify at WEBMD
99 ; Envoy changed to WEBMD in patch 232
100 S IBSEQ=+$$COBN^IBCEF(IBIFN)
101 D ALLPAYID(IBIFN,.NUM,IBSEQ) S NUM=$G(NUM(IBSEQ))
102 Q $G(NUM)
103 ;
104CURR(IBIFN) ; Returns ien of the current insurance
105 ; company for bill ien IBIFN
106 Q $$FINDINS^IBCEF1(IBIFN)
107 ;
108ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
109 D ADMDT^IBCEF21(IBIFN,$G(NOOUTCK)) ; Moved for space
110 Q
111 ;
112DISDT(IBIFN) ; Calculate discharge date
113 D DISDT^IBCEF21(IBIFN) ; Moved for space
114 Q
115 ;
116INDTS(IBIFN) ; Function returns the admit ^ discharge date/time of admission if patient is an inpatient on bill's event date
117 N Z,Z0,DFN,VAINDT,VAIN S Z0=""
118 S Z=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(Z,U,2),VAINDT=$P(Z,U,3)
119 I +DFN,+VAINDT D INP^VADPT I +VAIN(1) S Z0=+VAIN(7)_U_+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0))
120 Q Z0
121 ;
122TXMT(IBIFN) ; Function moved - use new call in IBCEF4
123 Q $$TXMT^IBCEF4(IBIFN)
124 ;
125 ;
126ID(LN,VAL) ; Set EXTRACT GLOBAL for multi-valued record
127 ; ids for Austin
128 ; LN = the line # being extracted
129 ; VAL = the value of the element being extracted
130 ;
131 ; Assumes IBXPG exists
132 ;
133 Q:LN<2
134 D SETGBL^IBCEFG(IBXPG,LN,1,VAL,.IBXSIZE)
135 Q
136 ;
137ID1(LN,DX,CT) ;Special entrypoint for diagnoses to 'save' the fact
138 ; a dx code is an e-code.
139 ; LN is last entry # output, returned as the entry # (IBXLINE) to assign to this entry
140 ; DX = the actual Dx code array(RECORD ID). Pass by reference, DX returned null if
141 ; dx was not output
142 ; CT = the ct on the 'DC' entry. pass by reference, returned null if
143 ; the end of the valid dx codes has been reached
144 N IBINS,VAL
145 S IBINS=($$FT^IBCEF(IBXIEN)=3)
146 S VAL="DC"_CT ; **232**
147 S VAL=$E(VAL_" ",1,4)
148 I IBINS D
149 . I CT>8 S CT="" Q ;Only 8 codes for institutional/UB **232**
150 . ; Check for 'E-code'. If there, don't extract the first one as a dx,
151 . ; but as a special E-code
152 . I $G(IBXSAVE("DX-E"))="",$E($G(DX))="E" S IBXSAVE("DX-E")=DX,DX=""
153 I 'IBINS,CT>8 S ^TMP("IBXSAVE",$J,"DX",IBXIEN)=$G(^TMP("IBXSAVE",$J,"DX",IBXIEN))+1,^TMP("IBXSAVE",$J,"DX",IBXIEN,$P(DX(+^TMP("IBXSAVE",$J,"DX",IBXIEN)),U,2))=$G(^TMP("IBXSAVE",$J,"DX",IBXIEN)) S DX="" Q
154 I CT'="",DX'="" S LN=LN+1 D ID(LN,VAL) S ^TMP("IBXSAVE",$J,"DX",IBXIEN,$P(DX(LN),U,2))=LN,^TMP("IBXSAVE",$J,"DX",IBXIEN)=CT,CT=CT+1 Q
155 Q
156 ;
157M(CT) ; Calculate multi-valued field for 837 extract
158 ; CT = passed by reference/the record ID counter
159 S CT=CT+1
160 Q $E(CT#12+$S(CT#12:0,1:12)_" ",1,2)
161 ;
162SVITM(IBA,LINE) ; Saves the linked items from the bill data extract into
163 ; an array the formatter will use to link Rxs and prosthetics
164 ; to an SV1 or SV2 line item, if possible. Kills off IBA array entries
165 ; after they are 'moved'
166 ; IBA = array that contains the data to be saved
167 ; subscripts are (line #,item type,item pointer)=ct
168 N Z0,Z1
169 S Z0="" F S Z0=$O(IBA("OUTPT",LINE,Z0)) Q:Z0="" I Z0?1N.N S Z1="" F S Z1=$O(IBA("OUTPT",LINE,Z0,Z1)) Q:Z1="" S ^TMP($J,"IBITEM",Z0,Z1,LINE)=IBA("OUTPT",LINE,Z0,Z1) K IBA("OUTPT",LINE,Z0,Z1)
170 Q
171 ;
172LINK(IBTYP,IBDATA) ; Link the item with a service line, if possible
173 ; IBTYP = the code for the type of item
174 ; returned incremented if no link is made
175 ; IBDATA = the extracted data string that identifies the item.
176 ; Returns the line to link to or null if no link
177 N IBLN,IBKEY,Z
178 S IBLN=""
179 S IBKEY=$S(IBTYP=3:$P(IBDATA,U,9),IBTYP=5:$P(IBDATA,U,4),1:"") Q:IBKEY=""
180 I $D(^TMP($J,"IBITEM",IBTYP,IBKEY)) D G:IBLN LINKQ
181 .S Z=0 F S Z=$O(^TMP($J,"IBITEM",IBTYP,IBKEY,Z)) Q:'Z I ^TMP($J,"IBITEM",IBTYP,IBKEY,Z) S IBLN=Z,^TMP($J,"IBITEM",IBTYP,IBKEY,Z)=^TMP($J,"IBITEM",IBTYP,IBKEY,Z)-1 Q
182 I $D(^TMP($J,"IBITEM",IBTYP,0)) S IBKEY=0 D
183 .S Z=0 F S Z=$O(^TMP($J,"IBITEM",IBTYP,IBKEY,Z)) Q:'Z I ^TMP($J,"IBITEM",IBTYP,IBKEY,Z) S IBLN=Z,^TMP($J,"IBITEM",IBTYP,IBKEY,Z)=^TMP($J,"IBITEM",IBTYP,IBKEY,Z)-1 Q
184LINKQ Q IBLN
185 ;
186COID(IBIFN) ; Claim office ID - moved for space
187 Q $$COID^IBCEF21(IBIFN)
188 ;
189PPOL(IBIFN,COB) ; return IFN of patient policy on a bill defined by COB (fields 399,112-114)
190 N X,Y,PPOL S PPOL=""
191 I +$G(IBIFN) S X=$G(^DGCR(399,+IBIFN,"M")) I +$G(COB),COB<4 S Y=COB+11,PPOL=$P(X,U,Y)
192 Q PPOL
193 ;
194LADJ(SUB,LINE,SEQ1,GRP,IBXSAVE,PIECE) ; Extract line level adjustments
195 ; SUB = 1st subscript in IBXSAVE array to use
196 ; LINE = 2nd subscript
197 ; SEQ1 = 4th subscript
198 ; GRP = 5th subscript
199 ; IBXSAVE = array that has the data for COB line level adjustments
200 ; PIECE = # of the piece on the 0-node of the line level
201 ; adjustment reason to be extracted
202 ;
203 N A,B
204 S (A,B)=0
205 F S A=$O(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A)) Q:'A D
206 . S B=B+1,IBXDATA(B)=$P(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A),U,PIECE)
207 Q
208 ;
209ESGHPST(IBIFN,COB) ; return insureds employ status if bill policy defined by COB is an Employer Sponsored Group Health Plan
210 Q $$ESGHPST^IBCEF21(IBIFN,COB) ;Tag moved
211 ;
212ESGHPNL(IBIFN,COB) ; return employer name and location if bill policy defined by COB is an Employer Sponsored Group Health Plan
213 Q $$ESGHPNL^IBCEF21(IBIFN,COB) ;Tag moved
214 ;
215AMTOUT(A,B,C,IBXSAVE) ; format output amount
216 ;
217 N Z,K,IBZ,IBARR K IBXDATA S (IBZ,K)=0,IBARR="IBXSAVE("""_A_""")" F S IBZ=$O(@IBARR@(IBZ)) Q:'IBZ S K=K+1,Z=0 F S Z=$O(@IBARR@(IBZ,Z)) Q:'Z I $P($G(@IBARR@(IBZ,Z,B)),U,C) S IBXDATA(K)=$$DOLLAR^IBCEFG1($G(IBXDATA(K))+$P(@IBARR@(IBZ,Z,B),U,C))
218 Q
Note: See TracBrowser for help on using the repository browser.