| 1 | IBCRHBR5 ;ALB/ARH - RATES: UPLOAD (RC) CALCULATIONS SETUP ; 10-OCT-1998
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**106,138,148,169**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | CALCRC(SITE) ; calculate a sites RC charges, create XTMP file that can be loaded into CM
|
|---|
| 6 | ; input: IFN of site in IBCR RC SITE ^ site number ^ site name
|
|---|
| 7 | ;
|
|---|
| 8 | N IBX,IBXSITE,IBSITE Q:'$G(SITE) S IBXSITE=+SITE,IBSITE=$P(SITE,U,2)_" "_$P(SITE,U,3)
|
|---|
| 9 | I '$D(^XTMP("IBCR RC SITE",IBXSITE))!(IBSITE="") W !!,"Site incompletely defined in upload, can not continue!" Q
|
|---|
| 10 | W @IOF,!,"Calculating Reasonable Charges v"_$$VERSION^IBCRHBRV_" for "_IBSITE_":"
|
|---|
| 11 | W !,"-------------------------------------------------------------------------------"
|
|---|
| 12 | ;
|
|---|
| 13 | I '$$CONT("RC "_IBSITE) Q
|
|---|
| 14 | ;I '$$CONT1(IBSITE) Q
|
|---|
| 15 | ;
|
|---|
| 16 | D CGROUP^IBCRHBR
|
|---|
| 17 | S IBX=$$RG^IBCRHU2("RC "_$P(SITE,U,2)_" - "_$P(SITE,U,3),$P(SITE,U,2),$P(SITE,U,4)) W !
|
|---|
| 18 | ;
|
|---|
| 19 | D INPT^IBCRHBR6(+IBXSITE)
|
|---|
| 20 | D SNF^IBCRHBR6(+IBXSITE)
|
|---|
| 21 | D OPT^IBCRHBR6(+IBXSITE)
|
|---|
| 22 | D PCE^IBCRHBR6(+IBXSITE)
|
|---|
| 23 | D PCF^IBCRHBR6(+IBXSITE)
|
|---|
| 24 | D PCG^IBCRHBR6(+IBXSITE)
|
|---|
| 25 | ;
|
|---|
| 26 | K ^TMP($J,"IBCR RC CGROUP")
|
|---|
| 27 | D LAB^IBCRHBRB ; move selected Lab charges from Physician to Faclity Charge Sets, v1.4 only
|
|---|
| 28 | ;
|
|---|
| 29 | W !!,"Done.",!!,"The following files were created, they will be purged in 2 days:" D DISP1^IBCRHU1("IBCR UPLOAD RC "_IBSITE)
|
|---|
| 30 | ;
|
|---|
| 31 | S IBX=$P(IBSITE," ",1) I (IBX?3N1"X"1.3N)!(IBX>899.9)&(IBX'=999) D RESETDV^IBCREE2("RC "_IBX)
|
|---|
| 32 | Q
|
|---|
| 33 | ;
|
|---|
| 34 | CONT(SITE) ; check for existing files stored in XTMP with same subscript
|
|---|
| 35 | ; returns true if user wants to continue, any existing files are deleted, 0 otherwise
|
|---|
| 36 | N ARR,IBX,IBY,IBZ,DIR,DIRUT,DUOUT,X,Y S ARR=0,IBZ=1
|
|---|
| 37 | ;
|
|---|
| 38 | D DISP1^IBCRHU1("IBCR UPLOAD "_$G(SITE),.ARR)
|
|---|
| 39 | ;
|
|---|
| 40 | I +ARR S IBZ=0 D
|
|---|
| 41 | . 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."
|
|---|
| 42 | . S DIR("A")="Delete the above files and continue with upload",DIR(0)="Y" D ^DIR K DIR
|
|---|
| 43 | . ;
|
|---|
| 44 | . I Y=1 S IBZ=1,IBX="" F S IBX=$O(ARR(IBX)) Q:IBX="" K ^XTMP(IBX) W "."
|
|---|
| 45 | ;
|
|---|
| 46 | Q IBZ
|
|---|
| 47 | ;
|
|---|
| 48 | CONT1(SITE) ; get final OK to start charge calculations, return true if want to continue, 0 if not
|
|---|
| 49 | N IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=0 W !!
|
|---|
| 50 | S DIR("?")="Enter either 'Y' or 'N'. Enter 'Y' if you want to calculate charges for "_$G(SITE)_" into XTMP."
|
|---|
| 51 | S DIR("A")="Proceed with calculations now",DIR(0)="Y" D ^DIR K DIR I Y=1 S IBZ=1 W !
|
|---|
| 52 | Q IBZ
|
|---|
