source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 6.2 KB
Line 
1IBCEF75 ;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
6AWAY Q
7 ;
8ALLIDS(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 ;
37BPIDS(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 ;
103OLDWAY(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 ;
109BPSID1(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 ;
115TAXID() ; 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 ;
121VAMCFD(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 ;
153CLEANUP(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 TracBrowser for help on using the repository browser.