| 1 | IBCRU6 ;ALB/ARH - RATES: UTILITIES (SPECIAL GROUPS); 10-OCT-1998
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**106,138**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | CSSG(CS,BR,TYPE,ARR) ; search for special group(s) of TYPE this CS belongs, returns IFN of first group found TYPE
|
|---|
| 6 | ; outputs ARR(order)=group ifn ^ groups 0 node, if passed by reference
|
|---|
| 7 | N IBBR,IBSGFN,IBSG0,IBSGFN1,IBSG10,IBORDER,IBFND,ARR1 K ARR,ARR1 S IBFND=""
|
|---|
| 8 | S IBBR=$G(BR) I 'IBBR S IBBR=+$P($G(^IBE(363.1,+$G(CS),0)),U,2) I 'IBBR G CSSGQ
|
|---|
| 9 | ;
|
|---|
| 10 | I +IBBR S IBSGFN=0 F S IBSGFN=$O(^IBE(363.32,IBSGFN)) Q:'IBSGFN D
|
|---|
| 11 | . S IBSG0=$G(^IBE(363.32,IBSGFN,0)) I +$G(TYPE),+$P(IBSG0,U,2)'=TYPE Q
|
|---|
| 12 | . S IBSGFN1=0 F S IBSGFN1=$O(^IBE(363.32,IBSGFN,11,"B",IBBR,IBSGFN1)) Q:'IBSGFN1 D
|
|---|
| 13 | .. S IBSG10=$G(^IBE(363.32,IBSGFN,11,IBSGFN1,0)) I +$P(IBSG10,U,2),+$G(CS)'=+$P(IBSG10,U,2) Q
|
|---|
| 14 | .. S IBORDER=+$P(IBSG10,U,3) I +IBORDER,+$G(ARR(IBORDER)) S IBORDER=$O(ARR((IBORDER+1)),-1)+.01
|
|---|
| 15 | .. I 'IBORDER S IBORDER=1000 I +$G(ARR(IBORDER)) S IBORDER=$O(ARR(99999),-1)+1
|
|---|
| 16 | .. I '$G(ARR1(+IBSGFN)) S ARR(IBORDER)=IBSGFN_U_IBSG0,ARR1(+IBSGFN)=1
|
|---|
| 17 | S IBORDER=$O(ARR(0)) I +IBORDER S IBFND=+ARR(IBORDER)
|
|---|
| 18 | CSSGQ Q IBFND
|
|---|
| 19 | ;
|
|---|
| 20 | RVLNK(ITM,BR,CS,ARR) ; return the ifn^revenue code for a particular ITEM as defined by the Billing Rates Revenue Code links
|
|---|
| 21 | N IBBR,IBORDER,IBSGFN,IBRV,IBRVD,IBALL,SGARR S IBALL=+$G(ARR),IBRVD="" I '$G(ITM) G RVLNKQ
|
|---|
| 22 | S IBBR=$G(BR) I 'IBBR S IBBR=$P($G(^IBE(363.1,+$G(CS),0)),U,2) I 'IBBR G RVLNKQ
|
|---|
| 23 | I $P($G(^IBE(363.3,+IBBR,0)),U,4)'=2 G RVLNKQ
|
|---|
| 24 | ;
|
|---|
| 25 | I +$$CSSG(+$G(CS),IBBR,1,.SGARR) S IBORDER=0 F S IBORDER=$O(SGARR(IBORDER)) Q:'IBORDER D I +IBRVD,'IBALL Q
|
|---|
| 26 | . S IBSGFN=+SGARR(IBORDER) I +IBSGFN S IBRV=$$GRVLNK(ITM,IBSGFN,.ARR) I +IBRV,'IBRVD S IBRVD=IBRV
|
|---|
| 27 | RVLNKQ Q IBRVD
|
|---|
| 28 | ;
|
|---|
| 29 | GRVLNK(ITM,GRP,ARR) ; return the ifn^revenue code for a particular ITEM as defined in a single group
|
|---|
| 30 | ; Output: if ARR=1 on entry and passed by reference, then the array ARR will be defined on output
|
|---|
| 31 | ; ARR(IFN of Rv Cd link in 363.33) = IFN of Rv Cd link in 363.33 ^ revenue code
|
|---|
| 32 | ; (since ranges and specific individual ITEMs can be defined, one ITEM may be set up for more than one revenue
|
|---|
| 33 | ; code, the one used on the bills will be the return value, any others will be in the array)
|
|---|
| 34 | N IBALL,IBRVD,IBXRF,IBRV,IBEND,IBX,IBY S IBALL=+$G(ARR),IBRVD="",GRP=+$G(GRP),ITM=+$G(ITM) I 'ITM!'GRP G GRVLNKQ
|
|---|
| 35 | ;
|
|---|
| 36 | S IBXRF="AGP",IBX=$O(^IBE(363.33,IBXRF,GRP,+ITM,0))
|
|---|
| 37 | I +IBX S IBRV=+IBX_U_+$G(^IBE(363.33,+IBX,0)),ARR(+IBX)=IBRV,IBRVD=IBRV I 'IBALL G GRVLNKQ
|
|---|
| 38 | ;
|
|---|
| 39 | S IBXRF="AGPE"
|
|---|
| 40 | S IBEND=ITM-.1 F S IBEND=$O(^IBE(363.33,IBXRF,GRP,+IBEND)) Q:'IBEND D I +IBRVD,'IBALL Q
|
|---|
| 41 | . S IBX=0 F S IBX=$O(^IBE(363.33,IBXRF,GRP,+IBEND,IBX)) Q:'IBX D I +IBRVD,'IBALL Q
|
|---|
| 42 | .. S IBY=$G(^IBE(363.33,IBX,0))
|
|---|
| 43 | .. I +$P(IBY,U,3),$P(IBY,U,3)'>ITM S IBRV=+IBX_U_+IBY,ARR(+IBX)=IBRV I 'IBRVD S IBRVD=IBRV
|
|---|
| 44 | GRVLNKQ Q IBRVD
|
|---|
| 45 | ;
|
|---|
| 46 | PRVTYP(PRV,IBDT) ; find the provider type/discount group of a provider on a given date
|
|---|
| 47 | ; returns prv type ifn (363.34) ^ provider person class ifn ^ provider type ^ special group ^ percent
|
|---|
| 48 | N IBPC,IBPDIFN,IBPD0,IBPT S IBPT="",IBDT=$G(IBDT) I 'IBDT S IBDT=DT
|
|---|
| 49 | I +$G(PRV) S IBPC=$$GET^XUA4A72(PRV,IBDT)
|
|---|
| 50 | I +$G(IBPC)>0 S IBPDIFN=$O(^IBE(363.34,"D",+IBPC,0)) I +IBPDIFN D
|
|---|
| 51 | . S IBPD0=$G(^IBE(363.34,+IBPDIFN,0))
|
|---|
| 52 | . S IBPT=+IBPDIFN_U_+IBPC_U_IBPD0
|
|---|
| 53 | Q IBPT
|
|---|
