165 lines
8.3 KiB
Mathematica
165 lines
8.3 KiB
Mathematica
|
IBCRHU2 ;ALB/ARH - RATES: UPLOAD UTILITIES (ADD CM ELEMENTS) ; 10-OCT-1998
|
||
|
|
;;2.0;INTEGRATED BILLING;**106,138,245,175,307**;21-MAR-94
|
||
|
|
;;Per VHA Directive 10-93-142, 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"
|
||
|
|
. I CSN["SNF " S IBRSLST="RI-SNF,NF-SNF,WC-SNF,TF-SNF"
|
||
|
|
. I CSN["OPT " S IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT"
|
||
|
|
. I CSN[" FS " S IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-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 +$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
|