| 1 | IBRFN ;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 | ;
|
|---|
| 5 | ERR(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)
|
|---|
| 15 | ERRQ Q IBRERR
|
|---|
| 16 | ;
|
|---|
| 17 | MESS(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 | ;
|
|---|
| 21 | SVDT(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 | ;
|
|---|
| 36 | REC(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 | ;
|
|---|
| 67 | RECQ Q IBAR
|
|---|
| 68 | ;
|
|---|
| 69 | RXREC(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 | ;
|
|---|
| 100 | AREC(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
|
|---|
| 109 | ARECQ ;
|
|---|
| 110 | D DTL(IBIFN,"TRICARE#",AUTH)
|
|---|
| 111 | Q IBIFN
|
|---|
| 112 | ;
|
|---|
| 113 | ;
|
|---|
| 114 | EREC(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)
|
|---|
| 130 | ERECQ S:'IBIFN IBIFN=-1
|
|---|
| 131 | D DTL(IBIFN,"ECME#",AUTH) ;details
|
|---|
| 132 | Q IBIFN
|
|---|
| 133 | ;
|
|---|
| 134 | DTL(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 | ;
|
|---|
| 150 | AUD(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 | ;
|
|---|
| 157 | AUDQ Q $O(^IBA(351.5,"ACL",+$G(IBIFN),0))'>0
|
|---|
| 158 | ;
|
|---|
| 159 | ;
|
|---|
| 160 | TYP(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")
|
|---|
| 196 | TYPQ Q IBTYP
|
|---|
| 197 | ;
|
|---|
| 198 | RELBILL(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 | ;
|
|---|
| 217 | SEL(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
|
|---|
