IBCRHBS5 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS DRIVER ; 10-OCT-03
;;2.0;INTEGRATED BILLING;**245**;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 ^ 3-digit zip ^ type
;
N IBX,IBSITE,IBRG Q:'$G(SITE) S IBSITE=$P(SITE,U,2)_" "_$P(SITE,U,3) K ^TMP($J,"IBCR UPLOAD FS PROF")
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
W @IOF,!,"Calculating Reasonable Charges v"_$$VERSION^IBCRHBRV_" for "_IBSITE_":"
W !,"-------------------------------------------------------------------------------"
;
I '$$CONT("RC "_IBSITE) Q
;
S IBXRF1="IBCR UPLOAD RC "_$P(SITE,U,2)_" "_$P(SITE,U,3) K ^XTMP(IBXRF1)
;
;
S TYPE=$P(SITE,U,5) Q:'TYPE
;
I TYPE=1 D
. D INPT^IBCRHBS6(SITE,IBXRF1)
. D OPT^IBCRHBS6(SITE,IBXRF1)
. D A^IBCRHBS7(SITE,IBXRF1)
. D B^IBCRHBS7(SITE,IBXRF1)
. D C^IBCRHBS7(SITE,IBXRF1)
;
I TYPE=2 D
. D OPT^IBCRHBS6(SITE,IBXRF1)
. D B^IBCRHBS7(SITE,IBXRF1)
. D C^IBCRHBS7(SITE,IBXRF1)
;
I TYPE=3 D
. D FREE^IBCRHBS6(SITE,IBXRF1)
. D B^IBCRHBS7(SITE,IBXRF1)
. D C^IBCRHBS7(SITE,IBXRF1)
. D FA^IBCRHBS7(SITE,IBXRF1)
;
;
W !!,"Done.",!!,"The following files were created, they will be purged in 2 days:" D DISP1^IBCRHU1("IBCR UPLOAD RC "_IBSITE)
;
K ^TMP($J,"IBCR UPLOAD FS PROF")
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBS5 2234 printed Apr 09, 2024@21:19:16 Page 2
IBCRHBS5 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS DRIVER ; 10-OCT-03
+1 ;;2.0;INTEGRATED BILLING;**245**;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 ^ 3-digit zip ^ type
+2 ;
+3 NEW IBX,IBSITE,IBRG
if '$GET(SITE)
QUIT
SET IBSITE=$PIECE(SITE,U,2)_" "_$PIECE(SITE,U,3)
KILL ^TMP($JOB,"IBCR UPLOAD FS PROF")
+4 IF '$DATA(^XTMP("IBCR RC SITE",+SITE))!(IBSITE="")!($PIECE(SITE,U,4)'?3N)!('$PIECE(SITE,U,5))
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 ;
+10 SET IBXRF1="IBCR UPLOAD RC "_$PIECE(SITE,U,2)_" "_$PIECE(SITE,U,3)
KILL ^XTMP(IBXRF1)
+11 ;
+12 ;
+13 SET TYPE=$PIECE(SITE,U,5)
if 'TYPE
QUIT
+14 ;
+15 IF TYPE=1
Begin DoDot:1
+16 DO INPT^IBCRHBS6(SITE,IBXRF1)
+17 DO OPT^IBCRHBS6(SITE,IBXRF1)
+18 DO A^IBCRHBS7(SITE,IBXRF1)
+19 DO B^IBCRHBS7(SITE,IBXRF1)
+20 DO C^IBCRHBS7(SITE,IBXRF1)
End DoDot:1
+21 ;
+22 IF TYPE=2
Begin DoDot:1
+23 DO OPT^IBCRHBS6(SITE,IBXRF1)
+24 DO B^IBCRHBS7(SITE,IBXRF1)
+25 DO C^IBCRHBS7(SITE,IBXRF1)
End DoDot:1
+26 ;
+27 IF TYPE=3
Begin DoDot:1
+28 DO FREE^IBCRHBS6(SITE,IBXRF1)
+29 DO B^IBCRHBS7(SITE,IBXRF1)
+30 DO C^IBCRHBS7(SITE,IBXRF1)
+31 DO FA^IBCRHBS7(SITE,IBXRF1)
End DoDot:1
+32 ;
+33 ;
+34 WRITE !!,"Done.",!!,"The following files were created, they will be purged in 2 days:"
DO DISP1^IBCRHU1("IBCR UPLOAD RC "_IBSITE)
+35 ;
+36 KILL ^TMP($JOB,"IBCR UPLOAD FS PROF")
+37 QUIT
+38 ;
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
