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 Oct 16, 2024@18:20:40 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
