IBCRHRS.m

IBCRHRS ;ALB/ARH - RATES: UPLOAD (RC) CHANGE SITE TYPE OPTION ; 25-JAN-13

 ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ;

 ; Option that allows the user to change a divisions Facility Charge Type

 ; only allows the currently released version to be changed

 ;

OPTION ; Option entry Change Reasonable Charge Facility Type

 N IBVERS,IBVERSDT,IBCMRG,IBHFRG,IBNWFT,IBNWDT,IBXRF1,IBDS,IBDONE S IBDONE=0 S IBDS="",$P(IBDS,"=",IOM+1)=""

 ;

 W !!,"Change Reasonable Charges Facility Type:",!

 W !,"This option allows the Facility Type of currently loaded Reasonable Charges"

 W !,"to be changed on a specified date.  A Non-Provider Based Freestanding site"

 W !,"with only Professional charges may be changed to a Provider Based site with"

 W !,"both Institutional and Professional charges.",!

 W !,"This option will complete the following steps:"

 W !,"1.  Uploads the current version of Reasonable Charges."

 W !,"2.  Request the Region/Division to change, the new type and effective date."

 W !,"3.  Calculate the charges for the Region with the new type and effective date."

 W !,"4.  Request confirmation then update the permanent files in the Charge Master:"

 W !,"    inactivate the currently loaded charges for the region, update the "

 W !,"    Region's Type, and load the new charges into the Charge Master.",!

 W !,"Only CBO can approve a Facility Type change for a division.  "

 W !,"Approval from CBO must be received before using this option to change charges.",!

 S DIR(0)="Y",DIR("A")="Approval Received to Change a Divisions Facility Type, Continue" D ^DIR K DIR,X I Y'=1 Q

 ;

 ;

 S IBVERS=+$$VERSTR^IBCRHBRV(1) I 'IBVERS G OPTIONQ ; get the current version

 S IBVERSDT=+$$VERSDT^IBCRHBRV(IBVERS) I 'IBVERSDT G OPTIONQ ; get effective date of current version

 ;

 W !,IBDS,!,"*** Set-Up process:",!

 ;

 D XTMPKL ; delete any existing upload files in XTMP

 I '$$XTMPHL(IBVERS) G OPTIONQ ; load current version load files into XTMP

 ;

 W !,IBDS,!,"*** Get specifications from user and check the change is valid",!

 ;

 S IBCMRG=$$ASKCMRG I 'IBCMRG G OPTIONQ ; get CM Billing Region from user (#363.31)

 S IBHFRG=$$GETHFRG(IBCMRG) I 'IBHFRG G OPTIONQ ; get HF Billing Region from Host Site File

 S IBNWFT=$$ASKNWFT(IBHFRG) I 'IBNWFT G OPTIONQ ; get the new Charge Type for the Billing Region

 S IBNWDT=$$ASKNWDT I 'IBNWDT G OPTIONQ ; get the effective date of the change from the user

 I '$$CHECK(IBVERS,IBVERSDT,IBNWDT,IBCMRG,IBHFRG,IBNWFT) G OPTIONQ

 ;

 W !,IBDS,!,"*** Calculate charges and update effective date based on user entry",!

 ;

 S $P(IBHFRG,U,5)=IBNWFT

 D CALCRC^IBCRHBS5(IBHFRG) ; calculate site charges with new type, create XTMP files

 I '$$XTMPDT(IBVERSDT,IBNWDT) G OPTIONQ ; update calculated charges dates in XTMP

 ;

 W !,IBDS,!,"*** Confirm Request to Update Charge Master",!

 ;

 I '$$ASKFNL(IBCMRG,IBNWDT,IBNWFT) G OPTIONQ ; get final confirmation for change from user

 ;

 W !,IBDS,!,"*** Complete Request - Update Charge Master",!

 ;

 I '$$CMINDT(IBCMRG,IBVERSDT,IBNWDT) G OPTIONQ ; inactivate existing charges in Charge Master

 S IBDONE=1

 D CMRGFT(IBCMRG,IBNWFT) ; update Facility Type in Charge Master

 D CMLOAD ; load the modifified charges into Charge Master

 ;

OPTIONQ ;

 D XTMPKL ; delete any existing upload files in XTMP

 ;

 I +IBDONE W !,IBDS,!,"*** Process Complete, Charge Master Charges Updated.",!

 I 'IBDONE W !,IBDS,!,"*** Process Ended, No Permanent Changes.",!

 Q

 ;

 ;

XTMPKL ; delete any existing RC Upload Files in XTMP

 N IBX

 W !,"Removing any existing temporary Upload files: ",!

 S IBX="IBCR RC" F  S IBX=$O(^XTMP(IBX)) Q:IBX'["IBCR RC"  K ^XTMP(IBX) W "."

 S IBX="IBCR UPLOAD RC" F  S IBX=$O(^XTMP(IBX)) Q:IBX'["IBCR UPLOAD RC"  K ^XTMP(IBX) W "."

 Q

 ;

XTMPHL(VERS) ; load version of RC Host Files IBCR RC into XTMP (IBCRHBS1)

 N IBPATH,IBFILES,IBFILE,IBNODE,IBOK S IBOK=0 I '$G(VERS) G XTMPHLQ

 ;

 W !!,"Upload National Reasonable Charges v"_VERS_" Host Files to temporary local files:",!

 S IBPATH=$$PATH^IBCRHBS1 I IBPATH<0 G XTMPHLQ ; get path/directory

 D FILES^IBCRHBRV(.IBFILES,VERS) ; get list of files to be loaded

 I '$$FNDHOST^IBCRHBS1(.IBFILES,IBPATH) G XTMPHLQ ; check host files are available/found

 ;

 W !,"Loading National Reasonable Charges v"_VERS_" Host Files into temporary local file:"

 S IBOK=1,IBFILE="" F  S IBFILE=$O(IBFILES(IBFILE)) Q:IBFILE=""  D  I 'IBOK Q

 . S IBNODE=IBFILES(IBFILE)

 . I $$LOAD^IBCRHBS2(IBPATH,IBFILE,$P(IBNODE,U,1),$P(IBNODE,U,2),VERS,$P(IBNODE,U,3)) Q

 . W !!,"   Error while processing host file, can not continue!",!! S IBOK=0

 I +IBOK W !!,"Upload of Reasonable Charges v"_VERS_" Host Files Complete.",!

 ;

XTMPHLQ Q IBOK

 ;

XTMPDT(VSDT,NWDT) ; update calculated charges IBCR UPLOAD effective date in XTMP, returns count changed

 N IBXRF1,IBSUB,IBX,IBLN,IBCNT S IBXRF1=0,IBCNT=0

 I ($G(VSDT)'?7N)!($G(NWDT)'?7N) G XTMPDTQ

 ;

 S IBSUB="IBCR UPLOAD RC" S IBXRF1=$O(^XTMP(IBSUB)) I IBXRF1'[IBSUB G XTMPDTQ

 ;

 W !!,"Changing Effective Date from ",$$FMTE^XLFDT(VSDT,2)," to ",$$FMTE^XLFDT(NWDT,2)," in Host Files."

 W !!,"Host Files ",IBXRF1,?55,"Count = ",$P($G(^XTMP(IBXRF1,0)),U,4),!

 ;

 ; loop through XTMP calculated charges and update the effective date

 S IBSUB="" F  S IBSUB=$O(^XTMP(IBXRF1,IBSUB)) Q:IBSUB=""  D

 . S IBX=0 F  S IBX=$O(^XTMP(IBXRF1,IBSUB,IBX)) Q:'IBX  D

 .. S IBLN=$G(^XTMP(IBXRF1,IBSUB,IBX))

 .. I +$P(IBLN,U,3),+$P(IBLN,U,3)<NWDT Q

 .. ;

 .. I $P(IBLN,U,2)=VSDT S $P(IBLN,U,2)=NWDT,^XTMP(IBXRF1,IBSUB,IBX)=IBLN S IBCNT=IBCNT+1

 . I +IBCNT W !,IBSUB,?25,IBCNT

 ;

XTMPDTQ I IBCNT'=$P($G(^XTMP(IBXRF1,0)),U,4) S IBCNT=0 W !!,"Error: All dates not changed, can not continue!",!

 Q IBCNT

 ;

 ;

CMINDT(CMRG,VSDT,NWDT) ; inactivate existing charges for selected Billing Region in Charge Master (#363.2)

 N IBCNT,IBINACT,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBCI,IBCI0,IBCHG,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0

 I ($G(VSDT)'?7N)!($G(NWDT)'?7N) G CMINDTQ

 I $G(^IBE(363.31,+$G(CMRG),0))'["RC " G CMINDTQ

 ;

 S IBINACT=$$FMADD^XLFDT(NWDT,-1)

 ;

 W !!,"Inactivating ",$P(CMRG,U,2)," existing charges on ",$$FMTE^XLFDT(IBINACT,2),":",!,"Please wait...",!

 ;

 S IBCS=0 F  S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS  D

 . S IBCS0=$G(^IBE(363.1,IBCS,0)) I $P(IBCS0,U,7)'=+CMRG Q

 . S IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)) I $E(IBBR0,1,3)'="RC " Q

 . ;

 . S IBXRF="AIVDTS"_IBCS,IBCHG=0

 . S IBITM=0 F  S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM  D

 .. S IBCI=0 F  S IBCI=$O(^IBA(363.2,IBXRF,IBITM,-VSDT,IBCI)) Q:'IBCI  D

 ... S IBCI0=$G(^IBA(363.2,IBCI,0))

 ... I +$P(IBCI0,U,4),IBINACT>+$P(IBCI0,U,4) Q

 ... ;

 ... S DR=".04///"_+IBINACT,DIE="^IBA(363.2,",DA=+IBCI D ^DIE K DIC,X,Y S IBCNT=IBCNT+1,IBCHG=1

 . I +IBCHG W !,$P(IBCS0,U,1),?35,IBCNT

 ;

CMINDTQ I 'IBCNT W !!,"Unable to Inactivate current charges, can not continue!",!

 Q IBCNT

 ;

CMRGFT(CMRG,NWFT) ; change the Billing Regions Facility Type in the Charge Master (#363.31,.03)

 N IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S NWFT=+$G(NWFT)

 S IBX=+$P($G(^IBE(363.31,+$G(CMRG),0)),U,3)

 W !!,"Changing Billing Regions Facility Type: "

 ;

 I +IBX,+NWFT,IBX'=NWFT S DR=".03///"_NWFT,DIE="^IBE(363.31,",DA=+CMRG D ^DIE

 ;

 W !,"Billing Region ",$P($G(CMRG),U,2)," changed from ",IBX," to ",NWFT

 Q

 ;

CMLOAD ; load charges into Charge Master

 ; queuing is not allowed to ensure the modified files are used and 

 ; process completes fully.

 ;

 N ADD W !!,"Load modified charges into Charge Master:",!

 ;

 ; get the device

 W !,"Report requires 120 columns.  Queuing not allowed to ensure process completes."

 S %ZIS="M",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS I POP QUIT

 ;

 S ADD=1 D RPT^IBCRHO

 Q

 ;

 ;

ASKCMRG() ; ask user for Billing Region (#363.31), return Billing Region ifn ^ name ^ div/site ^ id/zip ^ chg type

 N IBRG,IBDV,IBX,IBY,DIC,X,Y

 W !,"Enter the Division to change the Reasonable Charges Facility Type:",!

 S DIC("S")="I $E(^(0),1,3)=""RC """

 S DIC="^IBE(363.31,",DIC(0)="AEMNQZ",DIC("A")="Select DIVISION/REGION: " D ^DIC I Y<1 S Y=0

 I +Y S Y=Y_U_$P(Y(0)," ",2)_U_$P(Y(0),U,2,3)

 ;

 I +Y D

 . W !!,"Billing Region: ",$P(Y,U,2),?50,"3-Zip: ",$P(Y,U,4),?65,"Type: ",$P(Y,U,5)

 . W !,"Division: " S IBRG=+Y,IBY=0 F  S IBY=$O(^IBE(363.31,IBRG,11,IBY)) Q:'IBY  D

 .. S IBDV=$G(^IBE(363.31,IBRG,11,IBY,0)) Q:'IBDV  S IBX=$G(^DG(40.8,+IBDV,0)) W ?16,$P(IBX,U,2),?24,$P(IBX,U,1),!

 Q Y

 ;

GETHFRG(CMRG) ; get the Host File Site of Region selection, return IBCR RC SITE ifn ^ div/site ^ site name ^ id/zip ^ chg type

 N IBX,IBS,IBY S IBX=0

 S IBS=$P($G(CMRG)," ",2)_" "

 S IBY=$O(^XTMP("IBCR RC SITE","B",IBS,0)),IBS=$G(^XTMP("IBCR RC SITE",+IBY))

 I +IBY,IBS'="" S IBX=IBY_U_IBS

 ;

 I 'IBX W !!,"Error:  Site ",$P($G(CMRG)," ",2)," not found in Host Files, can not continue!",!!

 Q IBX

 ;

ASKNWFT(HFRG) ; determine/confirm from user the Facility Type Change based on the current Host File setting

 N IBT,IBN,IBX,DIR,X,Y S IBX=0 S HFRG=$G(HFRG)

 S IBT=+$P(HFRG,U,5),IBN=$P(HFRG,U,2)_" - "_$P(HFRG,U,3)

 ;

 ; if currently Provider Based (1 or 2) then ask to confirm the change to Freestanding (3)

 I (IBT=1)!(IBT=2) D

 . W !!,IBN," is currently Provider Based ",$S(IBT=1:"INPT/SFN/OPT (1)",1:"Outpatient Only (2)"),!

 . S DIR("?")="Must change the Provider Type otherwise do not use this option."

 . S DIR("A")="Do you want to change this site to Freestanding (3)"

 . S DIR(0)="YO" D ^DIR I Y=1 S IBX=3

 ;

 ; if currently Freestanding (3) then ask if change to Provider Based Inpatient (1) or Outpatient (2)

 I IBT=3 D

 . W !!,IBN," is currently Non-Provider Based Freestanding (3)",!

 . S DIR("?")="Must change the Provider Type otherwise do not use this option."

 . S DIR("?",1)="Enter 'I' if Inpatient, SNF and Outpatient charges are required for the site."

 . S DIR("?",2)="Enter 'O' if Outpatient Only charges are required for the site."

 . S DIR("A")="Site will be changed to Provider Based, select Type"

 . S DIR(0)="SO^1:Inpatient/SNF/Outpatient;2:Outpatient" D ^DIR I Y>0 S IBX=+Y

 ;

 Q IBX

 ;

ASKNWDT() ; ask the user for the effective date of the change, return date or 0

 N DIR,X,Y W !

 S DIR("?")="The date the new charges will become effective."

 S DIR("?",1)="Enter the Effective Date of the Facility Type change."

 S DIR("?",2)="This is the date the new charges become available."

 S DIR("?",3)="The old charges (existing) will be inactivated one day before this date."

 S DIR("A")="Effective Date of Facility Type Change"

 S DIR(0)="DO^::AEX" D ^DIR I Y'?7N S Y=0

 Q Y

 ;

 ;

ASKFNL(CMRG,NWDT,NWFT) ; ask user if they really want to make the change, return true if yes

 N DIR,IBRG,IBDV,IBX,IBY,IBOK,X,Y S IBOK=0

 W !,"You have requested current charges for the following Region and Division "

 W !,"be changed from ",$S(NWFT'=3:"Freestanding",1:"Provider Based")," to ",$S(NWFT=3:"Freestanding",1:"Provider Based"),":",!

 ;

 W !,"Billing Region: ",$P(CMRG,U,2),?50,"3-Zip: ",$P(CMRG,U,4),?65,"Type: ",$P(CMRG,U,5)

 W !,"Division: " S IBRG=+CMRG,IBY=0 F  S IBY=$O(^IBE(363.31,IBRG,11,IBY)) Q:'IBY  D

 . S IBDV=$G(^IBE(363.31,IBRG,11,IBY,0)) Q:'IBDV  S IBX=$G(^DG(40.8,+IBDV,0)) W ?16,$P(IBX,U,2),?24,$P(IBX,U,1),!

 ;

 W !!,"Currently loaded ",$S(NWFT'=3:"Freestanding",1:"Provider Based")," charges will be inactivated as of ",$$FMTE^XLFDT($$FMADD^XLFDT(NWDT,-1),2)

 W !,"New ",$S(NWFT=3:"Freestanding",1:"Provider Based")," charges will be loaded with an effective date of ",$$FMTE^XLFDT(NWDT,2),!

 ;

 S DIR("?")="No permanent changes have been made, enter Yes to complete the changes."

 S DIR("A")="Do you want to complete these changes and update your stored charges"

 S DIR(0)="YO" D ^DIR I Y=1 S IBOK=1

 ;

 Q IBOK

 ;

 ;

CHECK(VERS,VSDT,NWDT,CMRG,HFRG,NWFT) ; check the inputs to determine if change is ok

 N IBX,IBC,IBRG,IBDS,IBOK S IBOK=1 S IBDS="",$P(IBDS,"=",IOM+1)="" W !,IBDS,!

 ;

 I VERS'=$$VERSION^IBCRHBRV D  S IBOK=0 G CHECKQ

 . W !,"Error: Version of Host Files loaded is not the current RC version "_VERS_".",!

 ;

 I $P(CMRG,U,3)'=$P(HFRG,U,2) D  S IBOK=0 G CHECKQ

 . W !,"Error: Site Number does not match in Host File and Charge Master"

 . W !,"       for selected Region.  Data inconsistency unresolved.",!

 ;

 I $P(CMRG,U,4)'=$P(HFRG,U,4) D  S IBOK=0 G CHECKQ

 . W !,"Error: Identifier 3-digit zip does not match in Host File and Charge Master"

 . W !,"       for selected Region.  Data inconsistency unresolved.",!

 ;

 I $P(CMRG,U,5)'=$P(HFRG,U,5) D  S IBOK=0 G CHECKQ

 . W !,"Error: Facility Type does not match in Host File and Charge Master"

 . W !,"       for selected Region.  Data inconsistency unresolved.",!

 ;

 I NWFT=$P(HFRG,U,5) D  S IBOK=0 G CHECKQ

 . W !,"Error: Host File Facility Type is the same as the selected Facility Type."

 . W !,"       This would result in no change to the charges.",!

 ;

 I NWFT<3,$P(HFRG,U,5)<3 D  S IBOK=0 G CHECKQ

 . W !,"Error: Host File Facility Type and Selected Facility Type are both"

 . W !,"       Provider Based.  This would result in no change to the charges.",!

 ;

 I NWDT'>VSDT D  S IBOK=0 G CHECKQ

 . W !,"Error: Date entered ",$$FMTE^XLFDT(NWDT,2)," is before v",VERS," effective date ",$$FMTE^XLFDT(VSDT,2),"."

 . W !,"       This option may only be used to change the Facility Type of the"

 . W !,"       current version charges after they are effective.  Use the regular"

 . W !,"       Upload to change charges on ",$$FMTE^XLFDT(VSDT,2),".",!

 ;

 S IBC=","_$$VERSITE^IBCRHBRV($P(HFRG,U,2))_",",IBX=","_VERS_","

 I IBC'[IBX D  S IBOK=0 G CHECKQ

 . W !,"Error: Selected Billing Region ",$P(CMRG,U,2)

 . W !,"       does not have the current version ",VERS," of Reasonable Charges installed."

 . W !,"       This option may only be used to change the current version charges."

 . W !,"       Use the regular Upload option to change charges from previous versions.",!

 ;

 S IBRG=+CMRG,IBC=0,IBX=0 F  S IBX=$O(^IBE(363.31,IBRG,11,IBX)) Q:'IBX  S IBC=IBC+1

 I IBC>1 D  S IBOK=0 G CHECKQ

 . W !,"Error: Selected Billing Region ",$P(CMRG,U,2)

 . W !,"       has more than one Division assigned.  Changing the Facility Type"

 . W !,"       may only be applied to one Division.  The extra Divisions need"

 . W !,"       to be removed from the Billing Region and charges loaded specifically"

 . W !,"       for those sites, usually at least two past versions.",!

 ;

CHECKQ Q IBOK

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCRHRS   14489     printed  Mar 13, 2025@21:24:35                                                                                                                                                                                                    Page 2

IBCRHRS   ;ALB/ARH - RATES: UPLOAD (RC) CHANGE SITE TYPE OPTION ; 25-JAN-13

 +1       ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

 +4       ; Option that allows the user to change a divisions Facility Charge Type

 +5       ; only allows the currently released version to be changed

 +6       ;

OPTION    ; Option entry Change Reasonable Charge Facility Type

 +1        NEW IBVERS,IBVERSDT,IBCMRG,IBHFRG,IBNWFT,IBNWDT,IBXRF1,IBDS,IBDONE

           SET IBDONE=0

           SET IBDS=""

           SET $PIECE(IBDS,"=",IOM+1)=""

 +2       ;

 +3        WRITE !!,"Change Reasonable Charges Facility Type:",!

 +4        WRITE !,"This option allows the Facility Type of currently loaded Reasonable Charges"

 +5        WRITE !,"to be changed on a specified date.  A Non-Provider Based Freestanding site"

 +6        WRITE !,"with only Professional charges may be changed to a Provider Based site with"

 +7        WRITE !,"both Institutional and Professional charges.",!

 +8        WRITE !,"This option will complete the following steps:"

 +9        WRITE !,"1.  Uploads the current version of Reasonable Charges."

 +10       WRITE !,"2.  Request the Region/Division to change, the new type and effective date."

 +11       WRITE !,"3.  Calculate the charges for the Region with the new type and effective date."

 +12       WRITE !,"4.  Request confirmation then update the permanent files in the Charge Master:"

 +13       WRITE !,"    inactivate the currently loaded charges for the region, update the "

 +14       WRITE !,"    Region's Type, and load the new charges into the Charge Master.",!

 +15       WRITE !,"Only CBO can approve a Facility Type change for a division.  "

 +16       WRITE !,"Approval from CBO must be received before using this option to change charges.",!

 +17       SET DIR(0)="Y"

           SET DIR("A")="Approval Received to Change a Divisions Facility Type, Continue"

           DO ^DIR

           KILL DIR,X

           IF Y'=1

               QUIT 

 +18      ;

 +19      ;

 +20      ; get the current version

           SET IBVERS=+$$VERSTR^IBCRHBRV(1)

           IF 'IBVERS

               GOTO OPTIONQ

 +21      ; get effective date of current version

           SET IBVERSDT=+$$VERSDT^IBCRHBRV(IBVERS)

           IF 'IBVERSDT

               GOTO OPTIONQ

 +22      ;

 +23       WRITE !,IBDS,!,"*** Set-Up process:",!

 +24      ;

 +25      ; delete any existing upload files in XTMP

           DO XTMPKL

 +26      ; load current version load files into XTMP

           IF '$$XTMPHL(IBVERS)

               GOTO OPTIONQ

 +27      ;

 +28       WRITE !,IBDS,!,"*** Get specifications from user and check the change is valid",!

 +29      ;

 +30      ; get CM Billing Region from user (#363.31)

           SET IBCMRG=$$ASKCMRG

           IF 'IBCMRG

               GOTO OPTIONQ

 +31      ; get HF Billing Region from Host Site File

           SET IBHFRG=$$GETHFRG(IBCMRG)

           IF 'IBHFRG

               GOTO OPTIONQ

 +32      ; get the new Charge Type for the Billing Region

           SET IBNWFT=$$ASKNWFT(IBHFRG)

           IF 'IBNWFT

               GOTO OPTIONQ

 +33      ; get the effective date of the change from the user

           SET IBNWDT=$$ASKNWDT

           IF 'IBNWDT

               GOTO OPTIONQ

 +34       IF '$$CHECK(IBVERS,IBVERSDT,IBNWDT,IBCMRG,IBHFRG,IBNWFT)

               GOTO OPTIONQ

 +35      ;

 +36       WRITE !,IBDS,!,"*** Calculate charges and update effective date based on user entry",!

 +37      ;

 +38       SET $PIECE(IBHFRG,U,5)=IBNWFT

 +39      ; calculate site charges with new type, create XTMP files

           DO CALCRC^IBCRHBS5(IBHFRG)

 +40      ; update calculated charges dates in XTMP

           IF '$$XTMPDT(IBVERSDT,IBNWDT)

               GOTO OPTIONQ

 +41      ;

 +42       WRITE !,IBDS,!,"*** Confirm Request to Update Charge Master",!

 +43      ;

 +44      ; get final confirmation for change from user

           IF '$$ASKFNL(IBCMRG,IBNWDT,IBNWFT)

               GOTO OPTIONQ

 +45      ;

 +46       WRITE !,IBDS,!,"*** Complete Request - Update Charge Master",!

 +47      ;

 +48      ; inactivate existing charges in Charge Master

           IF '$$CMINDT(IBCMRG,IBVERSDT,IBNWDT)

               GOTO OPTIONQ

 +49       SET IBDONE=1

 +50      ; update Facility Type in Charge Master

           DO CMRGFT(IBCMRG,IBNWFT)

 +51      ; load the modifified charges into Charge Master

           DO CMLOAD

 +52      ;

OPTIONQ   ;

 +1       ; delete any existing upload files in XTMP

           DO XTMPKL

 +2       ;

 +3        IF +IBDONE

               WRITE !,IBDS,!,"*** Process Complete, Charge Master Charges Updated.",!

 +4        IF 'IBDONE

               WRITE !,IBDS,!,"*** Process Ended, No Permanent Changes.",!

 +5        QUIT 

 +6       ;

 +7       ;

XTMPKL    ; delete any existing RC Upload Files in XTMP

 +1        NEW IBX

 +2        WRITE !,"Removing any existing temporary Upload files: ",!

 +3        SET IBX="IBCR RC"

           FOR 

               SET IBX=$ORDER(^XTMP(IBX))

               if IBX'["IBCR RC"

                   QUIT 

               KILL ^XTMP(IBX)

               WRITE "."

 +4        SET IBX="IBCR UPLOAD RC"

           FOR 

               SET IBX=$ORDER(^XTMP(IBX))

               if IBX'["IBCR UPLOAD RC"

                   QUIT 

               KILL ^XTMP(IBX)

               WRITE "."

 +5        QUIT 

 +6       ;

XTMPHL(VERS) ; load version of RC Host Files IBCR RC into XTMP (IBCRHBS1)

 +1        NEW IBPATH,IBFILES,IBFILE,IBNODE,IBOK

           SET IBOK=0

           IF '$GET(VERS)

               GOTO XTMPHLQ

 +2       ;

 +3        WRITE !!,"Upload National Reasonable Charges v"_VERS_" Host Files to temporary local files:",!

 +4       ; get path/directory

           SET IBPATH=$$PATH^IBCRHBS1

           IF IBPATH<0

               GOTO XTMPHLQ

 +5       ; get list of files to be loaded

           DO FILES^IBCRHBRV(.IBFILES,VERS)

 +6       ; check host files are available/found

           IF '$$FNDHOST^IBCRHBS1(.IBFILES,IBPATH)

               GOTO XTMPHLQ

 +7       ;

 +8        WRITE !,"Loading National Reasonable Charges v"_VERS_" Host Files into temporary local file:"

 +9        SET IBOK=1

           SET IBFILE=""

           FOR 

               SET IBFILE=$ORDER(IBFILES(IBFILE))

               if IBFILE=""

                   QUIT 

               Begin DoDot:1

 +10               SET IBNODE=IBFILES(IBFILE)

 +11               IF $$LOAD^IBCRHBS2(IBPATH,IBFILE,$PIECE(IBNODE,U,1),$PIECE(IBNODE,U,2),VERS,$PIECE(IBNODE,U,3))

                       QUIT 

 +12               WRITE !!,"   Error while processing host file, can not continue!",!!

                   SET IBOK=0

               End DoDot:1

               IF 'IBOK

                   QUIT 

 +13       IF +IBOK

               WRITE !!,"Upload of Reasonable Charges v"_VERS_" Host Files Complete.",!

 +14      ;

XTMPHLQ    QUIT IBOK

 +1       ;

XTMPDT(VSDT,NWDT) ; update calculated charges IBCR UPLOAD effective date in XTMP, returns count changed

 +1        NEW IBXRF1,IBSUB,IBX,IBLN,IBCNT

           SET IBXRF1=0

           SET IBCNT=0

 +2        IF ($GET(VSDT)'?7N)!($GET(NWDT)'?7N)

               GOTO XTMPDTQ

 +3       ;

 +4        SET IBSUB="IBCR UPLOAD RC"

           SET IBXRF1=$ORDER(^XTMP(IBSUB))

           IF IBXRF1'[IBSUB

               GOTO XTMPDTQ

 +5       ;

 +6        WRITE !!,"Changing Effective Date from ",$$FMTE^XLFDT(VSDT,2)," to ",$$FMTE^XLFDT(NWDT,2)," in Host Files."

 +7        WRITE !!,"Host Files ",IBXRF1,?55,"Count = ",$PIECE($GET(^XTMP(IBXRF1,0)),U,4),!

 +8       ;

 +9       ; loop through XTMP calculated charges and update the effective date

 +10       SET IBSUB=""

           FOR 

               SET IBSUB=$ORDER(^XTMP(IBXRF1,IBSUB))

               if IBSUB=""

                   QUIT 

               Begin DoDot:1

 +11               SET IBX=0

                   FOR 

                       SET IBX=$ORDER(^XTMP(IBXRF1,IBSUB,IBX))

                       if 'IBX

                           QUIT 

                       Begin DoDot:2

 +12                       SET IBLN=$GET(^XTMP(IBXRF1,IBSUB,IBX))

 +13                       IF +$PIECE(IBLN,U,3)

                               IF +$PIECE(IBLN,U,3)<NWDT

                                   QUIT 

 +14      ;

 +15                       IF $PIECE(IBLN,U,2)=VSDT

                               SET $PIECE(IBLN,U,2)=NWDT

                               SET ^XTMP(IBXRF1,IBSUB,IBX)=IBLN

                               SET IBCNT=IBCNT+1

                       End DoDot:2

 +16               IF +IBCNT

                       WRITE !,IBSUB,?25,IBCNT

               End DoDot:1

 +17      ;

XTMPDTQ    IF IBCNT'=$PIECE($GET(^XTMP(IBXRF1,0)),U,4)

               SET IBCNT=0

               WRITE !!,"Error: All dates not changed, can not continue!",!

 +1        QUIT IBCNT

 +2       ;

 +3       ;

CMINDT(CMRG,VSDT,NWDT) ; inactivate existing charges for selected Billing Region in Charge Master (#363.2)

 +1        NEW IBCNT,IBINACT,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBCI,IBCI0,IBCHG,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y

           SET IBCNT=0

 +2        IF ($GET(VSDT)'?7N)!($GET(NWDT)'?7N)

               GOTO CMINDTQ

 +3        IF $GET(^IBE(363.31,+$GET(CMRG),0))'["RC "

               GOTO CMINDTQ

 +4       ;

 +5        SET IBINACT=$$FMADD^XLFDT(NWDT,-1)

 +6       ;

 +7        WRITE !!,"Inactivating ",$PIECE(CMRG,U,2)," existing charges on ",$$FMTE^XLFDT(IBINACT,2),":",!,"Please wait...",!

 +8       ;

 +9        SET IBCS=0

           FOR 

               SET IBCS=$ORDER(^IBE(363.1,IBCS))

               if 'IBCS

                   QUIT 

               Begin DoDot:1

 +10               SET IBCS0=$GET(^IBE(363.1,IBCS,0))

                   IF $PIECE(IBCS0,U,7)'=+CMRG

                       QUIT 

 +11               SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))

                   IF $EXTRACT(IBBR0,1,3)'="RC "

                       QUIT 

 +12      ;

 +13               SET IBXRF="AIVDTS"_IBCS

                   SET IBCHG=0

 +14               SET IBITM=0

                   FOR 

                       SET IBITM=$ORDER(^IBA(363.2,IBXRF,IBITM))

                       if 'IBITM

                           QUIT 

                       Begin DoDot:2

 +15                       SET IBCI=0

                           FOR 

                               SET IBCI=$ORDER(^IBA(363.2,IBXRF,IBITM,-VSDT,IBCI))

                               if 'IBCI

                                   QUIT 

                               Begin DoDot:3

 +16                               SET IBCI0=$GET(^IBA(363.2,IBCI,0))

 +17                               IF +$PIECE(IBCI0,U,4)

                                       IF IBINACT>+$PIECE(IBCI0,U,4)

                                           QUIT 

 +18      ;

 +19                               SET DR=".04///"_+IBINACT

                                   SET DIE="^IBA(363.2,"

                                   SET DA=+IBCI

                                   DO ^DIE

                                   KILL DIC,X,Y

                                   SET IBCNT=IBCNT+1

                                   SET IBCHG=1

                               End DoDot:3

                       End DoDot:2

 +20               IF +IBCHG

                       WRITE !,$PIECE(IBCS0,U,1),?35,IBCNT

               End DoDot:1

 +21      ;

CMINDTQ    IF 'IBCNT

               WRITE !!,"Unable to Inactivate current charges, can not continue!",!

 +1        QUIT IBCNT

 +2       ;

CMRGFT(CMRG,NWFT) ; change the Billing Regions Facility Type in the Charge Master (#363.31,.03)

 +1        NEW IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y

           SET NWFT=+$GET(NWFT)

 +2        SET IBX=+$PIECE($GET(^IBE(363.31,+$GET(CMRG),0)),U,3)

 +3        WRITE !!,"Changing Billing Regions Facility Type: "

 +4       ;

 +5        IF +IBX

               IF +NWFT

                   IF IBX'=NWFT

                       SET DR=".03///"_NWFT

                       SET DIE="^IBE(363.31,"

                       SET DA=+CMRG

                       DO ^DIE

 +6       ;

 +7        WRITE !,"Billing Region ",$PIECE($GET(CMRG),U,2)," changed from ",IBX," to ",NWFT

 +8        QUIT 

 +9       ;

CMLOAD    ; load charges into Charge Master

 +1       ; queuing is not allowed to ensure the modified files are used and 

 +2       ; process completes fully.

 +3       ;

 +4        NEW ADD

           WRITE !!,"Load modified charges into Charge Master:",!

 +5       ;

 +6       ; get the device

 +7        WRITE !,"Report requires 120 columns.  Queuing not allowed to ensure process completes."

 +8        SET %ZIS="M"

           SET %ZIS("A")="OUTPUT DEVICE: "

           DO ^%ZIS

           IF POP

               QUIT 

 +9       ;

 +10       SET ADD=1

           DO RPT^IBCRHO

 +11       QUIT 

 +12      ;

 +13      ;

ASKCMRG() ; ask user for Billing Region (#363.31), return Billing Region ifn ^ name ^ div/site ^ id/zip ^ chg type

 +1        NEW IBRG,IBDV,IBX,IBY,DIC,X,Y

 +2        WRITE !,"Enter the Division to change the Reasonable Charges Facility Type:",!

 +3        SET DIC("S")="I $E(^(0),1,3)=""RC """

 +4        SET DIC="^IBE(363.31,"

           SET DIC(0)="AEMNQZ"

           SET DIC("A")="Select DIVISION/REGION: "

           DO ^DIC

           IF Y<1

               SET Y=0

 +5        IF +Y

               SET Y=Y_U_$PIECE(Y(0)," ",2)_U_$PIECE(Y(0),U,2,3)

 +6       ;

 +7        IF +Y

               Begin DoDot:1

 +8                WRITE !!,"Billing Region: ",$PIECE(Y,U,2),?50,"3-Zip: ",$PIECE(Y,U,4),?65,"Type: ",$PIECE(Y,U,5)

 +9                WRITE !,"Division: "

                   SET IBRG=+Y

                   SET IBY=0

                   FOR 

                       SET IBY=$ORDER(^IBE(363.31,IBRG,11,IBY))

                       if 'IBY

                           QUIT 

                       Begin DoDot:2

 +10                       SET IBDV=$GET(^IBE(363.31,IBRG,11,IBY,0))

                           if 'IBDV

                               QUIT 

                           SET IBX=$GET(^DG(40.8,+IBDV,0))

                           WRITE ?16,$PIECE(IBX,U,2),?24,$PIECE(IBX,U,1),!

                       End DoDot:2

               End DoDot:1

 +11       QUIT Y

 +12      ;

GETHFRG(CMRG) ; get the Host File Site of Region selection, return IBCR RC SITE ifn ^ div/site ^ site name ^ id/zip ^ chg type

 +1        NEW IBX,IBS,IBY

           SET IBX=0

 +2        SET IBS=$PIECE($GET(CMRG)," ",2)_" "

 +3        SET IBY=$ORDER(^XTMP("IBCR RC SITE","B",IBS,0))

           SET IBS=$GET(^XTMP("IBCR RC SITE",+IBY))

 +4        IF +IBY

               IF IBS'=""

                   SET IBX=IBY_U_IBS

 +5       ;

 +6        IF 'IBX

               WRITE !!,"Error:  Site ",$PIECE($GET(CMRG)," ",2)," not found in Host Files, can not continue!",!!

 +7        QUIT IBX

 +8       ;

ASKNWFT(HFRG) ; determine/confirm from user the Facility Type Change based on the current Host File setting

 +1        NEW IBT,IBN,IBX,DIR,X,Y

           SET IBX=0

           SET HFRG=$GET(HFRG)

 +2        SET IBT=+$PIECE(HFRG,U,5)

           SET IBN=$PIECE(HFRG,U,2)_" - "_$PIECE(HFRG,U,3)

 +3       ;

 +4       ; if currently Provider Based (1 or 2) then ask to confirm the change to Freestanding (3)

 +5        IF (IBT=1)!(IBT=2)

               Begin DoDot:1

 +6                WRITE !!,IBN," is currently Provider Based ",$SELECT(IBT=1:"INPT/SFN/OPT (1)",1:"Outpatient Only (2)"),!

 +7                SET DIR("?")="Must change the Provider Type otherwise do not use this option."

 +8                SET DIR("A")="Do you want to change this site to Freestanding (3)"

 +9                SET DIR(0)="YO"

                   DO ^DIR

                   IF Y=1

                       SET IBX=3

               End DoDot:1

 +10      ;

 +11      ; if currently Freestanding (3) then ask if change to Provider Based Inpatient (1) or Outpatient (2)

 +12       IF IBT=3

               Begin DoDot:1

 +13               WRITE !!,IBN," is currently Non-Provider Based Freestanding (3)",!

 +14               SET DIR("?")="Must change the Provider Type otherwise do not use this option."

 +15               SET DIR("?",1)="Enter 'I' if Inpatient, SNF and Outpatient charges are required for the site."

 +16               SET DIR("?",2)="Enter 'O' if Outpatient Only charges are required for the site."