IBCRHBS1 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC 2+) SETUP ; 10-OCT-03
;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
HOSTLOAD(VERS) ; upload national REASONABLE CHARGES files from Host files into ^XTMP
;
N X,Y,IBFILES,IBPATH,IBFILE,IBNODE,IBOK S IBOK=0,VERS=+$G(VERS)
W @IOF,!,"Upload National Reasonable Charges v"_VERS_" Host Files to Temporary Vista files"
W !,"--------------------------------------------------------------------------------",!
;
S IBPATH=$$PATH I IBPATH<0 G HLEND
;
D FILES^IBCRHBRV(.IBFILES,VERS) ; list of files to be loaded
;
I '$$FNDHOST(.IBFILES,IBPATH) G HLEND ; all host files found
;
I '$$CONT(.IBFILES) G HLEND
I '$$CONT1 G HLEND
;
W @IOF,!,"Loading National Reasonable Charges v"_VERS_" Host Files into temporary local file"
W !,"--------------------------------------------------------------------------------"
;
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.",!
I +$$FNDXTMP(.IBFILES) D
. W !!,"The following files were created in XTMP, they will be purged in 2 days:"
. W !,"------------------------------------------------------------------------" D DSPXTMP(.IBFILES)
HLEND Q IBOK
;
CONT(FILES) ; check for existing files stored in XTMP with same subscript
; returns true if user wants to continue, any existing files are deleted
;
N ARR,IBX,IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=1
;
I +$$FNDXTMP(.FILES) D
. S IBZ=0 W !!,"These files already exist in XTMP:",!,"----------------------------------"
. ;
. D DSPXTMP(.FILES,.ARR) Q:$D(ARR)<10 W !
. S DIR("?")="Enter either 'Y' or 'N'. These 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 the upload",DIR(0)="Y" D ^DIR K DIR
. ;
. I Y=1 S IBZ=1,IBX="IBCR RC" F S IBX=$O(^XTMP(IBX)) Q:IBX'["IBCR RC" K ^XTMP(IBX) W "."
;
Q IBZ
;
CONT1() ; get final OK to start upload, return true if want to continue with upload
N IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=0 W !!
S DIR("?")="Enter either 'Y' or 'N'. Enter 'Y' if you want to load the Reasonable Charges Host files into XTMP."
S DIR("A")="Proceed with upload of National Reasonable Charges Host Files now",DIR(0)="Y" D ^DIR K DIR I Y=1 S IBZ=1
Q IBZ
;
PATH() ; return directory or -1
N IBPATH,DIR,DIRUT,DUOUT,X,Y S IBPATH=""
S DIR("?",1)="Enter the full path specification where the host files may be found"
S DIR("?")="or press return for the default directory "_$$PWD^%ZISH
S DIR(0)="FO^3:60",DIR("A")="Enter the file path",DIR("B")=$$PWD^%ZISH D ^DIR K DIR
S IBPATH=$S($D(DUOUT)!$D(DTOUT):-1,1:Y)
Q IBPATH
;
FNDXTMP(FILES) ; find if any existing files in XTMP, return true if any found
N IBFILE,IBXRF,IBNODE,IBZ S IBZ=0
;
S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D Q:+IBZ
. S IBXRF="IBCR RC "_$P(FILES(IBFILE),U,2) Q:$D(^XTMP(IBXRF))=0 S IBZ=1
Q IBZ
;
DSPXTMP(FILES,ARR) ; display any existing files in XTMP, ARR passed by ref can be used to get list of existing file subscripts
N IBFILE,IBXRF,IBNODE,IBY K ARR
;
S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D
. S IBXRF="IBCR RC "_$P(FILES(IBFILE),U,2) I $D(^XTMP(IBXRF))=0 Q
. S ARR(IBXRF)="",IBNODE=$G(^XTMP(IBXRF,0)),IBY=$S($P(IBNODE,U,3)="":IBXRF,1:$P(IBNODE,U,3))
. W !,?4,$E(IBY,1,67),?74,$P(IBNODE,U,5)
Q
;
FNDHOST(FILES,IBPATH) ; find and display any Host files available for upload, return true if all required files found
N IBX,IBY,IBZ,IBF,IBFILE,X,Y S IBF=1
W !!,"Reasonable Charges Host Files found: ",?44,IBPATH,!,"------------------------------------"
;
I $O(FILES(""))="" S IBF=0
;
S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D
. S IBX(IBFILE)="",IBZ=$$LIST^%ZISH(IBPATH,"IBX","IBY") K IBX,IBY
. W !,$P(FILES(IBFILE),U,1),":",?45,IBFILE I 'IBZ W ?57,"*** not found ***" S IBF=0
;
I 'IBF W !!,"Can not find all required host files, can not continue!",!!
I +IBF W !!,"All required host files found.",!
Q IBF
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBS1 4400 printed Nov 22, 2024@17:29:28 Page 2
IBCRHBS1 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC 2+) SETUP ; 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 ;
HOSTLOAD(VERS) ; upload national REASONABLE CHARGES files from Host files into ^XTMP
+1 ;
+2 NEW X,Y,IBFILES,IBPATH,IBFILE,IBNODE,IBOK
SET IBOK=0
SET VERS=+$GET(VERS)
+3 WRITE @IOF,!,"Upload National Reasonable Charges v"_VERS_" Host Files to Temporary Vista files"
+4 WRITE !,"--------------------------------------------------------------------------------",!
+5 ;
+6 SET IBPATH=$$PATH
IF IBPATH<0
GOTO HLEND
+7 ;
+8 ; list of files to be loaded
DO FILES^IBCRHBRV(.IBFILES,VERS)
+9 ;
+10 ; all host files found
IF '$$FNDHOST(.IBFILES,IBPATH)
GOTO HLEND
+11 ;
+12 IF '$$CONT(.IBFILES)
GOTO HLEND
+13 IF '$$CONT1
GOTO HLEND
+14 ;
+15 WRITE @IOF,!,"Loading National Reasonable Charges v"_VERS_" Host Files into temporary local file"
+16 WRITE !,"--------------------------------------------------------------------------------"
+17 ;
+18 SET IBOK=1
SET IBFILE=""
FOR
SET IBFILE=$ORDER(IBFILES(IBFILE))
if IBFILE=""
QUIT
Begin DoDot:1
+19 SET IBNODE=IBFILES(IBFILE)
+20 IF $$LOAD^IBCRHBS2(IBPATH,IBFILE,$PIECE(IBNODE,U,1),$PIECE(IBNODE,U,2),VERS,$PIECE(IBNODE,U,3))
QUIT
+21 WRITE !!," Error while processing host file, can not continue!",!!
SET IBOK=0
End DoDot:1
IF 'IBOK
QUIT
+22 ;
+23 IF +IBOK
WRITE !!,"Upload of Reasonable Charges v"_VERS_" Host Files Complete.",!
+24 IF +$$FNDXTMP(.IBFILES)
Begin DoDot:1
+25 WRITE !!,"The following files were created in XTMP, they will be purged in 2 days:"
+26 WRITE !,"------------------------------------------------------------------------"
DO DSPXTMP(.IBFILES)
End DoDot:1
HLEND QUIT IBOK
+1 ;
CONT(FILES) ; check for existing files stored in XTMP with same subscript
+1 ; returns true if user wants to continue, any existing files are deleted
+2 ;
+3 NEW ARR,IBX,IBZ,DIR,DIRUT,DUOUT,X,Y
SET IBZ=1
+4 ;
+5 IF +$$FNDXTMP(.FILES)
Begin DoDot:1
+6 SET IBZ=0
WRITE !!,"These files already exist in XTMP:",!,"----------------------------------"
+7 ;
+8 DO DSPXTMP(.FILES,.ARR)
if $DATA(ARR)<10
QUIT
WRITE !
+9 SET DIR("?")="Enter either 'Y' or 'N'. These files use the same name as the new upload would use and therefore must be deleted before the upload can proceed."
+10 SET DIR("A")="Delete the above files and continue with the upload"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
+11 ;
+12 IF Y=1
SET IBZ=1
SET IBX="IBCR RC"
FOR
SET IBX=$ORDER(^XTMP(IBX))
if IBX'["IBCR RC"
QUIT
KILL ^XTMP(IBX)
WRITE "."
End DoDot:1
+13 ;
+14 QUIT IBZ
+15 ;
CONT1() ; get final OK to start upload, return true if want to continue with upload
+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 load the Reasonable Charges Host files into XTMP."
+3 SET DIR("A")="Proceed with upload of National Reasonable Charges Host Files now"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF Y=1
SET IBZ=1
+4 QUIT IBZ
+5 ;
PATH() ; return directory or -1
+1 NEW IBPATH,DIR,DIRUT,DUOUT,X,Y
SET IBPATH=""
+2 SET DIR("?",1)="Enter the full path specification where the host files may be found"
+3 SET DIR("?")="or press return for the default directory "_$$PWD^%ZISH
+4 SET DIR(0)="FO^3:60"
SET DIR("A")="Enter the file path"
SET DIR("B")=$$PWD^%ZISH
DO ^DIR
KILL DIR
+5 SET IBPATH=$SELECT($DATA(DUOUT)!$DATA(DTOUT):-1,1:Y)
+6 QUIT IBPATH
+7 ;
FNDXTMP(FILES) ; find if any existing files in XTMP, return true if any found
+1 NEW IBFILE,IBXRF,IBNODE,IBZ
SET IBZ=0
+2 ;
+3 SET IBFILE=""
FOR
SET IBFILE=$ORDER(FILES(IBFILE))
if IBFILE=""
QUIT
Begin DoDot:1
+4 SET IBXRF="IBCR RC "_$PIECE(FILES(IBFILE),U,2)
if $DATA(^XTMP(IBXRF))=0
QUIT
SET IBZ=1
End DoDot:1
if +IBZ
QUIT
+5 QUIT IBZ
+6 ;
DSPXTMP(FILES,ARR) ; display any existing files in XTMP, ARR passed by ref can be used to get list of existing file subscripts
+1 NEW IBFILE,IBXRF,IBNODE,IBY
KILL ARR
+2 ;
+3 SET IBFILE=""
FOR
SET IBFILE=$ORDER(FILES(IBFILE))
if IBFILE=""
QUIT
Begin DoDot:1
+4 SET IBXRF="IBCR RC "_$PIECE(FILES(IBFILE),U,2)
IF $DATA(^XTMP(IBXRF))=0
QUIT
+5 SET ARR(IBXRF)=""
SET IBNODE=$GET(^XTMP(IBXRF,0))
SET IBY=$SELECT($PIECE(IBNODE,U,3)="":IBXRF,1:$PIECE(IBNODE,U,3))
+6 WRITE !,?4,$EXTRACT(IBY,1,67),?74,$PIECE(IBNODE,U,5)
End DoDot:1
+7 QUIT
+8 ;
FNDHOST(FILES,IBPATH) ; find and display any Host files available for upload, return true if all required files found
+1 NEW IBX,IBY,IBZ,IBF,IBFILE,X,Y
SET IBF=1
+2 WRITE !!,"Reasonable Charges Host Files found: ",?44,IBPATH,!,"------------------------------------"
+3 ;
+4 IF $ORDER(FILES(""))=""
SET IBF=0
+5 ;
+6 SET IBFILE=""
FOR
SET IBFILE=$ORDER(FILES(IBFILE))
if IBFILE=""
QUIT
Begin DoDot:1
+7 SET IBX(IBFILE)=""
SET IBZ=$$LIST^%ZISH(IBPATH,"IBX","IBY")
KILL IBX,IBY
+8 WRITE !,$PIECE(FILES(IBFILE),U,1),":",?45,IBFILE
IF 'IBZ
WRITE ?57,"*** not found ***"
SET IBF=0
End DoDot:1
+9 ;
+10 IF 'IBF
WRITE !!,"Can not find all required host files, can not continue!",!!
+11 IF +IBF
WRITE !!,"All required host files found.",!
+12 QUIT IBF
