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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1IBOBL ;ALB/ARH - LIST ALL BILLS FOR AN EPISODE OF CARE ; 25-MAY-90
2 ;;2.0;INTEGRATED BILLING;**80,106**;21-MAR-94
3 ;
4EN ;get parameters then run the report
5 D HOME^%ZIS N IBASK,IBCANC,IBX W !!,"Episode of Care Bill List:",!,"--------------------------"
6 W !,"Enter a Bill Number to get a list of all bills that match the selected bill's",!,"event date or any of it's outpatient visit dates."
7 W !,"Enter a Patient Name and Episode Date to get a list of all bills for a patient",!,"that have either that date as the event date or as an outpatient visit date."
8 W !,"This report also includes bills related as continuing episodes of care."
9 ;
10 S IBASK=$$PB^IBJTU2 Q:IBASK'>0 W !
11 I +IBASK=1 S IBX=$$GETDT^IBCRU1("","Episode Date") Q:IBX'?7N S IBASK=IBASK_U_IBX W !
12 S IBADDCPT=$$CPT Q:IBADDCPT<0
13 S IBCANC=$$CANC Q:IBCANC<0 W !
14 ;
15DEV ;get the device
16 W !,"Report requires 132 columns."
17 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
18 I $D(IO("Q")) S ZTRTN="RPT^IBOBL",ZTDESC="Episode of Care Bill List",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") G EXIT
19 U IO
20 ;
21RPT ;find, save, and print the data that satisfies the search parameters
22 ;entry point for tasked jobs
23 ;
24 K ^TMP($J,"IBOBL") I '$G(IBASK) G EXIT
25 ;
26 D FIND
27 D PRINT
28 ;
29EXIT ;clean up and quit
30 K ^TMP($J,"IBOBL"),IBASK,IBADDCPT,IBCANC,IBX Q:$D(ZTQUEUED)
31 D ^%ZISC
32 Q
33 ;
34FIND ; compile list of all related bills
35 N IBIFN,IB0,DFN,IBEPDT,IBX
36 ;
37 ; compile list of related bills based on event date and opt visit dates of selected bill
38 I +IBASK=2 S IBIFN=+$P(IBASK,U,2),IB0=$G(^DGCR(399,IBIFN,0)) D
39 . S DFN=$P(IB0,U,2),IBEPDT=$P(IB0,U,3) D FIND1(DFN,IBEPDT)
40 . S IBX=0 F S IBX=$O(^DGCR(399,+IBIFN,"OP",IBX)) Q:'IBX D
41 .. S IBEPDT=+$G(^DGCR(399,+IBIFN,"OP",IBX,0)) Q:'IBEPDT D FIND1(DFN,IBEPDT)
42 ;
43 ; compile list of related bills based on selected patient and episode date
44 I +IBASK=1 S DFN=$P(IBASK,U,2),IBEPDT=$P(IBASK,U,3) D FIND1(DFN,IBEPDT)
45 ;
46 D FIND2 ; compile list of bills based on Primary Bill link with bills already found
47 Q
48 ;
49FIND1(DFN,IBEPDT) ; find all bills for a patient with a specific event date or opt visit date
50 N IBX,IBIFN,IBDT S IBEPDT=IBEPDT\1
51 ;
52 ; find all bills for patient with episode date as outpatient visit date
53 S IBDT=IBEPDT-.0001 F S IBDT=$O(^DGCR(399,"AOPV",DFN,IBDT)) Q:((IBDT\1)'=IBEPDT) D
54 . S IBIFN=0 F S IBIFN=$O(^DGCR(399,"AOPV",DFN,IBDT,IBIFN)) Q:'IBIFN D
55 .. S IBX=$G(^DGCR(399,IBIFN,0)) I IBX="" Q
56 .. S ^TMP($J,"IBOBL","BILL",IBIFN)=""
57 .. I +$P(IBX,U,17) S ^TMP($J,"IBOBL","BILL",+$P(IBX,U,17))=""
58 ;
59 ; find all bills for patient with episode date as Event Date
60 S IBDT=IBEPDT-.00001 F S IBDT=$O(^DGCR(399,"D",IBDT)) Q:((IBDT\1)'=IBEPDT) D
61 . S IBIFN=0 F S IBIFN=$O(^DGCR(399,"D",IBDT,IBIFN)) Q:'IBIFN D
62 .. S IBX=$G(^DGCR(399,IBIFN,0)) I $P(IBX,U,2)'=DFN Q
63 .. S ^TMP($J,"IBOBL","BILL",IBIFN)=""
64 .. I +$P(IBX,U,17) S ^TMP($J,"IBOBL","BILL",+$P(IBX,U,17))=""
65 ;
66 Q
67 ;
68FIND2 ; compile list of related bills based on Primary Bill of bills already found
69 N IBBILL,IBIFN,IBX
70 S IBBILL=0 F S IBBILL=$O(^TMP($J,"IBOBL","BILL",IBBILL)) Q:'IBBILL D
71 . S IBIFN=0 F S IBIFN=$O(^DGCR(399,"AC",IBBILL,IBIFN)) Q:'IBIFN D
72 .. S IBX=$G(^DGCR(399,IBIFN,0)) I IBX="" Q
73 .. S ^TMP($J,"IBOBL","BILL",IBIFN)=""
74 Q
75 ;
76PRINT ;print the report from the temp sort file to the appropriate device
77 N IBPGN,IBQUIT,IBLN,IBHDR1,IBHDR2,IBIFN
78 S IBPGN=0,IBQUIT=0 D HDRLNS,HDR Q:IBQUIT
79 ;
80 S IBIFN=0 F S IBIFN=$O(^TMP($J,"IBOBL","BILL",IBIFN)) Q:'IBIFN D Q:$$LNCHK(2)
81 . I '$G(IBCANC),$P($G(^DGCR(399,+IBIFN,0)),U,13)=7 Q
82 . D PRTLN(IBIFN,IBADDCPT)
83 ;
84 I 'IBQUIT D PAUSE
85 Q
86 ;
87PRTLN(IBIFN,IBADDCPT) ; print one bill with all it's CPTs
88 N IB0,IBU,IBM,IBMP,IBX,IBCPT S IBLN=IBLN+1
89 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G(^DGCR(399,IBIFN,"U"))
90 S IBM=$G(^DGCR(399,IBIFN,"M")),IBMP=$G(^DGCR(399,IBIFN,"MP"))
91 W !,$P(IB0,U,1),?12,$P($G(^DGCR(399.3,+$P(IB0,U,7),0)),U,4) S IBX=$P(IB0,U,5)
92 W ?24,$S(IBX=1:"INPT",IBX=2:"INPT-H",IBX=3:"OPT",IBX=4:"OPT-H",1:"") S IBX=$P(IB0,U,27)
93 W ?32,$S(IBX=1:"INST",IBX=2:"PROF",1:"")
94 W ?39,$$DATE(+$P(IB0,U,3)),?49,$$DATE(+IBU),?59,$$DATE(+$P(IBU,U,2))
95 W ?70,$P($$ARSTATA^IBJTU4(IBIFN),U,2) S IBX=$P(IB0,U,21)
96 W ?75,$S(IBX="P":"PRIM",IBX="S":"SEC",IBX="T":"TER",IBX="A":"PAT",1:"") S IBX=$P(IB0,U,11)
97 W ?82,$E($S(IBX="i":$P($G(^DIC(36,+IBMP,0)),U,1),IBX="o":$P($G(^DIC(4,+$P(IBM,U,11),0)),U,1),IBX="p":$P($G(^DPT(+$P(IB0,U,2),0)),U,1),1:""),1,23)
98 W ?107,$J(+$P($$BILL^RCJIBFN2(IBIFN),U,1),10,2)
99 ;
100 I 'IBADDCPT W ! Q
101 ;
102 S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"CP",IBX)) Q:'IBX D
103 . S IBCPT=$P($G(^DGCR(399,IBIFN,"CP",IBX,0)),U,1) I IBCPT["ICPT" S IBCPT(+IBCPT)=+$G(IBCPT(+IBCPT))+1
104 ;
105 S IBCPT="" F S IBCPT=$O(IBCPT(IBCPT)) Q:'IBCPT D Q:$$LNCHK(1)
106 . S IBX=+IBCPT(IBCPT) W ?120,$P($$CPT^ICPTCOD(+IBCPT),U,2),?127,$S(IBX'=1:"("_IBX_")",1:""),! S IBLN=IBLN+1
107 ;
108 Q
109 ;
110HDR ;print the report header
111 N IBNOW,IBI
112 S IBQUIT=$$STOP Q:IBQUIT S IBPGN=IBPGN+1,IBLN=7
113 S IBNOW=$$FMTE^XLFDT($$NOW^XLFDT),IBNOW=$P(IBNOW,"@",1)_" "_$P($P(IBNOW,"@",2),":",1,2)
114 I IBPGN>1!($E(IOST,1,2)["C-") W @IOF
115 ;
116 W !,IBHDR1,?(IOM-30),IBNOW,?(IOM-8),"PAGE ",IBPGN,!,IBHDR2
117 W !,"BILL #",?12,"RATE",?24,"CLASSIFICATION",?39,"EVENT",?49,"FROM",?59,"TO",?70,"AR",?75,"COB",?82,"PAYER",?112,"TOTAL",?120,"CPT'S",!
118 S IBI="",$P(IBI,"-",IOM+1)="" W IBI
119 W !
120 Q
121 ;
122HDRLNS ; set up header lines
123 N DFN,IBX S DFN=0
124 S IBHDR1="EPISODE OF CARE BILL LIST FOR "
125 I +IBASK=1 S IBHDR1=IBHDR1_$P($G(^DPT(+$P(IBASK,U,2),0)),U,1)_" ON "_$$DATE(+$P(IBASK,U,3)) S DFN=+$P(IBASK,U,2)
126 I +IBASK=2 S IBX=$G(^DGCR(399,+$P(IBASK,U,2),0)),IBHDR1=IBHDR1_$P(IBX,U,1) S DFN=+$P(IBX,U,2)
127 S IBX=$G(^DPT(DFN,0)) S IBHDR2=$P(IBX,U,1)_$J("",10)_$E(IBX)_$P($$PT^IBEFUNC(DFN),U,3)_$J("",10)_"DOB: "_$$DATE($P(IBX,U,3))
128 Q
129 ;
130DATE(X) ;
131 Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
132 ;
133LNCHK(LNS) ; check if new page is needed
134 I 'IBQUIT,IBLN>(IOSL-LNS) D PAUSE I 'IBQUIT D HDR
135 Q IBQUIT
136 ;
137PAUSE ;pause at end of screen if beeing displayed on a terminal
138 Q:$E(IOST,1,2)'["C-" N DIR,DUOUT,DTOUT,DIRUT
139 S DIR(0)="E" D ^DIR K DIR
140 I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1
141 Q
142 ;
143STOP() ;determine if user has requested the queued report to stop
144 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
145 Q +$G(ZTSTOP)
146 ;
147CPT() ; return true if include bills CPT procedures
148 N IBX,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBX=0
149 S DIR("?")="Enter either 'Y' or 'N'. Enter 'Y' if you want the CPT procedures for each bill included in the report."
150 S DIR("A")="Include CPT Procedures",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR S:Y=1 IBX=1 I $D(DIRUT) S IBX=-1
151 Q IBX
152 ;
153CANC() ; return true if include canceled bills
154 N IBX,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBX=0
155 S DIR("?")="Enter either 'Y' or 'N'. Enter 'Y' if you want cancelled bills included in the report."
156 S DIR("A")="Include Cancelled Bills",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR S:Y=1 IBX=1 I $D(DIRUT) S IBX=-1
157 Q IBX
Note: See TracBrowser for help on using the repository browser.