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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1IBTODD1 ;ALB/AAS - CLAIMS TRACKING DENIED DAYS REPORT ; 27-OCT-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**32**; 21-MAR-94
3 ;
4% I '$D(DT) D DT^DICRW
5PRINT ; -- print data
6 ; -- ^tmp($j,"ibtodd",primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^ billing bed section ^ billing rate
7 ;
8 K IBCNT
9 I 'IBSUM D HDR
10 I 'IBSUM,$O(^TMP($J,"IBTODD",""))="" W !!,"No Denials Found in Date Range." G PRINTQ
11 ;
12 S IBI="",IBISV=""
13 F S IBI=$O(^TMP($J,"IBTODD",IBI)) Q:IBI=""!(IBQUIT) D
14 .I IBSORT'="P",IBISV'=IBI D SUBT^IBTODD2
15 .S IBISV=IBI D SUBH^IBTODD2(IBI) Q:IBQUIT
16 .S IBJ="" F S IBJ=$O(^TMP($J,"IBTODD",IBI,IBJ)) Q:IBJ=""!(IBQUIT) D
17 ..S IBTRC=""
18 ..F S IBTRC=$O(^TMP($J,"IBTODD",IBI,IBJ,IBTRC)) Q:IBTRC=""!(IBQUIT) S IBDATA=^(IBTRC) D ONE
19 I IBQUIT G PRINTQ
20 I 'IBSUM D SUBT^IBTODD2
21 D SUM^IBTODD2
22 ;
23PRINTQ Q
24 ;
25ONE ; -- print one entry
26 ; -- ^tmp($j,"ibtodd",primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^ billing bed section ^ billing rate
27 ;
28 S IBAPL=$$APPEAL(IBTRC)
29 D CNTS
30 S IBTALL=+$P($G(^IBT(356.2,+IBTRC,1)),"^",7) ;entire admission denied
31 Q:IBSUM
32 ;
33 I IOSL<($Y+6) D HDR,SUBH^IBTODD2(IBI)
34 S DFN=+IBDATA D PID^VADPT
35 S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
36L1 W !,$E($P(^DPT(DFN,0),"^"),1,22),?25,VA("PID")
37 S IBCDT=$$CDT($P(IBTRCD,"^",2))
38 W ?38,$$DAT1^IBOUTL(+IBCDT\1) W:$P(IBCDT,"^",2) " to"
39 W ?50,$J($P(IBDATA,"^",2),8)
40 I IBTALL W ?64,"ALL"
41 I 'IBTALL W ?64,$$DAT1^IBOUTL($P(IBTRCD,"^",15),"2P") W:$P(IBTRCD,"^",16) " to"
42 I IBTALL!('$P(IBTRCD,"^",16)) W " (",$P(IBDATA,"^",7),")"
43 K IBDEN,IBC S IBDEN=0,IBC=0
44 F S IBDEN=$O(^IBT(356.2,+IBTRC,12,IBDEN)) Q:'IBDEN S IBC=IBC+1,IBC(IBC)=^(IBDEN,0)
45 W:$G(IBC(1)) ?78,$E($$EXPAND^IBTRE(356.212,.01,+IBC(1)),1,25)
46 W ?110,$S(+$P(IBAPL,"^",2):"YES",1:"NO")
47 W ?117,$J(+IBAPL,8)
48 ;
49 ;
50L2 W !?38,$$DAT1^IBOUTL($P(IBCDT,"^",2)\1,"2P")
51 W ?64,$$DAT1^IBOUTL($P(IBTRCD,"^",16),"2P")
52 I 'IBTALL,$P(IBTRCD,"^",16) W " (",$P(IBDATA,"^",7),")"
53 W ?78,$E($$EXPAND^IBTRE(356.212,.01,$G(IBC(2))),1,25)
54 ;
55 I $O(IBC(2)) S IBDEN=2 F S IBDEN=$O(IBC(IBDEN)) Q:'IBDEN W !?78,$E($$EXPAND^IBTRE(356.212,.01,$G(IBC(IBDEN))),1,25)
56ONEQ W !
57 Q
58 ;
59 ;
60CNTS ; -- develop summary data
61 S IBSERV=$P(IBDATA,"^",4)
62 I IBSERV="" S IBSERV="UNKNOWN"
63 S:'$D(IBCNT(IBSERV)) IBCNT(IBSERV)=""
64 S $P(IBCNT(IBSERV),"^")=$P(IBCNT(IBSERV),"^")+$P(IBDATA,"^",7)
65 S $P(IBCNT(IBSERV),"^",2)=$P(IBCNT(IBSERV),"^",2)+($P(IBDATA,"^",7)*$P(IBDATA,"^",6))
66 S $P(IBCNT(IBSERV),"^",3)=$P(IBCNT(IBSERV),"^",3)+1
67 S $P(IBCNT(IBSERV),"^",4)=$P(IBCNT(IBSERV),"^",4)+$G(IBAPL)
68 S:$P(IBCNT(IBSERV),"^",6)<$P(IBDATA,"^",6) $P(IBCNT(IBSERV),"^",6)=$P(IBDATA,"^",6)
69 S IBSUBT=$G(IBSUBT)+$P(IBDATA,"^",7)
70 S IBTOTL=$G(IBTOTL)+$P(IBDATA,"^",7)
71 Q
72 ;
73HDR ; -- Print header for billing report
74 Q:IBQUIT
75 I $E(IOST,1,2)="C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
76 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF
77 S IBPAG=IBPAG+1
78 W !,"MCCR/UR DENIED DAYS Report for Denials Dated ",$$FMTE^XLFDT(IBBDT),$S(IBBDT'=IBEDT:" to "_$$FMTE^XLFDT(IBEDT),1:"")," "
79 W ?(IOM-33),"Page ",IBPAG," ",IBHDT
80 W !!,?38,"Dates of",?64,"Dates",?117,"Days Approved"
81 W !,"Patient",?25,"Pt. ID",?38,"Care",?50,"Attending",?64,"Denied",?78,"Denial Reason",?105,"Appealed",?117,"on Appeal"
82 W !,$TR($J(" ",IOM)," ","-")
83 Q
84 ;
85CDT(IBTRN) ; -- compute dates of care
86 N X,Y S X=$G(^IBT(356,+IBTRN,0)),Y=""
87 I $P(X,"^",5) S DGPM=$G(^DGPM($P(X,"^",5),0)) D
88 .S Y=+DGPM
89 .I $P(DGPM,"^",17) S Y=Y_"^"_+$G(^DGPM($P(DGPM,"^",17),0))
90 I 'Y S Y=$P(X,"^",6)
91 Q Y
92 ;
93APPEAL(IBTRC) ; -- Find appeals
94 N X,Y,IBAPEAL,IBTRN,IBTRSV S (Y,X)=0
95 S IBTRSV=IBTRC
96 S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"AP",+IBTRSV,IBTRC)) Q:'IBTRC S Y=1,X=X+$$AP(IBTRC)
97 ;
98 Q X_"^"_Y
99 ;
100AP(IBTRC) ; -- count days approved
101 N X,Y,Z
102 S (X,Z)=0
103 F S X=$O(^IBT(356.2,+IBTRC,14,X)) Q:'X S Y=$G(^(X,0)),Z=Z+$$FMDIFF^XLFDT($P(Y,"^",2),+Y)+1
104 Q Z
Note: See TracBrowser for help on using the repository browser.