- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m
r613 r623 1 IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89 2 ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363,371,395**;21-MAR-94;Build 3 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;MAP TO DGCRBB1 6 ; 7 % ;Bill Status 8 N Z,Z0,Z1 9 I $S(+IBST=0:1,1:"^1^2^3^4^7^"'[(U_IBST_U)) S IBER=IBER_"IB045;" 10 ; 11 ;Statement Covers From 12 I IBFDT="" S IBER=IBER_"IB061;" 13 I IBFDT]"",IBFDT'?7N&(IBFDT'?7N1".".N) S IBER=IBER_"IB061;" 14 I IBFDT>IBTDT S IBER=IBER_"IB061;" ; from must be on or before the to date 15 S IBFFY=$$FY^IBOUTL(IBFDT) 16 ; if inpat - from date must not be prior to admit date. 17 I $$INPAT^IBCEF(IBIFN,1),(IBFDT<($P($G(^DGPT(+$P(IBND0,U,8),0)),U,2)\1)) S IBER=IBER_"IB061;" 18 ; 19 ;Statement Covers To 20 I IBTDT="" S IBER=IBER_"IB062;" 21 I IBTDT]"",IBTDT'?7N&(IBTDT'?7N1".".N) S IBER=IBER_"IB062;" 22 I IBTDT>DT!(IBTDT<IBFDT) S IBER=IBER_"IB062;" ; to date must not be >than today's date 23 S IBTFY=$$FY^IBOUTL(IBTDT) 24 ; 25 ;Total Charges 26 I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;" 27 ; 28 ;Billable charges for secondary claim 29 I $$MCRONBIL^IBEFUNC(IBIFN)&(($P(IBNDU1,U,1)-$P(IBNDU1,U,2))'>0) S IBER=IBER_"IB094;" 30 ;Fiscal Year 1 31 S IBFFY=$$FY^IBOUTL(IBFDT) 32 ; 33 ;Check provider link for current user, enterer, reviewer and Authorizor 34 I '$D(^VA(200,DUZ,0)) S IBER=IBER_"IB048;" 35 I IBEU]"",'$D(^VA(200,IBEU,0)) S IBER=IBER_"IB048;" 36 I IBRU]"",'$D(^VA(200,IBRU,0)) S IBER=IBER_"IB060;" 37 I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;" 38 ; 39 I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;" 40 ; If ins bill, must have valid COB sequence 41 I $P(IBND0,U,11)="i",$S($P(IBND0,U,21)="":1,1:"PST"'[$P(IBND0,U,21)) S IBER=IBER_"IB324;" 42 ; 43 ; Check for valid sec provider id for current ins 44 S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z S Z0=$G(^(Z,0)),Z1=+$$COBN^IBCEF(IBIFN) I $P(Z0,U,4+Z1)'="",$P(Z0,U,11+Z1)'="" D 45 . I '$$SECIDCK^IBCEF74(IBIFN,Z1,$P(Z0,U,11+Z1),Z) D WARN^IBCBB11("Prov secondary id type for the "_$P("PRIMARY^SECONDARY^TERTIARY",U,Z1)_" "_$$EXTERNAL^DILFD(399.0222,.01,,+Z0)_" is invalid/won't transmit") 46 ; Check NPIs 47 D NPICHK^IBCBB11 48 ; 49 ; Check multiple rx NPIs 50 D RXNPI^IBCBB11(IBIFN) 51 ; 52 ; Check taxonomies 53 D TAXCHK^IBCBB11 54 ; 55 ; Check for Physician Name 56 K IBXDATA D F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN) 57 I $P($G(IBXDATA),U)="" S IBER=IBER_"IB303;" 58 ; 59 N FUNCTION,IBINS 60 S FUNCTION=$S($$FT^IBCEF(IBIFN)=3:4,1:3) 61 I IBER'["IB303;" D 62 . F IBINS=1:1:3 D 63 .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS) 64 .. I Z,$P(Z,U,2) D ; Rendering/attending prov secondary id required 65 ... N IBID,IBOK,Q0 66 ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C") ; check all as though they were current 67 ... S IBOK=0 68 ... S Q0=0 F S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0 I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q 69 ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"") 70 ; 71 D PRIIDCHK^IBCBB11 72 ; 73 N IBM,IBM1 74 S IBM=$G(^DGCR(399,IBIFN,"M")) 75 S IBM1=$G(^DGCR(399,IBIFN,"M1")) 76 I $P(IBM,U),$P($G(^DIC(36,$P(IBM,U),4)),U,6),$P(IBM1,U,2)="" S IBER=IBER_"IB244;" 77 I $P(IBM,U,2),$P($G(^DIC(36,$P(IBM,U,2),4)),U,6),$P(IBM1,U,3)="" S IBER=IBER_"IB245;" 78 I $P(IBM,U,3),$P($G(^DIC(36,$P(IBM,U,3),4)),U,6),$P(IBM1,U,4)="" S IBER=IBER_"IB246;" 79 ; 80 ; If outside facility, check for ID and qualifier in 355.93 81 ; 5/15/06 - esg - hard error IB243 turned into warning message instead 82 S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10) 83 I Z D 84 . I $P($G(^IBA(355.93,Z,0)),U,9)=""!($P($G(^IBA(355.93,Z,0)),U,13)="") D 85 .. N Z1,Z2 86 .. S Z1="Missing Lab or Facility Primary ID for non-VA facility, " 87 .. S Z2=$$EXTERNAL^DILFD(399,232,,Z) 88 .. I $L(Z2)'>19 D WARN^IBCBB11(Z1_Z2) Q 89 .. D WARN^IBCBB11(Z1),WARN^IBCBB11(" "_Z2) 90 .. Q 91 . Q 92 ; 93 ; Must be one and only one division on bill 94 S IBZ=$$MULTDIV^IBCBB11(IBIFN,IBND0) 95 I IBZ S IBER=IBER_$S(IBZ=1:"IB095;",IBZ=2:"IB104;",1:"IB105;") 96 ; Division address must be defined in institution file 97 I $P(IBND0,U,22) D 98 . N Z,Z0,Z1 99 . S Z0=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),0)) 100 . S Z1=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),1)) 101 . I $P(Z0,U,2)="" S IBER=IBER_"IB097;" Q 102 . F Z=1,3,4 I $P(Z1,U,Z)="" S IBER=IBER_"IB097;" Q 103 ; 104 ;CHAMPVA Rate Type and Primary Insurance Carriers Type of Coverage must match 105 S (IBRTCHV,IBPICHV)=0 106 I $P($G(^DGCR(399.3,+IBAT,0)),U,1)="CHAMPVA" S IBRTCHV=1 107 I $P($G(^IBE(355.2,+$P($G(^DIC(36,+IBNDMP,0)),U,13),0)),U,1)="CHAMPVA" S IBPICHV=1 108 I (+IBRTCHV!+IBPICHV)&('IBRTCHV!'IBPICHV) S IBER=IBER_"IB085;" 109 ; 110 N IBZPRC,IBZPRCUB 111 D F^IBCEF("N-ALL PROCEDURES","IBZPRC",,IBIFN) 112 ; Procedure Clinic is required for Surgical Procedures Outpt Facility Charges 113 I +$P(IBND0,U,27)'=2,$$BILLRATE^IBCRU3(IBAT,IBCL,IBEVDT,"RC OUTPATIENT") D 114 . N Z,Z0,Z1,ZE S (ZE,Z)=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z D I +ZE S IBER=IBER_"IB320;" Q 115 .. S Z0=$G(^DGCR(399,IBIFN,"CP",Z,0)),Z1=+Z0 I Z0'[";ICPT(" Q 116 .. I '((Z1'<10000)&(Z1'>69999))&'((Z1'<93501)&(Z1'>93533)) Q 117 .. I '$P(Z0,U,7) S ZE=1 118 ; 119 ; Extract procedures for UB-04 120 D F^IBCEF("N-UB-04 PROCEDURES","IBZPRCUB",,IBIFN) 121 ; Does this bill have ANY prescriptions associated with it? 122 ; Must bill prescriptions separately from other charges 123 ; 124 I $$ISRX^IBCEF1(IBIFN) D 125 . N IBZ,IBRXDEF 126 . S IBRXDEF=$P($G(^IBE(350.9,1,1)),U,30),IBZ=0 127 . F S IBZ=$O(IBZPRCUB(IBZ)) Q:'IBZ I IBZPRCUB(IBZ),+$P(IBZPRCUB(IBZ),U)'=IBRXDEF S IBER=IBER_"IB102;" Q 128 . K IBZ 129 ; 130 ; Check that COB sequences are not skipped 131 K Z 132 F Z=1:1:3 S:+$G(^DGCR(399,IBIFN,"I"_Z)) Z(Z)="" 133 F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0 I Z0'=(Z+1) S IBER=IBER_"IB322;" Q 134 K Z 135 ; HD64676 IB*2*371 - OK for payer sequence to be blank when the Rate 136 ; Type is either Interagency or Sharing Agreement 137 I $P($G(^DGCR(399,IBIFN,0)),U,21)="",$P($G(^DGCR(399,IBIFN,0)),U,7)'=4,$P($G(^DGCR(399,IBIFN,0)),U,7)'=9 S IBER=IBER_"IB323;" 138 K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN) 139 ; Coding method should agree with types of procedure codes 140 S IBOK=$S('$O(IBZPRC(0))!(IBXDATA=""):1,1:0) 141 I 'IBOK S IBOK=1,IBZ=0 F S IBZ=$O(IBZPRC(IBZ)) Q:'IBZ I IBZPRC(IBZ),$P(IBZPRC(IBZ),U)'[$S(IBXDATA=9:"ICD",1:"ICP") S IBOK=0 Q 142 I 'IBOK D WARN^IBCBB11("Coding Method does not agree with all procedure codes found on bill") 143 D EDITMRA^IBCBB3(.IBQUIT,.IBER,IBIFN,IBFT) 144 Q:$G(IBQUIT) 145 ; 146 ;Other things that could be added: Rev Code - calculating charges 147 ; Diagnosis Coding, if MT copay - check for other co-payments 148 ; 149 I $P(IBNDTX,U,8),$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB121;" ; can't force MRAs to print 150 I $P(IBNDTX,U,8)!$P(IBNDTX,U,9) D WARN^IBCBB11($S($$REQMRA^IBEFUNC(IBIFN)&($P(IBNDTX,U,9)):"MRA Secondary ",1:"")_"Bill has been forced to print "_$S($P(IBNDTX,U,8)=1!($P(IBNDTX,U,9)=1):"locally",1:"at clearinghouse")) 151 N IBXZ,IBIZ F IBIZ=12,13,14 S IBXZ=$P(IBNDM,U,IBIZ) I +IBXZ S IBXZ=$P($G(^DPT(DFN,.312,IBXZ,0)),U,18) I +IBXZ S IBXZ=$G(^IBA(355.3,+IBXZ,0)) I +$P(IBXZ,U,12) D 152 . D WARN^IBCBB11($P($G(^DIC(36,+IBXZ,0)),U,1)_" requires Amb Care Certification") 153 ; 154 D VALNDC^IBCBB11(IBIFN,DFN) ;validate NDC# 155 ; 156 ;Build AR array if no errors and MRA not needed or already rec'd 157 I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY 158 ; 159 END ;Don't kill IBIFN, IBER, DFN 160 I $O(^TMP($J,"BILL-WARN",0)),$G(IBER)="" S IBER="WARN" ;Warnings only 161 K IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBMRA,IBTOB,IBTOB12,IBNDU2,IBNDUF3,IBNDUF31,IBNDTX 162 K IBNDS,IBND0,IBNDU,IBNDM,IBNDMP,IBNDU1,IBFFY,IBTFY,IBFT,IBRTCHV,IBPICHV,IBXDATA,IBOK 163 I $D(IBER),IBER="" W !,"No Errors found for National edits" 164 Q 165 ; 166 ARRAY ;Build PRCASV(array) 167 N IBCOBN,X 168 K PRCASV 169 Q:$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) 170 S IBCOBN=$$COBN^IBCEF(IBIFN) 171 S X=IBIFN 172 S PRCASV("BDT")=DT,PRCASV("ARREC")=IBIFN 173 S PRCASV("APR")=DUZ 174 S PRCASV("PAT")=DFN,PRCASV("CAT")=$P(^DGCR(399.3,IBAT,0),"^",6) 175 I IBWHO="i" S PRCASV("DEBTOR")=+IBNDMP_";DIC(36," 176 S PRCASV("DEBTOR")=$S(IBWHO="p":DFN_";DPT(",IBWHO="o":$P(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"") 177 S PRCASV("CARE")=$E($$TOB^IBCEF1(IBIFN),1,2) 178 S PRCASV("FY")=$$FY^IBOUTL(DT)_U_($P(IBNDU1,U)-$P(IBNDU1,U,2)) 179 ;S PRCASV("FY")=$P(IBNDU1,U,9)_U_$S($P(IBNDU1,U,2)]"":($P(IBNDU1,U,10)-$P(IBNDU1,U,2)),1:$P(IBNDU1,U,10))_$S($P(IBNDU1,U,11)]"":U_$P(IBNDU1,U,11)_U_$P(IBNDU1,U,12),1:"") 180 PLUS I IBWHO="i",$P(IBNDM,"^",2),$D(^DIC(36,$P(IBNDM,"^",2),0)) S PRCASV("2NDINS")=$P(IBNDM,"^",2) 181 I IBWHO="i",$P(IBNDM,"^",3),$D(^DIC(36,$P(IBNDM,"^",3),0)) S PRCASV("3RDINS")=$P(IBNDM,"^",3) 182 ; 183 N IBX S IBX=$P(IBND0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:"") Q:IBX="" 184 N IBNDI1 185 Q:'$D(^DGCR(399,IBIFN,IBX)) S IBNDI1=^(IBX) 186 S:$P(IBNDI1,"^",3)]"" PRCASV("GPNO")=$P(IBNDI1,"^",3) 187 S:$P(IBNDI1,"^",15)]"" PRCASV("GPNM")=$P(IBNDI1,"^",15) 188 S:$P(IBNDI1,"^",17)]"" PRCASV("INPA")=$P(IBNDI1,"^",17) 189 S:$P(IBNDI1,"^",2)]"" PRCASV("IDNO")=$P(IBNDI1,"^",2),PRCASV("INID")=PRCASV("IDNO") 190 ; Check that this is a secondary or tertiary bill and insurance for previous 191 ; COB sequence is Medicare WNR and MRA is active --> send data elements to AR 192 I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1),$$EDIACTV^IBCEF4(2) D MRA 193 Q 194 ; 195 MRA N IBEOB S IBEOB=0 196 ; 197 K PRCASV("MEDURE"),PRCASV("MEDCA") 198 ; Get EOB data 199 F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D 200 . D MRACALC^IBCEMU2(IBEOB,IBIFN,1,.PRCASV) 201 Q ;MRA 202 ; 203 ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677** 204 ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009 1 IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89 2 ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363**;21-MAR-94;Build 35 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;MAP TO DGCRBB1 6 ; 7 % ;Bill Status 8 N Z,Z0,Z1 9 I $S(+IBST=0:1,1:"^1^2^3^4^7^"'[(U_IBST_U)) S IBER=IBER_"IB045;" 10 ; 11 ;Statement Covers From 12 I IBFDT="" S IBER=IBER_"IB061;" 13 I IBFDT]"",IBFDT'?7N&(IBFDT'?7N1".".N) S IBER=IBER_"IB061;" 14 I IBFDT>IBTDT S IBER=IBER_"IB061;" ; from must be on or before the to date 15 S IBFFY=$$FY^IBOUTL(IBFDT) 16 ; if inpat - from date must not be prior to admit date. 17 I $$INPAT^IBCEF(IBIFN,1),(IBFDT<($P($G(^DGPT(+$P(IBND0,U,8),0)),U,2)\1)) S IBER=IBER_"IB061;" 18 ; 19 ;Statement Covers To 20 I IBTDT="" S IBER=IBER_"IB062;" 21 I IBTDT]"",IBTDT'?7N&(IBTDT'?7N1".".N) S IBER=IBER_"IB062;" 22 I IBTDT>DT!(IBTDT<IBFDT) S IBER=IBER_"IB062;" ; to date must not be >than today's date 23 S IBTFY=$$FY^IBOUTL(IBTDT) 24 ; 25 ;Statement crosses fiscal years 26 ;I IBTFY'=IBFFY S IBER=IBER_"IB047;" 27 ; 28 ;Statement crosses calendar years 29 ;I $E(IBTDT,1,3)'=$E(IBFDT,1,3) S IBER=IBER_"IB046;" 30 ; 31 ;Total Charges 32 I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;" 33 ; 34 ;Billable charges for secondary claim 35 I $$MCRONBIL^IBEFUNC(IBIFN)&(($P(IBNDU1,U,1)-$P(IBNDU1,U,2))'>0) S IBER=IBER_"IB094;" 36 ;Fiscal Year 1 37 S IBFFY=$$FY^IBOUTL(IBFDT) 38 ; 39 ;Check provider link for current user, enterer, reviewer and Authorizor 40 I '$D(^VA(200,DUZ,0)) S IBER=IBER_"IB048;" 41 I IBEU]"",'$D(^VA(200,IBEU,0)) S IBER=IBER_"IB048;" 42 I IBRU]"",'$D(^VA(200,IBRU,0)) S IBER=IBER_"IB060;" 43 I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;" 44 ; 45 ;Bill exists and not already new bill 46 ;I $S('$D(^PRCA(430,IBIFN,0)):1,$P($P(^PRCA(430,IBIFN,0),"^"),"-",2)'=IBBNO:1,1:0) S IBER=IBER_"IB056;" 47 ;I $P($$BN^PRCAFN(IBIFN),"-",2)'=IBBNO S IBER=IBER_"IB056;" 48 ;I IBER="",$P(^PRCA(430,IBIFN,0),"^",8)=$O(^PRCA(430.3,"AC",104,"")) S IBER=IBER_"IB040;" 49 I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;" 50 ; If ins bill, must have valid COB sequence 51 I $P(IBND0,U,11)="i",$S($P(IBND0,U,21)="":1,1:"PST"'[$P(IBND0,U,21)) S IBER=IBER_"IB324;" 52 ; 53 ; Check for valid sec provider id for current ins 54 S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z S Z0=$G(^(Z,0)),Z1=+$$COBN^IBCEF(IBIFN) I $P(Z0,U,4+Z1)'="",$P(Z0,U,11+Z1)'="" D 55 . I '$$SECIDCK^IBCEF74(IBIFN,Z1,$P(Z0,U,11+Z1),Z) D WARN^IBCBB11("Prov secondary id type for the "_$P("PRIMARY^SECONDARY^TERTIARY",U,Z1)_" "_$$EXTERNAL^DILFD(399.0222,.01,,+Z0)_" is invalid/won't transmit") 56 ; Check NPIs 57 D NPICHK^IBCBB11 58 ; 59 ; Check taxonomies 60 D TAXCHK^IBCBB11 61 ; 62 ; Check for Physician Name 63 K IBXDATA D F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN) 64 I $P($G(IBXDATA),U)="" S IBER=IBER_"IB303;" 65 ; 66 N FUNCTION,IBINS 67 S FUNCTION=$S($$FT^IBCEF(IBIFN)=3:4,1:3) 68 I IBER'["IB303;" D 69 . F IBINS=1:1:3 D 70 .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS) 71 .. I Z,$P(Z,U,2) D ; Rendering/attending prov secondary id required 72 ... N IBID,IBOK,Q0 73 ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C") ; check all as though they were current 74 ... S IBOK=0 75 ... S Q0=0 F S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0 I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q 76 ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"") 77 . I $$TXMT^IBCEF4(IBIFN) D 78 .. D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN) 79 .. I $P(IBZ,U,3)=""&($P(IBZ,U,4)="") S IBER=IBER_"IB321;" ; SSN/IEN required for rend/att 80 ; 81 N IBM,IBM1 82 S IBM=$G(^DGCR(399,IBIFN,"M")) 83 S IBM1=$G(^DGCR(399,IBIFN,"M1")) 84 I $P(IBM,U),$P($G(^DIC(36,$P(IBM,U),4)),U,6),$P(IBM1,U,2)="" S IBER=IBER_"IB244;" 85 I $P(IBM,U,2),$P($G(^DIC(36,$P(IBM,U,2),4)),U,6),$P(IBM1,U,3)="" S IBER=IBER_"IB245;" 86 I $P(IBM,U,3),$P($G(^DIC(36,$P(IBM,U,3),4)),U,6),$P(IBM1,U,4)="" S IBER=IBER_"IB246;" 87 ; 88 ; If outside facility, check for ID and qualifier in 355.93 89 ; 5/15/06 - esg - hard error IB243 turned into warning message instead 90 S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10) 91 I Z D 92 . I $P($G(^IBA(355.93,Z,0)),U,9)=""!($P($G(^IBA(355.93,Z,0)),U,13)="") D 93 .. N Z1,Z2 94 .. S Z1="Missing Lab or Facility Primary ID for non-VA facility, " 95 .. S Z2=$$EXTERNAL^DILFD(399,232,,Z) 96 .. I $L(Z2)'>19 D WARN^IBCBB11(Z1_Z2) Q 97 .. D WARN^IBCBB11(Z1),WARN^IBCBB11(" "_Z2) 98 .. Q 99 . Q 100 ; 101 ; Must be one and only one division on bill 102 S IBZ=$$MULTDIV^IBCBB11(IBIFN,IBND0) 103 I IBZ S IBER=IBER_$S(IBZ=1:"IB095;",IBZ=2:"IB104;",1:"IB105;") 104 ; Division address must be defined in institution file 105 I $P(IBND0,U,22) D 106 . N Z,Z0,Z1 107 . S Z0=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),0)) 108 . S Z1=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),1)) 109 . I $P(Z0,U,2)="" S IBER=IBER_"IB097;" Q 110 . F Z=1,3,4 I $P(Z1,U,Z)="" S IBER=IBER_"IB097;" Q 111 ; 112 ;CHAMPVA Rate Type and Primary Insurance Carriers Type of Coverage must match 113 S (IBRTCHV,IBPICHV)=0 114 I $P($G(^DGCR(399.3,+IBAT,0)),U,1)="CHAMPVA" S IBRTCHV=1 115 I $P($G(^IBE(355.2,+$P($G(^DIC(36,+IBNDMP,0)),U,13),0)),U,1)="CHAMPVA" S IBPICHV=1 116 I (+IBRTCHV!+IBPICHV)&('IBRTCHV!'IBPICHV) S IBER=IBER_"IB085;" 117 ; 118 N IBZPRC,IBZPRCUB 119 D F^IBCEF("N-ALL PROCEDURES","IBZPRC",,IBIFN) 120 ; Procedure Clinic is required for Surgical Procedures Outpt Facility Charges 121 I +$P(IBND0,U,27)'=2,$$BILLRATE^IBCRU3(IBAT,IBCL,IBEVDT,"RC OUTPATIENT") D 122 . N Z,Z0,Z1,ZE S (ZE,Z)=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z D I +ZE S IBER=IBER_"IB320;" Q 123 .. S Z0=$G(^DGCR(399,IBIFN,"CP",Z,0)),Z1=+Z0 I Z0'[";ICPT(" Q 124 .. I '((Z1'<10000)&(Z1'>69999))&'((Z1'<93501)&(Z1'>93533)) Q 125 .. I '$P(Z0,U,7) S ZE=1 126 ; 127 ; Extract procedures for UB-04 128 D F^IBCEF("N-UB-04 PROCEDURES","IBZPRCUB",,IBIFN) 129 ; Does this bill have ANY prescriptions associated with it? 130 ; Must bill prescriptions separately from other charges 131 ; 132 I $$ISRX^IBCEF1(IBIFN) D 133 . N IBZ,IBRXDEF 134 . S IBRXDEF=$P($G(^IBE(350.9,1,1)),U,30),IBZ=0 135 . F S IBZ=$O(IBZPRCUB(IBZ)) Q:'IBZ I IBZPRCUB(IBZ),+$P(IBZPRCUB(IBZ),U)'=IBRXDEF S IBER=IBER_"IB102;" Q 136 . K IBZ 137 ; 138 ; Check that COB sequences are not skipped 139 K Z 140 F Z=1:1:3 S:+$G(^DGCR(399,IBIFN,"I"_Z)) Z(Z)="" 141 F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0 I Z0'=(Z+1) S IBER=IBER_"IB322;" Q 142 K Z 143 I $P($G(^DGCR(399,IBIFN,0)),U,21)="" S IBER=IBER_"IB323;" 144 K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN) 145 ; Coding method should agree with types of procedure codes 146 S IBOK=$S('$O(IBZPRC(0))!(IBXDATA=""):1,1:0) 147 I 'IBOK S IBOK=1,IBZ=0 F S IBZ=$O(IBZPRC(IBZ)) Q:'IBZ I IBZPRC(IBZ),$P(IBZPRC(IBZ),U)'[$S(IBXDATA=9:"ICD",1:"ICP") S IBOK=0 Q 148 I 'IBOK D WARN^IBCBB11("Coding Method does not agree with all procedure codes found on bill") 149 D EDITMRA^IBCBB3(.IBQUIT,.IBER,IBIFN,IBFT) 150 Q:$G(IBQUIT) 151 ; 152 ;Other things that could be added: Rev Code - calculating charges 153 ; Diagnosis Coding, if MT copay - check for other co-payments 154 ; 155 I $P(IBNDTX,U,8),$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB121;" ; can't force MRAs to print 156 I $P(IBNDTX,U,8)!$P(IBNDTX,U,9) D WARN^IBCBB11($S($$REQMRA^IBEFUNC(IBIFN)&($P(IBNDTX,U,9)):"MRA Secondary ",1:"")_"Bill has been forced to print "_$S($P(IBNDTX,U,8)=1!($P(IBNDTX,U,9)=1):"locally",1:"at clearinghouse")) 157 N IBXZ,IBIZ F IBIZ=12,13,14 S IBXZ=$P(IBNDM,U,IBIZ) I +IBXZ S IBXZ=$P($G(^DPT(DFN,.312,IBXZ,0)),U,18) I +IBXZ S IBXZ=$G(^IBA(355.3,+IBXZ,0)) I +$P(IBXZ,U,12) D 158 . D WARN^IBCBB11($P($G(^DIC(36,+IBXZ,0)),U,1)_" requires Amb Care Certification") 159 ; 160 D VALNDC^IBCBB11(IBIFN,DFN) ;validate NDC# 161 ;Build AR array if no errors and MRA not needed or already rec'd 162 I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY 163 ; 164 END ;Don't kill IBIFN, IBER, DFN 165 I $O(^TMP($J,"BILL-WARN",0)),$G(IBER)="" S IBER="WARN" ;Warnings only 166 K IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBMRA,IBTOB,IBTOB12,IBNDU2,IBNDUF3,IBNDUF31,IBNDTX 167 K IBNDS,IBND0,IBNDU,IBNDM,IBNDMP,IBNDU1,IBFFY,IBTFY,IBFT,IBRTCHV,IBPICHV,IBXDATA,IBOK 168 I $D(IBER),IBER="" W !,"No Errors found for National edits" 169 Q 170 ; 171 ARRAY ;Build PRCASV(array) 172 N IBCOBN,X 173 K PRCASV 174 Q:$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) 175 S IBCOBN=$$COBN^IBCEF(IBIFN) 176 S X=IBIFN 177 S PRCASV("BDT")=DT,PRCASV("ARREC")=IBIFN 178 S PRCASV("APR")=DUZ 179 S PRCASV("PAT")=DFN,PRCASV("CAT")=$P(^DGCR(399.3,IBAT,0),"^",6) 180 I IBWHO="i" S PRCASV("DEBTOR")=+IBNDMP_";DIC(36," 181 S PRCASV("DEBTOR")=$S(IBWHO="p":DFN_";DPT(",IBWHO="o":$P(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"") 182 S PRCASV("CARE")=$E($$TOB^IBCEF1(IBIFN),1,2) 183 S PRCASV("FY")=$$FY^IBOUTL(DT)_U_($P(IBNDU1,U)-$P(IBNDU1,U,2)) 184 ;S PRCASV("FY")=$P(IBNDU1,U,9)_U_$S($P(IBNDU1,U,2)]"":($P(IBNDU1,U,10)-$P(IBNDU1,U,2)),1:$P(IBNDU1,U,10))_$S($P(IBNDU1,U,11)]"":U_$P(IBNDU1,U,11)_U_$P(IBNDU1,U,12),1:"") 185 PLUS I IBWHO="i",$P(IBNDM,"^",2),$D(^DIC(36,$P(IBNDM,"^",2),0)) S PRCASV("2NDINS")=$P(IBNDM,"^",2) 186 I IBWHO="i",$P(IBNDM,"^",3),$D(^DIC(36,$P(IBNDM,"^",3),0)) S PRCASV("3RDINS")=$P(IBNDM,"^",3) 187 ; 188 N IBX S IBX=$P(IBND0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:"") Q:IBX="" 189 N IBNDI1 190 Q:'$D(^DGCR(399,IBIFN,IBX)) S IBNDI1=^(IBX) 191 S:$P(IBNDI1,"^",3)]"" PRCASV("GPNO")=$P(IBNDI1,"^",3) 192 S:$P(IBNDI1,"^",15)]"" PRCASV("GPNM")=$P(IBNDI1,"^",15) 193 S:$P(IBNDI1,"^",17)]"" PRCASV("INPA")=$P(IBNDI1,"^",17) 194 S:$P(IBNDI1,"^",2)]"" PRCASV("IDNO")=$P(IBNDI1,"^",2),PRCASV("INID")=PRCASV("IDNO") 195 ; Check that this is a secondary or tertiary bill and insurance for previous 196 ; COB sequence is Medicare WNR and MRA is active --> send data elements to AR 197 I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1),$$EDIACTV^IBCEF4(2) D MRA 198 Q 199 ; 200 MRA N IBEOB S IBEOB=0 201 ; 202 K PRCASV("MEDURE"),PRCASV("MEDCA") 203 ; Get EOB data 204 F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D 205 . D MRACALC^IBCEMU2(IBEOB,IBIFN,1,.PRCASV) 206 Q ;MRA 207 ; 208 ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677** 209 ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009
Note:
See TracChangeset
for help on using the changeset viewer.
