IBYPPR ;ALB/ARH - IB*2.0*106 PRE/POST INIT: REASONABLE CHARGES ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
Q
PRE ; in 399, delete all xrefs for certain fields, these fields are all exported with this patch
; they must be deleted before the build inserts the updated fields because the xrefs have changed
N IBX,X,Y,DIK,DA,IBFLD,IBXREF
;
D BMES^XPDUTL("Pre-Installation Updates (Cross references will be updated during install)")
;
F IBFLD=135,151 D
. ;
. S IBXREF=0 F S IBXREF=$O(^DD(399,IBFLD,1,IBXREF)) Q:'IBXREF D
.. S DIK="^DD(399,"_IBFLD_",1,",DA(2)=399,DA(1)=IBFLD,DA=IBXREF
.. D ^DIK K DIK,DA
. S IBX=" >> ^DGCR(399,"_IBFLD_") cross references deleted." D MES^XPDUTL(IBX)
;
F IBFLD=.01,1,5,6 D
. ;
. S IBXREF=0 F S IBXREF=$O(^DD(399.0304,IBFLD,1,IBXREF)) Q:'IBXREF D
.. S DIK="^DD(399.0304,"_IBFLD_",1,",DA(2)=399.0304,DA(1)=IBFLD,DA=IBXREF
.. D ^DIK K DIK,DA
. S IBX=" >> ^DGCR(399,304,"_IBFLD_") cross references deleted." D MES^XPDUTL(IBX)
;
; Output Formatter Updates: the Data Element (364.7,.03) of a field has changed, update this before the
; installation so the incoming field can match correctly with the existing field
N OLD,NEW,DIC,DIE,DR,X,Y
;
; change ACCEPT ASSIGNMENT (BX-27) (357) from N-GET FROM PREVIOUS EXTRACT (5) to N-ASSIGN OF BENEFITS INDICATOR (24)
;
S DA=357
S OLD=$O(^IBA(364.5,"B","N-GET FROM PREVIOUS EXTRACT",0))
S NEW=$O(^IBA(364.5,"B","N-ASSIGN OF BENEFITS INDICATOR",0))
I +OLD,+NEW,$P($G(^IBA(364.7,DA,0)),U,3)=OLD S DIE="^IBA(364.7,",DR=".03////"_NEW D ^DIE
;
S IBX=" >> Output Formatter Fields Updated (#364.7,.03)." D MES^XPDUTL(IBX)
;
D BMES^XPDUTL("Pre-Installation Updates Completed")
Q
;
POST ;
N IBA
S IBA(1)="",IBA(2)=" Reasonable Charges Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
D DELCT ; clear Charge Type field for all Charge Sets (363.1, .04)
D RSINDT ; add Rate Schedule Inactive dates (363, .06)
;
D ADDBS^IBYPPR1 ; add Bedsections (399.1,.12)
D ADDBE^IBYPPR1 ; add Billable Events (399.1, .21)
D ADDBI^IBYPPR1 ; add Billable Items (363.21)
D ADDRS^IBYPPR1 ; add Rate Schedule (363)
D ADDBR^IBYPPR1 ; add Billing Rates (363.3)
;
D SGBR ; add Billing Rates to Special Groups (363.32,11,.01)
D RVACT ; activate 41 Revenue Codes (399.2,2)
;
S IBA(1)="",IBA(2)=" Reasonable Charges Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
Q
;
DELCT ; Delete Charge Type from all Non-Reasonable Charges Charge Sets (363.1,.04)
N IBA,IBCS,IBLN,IBBRN,DIC,DIE,DR,DA,X,Y
;
S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
. S IBLN=$G(^IBE(363.1,IBCS,0)) I '$P(IBLN,U,4) Q
. S IBBRN=$P($G(^IBE(363.3,+$P(IBLN,U,2),0)),U,1) I $E(IBBRN,1,3)="RC " Q
. ;
. S DR=".04////@",DIE="^IBE(363.1,",DA=+IBCS D ^DIE K DIE,DA,DR,X,Y
;
DCQ S IBA(1)=" >> Removing Charge Types from non-RC Charge Sets (363.1)..."
D MES^XPDUTL(.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 INPATIENT FACILITY",0)) G RSINQ
;
S IBSTDT=2990831 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)'="")!($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
;
SGBR ; add 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 S IBCNT=0
;
F IBSET="STANDARD RVCD LINKS^RC OUTPATIENT 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 IBBRFN=$O(^IBE(363.3,"B",IBBR,0)) Q:'IBBRFN
. ;
. 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=IBBR,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 (30) Revenue Codes exported in RV-CPT links (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 (59) Activate (399.2,2)
;;301,302,305,306,307,309,310,311,312,320,322,323,324,333,341,342,351,352,359,360,362,370,401,402,403,404,410,413,420,430,440,441,450,460,470,471,480,481,482,610,636,730,731,740,750,761,901,910,914,915,916,918,920,921,922,924,943,
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPR 5973 printed Apr 09, 2024@21:20:31 Page 2
IBYPPR ;ALB/ARH - IB*2.0*106 PRE/POST INIT: REASONABLE CHARGES ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
+5 QUIT
PRE ; in 399, delete all xrefs for certain fields, these fields are all exported with this patch
+1 ; they must be deleted before the build inserts the updated fields because the xrefs have changed
+2 NEW IBX,X,Y,DIK,DA,IBFLD,IBXREF
+3 ;
+4 DO BMES^XPDUTL("Pre-Installation Updates (Cross references will be updated during install)")
+5 ;
+6 FOR IBFLD=135,151
Begin DoDot:1
+7 ;
+8 SET IBXREF=0
FOR
SET IBXREF=$ORDER(^DD(399,IBFLD,1,IBXREF))
if 'IBXREF
QUIT
Begin DoDot:2
+9 SET DIK="^DD(399,"_IBFLD_",1,"
SET DA(2)=399
SET DA(1)=IBFLD
SET DA=IBXREF
+10 DO ^DIK
KILL DIK,DA
End DoDot:2
+11 SET IBX=" >> ^DGCR(399,"_IBFLD_") cross references deleted."
DO MES^XPDUTL(IBX)
End DoDot:1
+12 ;
+13 FOR IBFLD=.01,1,5,6
Begin DoDot:1
+14 ;
+15 SET IBXREF=0
FOR
SET IBXREF=$ORDER(^DD(399.0304,IBFLD,1,IBXREF))
if 'IBXREF
QUIT
Begin DoDot:2
+16 SET DIK="^DD(399.0304,"_IBFLD_",1,"
SET DA(2)=399.0304
SET DA(1)=IBFLD
SET DA=IBXREF
+17 DO ^DIK
KILL DIK,DA
End DoDot:2
+18 SET IBX=" >> ^DGCR(399,304,"_IBFLD_") cross references deleted."
DO MES^XPDUTL(IBX)
End DoDot:1
+19 ;
+20 ; Output Formatter Updates: the Data Element (364.7,.03) of a field has changed, update this before the
+21 ; installation so the incoming field can match correctly with the existing field
+22 NEW OLD,NEW,DIC,DIE,DR,X,Y
+23 ;
+24 ; change ACCEPT ASSIGNMENT (BX-27) (357) from N-GET FROM PREVIOUS EXTRACT (5) to N-ASSIGN OF BENEFITS INDICATOR (24)
+25 ;
+26 SET DA=357
+27 SET OLD=$ORDER(^IBA(364.5,"B","N-GET FROM PREVIOUS EXTRACT",0))
+28 SET NEW=$ORDER(^IBA(364.5,"B","N-ASSIGN OF BENEFITS INDICATOR",0))
+29 IF +OLD
IF +NEW
IF $PIECE($GET(^IBA(364.7,DA,0)),U,3)=OLD
SET DIE="^IBA(364.7,"
SET DR=".03////"_NEW
DO ^DIE
+30 ;
+31 SET IBX=" >> Output Formatter Fields Updated (#364.7,.03)."
DO MES^XPDUTL(IBX)
+32 ;
+33 DO BMES^XPDUTL("Pre-Installation Updates Completed")
+34 QUIT
+35 ;
POST ;
+1 NEW IBA
+2 SET IBA(1)=""
SET IBA(2)=" Reasonable Charges Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ;
+4 ; clear Charge Type field for all Charge Sets (363.1, .04)
DO DELCT
+5 ; add Rate Schedule Inactive dates (363, .06)
DO RSINDT
+6 ;
+7 ; add Bedsections (399.1,.12)
DO ADDBS^IBYPPR1
+8 ; add Billable Events (399.1, .21)
DO ADDBE^IBYPPR1
+9 ; add Billable Items (363.21)
DO ADDBI^IBYPPR1
+10 ; add Rate Schedule (363)
DO ADDRS^IBYPPR1
+11 ; add Billing Rates (363.3)
DO ADDBR^IBYPPR1
+12 ;
+13 ; add Billing Rates to Special Groups (363.32,11,.01)
DO SGBR
+14 ; activate 41 Revenue Codes (399.2,2)
DO RVACT
+15 ;
+16 SET IBA(1)=""
SET IBA(2)=" Reasonable Charges Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+17 ;
+18 QUIT
+19 ;
DELCT ; Delete Charge Type from all Non-Reasonable Charges Charge Sets (363.1,.04)
+1 NEW IBA,IBCS,IBLN,IBBRN,DIC,DIE,DR,DA,X,Y
+2 ;
+3 SET IBCS=0
FOR
SET IBCS=$ORDER(^IBE(363.1,IBCS))
if 'IBCS
QUIT
Begin DoDot:1
+4 SET IBLN=$GET(^IBE(363.1,IBCS,0))
IF '$PIECE(IBLN,U,4)
QUIT
+5 SET IBBRN=$PIECE($GET(^IBE(363.3,+$PIECE(IBLN,U,2),0)),U,1)
IF $EXTRACT(IBBRN,1,3)="RC "
QUIT
+6 ;
+7 SET DR=".04////@"
SET DIE="^IBE(363.1,"
SET DA=+IBCS
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+8 ;
DCQ SET IBA(1)=" >> Removing Charge Types from non-RC Charge Sets (363.1)..."
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
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 INPATIENT FACILITY",0))
GOTO RSINQ
+6 ;
+7 SET IBSTDT=2990831
IF '$$PROD^IBCORC
SET IBSTDT=2980930
+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)'="")!($PIECE(IBRS0,U,6)'="")
QUIT
+13 ;
+14 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
+15 ;
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 ;
SGBR ; add 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
SET IBCNT=0
+2 ;
+3 FOR IBSET="STANDARD RVCD LINKS^RC OUTPATIENT 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
SET IBBRFN=$ORDER(^IBE(363.3,"B",IBBR,0))
if 'IBBRFN
QUIT
+6 ;
+7 IF $ORDER(^IBE(363.32,+IBSGFN,11,"B",+IBBRFN,0))
QUIT
+8 ;
+9 SET DLAYGO=363.32
SET DA(1)=+IBSGFN
SET DIC="^IBE(363.32,"_DA(1)_",11,"
SET DIC(0)="L"
SET X=IBBR
SET DIC("P")="363.3211PA"
DO ^DIC
KILL DIC,DIE
SET IBCNT=IBCNT+1
End DoDot:1
+10 ;
SGBRQ SET IBA(1)=" >> "_IBCNT_" Billing Rates added to Special Groups (363.32)..."
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
RVACT ; activate (30) Revenue Codes exported in RV-CPT links (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 (59) Activate (399.2,2)
+1 ;;301,302,305,306,307,309,310,311,312,320,322,323,324,333,341,342,351,352,359,360,362,370,401,402,403,404,410,413,420,430,440,441,450,460,470,471,480,481,482,610,636,730,731,740,750,761,901,910,914,915,916,918,920,921,922,924,943,
+2 ;;
