source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS5.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1IBCRHBS5 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS DRIVER ; 10-OCT-03
2 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CALCRC(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 ^ 3-digit zip ^ type
7 ;
8 N IBX,IBSITE,IBRG Q:'$G(SITE) S IBSITE=$P(SITE,U,2)_" "_$P(SITE,U,3) K ^TMP($J,"IBCR UPLOAD FS PROF")
9 I '$D(^XTMP("IBCR RC SITE",+SITE))!(IBSITE="")!($P(SITE,U,4)'?3N)!('$P(SITE,U,5)) 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 ;
15 S IBXRF1="IBCR UPLOAD RC "_$P(SITE,U,2)_" "_$P(SITE,U,3) K ^XTMP(IBXRF1)
16 ;
17 ;
18 S TYPE=$P(SITE,U,5) Q:'TYPE
19 ;
20 I TYPE=1 D
21 . D INPT^IBCRHBS6(SITE,IBXRF1)
22 . D OPT^IBCRHBS6(SITE,IBXRF1)
23 . D A^IBCRHBS7(SITE,IBXRF1)
24 . D B^IBCRHBS7(SITE,IBXRF1)
25 . D C^IBCRHBS7(SITE,IBXRF1)
26 ;
27 I TYPE=2 D
28 . D OPT^IBCRHBS6(SITE,IBXRF1)
29 . D B^IBCRHBS7(SITE,IBXRF1)
30 . D C^IBCRHBS7(SITE,IBXRF1)
31 ;
32 I TYPE=3 D
33 . D FREE^IBCRHBS6(SITE,IBXRF1)
34 . D B^IBCRHBS7(SITE,IBXRF1)
35 . D C^IBCRHBS7(SITE,IBXRF1)
36 . D FA^IBCRHBS7(SITE,IBXRF1)
37 ;
38 ;
39 W !!,"Done.",!!,"The following files were created, they will be purged in 2 days:" D DISP1^IBCRHU1("IBCR UPLOAD RC "_IBSITE)
40 ;
41 K ^TMP($J,"IBCR UPLOAD FS PROF")
42 Q
43 ;
44CONT(SITE) ; check for existing files stored in XTMP with same subscript
45 ; returns true if user wants to continue, any existing files are deleted, 0 otherwise
46 N ARR,IBX,IBY,IBZ,DIR,DIRUT,DUOUT,X,Y S ARR=0,IBZ=1
47 ;
48 D DISP1^IBCRHU1("IBCR UPLOAD "_$G(SITE),.ARR)
49 ;
50 I +ARR S IBZ=0 D
51 . 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."
52 . S DIR("A")="Delete the above files and continue with upload",DIR(0)="Y" D ^DIR K DIR
53 . ;
54 . I Y=1 S IBZ=1,IBX="" F S IBX=$O(ARR(IBX)) Q:IBX="" K ^XTMP(IBX) W "."
55 ;
56 Q IBZ
Note: See TracBrowser for help on using the repository browser.