IBCRHBR1 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC) SETUP ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106,138,148**;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^IBCRHBR2(IBPATH,IBFILE,$P(IBNODE,U,1),$P(IBNODE,U,2),VERS) 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="" K ^XTMP("IBCR RC SITE") F S IBX=$O(ARR(IBX)) Q:IBX="" 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
;
;
RELOAD() ; check for existing files stored in XTMP with same subscript (these may be reloaded or re-used)
; returns 0 if host files already loaded/defined, 1 if not defined and need to be loaded, -1 if ^
;
N IBFILES,ARR,IBX,IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=1
;
D FILES^IBCRHBRV(.IBFILES)
;
I +$$FNDXTMP(.IBFILES) D
. S IBZ=0 W !!,"These files already exist in XTMP:",!,"----------------------------------"
. ;
. D DSPXTMP(.IBFILES,.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. You may either use these files to calculate RC charges or reload the Host files."
. S DIR("A")="Delete the above XTMP files and reload the Host files",DIR(0)="Y" D ^DIR I $D(DIRUT) S IBZ=-1 Q
. ;
. I Y=1 S IBZ=1,IBX="" K ^XTMP("IBCR RC SITE") F S IBX=$O(ARR(IBX)) Q:IBX="" K ^XTMP(IBX) W "."
;
Q IBZ
;
TMESS ; display message for test accounts (IB*2*138: loading test version of files not needed after release of v1)
W *7,*7,*7
W !,?10,"**** Will Load Test Version of Reasonable Charge Files ****"
W !!,"This appears to be a test account, the test version of the files will be loaded."
W !,"The test version of the charges should only be loaded into test accounts."
W !,"If this is not a test account but a live production account then do not load",!,"the charges! Contact support."
W !!,?3,"**** If this is a production account do not continue, Contact Support ****",!!
Q
;
PROD() ; return true if production version of the files should be loaded
N IBX S IBX=0 I +$$PROD^IBCORC S IBX=1 ; test account
Q IBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBR1 6023 printed Nov 22, 2024@17:29:19 Page 2
IBCRHBR1 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC) SETUP ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106,138,148**;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 ; all host files found
IF '$$FNDHOST(.IBFILES,IBPATH)
GOTO HLEND
+10 ;
+11 IF '$$CONT(.IBFILES)
GOTO HLEND
+12 IF '$$CONT1
GOTO HLEND
+13 ;
+14 WRITE @IOF,!,"Loading National Reasonable Charges v"_VERS_" Host Files into temporary local file"
+15 WRITE !,"--------------------------------------------------------------------------------"
+16 ;
+17 SET IBOK=1
SET IBFILE=""
FOR
SET IBFILE=$ORDER(IBFILES(IBFILE))
if IBFILE=""
QUIT
Begin DoDot:1
+18 SET IBNODE=IBFILES(IBFILE)
+19 IF $$LOAD^IBCRHBR2(IBPATH,IBFILE,$PIECE(IBNODE,U,1),$PIECE(IBNODE,U,2),VERS)
QUIT
+20 WRITE !!," Error while processing host file, can not continue!",!!
SET IBOK=0
End DoDot:1
IF 'IBOK
QUIT
+21 ;
+22 IF +IBOK
WRITE !!,"Upload of Reasonable Charges v"_VERS_" Host Files Complete.",!
+23 IF +$$FNDXTMP(.IBFILES)
Begin DoDot:1
+24 WRITE !!,"The following files were created in XTMP, they will be purged in 2 days:"
+25 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=""
KILL ^XTMP("IBCR RC SITE")
FOR
SET IBX=$ORDER(ARR(IBX))
if IBX=""
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
+13 ;
+14 ;
RELOAD() ; check for existing files stored in XTMP with same subscript (these may be reloaded or re-used)
+1 ; returns 0 if host files already loaded/defined, 1 if not defined and need to be loaded, -1 if ^
+2 ;
+3 NEW IBFILES,ARR,IBX,IBZ,DIR,DIRUT,DUOUT,X,Y
SET IBZ=1
+4 ;
+5 DO FILES^IBCRHBRV(.IBFILES)
+6 ;
+7 IF +$$FNDXTMP(.IBFILES)
Begin DoDot:1
+8 SET IBZ=0
WRITE !!,"These files already exist in XTMP:",!,"----------------------------------"
+9 ;
+10 DO DSPXTMP(.IBFILES,.ARR)
if $DATA(ARR)<10
QUIT
WRITE !
+11 SET DIR("?")="Enter either 'Y' or 'N'. These files use the same name as the new upload would use. You may either use these files to calculate RC charges or reload the Host files."
+12 SET DIR("A")="Delete the above XTMP files and reload the Host files"
SET DIR(0)="Y"
DO ^DIR
IF $DATA(DIRUT)
SET IBZ=-1
QUIT
+13 ;
+14 IF Y=1
SET IBZ=1
SET IBX=""
KILL ^XTMP("IBCR RC SITE")
FOR
SET IBX=$ORDER(ARR(IBX))
if IBX=""
QUIT
KILL ^XTMP(IBX)
WRITE "."
End DoDot:1
+15 ;
+16 QUIT IBZ
+17 ;
TMESS ; display message for test accounts (IB*2*138: loading test version of files not needed after release of v1)
+1 WRITE *7,*7,*7
+2 WRITE !,?10,"**** Will Load Test Version of Reasonable Charge Files ****"
+3 WRITE !!,"This appears to be a test account, the test version of the files will be loaded."
+4 WRITE !,"The test version of the charges should only be loaded into test accounts."
+5 WRITE !,"If this is not a test account but a live production account then do not load",!,"the charges! Contact support."
+6 WRITE !!,?3,"**** If this is a production account do not continue, Contact Support ****",!!
+7 QUIT
+8 ;
PROD() ; return true if production version of the files should be loaded
+1 ; test account
NEW IBX
SET IBX=0
IF +$$PROD^IBCORC
SET IBX=1
+2 QUIT IBX
