source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAWRVUP.m@ 767

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

initial load of WorldVistAEHR

File size: 6.7 KB
Line 
1RAWRVUP ;HISC/GJC-Display procedures with their wRVU values ;10/26/05 14:57
2 ;;5.0;Radiology/Nuclear Medicine;**64,77**;Mar 16, 1998;Build 7
3 ;09/25/06 KAM/BAY Remedy Call 154793 PATCH *77 RVU with 0 value
4 ; and changed CPT calls from ^ICPTCOD to ^RACPTMSC
5 ; eliminating the need for IA's 1995 amd 1996
6 ;03/28/07 KAM/BAY Remedy Call 179232 Patch RA*5*77
7 ; Add check to see if current RVU data is available and if
8 ; not use previous year RVU data and added default scaling
9 ; factors
10 ;
11 ;DBIA#:4799 ($$RVU^FBRVU) return wRVU value for CPT, CPT Mod, & exam
12 ; date/time
13 ;DBIA#:10060 EN1^RASELCT enacts 10060 which allows lookups on the NEW
14 ; PERSON (#200) file
15 ;DBIA#:10063 ($$S^%ZTLOAD)
16 ;DBIA#:10103 ($$FMTE^XLFDT) & ($$NOW^XLFDT)
17 ;DBIA#:10104 ($$CJ^XLFSTR)
18 ;DBIA#:1519 ($$EN^XUTMDEVQ)
19 ;DBIA#:4432 (LASTCY^FBAAFSR) return last calendar year file
20 ; 162.99 was updated
21 ;
22EN(RASCLD) ;entry point
23 ;input: RASCLD=one if scaled, 0 if un-scaled
24 K ^TMP($J,"RA PROCEDURES")
25 ;
26PROC ;allow the user to select one/many/all Rad/Nuc Med procedures
27 S RADIC="^RAMIS(71,",RADIC(0)="QEAMZ",RAUTIL="RA PROCEDURES"
28 S RADIC("A")="Select Procedures: ",RADIC("B")="All",RAXIT=0
29 ;screen: based on user selection of procedure activity and that the
30 ;procedure must have a CPT code (only detailed and series procedures)
31 S RADIC("S")="I $P(^(0),U,9)" ;must have a CPT code (detailed/series)
32 W !! D EN1^RASELCT(.RADIC,RAUTIL)
33 S RAXIT=RAQUIT K %W,%Y1,DIC,RADIC,RAQUIT,RAUTIL,X,Y
34 ;did the user select physicians to compile data on? if not, quit
35 I $O(^TMP($J,"RA PROCEDURES",""))="" D D XIT Q
36 .W !!?3,$C(7),"Rad/Nuc Med Procedures were not selected."
37 .Q
38 ;
39 F I="RASCLD","^TMP($J,""RA PROCEDURES""," S ZTSAVE(I)=""
40 S I="RA print wRVUs for Rad/Nuc Med procedures"
41 D EN^XUTMDEVQ("START^RAWRVUP",I,.ZTSAVE,,1)
42 I +$G(ZTSK)>0 W !!,"Task Number: "_ZTSK,!
43 K I,ZTSAVE,ZTSK
44 Q
45 ;
46START ;
47 S:$D(ZTQUEUED)#2 ZTREQ="@"
48 ; 03/29/07 KAM/BAY Patch RA*5*77/179232 Added RACYFLG to next line
49 S $P(RALN,"-",IOM+1)="",(RACNT,RAPG,RAXIT,RACYFLG)=0
50 ;03/29/07 KAM/BAY RA*5*77/179232 Added Fee Basis Data Check
51 D CHKCY
52 S RARUNDT=$$FMTE^XLFDT(DT,"1P")
53 S RAHDR="PROCEDURE CPT CODE AND"_$S(RASCLD=1:" SCALED",1:"")_" WORK RELATIVE VALUE UNITS (wRVU)"
54 S RAX="" D HDR
55 F S RAX=$O(^TMP($J,"RA PROCEDURES",RAX)) Q:RAX="" D Q:RAXIT
56 .S RAY=0
57 .F S RAY=$O(^TMP($J,"RA PROCEDURES",RAX,RAY)) Q:'RAY D Q:RAXIT
58 ..S RACNT=RACNT+1 S:RACNT#500=0 (RAXIT,ZTSTOP)=$$S^%ZTLOAD() Q:RAXIT
59 ..S RAMIS(0)=$G(^RAMIS(71,RAY,0))
60 ..S RAPROC=$E($P(RAMIS(0),U),1,35) ;truncate to thirty-five chars
61 ..S RAPTYPE=$S($P(RAMIS(0),U,6)="D":"Detailed",1:"Series")
62 ..S RAITYPE=$P($G(^RA(79.2,+$P(RAMIS(0),U,12),0)),U,3)
63 ..;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC
64 ..S RACPT=$P(RAMIS(0),U,9),RACPT=$P($$NAMCODE^RACPTMSC(RACPT,DT),U,1)
65 ..;determine if there are default CPT modifiers for this procedure; if
66 ..;so, does one indicate 'bilateral'? If bilateral multiply wRVU by two.
67 ..S RACPTMOD="",RABILAT=0
68 ..I $O(^RAMIS(71,RAY,"DCM",0))>0 S RAI=0 D
69 ...F S RAI=$O(^RAMIS(71,RAY,"DCM",RAI)) Q:'RAI D
70 ....S RACPTMOD(0)=+$G(^RAMIS(71,RAY,"DCM",RAI,0))
71 ....;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC
72 ....S RA813(0)=$$BASICMOD^RACPTMSC(RACPTMOD(0),DT)
73 ....I 'RABILAT,$P(RA813(0),U,2)=50 S RABILAT=1 ;bilateral multiplier=2
74 ....S RACPTMOD=RACPTMOD_$P(RA813(0),U,2)_","
75 ....Q
76 ...Q
77 ..;get wRVU value from FEE BASIS; returns a string: status^value^message
78 ..;where status'=1 means "in error"
79 .. ;03/29/07 KAM/BAY RA*5*77/179232 Added $S to next line
80 ..S RAWRVU=$$RVU^FBRVU(RACPT,RACPTMOD,$S(RACYFLG:DT-10000,1:DT))
81 .. ; 09/25/2006 Remedy call 154793 Correct 0 RVUs
82 .. I $P(RAWRVU,U,2)=0,RACPTMOD="" D
83 ... ;03/29/07 KAM/BAY RA*5*77/179232 Added $S to next line
84 ... S RAWRVU=$$RVU^FBRVU(RACPT,26,$S(RACYFLG:DT-10000,1:DT))
85 .. ;
86 ..I $P(RAWRVU,U)=1 D
87 ...;apply bilateral multiplier if appropriate
88 ...S:RABILAT RAWRVU=$P(RAWRVU,U,2)*2
89 ...;or not...
90 ...S:'RABILAT RAWRVU=$P(RAWRVU,U,2)
91 ...Q
92 ..E S RAWRVU=0 ;status some other value than 1; "in error"
93 ..;
94 ..S:RAWRVU>0 RAWRVU=$J(RAWRVU,1,2)
95 ..;
96SCALED ..;when scaled find scaled wRVU value
97 ..I RASCLD=1,(RAWRVU>0) D
98 ...S RASFACTR=$$SFCTR(+$P(RAMIS(0),U,12)) ;pass i-type ptr
99 ...S RASWRVU=$J((RAWRVU*RASFACTR),1,2)
100 ...Q
101 ..E S RASWRVU=0 ;mult by zero
102 ..;
103 ..W !,RAPROC,?37,RAPTYPE,?48,RAITYPE,?58,RACPT,?68,$S(RASCLD=1:$J(RASWRVU,7,2),1:$J(RAWRVU,7,2))
104 ..I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR
105 ..Q
106 .Q
107 I 'RAXIT,(RASCLD) S RASFACTR(0)="" D
108 .I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR
109 .W !!,"For calendar year "_($E(DT,1,3)+1700)_" the following scaling factors apply:"
110 .S I=0
111 . ;04/13/07 KAM/BAY RA*5*77 Modified next line to loop thru all imaging types
112 .F S I=$O(^RA(79.2,I)) Q:'I D Q:RAXIT
113 ..S I(0)=$G(^RA(79.2,I,0))
114 ..I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR
115 ..; 04/13/07 KAM/BAY RA*5*77 Added $S to next line
116 .. W !,$P(I(0),U),?34,$P(I(0),U,3),?49,$S($O(^RA(79.2,I,"CY",0))>0:$$SFCTR^RAWRVUP(I,DT),1:"1.00 (default)")
117 ..Q
118 .S RAXIT=$$EOS^RAUTL5()
119 .Q
120 D XIT
121 Q
122 ;
123HDR ; Header for our report
124 W:RAPG!($E(IOST,1,2)="C-") @IOF
125 S RAPG=RAPG+1 W !?(IOM-$L(RAHDR)\2),RAHDR
126 W !,"Run Date: ",RARUNDT,?68,"Page: ",RAPG
127 ;03/28/07 KAM/BAY RA*5*77/179232 Added next 2 lines
128 I $G(RACYFLG) D
129 . W !,?7,"***This report was prepared with "_$$LASTCY^FBAAFSR()_" Calendar Year RVU Data***"
130 W:'$D(RASFACTR(0))#2 !!,"Procedure",?37,"Proc Type",?48,"Img Type",?58,"CPT Code",?68,$S(RASCLD=1:" S",1:" ")_"wRVU"
131 W:$D(RASFACTR(0))#2 !!,"Imaging Type",?34,"Abbreviation",?51,"wRVU scaling factor"
132 W !,RALN
133 Q
134 ;
135XIT ;kill variables and exit
136 I 'RAXIT W:'RACNT !,$$CJ^XLFSTR("No data found for this report",IOM)
137 K DILN,DTOUT,DUOUT,I,POP,RA813,RABILAT,RACNT,RACPT,RACPTMOD,RAHDR,RAI
138 K RAITYPE,RALN,RAMIS,RAPTYPE,RAPG,RAPROC,RARUNDT,RASCLD,RASFACTR
139 K RASWRVU,RAWRVU,RAX,RAXIT,RAY,RAYEAR,X,Y,RACYFLG
140 K ^TMP($J,"RA PROCEDURES")
141 Q
142 ;
143SFCTR(RAITYP,RAYEAR) ;return the calendar year specific scaling factor for a
144 ;specific imaging type
145 ;input: RAITYP=imaging type
146 ; RAYEAR=internal FM date/time format; resolves to current year
147 ;return: calendar year specific scaling factor
148 N RASF,RAYR S RAYEAR=$G(RAYEAR,DT) ;default to DT (current year)
149 S (RAYEAR,RAYR)=$E(RAYEAR,1,3)+1700
150 S RASF=+$O(^RA(79.2,RAITYP,"CY","B",RAYEAR,0))
151 ;if RASF=0 for the current year, check for the most recent year
152 I RASF=0 D
153 .S RAYEAR=+$O(^RA(79.2,1,"CY","B",RAYEAR),-1)
154 .S RASF=+$O(^RA(79.2,RAITYP,"CY","B",RAYEAR,0))
155 .Q
156 S RASF=+$P($G(^RA(79.2,RAITYP,"CY",RASF,0)),U,2)
157 S:RASF=0 RASF=1 ;defaults to one
158 Q $J(RASF,$L(RASF),2)_$S(RAYEAR:" ("_RAYR_")",1:"")
159 ;
160CHKCY ;03/28/2007 KAM/BAY RA*5*77 Remedy Call 179232 Check for latest RVU
161 ;data from Fee Basis
162 S RACYFLG=0,Y=$G(DT) D DD^%DT
163 I $$LASTCY^FBAAFSR()<$P(Y," ",3) S RACYFLG=1
164 Q
Note: See TracBrowser for help on using the repository browser.