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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1IBCEF76 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
2 ;;2.0;INTEGRATED BILLING;**320,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 G AWAY
6AWAY Q
7 ;
8LFIDS(IBIFN,IDS,IBSTRIP,SEG) ;
9 ; Pass in the the internal claim number and return the array of IDS.
10 ; IDS("C"urrent or "O"ther, Order of Insurance within subscript 1, order of ID within subscript 2)
11 ; IDS("C",1)="P"
12 ; IDS("C",1,0)=Qualifier^Primary ID
13 ; IDS("C",1,1)=Qualifier^Sec ID #1
14 ; IDS("C",1,2)=Qualifier^Sec ID #2
15 ;
16 N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,OUTFAC,MAIN,IBCCOB,TMPIDS,COB,IBSORT1,IBSORT2,IBLIMIT
17 ;
18 S DAT=$G(^DGCR(399,IBIFN,0))
19 S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
20 S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
21 S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
22 S IBDIV=+$P(DAT,U,22)
23 S OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
24 S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division
25 ;
26 S IBCCOB=$$COBN^IBCEF(IBIFN)
27 F COB=1:1:3 D
28 . S IBSORT1=$S(COB=IBCCOB:"C",1:"O")
29 . S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
30 . S IBLIMIT=$S(IBSORT1="C":5,1:3) ; Limit secondary IDs
31 . S DAT=$G(^DGCR(399,IBIFN,"I"_COB))
32 .;
33 . S IBINS=$P(DAT,U) ; insurance PTR 36
34 . Q:IBINS=""
35 .;
36 . I OUTFAC]"" D Q
37 .. D NONVALF(IBIFN,OUTFAC_";IBA(355.93,",IBINS,IBFRMTYP,IBCARE,.IDS,IBSORT1,IBSORT2,COB,IBLIMIT,IBSTRIP,SEG)
38 . ;
39 . I OUTFAC="" D
40 .. ; [7] Send VA Lab/Facility IDs or Facility Data for VAMC?(0 - NO, 1 - YES)
41 .. S DAT(3647)=$P($G(^DIC(36,IBINS,4)),U,7)
42 .. I 'DAT(3647),IBDIV=MAIN Q
43 .. S IDS("LAB/FAC",IBIFN,IBSORT1,IBSORT2,0)=$$STRIP($$TAXID^IBCEF75(),1,U,IBSTRIP)
44 .. D VALF(IBIFN,IBINS,IBFRMTYP,IBDIV,.IDS,IBSORT1,IBSORT2,COB,IBLIMIT,IBSTRIP,SEG)
45 Q
46 ;
47VALF(IBIFN,INS,FT,DIV,IDS,SORT1,SORT2,COB,IBLIMIT,IBSTRIP,SEG) ; Get VA Lab/Fac Secondary IDs
48 ; Pass in INS - IEN to file 36
49 ; FT - 1 = UB 2 = 1500
50 ; DIV - PTR to 40.8
51 ;
52 N Z,Z0,ID,QUAL,MAIN,IDTBL,CNT,Z
53 S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division
54 S Z=0 F S Z=$O(^IBA(355.92,"B",INS,Z)) Q:'Z D
55 . S Z0=$G(^IBA(355.92,Z,0))
56 . Q:$P(Z0,U,8)'="LF" ; Screen out anything other than Lab or Facility
57 . I +$P(Z0,U,4) Q:$P(Z0,U,4)'=FT ; Form type must match that passed in or be a 0 which allows both
58 . S ID=$$STRIP($P(Z0,U,7),1,,IBSTRIP)
59 . S QUAL=$$STRIP($P(Z0,U,6),1,,IBSTRIP)
60 . Q:QUAL="" ; Needs a qualifier
61 . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
62 . I FT=1,SORT1="O" Q:$$OP3^IBCEF73(FT)'[(U_QUAL_U) ; Institutional
63 . I FT=2,SORT1="O" Q:$$OP7^IBCEF73(FT)'[(U_QUAL_U) ; Professional
64 . I $P(Z0,U,5)=""!($P(Z0,U,5)=0)!($P(Z0,U,5)=MAIN) S IDTBL("DEF",QUAL)=ID ; set up default for main division
65 . I $P(Z0,U,5)=DIV S IDTBL("DIV",QUAL)=ID ; set up default for division
66 S CNT=0
67 S IDS("LAB/FAC",IBIFN,SORT1,SORT2)=$E("PST",COB)
68 I $D(IDTBL("DIV")) D Q
69 . S Z="" F S Z=$O(IDTBL("DIV",Z)) Q:Z="" S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("DIV",Z) Q:CNT=IBLIMIT
70 I $D(IDTBL("DEF")) D Q
71 . S Z="" F S Z=$O(IDTBL("DEF",Z)) Q:Z="" S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("DEF",Z) Q:CNT=IBLIMIT
72 Q
73 ;
74NONVALF(IBIFN,PRV,INS,FT,PT,IDS,SORT1,SORT2,COB,IBLIMIT,IBSTRIP,SEG) ; Get Non VA Lab/Fac Secondary IDs
75 ; Pass in PRV - VPTR - PTR to 355.93 (in format of variabel pointer IEN;IBA(355.93,
76 ; Pass in INS - PTR to 36 of null (not provide by insurance company)
77 ; FT - 1 = UB 2 = 1500
78 ; PT - Patient Type - 1 inpatient 2 outpatient
79 ; IDS array being returned
80 ; SORT1 - "C"urrent or "O"ther
81 ; SORT2 - 1 if current or (1 or 2 if other)
82 N Z,Z0,ID,QUAL,IDTBL,CNT
83 S Z=0 F S Z=$O(^IBA(355.9,"B",PRV,Z)) Q:'Z D
84 . S Z0=$G(^IBA(355.9,Z,0))
85 . I +$P(Z0,U,4) Q:$P(Z0,U,4)'=FT ; Form type must match that passed in or be a 0 which allows both UB and 1500
86 . I +$P(Z0,U,5) Q:$P(Z0,U,5)'=PT ; Patient type must match that passed in or be a 0 which allows both in patient and outpatient
87 . I INS]"",$P(Z0,U,2)]"",INS'=$P(Z0,U,2) Q
88 . S ID=$$STRIP($P(Z0,U,7),1,,IBSTRIP)
89 . Q:ID=""
90 . S QUAL=$$STRIP($P(Z0,U,6),1,,IBSTRIP)
91 . Q:QUAL="" ; Needs a qualifier
92 . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
93 . Q:QUAL=""
94 . I FT=1,SORT1="O" Q:$$OP3^IBCEF73(FT)'[(U_QUAL_U) ; Institutional
95 . I FT=2,SORT1="O" Q:$$OP7^IBCEF73(FT)'[(U_QUAL_U) ; Professional
96 . I $G(SEG)="SUB1" Q:$$SUB1^IBCEF73(FT)'[(U_QUAL_U)
97 . I $P(Z0,U,2)="" S IDTBL("OWN",QUAL)=ID ; set up default of lab or facilities own ids
98 . I $P(Z0,U,2)=INS S IDTBL("INS",QUAL)=ID ; set up default for division
99 ;
100 S CNT=0
101 S IDS("LAB/FAC",IBIFN,SORT1,SORT2)=$E("PST",COB)_U_PRV
102 ; get primary
103 S Z0=$G(^IBA(355.93,+PRV,0))
104 I $P(Z0,U,9)]"",$P(Z0,U,13)]"" S IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=$$STRIP($P($G(^IBE(355.97,$P(Z0,U,13),0)),U,3)_U_$P(Z0,U,9),1,U,IBSTRIP)
105 ; get secondarys in order
106 I $D(IDTBL("INS")) D
107 . N Z S Z="" F S Z=$O(IDTBL("INS",Z)) Q:Z="" S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("INS",Z) Q:CNT=IBLIMIT
108 I $D(IDTBL("OWN")),CNT'=IBLIMIT D
109 . N Z S Z="" F S Z=$O(IDTBL("OWN",Z)) Q:Z="" I '$D(IDTBL("INS",Z)) S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("OWN",Z) Q:CNT=IBLIMIT
110 Q
111 ;
112STRIP(X,SPACE,EXC,IBSTRIP) ;
113 ; Strip punctuation from data in X
114 ; SPACE = flag if 1 strip SPACES
115 ; EXC = list of punct not to strip
116 ;
117 Q:'$G(IBSTRIP) X
118 Q $$NOPUNCT^IBCEF(X,$G(SPACE),$G(EXC))
119 ;
120OTH(IBIFN,IBXSAVE,IBXDATA,COND,SEG) ; Procedure used in piece 2 of some output
121 ; formatter segments for other insurance
122 ; COND = 0/1 value passed in that determines whether or not to call the
123 ; provider ID function
124 ; SEG = name of segment for use in calling ID^IBCEF2 (4 characters)
125 ;
126 N Z
127 D CLEANUP^IBCEF75(.IBXSAVE)
128 I COND D ALLIDS^IBCEF75(IBIFN,.IBXSAVE,1)
129 ;
130 ; Special Check: if Other Insurance #2 has secondary ID's while Other
131 ; Insurance #1 does not, then move up #2 to be #1 here. This is to
132 ; ensure the output formatter IBXDATA array is built properly.
133 ;
134 I $O(IBXSAVE("LAB/FAC",IBIFN,"O",2,0)),'$O(IBXSAVE("LAB/FAC",IBIFN,"O",1,0)) D
135 . K IBXSAVE("LAB/FAC",IBIFN,"O",1)
136 . M IBXSAVE("LAB/FAC",IBIFN,"O",1)=IBXSAVE("LAB/FAC",IBIFN,"O",2)
137 . K IBXSAVE("LAB/FAC",IBIFN,"O",2)
138 . Q
139 ;
140 K IBXDATA
141 S Z=0
142 F S Z=$O(IBXSAVE("LAB/FAC",IBIFN,"O",Z)) Q:'Z D
143 . I '$O(IBXSAVE("LAB/FAC",IBIFN,"O",Z,0)) Q
144 . S IBXDATA(Z)=$P($G(IBXSAVE("LAB/FAC",IBIFN,"O",Z)),U,1)
145 . I Z>1 D ID^IBCEF2(Z,SEG)
146 . Q
147OTHX ;
148 Q
149 ;
Note: See TracBrowser for help on using the repository browser.