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

IBCREE2.m

Go to the documentation of this file. 
  1. IBCREE2 ;ALB/ARH - RATES: CM ENTER/EDIT (SG,RL,PD,DV) ; 10-OCT-1998
  1.  ;;2.0;INTEGRATED BILLING;**106,138,148**;21-MAR-94
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. EDITSG ; enter/edit special groups (363.32)
  1.  N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBSGFN
  1.  W !!,"Enter/Edit a Special Group: ",!
  1.  ;
  1.  S DINUM=$O(^IBE(363.32,"A"),-1),DINUM=$S(DINUM<1000:1001,1:DINUM+1) I 'DINUM!($D(^IBE(363.32,DINUM,0))) Q
  1.  S DLAYGO=363.32,DIC="^IBE(363.32,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
  1.  ;
  1.  S IBSGFN=+Y
  1.  ;
  1.  S DR=".01;.02;11",DIE("NO^")="BACK"
  1.  ;
  1.  S IBX=$$CHKSG^IBCREU1(+Y) I +IBX S DR="11" W ! D  W !!
  1.  . I +$P(IBX,U,2) W !,"This was exported Nationally, only the assigned Billing Rates may be edited."
  1.  . I +$P(IBX,U,3) W !,"This group has associated Revenue Code Links, can not edit Type."
  1.  . I +$P(IBX,U,4) W !,"This group has associated Provider Discount Links, can not edit Type."
  1.  . I '$P(IBX,U,2) S DR=".01;"_DR
  1.  ;
  1.  S DIDEL=363.32,DIE="^IBE(363.32,",DA=+IBSGFN D ^DIE K DIE,DA,DR,X,Y,DIDEL
  1.  Q
  1.  ;
  1. EDITRL ; enter/edit revenue code links (363.33)
  1.  N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBRLFN
  1.  W !!,"Enter/Edit a Revenue Code Link: " I +$G(IBSGFN) W " (for "_$P(IBSGFN,U,2)_" group)",!
  1.  ;
  1.  I '$G(IBSGFN) N IBSGFN S IBSGFN=$$GETSG^IBCRU1(1) Q:IBSGFN'>0  W !!
  1.  ;
  1.  I IBSGFN<1000 W !,"This is a Nationally exported set of revenue code links.",!,"This should be modified only if the revenue code links added or changed",!,"fit the specific group definition: ",$P(IBSGFN,U,2),".",!!
  1.  ;
  1.  S DIC("S")="I $P(^(0),U,2)="_+IBSGFN,DIC("DR")=".02////"_+IBSGFN,DIC("A")="Select REVENUE CODE: "
  1.  S DLAYGO=363.33,DIC="^IBE(363.33,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
  1.  ;
  1.  S IBRLFN=+Y
  1.  ;
  1.  S DR=".01;.03;.04"
  1.  S DIDEL=363.33,DIE="^IBE(363.33,",DA=+IBRLFN D ^DIE K DIE,DA,DR,X,Y,DIDEL
  1.  ;
  1.  S IBX=$G(^IBE(363.33,+IBRLFN,0)) S IBCPT=$P(IBX,U,3) ; reset cpt being displayed
  1.  Q
  1.  ;
  1. EDITPD ; enter/edit provider discount (363.34)
  1.  N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBPDFN
  1.  W !!,"Enter/Edit Provider Discount: " I +$G(IBSGFN) W " (for "_$P(IBSGFN,U,2)_" group)",!
  1.  ;
  1.  I '$G(IBSGFN) S IBSGFN=$$GETSG^IBCRU1(2) Q:IBSGFN'>0
  1.  ;
  1.  I IBSGFN<1000 W !!,"This is a Nationally exported set of Provider Discounts.",!,"This should be modified only if the provider discount added or changed",!,"fits the specific group definition: ",$P(IBSGFN,U,2),".",!!
  1.  ;
  1.  S DIC("S")="I $P(^(0),U,2)="_+IBSGFN,DIC("DR")=".02////"_+IBSGFN
  1.  S DLAYGO=363.34,DIC="^IBE(363.34,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
  1.  ;
  1.  S IBPDFN=+Y I $D(IBPDFNX) S IBPDFNX=+Y
  1.  ;
  1.  S DR=".01;.03;11"
  1.  S DIDEL=363.34,DIE="^IBE(363.34,",DA=+IBPDFN D ^DIE K DIE,DA,DR,X,Y,DIDEL
  1.  Q
  1.  ;
  1. RESETDV(NAME) ; Reset Division numbers in both Charge Sets and Billing Regions (input CS or RG name)
  1.  ; not all division numbers were known when the Reasonable Charges files were released,
  1.  ; if the division number was not known then nnnXn or 9nnnn was used as a place holder in CS and RG names
  1.  ; this option allows the user to change these fake division numbers to the correct division number, when known
  1.  ;
  1.  N IBDIV,IBNDIV,IBFN,IBNM,IBNEW,IBI,IBX,DIC,DIE,DIR,DA,DR,DIRUT,DUOUT,DTOUT,X,Y,IBNDIVN,IBCT,IBST S IBNEW=""
  1.  Q:$G(NAME)=""  I $E(NAME,1,3)'="RC ",$E(NAME,1,3)'="RC-" Q
  1.  ;
  1.  S IBDIV="" F IBI=1:1 S IBX=$P(NAME," ",IBI) Q:IBX=""  I (IBX?3N1"X"1.3N)!(IBX>899.9) S IBDIV=IBX Q
  1.  I IBDIV=""!(IBDIV=999) Q
  1.  ;
  1.  W !!,">>> "_IBDIV," is an invalid site number.",!
  1.  S DIR("?")=IBDIV_" is not a valid site number, if you know the correct number for this division you may change it now for all Billing Region and Charge Set names."
  1. RESET1 S DIR(0)="FO^3:7^I X'?3N,X'?3N1.4UN,'$O(^DG(40.8,""C"",X,0)) K X",DIR("A")="Enter the correct Division number for this site if available" D ^DIR Q:$D(DIRUT)  I Y="" Q
  1.  ;
  1.  S IBNDIV=Y,IBNDIVN=$O(^DG(40.8,"C",IBNDIV,0))
  1.  I 'IBNDIVN W !!,?5,IBNDIV," is not a valid Medical Center division on your system.",!!
  1.  ;
  1.  S IBI="RC "_IBNDIV,IBX=$O(^IBE(363.31,"B",IBI)) I IBI=$P(IBX," ",1,2) W !!,IBX," already exists.",! G RESET1
  1.  S IBI="RC-PHYSICIAN "_IBNDIV,IBX=$O(^IBE(363.1,"B",IBI,0)) I +IBX W !!,IBI," already exists.",! G RESET1
  1.  ;
  1.  S DIR(0)="YO",DIR("A")="Replace "_IBDIV_" with "_IBNDIV D ^DIR K DIR Q:$D(DIRUT)  I Y'=1 Q
  1.  ;
  1.  ; change Billing Region Names
  1.  S IBFN=0 F  S IBFN=$O(^IBE(363.31,IBFN)) Q:'IBFN  D
  1.  . S IBNM=$P($G(^IBE(363.31,IBFN,0)),U,1) I IBNM'[IBDIV Q
  1.  . I ($E(IBNM,1,3)'="RC ")!($P(IBNM," ",2)'=IBDIV) Q
  1.  . ;
  1.  . S IBNEW=$P(IBNM,IBDIV,1)_IBNDIV_$P(IBNM,IBDIV,2)
  1.  . ;
  1.  . S DIE="^IBE(363.31,",DA=+IBFN,DR=".01///"_$E(IBNEW,1,30) D ^DIE K DIE,DR,X,Y
  1.  . ;
  1.  . ; check location of Billing Region, allow it to be updated if it does not appear to be standard
  1.  . I $P($P(IBNEW," - ",2),", ",2)'?2U D
  1.  .. W !!,">>> New Billing Region Name: ",IBNEW
  1.  .. W !,">>> The Billing Region location is not in the standard 'CITY, ST' format."
  1.  .. W !,">>> If you know the correct City, State for this division you may change it now.",!
  1.  .. S DIR(0)="PO^5:AEQMZ",DIR("A")="Enter the STATE where the Division is located"
  1.  .. D ^DIR Q:$D(DIRUT)  S IBST=$P(Y(0),U,2)
  1.  .. S DIR(0)="FO^1:"_(30-$L($P(IBNEW," - ",1))-7),DIR("A")="Enter the CITY where the Division is located"
  1.  .. D ^DIR Q:$D(DIRUT)  S IBCT=$$UP^XLFSTR(Y)
  1.  .. S IBNEW=$P(IBNEW," - ",1)_" - "_IBCT_", "_IBST W !!,IBNM," replaced with ",IBNEW
  1.  .. S DIE="^IBE(363.31,",DA=+IBFN,DR=".01///"_$E(IBNEW,1,30) D ^DIE K DIE,DR,X,Y
  1.  . ;
  1.  . ; add division to Billing Region, if not already there
  1.  . I +IBNDIVN,'$O(^IBE(363.31,+IBFN,11,"B",IBNDIVN,0)) D
  1.  .. S DLAYGO=363.31,DA(1)=+IBFN,DIC="^IBE(363.31,"_DA(1)_",11,",DIC(0)="L",X=+IBNDIVN,DIC("P")="363.3111P" D ^DIC K DIC,DIE,DLAYGO
  1.  ;
  1.  ; change Charge Set Names
  1.  S IBFN=0 F  S IBFN=$O(^IBE(363.1,IBFN)) Q:'IBFN  Q:IBFN'<1000  D
  1.  . S IBNM=$P($G(^IBE(363.1,IBFN,0)),U,1) I IBNM'[IBDIV Q
  1.  . I ($E(IBNM,1,3)'="RC-")!($E(IBNM,($L(IBNM)-$L(IBDIV)+1),999)'=IBDIV) Q
  1.  . ;
  1.  . S IBNEW=$P(IBNM,IBDIV,1)_IBNDIV_$P(IBNM,IBDIV,2)
  1.  . ;
  1.  . S DIE="^IBE(363.1,",DA=+IBFN,DR=".01///"_$E(IBNEW,1,30) D ^DIE K DIE,DR,X,Y
  1.  ;
  1.  W " ... Done.",!
  1.  Q