source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBC2.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: 3.5 KB
Line 
1IBCRHBC2 ;ALB/ARH - RATES: UPLOAD HOST FILES (CMAC 2000+) ; 14-FEB-2000
2 ;;2.0;INTEGRATED BILLING;**124**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; ROUTINE SPECIFIC FOR FORMAT OF YEAR 2000+ CMAC FILES
6 ;
7CMAC(IBPATH,IBFILE,IBNAME,IBMODP,IBMODT) ; upload CMAC file from a VMS file into ^XTMP
8 N X,Y,IBI,IBXRF,IBLOC,IBDONE,IBXRF1,IBXRF2,IBFLINE,IBINACT,IBMOD,IBCHG
9 N IBCPT,IBCL1,IBCL2,IBCL34,IBEFDT,IBTRDT,IBCL1P,IBCL1T,IBCL4P,IBCL4T
10 ;
11 S IBXRF=IBNAME_IBFILE,IBLOC="",IBDONE=""
12 ;
13 D OPEN^%ZISH("CMAC UPLOAD",IBPATH,IBFILE,"R") I POP W !!,"**** Unable to open ",IBPATH,IBFILE,! G CMACQ
14 ;
15 U IO(0) W !!,"Loading ",IBFILE," into ^XTMP "
16 ;
17 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 "."
18 ;
19 D CLOSE^%ZISH("CMAC UPLOAD")
20 ;
21 S IBDONE=(IBI-1)_U_IBXRF
22 ;
23CMACQ Q IBDONE
24 ;
25ENDF() N IBX S IBX=1 I $T,IBFLINE'="" S IBX=0
26 I $$STATUS^%ZISH S IBX=1
27 I 'IBX,'$$LNFORM(IBFLINE) D
28 . U IO(0)
29 . W !!,"**** Error while reading file: line not expected format (91 numeric characters):"
30 . W !!,"Line Length=",$L(IBFLINE)," characters" W:IBFLINE="" ?40,"Line read is null"
31 . W !,"LINE='",IBFLINE,"'",!!,"Upload Aborted!"
32 . S IBX=1 H 7 U IO
33 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
34 Q IBX
35 ;
36LNFORM(LINE) ; check an individual line of the file for proper format
37 N IBX S IBX=0,LINE=$G(LINE) I (LINE?91N)!(LINE?3N1A87N) S IBX=1
38 Q IBX
39 ;
40PARSE ; process a single lin from a CMAC file: parse out into individual fields and store the line in XTMP
41 ;
42 S IBLOC=$E(IBFLINE,1,3) ; locality
43 S IBCPT=$E(IBFLINE,4,8) ; CPT procedure
44 S IBCL1=$E(IBFLINE,9,16) ; class 1 charge
45 S IBCL2=$E(IBFLINE,17,24) ; class 2 charge
46 S IBCL34=$E(IBFLINE,25,32) ; class 3&4 charge
47 S IBEFDT=$E(IBFLINE,36,43) ; effective date
48 S IBTRDT=$E(IBFLINE,52,59) ; termination date
49 S IBCL1P=$E(IBFLINE,60,67) ; class 1 professional component
50 S IBCL1T=$E(IBFLINE,68,75) ; class 1 technical component
51 S IBCL4P=$E(IBFLINE,76,83) ; class 4 professional component
52 S IBCL4T=$E(IBFLINE,84,91) ; class 4 technical component
53 Q
54 ;
55STORE ;
56 S IBXRF1=IBXRF_" "_IBLOC
57 ;
58 S IBMOD="",IBEFDT=$$DATE(IBEFDT),IBINACT="" I IBTRDT'=99999999,+IBTRDT S IBINACT=$$DATE(IBTRDT)
59 ;
60 I +IBCL1 S IBXRF2="CLASS 1",IBCHG=$E(IBCL1,1,6)_"."_$E(IBCL1,7,8) D SET ; class 1 charge
61 I +IBCL2 S IBXRF2="CLASS 2",IBCHG=$E(IBCL2,1,6)_"."_$E(IBCL2,7,8) D SET ; class 2 charge
62 I +IBCL34 S IBXRF2="CLASS 3&4",IBCHG=$E(IBCL34,1,6)_"."_$E(IBCL34,7,8) D SET ; class 3&4 charge
63 ;
64 I +IBMODP,+IBCL1P S IBXRF2="CLASS 1 PC",IBCHG=$E(IBCL1P,1,6)_"."_$E(IBCL1P,7,8),IBMOD=IBMODP D SET
65 I +IBMODT,+IBCL1T S IBXRF2="CLASS 1 TC",IBCHG=$E(IBCL1T,1,6)_"."_$E(IBCL1T,7,8),IBMOD=IBMODT D SET
66 ;
67 I +IBMODP,+IBCL4P S IBXRF2="CLASS 4 PC",IBCHG=$E(IBCL4P,1,6)_"."_$E(IBCL4P,7,8),IBMOD=IBMODP D SET
68 I +IBMODT,+IBCL4T S IBXRF2="CLASS 4 TC",IBCHG=$E(IBCL4T,1,6)_"."_$E(IBCL4T,7,8),IBMOD=IBMODT D SET
69 ;
70 Q
71 ;
72SET ;
73 N IBX S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR
74 S $P(^XTMP(IBXRF1,0),U,4)=+$P(IBX,U,4)+1
75 S ^XTMP(IBXRF1,IBXRF2)=(+$G(^XTMP(IBXRF1,IBXRF2))+1)_U_2
76 S ^XTMP(IBXRF1,IBXRF2,IBI)=IBCPT_U_IBEFDT_U_IBINACT_U_+IBCHG_U_IBMOD
77 Q
78 ;
79SETHDR ;
80 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)
81 S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX
82 Q
83 ;
84 ;
85DATE(DATE) ; return yymmdd in FM format
86 N IBX S IBX="" I $G(DATE)?8N S IBX=$S($E(DATE,1,2)<20:"2",1:"3")_$E(DATE,3,8)
87 Q IBX
88 ;
89 ;
90LNDT(LINE) ; return the date of an individual line, in FM format
91 N IBX S IBX=$E($G(LINE),36,43) S IBX=$$DATE(IBX)
92 Q IBX
Note: See TracBrowser for help on using the repository browser.