source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBAAV5.m@ 1611

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

initial load of FOIAVistA 6/30/08 version
File size: 7.8 KB
Line 
1FBAAV5 ;AISC/GRR-CREATE TRANSACTIONS FOR CH/CNH PAYMENTS ;11 Apr 2006 2:54 PM
2 ;;3.5;FEE BASIS;**3,55,89,98**;JAN 30, 1995;Build 54
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 D CKB9V^FBAAV01 I $G(FBERR) K FBERR Q
5 G:FBSTAT="S"&(FBCHB="Y")&($P(Y(0),"^",18)'="Y") ^FBAAV6
6DETCH S FBTXT=0
7 F K=0:0 S K=$O(^FBAAI("AC",J,K)) Q:K'>0 S Y(0)=$G(^FBAAI(K,0)),Y(2)=$G(^(2)) I Y(0)]"",+$P(Y(0),U,9) D
8 .N FBPICN,FBY
9 .S FBPICN=K
10 .S FBY=$S($P(Y(2),U,2):$P(Y(2),U,2),1:$P(Y(0),U,2))_U_+$P(Y(2),U,3)
11 .I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01,STORE^FBAAV01,UPD^FBAAV0
12 .D GOT
13 D:FBTXT XMIT^FBAAV01 Q
14GOT ; process an inpatient invoice
15 N DFN,FBADJ,FBADJA,FBADJR,FBADMIT,FBAUTHF,FBCDAYS,FBDISDT,FBDISTY,FBNPI
16 N FBDRG,FBIENS,FBPA,FBPNAMX,FBVMID,FBX
17 S FBIENS=K_","
18 I '$L($G(FBAASN)) D STATION^FBAAUTL
19 S FBPSA=$$PSA(+$P(Y(0),U,20),+$G(FBAASN)) I $L(+FBPSA)'=3 S FBPSA=999
20 S FBPAYT=$P(Y(0),"^",13),FBPAYT=$S(FBPAYT]"":FBPAYT,1:"V")
21 S L=$P(Y(0),"^",3)
22 S FBVID=$S($D(^FBAAV(L,0)):$P(^(0),"^",2),1:"")
23 S FBNPI=$$EN^FBNPILK(L)
24 S FBVID=FBVID_$E(PAD,$L(FBVID)+1,11)
25 S:FBPAYT="R" FBVID=$E(PAD,1,11)
26 S FBVMID=$S($D(^FBAAV(L,0)):$P(^(0),"^",17),1:"")
27 S FBVMID=$E(PAD,$L(FBVMID)+1,6)_FBVMID
28 S POV=$P(Y(0),"^",18)
29 S POV=$S(POV']"":"",POV="A":6,POV="B":7,POV="C":8,POV="D":9,POV="E":10,1:POV),POV=$S(POV']"":40,$D(^FBAA(161.82,POV,0)):$P(^(0),"^",3),1:40),FBPOV=POV
30 S FBPATT=$P(Y(0),"^",19),FBPATT=$S(FBPATT]"":FBPATT,1:10)
31 S FBFTD=$$AUSDT^FBAAV3($P(Y(0),"^",6)) ; from treatment date
32 S FBTTD=$$AUSDT^FBAAV3($P(Y(0),"^",7)) ; to treatment date
33 S FBSUSP=$P(Y(0),"^",11),FBSUSP=$S(FBSUSP="":" ",$D(^FBAA(161.27,FBSUSP,0)):$P(^(0),"^",1),1:" ")
34 S FBINVN=$P(Y(0),"^",1)
35 S FBINVN=$E("000000000",$L(FBINVN)+1,9)_FBINVN
36 S FBDIN=$$AUSDT^FBAAV3($P(Y(0),"^",2)) ; invoice date rec'd
37 S FBAP=$$AUSAMT^FBAAV3($P(Y(0),"^",9),8)
38 S FBAC=$$AUSAMT^FBAAV3($P(Y(0),"^",8),8)
39 S FBPA=$$AUSAMT^FBAAV3($P(Y(0),"^",26),8)
40 S FBDRG=$P(Y(0),"^",24),FBDRG=$E(PAD,$L(FBDRG)+1,4)_FBDRG
41 S FBAUTHF=$S($P(Y(0),U,5)["FB583":"U",1:"A") ; auth/unauth flag
42 K FBDX,FBPRC F I=1:1:5 S (FBDX(I),FBPRC(I))=" "
43 I $D(^FBAAI(K,"DX")) S Y("DX")=^("DX") F M=1:1:5 Q:$P(Y("DX"),"^",M)="" S FBDX(M)=$$SPACES^FBCSV1($$ICD9^FBCSV1(+$P(Y("DX"),"^",M),$P($G(Y(0)),"^",6)),7) I $L(FBDX(M))<7 S FBDX(M)=$E(PAD,$L(FBDX(M))+1,7)_FBDX(M)
44 I $D(^FBAAI(K,"PROC")) S Y("PROC")=^("PROC") F M=1:1:5 Q:$P(Y("PROC"),"^",M)="" S FBPRC(M)=$$SPACES^FBCSV1($$ICD0^FBCSV1($P(Y("PROC"),"^",M),$P($G(Y(0)),"^",6)),7) I $L(FBPRC(M))<7 S FBPRC(M)=$E(" ",$L(FBPRC(M))+1,7)_FBPRC(M)
45 S DFN=$P(Y(0),"^",4)
46 ; Note: Prior to the following line Y(0) = the 0 node of file 162.5
47 ; After the line Y(0) will equal the 0 node of file #2
48 S VAPA("P")="",Y(0)=$S($D(^DPT(DFN,0)):^(0),1:"")
49 D PAT^FBAAUTL2
50 ; obtain date of birth, must follow call to PAT^FBAAUTL2 to overwrite
51 ; the value returned from it
52 S FBDOB=$$AUSDT^FBAAV3($P(Y(0),"^",3))
53 D ADD^VADPT
54 S FBPNAMX=$$HL7NAME^FBAAV4(DFN) ; patient name
55 S FBST=$S($P(VAPA(5),"^",1)="":" ",$D(^DIC(5,$P(VAPA(5),"^",1),0)):$P(^(0),"^",2),1:" ")
56 S:$L(FBST)'=2 FBST=$E(PAD,$L(FBST)+1,2)_FBST
57 S FBCTY=$S($P(VAPA(7),"^",1)="":" ",FBST=" ":" ",$D(^DIC(5,$P(VAPA(5),"^",1),1,$P(VAPA(7),"^",1),0)):$P(^(0),"^",3),1:" ")
58 I $L(FBCTY)'=3 S FBCTY=$E("000",$L(FBCTY)+1,3)_FBCTY
59 S FBZIP=$S('+$G(VAPA(11)):VAPA(6),+VAPA(11):$P(VAPA(11),U),1:VAPA(6)),FBZIP=$TR(FBZIP,"-","")_$E("000000000",$L(FBZIP)+1,9)
60 S FBADMIT=$$AUSDT^FBAAV3($P($$B9ADMIT(FBIENS),".")) ; admission date
61 ; get and format discharge date and type
62 S FBX=$$B9DISCHG(FBIENS)
63 S FBDISDT=$$AUSDT^FBAAV3($P($P(FBX,U),".")) ; discharge date
64 S FBDISTY=$$RJ^XLFSTR($P(FBX,U,2),3,0) ; discharge type
65 K FBX
66 ; get volume indicator (covered days)
67 S FBCDAYS=$$RJ^XLFSTR($$GET1^DIQ(162.5,FBIENS,54),5,"0")
68 ; obtain and format the adjustment codes and amounts
69 ; get and format adjustment reason codes and amounts (if any)
70 D LOADADJ^FBCHFA(FBIENS,.FBADJ)
71 S FBX=$$ADJL^FBUTL2(.FBADJ)
72 S FBADJR=$$RJ^XLFSTR($P(FBX,U,1),5," ")
73 S FBADJA=$$AUSAMT^FBAAV3($P(FBX,U,3),9,1)
74 K FBADJ,FBX
75 ;
76 S FBSTR=9_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_" "_" "_FBAP_FBAAON_FBSUSP_FBPOV_FBPATT_FBFTD_FBTTD_FBDIN_FBINVN_FBVMID_FBST_FBCTY_FBZIP_FBPSA_$P(FBY,U,2)_$E(PAD,1,14)
77 F I=1:1:5 S FBSTR=FBSTR_FBDX(I)
78 S FBSTR=FBSTR_$$PADZ^FBAAV01(FBPICN,23)_$$AUSDT^FBAAV3(+FBY)_"~"
79 D STORE^FBAAV01
80 ;
81 ; build 2nd line
82 S FBSTR=""
83 F I=1:1:5 S FBSTR=FBSTR_FBPRC(I)
84 S FBSTR=FBSTR_" "_FBAC_" "_FBPA_FBDRG_" "_FBADMIT_FBDISDT_FBDOB_FBDISTY_FBCDAYS_FBAUTHF_FBADJR_" "_FBADJA_FBNPI_"~$"
85 D STORE^FBAAV01
86 ;
87 Q
88 ;
89PSA(X,Y) ;call to set default Primary Service Area (PSA)
90 ;to send to Austin.
91 ;X = pointer to the institution file
92 ;Y = default if unable to determine station number in file 4
93 ;call returns the 3 digit station number only
94 ;if Y undef return '0'
95 I '$G(Y) S Y=0
96 Q $S('X:+Y,$E($P($G(^DIC(4,+X,99)),U),1,3)'?3N:+Y,1:$E($P($G(^(99)),U),1,3))
97 ;
98B9ADMIT(FBIENS) ; Determine Admission Date for a B9 payment
99 ; input
100 ; FBIENS
101 ; returns admission date in internal FileMan format or null value
102 N FB7078,FBRET
103 S FBRET=""
104 ;
105 S FB7078=$$GET1^DIQ(162.5,FBIENS,4,"I") ; associated 7078/583
106 ;
107 ; if invoice points to a 7078 authorization then get date from the 7078
108 I $P(FB7078,";",2)="FB7078(" D
109 . N FBY
110 . S FBY=$G(^FB7078(+FB7078,0))
111 . ; if fee program is civil hospital then return 7078 date of admission
112 . I $P(FBY,U,11)=6 S FBRET=$P(FBY,U,15)
113 . ; if fee program is CNH then return 7078 authorized from date
114 . I $P(FBY,U,11)=7 S FBRET=$P(FBY,U,4)
115 ;
116 ; if invoice points to an unauthorized claim then use the treatment from
117 ; date on the unauthorized claim
118 I $P(FB7078,";",2)="FB583(" D
119 . N FBY
120 . S FBY=$G(^FB583(+FB7078,0))
121 . S FBRET=$P(FBY,U,5)
122 ;
123 ; return the result
124 Q FBRET
125 ;
126B9DISCHG(FBIENS) ; Determine Discharge Date and Type for a B9 payment
127 ; input
128 ; FBIENS - Invoice IEN (file 162.5) with trailing comma
129 ; returns discharge date in internal FileMan format or null value and
130 ; discharge type or null value
131 N FB7078,FBDISDT,FBDISTY
132 S (FBDISDT,FBDISTY)=""
133 ;
134 S FB7078=$$GET1^DIQ(162.5,FBIENS,4,"I") ; associated 7078/583
135 ;
136 ; if invoice points to an unauthorized claim then use the treatment to
137 ; date on the unauthorized claim
138 I $P(FB7078,";",2)="FB583(" D
139 . N FBY
140 . S FBY=$G(^FB583(+FB7078,0))
141 . S FBDISDT=$P(FBY,U,6)
142 . S FBDISTY=$$GET1^DIQ(162.5,FBIENS,"6.5:1") ; discharge type
143 ;
144 ; if invoice points to a 7078 authorization then get date from the 7078
145 I $P(FB7078,";",2)="FB7078(" D
146 . N FBY
147 . S FBY=$G(^FB7078(+FB7078,0))
148 . ;
149 . ; if fee program is civil hospital then return 7078 date of discharge
150 . I $P(FBY,U,11)=6 D
151 . . S FBDISDT=$P(FBY,U,16) ; discharge date
152 . . S FBDISTY=$$GET1^DIQ(162.5,FBIENS,"6.5:1") ; discharge type
153 . ;
154 . ; if fee program is CNH then get date & type from CNH activity file
155 . I $P(FBY,U,11)=7 D
156 . . N DFN,FBADMIT,FBADMITR,FBACTA,FBAUTHP,FBDA,FBDTR
157 . . S DFN=$P(FBY,U,3) ; patient IEN
158 . . S FBADMIT=$P($P(FBY,U,4),".") ; CNH admission date
159 . . S FBAUTHP=+$O(^FBAAA("AG",FB7078,DFN,0)) ; authorization 'pointer'
160 . . ;
161 . . ; find the admission entry in CNH ACTIVITY file
162 . . S FBACTA=0 ; init the admission activity ien
163 . . S FBADMITR=9999999-FBADMIT ; reverse admission date
164 . . S FBDTR=9999999-$$FMADD^XLFDT(FBADMIT,1) ; start loop
165 . . F S FBDTR=$O(^FBAACNH("AF",DFN,FBDTR)) Q:'FBDTR!($P(FBDTR,".")>FBADMITR) D Q:FBACTA
166 . . . S FBDA=0 F S FBDA=$O(^FBAACNH("AF",DFN,FBDTR,FBDA)) Q:'FBDA D
167 . . . . S FBY=$G(^FBAACNH(FBDA,0))
168 . . . . I $P(FBY,U,3)="A",$P(FBY,U,10)=FBAUTHP S FBACTA=FBDA ; found it
169 . . Q:'FBACTA ; could not find the admission activity
170 . . ;
171 . . ; get date from associated discharge (if any) in CNH ACTIVITY file
172 . . S FBDA=" "
173 . . F S FBDA=$O(^FBAACNH("AC",FBACTA,FBDA),-1) Q:FBDA'>0 D Q:FBDISDT
174 . . . S FBY=$G(^FBAACNH(FBDA,0))
175 . . . I $P(FBY,U,3)="D" D
176 . . . . S FBDISDT=$P($P(FBY,U),".")
177 . . . . S FBDISTY=$P(FBY,U,8)
178 . . . . I FBDISTY'="" S FBDISTY=FBDISTY+100
179 ;
180 ; return the result
181 Q FBDISDT_"^"_FBDISTY
182 ;
183 ;FBAAV5
Note: See TracBrowser for help on using the repository browser.