source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMCUT1.m

Last change on this file was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 7.6 KB
Line 
1RCDMCUT1 ;HEC/SBW - Utility Functions for Hold Debt to DMC Project ;30/AUG/2007
2 ;;4.5;Accounts Receivable;**253**;Mar 20, 1995;Build 9
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6 ;
7HOLDCHK(IEN,DFN) ;Check if receivable shouldn't be sent to DMC
8 ;Dont refer receivables for veterans who are (return 1)
9 ; 1. "DMC Debt Valid" field = NULL and
10 ; SC 50% to 100% or in receipt of VA Pension and "DMC Debt Valid"
11 ; For this case only update DMC Debt Valid Field to Pending
12 ; 2. "DMC Debt Valid" is Pending or NO
13 ;Refer receivables for veterans who are (return 0)
14 ; 1. "DMC Debt Valid" is "YES"
15 ; 2. "DMC Debt Valid" is NULL and
16 ; not SC 50% to 100% and not in receipt of a VA Pensions
17 ;
18 ;INPUT
19 ; IEN - Internal Entry Number for Accounts Recievable File
20 ; DFN - Internal Entry Number to Patient (#2) file
21 ;OUTPUT
22 ; 1 - Don't sent the Debt to DMC
23 ; 0 - Debt can be sent to DMC
24 ;
25 N OUT,DMCVALID,DMCELIG
26 S OUT=0
27 ;Quit if invalid IEN or DFN passed
28 Q:$G(IEN)'>0!($G(DFN)'>0) OUT
29 ;Get DMC Debt Valid field
30 S DMCVALID=$$GET1^DIQ(430,+$G(IEN)_",",125,"E")
31 ;If DMC Debt Valid is No or Pending don't refer to DMC
32 S:DMCVALID="NO"!(DMCVALID="PENDING") OUT=1
33 ;If DMC Debt Valid is Yes refer to DMC
34 S:DMCVALID="YES" OUT=0
35 ;Check if Vet is SC 50% to 100% or in Receipt of VA Pension
36 S DMCELIG=+$$DMCELIG^RCDMCUT1(+$G(DFN))
37 ;If DMC Debt Valid is Null & SC 50% to 100% or Receiving VA Pension
38 ;refer to DMC
39 D:DMCVALID=""&(DMCELIG>0)
40 . S OUT=1
41 . ;Update DMC Valid Indicator to Pending
42 . D UPDTDMC^RCDMCUT1(IEN,"P",1)
43 ;If DMC Debt Valid is Null & NOT SC 50%to100% & NOT Receiving VA Pension
44 ;don't refer to DMC
45 S:DMCVALID=""&(DMCELIG'>0) OUT=0
46 Q OUT
47 ;
48DMCELIG(DFN) ;Checks Bill Debtor SC% and Receipt of VA Pension Values
49 ;INPUT:
50 ; DFN - Pointer Value to Patient (#2) file
51 ;OUTPUT:
52 ; Returns 0 if not SC 50% to 100% and not receiving a VA Pension
53 ; Returns "1^ SC % ^ VA Pension ^ A&A Benefits ^ Housbound Benefits"
54 ; if SC 50% to 100% or Receiving a VA Pension.
55 ; Should also consider Vets who are receiving A&A or
56 ; Housebound benefits as Receiving VA a VA Pension.
57 ; The 2nd piece will be the SC % if SC 50% to 100%.
58 ; The 3rd piece will be a 1 if Receiving a VA Pension.
59 ; If not SC 50% to 100% or Receiving a VA Pension then
60 ; The 4th piece will be the A&A Benefits.
61 ; The 5th piece will be the Housebound Benefits.
62 ;
63 N OUT
64 ;Protect the VADPT variables to prevent errors with ^RCDMC90 routine
65 N VAHOW,VAROOT,VAERR,VAEL,VAMB,VADM,VASV,VAPA,VATEST,VAOA,VAINDT,VAIN
66 N VAIP,VAPD,VARP,VASD,VA,VADMVT
67 S OUT=0
68 ;Quit if no DFN passed
69 Q:$G(DFN)'>0 OUT
70 ;Get Eligibility Data
71 D ELIG^VADPT
72 ;Quit if ^DPT(DFN,0) not defined
73 Q:$G(VAERR)>0 OUT
74 ;Get monetary benefit data
75 D MB^VADPT
76 ;SERVICE CONNECTED? Field- If SC the SC% returned in the 2nd piece.
77 S:$P($G(VAEL(3)),U,2)>49 $P(OUT,U,1)=1,$P(OUT,U,2)=$P(VAEL(3),U,2)
78 ;RECEIVING A VA PENSION?
79 S:$P($G(VAMB(4)),U,1)>0 $P(OUT,U,1)=1,$P(OUT,U,3)=$P(VAMB(4),U,1)
80 D:+OUT'>0
81 . ;RECEIVING A&A BENEFITS?
82 . S:$P($G(VAMB(1)),U,1)>0 $P(OUT,U,1)=1,$P(OUT,U,4)=$P(VAMB(1),U,1)
83 . ;RECEIVING HOUSEBOUND BENEFITS?
84 . S:$P($G(VAMB(2)),U,1)>0 $P(OUT,U,1)=1,$P(OUT,U,5)=$P(VAMB(2),U,1)
85 D KVAR^VADPT
86 Q OUT
87 ;
88UPDTDMC(IEN,VAL,DELBY) ;Update the DMC Debt Valid Field
89 ;INPUT
90 ; IEN - Internal Entry Number of Accounts Receivable (#430) file
91 ; VAL - DMC Debt Valid Value ("P", "Y", "N" or "@"),
92 ; If "@" pass the field will be deleted
93 ; DELBY - Used to delete the "DMC Debt Valid Edited By" field when
94 ; updated by the Nightly Background Job
95 ;Output
96 ; No output
97 ;
98 N DA,DIE,DR,X,Y
99 Q:$G(IEN)'>0
100 Q:"^Y^N^P^@^"'[(U_$G(VAL)_U)
101 L +^PRCA(430,IEN,12.1):30
102 ;Quit if another user is editing this entry
103 I '$T Q
104 S DA=IEN
105 S DIE=430
106 S DR="125////"_VAL
107 S:$G(DELBY)>0 DR=DR_";126///@"
108 D ^DIE
109 L -^PRCA(430,IEN,12.1)
110 Q
111 ;
112GETDEM(DFN) ; Get data from Patient (#2) file
113 ;INPUT:
114 ; DFN - Pointer Value to Patient (#2) file
115 ;OUTPUT:
116 ; DEM^VADPT VADM array as spelled out in PIMS Technical Manual
117 ;
118 ;Calling routines needs to New or Kill following Variables by calling
119 ; D KVAR^VADPT
120 ; VADM,VAERR,VA
121 ;
122 N OUT,Y
123 S OUT=0
124 ;Quit if no DFN passed
125 Q:$G(DFN)'>0 OUT
126 ;Get Demographic Data
127 D DEM^VADPT
128 ;Quit if ^DPT(DFN,0) not defined
129 Q:$G(VAERR)>0 OUT
130 ;Calls Successful
131 S OUT=1
132 Q OUT
133 ;
134FIRSTPAR(IEN430) ;Check if this is a First Party bill
135 ;INPUT
136 ; IEN430 - Internal Entry Number for Accounts Receivable File
137 ;OUTPUT
138 ; Returns a 0 if not First Party Bill
139 ; Returns a 1 if First Party Bill
140 ;
141 N FLD,FIRST,IEN340
142 ;Set default to zero
143 S FIRST=0
144 S IEN430=+$G(IEN430)
145 ;Get DEBTOR Field Value in Account Receivable File
146 S IEN340=+$P($G(^PRCA(430,IEN430,0)),U,9)
147 ;If .01 field in AR Debtor File points to the Patient file
148 ;then this is a First Party Debt
149 S FLD=$P($G(^RCD(340,IEN340,0)),U,1)
150 S:FLD["DPT" FIRST=1_U_$P(FLD,";",1)
151 Q FIRST
152 ;
153GETSERDT(BILLNUM) ; Get most recent Outpatient Date, Inpatient Date and RX Date
154 ; from the IB Action (#350) file for the corresponding bill
155 ;INPUT
156 ; BILLNUM - Bill No. (.01) field in AR (#430) file
157 ;OUTPUT
158 ; 0 - No data
159 ; 1 ^ Outpatient Date ^ Discharge Date ^ RX/Refill Date
160 N OUT,IEN
161 S OUT=0,IEN=0
162 ;Quit if a Bill Number wasn't passed
163 Q:$G(BILLNUM)']"" OUT
164 F S IEN=$O(^IB("ABIL",BILLNUM,IEN)) Q:IEN'>0 D
165 . N IBDATA,IENS,DFN,ACTTYPE,RESULT,DTBILLFR,BILGROUP,OPDT,DISCHARG,RXDT
166 . S IENS=IEN_","
167 . D GETS^DIQ(350,IENS,".02;.03;.04;.14","IN","IBDATA")
168 . S DFN=$G(IBDATA(350,IENS,.02,"I"))
169 . S ACTTYPE=$G(IBDATA(350,IENS,.03,"I"))
170 . S RESULT=$G(IBDATA(350,IENS,.04,"I"))
171 . S DTBILLFR=$G(IBDATA(350,IENS,.14,"I"))
172 . ;
173 . ;Child charge. Need to get Parent Charge
174 . I $P(RESULT,":",1)=350 D
175 . . S IENS=+$P(RESULT,":",2)_","
176 . . ;Quit if the entry is the parent
177 . . Q:+IENS=IEN
178 . . D GETS^DIQ(350,IENS,".02;.03;.04;.14","IN","IBDATA")
179 . . S DFN=$G(IBDATA(350,IENS,.02,"I"))
180 . . S ACTTYPE=$G(IBDATA(350,IENS,.03,"I"))
181 . . S RESULT=$G(IBDATA(350,IENS,.04,"I"))
182 . . S DTBILLFR=$G(IBDATA(350,IENS,.14,"I"))
183 . Q:$G(DFN)']""
184 . ;
185 . ;Get Billing Group in the IB Action Type File. If internal Set
186 . ;Code value is 4, then this is an Outpatient Visit (From STMT^IBRFN1)
187 . ;and can use Date Billed From for the Outpatient Visit Date
188 . S BILGROUP=$$GET1^DIQ(350.1,+ACTTYPE_",",.11,"I")
189 . ;
190 . ;Outpatient Event
191 . I BILGROUP=4!($P(RESULT,":",1)=44)!($P(RESULT,":",1)=409.68) D Q
192 . . I $P(RESULT,":",1)=44 S OPDT=$P($P(RESULT,";",2),":",2)
193 . . I $P(RESULT,":",1)=409.68 S OPDT=$$GET1^DIQ(409.68,+$P(RESULT,":",2)_",",.01,"I")
194 . . I $G(OPDT)'>0 S OPDT=DTBILLFR
195 . . I $G(OPDT)>$P(OUT,U,2) S $P(OUT,U,1)=1,$P(OUT,U,2)=OPDT
196 . ;
197 . ;Quit if RESULTING FROM field is blank
198 . Q:$G(RESULT)']""
199 . ;
200 . ;Inpatient Event
201 . I $P(RESULT,":",1)=405!($P(RESULT,":",1)=45) D Q
202 . . S VAIP("E")=$P($P(RESULT,";",1),":",2)
203 . . ;Call to get Inpatient data
204 . . D IN5^VADPT
205 . . Q:VAERR>0
206 . . S DISCHARG=$P($G(VAIP(17,1)),U,1)
207 . . ;Ensure get most current Discharge Date
208 . . I DISCHARG>$P(OUT,U,3) S $P(OUT,U,1)=1,$P(OUT,U,3)=DISCHARG
209 . . D KVAR^VADPT
210 . ;
211 . ;RX Event
212 . I $P(RESULT,":",1)=52 D Q
213 . . N PSOFILE,IENS,FLD
214 . . ;Set up for RX Refills
215 . . I $P(RESULT,";",2)]"" D
216 . . . S PSOFILE=52.1
217 . . . S IENS=+$P($P(RESULT,";",2),":",2)_","_+$P($P(RESULT,";",1),":",2)_","
218 . . . S FLD=.01
219 . . ;Set up for RX Data (No refill)
220 . . I $P(RESULT,";",2)']"" D
221 . . . S PSOFILE=52
222 . . . S IENS=+$P($P(RESULT,";",1),":",2)_","
223 . . . S FLD=1
224 . . ;Call Pharmacy API to get RX/Refill Date
225 . . S RXDT=$$GET1^PSODI(PSOFILE,IENS,FLD,"I")
226 . . ;Ensure get most current RX/Refill Date
227 . . I RXDT>$P(OUT,U,4) S $P(OUT,U,1)=1,$P(OUT,U,4)=$P(RXDT,U,2)
228 Q OUT
229 ;
Note: See TracBrowser for help on using the repository browser.