Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCRHU2

IBCRHU2.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. 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
  1.  ; the part of the name before a dash is used to attempt a match with existing regions
  1.  N IBA,IBDV,IBFN,IBNEW,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S DIV=$G(DIV),IBDV="",(IBFN,IBNEW)=0
  1.  I $G(NAME)="" G RGQ
  1.  I NAME[" (DIV)" S NAME=$P(NAME," (DIV)",1)_$P(NAME," (DIV)",2)
  1.  I NAME[" (2)" S NAME=$P(NAME," (2)",1)_$P(NAME," (2)",2)
  1.  I NAME[" (3)" S NAME=$P(NAME," (2)",1)_$P(NAME," (3)",2)
  1.  ;
  1.  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
  1.  I +IBFN S IBFN=IBFN_U_$E(IBX,1,30),IBNEW=0 G RGQ
  1.  ;
  1.  S IBDV=$$DIV(DIV) I 'IBDV D MSG("     *** Warning: No MC division "_DIV_" defined, no division added to Region")
  1.  ;
  1.  I $G(ID)'="" S DIC("DR")=".02////"_$E(ID,1,10)_";"
  1.  I $G(TY)'="" S DIC("DR")=$G(DIC("DR"))_".03////"_$E(TY,1,10)
  1.  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
  1.  S IBFN=Y,IBNEW=1
  1.  ;
  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
  1.  ;
  1. 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
  1.  Q $G(IBFN)
  1.  ;
  1. 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
  1.  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
  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
  1.  ;
  1.  S IBFND=+$O(^IBE(363.1,"B",$E(NAME,1,30),0)) I +IBFND S IBFN=IBFND,IBCSN=NAME G CSQ
  1.  ;
  1.  S IBBR=$O(^IBE(363.3,"B",RATE,0)) I 'IBBR S IBOK=0 D MSG("     *** Error: "_RATE_" Billing Rate does not exist")
  1.  S IBBE=$$MCCRUTL(EVENT,14) I 'IBBE S IBOK=0 D MSG("     *** Error: "_EVENT_" Billable Event undefined")
  1.  S IBRG="" I RG'="" S IBRG=$O(^IBE(363.31,"B",$E(RG,1,30),0))
  1.  I 'IBRG,RG'="" S IBOK=0 D MSG("     *** Error: "_$E(RG,1,30)_" Billing Region does not exist")
  1.  I '$G(IBOK) G CSQ
  1.  S IBRV=$$RVCD(RV) I 'IBRV D MSG("     *** Warning: No default revenue code added for Charge Set")
  1.  S IBBS=$$MCCRUTL(BS,5) I 'IBBS D MSG("     *** Warning: No default bedsection added for Charge Set")
  1.  S IBCT=$S($E(CT)="I":1,$E(CT)="P":2,1:"")
  1.  ;
  1.  F IBJ=1:1 S IBFN=$G(^IBE(363.1,IBJ,0)) I IBFN="" S DINUM=IBJ Q
  1.  ;
  1.  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
  1.  S IBFN=+Y,IBCSN=$P(Y,U,2)
  1.  ;
  1.  S DR=".02////"_IBBR_";.03////"_IBBE_";.04////"_IBCT_";.07////"_IBRG
  1.  I +IBRV S DR=DR_";.05////"_IBRV
  1.  I +IBBS S DR=DR_";.06////"_IBBS
  1.  S DIE="^IBE(363.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
  1.  ;
  1.  ;
  1. CSQ I +$G(IBFN),$G(IBCSN)'="" D RS(IBCSN)
  1.  ;
  1.  S IBA(1)="  >> "_$E(NAME,1,30)_" Charge Set "_$S('$G(IBFN):"NOT ",1:"")_$S(+$G(IBFND):"used",1:"added") D MSGP
  1.  Q +$G(IBFN)
  1.  ;
  1. USECS(CSN) ; return an existing CS for a set of RC charges, given the name to look for, or write an error message
  1.  N IBCS S IBCS=0
  1.  I $G(CSN)'="" S IBCS=$O(^IBE(363.1,"B",$E(CSN,1,30),0))
  1.  I 'IBCS W !,"     *** Warning:  No Charge Set found for these charges"
  1.  I +IBCS W !,"  >> "_$E(CSN,1,30)_" Charge Set used"
  1.  Q IBCS
  1.  ;
  1. MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
  1.  N IBX,IBY S IBY=""
  1.  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
  1.  Q IBY
  1.  ;
  1. 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
  1.  N IBX,IBY S IBY=""
  1.  I +$G(RVCD) S IBX=$G(^DGCR(399.2,+RVCD,0)) I +$P(IBX,U,3) S IBY=+RVCD
  1.  Q IBY
  1.  ;
  1. 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
  1.  N IBX,IBY S IBX=0
  1.  I $G(DIV)'="" S DIV=+$O(^DG(40.8,"C",DIV,0))
  1.  I +$G(DIV) S IBY=$G(^DG(40.8,+DIV,0)) I IBY'="" S IBX=DIV_U_$P(IBY,U,1,2)
  1.  Q IBX
  1.  ;
  1. MSG(X) ; add message to end of message list, reserves IBA(1) for primary message
  1.  N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
  1.  S IBA(IBX)=$G(X)
  1.  Q
  1. MSGP ; print error messages in IBA
  1.  N IBX S IBX="" F  S IBX=$O(IBA(IBX)) Q:'IBX  W !,IBA(IBX)
  1.  Q
  1.  ;
  1.  ;
  1. 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
  1.  ; for RC 1.x only adds physician to inpt if there was also inpatient facility charges
  1.  ; Tort Feasor began using Reasonable Charges on 01/07/04
  1.  N IBCSFN,IBRSN,IBRS,IBRS0,IBRSLST,IBVBEG,IBVEND,IBVERS,IBAUTO,IBFND,IBSITE,IBI,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
  1.  ;
  1.  I $G(CSN)="" Q
  1.  I $E(CSN,1,2)'="RC" Q
  1.  S IBCSFN=$O(^IBE(363.1,"B",$E(CSN,1,30),0)) I 'IBCSFN Q
  1.  S IBAUTO=1 I $P($G(^IBE(363.3,+$P($G(^IBE(363.1,+IBCSFN,0)),U,2),0)),U,4)=9 S IBAUTO=""
  1.  S IBVERS=$$VERSION^IBCRHBRV,IBVBEG=$$VERSDT^IBCRHBRV,IBVEND=$$VERSEDT^IBCRHBRV,IBFND=1
  1.  S IBI=$L(CSN," "),IBSITE=$P(CSN," ",IBI)
  1.  ;
  1.  I IBVERS<2 D
  1.  . I CSN["INPT " S IBRSLST="RI-INPT,NF-INPT,WC-INPT"
  1.  . I CSN["SNF " S IBRSLST="RI-INPT,NF-INPT,WC-INPT"
  1.  . I CSN["OPT " S IBRSLST="RI-OPT,NF-OPT,WC-OPT"
  1.  . I CSN["PHYS" S IBRSLST="RI-OPT,NF-OPT,WC-OPT"
  1.  . I CSN["PHYS",$O(^IBE(363.1,"B","RC-INPT ANC "_IBSITE,0)) S IBRSLST=IBRSLST_",RI-INPT,NF-INPT,WC-INPT"
  1.  ;
  1.  I IBVERS'<2 D
  1.  . I CSN["INPT " S IBRSLST="RI-INPT,NF-INPT,WC-INPT,TF-INPT,CVA-INPT,CVA RI-INPT"
  1.  . I CSN["SNF " S IBRSLST="RI-SNF,NF-SNF,WC-SNF,TF-SNF,CVA-SNF,CVA RI-SNF"
  1.  . I CSN["OPT " S IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT,CVA-OPT,CVA RI-OPT"
  1.  . I CSN[" FS " S IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT,CVA-OPT,CVA RI-OPT"
  1.  I $G(IBRSLST)="" Q
  1.  ;
  1.  F IBI=1:1 S IBRSN=$P(IBRSLST,",",IBI) Q:IBRSN=""  D
  1.  . S IBRS=0 F  S IBRS=$O(^IBE(363,"B",IBRSN,IBRS)) Q:'IBRS  D  Q:+IBFND
  1.  .. S IBRS0=$G(^IBE(363,IBRS,0))
  1.  .. I $E(IBRSN,1,3)="TF-",+$P(IBRS0,U,6),$P(IBRS0,U,6)<3040107 S IBFND=0 Q
  1.  .. I $E(IBRSN,1,3)="CVA",+$P(IBRS0,U,6),$P(IBRS0,U,6)<3100101 S IBFND=0 Q
  1.  .. I +$P(IBRS0,U,6),$P(IBRS0,U,6)<IBVBEG S IBFND=0 Q
  1.  .. I +IBVEND,+$P(IBRS0,U,5),$P(IBRS0,U,5)>IBVEND S IBFND=0 Q
  1.  .. S IBFND=1 I $O(^IBE(363,+IBRS,11,"B",+IBCSFN,0)) Q
  1.  .. I +IBAUTO S DIC("DR")=".02////"_1
  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
  1.  Q
  1.  ;
  1.  ;
  1.  ;
  1. GETDIV(RGFN) ; ask the user for the divisions for a Billing Region
  1.  N IBX,DIC,DIE,DA,DR,X,Y,DIDEL,DLAYGO Q:'$G(RGFN)  S IBX=$G(^IBE(363.31,+RGFN,0)) Q:IBX=""
  1.  W !!,"Enter the Divisions associated with these charges: ",$P(IBX,U,1)
  1.  S (DLAYGO,DIDEL)=363.31,DIE="^IBE(363.31,",DA=+RGFN,DR=11 D ^DIE K DIE,DR,X,Y,DIDEL,DLAYGO
  1.  Q
  1.  ;
  1. 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
  1.  ; will add the Charge Set to any Rate Schedule that already has a Set of same Billing Rate and is not inactive
  1.  N IBCS0,IBCSN,IBBRFN,IBRS,IBRSIA,IBCSE,IBNEW,IBFND,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S DLAYGO=363,IBNEW=0
  1.  ;
  1.  S CSFN=+$G(CSFN) I 'CSFN Q
  1.  I $G(^IBE(363.1,CSFN,0))="" Q
  1.  I +$O(^IBE(363,"C",CSFN,0)) Q  ; charge set already assigned to rate schedules
  1.  ;
  1.  S IBCS0=$G(^IBE(363.1,CSFN,0)),IBCSN=$P(IBCS0,U,1),IBBRFN=$P(IBCS0,U,2) Q:'IBBRFN
  1.  ;
  1.  S IBRS=0 F  S IBRS=$O(^IBE(363,IBRS)) Q:'IBRS  S IBFND=0 D
  1.  . I $O(^IBE(363,IBRS,11,"B",CSFN,0)) Q  ; charge set already assigned to RS
  1.  . I +$G(EFFDT) S IBRSIA=$P($G(^IBE(363,IBRS,0)),U,6) I +IBRSIA,EFFDT>IBRSIA Q  ; RS inactive before CS active
  1.  . ;
  1.  . S IBCSE=0 F  S IBCSE=$O(^IBE(363,IBRS,11,"B",IBCSE)) Q:'IBCSE  D  Q:IBFND
  1.  .. I $D(^IBE(363.1,"C",IBBRFN,IBCSE)) D  S IBFND=1,IBNEW=1 ; schedule has charge sets of same billing rate
  1.  ... ;
  1.  ... I +$G(AUTO) S DIC("DR")=".02////"_1
  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
  1.  ... W !,"     Charge Set added to Rate Schedule ",$P($G(^IBE(363,+IBRS,0)),U,1)
  1.  ;
  1.  I 'IBNEW W !,"     *** Warning: ",IBCSN," not added to any Rate Schedule,",!,"         set manually using Enter/Edit Charge Master option."
  1.  Q