source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS1.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.2 KB
Line 
1IBCRHBS1 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC 2+) SETUP ; 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 ;
5HOSTLOAD(VERS) ; upload national REASONABLE CHARGES files from Host files into ^XTMP
6 ;
7 N X,Y,IBFILES,IBPATH,IBFILE,IBNODE,IBOK S IBOK=0,VERS=+$G(VERS)
8 W @IOF,!,"Upload National Reasonable Charges v"_VERS_" Host Files to Temporary Vista files"
9 W !,"--------------------------------------------------------------------------------",!
10 ;
11 S IBPATH=$$PATH I IBPATH<0 G HLEND
12 ;
13 D FILES^IBCRHBRV(.IBFILES,VERS) ; list of files to be loaded
14 ;
15 I '$$FNDHOST(.IBFILES,IBPATH) G HLEND ; all host files found
16 ;
17 I '$$CONT(.IBFILES) G HLEND
18 I '$$CONT1 G HLEND
19 ;
20 W @IOF,!,"Loading National Reasonable Charges v"_VERS_" Host Files into temporary local file"
21 W !,"--------------------------------------------------------------------------------"
22 ;
23 S IBOK=1,IBFILE="" F S IBFILE=$O(IBFILES(IBFILE)) Q:IBFILE="" D I 'IBOK Q
24 . S IBNODE=IBFILES(IBFILE)
25 . I $$LOAD^IBCRHBS2(IBPATH,IBFILE,$P(IBNODE,U,1),$P(IBNODE,U,2),VERS,$P(IBNODE,U,3)) Q
26 . W !!," Error while processing host file, can not continue!",!! S IBOK=0
27 ;
28 I +IBOK W !!,"Upload of Reasonable Charges v"_VERS_" Host Files Complete.",!
29 I +$$FNDXTMP(.IBFILES) D
30 . W !!,"The following files were created in XTMP, they will be purged in 2 days:"
31 . W !,"------------------------------------------------------------------------" D DSPXTMP(.IBFILES)
32HLEND Q IBOK
33 ;
34CONT(FILES) ; check for existing files stored in XTMP with same subscript
35 ; returns true if user wants to continue, any existing files are deleted
36 ;
37 N ARR,IBX,IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=1
38 ;
39 I +$$FNDXTMP(.FILES) D
40 . S IBZ=0 W !!,"These files already exist in XTMP:",!,"----------------------------------"
41 . ;
42 . D DSPXTMP(.FILES,.ARR) Q:$D(ARR)<10 W !
43 . 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."
44 . S DIR("A")="Delete the above files and continue with the upload",DIR(0)="Y" D ^DIR K DIR
45 . ;
46 . I Y=1 S IBZ=1,IBX="IBCR RC" F S IBX=$O(^XTMP(IBX)) Q:IBX'["IBCR RC" K ^XTMP(IBX) W "."
47 ;
48 Q IBZ
49 ;
50CONT1() ; get final OK to start upload, return true if want to continue with upload
51 N IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=0 W !!
52 S DIR("?")="Enter either 'Y' or 'N'. Enter 'Y' if you want to load the Reasonable Charges Host files into XTMP."
53 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
54 Q IBZ
55 ;
56PATH() ; return directory or -1
57 N IBPATH,DIR,DIRUT,DUOUT,X,Y S IBPATH=""
58 S DIR("?",1)="Enter the full path specification where the host files may be found"
59 S DIR("?")="or press return for the default directory "_$$PWD^%ZISH
60 S DIR(0)="FO^3:60",DIR("A")="Enter the file path",DIR("B")=$$PWD^%ZISH D ^DIR K DIR
61 S IBPATH=$S($D(DUOUT)!$D(DTOUT):-1,1:Y)
62 Q IBPATH
63 ;
64FNDXTMP(FILES) ; find if any existing files in XTMP, return true if any found
65 N IBFILE,IBXRF,IBNODE,IBZ S IBZ=0
66 ;
67 S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D Q:+IBZ
68 . S IBXRF="IBCR RC "_$P(FILES(IBFILE),U,2) Q:$D(^XTMP(IBXRF))=0 S IBZ=1
69 Q IBZ
70 ;
71DSPXTMP(FILES,ARR) ; display any existing files in XTMP, ARR passed by ref can be used to get list of existing file subscripts
72 N IBFILE,IBXRF,IBNODE,IBY K ARR
73 ;
74 S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D
75 . S IBXRF="IBCR RC "_$P(FILES(IBFILE),U,2) I $D(^XTMP(IBXRF))=0 Q
76 . S ARR(IBXRF)="",IBNODE=$G(^XTMP(IBXRF,0)),IBY=$S($P(IBNODE,U,3)="":IBXRF,1:$P(IBNODE,U,3))
77 . W !,?4,$E(IBY,1,67),?74,$P(IBNODE,U,5)
78 Q
79 ;
80FNDHOST(FILES,IBPATH) ; find and display any Host files available for upload, return true if all required files found
81 N IBX,IBY,IBZ,IBF,IBFILE,X,Y S IBF=1
82 W !!,"Reasonable Charges Host Files found: ",?44,IBPATH,!,"------------------------------------"
83 ;
84 I $O(FILES(""))="" S IBF=0
85 ;
86 S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D
87 . S IBX(IBFILE)="",IBZ=$$LIST^%ZISH(IBPATH,"IBX","IBY") K IBX,IBY
88 . W !,$P(FILES(IBFILE),U,1),":",?45,IBFILE I 'IBZ W ?57,"*** not found ***" S IBF=0
89 ;
90 I 'IBF W !!,"Can not find all required host files, can not continue!",!!
91 I +IBF W !!,"All required host files found.",!
92 Q IBF
Note: See TracBrowser for help on using the repository browser.