source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBAAPCS.m@ 1726

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1FBAAPCS ;WCIOFO/SAB-REPORT COST/SAVINGS FROM RBRVS FEE SCHEDULE ;6/28/1999
2 ;;3.5;FEE BASIS;**4,77**;JAN 30, 1995
3 ;
4 ; ask date range
5 D DATE^FBAAUTL Q:FBPOP
6 ;
7 W !,"Note: code descriptors will be versioned for the Ending DATE"
8 N ICPTVDT S ICPTVDT=$G(ENDDATE)
9 ;
10 ; ask CPT codes to include
11 K FBRCPT
12 S DIR(0)="Y",DIR("A")="Include all CPT codes",DIR("B")="YES"
13 D ^DIR K DIR G:$D(DIRUT) EXIT
14 S FBRCPT=$S(Y:"A",1:"")
15 ; if not all CPT codes then ask selection method
16 I FBRCPT="" D
17 . S DIR(0)="S^1:RANGE OF CODES;2:INDIVIDUAL CODES"
18 . S DIR("A")="Choose a method to specify CPT Codes"
19 . S DIR("?",1)="You must choose one of the two methods that can be used"
20 . S DIR("?",2)="to specify the CPT codes to be included on the report."
21 . S DIR("?",3)="If the Range method is chosen, you will asked for one or more"
22 . S DIR("?",4)="ranges of CPT codes. (e.g. from 11000 to 11999)"
23 . S DIR("?",5)="If the Individual method is chosen, you will be asked to select"
24 . S DIR("?",6)="one or more specific CPT codes."
25 . S DIR("?")="Enter a code from the list."
26 . D ^DIR K DIR Q:$D(DIRUT)
27 . S FBRCPT=$S(Y=1:"R",1:"I")
28 I FBRCPT="" G EXIT
29 ; if individual selected then ask specific codes
30 I FBRCPT="I" D I $D(DTOUT)!$D(DUOUT)!'$O(FBRCPT(0)) G EXIT
31 . W !,"Note: code descriptors will be versioned for the Ending DATE"
32 . F D Q:Y'>0!$D(DIRUT)
33 . . S DIR(0)="PO^81:EM"
34 . . D ^DIR K DIR Q:$D(DIRUT)
35 . . I Y>0 S FBRCPT($P(Y,U))=$P(Y,U,2)
36 ; if range selected then ask ranges
37 I FBRCPT="R" D I $D(DTOUT)!$D(DUOUT)!'$O(FBRCPT(0)) G EXIT
38 . N FBI,FBX
39 . S FBI=0 F D Q:Y=""!$D(DIRUT)
40 . . S DIR(0)="FO^5:5",DIR("A")="Start of CPT Range #"_(FBI+1)
41 . . D ^DIR K DIR Q:$D(DIRUT)
42 . . S FBX=Y
43 . . S DIR(0)="F^5:5",DIR("A")="End of CPT Range #"_(FBI+1)
44 . . D ^DIR K DIR Q:$D(DIRUT)
45 . . S $P(FBX,U,2)=Y
46 . . I $P(FBX,U)]$P(FBX,U,2) W $C(7),!,"Start can't be after the End" Q
47 . . S FBI=FBI+1,FBRCPT(FBI)=FBX
48 ;
49 ; ask device
50 W !!,"Note: Additional data printed if device supports 130+ characters"
51 S VAR="BEGDATE^ENDDATE^FBRCPT*",PGM="START^FBAAPCS"
52 D ZIS^FBAAUTL G EXIT:FBPOP
53 ;
54START ; queued entry
55 ; input
56 ; BEGDATE - begin date (fileman)
57 ; ENDDATE - end date (fileman)
58 ; FBRCPT - CPT codes to report ('A' All, 'I' Individual, 'R' Ranges)
59 ; FBRCPT( - array of specifc codes or ranges when not All CPT codes
60 ; format when FBRCPT="I"
61 ; FBRCPT(cpt code internal value)=cpt code external value
62 ; format when FBRCPT="R"
63 ; FBRCPT(sequential range #)=start value^end value
64 U IO
65 ;
66GATHER ; collect and sort data
67 K ^TMP($J)
68 ; loop thru payments by date finalized
69 S FBDT=BEGDATE-1
70 F S FBDT=$O(^FBAAC("AK",FBDT)) Q:FBDT'>0!(FBDT>ENDDATE) D
71 . ; loop thru veterans
72 . S FBDFN=0
73 . F S FBDFN=$O(^FBAAC("AK",FBDT,FBDFN)) Q:FBDFN'>0 D
74 . . ; loop thru vendors
75 . . S FBV=0
76 . . F S FBV=$O(^FBAAC("AK",FBDT,FBDFN,FBV)) Q:FBV'>0 D
77 . . . ; loop thru initial treatment dates
78 . . . S FBK=0
79 . . . F S FBK=$O(^FBAAC("AK",FBDT,FBDFN,FBV,FBK)) Q:FBK'>0 D
80 . . . . ; loop thru service provided (cpt)
81 . . . . S FBL=0
82 . . . . F S FBL=$O(^FBAAC("AK",FBDT,FBDFN,FBV,FBK,FBL)) Q:FBL'>0 D
83 . . . . . S FBY0=$G(^FBAAC(FBDFN,1,FBV,1,FBK,1,FBL,0))
84 . . . . . S FBCPT=$$CPT^FBAAUTL4($P(FBY0,U))
85 . . . . . ; quit if CPT code not included in report
86 . . . . . I FBRCPT="I",'$D(FBRCPT($P(FBY0,U))) Q
87 . . . . . I FBRCPT="R" S FBFND=0 D Q:'FBFND
88 . . . . . . S FBI=0 F S FBI=$O(FBRCPT(FBI)) Q:'FBI I $P(FBRCPT(FBI),U)']FBCPT,FBCPT']$P(FBRCPT(FBI),U,2) S FBFND=1 Q
89 . . . . . ; passed CPT checks
90 . . . . . S FBY2=$G(^FBAAC(FBDFN,1,FBV,1,FBK,1,FBL,2))
91 . . . . . S FBMODL=$$MODL^FBAAUTL4("^FBAAC("_FBDFN_",1,"_FBV_",1,"_FBK_",1,"_FBL_",""M"")","E")
92 . . . . . S FBCPTM=" "_FBCPT_$S(FBMODL]"":"-"_FBMODL,1:"")
93 . . . . . ; retrieve counts and totals for the CPT-MODIFIERS combination
94 . . . . . S FBX=$G(^TMP($J,FBCPTM))
95 . . . . . ; update counts and totals for this payment
96 . . . . . S $P(FBX,U)=$P(FBX,U)+1 ; total count
97 . . . . . S $P(FBX,U,2)=$P(FBX,U,2)+$P(FBY0,U,3) ; total paid
98 . . . . . ; if paid at the RBRVS amount
99 . . . . . I +$P(FBY0,U,3)=+$P(FBY2,U,12),$P(FBY2,U,13)="R" D
100 . . . . . . S $P(FBX,U,3)=$P(FBX,U,3)+1 ; RBRVS count
101 . . . . . . S $P(FBX,U,4)=$P(FBX,U,4)+$P(FBY0,U,3) ; RBRVS payments
102 . . . . . . ; calc 75th percentile
103 . . . . . . S FBDOS=$P($G(^FBAAC(FBDFN,1,FBV,1,FBK,0)),U)
104 . . . . . . S FBAMT=$$PRCTL^FBAAFSF($P(FBY0,U),FBMODL,FBDOS)
105 . . . . . . I FBAMT>0 D
106 . . . . . . . S $P(FBX,U,5)=$P(FBX,U,5)+1 ; covered by 75th count
107 . . . . . . . S $P(FBX,U,6)=$P(FBX,U,6)+FBAMT ; 75th estimated payment
108 . . . . . . E D
109 . . . . . . . S $P(FBX,U,7)=$P(FBX,U,7)+1 ; not covered by 75th count
110 . . . . . . . S $P(FBX,U,8)=$P(FBX,U,8)+$P(FBY0,U,2) ; claimed amount
111 . . . . . ; save counts and totals for the CPT-MODIFIERS combination
112 . . . . . S ^TMP($J,FBCPTM)=FBX
113 ;
114PRINT ; report data
115 S (FBQUIT,FBPG)=0 D NOW^%DTC S Y=% D DD^%DT S FBDTR=Y
116 S FBO=$S(IOM>129:43,1:0) ; column offset if room to display more detail
117 ;
118 ; build page header text in FBHT( based on selection criteria
119 K FBHT
120 S FBHT(1)=" for Payments with Finalized Dates from "
121 S FBHT(1)=FBHT(1)_$$FMTE^XLFDT(BEGDATE)_" to "_$$FMTE^XLFDT(ENDDATE)
122 I FBRCPT="A" S FBHT(2)=" and all CPT Codes"
123 E D
124 . S FBL=2,FBHT(FBL)=" and CPT Codes: "
125 . S (FBC,FBI)=0 F S FBI=$O(FBRCPT(FBI)) Q:'FBI D
126 . . I $L(FBHT(FBL))+$S(FBRCPT="I":2,1:10)+$L(FBRCPT(FBI))>75 D
127 . . . I FBC S FBHT(FBL)=FBHT(FBL)_","
128 . . . S FBL=FBL+1,FBC=0,FBHT(FBL)=" "
129 . . S FBHT(FBL)=FBHT(FBL)_$S(FBC:", ",1:"")
130 . . I FBRCPT="I" S FBHT(FBL)=FBHT(FBL)_FBRCPT(FBI)
131 . . I FBRCPT="R" S FBHT(FBL)=FBHT(FBL)_"from "_$P(FBRCPT(FBI),U)_" to "_$P(FBRCPT(FBI),U,2)
132 . . S FBC=FBC+1 ; count of codes or ranges on current line (FBL)
133 ;
134 D HD
135 I '$D(^TMP($J)) W !!," No payments found that match criteria. ",!
136 ;
137 S FBT="" ; initialize report totals
138 ; loop thru CPT-MODIFIER(S)
139 S FBCPTM="" F S FBCPTM=$O(^TMP($J,FBCPTM)) Q:FBCPTM="" D Q:FBQUIT
140 . S FBX=$G(^TMP($J,FBCPTM))
141 . I $Y+6>IOSL D HD Q:FBQUIT
142 . ;
143 . ; compute estimated savings
144 . S FBSAV=$P(FBX,U,6)+$P(FBX,U,8)-$P(FBX,U,4)
145 . ;
146 . ; print detail line
147 . W !,$E($P(FBCPTM,",",1,4),2,99) W:$P(FBCPTM,",",5)]"" "," W ?18,"|"
148 . W ?20,$J($P(FBX,U,1),5),?26,$J($FN($P(FBX,U,2),",",2),13),?40,"|"
149 . W ?42,$J($P(FBX,U,3),5),?48,$J($FN($P(FBX,U,4),",",2),13),?62,"|"
150 . ; if room display additional detail
151 . I FBO D
152 . . W ?64,$J($P(FBX,U,5),5),?70,$J($FN($P(FBX,U,6),",",2),13)
153 . . W ?85,$J($P(FBX,U,7),5),?91,$J($FN($P(FBX,U,8),",",2),13)
154 . . W ?105,"|"
155 . W ?63+FBO,$J($FN(FBSAV,",P",2),15),?78+FBO,"|"
156 . ; if more than 4 modifiers then display them on subsequent lines
157 . F FBI=1:1 Q:$P(FBCPTM,",",(FBI*4)+1)="" D
158 . . W !,?5,"-",$P(FBCPTM,",",(FBI*4)+1,(FBI*4)+4) ; next set of mods
159 . . W:$P(FBCPTM,",",(FBI*4)+5)]"" "," ; additional line will be needed
160 . . W ?18,"|",?40,"|",?62,"|" W:FBO ?105,"|" W ?78+FBO,"|"
161 . ;
162 . ; add to report totals
163 . F FBI=1:1:8 S $P(FBT,U,FBI)=$P(FBT,U,FBI)+$P(FBX,U,FBI)
164 . S $P(FBT,U,9)=$P(FBT,U,9)+FBSAV
165 ;
166 I FBQUIT W !!,"REPORT STOPPED AT USER REQUEST"
167 E D ; report totals
168 . D DL
169 . W !,"REPORT TOTALS ",?18,"|"
170 . W ?20,$J($P(FBT,U,1),5),?26,$J($FN($P(FBT,U,2),",",2),13),?40,"|"
171 . W ?42,$J($P(FBT,U,3),5),?48,$J($FN($P(FBT,U,4),",",2),13),?62,"|"
172 . I FBO D
173 . . W ?64,$J($P(FBT,U,5),5),?70,$J($FN($P(FBT,U,6),",",2),13)
174 . . W ?85,$J($P(FBT,U,7),5),?91,$J($FN($P(FBT,U,8),",",2),13)
175 . . W ?105,"|"
176 . W ?63+FBO,$J($FN($P(FBT,U,9),",P",2),15),?78+FBO,"|"
177 I 'FBQUIT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
178 D ^%ZISC
179 ;
180EXIT ;
181 I $D(ZTQUEUED) S ZTREQ="@"
182 K ^TMP($J)
183 K BEGDATE,ENDDATE,FBRCPT
184 K FBAMT,FBC,FBCPT,FBCPTM,FBDFN,FBDT,FBDTR,FBFND,FBHT,FBI,FBK
185 K FBL,FBMODL,FBO,FBPG,FBPOP,FBQUIT,FBRCPT,FBSAV,FBT,FBV,FBX,FBY0,FBY2
186 K DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
187 Q
188 ;
189HD ; page header
190 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,FBQUIT=1 Q
191 I $E(IOST,1,2)="C-",FBPG S DIR(0)="E" D ^DIR K DIR I 'Y S FBQUIT=1 Q
192 I $E(IOST,1,2)="C-"!FBPG W @IOF
193 S FBPG=FBPG+1
194 W !,"COST/SAVINGS FROM RBRVS FEE SCHEDULE",?49,FBDTR,?72,"page ",FBPG
195 S FBI=0 F S FBI=$O(FBHT(FBI)) Q:'FBI W !,FBHT(FBI)
196 ;
197 W !!,"CPT CODE-",?18,"|",?20,"Total Occurrences ",?40,"|"
198 W ?42,"Payments at RBRVS",?62,"|"
199 W:FBO ?64,"Estimated Payments if RBRVS was not used",?105,"|"
200 W ?64+FBO,"Est. Savings",?78+FBO,"|"
201 ;
202 I FBO D
203 . W !,?18,"|",?40,"|",?62,"|"
204 . W ?64,"75th Percentile",?85,"Usual & Customary*"
205 . W ?105,"|",?78+FBO,"|"
206 ;
207 W !," Modifier(s)",?18,"|",?20,"count $ amount",?40,"|"
208 W ?42,"count $ amount",?62,"|"
209 W:FBO ?64,"count $ amount",?85,"count $ amount",?105,"|"
210 W ?64+FBO,"from RBRVS",?78+FBO,"|"
211 ;
212DL ; write dashed line
213 W !,"------------------",?18,"|",?20,"----- -------------",?40,"|"
214 W ?42,"----- -------------",?62,"|"
215 W:FBO ?64,"----- -------------",?85,"----- -------------",?105,"|"
216 W ?64+FBO,"-------------",?78+FBO,"|"
217 Q
218 ;
219 ;FBAAPCS
Note: See TracBrowser for help on using the repository browser.