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

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1IBRFN ;ALB/AAS - Supported functions for AR ;5-MAY-1992
2 ;;2.0;INTEGRATED BILLING;**52,130,183,223,309,276,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ERR(Y) ; Input Y = -1^error code[;error code...]^literal message
6 ; Output IBRERR = error message 1
7 ; if more than one code then
8 ; IBRERR(n)=error code n
9 N N,X,X1,X2 K IBRERR S IBRERR=""
10 G:+Y>0 ERRQ
11 S X2=$P(Y,U,2) F N=1:1 S X=$P(X2,";",N) Q:X="" S X1=$P($G(^IBE(350.8,+$O(^IBE(350.8,"AC",X,0)),0)),U,2) D
12 .I N=1 S IBRERR=X1
13 .I $P(Y,U,3)]""!($P(X2,";",2,99)]"") S IBRERR(N)=X1
14 I $P(Y,U,3)]"" S N=N+1,IBRERR(N)=$P(Y,U,3)
15ERRQ Q IBRERR
16 ;
17MESS(Y) ; -input y=error code - from file 350.8 (piece 3)
18 ; output error message
19 Q $P($G(^IBE(350.8,+$O(^IBE(350.8,"AC",Y,0)),0)),U,2)
20 ;
21SVDT(BN,VDT) ;returns service dates for a specific bill
22 ; Input: BN bill number (external form)
23 ; VDT name of array to hold outpatient visit dates, pass by value (if needed)
24 ; Output: X function value, string, = 0 if bill not found
25 ; = 1 (Inpt) or 2 (Outpt)^event date^stmt from date^stmt to date^LOS (I)^Number of visit dates (O)
26 ; all are internal form, any piece may be null if not defined for the bill
27 ; array containing outpatient visit dates as subscripts/no data, if VDT passed by value
28 N X,Y,IFN S X=0,BN=$G(BN)
29 I BN'="" S IFN=+$O(^DGCR(399,"B",BN,0)),Y=$G(^DGCR(399,IFN,0)) I Y'="" D
30 . S X=$S(+$P(Y,U,5)<1:"",+$P(Y,U,5)<3:1,+$P(Y,U,5)<5:2,1:"")_U_$P(Y,U,3),Y=$G(^DGCR(399,IFN,"U"))
31 . S X=X_U_$P(Y,U,1)_U_$P(Y,U,2)_U_$P(Y,U,15)_U_$P($G(^DGCR(399,IFN,"OP",0)),U,4)
32 . S Y=0 F S Y=$O(^DGCR(399,IFN,"OP",Y)) Q:'Y S VDT(Y)=""
33 Q X
34 ;
35 ;
36REC(IBSTR,IBTYPE) ; Find the AR for an Authorization or Rx number
37 ; Input: IBSTR - FI Authorization Number or Rx Number
38 ; Output: IBAR >0 => ptr to claim/AR in files 399/430
39 ; -1 => No receivable found
40 ; IBTYPE (by ref) - how the IBSTR was recognized: 1-Auth,2-ECME,3-Rx#,0-Unknown
41 ;
42 N IBAR,IBARR,IBRX,IBKEY,IBKEYS,IBREF,IBPREF
43 S IBTYPE=0
44 S IBAR=-1
45 I $G(IBSTR)="" G RECQ
46 ;
47 ; extended syntax to indicate the type:
48 ; T.000000 for TRICARE, E.7000000 for ECME, R.50000000 for Rx
49 I $L($P(IBSTR,"."))=1,$P(IBSTR,".",2)'="" D
50 . S IBPREF=$TR($P(IBSTR,"."),"ter","TER")
51 . S IBSTR=$P(IBSTR,".",2,255)
52 . I $E(IBPREF)="T" S IBTYPE=1 ; TRICARE Auth#
53 . I $E(IBPREF)="E" S IBTYPE=2 ; ECME #
54 . I $E(IBPREF)="R" S IBTYPE=3 ; Rx #
55 ;
56 ; look for TRICARE number
57 I (IBTYPE=0)!(IBTYPE=1) S IBAR=$$AREC(IBSTR) I IBAR>0 S IBTYPE=1 G RECQ
58 ;
59 ; - look for ecme number
60 I (IBTYPE=0)!(IBTYPE=2) S IBAR=$$EREC(IBSTR) I IBAR>0 S IBTYPE=2 G RECQ
61 ;
62 I IBTYPE,IBTYPE'=3 G RECQ
63 ;
64 ; - treat as an rx number
65 S IBAR=$$RXREC(IBSTR) I IBAR>0 S IBTYPE=3
66 ;
67RECQ Q IBAR
68 ;
69RXREC(IBRXN) ; Search the Rx
70 N IBR,IBX,IBARR,IBY,IBBIL,IBTRKN,IBFIL,IBRX
71 I $L(IBRXN)<5,'$D(^IBA(362.4,"B",IBRXN)) Q -1
72 ; Scan 362.4
73 ; 1) check the exact match:
74 S IBX=0 F S IBX=$O(^IBA(362.4,"B",IBRXN,IBX)) Q:'IBX D
75 . S IBBIL=$P($G(^IBA(362.4,IBX,0)),U,2) Q:'IBBIL
76 . I $P($G(^DGCR(399,IBBIL,0)),U,13)=7 Q ; ignore cancld
77 . S IBARR(IBBIL)=""
78 ; 2) check Rx with postfixes like "A","B" etc
79 S IBR=IBRXN_" " F S IBR=$O(^IBA(362.4,"B",IBR)) Q:$E(IBR,1,$L(IBRXN))'=IBRXN D
80 . I $E(IBR,$L(IBRXN)+1)'?1A Q ; only letters in postfx
81 . S IBX=0 F S IBX=$O(^IBA(362.4,"B",IBR,IBX)) Q:'IBX D
82 . . S IBBIL=$P($G(^IBA(362.4,IBX,0)),U,2) Q:'IBBIL
83 . . I $P($G(^DGCR(399,IBBIL,0)),U,13)=7 Q ; ignore cancld
84 . . S IBARR(IBBIL)=""
85 ; 3) Now scan CT (356):
86 S DIC=52,DIC(0)="BO",X=IBSTR D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y
87 I IBRX S IBFIL="" F S IBFIL=$O(^IBT(356,"ARXFL",IBRX,IBFIL)) Q:IBFIL="" D
88 . S IBTRKN="" F S IBTRKN=$O(^IBT(356,"ARXFL",IBRX,IBFIL,IBTRKN)) Q:IBTRKN="" D
89 .. S IBBIL=$P($G(^IBT(356,IBTRKN,0)),U,11) Q:'IBBIL
90 .. I $P($G(^DGCR(399,IBBIL,0)),U,13)=7 Q ; ignore cancld
91 .. S IBARR(IBBIL)=""
92 ;
93 S IBY=$O(IBARR("")) I IBY'>0 Q -1 ;not found
94 I '$O(IBARR(IBY)) D DTL(+IBY,"Rx#",IBRXN) Q +IBY ;one only
95 W !!,"More than one fill for Rx# ",IBSTR," has been billed."
96 S IBY=$$SEL(.IBARR)
97 D DTL(IBY,"Rx#",IBRXN)
98 Q IBY
99 ;
100AREC(AUTH) ; Find the Receivable for a TRICARE FI Authorization Number
101 ; Input: AUTH - Fiscal Intermediary Authorization Number
102 ; Output: IBIFN >0 => ptr to claim/AR in files 399/430
103 ; -1 => No receivable found
104 N IBIFN
105 S IBIFN=-1
106 I $G(AUTH)="" G ARECQ
107 S IBIFN=$P($G(^IBA(351.5,+$O(^IBA(351.5,"AUTH",AUTH,0)),0)),U,9)
108 S:'IBIFN IBIFN=-1
109ARECQ ;
110 D DTL(IBIFN,"TRICARE#",AUTH)
111 Q IBIFN
112 ;
113 ;
114EREC(AUTH) ; Find the Receivable for an ECME FI Number
115 ; Input: AUTH - Fiscal Intermediary ECME Number
116 ; Output: IBIFN >0 => ptr to claim/AR in files 399/430
117 ; -1 => No receivable found
118 ;
119 N IBIFN,IBC,IBX,IBA,IBE,IBES
120 S IBIFN=-1,IBC=0
121 I $G(AUTH)="" G ARECQ
122 S (IBE,IBES)=+AUTH_";"
123 F S IBE=$O(^DGCR(399,"AG",IBE)) Q:IBE'[IBES D
124 . S IBX=0 F S IBX=$O(^DGCR(399,"AG",IBE,IBX)) Q:'IBX D
125 .. I $P($G(^DGCR(399,IBX,0)),U,13)=7 Q ;exclude cancld
126 .. S IBA(IBX)="",IBC=IBC+1
127 I IBC'>1 S IBIFN=$O(IBA(0)) G ERECQ ; only one found
128 W !!,"More than one fill for ECME# ",AUTH," has been billed."
129 S IBIFN=$$SEL(.IBA)
130ERECQ S:'IBIFN IBIFN=-1
131 D DTL(IBIFN,"ECME#",AUTH) ;details
132 Q IBIFN
133 ;
134DTL(IBIFN,TYPE,AUTH) ;Details
135 Q:IBIFN'>0 Q:AUTH=""
136 N IBZ,IBBIL,IBPAT,IBPATN,IBRX,IB3624,IBDRUG,IBQTY,IBDAT,DIR
137 S IBZ=$G(^DGCR(399,IBIFN,0))
138 S IBBIL=$P(IBZ,U),IBPAT=$P(IBZ,U,2),IBDAT=$P(IBZ,U,3)
139 S IBPATN=$P($G(^DPT(+IBPAT,0)),U)
140 S IB3624=$G(^IBA(362.4,+$O(^IBA(362.4,"C",IBIFN,"")),0))
141 D ZERO^IBRXUTL(+$P(IB3624,U,4))
142 S IBDRUG=$G(^TMP($J,"IBDRUG",+$P(IB3624,U,4),.01))
143 K ^TMP($J,"IBDRUG")
144 S IBRX=$$FILE^IBRXUTL(+$P(IB3624,U,5),.01)
145 S IBQTY=+$P(IB3624,U,7)
146 W !!,"Found IB Bill ",IBBIL," matching to "_TYPE_" '",AUTH,"':"
147 W !,"Rx#",IBRX," ",$$DAT3^IBOUTL(IBDAT),", ",IBPATN,", ",IBDRUG I IBQTY W " (",IBQTY,")"
148 Q
149 ;
150AUD(IBIFN) ; Does the Accounts Receivable need to be audited?
151 ; Input: IBIFN - ptr to claim/AR in files 399/430
152 ; Output: 0 => Claim does not have to be audited
153 ; (claim was set up automatically)
154 ; 1 => Claim must be audited
155 ; (claim was established manually)
156 ;
157AUDQ Q $O(^IBA(351.5,"ACL",+$G(IBIFN),0))'>0
158 ;
159 ;
160TYP(IBIFN) ; Determine the bill type for an Accounts Receivable.
161 ; Input: IBIFN - ptr to claim/AR in files 399/430
162 ; Output: I => Inpatient bill
163 ; O => Outpatient bill
164 ; PH => Pharmacy bill
165 ; PR => Prosthetics bill
166 ;
167 ; or -1 if the bill type can't be determined.
168 ;
169 N IBATYP,IBATYPN,IBBG,IBN,IBND,IBTYP,IBX
170 S IBTYP=-1
171 I '$G(IBIFN) G TYPQ
172 ;
173 ; - see if AR originated from file #399
174 S IBX=$G(^DGCR(399,IBIFN,0))
175 I IBX]"" D G TYPQ
176 .S IBTYP=$$BTYP^IBCOIVM1(IBIFN,IBX)
177 .S IBTYP=$S(IBTYP="":-1,IBTYP="P":"PR",IBTYP="R":"PH",1:IBTYP)
178 ;
179 ; - get the bill number
180 S IBX=$P($G(^PRCA(430,IBIFN,0)),U)
181 I IBX="" G TYPQ
182 ;
183 ; - AR must have originated from file #350
184 S IBN=$O(^IB("ABIL",IBX,0))
185 I 'IBN G TYPQ
186 S IBND=$G(^IB(IBN,0))
187 I 'IBND G TYPQ
188 S IBATYP=$G(^IBE(350.1,+$P(IBND,U,3),0)),IBBG=$P(IBATYP,U,11)
189 ;
190 ; - handle TRICARE charges first
191 I IBBG=7 D G TYPQ
192 .S IBATYPN=$P(IBATYP,U)
193 .S IBTYP=$S(IBATYPN["INPT":"I",IBATYPN["OPT":"O",1:"PH")
194 ;
195 S IBTYP=$S(IBBG=4:"O",IBBG=5:"PH",IBBG=8:"O",1:"I")
196TYPQ Q IBTYP
197 ;
198RELBILL(IBIFN) ; given a Third Party Bill, find all related Third Party bills,
199 ; then find all First Party bills related to any of the Third Party bills
200 ; Input: IBIFN = internal file number of a Third Party bill
201 ; Output: Third Party Bills (#399)
202 ; ^TMP("IBRBT", $J, selected bill ifn) = PATIENT HAS ANY RX COVERAGE ON FROM DATE OF BILL?
203 ; ^TMP("IBRBT", $J, selected bill ifn, matching bill ifn) =
204 ; BILL FROM ^ BILL TO ^ CANCELLED? ^ AR BILL NUMBER ^
205 ; PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
206 ; Output: First Party Bills (#350)
207 ; ^TMP("IBRBF", $J , selected bill ifn ) = ""
208 ; ^TMP("IBRBF", $J , selected bill ifn , charge ifn) =
209 ; BILL FROM ^ BILL TO ^ CANCELLED? ^ AR BILL NUMBER ^
210 ; TOTAL CHARGE ^ ACTION TYPE (SHORT) ^ # DAYS ON HOLD
211 ;
212 N IBIFN1 I '$D(^DGCR(399,+$G(IBIFN),0)) Q
213 D TPTP^IBEFUR(IBIFN)
214 S IBIFN1=0 F S IBIFN1=$O(^TMP("IBRBT",$J,IBIFN,IBIFN1)) Q:'IBIFN1 D TPFP^IBEFUR(IBIFN1)
215 Q
216 ;
217SEL(IBARR) ; Select an rx bill
218 ; Input: IBARR - Array of IBIFN
219 ; Output: IBNUM - One of the bill iens, or -1
220 ;
221 N DIR,IBIFN,IBRXN,IBDT,IBZ,IBY,IBC,IBBIL,IBLNK,DFN,IBPT,I
222 ;
223 S IBIFN=$O(IBARR(""))
224 I 'IBIFN Q -1
225 I '$O(IBARR(IBIFN)) Q IBIFN ; no choice
226 ;
227 W !!?4,"Select one of the following:",!
228 W !?11,"BILL",?23,"RX",?33,"DATE",?46,"PATIENT"
229 W !?6 F I=1:1:60 W "-"
230 ;
231 S (IBIFN,IBC)=0
232 F S IBIFN=$O(IBARR(IBIFN)) Q:'IBIFN D
233 . S IBZ=$G(^DGCR(399,IBIFN,0)) Q:IBZ=""
234 . S DFN=+$P(IBZ,U,2),IBPT=$P($G(^DPT(DFN,0)),U)
235 . S IBBIL=$P(IBZ,U)
236 . S IBDT=$P(IBZ,U,3)
237 . S IBY=$G(^IBA(362.4,+$O(^IBA(362.4,"C",IBIFN,0)),0))
238 . S IBRXN=$P(IBY,U)
239 . S IBC=IBC+1
240 . S IBLNK(IBC)=IBIFN
241 . W !?6,IBC,?10,IBBIL," ",?20,IBRXN," ",?32,$$DAT1^IBOUTL(IBDT)," ",?45,IBPT
242 ;
243 ;
244 F R !!?4,"Select one of the bills by number: ",IBY:DTIME Q:'$T Q:"^"[IBY Q:$D(IBLNK(+IBY)) W:(IBY'="")&(IBY'["?") " ??" D
245 . W !!?8,"Enter numeric value from 1 to ",IBC
246 ;
247 S IBIFN=$G(IBLNK(+IBY),-1)
248 Q IBIFN
Note: See TracBrowser for help on using the repository browser.