source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEDE6.m@ 1608

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

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1IBCNEDE6 ;DAOU/DAC - IIV DATA EXTRACTS ;15-OCT-2002
2 ;;2.0;INTEGRATED BILLING;**184,271,345**;21-MAR-94;Build 28
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q ; no direct calls allowed
6 ;
7INAC(IBCNCNT,MAXNUM,IBDDI,SRVICEDT,FDAYS,APPTFLG) ;Get Inactive Insurances
8 ; DAOU/BHS - 10/15/2002 - Replaced VRFDT w/ FDAYS (fresh days value)
9 ; APPTFLG - Appt extract flag ONLY set from IBCNEDE2 - optional 0/1
10 ;
11 NEW IDATA,INCP,IEN,TQIEN,INS,INACT,DATA1,DATA2,FRESHDT
12 NEW PAYER,PAYERID,RESULT,FOUND,SIDARRAY,SIDACT,SIDCNT,SID,INREC
13 ;
14 ; Need FOUND to avoid the creation of a no payer inquiry the day after
15 ; the original inquiry for pre-reg (appt) extract and no insurance
16 ; extract was created.
17 S FOUND=0 ; set flag to 1 if potential inquiry was found
18 ;
19 S APPTFLG=$G(APPTFLG)
20 S IDATA=$G(^IBE(350.9,1,51))
21 S INACT=$P(IDATA,U,8)
22 S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FDAYS)
23 ;
24 ; If the search for inactive insurances is 'No', quit
25 I 'INACT G INACX
26 ;
27 S INCP="" F S INCP=$O(IBDDI(INCP)) Q:INCP="" D Q:IBCNCNT'<MAXNUM
28 . S IEN="" F S IEN=$O(^DPT(DFN,.312,"B",INCP,IEN)) Q:IEN="" D
29 .. S INS=$P(^DPT(DFN,.312,IEN,0),U)
30 .. ;
31 .. ;Check for Medicare/Medicaid
32 .. I $$EXCLUDE^IBCNEUT4($P($G(^DIC(36,INS,0)),U)) Q
33 .. ;
34 .. ; Check for insurance company payer, etc.
35 .. S RESULT=$$INSERROR^IBCNEUT3("I",INS)
36 .. I $P(RESULT,U)'="" Q
37 .. ;
38 .. S PAYER=$P(RESULT,U,2),PAYERID=$P(RESULT,U,3)
39 .. I ('PAYER)!(PAYERID="") Q
40 .. ;
41 .. S FOUND=1 ; potential inquiry
42 .. ;
43 .. ; Update service date based on payer's allowed range
44 .. D UPDDTS(PAYER,.SRVICEDT,.FRESHDT)
45 .. ; update service dates for inquiries to be transmitted
46 .. D TQUPDSV^IBCNEUT5(DFN,PAYER,SRVICEDT)
47 .. ; check for outstanding/current entries in File 356.1
48 .. I '$$ADDTQ^IBCNEUT5(DFN,PAYER,SRVICEDT,FDAYS) Q
49 .. ;
50 .. ; Call function to set IIV TRANSMISSION QUEUE file #365.1
51 .. ;
52 .. K SIDARRAY
53 .. S SIDACT=$$SIDCHK2^IBCNEDE5(DFN,PAYER,.SIDARRAY,FRESHDT)
54 .. S SIDCNT=$P(SIDACT,U,2),SIDACT=$P(SIDACT,U)
55 .. ; Add to SIDCNT to compensate for a TQ entry w/ blank Sub ID
56 .. I SIDACT=5!(SIDACT=6)!(SIDACT=7)!(SIDACT=8) S SIDCNT=SIDCNT+1
57 .. I IBCNCNT+SIDCNT>MAXNUM S IBCNCNT=MAXNUM Q ; see if TQ entries will exceed MAXNUM
58 .. S SID="" F S SID=$O(SIDARRAY(SID)) Q:SID="" D
59 ... S INREC=$P(SID,"_",2) ; which patient ins rec ID is from
60 ... D INACSET($P(SID,"_"),INREC)
61 ... ;
62 .. ; Create TQ entry w/ blank Sub ID
63 .. I (SIDACT=5)!(SIDACT=6)!(SIDACT=7)!(SIDACT=8) S SID="" D INACSET("","")
64 K SIDARRAY
65INACX ;
66 Q FOUND
67 ;
68INACSET(SID,INREC) ; INAC. SET
69 ; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
70 ; status of file 365.1 to "Ready to Transmit"
71 N FRESH
72 S FRESH=$$FMADD^XLFDT(SRVICEDT,-FDAYS)
73 S DATA1=DFN_U_PAYER_U_1_U_""_U_SID_U_FRESH
74 ;
75 ; The hardcoded 1st piece of DATA2 tells file 365.1 which extract
76 ; it is.
77 I APPTFLG S DATA2=2 ; appt extract IBCNEDE2
78 I 'APPTFLG S DATA2=4 ; no ins extract IBCNEDE4
79 S DATA2=DATA2_U_"I"_U_SRVICEDT_U_$G(INREC)
80 ;
81 S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2)
82 I TQIEN'="" S IBCNCNT=IBCNCNT+1
83 ;
84 Q
85 ;
86UPDDTS(PIEN,SVDT,FRDT) ; Update service date and freshness date per payer
87 ; date parameters FUTURE SERVICE DAYS (365.121,.14) and PAST SERVICE
88 ; DAYS (365.121,.15)
89 ; Output:
90 ; SVDT - passed by reference - updates service date
91 ; FRDT - passed by reference - updates freshness date - except for
92 ; INAC where it is optional
93 N FDAYS,PDAYS,DIFF,AIEN,DATA,OSVDT,EDTFLG
94 ;
95 ; Init vars - save original service date to calc diff
96 S (FDAYS,PDAYS,EDTFLG)=0,OSVDT=SVDT
97 ; Determine Payer App IEN
98 S AIEN=$$PYRAPP^IBCNEUT5("IIV",PIEN)
99 I AIEN="" Q ; Quit without changing if app is not defined
100 S DATA=$G(^IBE(365.12,PIEN,1,AIEN,0))
101 I DATA="" Q ; Quit without changing if node is not defined
102 S FDAYS=$P(DATA,U,14),PDAYS=$P(DATA,U,15)
103 ; DAOU/WCW - Overriding this to allow service date of only today
104 ; for the time being - setting params to 0
105 S FDAYS=0,PDAYS=0
106 ; Process past service days if not null
107 I PDAYS'="" D
108 . ; If zero, reset to today
109 . I PDAYS=0 S SVDT=$$DT^XLFDT,EDTFLG=1
110 . ; If non-zero and service date is earlier than the allowed
111 . ; payer service date range, reset service date to earliest allowed
112 . ; date for the payer
113 . I PDAYS,SVDT<$$FMADD^XLFDT($$DT^XLFDT,-PDAYS+1) D
114 . . S SVDT=$$FMADD^XLFDT($$DT^XLFDT,-PDAYS+1),EDTFLG=1
115 ; Process future service days if not edited and if not null
116 I EDTFLG=0,FDAYS'="" D
117 . ; If zero, reset to today
118 . I FDAYS=0 S SVDT=$$DT^XLFDT,EDTFLG=1
119 . ; If non-zero and service date is later than the allowed
120 . ; payer service date range, reset service date to latest allowed
121 . ; date for the payer
122 . I FDAYS,SVDT>$$FMADD^XLFDT($$DT^XLFDT,FDAYS-1) D
123 . . S SVDT=$$FMADD^XLFDT($$DT^XLFDT,FDAYS-1),EDTFLG=1
124 ;
125 ; Determine if difference exists
126 I EDTFLG,$G(FRDT)'="" S FRDT=$$FMADD^XLFDT(FRDT,$$FMDIFF^XLFDT(SVDT,OSVDT))
127 ;
128 Q
129 ;
130BLANKTQ(SRVICEDT,FRESHDT,YDAYS,IBCNCNT) ;
131 ; This tag is only called from PROCESS^IBCNEDE4
132 ; No new records were created in file 365.1 for this DFN.
133 ; Need to check if an inquiry for any payer exists for this DFN within
134 ; the freshness period. If it doesn't exist create a new blank inquiry
135 ;
136 ; Input
137 ; SRVICEDT - Service Date
138 ; FRESHDT - Freshness Date
139 ; YDAYS -
140 ; IBCNCNT - updated - Counter for the extract
141 ;
142 I $$TFL^IBCNEDE6(DFN)=0 Q
143 ;
144 N PAYER,DATA1,DATA2,TQIEN
145 ;
146 S PAYER=$$FIND1^DIC(365.12,,"X","~NO PAYER")
147 ;
148 ; Update service date and freshness date based on payer allowed
149 ; date range
150 D UPDDTS^IBCNEDE6(PAYER,.SRVICEDT,.FRESHDT)
151 ;
152 ; Update service dates for inquiries to be transmitted
153 D TQUPDSV^IBCNEUT5(DFN,PAYER,SRVICEDT)
154 ;
155 ; Are we allowed to add it to the TQ file
156 I '$$ADDTQ^IBCNEUT5(DFN,PAYER,SRVICEDT,YDAYS,1) G BLANKXT
157 ;
158 ; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
159 ; status of file 365.1 to "Ready to Transmit"
160 S DATA1=DFN_U_PAYER_U_1_U_""_U_""_U_FRESHDT
161 ;
162 ; The hardcoded '4' in the 1st piece of DATA2 is the value to tell
163 ; the file 365.1 that it is the no active insurance extract.
164 S DATA2=4_U_"I"_U_SRVICEDT
165 ;
166 S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2),PAYER=""
167 I TQIEN'="" S IBCNCNT=IBCNCNT+1
168 ;
169BLANKXT ;
170 Q
171 ;
172TFL(DFN) ; Examines treating facility list,
173 ; value returned is 1 if patient has visited at least one other site
174 N IBC,IBZ,IBS
175 D TFL^VAFCTFU1(.IBZ,DFN) Q:-$G(IBZ(1))=1 0
176 S IBS=+$P($$SITE^VASITE,"^",3),(IBZ,IBC)=0
177 ; Look for remote facilities of type VAMC:
178 F S IBZ=$O(IBZ(IBZ)) Q:IBZ<1 I +IBZ(IBZ)>0,+IBZ(IBZ)'=IBS,$P(IBZ(IBZ),U,5)="VAMC" S IBC=1 Q
179 Q IBC
Note: See TracBrowser for help on using the repository browser.