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

IBCREE.m

Go to the documentation of this file. 
  1. IBCREE ;ALB/ARH - RATES: CM ENTER/EDIT ;16-MAY-1996
  1.  ;;2.0;INTEGRATED BILLING;**52,106,115,223,474**;21-MAR-94;Build 29
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. EDITRT ; ACTION enter/edit rate types (399.3)
  1.  N DIC,DIE,DA,DR,X,Y,IBRTFN
  1.  W !!,"CAUTION:  This is a standard file with entries released nationally, do not add or"
  1.  W !,"          modify unless necessary.  Changing the Name or AR Category or if it is"
  1.  W !,"          a Third Party rate type will effect processing of claims."
  1.  W !!,"Enter/Edit a Rate Type:"
  1.  ;
  1.  S DIC="^DGCR(399.3,",DIC(0)="AELNQ" D ^DIC K DIC I Y<1 K X,Y Q
  1.  ;
  1.  S IBRTFN=+Y I $D(IBRTFNX) S IBRTFNX=+Y
  1.  ;
  1.  S DIE="^DGCR(399.3,",DA=+IBRTFN,DR=".01;.02;.04;.05;.08;.09;.03;.06" D ^DIE K DIE,DA,DR,X,Y
  1.  Q
  1.  ;
  1. EDITRS ; ACTION enter/edit rate schedules (363)
  1.  N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBRSFN
  1.  W !!,"The Rate Schedule Adjustment is an M code field, it therefore requires"
  1.  W !,"programmer access to enter or edit (using Charge Master IRM Enter/Edit"
  1.  W !,"[IBCR CHARGE MASTER IRM] option. Contact IRM if this field needs to be modified."
  1.  W !!,"Enter/Edit a Rate Schedule:"
  1.  ;
  1.  S DINUM=$O(^IBE(363,"A"),-1),DINUM=$S(DINUM<1000:1001,1:DINUM+1) I 'DINUM!($D(^IBE(363,DINUM,0))) Q
  1.  S DLAYGO=363,DIC="^IBE(363,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
  1.  ;
  1.  S IBRSFN=+Y I $D(IBRSFNX) S IBRSFNX=+Y
  1.  ;
  1.  S DIE("NO^")="BACK"
  1.  S DIDEL=363,DIE="^IBE(363,",DA=+IBRSFN,DR=".01;.02;.03;.04;.05;.06;11" D ^DIE K DIE,DA,DR,X,Y,DIDEL
  1.  Q
  1.  ;
  1. EDITRSA ; OPTION enter/edit Rate Schedule Adjustment field (363,10) if DUZ="@"
  1.  N IBRS10,IBRS10A,IBRS10B,DIR,DIC,DIE,DA,DR,X,Y,IBRSFN
  1.  I DUZ(0)'="@" W !,"This option requires programmer access (DUZ(0)=@).",! G ERSA1Q
  1.  ;
  1.  S DIC="^IBE(363,",DIC(0)="AENQ" D ^DIC K DIC S IBRSFN=+Y I Y<1 K X,Y Q
  1.  S IBRS10B=$G(^IBE(363,+IBRSFN,10))
  1.  ;
  1. ERSA1 W !
  1.  S IBRS10=$G(^IBE(363,+IBRSFN,10))
  1.  I IBRS10="" W !,?7,"The base unit charges are not currently Adjusted.",!
  1.  I IBRS10'="" S X=100 X IBRS10 W !,?7,"If the base unit charge is $100,",!,?7,"this Adjustment will result in a charge of: $",$J(X,10,2),!!
  1.  S DIE="^IBE(363,",DA=+IBRSFN,DR="10" D ^DIE K DIE,DA,DR,X,Y
  1.  S IBRS10A=$G(^IBE(363,+IBRSFN,10))
  1.  I IBRS10A=IBRS10 W "  ... no change"
  1.  I IBRS10A="" W !!,?7,"The base unit charges will not be modified."
  1.  S X=100 X IBRS10A W !!,?7,"If the base unit charge is $100,",!,?7,"this Adjustment will result in a charge of: $",$J(X,10,2),!
  1.  S DIR("?")="If the correct Adjustment has been entered, answer Yes to this question. If the Adjustment has been entered incorrectly, answer No, and then enter the correct value."
  1.  S DIR("?")=DIR("?")_" To exit the option without saving changes to the original Adjustment, enter '^'."
  1.  S DIR("?",1)="Enter 'Y' or 'N' or '^' to exit the option.",DIR("?",2)=" "
  1.  S DIR("?",3)="The Adjustment has an immediate effect on the charges for this rate."
  1.  ;
  1.  W !,"Please note: using '^' to exit the option will not change the adjustment."
  1.  S DIR(0)="Y",DIR("A")="Is this correct" D ^DIR K DIR
  1.  ; restore the original adjustment or remove the change (#10)
  1.  I $D(DIRUT) D  G ERSA1Q
  1.  . I IBRS10B'="" S DIE="^IBE(363,",DA=+IBRSFN,DR="10///"_IBRS10B D ^DIE K DIE,DA,DR,X,Y Q
  1.  . S DA(1)=+IBRSFN,DIK="^IBE(363,"_DA(1)_",",DA=10 D ^DIK K DIK,DA
  1.  G:'Y ERSA1
  1.  ;
  1.  I $P($G(^DGCR(399.1,+$P(^IBE(363,+IBRSFN,0),"^",4),0)),"^")="PRESCRIPTION",IBRS10A["+" D
  1.  . W !,"The adjustment you entered may have included a dispensing fee or administrative"
  1.  . W !,"fee.  If that is the case, please record the amount of the respective fee(s)"
  1.  . W !,"used in the adjustment calculation above."
  1.  . S DIE="^IBE(363,",DA=+IBRSFN,DR="1.01;1.02" D ^DIE
  1.  ;
  1. ERSA1Q Q
  1.  ;
  1. EDITRG ; enter/edit billing regions (363.31)
  1.  N DIC,DIE,DA,DR,X,Y,DLAYGO,IBRGFN,IBI
  1.  W !!,"Enter/Edit a Rate's Billing Regions:"
  1.  ;
  1.  S DLAYGO=363.31,DIC="^IBE(363.31,",DIC(0)="AELNQ" D ^DIC K DIC,DLAYGO I Y<1 K X,Y Q
  1.  ;
  1.  S IBRGFN=+Y D RESETDV^IBCREE2($P(Y,U,2))
  1.  ;
  1.  ; dr to only allow divisions or institutions not both
  1.  S DIDEL=363.31,DIE="^IBE(363.31,",DA=+IBRGFN,DR=".01;"_$S($O(^IBE(363.31,DA,21,0)):"",1:"11;S:$O(^IBE(363.31,DA,11,0)) Y=0;")_"21" D ^DIE K DIE,DR,X,Y,DIDEL
  1.  ;
  1.  I '$D(DA),+IBRGFN S IBI=0 F  S IBI=$O(^IBE(363.1,IBI)) Q:'IBI  D  ; remove deleted regions from charge sets
  1.  . I +$P($G(^IBE(363.1,IBI,0)),U,7)=+IBRGFN S DIE="^IBE(363.1,",DA=+IBI,DR=".07///@" D ^DIE K DIE,DA,DR,X,Y
  1.  Q
  1.  ;
  1. EDITBR ; enter/edit billing rates (363.3)
  1.  N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBBRFN
  1.  W !!,"Enter/Edit a Billing Rate: "
  1.  ;
  1.  S DINUM=$O(^IBE(363.3,"A"),-1),DINUM=$S(DINUM<1000:1001,1:DINUM+1) I 'DINUM!($D(^IBE(363.3,DINUM,0))) Q
  1.  S DLAYGO=363.3,DIC="^IBE(363.3,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
  1.  ;
  1.  S IBBRFN=+Y
  1.  ;
  1.  S DIE("NO^")="BACK"
  1.  S DR=".01;.02;.03////2;.05;I X=2 S Y=""@6"";.04;@6" ; VA Cost sets should not have a billable item
  1.  ;
  1.  S IBX=$$CHKBR^IBCREU1(+Y) I +IBX S DR=".02" D  W !!
  1.  . W !!,"Only the Abbreviation may be edited, the Billing Rate Definition can not change:"
  1.  . I +$P(IBX,U,2) W !,"     -  this Billing Rate definition was exported Nationally"
  1.  . I +$P(IBX,U,3) W !,"     -  there are Charge Sets defined for this Billing Rate"
  1.  . I +$P(IBX,U,4) W !,"     -  there are Charge Items defined for a Charge Set with this Billing Rate"
  1.  I '$P(IBX,U,3) W !,"This Billing Rate does not have any Charge Sets assigned.",!
  1.  ;
  1.  S DIDEL=363.3,DIE="^IBE(363.3,",DA=+IBBRFN D ^DIE K DIE,DA,DR,X,Y,DIDEL
  1.  Q
  1.  ;
  1. EDITCS ; enter/edit Charge Sets (363.1)
  1.  N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBCSFN
  1.  W !!,"Enter/Edit a Charge Set:"
  1.  ;
  1.  S DINUM=$O(^IBE(363.1,"A"),-1),DINUM=$S(DINUM<1000:1001,1:DINUM+1) I 'DINUM!($D(^IBE(363.1,DINUM,0))) Q
  1.  S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
  1.  ;
  1.  S IBCSFN=+Y I $D(IBCSFNX) S IBCSFNX=+Y
  1.  I IBCSFN<1000 D RESETDV^IBCREE2($P(Y,U,2))
  1.  ;
  1.  S DR=".01;.02;.03;.04;.05;.06;.07"
  1.  S IBX=$$CHKCS^IBCREU1(+Y) I +IBX S DR=".04;.05;.06;.07" D  W !!
  1.  . W !!,"Not all elements of this Charge Set may be edited:"
  1.  . I +$P(IBX,U,3) D  Q
  1.  .. W !,"     -  the Set name, Rate, and Billable Event may not be modified since this",!,"        Charge Set definition was exported nationally."
  1.  . I +$P(IBX,U,2) D  S DR=".01;.03;"_DR
  1.  .. W !,"     -  the Billing Rate may not change since the Charge Set has Charge Items."
  1.  ;
  1.  ;
  1. REDTCS S DIDEL=363.1,DIE="^IBE(363.1,",DA=+IBCSFN D ^DIE K DIE,DR,X,DIDEL
  1.  ;
  1.  I $D(DA),$D(Y)=0 S IBX=$$RQCS^IBCREU1(IBCSFN) I +IBX S DR="" W ! D  G REDTCS
  1.  . I $P(IBX,U,2)=1 W !,"The Charge Set requires a Billing Rate.",! S DR=DR_".02;"
  1.  . I $P(IBX,U,3)=1 W !,"The Charge Set requires a Billable Event.",! S DR=DR_".03;"
  1.  . I $P(IBX,U,5) D  S DR=DR_".05;"
  1.  .. W !,"This Charge Set requires a default Revenue Code:"
  1.  .. W !,"     - A VA Cost Charge Set requires a default Rev Code since there are no"
  1.  .. W !,"       Items to assign the rev code to",!
  1.  . I $P(IBX,U,4) D  S DR=DR_".06;"
  1.  .. W !,"This Charge Set requires a default bedsection:"
  1.  .. W !,"     - a bedsection is required before a charge can be added to a bill"
  1.  .. W !,"       therefore a default bedsection is required for every Charge Set whose"
  1.  .. W !,"       charge item is not bedsection",!
  1.  ;
  1.  Q
  1.  ;
  1. EDITBI ; enter/edit billing items - NDC #, MISC (363.21)
  1.  N DIC,DIE,DIR,DA,DR,X,Y,DLAYGO,IBX,IBBIN,IBTYPE
  1.  W !!,"These are items that are billable but not found in other DHCP source files."
  1.  W !,"Items entered that already exist and have no associated charge, can be deleted.",!
  1.  ;
  1.  S DIR(0)="363.21,.02A",DIR("A")="Enter which type of Billable Item? " D ^DIR K DIR I Y<1 Q
  1.  S IBTYPE=+Y_U_Y(0)
  1.  ;
  1. EBI1 W !
  1.  ;
  1.  S DLAYGO=363.21,DIC="^IBA(363.21,",DIC(0)="AELQ",DIC("A")=$P(IBTYPE,U,2)_" Item: ",DIC("DR")=".02////"_+IBTYPE
  1.  S DIC("S")="I $P(^(0),U,2)="_+IBTYPE D ^DIC K DIC,DIE,DA,DR,DLAYGO I Y<1 K X,Y Q
  1.  S IBBIN=Y
  1.  ;
  1.  I +IBTYPE=1,+$P(IBBIN,U,3),$P(IBBIN,U,2)'?1N.N1"-"1N.N1"-"1N.N D  G EBI1
  1.  . I $$DELBI(+IBBIN) W !," ... not added, invalid format (n-n-n)"
  1.  ;
  1.  I +$P(IBBIN,U,3) W " ... added" G EBI1
  1.  ;
  1.  I '$P(IBBIN,U,3) W " ... already exists" D  G EBI1
  1.  . S IBX=+IBBIN_";IBA(363.21," I $O(^IBA(363.2,"B",IBX,0)) W " => can not delete, has Charge Items" Q
  1.  . S DIR(0)="Y",DIR("A")="      DELETE "_$P(IBTYPE,U,2)_" - "_$P(IBBIN,U,2) D ^DIR K DIR I Y'=1 W ?50," ... no change" Q
  1.  . I Y=1 I $$DELBI(+IBBIN) W ?50," ... deleted"
  1.  G EBI1
  1.  Q
  1. DELBI(DA) ;
  1.  N IBX,DIK S IBX=0 I $D(^IBA(363.21,+$G(DA),0)) S DIK="^IBA(363.21," D ^DIK K DA,DIK S IBX=1
  1.  Q IBX