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 ---[H[J[2J[HIBCRHRS 14489 printed Apr 09, 2024@21:15:39 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."
+17 SET DIR("A")="Site will be changed to Provider Based, select Type"
+18 SET DIR(0)="SO^1:Inpatient/SNF/Outpatient;2:Outpatient"
DO ^DIR
IF Y>0
SET IBX=+Y
End DoDot:1
+19 ;
+20 QUIT IBX
+21 ;
ASKNWDT() ; ask the user for the effective date of the change, return date or 0
+1 NEW DIR,X,Y
WRITE !
+2 SET DIR("?")="The date the new charges will become effective."
+3 SET DIR("?",1)="Enter the Effective Date of the Facility Type change."
+4 SET DIR("?",2)="This is the date the new charges become available."
+5 SET DIR("?",3)="The old charges (existing) will be inactivated one day before this date."
+6 SET DIR("A")="Effective Date of Facility Type Change"
+7 SET DIR(0)="DO^::AEX"
DO ^DIR
IF Y'?7N
SET Y=0
+8 QUIT Y
+9 ;
+10 ;
ASKFNL(CMRG,NWDT,NWFT) ; ask user if they really want to make the change, return true if yes
+1 NEW DIR,IBRG,IBDV,IBX,IBY,IBOK,X,Y
SET IBOK=0
+2 WRITE !,"You have requested current charges for the following Region and Division "
+3 WRITE !,"be changed from ",$SELECT(NWFT'=3:"Freestanding",1:"Provider Based")," to ",$SELECT(NWFT=3:"Freestanding",1:"Provider Based"),":",!
+4 ;
+5 WRITE !,"Billing Region: ",$PIECE(CMRG,U,2),?50,"3-Zip: ",$PIECE(CMRG,U,4),?65,"Type: ",$PIECE(CMRG,U,5)
+6 WRITE !,"Division: "
SET IBRG=+CMRG
SET IBY=0
FOR
SET IBY=$ORDER(^IBE(363.31,IBRG,11,IBY))
if 'IBY
QUIT
Begin DoDot:1
+7 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:1
+8 ;
+9 WRITE !!,"Currently loaded ",$SELECT(NWFT'=3:"Freestanding",1:"Provider Based")," charges will be inactivated as of ",$$FMTE^XLFDT($$FMADD^XLFDT(NWDT,-1),2)
+10 WRITE !,"New ",$SELECT(NWFT=3:"Freestanding",1:"Provider Based")," charges will be loaded with an effective date of ",$$FMTE^XLFDT(NWDT,2),!
+11 ;
+12 SET DIR("?")="No permanent changes have been made, enter Yes to complete the changes."
+13 SET DIR("A")="Do you want to complete these changes and update your stored charges"
+14 SET DIR(0)="YO"
DO ^DIR
IF Y=1
SET IBOK=1
+15 ;
+16 QUIT IBOK
+17 ;
+18 ;
CHECK(VERS,VSDT,NWDT,CMRG,HFRG,NWFT) ; check the inputs to determine if change is ok
+1 NEW IBX,IBC,IBRG,IBDS,IBOK
SET IBOK=1
SET IBDS=""
SET $PIECE(IBDS,"=",IOM+1)=""
WRITE !,IBDS,!
+2 ;
+3 IF VERS'=$$VERSION^IBCRHBRV
Begin DoDot:1
+4 WRITE !,"Error: Version of Host Files loaded is not the current RC version "_VERS_".",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+5 ;
+6 IF $PIECE(CMRG,U,3)'=$PIECE(HFRG,U,2)
Begin DoDot:1
+7 WRITE !,"Error: Site Number does not match in Host File and Charge Master"
+8 WRITE !," for selected Region. Data inconsistency unresolved.",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+9 ;
+10 IF $PIECE(CMRG,U,4)'=$PIECE(HFRG,U,4)
Begin DoDot:1
+11 WRITE !,"Error: Identifier 3-digit zip does not match in Host File and Charge Master"
+12 WRITE !," for selected Region. Data inconsistency unresolved.",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+13 ;
+14 IF $PIECE(CMRG,U,5)'=$PIECE(HFRG,U,5)
Begin DoDot:1
+15 WRITE !,"Error: Facility Type does not match in Host File and Charge Master"
+16 WRITE !," for selected Region. Data inconsistency unresolved.",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+17 ;
+18 IF NWFT=$PIECE(HFRG,U,5)
Begin DoDot:1
+19 WRITE !,"Error: Host File Facility Type is the same as the selected Facility Type."
+20 WRITE !," This would result in no change to the charges.",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+21 ;
+22 IF NWFT<3
IF $PIECE(HFRG,U,5)<3
Begin DoDot:1
+23 WRITE !,"Error: Host File Facility Type and Selected Facility Type are both"
+24 WRITE !," Provider Based. This would result in no change to the charges.",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+25 ;
+26 IF NWDT'>VSDT
Begin DoDot:1
+27 WRITE !,"Error: Date entered ",$$FMTE^XLFDT(NWDT,2)," is before v",VERS," effective date ",$$FMTE^XLFDT(VSDT,2),"."
+28 WRITE !," This option may only be used to change the Facility Type of the"
+29 WRITE !," current version charges after they are effective. Use the regular"
+30 WRITE !," Upload to change charges on ",$$FMTE^XLFDT(VSDT,2),".",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+31 ;
+32 SET IBC=","_$$VERSITE^IBCRHBRV($PIECE(HFRG,U,2))_","
SET IBX=","_VERS_","
+33 IF IBC'[IBX
Begin DoDot:1
+34 WRITE !,"Error: Selected Billing Region ",$PIECE(CMRG,U,2)
+35 WRITE !," does not have the current version ",VERS," of Reasonable Charges installed."
+36 WRITE !," This option may only be used to change the current version charges."
+37 WRITE !," Use the regular Upload option to change charges from previous versions.",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+38 ;
+39 SET IBRG=+CMRG
SET IBC=0
SET IBX=0
FOR
SET IBX=$ORDER(^IBE(363.31,IBRG,11,IBX))
if 'IBX
QUIT
SET IBC=IBC+1
+40 IF IBC>1
Begin DoDot:1
+41 WRITE !,"Error: Selected Billing Region ",$PIECE(CMRG,U,2)
+42 WRITE !," has more than one Division assigned. Changing the Facility Type"
+43 WRITE !," may only be applied to one Division. The extra Divisions need"
+44 WRITE !," to be removed from the Billing Region and charges loaded specifically"
+45 WRITE !," for those sites, usually at least two past versions.",!
End DoDot:1
SET IBOK=0
GOTO CHECKQ
+46 ;
CHECKQ QUIT IBOK
