source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF71.m@ 1006

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

initial load of WorldVistAEHR
File size: 9.1 KB
Line 
1IBCEF71 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;31-JUL-03
2 ;;2.0;INTEGRATED BILLING;**232,155,288,320,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;---------
6 ;OTHPAYC - from FORMAT code for OP1,OP2 ...
7 ;Input:
8 ;IBXIEN - ien #399
9 ;IBSAVE - "in" array (i.e. IBXSAVE)
10 ;IBDATA - "out" array (i.e. IBXDATA)
11 ;IBFUNC - FUNCTION from #399 (1-refering,2-operating,etc)
12 ;IBVAL - output value
13 ;Output:
14 ; IBDATA with formatted output
15OTHPAYC(IBXIEN,IBSAVE,IBDATA,IBFUNC,IBVAL) ;
16 N IB1,IB2,IBINS,IBFL
17 S IBFL=$S(IBFUNC=3!(IBFUNC=4):1,1:0)
18 F IB1=1,2 D
19 . Q:'$$ISINSUR($G(IBSAVE("PROVINF",IBXIEN,"O",IB1)),IBXIEN) ;don't create anything if no such insurance
20 . I IBFL S IBFUNC=$S($O(IBSAVE("PROVINF",IBXIEN,"O",IB1,3,0)):3,1:4)
21 . S:$O(IBSAVE("PROVINF",IBXIEN,"O",IB1,IBFUNC,0)) IBDATA(IB1)=IBVAL
22 Q
23 ;----
24 ;OTHPAYV - called from FORMAT code for OP1,OP2 ...
25 ;Input:
26 ;IBXIEN - ien #399
27 ;IBSAVE - "in" array (i.e. IBXSAVE)
28 ;IBDATA - "out" array (i.e. IBXDATA)
29 ;IBFUNC - FUNCTION from #399 (1-refering, 2-operating, etc)
30 ;IBSEQN - seq # of ID/QUAL
31 ;IBFLDTYP
32 ; "I" - ID "Q" - ID QUAL
33 ;Output:
34 ; IBDATA with formatted output
35OTHPAYV(IBXIEN,IBSAVE,IBDATA,IBFUNC,IBFLDTYP,IBSEQN) ;
36 N IB1,IB2,IBPIECE,IBINS,IBFL
37 S IBFL=$S(IBFUNC=3!(IBFUNC=4):1,1:0)
38 S IBPIECE=$S(IBFLDTYP="I":4,IBFLDTYP="Q":3,1:3)
39 F IB1=1,2 D
40 . Q:'$$ISINSUR($G(IBSAVE("PROVINF",IBXIEN,"O",IB1)),IBXIEN) ;don't create anything if there is no such insurance
41 . I IBFL S IBFUNC=$S($O(IBSAVE("PROVINF",IBXIEN,"O",IB1,3,0)):3,1:4),IBFL=0
42 . S IBDATA(IB1)=$P($G(IBSAVE("PROVINF",IBXIEN,"O",IB1,IBFUNC,IBSEQN)),"^",IBPIECE)
43 Q
44 ;
45 ;chk for ins
46 ;Input:
47 ; IBINS = "P","S","T"
48 ; IBXIEN - ien file #399
49 ;Output:
50 ; returns 1-exists , 0-doesn't
51ISINSUR(IBINS,IBXIEN) ;
52 N IBINSNOD
53 S IBINSNOD=$S(IBINS="P":"I1",IBINS="S":"I2",IBINS="T":"I3",1:"")
54 I IBINSNOD="" Q 0
55 Q $D(^DGCR(399,IBXIEN,IBINSNOD))
56 ;
57 ;---PRACT----
58 ;Get list of all 355.9 or 355.93 records for prov
59 ;Input:
60 ;IB399INS - ins co for bill to match PRACTIONER from 355.9
61 ;IB399FRM - form type (0=unknwn/both,1=UB,2=1500) to
62 ; match PRACTIONER from 355.9
63 ;IB399CAR - BILL CARE (0=unknwn or both inp/outp,1=inpatient,
64 ; 2=outpatient/3=Rx) to match PROV from 355.9
65 ; OR - DIVISION PTR to file 40.8 for entries in file 355.92
66 ;IBPROV - VARIABLE PTR VA prov
67 ;IBARR - array by reference for result
68 ;IBPROVTP- function (2-operating, 3-RENDERING,etc 0-facility)
69 ;IBINSTP - "C" -current ins , "O"-other
70 ;IBFILE - 355.92 for facility ids or 355.9 (default) for provider ids
71 ;IBINS - 1 if to include ids for the ins co for all provs
72 ;Ouput:
73 ;IBARR - array by ref for result
74 ; prov var ptr^ins ptr^X12 id cd^ID^form typ^care typ or division ptr^st ptr^id rec ptr^id type ptr
75PRACT(IB399INS,IB399FRM,IB399CAR,IBPROV,IBARR,IBPROVTP,IBINSTP,IBFILE,IBINS) ;
76 N IB1,IB2,IBDAT,IBF,IBFX,IB3559,IBINSCO,IBFRMTYP,IBIDTYP,IBID,IBIDT,IBDIV,IBQ,IBS1,IBS2,IBARRX,Z,Z1,Z2,IBCARE
77 I $G(IBFILE)="" S IBFILE=355.9
78 S IBINS=$G(IBINS)
79 S (IBARR,IB3559,IB1)=0
80 F IBF="",1 Q:IBF=1&$S(IBFILE'=355.9:1,1:'IBINS) S IBFX=IBFILE_IBF F IB2=1:1 S IB3559=$O(^IBA(IBFX,"B",$S(IBFILE=355.9&(IBF=""):IBPROV,1:IB399INS),IB3559)) Q:IB3559="" D
81 . S IBINSCO=$P($G(^IBA(IBFX,IB3559,0)),"^",$S(IBFILE=355.9&(IBF=""):2,1:1)) ;ins co. ptr
82 . I IBINSCO'="" I IBINSCO'=IB399INS Q ;exclude if different ins
83 . S:IBINSCO="" IBINSCO="NONE" ;NONE will be included in the array
84 . S IBFRMTYP=+$P($G(^IBA(IBFX,IB3559,0)),"^",4) ;form type (0=both,1=UB,2=1500)
85 . I '(IBFRMTYP=0!(IB399FRM=0)) Q:IBFRMTYP'=IB399FRM ;exclude if not "both" and different
86 . S IBCARE=+$P($G(^IBA(IBFX,IB3559,0)),"^",5) ;0=both(inp and outp),1=inp,2=outp,3=prescr -- OR -- division ptr
87 . I $S(IBFILE=355.92:0,1:IBCARE=3) I IB399CAR'=3 Q ; Id is only for Rx
88 . I $S(IBFILE=355.92:0,1:IBCARE=1!(IBCARE=2)) I IB399CAR=1!(IB399CAR=2) Q:IBCARE'=IB399CAR ;both is OK
89 . I IBFILE=355.92,IBCARE Q:IB399CAR'=IBCARE ; Division doesn't match
90 . S IBIDTYP=+$P($G(^IBA(IBFX,IB3559,0)),"^",6) ;prov ID type
91 . I IBFILE=355.9,IBIDTYP=$$TAXID^IBCEP8(),$S(IBPROV["VA(200":1,1:$P($G(^IBA(355.93,+IBPROV,0)),U,2)=2) Q ; Don't extract tax id # id for indiv prov
92 . S IBIDT=IBIDTYP
93 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
94 . Q:$P($G(^IBE(355.97,+IBIDT,1)),U,9)
95 . Q:IBFILE=355.9&(IBIDTYP="X4") ;exclude CLIA #
96 . S IBID=$P($G(^IBA(IBFX,IB3559,0)),"^",7) ;prov ID value
97 . I $G(IBPROVTP)'="",$G(IBINSTP)'="",IBPROVTP'=0 I '$$CHCKSEC^IBCEF73(IB399FRM,IBPROVTP,IBINSTP,IBIDTYP) Q ; No qualifier chk for fac
98 . I IBID'="" S IBDAT=IBPROV_"^"_IBINSCO_"^"_IBIDTYP_"^"_IBID_"^"_IBFRMTYP_"^"_IBCARE_"^"_"^"_IB3559_U_IBIDT,IBS2=$S(IBFX'=355.91:"",1:"INS DEF^")_IB3559
99 . I IBFILE'=355.92,IBID'="",IB399CAR=3 S IBQ=0 D Q:IBQ
100 .. I $G(IBARRX(IBIDT))!(IBCARE=1) S IBQ=1 Q
101 .. I IBCARE=3&(IB399CAR=3) S IBARRX(IBIDT)=1 Q ; Rx match
102 .. I IBCARE=0!(IBCARE=2) S IBARRX(IBIDT,IBINSCO,IBS2)=IBDAT,IBQ=1 Q
103 . I IBID'="" S IBARR(IBINSCO,IBS2)=IBDAT
104 ;
105 I IB399CAR=3 S Z=0 F S Z=$O(IBARRX(Z)) Q:'Z I '$G(IBARRX(Z)) D
106 . S Z1="" F S Z1=$O(IBARRX(Z,Z1)) Q:Z1="" S Z2="" F S Z2=$O(IBARRX(Z,Z1,Z2)) Q:Z2="" S IBARR(Z1,Z2)=IBARRX(Z,Z1,Z2)
107 ;
108 I IBPROV["VA(200," D ; Get lic #s from file 2 for VA providers
109 . N Z,IBLIC
110 . S IBLIC=+IBPROV,IBLIC=$$GETLIC^IBCEP5D(.IBLIC)
111 . S IBIDTYP=$P($G(^IBE(355.97,+$$STLIC^IBCEP8(),0)),U,3)
112 . S Z=0 F S Z=$O(IBLIC(Z)) Q:'Z S:$$CHCKSEC^IBCEF73(IB399FRM,IBPROVTP,IBINSTP,IBIDTYP) IBARR("NONE","LIC"_Z_"^"_IBPROV)=IBPROV_U_"NONE"_U_IBIDTYP_U_IBLIC(Z)_U_"0"_U_"0"_U_Z_U_U_+$$STLIC^IBCEP8()
113 I IBPROV["IBA(355.93" D
114 . Q:$P($G(^IBA(355.93,+IBPROV,0)),U,12)=""
115 . S IBIDTYP=$P($G(^IBE(355.97,+$$STLIC^IBCEP8(),0)),U,3)
116 . I $$CHCKSEC^IBCEF73(IB399FRM,IBPROVTP,IBINSTP,IBIDTYP) D
117 . . S IBARR("NONE","LIC"_$P($G(^DIC(5,+$P(^IBA(355.93,+IBPROV,0),U,7),0)),U,2)_"^"_IBPROV)=IBPROV_U_"NONE"_U_IBIDTYP_U_$P(^IBA(355.93,+IBPROV,0),U,12)_U_"0"_U_"0"_U_$P(^IBA(355.93,+IBPROV,0),U,7)_U_U_+IBPROV
118 Q
119 ;
120ALLPRFAC(IBXIEN,IBXSAVE) ; Return all non-VA/outside facility prov ids
121 ; and all VA alternate prov ids
122 ; IBXIEN = ien file 399
123 ; IBXSAVE = subscripted array returned
124 N IBPROV,IBFRMTYP,IBCARE,IBRETARR,IBRET1,IBCOBN,Z,Z0,Z1,ZZ
125 K IBXSAVE("PROVINF_FAC",IBXIEN) ; Always rebuild this
126 S IBCOBN=+$$COBN^IBCEF(IBXIEN)
127 S IBFRMTYP=$$FT^IBCEF(IBXIEN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
128 S IBPROV=$P($G(^DGCR(399,IBXIEN,"U2")),U,10)
129 ; IB patch 320 - Build IBPROV variable better when a non-VA facility exists
130 I IBPROV S IBPROV=IBPROV_";IBA(355.93,"
131 I 'IBPROV S IBCARE=$P($G(^DGCR(399,IBXIEN,0)),U,22)
132 I IBPROV D
133 . S IBCARE=$S($$ISRX^IBCEF1(IBXIEN):3,1:0) ;if Rx refill bill
134 . S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBXIEN,1) S:'IBCARE IBCARE=2 ;1-inp, 2-out
135 F Z=1:1:3 K IBRETARR I $G(^DGCR(399,IBXIEN,"I"_Z)) D
136 . D PRACT(+^DGCR(399,IBXIEN,"I"_Z),IBFRMTYP,IBCARE,IBPROV,.IBRETARR,0,$S(Z=IBCOBN:"C",1:"O"),$S('IBPROV:355.92,1:355.9))
137 . K IBRET1
138 . S Z0="" F S Z0=$O(IBRETARR(Z0)) Q:Z0="" S Z1="" F S Z1=$O(IBRETARR(Z0,Z1)) Q:Z1="" D
139 .. ; Sort by div/id type
140 .. S IBRET1($S(IBPROV:0,1:+$P(IBRETARR(Z0,Z1),U,6)),+$P(IBRETARR(Z0,Z1),U,9))=IBRETARR(Z0,Z1)
141 .. Q
142 . ;
143 . S Z0=$O(IBRET1(""),-1) Q:Z0="" D
144 .. ; IB patch 320 - loop thru all ID's
145 .. S Z1="" F S Z1=$O(IBRET1(Z0,Z1)) Q:Z1="" D
146 ... I Z=IBCOBN S IBXSAVE("PROVINF_FAC",IBXIEN,"C",1,0,$O(IBXSAVE("PROVINF_FAC",IBXIEN,"C",1,0," "),-1)+1)=IBRET1(Z0,Z1) Q
147 ... S ZZ=$S(Z=1:1,Z=2:(IBCOBN=3)+1,1:2)
148 ... S IBXSAVE("PROVINF_FAC",IBXIEN,"O",ZZ,0,$O(IBXSAVE("PROVINF_FAC",IBXIEN,"O",ZZ,0," "),-1)+1)=IBRET1(Z0,Z1),IBXSAVE("PROVINF_FAC",IBXIEN,"O",ZZ)=$E("PST",Z)
149 ... Q
150 .. Q
151 . Q
152 ;
153 S IBXSAVE("PROVINF_FAC",IBXIEN)=IBXIEN,IBXSAVE("PROVINF_FAC",IBXIEN,"C",1)=$E("PST",IBCOBN)
154 Q
155 ;
156OTHID(IBXSAVE,IBXDATA,IBXIEN,PRIDSEQ,PRTYP,IBQ,IBFAC) ; From data in IBXSAVE,
157 ; determine id or qualifier to output in the 837 records OP*
158 ; Returns IBXDATA array IBXDATA(n)=data
159 ; IBXIEN = ien of the bill-file 399
160 ; PRIDSEQ = sequence of the payer id needed
161 ; PRTYP = provider type to check for data
162 ; IBQ = 1 if qualifier needed, 0/null if id needed
163 ; IBFAC = 1 if facility id, 0 for individual provider id
164 ;
165 N Z,Z0,Z1
166 S Z0="PROVINF"_$S('$G(IBFAC):"",1:"_FAC"),Z1=$S($G(IBQ):3,1:4)
167 S Z=0 F S Z=$O(IBXSAVE("OSQ",Z)) Q:'Z D
168 . I $P($G(IBXSAVE(Z0,IBXIEN,"O",Z,+$G(PRTYP),+$G(PRIDSEQ))),U,4)'="" S IBXDATA(IBXSAVE("OSQ",Z))=$P(IBXSAVE(Z0,IBXIEN,"O",Z,+$G(PRTYP),+$G(PRIDSEQ)),U,Z1)
169 Q
170 ;
171SETSEQ(IBXIEN,IBXSAVE,IBXDATA,PRTYP,IBFAC,IBOP) ; Sets up IBXSAVE("OSQ")
172 ; array for other id seq in 837 records OP*
173 ; Returns IBXDATA(n)=cob seq indicator for ids
174 ; IBXIEN = ien of bill-399
175 ; PRTYP = the provider type to check for data for indiv provider
176 ; IBFAC = 1 if facility id, 0 for individual provider id
177 ; IBOP = segement # in OP being output
178 N C,Z,Z0,Z1,OK
179 S C=0,Z0="PROVINF"_$S('$G(IBFAC):"",1:"_FAC")
180 S:$G(IBFAC) PRTYP=0
181 S Z=0 F S Z=$O(IBXSAVE(Z0,IBXIEN,"O",Z)) Q:'Z S OK=0 D
182 . N Z1 F Z1=1:1 Q:'$D(IBXSAVE(Z0,IBXIEN,"O",Z,+$G(PRTYP),Z1)) I $P(IBXSAVE(Z0,IBXIEN,"O",Z,+$G(PRTYP),Z1),U,4)'="""" S OK=1 Q
183 . I OK S C=C+1,IBXSAVE("OSQ",Z)=C
184 S Z=0 F S Z=$O(IBXSAVE("OSQ",Z)) Q:'Z S IBXDATA(IBXSAVE("OSQ",Z))=$G(IBXSAVE(Z0,IBXIEN,"O",Z)) D:IBXSAVE("OSQ",Z)>1 ID^IBCEF2(IBXSAVE("OSQ",Z),"OP"_$G(IBOP)_" ")
185 Q
186 ;
187PSPRV(IBIFN) ;
188 Q $$PSPRV^IBCEF7(IBIFN) ; Moved
189 ;
Note: See TracBrowser for help on using the repository browser.