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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.1 KB
Line 
1IBJDF51 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (COMPILE);15-APR-00
2 ;;2.0;INTEGRATED BILLING;**123,185,240,356**;21-MAR-94
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ST ; - Tasked entry point.
6 K IB,^TMP("IBJDF5",$J) S IBQ=0
7 ;
8 ; - Set selected categories for report.
9 I IBSEL[1 S IBCAT(31)=1
10 I IBSEL[2 S IBCAT(19)=2
11 I IBSEL[3 S IBCAT(30)=3
12 I IBSEL[4 S IBCAT(32)=4
13 I IBSEL[5 S IBCAT(29)=5
14 I IBSEL[6 S IBCAT(28)=6
15 ;
16 ; Initialize the Summary Information
17 S IBCAT="" F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
18 . S IBDIV=0
19 . I IBSD,IBCAT'=31 D Q
20 . . F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D INIT^IBJDF53
21 . D INIT^IBJDF53
22 ;
23 ; - Print the header line for the Excel spreadsheet
24 I $G(IBEXCEL) D PHDL
25 ;
26 ; - Find data required for the report.
27 S IBA=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
28 . I IBA#100=0 D Q:IBQ
29 . . S IBQ=$$STOP^IBOUTL("CHAMPVA/Tricare Follow-Up Report")
30 . S IBAR=$G(^PRCA(430,IBA,0)) Q:'IBAR
31 . I $P($G(^DGCR(399,IBA,0)),U,13)=7 Q ; Cancelled claim.
32 . S IBCAT=+$P(IBAR,U,2) Q:'$D(IBCAT(IBCAT)) ; Invalid AR category.
33 . S IBCAT1=IBCAT(IBCAT)
34 . ;
35 . ; - Get division, if necessary.
36 . I IBCAT1=1 S IBDIV=0 ; CHAMPVA/Tricare Patient
37 . ;
38 . I IBCAT1'=1 D ; Others
39 . . I 'IBSD S IBDIV=0 Q
40 . . S IBDIV=$$DIV(IBA)
41 . ;
42 . I IBSD,IBDIV,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
43 . ;
44 . ; - Determine whether AR has corresponding IB action or claim and
45 . ; whether action/claim is inpatient, outpatient, or RX refill.
46 . S IBAC=$$CLMACT^IBJD(IBA,IBCAT) Q:IBAC=""!(+IBAC=3)
47 . I +IBAC=1 D
48 . . S X=$P($G(^IB($P(IBAC,U,2),0)),U,3)
49 . . S X=$P($G(^IBE(350.1,X,0)),U)
50 . . S IBTYP=$S(X["RX":3,X["OPT":2,1:1)
51 . I +IBAC'=1 D
52 . . S IBTYP=$S($P($G(^DGCR(399,IBA,0)),U,5)>2:2,1:1)
53 . . I $D(^IBA(362.4,"C",IBA)) S IBTYP=3
54 . ;
55 . I IBSEL1'[IBTYP,IBSEL1'[4 Q
56 . ;
57 . I IBRPT="D" S IBPT=$$PAT(IBA) Q:IBPT="" ; Get patient info.
58 . ;
59 . I '$G(IBEXCEL) D EN^IBJDF53 Q:IBRPT="S" ; Get stats for summary.
60 . ;
61 . ; - Get insurance info.
62 . S (IBI,IBIN)=0
63 . I $G(^DGCR(399,IBA,"MP")) D I 'IBI Q
64 . . S IBI=+$G(^DGCR(399,IBA,"MP")) I 'IBI S IBIN="*** UNKNOWN ***" Q
65 . . S IBIN=$P($G(^DIC(36,IBI,0)),U)_"@@"_IBI
66 . ;
67 . ; - Check the receivable age, if necessary.
68 . I IBSMN D Q:IBARD<IBSMN!(IBARD>IBSMX)
69 . . S IBARD=+$$ACT^IBJDF2(IBA) S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD)
70 . ;
71 . ; - Check the minimum balance amount, if necessary.
72 . S IBBA=0 F X=1:1:5 S IBBA=IBBA+$P($G(^PRCA(430,IBA,7)),U,X)
73 . I IBSAM,IBBA<IBSAM Q
74 . ;
75 . ; - Get remaining AR/claim information.
76 . S IBDP=$P(IBAR,U,10),X=$$CLMACT^IBJD(IBA,IBCAT) Q:X=""
77 . S IBBU=$S(+IBAC=1:$G(^IB($P(IBAC,U,2),0)),1:$G(^DGCR(399,IBA,"U")))
78 . S IBFR=$P(IBBU,U,$S(+IBAC=1:14,1:1))
79 . S IBTO=$P(IBBU,U,$S(+IBAC=1:15,1:2))
80 . S DFN=$P(IBPT,U,5),IBSID=$$SID(DFN,IBI)
81 . S IBOI=$$OTH(DFN,IBI,IBFR),IBVA=$$VA^IBJD1(DFN)
82 . S IBBN=$P(IBAR,U),IBOR=$P(IBAR,U,3)
83 . ;
84 . ; - Set up indexes for detail report.
85 . I $G(IBEXCEL) D Q
86 . . S IBDIV=$P($G(^DG(40.8,$S('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)
87 . . ;
88 . . S IBEXCEL1=$P(IBPT,U,2)_U_IBVA_U_$P(IBPT,U,3)_U_$TR($P(IBPT,U,4),"-")
89 . . S IBEXCEL1=IBEXCEL1_U_$S(IBIN=0:"",1:$E($P(IBIN,"@@"),1,12))_U_$E(IBOI,1,12)
90 . . S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBDP,1)_U_$$DT^IBJD(IBFR,1)
91 . . S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBTO,1)_U_IBSID_U_IBBN_U_IBOR
92 . . S IBEXCEL1=IBEXCEL1_U_IBBA_U_$P($G(^PRCA(430.2,IBCAT,0)),U,2)
93 . . S IBEXCEL1=IBEXCEL1_U_$E("IOR",IBTYP)_U
94 . . I IBSH D COM ; This will capture the Last Comment Date
95 . . S IBD=$$FMDIFF^XLFDT(DT,$S('$P(IBEXCEL1,U,16):IBDP,1:$G(DAT)))
96 . . S IBEXCEL1=IBEXCEL1_U_IBD_U_$E(IBDIV,1,12) W !,IBEXCEL1 K IBD,IBEXCEL1
97 . ;
98 . S IBKEY=$P(IBPT,U)_"@@"_$S($G(IBPT):IBDP,1:IBFR_"/"_IBTO)
99 . F X=IBTYP,4 I IBSEL1[X D
100 . . I '($D(^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY))#10) D
101 . . . S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY)=$P(IBPT,U,2)_" "_IBVA_U_$P(IBPT,U,3,4)_U_IBOI
102 . . S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY,IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA_U_IBSID
103 . . I IBSH D COM
104 ;
105 I 'IBQ,'$G(IBEXCEL) D EN^IBJDF52 ; Print the report.
106 ;
107ENQ K ^TMP("IBJDF5",$J)
108 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
109 ;
110 D ^%ZISC
111ENQ1 K IB,IBA,IBA1,IBAR,IBARD,IBBU,IBC,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBQ,IBPT
112 K IBDP,IBKEY,IBVA,IBAC,IBBA,IBBN,IBFR,IBIN,IBOI,IBOR,IBSID,IBTO,IBTYP
113 K COM,COM1,DAT,DFN,J,X,X1,X2,Y,Z D KVA^VADPT
114 Q
115 ;
116PAT(IBDA) ; - Find the claim patient and decide to include the claim.
117 ; Input: IBDA=Pointer to the claim/AR in file #399/#430 plus all
118 ; variable input in IBS*
119 ; Output: Y=Sort key (name or last 4)_@@_patient IEN to file #2
120 ; ^ Patient name ^ Age ^ SSN ^ Patient IEN to file #2
121 N AGE,ALL,ARZ,DA,DBTR,DFN,DIC,DIQ,DOB,DR,END,IBZ,INI,KEY,NAME,RCZ,SSN
122 N VADM,Y,Z
123 ;
124 S Y="" G:'$G(IBDA) PATQ
125 S DFN=0,(NAME,AGE,SSN)="",ARZ=$G(^PRCA(430,IBDA,0))
126 ;
127 ; - Look for Patient (Corresponding Claim in IB)
128 I $D(^DGCR(399,IBDA,0)) D I 'DFN S Y="" G PATQ
129 . S IBZ=^DGCR(399,IBDA,0),DFN=+$P(IBZ,"^",2)
130 . D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
131 ;
132 ; - Look for Debtor (No corresponding Claim in IB)
133 I '$D(^DGCR(399,IBDA,0)) D I 'DFN S Y="" G PATQ
134 . S DBTR=+$P(ARZ,"^",9) I 'DBTR Q
135 . S RCZ=$G(^RCD(340,DBTR,0)),DFN=+RCZ
136 . I $P(RCZ,"^")["DPT" D
137 . . D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
138 . I $P(RCZ,"^")'["DPT" D
139 . . S DIC="^PRCA(430,",DA=IBDA,DR=9,DIQ="DEB" D EN^DIQ1
140 . . S NAME=$G(DEB(430,DA,9)),KEY=NAME
141 . . S DIC="^RCD(340,",DA=DBTR,DR=110,DIQ="DEB" D EN^DIQ1
142 . . S SSN=$G(DEB(340,DA,110))
143 . . I SSN S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
144 ;
145 S KEY=$S(IBSN="N":NAME,1:+$P(SSN,"-",3))
146 S INI=IBSNF,END=IBSNL,ALL=IBSNA
147 I (INI'="@"&('DFN)) S Y="" G PATQ
148 I ALL="ALL"&('DFN)!(ALL="NULL"&(DFN)) S Y="" G PATQ
149 I INI="@",END="zzzzz" G PATC
150 I INI]KEY!(KEY]END) S Y="" G PATQ
151 ;
152PATC ; - Find all patient data.
153 S Y=KEY_"@@"_DFN_U_$E(NAME,1,25)_U_AGE_U_SSN_"^"_DFN
154PATQ Q Y
155 ;
156DIV(CLM) ;Find the default division of the bill.
157 S DIV=$P($G(^DGCR(399,CLM,0)),"^",22)
158QDIV S:'DIV DIV=$$PRIM^VASITE() S:DIV'>0 DIV=0
159 Q DIV
160SID(DFN,INS) ; - Find the subscriber ID for a bill (if any).
161 ; Input: DFN=Pointer to the patient in file #2
162 ; INS=Pointer to the patient's primary carrier in file #36
163 ; Output: Subscriber ID no. or null
164 N X,Y,Z S Y="" G:'$G(DFN)!('$G(INS)) SIDQ
165 S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D Q:Y]""
166 .I +X=INS S Y=$E($P(X,U,2),1,16)
167 ;
168SIDQ Q Y
169 ;
170PHDL ; - Print the header line for the Excel spreadsheet
171 N X
172 S X="Patient^VA Empl.?^Age^SSN^Prim.Ins.Carrier^Other Ins.Carrier^"
173 S X=X_"Dt Bill prep.^Bill From Dt^Bill To Dt^Subsc.ID^Bill #^"
174 S X=X_"Orig.Amt^Curr.Bal.^Cat.^Bill Type^Lst Comm.Dt^Days Lst Comm.^"
175 S X=X_"Division"
176 W !,X
177 Q
178 ;
179OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).
180 ; Input: DFN=Pointer to the patient in file #2
181 ; INS=Pointer to the patient's primary carrier in file #36
182 ; DS=Date of service for validity check
183 ; Output: Valid insurance carrier (first 15 chars.) or null
184 N X,X1,Y,Z S Y="" G:'$G(DFN)!('$G(INS))!('$G(DS)) OTHQ
185 S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D:X Q:Y]""
186 .I +X=INS Q
187 .S X1=$G(^DIC(36,+X,0)) Q:X1=""
188 .I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,15)
189 ;
190OTHQ Q Y
191 ;
192COM ; - Get bill comments.
193 S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)
194 F S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1 D I IBSH1="M",DAT Q
195 .S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC
196 .I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)<IBSH2 Q ; Comment age not minimum.
197 .I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q ; Not decrease/comment transact.
198 .S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)
199 .I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q
200 .;
201 .; - Append brief and transaction comments.
202 .K COM,COM1 S COM(0)=DAT,X1=0
203 .S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)
204 .S COM1(2)=$E($P($G(^PRCA(433,IBA1,8)),U,6),1,70)
205 .S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
206 .I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
207 .;
208 .; - Get main comments.
209 .S X2=0 F S X2=$O(^PRCA(433,IBA1,7,X2)) Q:'X2 S COM($S(X1:X2+1,1:X2))=^(X2,0)
210 .;
211 .S X1="" F S X1=$O(COM(X1)) Q:X1="" D
212 ..S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY,IBBN,IBA1,X1)=COM(X1)
213 ;
214 Q
Note: See TracBrowser for help on using the repository browser.