- IBCRU6 ;ALB/ARH - RATES: UTILITIES (SPECIAL GROUPS); 10-OCT-1998
- ;;2.0;INTEGRATED BILLING;**106,138,399**;21-MAR-94;Build 8
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- CSSG(CS,BR,TYPE,ARR) ; search for special group(s) of TYPE this CS belongs, returns IFN of first group found TYPE
- ; outputs ARR(order)=group ifn ^ groups 0 node, if passed by reference
- N IBBR,IBSGFN,IBSG0,IBSGFN1,IBSG10,IBORDER,IBFND,ARR1 K ARR,ARR1 S IBFND=""
- S IBBR=$G(BR) I 'IBBR S IBBR=+$P($G(^IBE(363.1,+$G(CS),0)),U,2) I 'IBBR G CSSGQ
- ;
- I +IBBR S IBSGFN=0 F S IBSGFN=$O(^IBE(363.32,IBSGFN)) Q:'IBSGFN D
- . S IBSG0=$G(^IBE(363.32,IBSGFN,0)) I +$G(TYPE),+$P(IBSG0,U,2)'=TYPE Q
- . S IBSGFN1=0 F S IBSGFN1=$O(^IBE(363.32,IBSGFN,11,"B",IBBR,IBSGFN1)) Q:'IBSGFN1 D
- .. S IBSG10=$G(^IBE(363.32,IBSGFN,11,IBSGFN1,0)) I +$P(IBSG10,U,2),+$G(CS)'=+$P(IBSG10,U,2) Q
- .. S IBORDER=+$P(IBSG10,U,3) I +IBORDER,+$G(ARR(IBORDER)) S IBORDER=$O(ARR((IBORDER+1)),-1)+.01
- .. I 'IBORDER S IBORDER=1000 I +$G(ARR(IBORDER)) S IBORDER=$O(ARR(99999),-1)+1
- .. I '$G(ARR1(+IBSGFN)) S ARR(IBORDER)=IBSGFN_U_IBSG0,ARR1(+IBSGFN)=1
- S IBORDER=$O(ARR(0)) I +IBORDER S IBFND=+ARR(IBORDER)
- CSSGQ Q IBFND
- ;
- RVLNK(ITM,BR,CS,ARR) ; return the ifn^revenue code for a particular ITEM as defined by the Billing Rates Revenue Code links
- N IBBR,IBORDER,IBSGFN,IBRV,IBRVD,IBALL,SGARR S IBALL=+$G(ARR),IBRVD="" I '$G(ITM) G RVLNKQ
- S IBBR=$G(BR) I 'IBBR S IBBR=$P($G(^IBE(363.1,+$G(CS),0)),U,2) I 'IBBR G RVLNKQ
- I $P($G(^IBE(363.3,+IBBR,0)),U,4)'=2 G RVLNKQ
- ;
- I +$$CSSG(+$G(CS),IBBR,1,.SGARR) S IBORDER=0 F S IBORDER=$O(SGARR(IBORDER)) Q:'IBORDER D I +IBRVD,'IBALL Q
- . S IBSGFN=+SGARR(IBORDER) I +IBSGFN S IBRV=$$GRVLNK(ITM,IBSGFN,.ARR) I +IBRV,'IBRVD S IBRVD=IBRV
- RVLNKQ Q IBRVD
- ;
- GRVLNK(ITM,GRP,ARR) ; return the ifn^revenue code for a particular ITEM as defined in a single group
- ; Output: if ARR=1 on entry and passed by reference, then the array ARR will be defined on output
- ; ARR(IFN of Rv Cd link in 363.33) = IFN of Rv Cd link in 363.33 ^ revenue code
- ; (since ranges and specific individual ITEMs can be defined, one ITEM may be set up for more than one revenue
- ; code, the one used on the bills will be the return value, any others will be in the array)
- ;
- N IBALL,IBRVD,IBXRF,IBRV,IBEND,IBX,IBY,IBC,IBC1,IBC2
- S IBALL=+$G(ARR),IBRVD="",GRP=+$G(GRP),ITM=+$G(ITM) I 'ITM!'GRP G GRVLNKQ
- ;
- S IBXRF="AGP",IBX=$O(^IBE(363.33,IBXRF,GRP,+ITM,0))
- I +IBX S IBRV=+IBX_U_+$G(^IBE(363.33,+IBX,0)),ARR(+IBX)=IBRV,IBRVD=IBRV I 'IBALL G GRVLNKQ
- ;
- I ITM<100000 S IBXRF="AGPE" D G GRVLNKQ
- . S IBEND=ITM-.1 F S IBEND=$O(^IBE(363.33,IBXRF,GRP,+IBEND)) Q:'IBEND D I +IBRVD,'IBALL Q
- .. S IBX=0 F S IBX=$O(^IBE(363.33,IBXRF,GRP,+IBEND,IBX)) Q:'IBX D I +IBRVD,'IBALL Q
- ... S IBY=$G(^IBE(363.33,IBX,0))
- ... I +$P(IBY,U,3),$P(IBY,U,3)'>ITM S IBRV=+IBX_U_+IBY,ARR(+IBX)=IBRV I 'IBRVD S IBRVD=IBRV
- ;
- I ITM>99999 S IBXRF="AGPE",IBC=$$CODEC^ICPTCOD(ITM) D G GRVLNKQ
- . S IBEND=99999 F S IBEND=$O(^IBE(363.33,IBXRF,GRP,+IBEND)) Q:'IBEND D I +IBRVD,'IBALL Q
- .. S IBX=0 F S IBX=$O(^IBE(363.33,IBXRF,GRP,+IBEND,IBX)) Q:'IBX D I +IBRVD,'IBALL Q
- ... S IBY=$G(^IBE(363.33,IBX,0))
- ... S IBC1=$$CODEC^ICPTCOD(+$P(IBY,U,3)),IBC2=IBC1 I +$P(IBY,U,4) S IBC2=$$CODEC^ICPTCOD(+$P(IBY,U,4))
- ... I IBC]IBC1,IBC']IBC2 S IBRV=+IBX_U_+IBY,ARR(+IBX)=IBRV I 'IBRVD S IBRVD=IBRV
- ;
- GRVLNKQ Q IBRVD
- ;
- PRVTYP(PRV,IBDT) ; find the provider type/discount group of a provider on a given date
- ; returns prv type ifn (363.34) ^ provider person class ifn ^ provider type ^ special group ^ percent
- N IBPC,IBPDIFN,IBPD0,IBPT S IBPT="",IBDT=$G(IBDT) I 'IBDT S IBDT=DT
- I +$G(PRV) S IBPC=$$GET^XUA4A72(PRV,IBDT)
- I +$G(IBPC)>0 S IBPDIFN=$O(^IBE(363.34,"D",+IBPC,0)) I +IBPDIFN D
- . S IBPD0=$G(^IBE(363.34,+IBPDIFN,0))
- . S IBPT=+IBPDIFN_U_+IBPC_U_IBPD0
- Q IBPT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRU6 3900 printed Feb 18, 2025@23:46:24 Page 2
- IBCRU6 ;ALB/ARH - RATES: UTILITIES (SPECIAL GROUPS); 10-OCT-1998
- +1 ;;2.0;INTEGRATED BILLING;**106,138,399**;21-MAR-94;Build 8
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- CSSG(CS,BR,TYPE,ARR) ; search for special group(s) of TYPE this CS belongs, returns IFN of first group found TYPE
- +1 ; outputs ARR(order)=group ifn ^ groups 0 node, if passed by reference
- +2 NEW IBBR,IBSGFN,IBSG0,IBSGFN1,IBSG10,IBORDER,IBFND,ARR1
- KILL ARR,ARR1
- SET IBFND=""
- +3 SET IBBR=$GET(BR)
- IF 'IBBR
- SET IBBR=+$PIECE($GET(^IBE(363.1,+$GET(CS),0)),U,2)
- IF 'IBBR
- GOTO CSSGQ
- +4 ;
- +5 IF +IBBR
- SET IBSGFN=0
- FOR
- SET IBSGFN=$ORDER(^IBE(363.32,IBSGFN))
- if 'IBSGFN
- QUIT
- Begin DoDot:1
- +6 SET IBSG0=$GET(^IBE(363.32,IBSGFN,0))
- IF +$GET(TYPE)
- IF +$PIECE(IBSG0,U,2)'=TYPE
- QUIT
- +7 SET IBSGFN1=0
- FOR
- SET IBSGFN1=$ORDER(^IBE(363.32,IBSGFN,11,"B",IBBR,IBSGFN1))
- if 'IBSGFN1
- QUIT
- Begin DoDot:2
- +8 SET IBSG10=$GET(^IBE(363.32,IBSGFN,11,IBSGFN1,0))
- IF +$PIECE(IBSG10,U,2)
- IF +$GET(CS)'=+$PIECE(IBSG10,U,2)
- QUIT
- +9 SET IBORDER=+$PIECE(IBSG10,U,3)
- IF +IBORDER
- IF +$GET(ARR(IBORDER))
- SET IBORDER=$ORDER(ARR((IBORDER+1)),-1)+.01
- +10 IF 'IBORDER
- SET IBORDER=1000
- IF +$GET(ARR(IBORDER))
- SET IBORDER=$ORDER(ARR(99999),-1)+1
- +11 IF '$GET(ARR1(+IBSGFN))
- SET ARR(IBORDER)=IBSGFN_U_IBSG0
- SET ARR1(+IBSGFN)=1
- End DoDot:2
- End DoDot:1
- +12 SET IBORDER=$ORDER(ARR(0))
- IF +IBORDER
- SET IBFND=+ARR(IBORDER)
- CSSGQ QUIT IBFND
- +1 ;
- RVLNK(ITM,BR,CS,ARR) ; return the ifn^revenue code for a particular ITEM as defined by the Billing Rates Revenue Code links
- +1 NEW IBBR,IBORDER,IBSGFN,IBRV,IBRVD,IBALL,SGARR
- SET IBALL=+$GET(ARR)
- SET IBRVD=""
- IF '$GET(ITM)
- GOTO RVLNKQ
- +2 SET IBBR=$GET(BR)
- IF 'IBBR
- SET IBBR=$PIECE($GET(^IBE(363.1,+$GET(CS),0)),U,2)
- IF 'IBBR
- GOTO RVLNKQ
- +3 IF $PIECE($GET(^IBE(363.3,+IBBR,0)),U,4)'=2
- GOTO RVLNKQ
- +4 ;
- +5 IF +$$CSSG(+$GET(CS),IBBR,1,.SGARR)
- SET IBORDER=0
- FOR
- SET IBORDER=$ORDER(SGARR(IBORDER))
- if 'IBORDER
- QUIT
- Begin DoDot:1
- +6 SET IBSGFN=+SGARR(IBORDER)
- IF +IBSGFN
- SET IBRV=$$GRVLNK(ITM,IBSGFN,.ARR)
- IF +IBRV
- IF 'IBRVD
- SET IBRVD=IBRV
- End DoDot:1
- IF +IBRVD
- IF 'IBALL
- QUIT
- RVLNKQ QUIT IBRVD
- +1 ;
- GRVLNK(ITM,GRP,ARR) ; return the ifn^revenue code for a particular ITEM as defined in a single group
- +1 ; Output: if ARR=1 on entry and passed by reference, then the array ARR will be defined on output
- +2 ; ARR(IFN of Rv Cd link in 363.33) = IFN of Rv Cd link in 363.33 ^ revenue code
- +3 ; (since ranges and specific individual ITEMs can be defined, one ITEM may be set up for more than one revenue
- +4 ; code, the one used on the bills will be the return value, any others will be in the array)
- +5 ;
- +6 NEW IBALL,IBRVD,IBXRF,IBRV,IBEND,IBX,IBY,IBC,IBC1,IBC2
- +7 SET IBALL=+$GET(ARR)
- SET IBRVD=""
- SET GRP=+$GET(GRP)
- SET ITM=+$GET(ITM)
- IF 'ITM!'GRP
- GOTO GRVLNKQ
- +8 ;
- +9 SET IBXRF="AGP"
- SET IBX=$ORDER(^IBE(363.33,IBXRF,GRP,+ITM,0))
- +10 IF +IBX
- SET IBRV=+IBX_U_+$GET(^IBE(363.33,+IBX,0))
- SET ARR(+IBX)=IBRV
- SET IBRVD=IBRV
- IF 'IBALL
- GOTO GRVLNKQ
- +11 ;
- +12 IF ITM<100000
- SET IBXRF="AGPE"
- Begin DoDot:1
- +13 SET IBEND=ITM-.1
- FOR
- SET IBEND=$ORDER(^IBE(363.33,IBXRF,GRP,+IBEND))
- if 'IBEND
- QUIT
- Begin DoDot:2
- +14 SET IBX=0
- FOR
- SET IBX=$ORDER(^IBE(363.33,IBXRF,GRP,+IBEND,IBX))
- if 'IBX
- QUIT
- Begin DoDot:3
- +15 SET IBY=$GET(^IBE(363.33,IBX,0))
- +16 IF +$PIECE(IBY,U,3)
- IF $PIECE(IBY,U,3)'>ITM
- SET IBRV=+IBX_U_+IBY
- SET ARR(+IBX)=IBRV
- IF 'IBRVD
- SET IBRVD=IBRV
- End DoDot:3
- IF +IBRVD
- IF 'IBALL
- QUIT
- End DoDot:2
- IF +IBRVD
- IF 'IBALL
- QUIT
- End DoDot:1
- GOTO GRVLNKQ
- +17 ;
- +18 IF ITM>99999
- SET IBXRF="AGPE"
- SET IBC=$$CODEC^ICPTCOD(ITM)
- Begin DoDot:1
- +19 SET IBEND=99999
- FOR
- SET IBEND=$ORDER(^IBE(363.33,IBXRF,GRP,+IBEND))
- if 'IBEND
- QUIT
- Begin DoDot:2
- +20 SET IBX=0
- FOR
- SET IBX=$ORDER(^IBE(363.33,IBXRF,GRP,+IBEND,IBX))
- if 'IBX
- QUIT
- Begin DoDot:3
- +21 SET IBY=$GET(^IBE(363.33,IBX,0))
- +22 SET IBC1=$$CODEC^ICPTCOD(+$PIECE(IBY,U,3))
- SET IBC2=IBC1
- IF +$PIECE(IBY,U,4)
- SET IBC2=$$CODEC^ICPTCOD(+$PIECE(IBY,U,4))
- +23 IF IBC]IBC1
- IF IBC']IBC2
- SET IBRV=+IBX_U_+IBY
- SET ARR(+IBX)=IBRV
- IF 'IBRVD
- SET IBRVD=IBRV
- End DoDot:3
- IF +IBRVD
- IF 'IBALL
- QUIT
- End DoDot:2
- IF +IBRVD
- IF 'IBALL
- QUIT
- End DoDot:1
- GOTO GRVLNKQ
- +24 ;
- GRVLNKQ QUIT IBRVD
- +1 ;
- PRVTYP(PRV,IBDT) ; find the provider type/discount group of a provider on a given date
- +1 ; returns prv type ifn (363.34) ^ provider person class ifn ^ provider type ^ special group ^ percent
- +2 NEW IBPC,IBPDIFN,IBPD0,IBPT
- SET IBPT=""
- SET IBDT=$GET(IBDT)
- IF 'IBDT
- SET IBDT=DT
- +3 IF +$GET(PRV)
- SET IBPC=$$GET^XUA4A72(PRV,IBDT)
- +4 IF +$GET(IBPC)>0
- SET IBPDIFN=$ORDER(^IBE(363.34,"D",+IBPC,0))
- IF +IBPDIFN
- Begin DoDot:1
- +5 SET IBPD0=$GET(^IBE(363.34,+IBPDIFN,0))
- +6 SET IBPT=+IBPDIFN_U_+IBPC_U_IBPD0
- End DoDot:1
- +7 QUIT IBPT
