source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBT.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: 5.2 KB
Line 
1IBCRHBT ;LL/ELZ - RATES: UPLOAD HOST FILES (TP) ; 19-MAR-1999
2 ;;2.0;INTEGRATED BILLING;**115,140**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5TP ; OPTION: upload an IBAT file from a VMS file into ^XTMP
6 ;
7 N DIR,DIRUT,DUOUT,X,Y,IBI,IBFILE,IBPATH,IBXRF,IBLOC,IBXRF1,IBXRF2,IBFLINE,IBX,IBY,IBTYPE,POP,IBCHRG,IBCODE
8 N IBCPT,IBEFDT,IBTRDT,IBINACT,IBMOD,IBCHG,IBPATH
9 W !!,"Upload the IBAT from a host file: 'IBATaxxxx.TXT' w/a = C for CPT or D for DRG",!,?49," & xxxx = year effective",!
10 ;
11 S IBPATH=$$PATH I IBPATH<0 Q
12 I '$$FNDHOST(IBPATH) Q
13 ;I '$$FNDHOST Q
14 ;
15 S DIR("?")="Enter an IBAT Host File Name of format: 'IBATaxxxx.TXT' w/xxxx = year effective"
16 S DIR(0)="FO^3:60",DIR("A")="Enter a Host File Name" D ^DIR K DIR Q:$D(DIRUT) S IBFILE=Y
17 ;
18 I $$CHECK(IBFILE) Q
19 ;
20 ;
21 S IBXRF="IBCR UPLOAD "_IBFILE,IBLOC="" I '$$CONT(IBXRF) Q
22 I '$$CONT1 Q
23 ;
24 ;
25 D OPEN^%ZISH("IBAT UPLOAD",IBPATH,IBFILE,"R") I POP W !!,"**** Unable to open ",IBPATH,IBFILE,! Q
26 ;
27 U IO(0) W !!,"Loading ",IBFILE," into ^XTMP "
28 ;
29 S IBI=0 F S IBI=IBI+1 U IO R IBFLINE:5 Q:$$ENDF D PARSE,STORE I '(IBI#100) U IO(0) W "."
30 ;
31 D CLOSE^%ZISH("IBAT UPLOAD")
32 ;
33 ;
34 W !!,"Done. ",(IBI-1)," lines processed."
35 W !,"The following files were created, they will be purged in 2 days:" D DISP1^IBCRHU1(IBXRF)
36 Q
37 ;
38ENDF() N IBX S IBX=1 I $T,IBFLINE'="" S IBX=0
39 I $$STATUS^%ZISH S IBX=1
40 I 'IBX,IBFLINE'?3U29N D
41 . U IO(0)
42 . W !!,"**** Error while reading file: line not expected format"
43 . W !,"(3 upper case letters & 29 numeric characters):"
44 . W !!,"Line Length=",$L(IBFLINE)," characters" W:IBFLINE="" ?40,"Line read is null"
45 . W !,"LINE='",IBFLINE,"'",!!,"Upload Aborted!"
46 . S IBX=1 H 7 U IO
47 I IBI=1,IBFLINE="" U IO(0) W !!,"First line of file has no data, can not continue!" S IBX=1 H 7 U IO
48 Q IBX
49 ;
50PARSE ; process a single line from an IBAT file: parse out into individual fields and store the line in XTMP
51 ;
52 ; format: 3 alpha letters and 29 numbers
53 ;
54 S IBTYPE=$E(IBFLINE,1,3) ; type, either CPT or DRG
55 S IBCODE=$E(IBFLINE,4,8) ; CPT procedure or DRG code
56 I IBTYPE="DRG" S IBCODE=IBTYPE_+IBCODE
57 S IBCHRG=$E(IBFLINE,9,16) ; charge
58 S IBEFDT=$E(IBFLINE,17,24) ; effective date
59 S IBTRDT=$E(IBFLINE,25,32) ; termination date
60 S IBCS=$$CS(IBTYPE)
61 Q
62 ;
63STORE ;
64 S IBXRF1=IBXRF_" "_IBLOC
65 ;
66 S IBMOD="",IBEFDT=$$DATE(IBEFDT),IBINACT="" I IBTRDT'=999999,+IBTRDT S IBINACT=$$DATE(IBTRDT)
67 ;
68 I +IBCHRG S IBXRF2=IBTYPE,IBCHG=$E(IBCHRG,1,6)_"."_$E(IBCHRG,7,8) D SET ; charge
69 ;
70 Q
71 ;
72DATE(X) ; reformats dates
73 N Y,DTOUT,%DT
74 I X S %DT="X" D ^%DT
75 Q $G(Y,X)
76SET ;
77 N IBX S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR
78 S $P(^XTMP(IBXRF1,0),U,4)=+$P(IBX,U,4)+1
79 S ^XTMP(IBXRF1,IBXRF2)=(+$G(^XTMP(IBXRF1,IBXRF2))+1)_U_$S(IBTYPE="CPT":2,1:4)_U_IBCS
80 S ^XTMP(IBXRF1,IBXRF2,IBI)=IBCODE_U_IBEFDT_U_IBINACT_U_+IBCHG
81 Q
82 ;
83SETHDR ;
84 N IBX S IBX="IB upload of Host file "_IBFILE_", on "_$$HTE^XLFDT($H,2)_" by "_$P($G(^VA(200,+$G(DUZ),0)),U,1)
85 S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX
86 Q
87 ;
88CONT(XREF) ; check for existing files stored in XREF with same host file name
89 ; returns true if user wants to continue and these files are deleted
90 ;
91 N ARR,IBX,IBY,IBZ,DIR,DIRUT,DUOUT,X,Y S ARR=0,IBZ=1 W !
92 ;
93 D DISP1^IBCRHU1(XREF,.ARR)
94 ;
95 I +ARR S IBZ=0 D W !
96 . 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."
97 . S DIR("A")="Delete the above files and continue with upload",DIR(0)="Y" D ^DIR K DIR
98 . ;
99 . I Y=1 S IBZ=1,IBX="" F S IBX=$O(ARR(IBX)) Q:IBX="" K ^XTMP(IBX) W "."
100 ;
101 Q IBZ
102 ;
103 ;
104CONT1() ; get final OK to start upload
105 N IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=0 W !
106 S DIR("A")="Proceed with upload now",DIR(0)="Y" D ^DIR K DIR I Y=1 S IBZ=1
107 Q IBZ
108 ;
109PATH() ; return directory or -1
110 N IBPATH,DIR,DIRUT,DUOUT,X,Y S IBPATH=""
111 S DIR("?",1)="Enter the full path specification where the host files may be found"
112 S DIR("?")="or press return for the default directory "_$$PWD^%ZISH
113 S DIR(0)="FO^3:60",DIR("A")="Enter the file path",DIR("B")=$$PWD^%ZISH D ^DIR K DIR
114 S IBPATH=$S($D(DUOUT)!$D(DTOUT):-1,1:Y)
115 Q IBPATH
116 ;
117FNDHOST(IBPATH) ; find and display any host files available for upload: 1 if some, 0 none found
118 N IBX,IBY,IBZ,IBQ S (IBZ,IBQ)=0
119 ;
120 W !,"IBAT Host files available for upload in: ",IBPATH,!!
121 S IBX("IBAT*.TXT")="",IBZ=$$LIST^%ZISH(IBPATH,"IBX","IBY")
122 I +IBZ S IBQ=IBZ,IBX="" F S IBX=$O(IBY(IBX)) Q:IBX="" W ?30,$P(IBX,";",1),!
123 K IBX,IBY S IBX("TP*.TXT")="",IBZ=$$LIST^%ZISH(IBPATH,"IBX","IBY")
124 I 'IBZ,'IBQ W "**** No IBAT files found ",IBPATH,"IBATaxxxx.TXT, can not continue.",!
125 I +IBZ S IBX="" F S IBX=$O(IBY(IBX)) Q:IBX="" W ?30,$P(IBX,";",1),!
126 Q $S(IBQ:IBQ,1:IBZ)
127 ;
128CS(X) ; find charge set ien from X (name)
129 N IBX S X=$S(X="CPT":"TP-OPT",X="DRG":"TP-INPT",1:""),IBX=0
130 I X'="" S IBX=$O(^IBE(363.1,"B",X,IBX))
131 Q IBX
132 ;
133CHECK(IBFILE) ; returns if file name is not in correct format
134 N IBZ S IBZ=1
135 I ($E(IBFILE,1,4)="IBAT"),(($E(IBFILE,5)="C")!($E(IBFILE,5)="D")),($E(IBFILE,6,9)?4N),($E(IBFILE,10,13)=".TXT") S IBZ=0
136 I IBZ,($E(IBFILE,1,2)="TP"),(($E(IBFILE,3)="C")!($E(IBFILE,3)="D")),($E(IBFILE,4,7)?4N),($E(IBFILE,8,11)=".TXT") S IBZ=0
137 I IBZ W !!,"**** File not an IBAT file: must be 'IBATaxxxx.TXT'.",!
138 Q IBZ
Note: See TracBrowser for help on using the repository browser.