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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1IBJDF61 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE) ;15-APR-00
2 ;;2.0;INTEGRATED BILLING;**123,159,356**;21-MAR-94
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ST ; - Tasked entry point.
6 K IB,IBCAT,^TMP("IBJDF6P",$J),^TMP("IBJDF6D",$J) S IBQ=0
7 ;
8 ; - Set selected categories for report.
9 I IBSEL[",1," S IBCAT(21)=1 ; MEDICARE
10 I IBSEL[2 S IBCAT(7)=2 ; NO-FAULT AUTO ACCIDENT
11 I IBSEL[3 S IBCAT(10)=3 ; TORT FEASOR
12 I IBSEL[4 S IBCAT(6)=4 ; WORKMEN'S COMP
13 I IBSEL[5 S IBCAT(16)=5 ; CURRENT EMPLOYEE
14 I IBSEL[6 S IBCAT(15)=6 ; EX-EMPLOYEE
15 I IBSEL[7 S IBCAT(13)=7 ; FEDERAL AGENCIES-REFUND
16 I IBSEL[8 S IBCAT(14)=8 ; FEDERAL AGENCIES-REIMBURSEMENT
17 I IBSEL[9 S IBCAT(20)=9 ; MILITARY
18 I IBSEL[10 S IBCAT(12)=10 ; INTERAGENCY
19 I IBSEL[11 S IBCAT(17)=11 ; VENDOR
20 ;
21 ; Initialize the Summary Information
22 S IBCAT="" F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
23 . S IBDIV=0
24 . I IBSDV," 6 7 10 21 "[(" "_IBCAT_" ") D Q
25 . . F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D INIT^IBJDF63
26 . D INIT^IBJDF63
27 ;
28 ; - Print the header line for the Excel spreadsheet
29 I $G(IBEXCEL) D PHDL
30 ;
31 ; - Find data required for the report.
32 S IBA=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
33 . I IBA#100=0 D Q:IBQ
34 . . S IBQ=$$STOP^IBOUTL("Miscellaneous Bills Follow-Up Report")
35 . S IBAR=$G(^PRCA(430,IBA,0)) Q:'IBAR
36 . S IBCAT=+$P(IBAR,U,2) Q:'$D(IBCAT(IBCAT)) ; Invalid AR category.
37 . S IBCAT1=IBCAT(IBCAT) I IBCAT1<5,'$D(^DGCR(399,IBA,0)) Q ; No claim.
38 . I IBCAT1<5,$P($G(^DGCR(399,IBA,0)),U,13)=7 Q ; Cancelled claim.
39 . ;
40 . ; - Get division, if necessary.
41 . I IBCAT1>4 S IBDIV=0
42 . E D
43 . . I 'IBSDV S IBDIV=0
44 . . E S IBDIV=$$DIV^IBJDF51(IBA)
45 . ;
46 . I IBSDV,IBDIV,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
47 . ;
48 . ; - Get patient or debtor for report.
49 . I IBRPT="D" S IBPTDB=$$PTDB(IBA) Q:IBPTDB=""
50 . ;
51 . ; - Check the receivable age, if necessary.
52 . I IBRPT="D",IBSMN D I (IBARD)<IBSMN!(IBARD>IBSMX) Q
53 . . S IBARD=+$$ACT^IBJDF2(IBA) S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD)
54 . ;
55 . ; - Check the minimum balance amount, if necessary.
56 . S IBBA=0 F X=1:1:5 S IBBA=IBBA+$P($G(^PRCA(430,IBA,7)),U,X)
57 . I IBRPT="D",IBSAM,IBBA<IBSAM Q
58 . ;
59 . ; - Get stats for summary
60 . I '$G(IBEXCEL) D EN^IBJDF63 Q:IBRPT="S"
61 . ;
62 . ; - Get remaining AR/claim info and set indexes for detailed report.
63 . S (IBFR,IBLP,IBOI,IBTO,IBCLM)="",IBIN=0
64 . S IBBN=$P(IBAR,U),IBOR=$P(IBAR,U,3),IBDP=$P(IBAR,U,10)
65 . I IBCAT1<5 D Q:'IBI!('IBCLM)
66 . . S IBI=+$G(^DGCR(399,IBA,"MP")) Q:'IBI ; Get primary ins carrier.
67 . . S IBIN=$P($G(^DIC(36,IBI,0)),U)_"@@"_IBI,DFN=$P($P(IBPTDB,U),"@@",2)
68 . . S IBDP=$P(IBAR,U,10),IBCLM=$$CLMACT^IBJD(IBA,IBCAT) Q:IBCLM=""
69 . . S IBR=$S(+IBCLM=1:$G(^IB($P(IBCLM,U,2),0)),+IBCLM=2:$G(^DGCR(399,IBA,"U")),1:IBDP)
70 . . S IBFR=$P(IBR,U,$S(+IBCLM=1:14,1:1)),IBTO=$P(IBR,U,$S(+IBCLM=1:15,+IBCLM=2:2,1:1))
71 . . S IBOI=$$OTH(DFN,$P(IBIN,"@@",2),IBFR) ; Get other insurance carrier.
72 . . I $G(IBEXCEL) Q
73 . . I '($D(^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U)))#10) D
74 . . . S ^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U))=$P(IBPTDB,U,2)_" "_$P(IBPTDB,U,6)_U_$P(IBPTDB,U,3,4)_U_IBOI
75 . . S ^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U),IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA
76 . E D
77 . . S IBLP=+$P($$PYMT^IBJD1(IBA),U,2)
78 . . I '($D(^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U)))#10) D
79 . . . S ^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U))=$P(IBPTDB,U,2)_" "_$P(IBPTDB,U,6)
80 . . S ^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U),IBBN)=IBDP_U_$P(IBPTDB,U,5)_U_IBOR_U_IBLP_U_IBBA
81 . ;
82 . I '$G(IBEXCEL) D:IBSH COM Q
83 . ;
84 . ; - Set up and write line for Excel document.
85 . S IBDIV=$P($G(^DG(40.8,$S('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)
86 . S IBEXCEL1=IBDIV_U_$P($G(^PRCA(430.2,IBCAT,0)),U,2)_U_$S(IBIN=0:"",1:$P(IBIN,"@@"))
87 . S IBEXCEL1=IBEXCEL1_U_$P(IBPTDB,U,2)_U_$S($P(IBPTDB,"^",6)="*":"E",1:"")_U_$TR($P(IBPTDB,U,4),"-")
88 . S IBEXCEL1=IBEXCEL1_U_$P(IBPTDB,U,3)_U_IBOI_U_IBBN_U_$$DT^IBJD(IBDP,1)
89 . S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBFR,1)_U_$$DT^IBJD(IBTO,1)_U_IBOR
90 . S IBEXCEL1=IBEXCEL1_U_IBLP_U_IBBA_U
91 . I IBSH D COM ; This will capture the Last Comment Date
92 . S IBD=$$FMDIFF^XLFDT(DT,$S('$P(IBEXCEL1,U,17):IBDP,1:$G(DAT)))
93 . S IBEXCEL1=IBEXCEL1_U_IBD W !,IBEXCEL1 K IBD,IBEXCEL1
94 ;
95 I 'IBQ,'$G(IBEXCEL) D EN^IBJDF62 ; Print the report.
96 ;
97ENQ K ^TMP("IBJDF6P",$J),^TMP("IBJDF6D",$J)
98 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
99 ;
100 D ^%ZISC
101ENQ1 K IBA,IBA1,IBAR,IBARD,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBIN,IBQ,IBR,IBOI,IBBA
102 K IBBN,IBCLM,IBDP,IBEXCEL,IBFR,IBLP,IBOR,IBPTDB,IBTO,IBTYP,COM
103 K COM1,DAT,DFN,J,X,X1,X2,Y,Z
104 Q
105 ;
106PTDB(X) ; - Find Patient/Debtor and decide to include the AR.
107 ; Input: X=Pointer to the AR in file #430 plus all IBS* variables
108 ; Output: Y=Sort key (name or last 4) and Patient/Debtor IEN(file #2)
109 ; ^ Patient/Debtor name (1st 25 chars) ^ Age ^ SSN
110 ; ^ Processed by (File #200) ^ Current VA Employee? (*=Yes)
111 N AGE,ALL,ARZ,CAT,DEB,DA,DFN,DIC,DIQ,DR,END,IBZ,INI,KEY,NAME,PRC,SSN
112 N VA,VADM,VAERR,Y
113 ;
114 S Y="" I '$G(X) G PDQ
115 S DFN=0,ARZ=$G(^PRCA(430,X,0)),CAT=$P(ARZ,"^",2)
116 S (NAME,AGE,SSN,PRC)=""
117 ;
118 ; - Look for Patient(Medicare,Tort Feasor,Work's Comp,No-Fault Auto Acc)
119 I " 6 7 10 21 "[(" "_CAT_" ") D I 'DFN S Y="" G PDQ
120 . I '$D(^DGCR(399,X,0)) Q
121 . S IBZ=^DGCR(399,X,0),DFN=+$P(IBZ,"^",2)
122 . S INI=IBSNF,END=IBSNL,ALL=IBSNA
123 . D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
124 . S KEY=$S(IBSN="N":NAME,1:$P(SSN,"-",3))
125 ;
126 ; - Look for Debtor (All the other Categories)
127 I " 6 7 10 21 "'[(" "_CAT_" ") D I 'DFN S Y="" G PDQ
128 . S DIC="^PRCA(430,",DA=X,DR="9;97",DIQ="DEB" D EN^DIQ1
129 . S DFN=+$P(ARZ,"^",9) I 'DFN Q
130 . S NAME=$G(DEB(430,DA,9)),PRC=$G(DEB(430,DA,97)),KEY=NAME
131 . S DIC="^RCD(340,",DA=DFN,DR="110",DIQ="DEB" D EN^DIQ1
132 . S SSN=$G(DEB(340,DA,110)) S:SSN=-1 SSN=""
133 . S INI=IBSDF,END=IBSDL,ALL=IBSDA
134 ;
135 I (INI'="@"&('DFN)) S Y="" G PDQ
136 I ALL="ALL"&('DFN)!(ALL="NULL"&(DFN)) S Y="" G PDQ
137 I INI="@",END="zzzzz" G PDC
138 I INI]KEY!(KEY]END) S Y="" G PDQ
139 ;
140 S KEY=KEY_"@@"_DFN
141PDC S Y=KEY_U_$E(NAME,1,25)_U_AGE_U_SSN_U_PRC_U_$$VAEMP(+$TR(SSN,"-"))
142PDQ Q Y
143 ;
144PHDL ; - Print the header line for the Excel spreadsheet
145 N X
146 S X="Division^Cat.^Prim.Ins.Carrier^Patient/Debtor^VA Empl.?^SSN^Age^"
147 S X=X_"Other Ins.Carrier^Bill #^Dt Bill prep.^Bill From Dt^Bill To Dt^"
148 S X=X_"Orig.Amt^Lst Pymt Amt^Curr.Bal.^Lst Comm.Dt^Days Lst Comm."
149 W !,X
150 Q
151 ;
152VAEMP(SSN) ; - Check if the Patient/Debtor is a current VA Employee
153 ; Input: SSN - Patient/Debtor Social Security Number
154 ;Output: VAEMP - "*":Current VA Employee / "":Not a Current VA Employee
155 ;
156 N IEN I 'SSN Q ""
157 S IEN=+$O(^PRSPC("SSN",SSN,0)) Q:'IEN ""
158 I $P($G(^PRSPC(IEN,1)),U,33)'="Y" Q "*"
159 Q ""
160 ;
161OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).
162 ; Input: DFN=Pointer to the patient in file #2
163 ; INS=Pointer to the patient's primary carrier in file #36
164 ; DS=Date of service for validity check
165 ; Output: Valid insurance carrier (first 22 chars.) or null
166 N Y S Y="" G:'$G(DFN)!('$G(DS)) OTHQ
167 S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D:X Q:Y]""
168 .I $G(INS),+X=INS Q
169 .S X1=$G(^DIC(36,+X,0)) Q:X1=""
170 .I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,22)
171 ;
172OTHQ Q Y
173 ;
174COM ; - Get bill comments.
175 N IBGLB,DAT,IBA1,IBC,COM,COM1,X1,X2
176 ;
177 S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)
178 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
179 . S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC
180 . I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)<IBSH2 Q ; Comment age not minimum.
181 . I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q ; Not decrease/comment transact.
182 . S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)
183 . I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q
184 . ;
185 . ; - Append brief and transaction comments.
186 . K COM,COM1 S COM(0)=DAT,X1=0
187 . S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)
188 . S COM1(2)=$E($P($G(^PRCA(433,IBA1,8)),U,6),1,70)
189 . S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
190 . I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
191 . ;
192 . ; - Get main comments.
193 . S X2=0 F S X2=$O(^PRCA(433,IBA1,7,X2)) Q:'X2 S COM($S(X1:X2+1,1:X2))=^(X2,0)
194 . ;
195 . S X1="" F S X1=$O(COM(X1)) Q:X1="" D
196 . . S IBGLB=$S(IBCAT1<5:"IBJDF6P",1:"IBJDF6D")
197 . . S ^TMP(IBGLB,$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U),IBBN,IBA1,X1)=COM(X1)
198 ;
199 Q
Note: See TracBrowser for help on using the repository browser.