IBYPSA ;ALB/ARH - IB*2.0*245 POST INIT: REASONABLE CHARGES V2.0 ; 10-OCT-2003
;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
Q
;
POST ;
N IBA
S IBA(1)="",IBA(2)=" Reasonable Charges v2.0 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
D RSINDT ; add Rate Schedule Inactive dates (363, .06)
;
D UPDBR ; update Billing Rate Names for v2.0 (363.3)
;
D ADDRB^IBYPSA1 ; add Billable Service (399.1, .2)
D ADDBS^IBYPSA1 ; add Bedsections (399.1,.12)
D ADDBI^IBYPSA1 ; add Billable Items (363.21)
D ADDRS^IBYPSA1 ; add Rate Schedule (363)
D ADDBR^IBYPSA1 ; add Billing Rates (363.3)
;
D SGBR ; add Billing Rates to Special Groups (363.32,11,.01)
D RVACT ; activate 3 Revenue Codes (399.2,2)
;
D CHGINA^IBYPSA2("") ; inactivate all RC charges in #363.2
;
S IBA(1)="",IBA(2)=" Reasonable Charges v2.0 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
Q
;
;
RSINDT ; add an inactive date to rate schedules if this is the first time the load is completed (363, .06)
; Reimbursable Ins, No Fault, and Workers Comp only
; if test account use 9/30/98, if production account use 8/31/99
N IBA,IBRSFN,IBRS0,IBRSN,IBCNT,IBSTDT,DD,DO,DIC,DIE,DA,DR,X,Y S IBSTDT="",IBCNT=0
;
I $O(^IBE(363.3,"B","RC PHYSICIAN MN",0)) G RSINQ
;
S IBSTDT=$$VERSEDT^IBCRHBRV(1.4) ;I '$$PROD^IBCORC S IBSTDT=2980930
;
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D
. S IBRS0=$G(^IBE(363,IBRSFN,0)),IBRSN=$E(IBRS0,1,3)
. I IBRSN'="RI-",IBRSN'="NF-",IBRSN'="WC-" Q
. I $P(IBRS0,U,5)'<IBSTDT Q
. I $P(IBRS0,U,6)'="" Q
. ;
. S IBCNT=IBCNT+1,DR=".06////"_IBSTDT,DIE="^IBE(363,",DA=+IBRSFN D ^DIE K DIE,DA,DR,X,Y
;
RSINQ S IBA(1)=" >> "_IBCNT_" Rate Schedules inactivated on "_$E(IBSTDT,4,5)_"/"_$E(IBSTDT,6,7)_"/"_$E(IBSTDT,2,3)_" (363)..."
D MES^XPDUTL(.IBA)
Q
;
UPDBR ; Update Billing Rate Names
N IBA,IBDA,IBCNT,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
;
S DA=$O(^IBE(363.3,"B","RC OUTPATIENT FACILITY","")) I +DA D
. S DR=".01///RC FACILITY PR;.02///RC F/PR" S DIE="^IBE(363.3," D ^DIE K DIE,DA,DR,X,Y
. D MSG(" RC OUTPATIENT FACILITY to RC FACILITY PR") S IBCNT=IBCNT+1
;
S DA=$O(^IBE(363.3,"B","RC PHYSICIAN","")) I +DA D
. S DR=".01///RC PHYSICIAN PR;.02///RC P/PR" S DIE="^IBE(363.3," D ^DIE K DIE,DA,DR,X,Y
. D MSG(" RC PHYSICIAN to RC PHYSICIAN PR") S IBCNT=IBCNT+1
;
S IBA(1)=" >> "_IBCNT_" Billing Rate Names Updated (363.3)..."
D MES^XPDUTL(.IBA)
Q
;
SGBR ; add new Billing Rates to the Special Groups (363.32,11,.01)
N IBA,IBSET,IBSG,IBSGFN,IBBR,IBBRFN,IBCNT,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBBRNM S IBCNT=0
;
F IBSET="STANDARD RVCD LINKS^RC FACILITY","STANDARD RVCD LINKS^RC PHYSICIAN","RC PROVIDER DISCOUNTS^RC PHYSICIAN" D
. S IBSG=$P(IBSET,U,1) Q:IBSG="" S IBSGFN=$O(^IBE(363.32,"B",IBSG,0)) Q:'IBSGFN
. S IBBR=$P(IBSET,U,2) Q:IBBR=""
. ;
. S IBBRNM=IBBR F S IBBRNM=$O(^IBE(363.3,"B",IBBRNM)) Q:IBBRNM'[IBBR D
.. ;
.. S IBBRFN=$O(^IBE(363.3,"B",IBBRNM,0)) Q:'IBBRFN
.. I +$P($G(^IBE(363.3,+IBBRFN,0)),U,4)'=2 Q ; cpt charges only
.. ;
.. I $O(^IBE(363.32,+IBSGFN,11,"B",+IBBRFN,0)) Q
.. ;
.. S DLAYGO=363.32,DA(1)=+IBSGFN,DIC="^IBE(363.32,"_DA(1)_",11,",DIC(0)="L",X=IBBRNM,DIC("P")="363.3211PA" D ^DIC K DIC,DIE S IBCNT=IBCNT+1
;
SGBRQ S IBA(1)=" >> "_IBCNT_" Billing Rates added to Special Groups (363.32)..."
D MES^XPDUTL(.IBA)
Q
;
RVACT ; activate (3) Revenue Codes exported in as defaults for new Charge Sets (399.2,2)
N IBA,IBLN,IBI,IBRVFN,IBACT,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBACT=""
;
S IBLN=$P($T(RVF+1),";;",2)
;
F IBI=1:1 S IBRVFN=$P(IBLN,",",IBI) Q:'IBRVFN D
. ;
. I +$P($G(^DGCR(399.2,IBRVFN,0)),U,3) Q
. ;
. S IBACT=IBACT_IBRVFN_","
. S IBCNT=IBCNT+1,DR="2////1",DIE="^DGCR(399.2,",DA=+IBRVFN D ^DIE K DIE,DA,DR,X,Y
;
I IBCNT>0 S IBJ=0 F IBI=1:15 S IBJ=IBJ+15 S IBLN=$P(IBACT,",",IBI,IBJ) Q:IBLN="" D MSG(" "_IBLN)
;
RVAQ S IBA(1)=" >> "_IBCNT_" Revenue Codes activated (399.2)..."
D MES^XPDUTL(.IBA)
Q
;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
N IBX,IBY S IBY=""
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
Q IBY
;
MSG(X) ;
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=$G(X)
Q
;
RVF ; Revenue Codes to (3) Activate (399.2,2)
;;190,200,912,
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPSA 4586 printed Sep 23, 2025@20:13 Page 2
IBYPSA ;ALB/ARH - IB*2.0*245 POST INIT: REASONABLE CHARGES V2.0 ; 10-OCT-2003
+1 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
+5 QUIT
+6 ;
POST ;
+1 NEW IBA
+2 SET IBA(1)=""
SET IBA(2)=" Reasonable Charges v2.0 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ;
+4 ; add Rate Schedule Inactive dates (363, .06)
DO RSINDT
+5 ;
+6 ; update Billing Rate Names for v2.0 (363.3)
DO UPDBR
+7 ;
+8 ; add Billable Service (399.1, .2)
DO ADDRB^IBYPSA1
+9 ; add Bedsections (399.1,.12)
DO ADDBS^IBYPSA1
+10 ; add Billable Items (363.21)
DO ADDBI^IBYPSA1
+11 ; add Rate Schedule (363)
DO ADDRS^IBYPSA1
+12 ; add Billing Rates (363.3)
DO ADDBR^IBYPSA1
+13 ;
+14 ; add Billing Rates to Special Groups (363.32,11,.01)
DO SGBR
+15 ; activate 3 Revenue Codes (399.2,2)
DO RVACT
+16 ;
+17 ; inactivate all RC charges in #363.2
DO CHGINA^IBYPSA2("")
+18 ;
+19 SET IBA(1)=""
SET IBA(2)=" Reasonable Charges v2.0 Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+20 ;
+21 QUIT
+22 ;
+23 ;
RSINDT ; add an inactive date to rate schedules if this is the first time the load is completed (363, .06)
+1 ; Reimbursable Ins, No Fault, and Workers Comp only
+2 ; if test account use 9/30/98, if production account use 8/31/99
+3 NEW IBA,IBRSFN,IBRS0,IBRSN,IBCNT,IBSTDT,DD,DO,DIC,DIE,DA,DR,X,Y
SET IBSTDT=""
SET IBCNT=0
+4 ;
+5 IF $ORDER(^IBE(363.3,"B","RC PHYSICIAN MN",0))
GOTO RSINQ
+6 ;
+7 ;I '$$PROD^IBCORC S IBSTDT=2980930
SET IBSTDT=$$VERSEDT^IBCRHBRV(1.4)
+8 ;
+9 SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^IBE(363,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:1
+10 SET IBRS0=$GET(^IBE(363,IBRSFN,0))
SET IBRSN=$EXTRACT(IBRS0,1,3)
+11 IF IBRSN'="RI-"
IF IBRSN'="NF-"
IF IBRSN'="WC-"
QUIT
+12 IF $PIECE(IBRS0,U,5)'<IBSTDT
QUIT
+13 IF $PIECE(IBRS0,U,6)'=""
QUIT
+14 ;
+15 SET IBCNT=IBCNT+1
SET DR=".06////"_IBSTDT
SET DIE="^IBE(363,"
SET DA=+IBRSFN
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+16 ;
RSINQ SET IBA(1)=" >> "_IBCNT_" Rate Schedules inactivated on "_$EXTRACT(IBSTDT,4,5)_"/"_$EXTRACT(IBSTDT,6,7)_"/"_$EXTRACT(IBSTDT,2,3)_" (363)..."
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
UPDBR ; Update Billing Rate Names
+1 NEW IBA,IBDA,IBCNT,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
+2 ;
+3 SET DA=$ORDER(^IBE(363.3,"B","RC OUTPATIENT FACILITY",""))
IF +DA
Begin DoDot:1
+4 SET DR=".01///RC FACILITY PR;.02///RC F/PR"
SET DIE="^IBE(363.3,"
DO ^DIE
KILL DIE,DA,DR,X,Y
+5 DO MSG(" RC OUTPATIENT FACILITY to RC FACILITY PR")
SET IBCNT=IBCNT+1
End DoDot:1
+6 ;
+7 SET DA=$ORDER(^IBE(363.3,"B","RC PHYSICIAN",""))
IF +DA
Begin DoDot:1
+8 SET DR=".01///RC PHYSICIAN PR;.02///RC P/PR"
SET DIE="^IBE(363.3,"
DO ^DIE
KILL DIE,DA,DR,X,Y
+9 DO MSG(" RC PHYSICIAN to RC PHYSICIAN PR")
SET IBCNT=IBCNT+1
End DoDot:1
+10 ;
+11 SET IBA(1)=" >> "_IBCNT_" Billing Rate Names Updated (363.3)..."
+12 DO MES^XPDUTL(.IBA)
+13 QUIT
+14 ;
SGBR ; add new Billing Rates to the Special Groups (363.32,11,.01)
+1 NEW IBA,IBSET,IBSG,IBSGFN,IBBR,IBBRFN,IBCNT,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBBRNM
SET IBCNT=0
+2 ;
+3 FOR IBSET="STANDARD RVCD LINKS^RC FACILITY","STANDARD RVCD LINKS^RC PHYSICIAN","RC PROVIDER DISCOUNTS^RC PHYSICIAN"
Begin DoDot:1
+4 SET IBSG=$PIECE(IBSET,U,1)
if IBSG=""
QUIT
SET IBSGFN=$ORDER(^IBE(363.32,"B",IBSG,0))
if 'IBSGFN
QUIT
+5 SET IBBR=$PIECE(IBSET,U,2)
if IBBR=""
QUIT
+6 ;
+7 SET IBBRNM=IBBR
FOR
SET IBBRNM=$ORDER(^IBE(363.3,"B",IBBRNM))
if IBBRNM'[IBBR
QUIT
Begin DoDot:2
+8 ;
+9 SET IBBRFN=$ORDER(^IBE(363.3,"B",IBBRNM,0))
if 'IBBRFN
QUIT
+10 ; cpt charges only
IF +$PIECE($GET(^IBE(363.3,+IBBRFN,0)),U,4)'=2
QUIT
+11 ;
+12 IF $ORDER(^IBE(363.32,+IBSGFN,11,"B",+IBBRFN,0))
QUIT
+13 ;
+14 SET DLAYGO=363.32
SET DA(1)=+IBSGFN
SET DIC="^IBE(363.32,"_DA(1)_",11,"
SET DIC(0)="L"
SET X=IBBRNM
SET DIC("P")="363.3211PA"
DO ^DIC
KILL DIC,DIE
SET IBCNT=IBCNT+1
End DoDot:2
End DoDot:1
+15 ;
SGBRQ SET IBA(1)=" >> "_IBCNT_" Billing Rates added to Special Groups (363.32)..."
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
RVACT ; activate (3) Revenue Codes exported in as defaults for new Charge Sets (399.2,2)
+1 NEW IBA,IBLN,IBI,IBRVFN,IBACT,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
SET IBACT=""
+2 ;
+3 SET IBLN=$PIECE($TEXT(RVF+1),";;",2)
+4 ;
+5 FOR IBI=1:1
SET IBRVFN=$PIECE(IBLN,",",IBI)
if 'IBRVFN
QUIT
Begin DoDot:1
+6 ;
+7 IF +$PIECE($GET(^DGCR(399.2,IBRVFN,0)),U,3)
QUIT
+8 ;
+9 SET IBACT=IBACT_IBRVFN_","
+10 SET IBCNT=IBCNT+1
SET DR="2////1"
SET DIE="^DGCR(399.2,"
SET DA=+IBRVFN
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+11 ;
+12 IF IBCNT>0
SET IBJ=0
FOR IBI=1:15
SET IBJ=IBJ+15
SET IBLN=$PIECE(IBACT,",",IBI,IBJ)
if IBLN=""
QUIT
DO MSG(" "_IBLN)
+13 ;
RVAQ SET IBA(1)=" >> "_IBCNT_" Revenue Codes activated (399.2)..."
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+3 QUIT IBY
+4 ;
MSG(X) ;
+1 NEW IBX
SET IBX=$ORDER(IBA(999999),-1)
if 'IBX
SET IBX=1
SET IBX=IBX+1
+2 SET IBA(IBX)=$GET(X)
+3 QUIT
+4 ;
RVF ; Revenue Codes to (3) Activate (399.2,2)
+1 ;;190,200,912,
+2 ;;
