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

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

initial load of FOIAVistA 6/30/08 version

File size: 4.2 KB
Line 
1IBOTR2 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - COMPILATION ; 5-JUN-91
2 ;;2.0;INTEGRATED BILLING;**21,42,52,80,100,118,128**;21-MAR-94
3 ;
4 ;MAP TO DGCROTR2
5 ;
6 ;***
7 ;S XRTL=$ZU(0),XRTN="IBOTR-2" D T0^%ZOSV ;start rt clock
8 ;
9 I $G(IBXTRACT) D E^IBJDE(8,1) ; Change extract status.
10 ;
11 K ^TMP($J) S IBQUIT=0
12 S IBDA="" F S IBDA=$O(^DGCR(399,"AD",IBRT,IBDA)) Q:'IBDA D Q:IBQUIT
13 .D COMP I IBDA#100=0 S IBQUIT=$$STOP^IBOUTL("Trend Report")
14 ;
15 ; - Write the output report.
16 I 'IBQUIT D
17 .I 'IBSDIV D:"OP"[IBSORT SORT D EN^IBOTR3(0) Q
18 .S IBDIV=0 F S IBDIV=$S('VAUTD:$O(VAUTD(IBDIV)),1:$O(^DG(40.8,IBDIV))) Q:'IBDIV D:"OP"[IBSORT SORT D EN^IBOTR3(IBDIV) Q:IBQUIT
19 ;
20 ;***
21 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOTR2" D T1^%ZOSV ;stop rt clock
22ENQ I $D(ZTQUEUED) S ZTREQ="@" Q
23 K IB,IBAO,IBAP,IBCNT,IBDA,DFN,IBBC,DIC,DA,DR,DIQ,IBDP,IBDBC,IBSCF,IBSCT
24 K IBCFL,IBDIV,IBQUIT,IBEVT,^TMP($J) D ^%ZISC
25 Q
26 ;
27COMP ; - Compile Bill-Accounts Receivable records for report.
28 S IBD=$G(^DGCR(399,IBDA,0)) I IBD="" Q
29 ;
30 ; - Get division, if necessary.
31 I 'IBSDIV S IBDIV=0
32 E S IBDIV=$$DIV^IBJDF2(IBDA) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
33 I IBSDIV,'VAUTD,'$D(VAUTD(IBDIV)) Q ; Not a selected division.
34 ;
35 ; - Exclude receivables referred to Regional Counsel, if necessary.
36 I 'IBINRC,$P($G(^PRCA(430,IBDA,6)),U,4) Q
37 ;
38 S IBBN=$P(IBD,U),DFN=+$P(IBD,U,2),IBEVT=+$P(IBD,U,3),IBBC=$P(IBD,U,5)
39 S:IBBN="" IBBN="NULL" Q:IBBRT="O"&("12"[IBBC) Q:IBBRT="I"&("34"[IBBC)
40 S IBDBC=$$CLO^PRCAFN(IBDA) Q:IBARST="O"&(IBDBC>-2)!(IBARST="C"&(IBDBC<-1))
41 I IBDBC>0 S IBBN=IBBN_" *"
42 E S IBD=$P($$STA^PRCAFN(IBDA),U,2),IBDBC=$S($L(IBD)>8:$E(IBD,1,8),1:IBD)
43 I $D(IBBRN),IBBRN="S" S IBBRTY=$S("12"[IBBC:"I",1:"O")
44 ;
45 ; - Perform edits for insurance company.
46 S IBD=$P($G(^DGCR(399,IBDA,"MP")),U),IBINS=$P($G(^DIC(36,+IBD,0)),U)
47 I $G(IBICPT) Q:'$D(IBICPT(+IBD)) G CANC
48 I IBICF'="@",IBD="" Q
49 I $D(IBIC) Q:IBIC="ALL"&(IBD="") Q:IBIC="NULL"&(IBD]"")
50 I IBINS="" S IBINS="UNKNOWN" G CANC
51 I $G(IBIC)="ALL" G CANC
52 I IBICF="@",IBICL="zzzzz" G CANC
53 I IBICF]IBINS!(IBINS]IBICL) Q
54 ;
55CANC ; - Keep cancelled bills if CANCEL BILL? field was selected or answer
56 ; to 'Do you want to include cancelled receivables?' prompt was YES.
57 S IBCFL=0,IBINS=IBINS_"@@"_IBD Q:'$D(^DGCR(399,IBDA,"S")) S IBD=^("S")
58 S IBCNC=0 I "^26^39^"[(U_$P($G(^PRCA(430,IBDA,0)),U,8)_U) S IBCNC=1
59 I $G(IBCANC),($P(IBD,U,16)!(IBCNC)) S IBCFL=1 G PTDE ; Add canc. bill.
60 I $G(IBAF)'=16 Q:$P(IBD,U,16)!(IBCNC) ; Bill has been cancelled.
61 ;
62PTDE ; - Perform Printed/Treatment date edits.
63 S IBDP=$P(IBD,U,12)
64 I IBDF=1 Q:IBDP<IBBDT!(IBDP>IBEDT) ; Date printed is out of range.
65 S IBD=$G(^DGCR(399,IBDA,"U")),IBSCF=$P(IBD,U),IBSCT=$P(IBD,U,2)
66 I IBDF=2 Q:IBSCT<IBBDT!(IBSCF>IBEDT) ; Treatment dates out of range.
67 I '$D(IBAF) G BUILD
68 ;
69 ; - Find the selected field value and compare to selection parameters.
70 K IB S DIC=399,DA=IBDA,DR=IBAF,DIQ="IB" S:IBAFD DIQ(0)="I"
71 D EN^DIQ1 K DIQ S:IBAFD IB(399,IBDA,IBAF)=IB(399,IBDA,IBAF,"I")
72 S IB=$G(IB(399,IBDA,IBAF)) I IB="",IBAFF'="@" Q
73 I $D(IBAFZ) Q:IBAFZ="ALL"&(IB="") Q:IBAFZ="NULL"&(IB]"")
74 I IB=""!($G(IBAFZ)="ALL") G BUILD
75 I IBAFF="@",IBAFL="" G BUILD
76 I +IBAFF=IBAFF,+IBAFL=IBAFL Q:IB<IBAFF!(IB>IBAFL)
77 E Q:IBAFF]IB!(IB]IBAFL)
78 ;
79BUILD ; - Retrieve A/R data and build sort global.
80 S IBAO=$$ORI^PRCAFN(IBDA) S:IBAO<0 IBAO=0
81 S IBAP=$$TPR^PRCAFN(IBDA) S:IBAP<0 IBAP=0
82 S ^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS,$$NAMAGE(DFN,IBEVT)_"@@"_IBBN)=U_IBSCF_U_IBSCT_U_IBDP_U_IBDBC_U_IBAO_U_IBAP_U_IBCFL
83 I "OP"[IBSORT D
84 .S ^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS)=$G(^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS))+$S(IBSORT="O":(IBAO-IBAP),1:IBAP)
85 Q
86 ;
87SORT ; - Create sort global based on amount owed/amount paid, if necessary.
88 I 'IBSDIV S IBDIV=0
89 S IBX="" F S IBX=$O(^TMP($J,"IBOTR",IBDIV,IBX)) Q:IBX="" D
90 .S IBINS="" F S IBINS=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS)) Q:IBINS="" S IBXX=^(IBINS),^TMP($J,"IBOTRS",IBDIV,IBX,-IBXX,IBINS)=""
91 K IBX,IBXX
92 Q
93 ;
94NAMAGE(DFN,EVT) ; - Return patient name and age.
95 ; Input: DFN = Pointer to patient in file #2
96 ; EVT = Event Date of claim
97 ; Output: Patient name (1st 18 chars.)_"("_Age_")"
98 N DPT0,X,X1,X2
99 S DPT0=$G(^DPT(DFN,0)),X2=$P(DPT0,U,3)
100 I 'X2 S X="UNK"
101 E S X1=EVT S:'X1 X1=DT D ^%DTC S X=X\365.25
102 Q $E($P(DPT0,U),1,18)_" ("_X_")"
Note: See TracBrowser for help on using the repository browser.