IBCRHBR5 ;ALB/ARH - RATES: UPLOAD (RC) CALCULATIONS SETUP ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106,138,148,169**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CALCRC(SITE) ; calculate a sites RC charges, create XTMP file that can be loaded into CM
; input: IFN of site in IBCR RC SITE ^ site number ^ site name
;
N IBX,IBXSITE,IBSITE Q:'$G(SITE) S IBXSITE=+SITE,IBSITE=$P(SITE,U,2)_" "_$P(SITE,U,3)
I '$D(^XTMP("IBCR RC SITE",IBXSITE))!(IBSITE="") W !!,"Site incompletely defined in upload, can not continue!" Q
W @IOF,!,"Calculating Reasonable Charges v"_$$VERSION^IBCRHBRV_" for "_IBSITE_":"
W !,"-------------------------------------------------------------------------------"
;
I '$$CONT("RC "_IBSITE) Q
;I '$$CONT1(IBSITE) Q
;
D CGROUP^IBCRHBR
S IBX=$$RG^IBCRHU2("RC "_$P(SITE,U,2)_" - "_$P(SITE,U,3),$P(SITE,U,2),$P(SITE,U,4)) W !
;
D INPT^IBCRHBR6(+IBXSITE)
D SNF^IBCRHBR6(+IBXSITE)
D OPT^IBCRHBR6(+IBXSITE)
D PCE^IBCRHBR6(+IBXSITE)
D PCF^IBCRHBR6(+IBXSITE)
D PCG^IBCRHBR6(+IBXSITE)
;
K ^TMP($J,"IBCR RC CGROUP")
D LAB^IBCRHBRB ; move selected Lab charges from Physician to Faclity Charge Sets, v1.4 only
;
W !!,"Done.",!!,"The following files were created, they will be purged in 2 days:" D DISP1^IBCRHU1("IBCR UPLOAD RC "_IBSITE)
;
S IBX=$P(IBSITE," ",1) I (IBX?3N1"X"1.3N)!(IBX>899.9)&(IBX'=999) D RESETDV^IBCREE2("RC "_IBX)
Q
;
CONT(SITE) ; check for existing files stored in XTMP with same subscript
; returns true if user wants to continue, any existing files are deleted, 0 otherwise
N ARR,IBX,IBY,IBZ,DIR,DIRUT,DUOUT,X,Y S ARR=0,IBZ=1
;
D DISP1^IBCRHU1("IBCR UPLOAD "_$G(SITE),.ARR)
;
I +ARR S IBZ=0 D
. W !!,"The above files already exist in XTMP." S DIR("?")="Enter either 'Y' or 'N'. This files use the same name as the new upload would use and therefore must be deleted before the upload can proceed."
. S DIR("A")="Delete the above files and continue with upload",DIR(0)="Y" D ^DIR K DIR
. ;
. I Y=1 S IBZ=1,IBX="" F S IBX=$O(ARR(IBX)) Q:IBX="" K ^XTMP(IBX) W "."
;
Q IBZ
;
CONT1(SITE) ; get final OK to start charge calculations, return true if want to continue, 0 if not
N IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=0 W !!
S DIR("?")="Enter either 'Y' or 'N'. Enter 'Y' if you want to calculate charges for "_$G(SITE)_" into XTMP."
S DIR("A")="Proceed with calculations now",DIR(0)="Y" D ^DIR K DIR I Y=1 S IBZ=1 W !
Q IBZ
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBR5 2476 printed Nov 22, 2024@17:29:22 Page 2
IBCRHBR5 ;ALB/ARH - RATES: UPLOAD (RC) CALCULATIONS SETUP ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106,138,148,169**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CALCRC(SITE) ; calculate a sites RC charges, create XTMP file that can be loaded into CM
+1 ; input: IFN of site in IBCR RC SITE ^ site number ^ site name
+2 ;
+3 NEW IBX,IBXSITE,IBSITE
if '$GET(SITE)
QUIT
SET IBXSITE=+SITE
SET IBSITE=$PIECE(SITE,U,2)_" "_$PIECE(SITE,U,3)
+4 IF '$DATA(^XTMP("IBCR RC SITE",IBXSITE))!(IBSITE="")
WRITE !!,"Site incompletely defined in upload, can not continue!"
QUIT
+5 WRITE @IOF,!,"Calculating Reasonable Charges v"_$$VERSION^IBCRHBRV_" for "_IBSITE_":"
+6 WRITE !,"-------------------------------------------------------------------------------"
+7 ;
+8 IF '$$CONT("RC "_IBSITE)
QUIT
+9 ;I '$$CONT1(IBSITE) Q
+10 ;
+11 DO CGROUP^IBCRHBR
+12 SET IBX=$$RG^IBCRHU2("RC "_$PIECE(SITE,U,2)_" - "_$PIECE(SITE,U,3),$PIECE(SITE,U,2),$PIECE(SITE,U,4))
WRITE !
+13 ;
+14 DO INPT^IBCRHBR6(+IBXSITE)
+15 DO SNF^IBCRHBR6(+IBXSITE)
+16 DO OPT^IBCRHBR6(+IBXSITE)
+17 DO PCE^IBCRHBR6(+IBXSITE)
+18 DO PCF^IBCRHBR6(+IBXSITE)
+19 DO PCG^IBCRHBR6(+IBXSITE)
+20 ;
+21 KILL ^TMP($JOB,"IBCR RC CGROUP")
+22 ; move selected Lab charges from Physician to Faclity Charge Sets, v1.4 only
DO LAB^IBCRHBRB
+23 ;
+24 WRITE !!,"Done.",!!,"The following files were created, they will be purged in 2 days:"
DO DISP1^IBCRHU1("IBCR UPLOAD RC "_IBSITE)
+25 ;
+26 SET IBX=$PIECE(IBSITE," ",1)
IF (IBX?3N1"X"1.3N)!(IBX>899.9)&(IBX'=999)
DO RESETDV^IBCREE2("RC "_IBX)
+27 QUIT
+28 ;
CONT(SITE) ; check for existing files stored in XTMP with same subscript
+1 ; returns true if user wants to continue, any existing files are deleted, 0 otherwise
+2 NEW ARR,IBX,IBY,IBZ,DIR,DIRUT,DUOUT,X,Y
SET ARR=0
SET IBZ=1
+3 ;
+4 DO DISP1^IBCRHU1("IBCR UPLOAD "_$GET(SITE),.ARR)
+5 ;
+6 IF +ARR
SET IBZ=0
Begin DoDot:1
+7 WRITE !!,"The above files already exist in XTMP."
SET DIR("?")="Enter either 'Y' or 'N'. This files use the same name as the new upload would use and therefore must be deleted before the upload can proceed."
+8 SET DIR("A")="Delete the above files and continue with upload"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
+9 ;
+10 IF Y=1
SET IBZ=1
SET IBX=""
FOR
SET IBX=$ORDER(ARR(IBX))
if IBX=""
QUIT
KILL ^XTMP(IBX)
WRITE "."
End DoDot:1
+11 ;
+12 QUIT IBZ
+13 ;
CONT1(SITE) ; get final OK to start charge calculations, return true if want to continue, 0 if not
+1 NEW IBZ,DIR,DIRUT,DUOUT,X,Y
SET IBZ=0
WRITE !!
+2 SET DIR("?")="Enter either 'Y' or 'N'. Enter 'Y' if you want to calculate charges for "_$GET(SITE)_" into XTMP."
+3 SET DIR("A")="Proceed with calculations now"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF Y=1
SET IBZ=1
WRITE !
+4 QUIT IBZ
