IBCRHU2 ;ALB/ARH - RATES: UPLOAD UTILITIES (ADD CM ELEMENTS) ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106,138,245,175,307,498**;21-MAR-94;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
RG(NAME,DIV,ID,TY) ; add a new Billing Region for Reasonable Charges (363.31), input region name, MC division site #
; returns IFN of billing region (new or existing) ^ region name, null otherwise
; the part of the name before a dash is used to attempt a match with existing regions
N IBA,IBDV,IBFN,IBNEW,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S DIV=$G(DIV),IBDV="",(IBFN,IBNEW)=0
I $G(NAME)="" G RGQ
I NAME[" (DIV)" S NAME=$P(NAME," (DIV)",1)_$P(NAME," (DIV)",2)
I NAME[" (2)" S NAME=$P(NAME," (2)",1)_$P(NAME," (2)",2)
I NAME[" (3)" S NAME=$P(NAME," (2)",1)_$P(NAME," (3)",2)
;
S IBX="" F S IBX=$O(^IBE(363.31,"B",IBX)) Q:IBX="" I $P(IBX,"-",1)=$P(NAME,"-",1) S IBFN=$O(^IBE(363.31,"B",IBX,0)) Q
I +IBFN S IBFN=IBFN_U_$E(IBX,1,30),IBNEW=0 G RGQ
;
S IBDV=$$DIV(DIV) I 'IBDV D MSG(" *** Warning: No MC division "_DIV_" defined, no division added to Region")
;
I $G(ID)'="" S DIC("DR")=".02////"_$E(ID,1,10)_";"
I $G(TY)'="" S DIC("DR")=$G(DIC("DR"))_".03////"_$E(TY,1,10)
K DD,DO S DLAYGO=363.31,DIC="^IBE(363.31,",DIC(0)="L",X=$E(NAME,1,30) D FILE^DICN K DIC,DD,DO I Y<1 K X,Y Q
S IBFN=Y,IBNEW=1
;
I +IBDV S DLAYGO=363.31,DA(1)=+IBFN,DIC="^IBE(363.31,"_DA(1)_",11,",DIC(0)="L",X=+IBDV,DIC("P")="363.3111P" D ^DIC K DIC,DIE,DLAYGO
;
RGQ I +IBNEW!($D(IBA)) S IBA(1)=" >> "_$E(NAME,1,30)_" Billing Region "_$S('$G(IBFN):"NOT ",1:"")_"added "_$S(+IBDV:"for MCD "_$P(IBDV,U,3)_" "_$P(IBDV,U,2),1:"") D MSGP
Q $G(IBFN)
;
CS(NAME,RATE,EVENT,RG,CT,RV,BS) ; add Charge Set for Reasonable Charges (363.1), all input in external form
; returns IFN of new charge set, 0 otherwise
N IBA,IBBR,IBBE,IBRG,IBRV,IBBS,IBCT,IBOK,IBFN,IBCSN,IBJ,DD,DO,DLAYGO,DINUM,DIC,DIE,DA,DR,X,Y,IBFND S IBOK=1
S NAME=$G(NAME),RATE=$G(RATE),EVENT=$G(EVENT),RG=$G(RG),CT=$G(CT),RV=$G(RV),BS=$G(BS) I NAME=""!(RATE="") G CSQ
;
S IBFND=+$O(^IBE(363.1,"B",$E(NAME,1,30),0)) I +IBFND S IBFN=IBFND,IBCSN=NAME G CSQ
;
S IBBR=$O(^IBE(363.3,"B",RATE,0)) I 'IBBR S IBOK=0 D MSG(" *** Error: "_RATE_" Billing Rate does not exist")
S IBBE=$$MCCRUTL(EVENT,14) I 'IBBE S IBOK=0 D MSG(" *** Error: "_EVENT_" Billable Event undefined")
S IBRG="" I RG'="" S IBRG=$O(^IBE(363.31,"B",$E(RG,1,30),0))
I 'IBRG,RG'="" S IBOK=0 D MSG(" *** Error: "_$E(RG,1,30)_" Billing Region does not exist")
I '$G(IBOK) G CSQ
S IBRV=$$RVCD(RV) I 'IBRV D MSG(" *** Warning: No default revenue code added for Charge Set")
S IBBS=$$MCCRUTL(BS,5) I 'IBBS D MSG(" *** Warning: No default bedsection added for Charge Set")
S IBCT=$S($E(CT)="I":1,$E(CT)="P":2,1:"")
;
F IBJ=1:1 S IBFN=$G(^IBE(363.1,IBJ,0)) I IBFN="" S DINUM=IBJ Q
;
K DD,DO S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="L",X=$E(NAME,1,30) D FILE^DICN K DIC K DIC,DINUM,DLAYGO,DD,DO I Y<1 K X,Y Q
S IBFN=+Y,IBCSN=$P(Y,U,2)
;
S DR=".02////"_IBBR_";.03////"_IBBE_";.04////"_IBCT_";.07////"_IBRG
I +IBRV S DR=DR_";.05////"_IBRV
I +IBBS S DR=DR_";.06////"_IBBS
S DIE="^IBE(363.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
;
;
CSQ I +$G(IBFN),$G(IBCSN)'="" D RS(IBCSN)
;
S IBA(1)=" >> "_$E(NAME,1,30)_" Charge Set "_$S('$G(IBFN):"NOT ",1:"")_$S(+$G(IBFND):"used",1:"added") D MSGP
Q +$G(IBFN)
;
USECS(CSN) ; return an existing CS for a set of RC charges, given the name to look for, or write an error message
N IBCS S IBCS=0
I $G(CSN)'="" S IBCS=$O(^IBE(363.1,"B",$E(CSN,1,30),0))
I 'IBCS W !," *** Warning: No Charge Set found for these charges"
I +IBCS W !," >> "_$E(CSN,1,30)_" Charge Set used"
Q IBCS
;
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
;
RVCD(RVCD) ; check for valid revenue code (#399.2), input either revenue code or revenue code IFN
; returns IFN if revenue code is valid and active, null otherwise
N IBX,IBY S IBY=""
I +$G(RVCD) S IBX=$G(^DGCR(399.2,+RVCD,0)) I +$P(IBX,U,3) S IBY=+RVCD
Q IBY
;
DIV(DIV) ; check for valid medical center division (#40.8), input facility/site number
; returns 'IFN ^ name ^ #' of division if it exists in Medical Center Division file (40.8), 0 otherwise
N IBX,IBY S IBX=0
I $G(DIV)'="" S DIV=+$O(^DG(40.8,"C",DIV,0))
I +$G(DIV) S IBY=$G(^DG(40.8,+DIV,0)) I IBY'="" S IBX=DIV_U_$P(IBY,U,1,2)
Q IBX
;
MSG(X) ; add message to end of message list, reserves IBA(1) for primary message
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=$G(X)
Q
MSGP ; print error messages in IBA
N IBX S IBX="" F S IBX=$O(IBA(IBX)) Q:'IBX W !,IBA(IBX)
Q
;
;
RS(CSN) ; add new Reasonable Charges Charge Sets to Rate Schedules, input Charge Set Name
; finds the RS to add the CS to based on the effective/inactive dates of the RS and version being loaded
; for RC 1.x only adds physician to inpt if there was also inpatient facility charges
; Tort Feasor began using Reasonable Charges on 01/07/04
N IBCSFN,IBRSN,IBRS,IBRS0,IBRSLST,IBVBEG,IBVEND,IBVERS,IBAUTO,IBFND,IBSITE,IBI,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
;
I $G(CSN)="" Q
I $E(CSN,1,2)'="RC" Q
S IBCSFN=$O(^IBE(363.1,"B",$E(CSN,1,30),0)) I 'IBCSFN Q
S IBAUTO=1 I $P($G(^IBE(363.3,+$P($G(^IBE(363.1,+IBCSFN,0)),U,2),0)),U,4)=9 S IBAUTO=""
S IBVERS=$$VERSION^IBCRHBRV,IBVBEG=$$VERSDT^IBCRHBRV,IBVEND=$$VERSEDT^IBCRHBRV,IBFND=1
S IBI=$L(CSN," "),IBSITE=$P(CSN," ",IBI)
;
I IBVERS<2 D
. I CSN["INPT " S IBRSLST="RI-INPT,NF-INPT,WC-INPT"
. I CSN["SNF " S IBRSLST="RI-INPT,NF-INPT,WC-INPT"
. I CSN["OPT " S IBRSLST="RI-OPT,NF-OPT,WC-OPT"
. I CSN["PHYS" S IBRSLST="RI-OPT,NF-OPT,WC-OPT"
. I CSN["PHYS",$O(^IBE(363.1,"B","RC-INPT ANC "_IBSITE,0)) S IBRSLST=IBRSLST_",RI-INPT,NF-INPT,WC-INPT"
;
I IBVERS'<2 D
. I CSN["INPT " S IBRSLST="RI-INPT,NF-INPT,WC-INPT,TF-INPT,CVA-INPT,CVA RI-INPT"
. I CSN["SNF " S IBRSLST="RI-SNF,NF-SNF,WC-SNF,TF-SNF,CVA-SNF,CVA RI-SNF"
. I CSN["OPT " S IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT,CVA-OPT,CVA RI-OPT"
. I CSN[" FS " S IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT,CVA-OPT,CVA RI-OPT"
I $G(IBRSLST)="" Q
;
F IBI=1:1 S IBRSN=$P(IBRSLST,",",IBI) Q:IBRSN="" D
. S IBRS=0 F S IBRS=$O(^IBE(363,"B",IBRSN,IBRS)) Q:'IBRS D Q:+IBFND
.. S IBRS0=$G(^IBE(363,IBRS,0))
.. I $E(IBRSN,1,3)="TF-",+$P(IBRS0,U,6),$P(IBRS0,U,6)<3040107 S IBFND=0 Q
.. I $E(IBRSN,1,3)="CVA",+$P(IBRS0,U,6),$P(IBRS0,U,6)<3100101 S IBFND=0 Q
.. I +$P(IBRS0,U,6),$P(IBRS0,U,6)<IBVBEG S IBFND=0 Q
.. I +IBVEND,+$P(IBRS0,U,5),$P(IBRS0,U,5)>IBVEND S IBFND=0 Q
.. S IBFND=1 I $O(^IBE(363,+IBRS,11,"B",+IBCSFN,0)) Q
.. I +IBAUTO S DIC("DR")=".02////"_1
.. S DLAYGO=363,DA(1)=+IBRS,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="LX",X=CSN,DIC("P")="363.0011P" D ^DIC K DIC,DIE
Q
;
;
;
GETDIV(RGFN) ; ask the user for the divisions for a Billing Region
N IBX,DIC,DIE,DA,DR,X,Y,DIDEL,DLAYGO Q:'$G(RGFN) S IBX=$G(^IBE(363.31,+RGFN,0)) Q:IBX=""
W !!,"Enter the Divisions associated with these charges: ",$P(IBX,U,1)
S (DLAYGO,DIDEL)=363.31,DIE="^IBE(363.31,",DA=+RGFN,DR=11 D ^DIE K DIE,DR,X,Y,DIDEL,DLAYGO
Q
;
RSBR(CSFN,AUTO,EFFDT) ; add the charge set to any Rate Schedule that already has charge sets of this Billing Rate assigned
; CSFN - IFN of Charge Set to add, AUTO - 1 if charges should be auto added, EFFDT - effective date of charges
; will add the Charge Set to any Rate Schedule that already has a Set of same Billing Rate and is not inactive
N IBCS0,IBCSN,IBBRFN,IBRS,IBRSIA,IBCSE,IBNEW,IBFND,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S DLAYGO=363,IBNEW=0
;
S CSFN=+$G(CSFN) I 'CSFN Q
I $G(^IBE(363.1,CSFN,0))="" Q
I +$O(^IBE(363,"C",CSFN,0)) Q ; charge set already assigned to rate schedules
;
S IBCS0=$G(^IBE(363.1,CSFN,0)),IBCSN=$P(IBCS0,U,1),IBBRFN=$P(IBCS0,U,2) Q:'IBBRFN
;
S IBRS=0 F S IBRS=$O(^IBE(363,IBRS)) Q:'IBRS S IBFND=0 D
. I $O(^IBE(363,IBRS,11,"B",CSFN,0)) Q ; charge set already assigned to RS
. I +$G(EFFDT) S IBRSIA=$P($G(^IBE(363,IBRS,0)),U,6) I +IBRSIA,EFFDT>IBRSIA Q ; RS inactive before CS active
. ;
. S IBCSE=0 F S IBCSE=$O(^IBE(363,IBRS,11,"B",IBCSE)) Q:'IBCSE D Q:IBFND
.. I $D(^IBE(363.1,"C",IBBRFN,IBCSE)) D S IBFND=1,IBNEW=1 ; schedule has charge sets of same billing rate
... ;
... I +$G(AUTO) S DIC("DR")=".02////"_1
... S DA(1)=+IBRS,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="LX",X=IBCSN,DIC("P")="363.0011P" D ^DIC K DIC,DIE
... W !," Charge Set added to Rate Schedule ",$P($G(^IBE(363,+IBRS,0)),U,1)
;
I 'IBNEW W !," *** Warning: ",IBCSN," not added to any Rate Schedule,",!," set manually using Enter/Edit Charge Master option."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHU2 8871 printed Sep 02, 2024@19:04:51 Page 2
IBCRHU2 ;ALB/ARH - RATES: UPLOAD UTILITIES (ADD CM ELEMENTS) ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106,138,245,175,307,498**;21-MAR-94;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
RG(NAME,DIV,ID,TY) ; add a new Billing Region for Reasonable Charges (363.31), input region name, MC division site #
+1 ; returns IFN of billing region (new or existing) ^ region name, null otherwise
+2 ; the part of the name before a dash is used to attempt a match with existing regions
+3 NEW IBA,IBDV,IBFN,IBNEW,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
SET DIV=$GET(DIV)
SET IBDV=""
SET (IBFN,IBNEW)=0
+4 IF $GET(NAME)=""
GOTO RGQ
+5 IF NAME[" (DIV)"
SET NAME=$PIECE(NAME," (DIV)",1)_$PIECE(NAME," (DIV)",2)
+6 IF NAME[" (2)"
SET NAME=$PIECE(NAME," (2)",1)_$PIECE(NAME," (2)",2)
+7 IF NAME[" (3)"
SET NAME=$PIECE(NAME," (2)",1)_$PIECE(NAME," (3)",2)
+8 ;
+9 SET IBX=""
FOR
SET IBX=$ORDER(^IBE(363.31,"B",IBX))
if IBX=""
QUIT
IF $PIECE(IBX,"-",1)=$PIECE(NAME,"-",1)
SET IBFN=$ORDER(^IBE(363.31,"B",IBX,0))
QUIT
+10 IF +IBFN
SET IBFN=IBFN_U_$EXTRACT(IBX,1,30)
SET IBNEW=0
GOTO RGQ
+11 ;
+12 SET IBDV=$$DIV(DIV)
IF 'IBDV
DO MSG(" *** Warning: No MC division "_DIV_" defined, no division added to Region")
+13 ;
+14 IF $GET(ID)'=""
SET DIC("DR")=".02////"_$EXTRACT(ID,1,10)_";"
+15 IF $GET(TY)'=""
SET DIC("DR")=$GET(DIC("DR"))_".03////"_$EXTRACT(TY,1,10)
+16 KILL DD,DO
SET DLAYGO=363.31
SET DIC="^IBE(363.31,"
SET DIC(0)="L"
SET X=$EXTRACT(NAME,1,30)
DO FILE^DICN
KILL DIC,DD,DO
IF Y<1
KILL X,Y
QUIT
+17 SET IBFN=Y
SET IBNEW=1
+18 ;
+19 IF +IBDV
SET DLAYGO=363.31
SET DA(1)=+IBFN
SET DIC="^IBE(363.31,"_DA(1)_",11,"
SET DIC(0)="L"
SET X=+IBDV
SET DIC("P")="363.3111P"
DO ^DIC
KILL DIC,DIE,DLAYGO
+20 ;
RGQ IF +IBNEW!($DATA(IBA))
SET IBA(1)=" >> "_$EXTRACT(NAME,1,30)_" Billing Region "_$SELECT('$GET(IBFN):"NOT ",1:"")_"added "_$SELECT(+IBDV:"for MCD "_$PIECE(IBDV,U,3)_" "_$PIECE(IBDV,U,2),1:"")
DO MSGP
+1 QUIT $GET(IBFN)
+2 ;
CS(NAME,RATE,EVENT,RG,CT,RV,BS) ; add Charge Set for Reasonable Charges (363.1), all input in external form
+1 ; returns IFN of new charge set, 0 otherwise
+2 NEW IBA,IBBR,IBBE,IBRG,IBRV,IBBS,IBCT,IBOK,IBFN,IBCSN,IBJ,DD,DO,DLAYGO,DINUM,DIC,DIE,DA,DR,X,Y,IBFND
SET IBOK=1
+3 SET NAME=$GET(NAME)
SET RATE=$GET(RATE)
SET EVENT=$GET(EVENT)
SET RG=$GET(RG)
SET CT=$GET(CT)
SET RV=$GET(RV)
SET BS=$GET(BS)
IF NAME=""!(RATE="")
GOTO CSQ
+4 ;
+5 SET IBFND=+$ORDER(^IBE(363.1,"B",$EXTRACT(NAME,1,30),0))
IF +IBFND
SET IBFN=IBFND
SET IBCSN=NAME
GOTO CSQ
+6 ;
+7 SET IBBR=$ORDER(^IBE(363.3,"B",RATE,0))
IF 'IBBR
SET IBOK=0
DO MSG(" *** Error: "_RATE_" Billing Rate does not exist")
+8 SET IBBE=$$MCCRUTL(EVENT,14)
IF 'IBBE
SET IBOK=0
DO MSG(" *** Error: "_EVENT_" Billable Event undefined")
+9 SET IBRG=""
IF RG'=""
SET IBRG=$ORDER(^IBE(363.31,"B",$EXTRACT(RG,1,30),0))
+10 IF 'IBRG
IF RG'=""
SET IBOK=0
DO MSG(" *** Error: "_$EXTRACT(RG,1,30)_" Billing Region does not exist")
+11 IF '$GET(IBOK)
GOTO CSQ
+12 SET IBRV=$$RVCD(RV)
IF 'IBRV
DO MSG(" *** Warning: No default revenue code added for Charge Set")
+13 SET IBBS=$$MCCRUTL(BS,5)
IF 'IBBS
DO MSG(" *** Warning: No default bedsection added for Charge Set")
+14 SET IBCT=$SELECT($EXTRACT(CT)="I":1,$EXTRACT(CT)="P":2,1:"")
+15 ;
+16 FOR IBJ=1:1
SET IBFN=$GET(^IBE(363.1,IBJ,0))
IF IBFN=""
SET DINUM=IBJ
QUIT
+17 ;
+18 KILL DD,DO
SET DLAYGO=363.1
SET DIC="^IBE(363.1,"
SET DIC(0)="L"
SET X=$EXTRACT(NAME,1,30)
DO FILE^DICN
KILL DIC
KILL DIC,DINUM,DLAYGO,DD,DO
IF Y<1
KILL X,Y
QUIT
+19 SET IBFN=+Y
SET IBCSN=$PIECE(Y,U,2)
+20 ;
+21 SET DR=".02////"_IBBR_";.03////"_IBBE_";.04////"_IBCT_";.07////"_IBRG
+22 IF +IBRV
SET DR=DR_";.05////"_IBRV
+23 IF +IBBS
SET DR=DR_";.06////"_IBBS
+24 SET DIE="^IBE(363.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+25 ;
+26 ;
CSQ IF +$GET(IBFN)
IF $GET(IBCSN)'=""
DO RS(IBCSN)
+1 ;
+2 SET IBA(1)=" >> "_$EXTRACT(NAME,1,30)_" Charge Set "_$SELECT('$GET(IBFN):"NOT ",1:"")_$SELECT(+$GET(IBFND):"used",1:"added")
DO MSGP
+3 QUIT +$GET(IBFN)
+4 ;
USECS(CSN) ; return an existing CS for a set of RC charges, given the name to look for, or write an error message
+1 NEW IBCS
SET IBCS=0
+2 IF $GET(CSN)'=""
SET IBCS=$ORDER(^IBE(363.1,"B",$EXTRACT(CSN,1,30),0))
+3 IF 'IBCS
WRITE !," *** Warning: No Charge Set found for these charges"
+4 IF +IBCS
WRITE !," >> "_$EXTRACT(CSN,1,30)_" Charge Set used"
+5 QUIT IBCS
+6 ;
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 ;
RVCD(RVCD) ; check for valid revenue code (#399.2), input either revenue code or revenue code IFN
+1 ; returns IFN if revenue code is valid and active, null otherwise
+2 NEW IBX,IBY
SET IBY=""
+3 IF +$GET(RVCD)
SET IBX=$GET(^DGCR(399.2,+RVCD,0))
IF +$PIECE(IBX,U,3)
SET IBY=+RVCD
+4 QUIT IBY
+5 ;
DIV(DIV) ; check for valid medical center division (#40.8), input facility/site number
+1 ; returns 'IFN ^ name ^ #' of division if it exists in Medical Center Division file (40.8), 0 otherwise
+2 NEW IBX,IBY
SET IBX=0
+3 IF $GET(DIV)'=""
SET DIV=+$ORDER(^DG(40.8,"C",DIV,0))
+4 IF +$GET(DIV)
SET IBY=$GET(^DG(40.8,+DIV,0))
IF IBY'=""
SET IBX=DIV_U_$PIECE(IBY,U,1,2)
+5 QUIT IBX
+6 ;
MSG(X) ; add message to end of message list, reserves IBA(1) for primary message
+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
MSGP ; print error messages in IBA
+1 NEW IBX
SET IBX=""
FOR
SET IBX=$ORDER(IBA(IBX))
if 'IBX
QUIT
WRITE !,IBA(IBX)
+2 QUIT
+3 ;
+4 ;
RS(CSN) ; add new Reasonable Charges Charge Sets to Rate Schedules, input Charge Set Name
+1 ; finds the RS to add the CS to based on the effective/inactive dates of the RS and version being loaded
+2 ; for RC 1.x only adds physician to inpt if there was also inpatient facility charges
+3 ; Tort Feasor began using Reasonable Charges on 01/07/04
+4 NEW IBCSFN,IBRSN,IBRS,IBRS0,IBRSLST,IBVBEG,IBVEND,IBVERS,IBAUTO,IBFND,IBSITE,IBI,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
+5 ;
+6 IF $GET(CSN)=""
QUIT
+7 IF $EXTRACT(CSN,1,2)'="RC"
QUIT
+8 SET IBCSFN=$ORDER(^IBE(363.1,"B",$EXTRACT(CSN,1,30),0))
IF 'IBCSFN
QUIT
+9 SET IBAUTO=1
IF $PIECE($GET(^IBE(363.3,+$PIECE($GET(^IBE(363.1,+IBCSFN,0)),U,2),0)),U,4)=9
SET IBAUTO=""
+10 SET IBVERS=$$VERSION^IBCRHBRV
SET IBVBEG=$$VERSDT^IBCRHBRV
SET IBVEND=$$VERSEDT^IBCRHBRV
SET IBFND=1
+11 SET IBI=$LENGTH(CSN," ")
SET IBSITE=$PIECE(CSN," ",IBI)
+12 ;
+13 IF IBVERS<2
Begin DoDot:1
+14 IF CSN["INPT "
SET IBRSLST="RI-INPT,NF-INPT,WC-INPT"
+15 IF CSN["SNF "
SET IBRSLST="RI-INPT,NF-INPT,WC-INPT"
+16 IF CSN["OPT "
SET IBRSLST="RI-OPT,NF-OPT,WC-OPT"
+17 IF CSN["PHYS"
SET IBRSLST="RI-OPT,NF-OPT,WC-OPT"
+18 IF CSN["PHYS"
IF $ORDER(^IBE(363.1,"B","RC-INPT ANC "_IBSITE,0))
SET IBRSLST=IBRSLST_",RI-INPT,NF-INPT,WC-INPT"
End DoDot:1
+19 ;
+20 IF IBVERS'<2
Begin DoDot:1
+21 IF CSN["INPT "
SET IBRSLST="RI-INPT,NF-INPT,WC-INPT,TF-INPT,CVA-INPT,CVA RI-INPT"
+22 IF CSN["SNF "
SET IBRSLST="RI-SNF,NF-SNF,WC-SNF,TF-SNF,CVA-SNF,CVA RI-SNF"
+23 IF CSN["OPT "
SET IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT,CVA-OPT,CVA RI-OPT"
+24 IF CSN[" FS "
SET IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT,CVA-OPT,CVA RI-OPT"
End DoDot:1
+25 IF $GET(IBRSLST)=""
QUIT
+26 ;
+27 FOR IBI=1:1
SET IBRSN=$PIECE(IBRSLST,",",IBI)
if IBRSN=""
QUIT
Begin DoDot:1
+28 SET IBRS=0
FOR
SET IBRS=$ORDER(^IBE(363,"B",IBRSN,IBRS))
if 'IBRS
QUIT
Begin DoDot:2
+29 SET IBRS0=$GET(^IBE(363,IBRS,0))
+30 IF $EXTRACT(IBRSN,1,3)="TF-"
IF +$PIECE(IBRS0,U,6)
IF $PIECE(IBRS0,U,6)<3040107
SET IBFND=0
QUIT
+31 IF $EXTRACT(IBRSN,1,3)="CVA"
IF +$PIECE(IBRS0,U,6)
IF $PIECE(IBRS0,U,6)<3100101
SET IBFND=0
QUIT
+32 IF +$PIECE(IBRS0,U,6)
IF $PIECE(IBRS0,U,6)<IBVBEG
SET IBFND=0
QUIT
+33 IF +IBVEND
IF +$PIECE(IBRS0,U,5)
IF $PIECE(IBRS0,U,5)>IBVEND
SET IBFND=0
QUIT
+34 SET IBFND=1
IF $ORDER(^IBE(363,+IBRS,11,"B",+IBCSFN,0))
QUIT
+35 IF +IBAUTO
SET DIC("DR")=".02////"_1
+36 SET DLAYGO=363
SET DA(1)=+IBRS
SET DIC="^IBE(363,"_DA(1)_",11,"
SET DIC(0)="LX"
SET X=CSN
SET DIC("P")="363.0011P"
DO ^DIC
KILL DIC,DIE
End DoDot:2
if +IBFND
QUIT
End DoDot:1
+37 QUIT
+38 ;
+39 ;
+40 ;
GETDIV(RGFN) ; ask the user for the divisions for a Billing Region
+1 NEW IBX,DIC,DIE,DA,DR,X,Y,DIDEL,DLAYGO
if '$GET(RGFN)
QUIT
SET IBX=$GET(^IBE(363.31,+RGFN,0))
if IBX=""
QUIT
+2 WRITE !!,"Enter the Divisions associated with these charges: ",$PIECE(IBX,U,1)
+3 SET (DLAYGO,DIDEL)=363.31
SET DIE="^IBE(363.31,"
SET DA=+RGFN
SET DR=11
DO ^DIE
KILL DIE,DR,X,Y,DIDEL,DLAYGO
+4 QUIT
+5 ;
RSBR(CSFN,AUTO,EFFDT) ; add the charge set to any Rate Schedule that already has charge sets of this Billing Rate assigned
+1 ; CSFN - IFN of Charge Set to add, AUTO - 1 if charges should be auto added, EFFDT - effective date of charges
+2 ; will add the Charge Set to any Rate Schedule that already has a Set of same Billing Rate and is not inactive
+3 NEW IBCS0,IBCSN,IBBRFN,IBRS,IBRSIA,IBCSE,IBNEW,IBFND,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
SET DLAYGO=363
SET IBNEW=0
+4 ;
+5 SET CSFN=+$GET(CSFN)
IF 'CSFN
QUIT
+6 IF $GET(^IBE(363.1,CSFN,0))=""
QUIT
+7 ; charge set already assigned to rate schedules
IF +$ORDER(^IBE(363,"C",CSFN,0))
QUIT
+8 ;
+9 SET IBCS0=$GET(^IBE(363.1,CSFN,0))
SET IBCSN=$PIECE(IBCS0,U,1)
SET IBBRFN=$PIECE(IBCS0,U,2)
if 'IBBRFN
QUIT
+10 ;
+11 SET IBRS=0
FOR
SET IBRS=$ORDER(^IBE(363,IBRS))
if 'IBRS
QUIT
SET IBFND=0
Begin DoDot:1
+12 ; charge set already assigned to RS
IF $ORDER(^IBE(363,IBRS,11,"B",CSFN,0))
QUIT
+13 ; RS inactive before CS active
IF +$GET(EFFDT)
SET IBRSIA=$PIECE($GET(^IBE(363,IBRS,0)),U,6)
IF +IBRSIA
IF EFFDT>IBRSIA
QUIT
+14 ;
+15 SET IBCSE=0
FOR
SET IBCSE=$ORDER(^IBE(363,IBRS,11,"B",IBCSE))
if 'IBCSE
QUIT
Begin DoDot:2
+16 ; schedule has charge sets of same billing rate
IF $DATA(^IBE(363.1,"C",IBBRFN,IBCSE))
Begin DoDot:3
+17 ;
+18 IF +$GET(AUTO)
SET DIC("DR")=".02////"_1
+19 SET DA(1)=+IBRS
SET DIC="^IBE(363,"_DA(1)_",11,"
SET DIC(0)="LX"
SET X=IBCSN
SET DIC("P")="363.0011P"
DO ^DIC
KILL DIC,DIE
+20 WRITE !," Charge Set added to Rate Schedule ",$PIECE($GET(^IBE(363,+IBRS,0)),U,1)
End DoDot:3
SET IBFND=1
SET IBNEW=1
End DoDot:2
if IBFND
QUIT
End DoDot:1
+21 ;
+22 IF 'IBNEW
WRITE !," *** Warning: ",IBCSN," not added to any Rate Schedule,",!," set manually using Enter/Edit Charge Master option."
+23 QUIT
