source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBR1.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: 5.8 KB
Line 
1IBCRHBR1 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC) SETUP ; 10-OCT-1998
2 ;;2.0;INTEGRATED BILLING;**106,138,148**;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 I '$$FNDHOST(.IBFILES,IBPATH) G HLEND ; all host files found
15 ;
16 I '$$CONT(.IBFILES) G HLEND
17 I '$$CONT1 G HLEND
18 ;
19 W @IOF,!,"Loading National Reasonable Charges v"_VERS_" Host Files into temporary local file"
20 W !,"--------------------------------------------------------------------------------"
21 ;
22 S IBOK=1,IBFILE="" F S IBFILE=$O(IBFILES(IBFILE)) Q:IBFILE="" D I 'IBOK Q
23 . S IBNODE=IBFILES(IBFILE)
24 . I $$LOAD^IBCRHBR2(IBPATH,IBFILE,$P(IBNODE,U,1),$P(IBNODE,U,2),VERS) Q
25 . W !!," Error while processing host file, can not continue!",!! S IBOK=0
26 ;
27 I +IBOK W !!,"Upload of Reasonable Charges v"_VERS_" Host Files Complete.",!
28 I +$$FNDXTMP(.IBFILES) D
29 . W !!,"The following files were created in XTMP, they will be purged in 2 days:"
30 . W !,"------------------------------------------------------------------------" D DSPXTMP(.IBFILES)
31HLEND Q IBOK
32 ;
33CONT(FILES) ; check for existing files stored in XTMP with same subscript
34 ; returns true if user wants to continue, any existing files are deleted
35 ;
36 N ARR,IBX,IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=1
37 ;
38 I +$$FNDXTMP(.FILES) D
39 . S IBZ=0 W !!,"These files already exist in XTMP:",!,"----------------------------------"
40 . ;
41 . D DSPXTMP(.FILES,.ARR) Q:$D(ARR)<10 W !
42 . 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."
43 . S DIR("A")="Delete the above files and continue with the upload",DIR(0)="Y" D ^DIR K DIR
44 . ;
45 . I Y=1 S IBZ=1,IBX="" K ^XTMP("IBCR RC SITE") F S IBX=$O(ARR(IBX)) Q:IBX="" K ^XTMP(IBX) W "."
46 ;
47 Q IBZ
48 ;
49CONT1() ; get final OK to start upload, return true if want to continue with upload
50 N IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=0 W !!
51 S DIR("?")="Enter either 'Y' or 'N'. Enter 'Y' if you want to load the Reasonable Charges Host files into XTMP."
52 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
53 Q IBZ
54 ;
55PATH() ; return directory or -1
56 N IBPATH,DIR,DIRUT,DUOUT,X,Y S IBPATH=""
57 S DIR("?",1)="Enter the full path specification where the host files may be found"
58 S DIR("?")="or press return for the default directory "_$$PWD^%ZISH
59 S DIR(0)="FO^3:60",DIR("A")="Enter the file path",DIR("B")=$$PWD^%ZISH D ^DIR K DIR
60 S IBPATH=$S($D(DUOUT)!$D(DTOUT):-1,1:Y)
61 Q IBPATH
62 ;
63FNDXTMP(FILES) ; find if any existing files in XTMP, return true if any found
64 N IBFILE,IBXRF,IBNODE,IBZ S IBZ=0
65 ;
66 S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D Q:+IBZ
67 . S IBXRF="IBCR RC "_$P(FILES(IBFILE),U,2) Q:$D(^XTMP(IBXRF))=0 S IBZ=1
68 Q IBZ
69 ;
70DSPXTMP(FILES,ARR) ; display any existing files in XTMP, ARR passed by ref can be used to get list of existing file subscripts
71 N IBFILE,IBXRF,IBNODE,IBY K ARR
72 ;
73 S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D
74 . S IBXRF="IBCR RC "_$P(FILES(IBFILE),U,2) I $D(^XTMP(IBXRF))=0 Q
75 . S ARR(IBXRF)="",IBNODE=$G(^XTMP(IBXRF,0)),IBY=$S($P(IBNODE,U,3)="":IBXRF,1:$P(IBNODE,U,3))
76 . W !,?4,$E(IBY,1,67),?74,$P(IBNODE,U,5)
77 Q
78 ;
79FNDHOST(FILES,IBPATH) ; find and display any Host files available for upload, return true if all required files found
80 N IBX,IBY,IBZ,IBF,IBFILE,X,Y S IBF=1
81 W !!,"Reasonable Charges Host Files found: ",?44,IBPATH,!,"------------------------------------"
82 ;
83 I $O(FILES(""))="" S IBF=0
84 ;
85 S IBFILE="" F S IBFILE=$O(FILES(IBFILE)) Q:IBFILE="" D
86 . S IBX(IBFILE)="",IBZ=$$LIST^%ZISH(IBPATH,"IBX","IBY") K IBX,IBY
87 . W !,$P(FILES(IBFILE),U,1),":",?45,IBFILE I 'IBZ W ?57,"*** not found ***" S IBF=0
88 ;
89 I 'IBF W !!,"Can not find all required host files, can not continue!",!!
90 I +IBF W !!,"All required host files found.",!
91 Q IBF
92 ;
93 ;
94RELOAD() ; check for existing files stored in XTMP with same subscript (these may be reloaded or re-used)
95 ; returns 0 if host files already loaded/defined, 1 if not defined and need to be loaded, -1 if ^
96 ;
97 N IBFILES,ARR,IBX,IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=1
98 ;
99 D FILES^IBCRHBRV(.IBFILES)
100 ;
101 I +$$FNDXTMP(.IBFILES) D
102 . S IBZ=0 W !!,"These files already exist in XTMP:",!,"----------------------------------"
103 . ;
104 . D DSPXTMP(.IBFILES,.ARR) Q:$D(ARR)<10 W !
105 . 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."
106 . 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
107 . ;
108 . I Y=1 S IBZ=1,IBX="" K ^XTMP("IBCR RC SITE") F S IBX=$O(ARR(IBX)) Q:IBX="" K ^XTMP(IBX) W "."
109 ;
110 Q IBZ
111 ;
112TMESS ; display message for test accounts (IB*2*138: loading test version of files not needed after release of v1)
113 W *7,*7,*7
114 W !,?10,"**** Will Load Test Version of Reasonable Charge Files ****"
115 W !!,"This appears to be a test account, the test version of the files will be loaded."
116 W !,"The test version of the charges should only be loaded into test accounts."
117 W !,"If this is not a test account but a live production account then do not load",!,"the charges! Contact support."
118 W !!,?3,"**** If this is a production account do not continue, Contact Support ****",!!
119 Q
120 ;
121PROD() ; return true if production version of the files should be loaded
122 N IBX S IBX=0 I +$$PROD^IBCORC S IBX=1 ; test account
123 Q IBX
Note: See TracBrowser for help on using the repository browser.