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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.2 KB
Line 
1IBCRU6 ;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 ;
5CSSG(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)
18CSSGQ Q IBFND
19 ;
20RVLNK(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
27RVLNKQ Q IBRVD
28 ;
29GRVLNK(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
44GRVLNKQ Q IBRVD
45 ;
46PRVTYP(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
Note: See TracBrowser for help on using the repository browser.