- 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/IBCEF75.m
r613 r623 1 IBCEF75 2 ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 AWAY 7 8 ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG) 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 I $TR($P(M1,U,COB+1)," ")]"" D69 70 71 72 73 74 75 76 I $TR($P(M1,U,COB+1)," ")="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 OLDWAY(IBIFN,COB) 104 105 106 107 108 109 BPSID1(DIV) 110 111 112 113 114 115 TAXID() 116 117 118 119 120 121 VAMCFD(IBIFN,IBRET) 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 CLEANUP(IBXSAVE) 154 155 156 157 158 1 IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006 2 ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94 3 ;; Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 G AWAY 6 AWAY Q 7 ; 8 ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS 9 I '$D(IBSTRIP) S IBSTRIP=0 10 I '$D(SEG) S SEG="" 11 N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB 12 ; 13 S IBXIEN=IBIFN 14 D ALLPROV^IBCEF7 ; Get the Person ID's (Returns IBXSAVE) 15 S DAT=$$PROVID^IBCEF73(IBIFN) 16 S DAT("QUAL")=IBXSAVE("ID") ; this value was also passed back by above function 17 S SORT1="" F S SORT1=$O(IBXSAVE("PROVINF",IBIFN,SORT1)) Q:SORT1="" D 18 . S SORT2=0 F S SORT2=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2)) Q:SORT2="" D 19 .. S SORT3=0 F S SORT3=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3)) Q:SORT3="" D 20 ... S IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($P(DAT("QUAL"),U,SORT3)_U_$P(DAT,U,SORT3),1,U,IBSTRIP) 21 ... F I=1:1 Q:'$D(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I)) D 22 .... S $P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4)=$$STRIP^IBCEF76($P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4),1,U,IBSTRIP) 23 ; 24 D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG) ; Get the Lab/Facility IDs 25 ; 26 S IBFRMTYP=$$FT^IBCEF(IBIFN) 27 S ARIEN=$S(IBFRMTYP=2:3,1:4) 28 S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance 29 F COB=1:1:3 D 30 . S SORT1=$S(COB=IBCCOB:"C",1:"O") 31 . S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2) 32 . S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1)) 33 . ; 34 . D BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG) 35 Q 36 ; 37 BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG) ; Get all the billing provider IDs and qualifiers from the claim and file 355.92 38 N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2 39 ; 40 S DAT=$G(^DGCR(399,IBIFN,0)) 41 S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0) 42 S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill 43 S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out 44 S IBDIV=+$P(DAT,U,22) 45 S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division 46 S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance 47 S IBINS=$P($G(^DGCR(399,IBIFN,"I"_COB)),U) 48 Q:IBINS="" 49 ; 50 S IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$E("PST",COB) 51 ; 52 ; Primary ID 53 S IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP) 54 S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))="" 55 ; 56 ; Secondary #1 - This is the ID Emdeon uses for sorting 57 S IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP) 58 S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))="" 59 ; 60 ; Check if this is a plan type which gets no secondary IDs 61 S M1=$G(^DGCR(399,IBIFN,"M1")) 62 ; the following check is the current value of the flag, not when the claim was created. 63 S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB) 64 I PLANTYPE]"",$D(^DIC(36,IBINS,13,"B",PLANTYPE)) Q 65 ; 66 ; Secondary #2 67 ; If there is a ID send with quailifer (stored or computed) 68 I $P(M1,U,COB+1)]"" D 69 . S QUAL="" 70 . S DAT=$P(M1,U,COB+9) 71 . I DAT S QUAL=$$STRIP^IBCEF76($P($G(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP) 72 . ; the null check is needed to be backwards compatible 73 . I QUAL=""!(QUAL="1J") S QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP) 74 . S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),1,,IBSTRIP) 75 ; 76 I $P(M1,U,COB+1)="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP) 77 ; 78 S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2 79 S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB) 80 S USED($P(IB2,U))="" 81 ; 82 S CNT=$S('$D(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3) 83 S IBLIMIT=8 84 S IEN=0 F S IEN=$O(^IBA(355.92,"B",IBINS,IEN)) Q:IEN="" D Q:CNT>IBLIMIT 85 . S DAT=$G(^IBA(355.92,IEN,0)) 86 . Q:$P(DAT,U,8)'="A" ; only allow additional IDs 87 . Q:$P(DAT,U,7)="" ; No Provider ID 88 . Q:$P(DAT,U,6)="" ; No ID Qualifier 89 . I IBFRMTYP=1 Q:$P(DAT,U,4)=2 90 . I IBFRMTYP=2 Q:$P(DAT,U,4)=1 91 . ; 92 . ; Check if we already have one of these 93 . S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP) 94 . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3) 95 . Q:QUAL="" 96 . Q:$D(USED(QUAL)) 97 . ; 98 . S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP) 99 . S CNT=CNT+1,USED(QUAL)="" 100 ; 101 Q 102 ; 103 OLDWAY(IBIFN,COB) ; Figure out the qualifier the old way if it's not stored with the claim. 104 ; It's based on the plan type. This is used for Billing Provider Secondary ID #2 105 N PLANTYPE 106 S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB) 107 Q $$SOP^IBCEP2B(IBIFN,PLANTYPE) 108 ; 109 BPSID1(DIV) ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs 110 N DATA 111 S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$SITE^VASITE())),U,3) 112 S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7) 113 Q "G5"_U_DATA 114 ; 115 TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier 116 N DATA 117 S DATA=$P($G(^IBE(350.9,1,1)),U,5) 118 S DATA=$$NOPUNCT^IBCEF(DATA,1) 119 Q 24_U_DATA 120 ; 121 VAMCFD(IBIFN,IBRET) ; 122 ; 123 ; This procedure returns data based on flag in insurance company file which is set in the insurance co editor 124 ; Send VA Lab/Facility IDs or Facility Data for VAMC? 125 ; The return value will be set to 1 (yes) if the division in the claim is not the main division (VAMC) or 126 ; if the flag in the dictionary for that insurance company says to send the data. 127 ; 128 ; Input - IBFN - IEN 399 129 ; Output - IBRET(IBSORT1,IBSORT2)=FLAG 130 ; IBSORT1 = "C"urrent or "O"ther insurance 131 ; IBSORT2 = order with IBSORT1 132 ; FLAG = 0 No or 1 Yes 133 ; 134 N IBDIV,MAIN,IBCCOB,IBSORT1,IBSORT2,DAT,IBINS,COB,OUTFAC 135 S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22) 136 S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division 137 S IBCCOB=$$COBN^IBCEF(IBIFN) 138 F COB=1:1:3 D 139 . S IBSORT1=$S(COB=IBCCOB:"C",1:"O") 140 . S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2) 141 . S IBINS=+$G(^DGCR(399,IBIFN,"I"_COB)) 142 . Q:'IBINS 143 . S IBRET(IBSORT1,IBSORT2)=1 144 . S OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10) 145 . Q:OUTFAC]"" 146 . Q:IBDIV'=MAIN 147 . ; [7] Send VA Lab/Facility IDs or Facility Data for VAMC?(0 - NO, 1 - YES) 148 . S DAT(3647)=$P($G(^DIC(36,IBINS,4)),U,7) 149 . I DAT(3647) Q 150 . S IBRET(IBSORT1,IBSORT2)=0 151 Q 152 ; 153 CLEANUP(IBXSAVE) ; Clean up 154 K IBXSAVE("PROVINF") 155 K IBXSAVE("LAB/FAC") 156 K IBXSAVE("BILLING PRV") 157 K IBXSAVE("ID") 158 Q
Note:
See TracChangeset
for help on using the changeset viewer.
