source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTODD.m@ 1000

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

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1IBTODD ;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
5 W !!,"Denied Days Report",!!
6 ;
7 S IBSORT="P"
8 N DIR
9 S DIR("?")="Answer YES if you only want to print a summary or answer NO if you want a detailed listing plus the summary."
10 S DIR(0)="Y",DIR("A")="Print Summary Only",DIR("B")="YES" D ^DIR K DIR
11 I $D(DIRUT) G END
12 S IBSUM=Y
13 G:IBSUM DATE
14 ;
15 ; -- ask how they want it sorted
16 D SORT^IBTODD2 I IBSORT<0 G END
17 ;
18DATE ; -- select date range
19 W ! D DATE^IBOUTL
20 I IBBDT=""!(IBEDT="") G END
21 ;
22DEV ; -- select device, run option
23 W !
24 I 'IBSUM W !!,"You will need a 132 column printer for this report!",!
25 S %ZIS="QM" D ^%ZIS G:POP END
26 I $D(IO("Q")) S ZTRTN="DQ^IBTODD",ZTSAVE("IB*")="",ZTDESC="IB - Denied Days Report" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
27 ;
28 U IO
29 D DQ G END
30 Q
31 ;
32END ; -- Clean up
33 W ! K ^TMP($J,"IBTODD")
34 I $D(ZTQUEUED) S ZTREQ="@" Q
35 D ^%ZISC
36 K I,J,X,X2,Y,DFN,%ZIS,DGPM,VA,IBI,IBJ,IBTRN,IBTRND,IBTRND1,IBPAG,IBHDT,IBDISDT,IBETYP,IBQUIT,IBTAG,IBTRC,IBTRCD,IBDEN,IBDAY,IBTALL,IBADM,IBDISCH,IBMAX
37 K IBAPL,IBBBS,IBBDT,IBC,IBCDT,IBCNT,IBDT,IBD,IBDATA,IBEDT,IBNAM,IBPRIM,IBPROV,IBRATE,IBSECN,IBSERV,IBSORT,IBSPEC,IBSUM,IBSUBT,IBTOTL
38 D KVAR^VADPT
39 Q
40DQ ; -- entry print from taskman
41 K ^TMP($J,"IBTODD")
42 S X=132 X ^%ZOSF("RM")
43 S IBPAG=0,IBHDT=$$HTE^XLFDT($H,1),IBQUIT=0
44 S IBDEN=$O(^IBE(356.7,"ACODE",20,0))
45 D BLD,PRINT^IBTODD1
46 I $D(ZTQUEUED) G END
47 Q
48 ;
49BLD ; -- sort through data and build array to print from
50 ;
51 S IBTRC=0
52 F S IBTRC=$O(^IBT(356.2,"ACT",IBDEN,IBTRC)) Q:'IBTRC D
53 .N IBDAY S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
54 .S IBTRN=$P(IBTRCD,"^",2),IBTRND=$G(^IBT(356,+IBTRN,0))
55 .Q:'$P(IBTRCD,"^",19) ; review is inactive
56 .Q:'$P(IBTRND,"^",20) ; parent CT entry is inactive
57 .S IBDDB=$P(IBTRCD,"^",15),IBDDE=$P(IBTRCD,"^",16)
58 .S IBTALL=$P($G(^IBT(356.2,+IBTRC,1)),"^",7)
59 .I IBDDB,IBDDE Q:(IBDDB>IBEDT)!(IBDDE<IBBDT) D
60 ..I IBDDB<IBBDT S IBDDB=IBBDT ; chk days denied in correct range
61 ..I IBDDE>IBEDT S IBDDE=IBEDT
62 ..S IBDAY=$$FMDIFF^XLFDT(IBDDE,IBDDB)+1 ; cals total denied days
63 .; if no days denied "to" and "from" and episode in range
64 .I (IBTALL),('$D(IBDAY)) S IBCDT=$$CDT^IBTODD1(IBTRN) D STRIP Q:('+IBCDT!(+IBCDT>IBEDT)) D
65 ..Q:'$P(IBTRND,U,5) ; quit if no link between ct and dgpm
66 ..; if the care date is >the report range there is no discharge add 1
67 ..I '$P(IBCDT,U,2)!($P(IBCDT,U,2)>IBEDT) S $P(IBCDT,U,2)=$$FMADD^XLFDT(IBEDT,1)
68 ..I +IBCDT<IBBDT S $P(IBCDT,U,1)=IBBDT
69 ..S IBDAY=$$FMDIFF^XLFDT($P(IBCDT,U,2),$P(IBCDT,U,1))
70 .Q:$G(IBDAY)<1
71 .S DFN=$P(IBTRCD,"^",5),IBNAM=$P($G(^DPT(+DFN,0)),"^") Q:IBNAM=""
72 .S IBD=$$PROV(DFN,IBTRCD,IBTRND,IBTALL),IBPROV=+IBD,IBSPEC=$P(IBD,"^",2),IBSERV=$P(IBD,"^",3)
73 .S IBBBS=$$BBS^IBTOSUM1($P(IBD,"^",2))
74 .S IBRATE=$$RATE^IBTOSUM1(IBBBS,+IBTRCD)
75 .D SET
76 K IBTRN,IBTRND,IBTRCD,DFN,IBDDB,IBDDE,IBCDT
77 Q
78 ;
79SET ; -- set array to print from
80 ; -- ^tmp($j,"ibtodd",primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^ billing bed section ^ billing rate^ no. days denied
81 S IBPRIM=$S(IBSORT="P":IBNAM,IBSORT="A":IBPROV,1:IBSERV)
82 S IBSECN=$S(IBSORT="P":IBPROV,1:IBNAM)
83 S:IBPRIM="" IBPRIM="UNKNOWN" S:IBSECN="" IBSECN="UNKNOWN"
84 S ^TMP($J,"IBTODD",IBPRIM,IBSECN,IBTRC)=DFN_"^"_IBPROV_"^"_IBSPEC_"^"_IBSERV_"^"_IBBBS_"^"_IBRATE_"^"_IBDAY
85 Q
86 ;
87PROV(DFN,IBTRCD,IBTRND,IBTALL) ; Find attending/serv/spec during the denied period
88 ; Input: DFN -- Pointer to the patient in file #2
89 ; IBTRCD -- Zeroth node of insurance review in file #356.2
90 ; IBTRND -- Zeroth node of parent CT entry in file #356
91 ; IBTALL -- 1=> deny entire admission
92 ; Output: 1^2^3, where 1 => pointer to attending in file #200
93 ; 2 => pointer to treating spec. in file #45.7
94 ; 3 => service abbr. code
95 ;
96 N I,J,X,Y,DGPM,IBD,VA200,VAIN,VAIP,VAERR
97 ;
98 ; - determine date/time to calculate attending/serv/spec
99 S DGPM=+$P(IBTRND,"^",5),IBD=+$G(^DGPM(DGPM,0))
100 S:'IBD IBD=$P(IBTRND,"^",6)
101 I IBTALL S Y=IBD
102 I 'IBTALL D
103 .I $P(IBTRCD,"^",16)>$P(IBTRCD,"^",15) S Y=$P(IBTRCD,"^",15)_.2359 Q
104 .I $P(IBTRCD,"^",15)=(IBD\1) S Y=IBD Q
105 .S VAIP("D")=$P(IBTRCD,"^",15) D IN5^VADPT
106 .I +VAIP(16,1)\1=$P(IBTRCD,"^",15) S Y=+VAIP(16,1) Q
107 .S Y=$P(IBTRCD,"^",15)
108 S VA200="",VAINDT=Y D INP^VADPT
109 ;
110 S X=+VAIN(11)
111 S Y=$G(^IBT(356.94,+$O(^IBT(356.94,"ATP",+DGPM,1,0)),0))
112 S:$P(Y,"^",3) X=$P(Y,"^",3)
113PROVQ Q X_"^"_+VAIN(3)_"^"_$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$G(VAIN(3)),0)),"^",2),0)),"^",3)
114 ;
115STRIP ; -- strip time from dates (if report run same day time could produce incorrect results)
116 S $P(IBCDT,U,1)=$P(IBCDT,".",1),$P(IBCDT,U,2)=$P($P(IBCDT,U,2),".",1) Q
Note: See TracBrowser for help on using the repository browser.