RAWRVUP ;HISC/GJC-Display procedures with their wRVU values ;10/26/05 14:57
;;5.0;Radiology/Nuclear Medicine;**64,77**;Mar 16, 1998;Build 7
;09/25/06 KAM/BAY Remedy Call 154793 PATCH *77 RVU with 0 value
; and changed CPT calls from ^ICPTCOD to ^RACPTMSC
; eliminating the need for IA's 1995 amd 1996
;03/28/07 KAM/BAY Remedy Call 179232 Patch RA*5*77
; Add check to see if current RVU data is available and if
; not use previous year RVU data and added default scaling
; factors
;
;DBIA#:4799 ($$RVU^FBRVU) return wRVU value for CPT, CPT Mod, & exam
; date/time
;DBIA#:10060 EN1^RASELCT enacts 10060 which allows lookups on the NEW
; PERSON (#200) file
;DBIA#:10063 ($$S^%ZTLOAD)
;DBIA#:10103 ($$FMTE^XLFDT) & ($$NOW^XLFDT)
;DBIA#:10104 ($$CJ^XLFSTR)
;DBIA#:1519 ($$EN^XUTMDEVQ)
;DBIA#:4432 (LASTCY^FBAAFSR) return last calendar year file
; 162.99 was updated
;
EN(RASCLD) ;entry point
;input: RASCLD=one if scaled, 0 if un-scaled
K ^TMP($J,"RA PROCEDURES")
;
PROC ;allow the user to select one/many/all Rad/Nuc Med procedures
S RADIC="^RAMIS(71,",RADIC(0)="QEAMZ",RAUTIL="RA PROCEDURES"
S RADIC("A")="Select Procedures: ",RADIC("B")="All",RAXIT=0
;screen: based on user selection of procedure activity and that the
;procedure must have a CPT code (only detailed and series procedures)
S RADIC("S")="I $P(^(0),U,9)" ;must have a CPT code (detailed/series)
W !! D EN1^RASELCT(.RADIC,RAUTIL)
S RAXIT=RAQUIT K %W,%Y1,DIC,RADIC,RAQUIT,RAUTIL,X,Y
;did the user select physicians to compile data on? if not, quit
I $O(^TMP($J,"RA PROCEDURES",""))="" D D XIT Q
.W !!?3,$C(7),"Rad/Nuc Med Procedures were not selected."
.Q
;
F I="RASCLD","^TMP($J,""RA PROCEDURES""," S ZTSAVE(I)=""
S I="RA print wRVUs for Rad/Nuc Med procedures"
D EN^XUTMDEVQ("START^RAWRVUP",I,.ZTSAVE,,1)
I +$G(ZTSK)>0 W !!,"Task Number: "_ZTSK,!
K I,ZTSAVE,ZTSK
Q
;
START ;
S:$D(ZTQUEUED)#2 ZTREQ="@"
; 03/29/07 KAM/BAY Patch RA*5*77/179232 Added RACYFLG to next line
S $P(RALN,"-",IOM+1)="",(RACNT,RAPG,RAXIT,RACYFLG)=0
;03/29/07 KAM/BAY RA*5*77/179232 Added Fee Basis Data Check
D CHKCY
S RARUNDT=$$FMTE^XLFDT(DT,"1P")
S RAHDR="PROCEDURE CPT CODE AND"_$S(RASCLD=1:" SCALED",1:"")_" WORK RELATIVE VALUE UNITS (wRVU)"
S RAX="" D HDR
F S RAX=$O(^TMP($J,"RA PROCEDURES",RAX)) Q:RAX="" D Q:RAXIT
.S RAY=0
.F S RAY=$O(^TMP($J,"RA PROCEDURES",RAX,RAY)) Q:'RAY D Q:RAXIT
..S RACNT=RACNT+1 S:RACNT#500=0 (RAXIT,ZTSTOP)=$$S^%ZTLOAD() Q:RAXIT
..S RAMIS(0)=$G(^RAMIS(71,RAY,0))
..S RAPROC=$E($P(RAMIS(0),U),1,35) ;truncate to thirty-five chars
..S RAPTYPE=$S($P(RAMIS(0),U,6)="D":"Detailed",1:"Series")
..S RAITYPE=$P($G(^RA(79.2,+$P(RAMIS(0),U,12),0)),U,3)
..;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC
..S RACPT=$P(RAMIS(0),U,9),RACPT=$P($$NAMCODE^RACPTMSC(RACPT,DT),U,1)
..;determine if there are default CPT modifiers for this procedure; if
..;so, does one indicate 'bilateral'? If bilateral multiply wRVU by two.
..S RACPTMOD="",RABILAT=0
..I $O(^RAMIS(71,RAY,"DCM",0))>0 S RAI=0 D
...F S RAI=$O(^RAMIS(71,RAY,"DCM",RAI)) Q:'RAI D
....S RACPTMOD(0)=+$G(^RAMIS(71,RAY,"DCM",RAI,0))
....;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC
....S RA813(0)=$$BASICMOD^RACPTMSC(RACPTMOD(0),DT)
....I 'RABILAT,$P(RA813(0),U,2)=50 S RABILAT=1 ;bilateral multiplier=2
....S RACPTMOD=RACPTMOD_$P(RA813(0),U,2)_","
....Q
...Q
..;get wRVU value from FEE BASIS; returns a string: status^value^message
..;where status'=1 means "in error"
.. ;03/29/07 KAM/BAY RA*5*77/179232 Added $S to next line
..S RAWRVU=$$RVU^FBRVU(RACPT,RACPTMOD,$S(RACYFLG:DT-10000,1:DT))
.. ; 09/25/2006 Remedy call 154793 Correct 0 RVUs
.. I $P(RAWRVU,U,2)=0,RACPTMOD="" D
... ;03/29/07 KAM/BAY RA*5*77/179232 Added $S to next line
... S RAWRVU=$$RVU^FBRVU(RACPT,26,$S(RACYFLG:DT-10000,1:DT))
.. ;
..I $P(RAWRVU,U)=1 D
...;apply bilateral multiplier if appropriate
...S:RABILAT RAWRVU=$P(RAWRVU,U,2)*2
...;or not...
...S:'RABILAT RAWRVU=$P(RAWRVU,U,2)
...Q
..E S RAWRVU=0 ;status some other value than 1; "in error"
..;
..S:RAWRVU>0 RAWRVU=$J(RAWRVU,1,2)
..;
SCALED ..;when scaled find scaled wRVU value
..I RASCLD=1,(RAWRVU>0) D
...S RASFACTR=$$SFCTR(+$P(RAMIS(0),U,12)) ;pass i-type ptr
...S RASWRVU=$J((RAWRVU*RASFACTR),1,2)
...Q
..E S RASWRVU=0 ;mult by zero
..;
..W !,RAPROC,?37,RAPTYPE,?48,RAITYPE,?58,RACPT,?68,$S(RASCLD=1:$J(RASWRVU,7,2),1:$J(RAWRVU,7,2))
..I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR
..Q
.Q
I 'RAXIT,(RASCLD) S RASFACTR(0)="" D
.I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR
.W !!,"For calendar year "_($E(DT,1,3)+1700)_" the following scaling factors apply:"
.S I=0
. ;04/13/07 KAM/BAY RA*5*77 Modified next line to loop thru all imaging types
.F S I=$O(^RA(79.2,I)) Q:'I D Q:RAXIT
..S I(0)=$G(^RA(79.2,I,0))
..I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR
..; 04/13/07 KAM/BAY RA*5*77 Added $S to next line
.. 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)")
..Q
.S RAXIT=$$EOS^RAUTL5()
.Q
D XIT
Q
;
HDR ; Header for our report
W:RAPG!($E(IOST,1,2)="C-") @IOF
S RAPG=RAPG+1 W !?(IOM-$L(RAHDR)\2),RAHDR
W !,"Run Date: ",RARUNDT,?68,"Page: ",RAPG
;03/28/07 KAM/BAY RA*5*77/179232 Added next 2 lines
I $G(RACYFLG) D
. W !,?7,"***This report was prepared with "_$$LASTCY^FBAAFSR()_" Calendar Year RVU Data***"
W:'$D(RASFACTR(0))#2 !!,"Procedure",?37,"Proc Type",?48,"Img Type",?58,"CPT Code",?68,$S(RASCLD=1:" S",1:" ")_"wRVU"
W:$D(RASFACTR(0))#2 !!,"Imaging Type",?34,"Abbreviation",?51,"wRVU scaling factor"
W !,RALN
Q
;
XIT ;kill variables and exit
I 'RAXIT W:'RACNT !,$$CJ^XLFSTR("No data found for this report",IOM)
K DILN,DTOUT,DUOUT,I,POP,RA813,RABILAT,RACNT,RACPT,RACPTMOD,RAHDR,RAI
K RAITYPE,RALN,RAMIS,RAPTYPE,RAPG,RAPROC,RARUNDT,RASCLD,RASFACTR
K RASWRVU,RAWRVU,RAX,RAXIT,RAY,RAYEAR,X,Y,RACYFLG
K ^TMP($J,"RA PROCEDURES")
Q
;
SFCTR(RAITYP,RAYEAR) ;return the calendar year specific scaling factor for a
;specific imaging type
;input: RAITYP=imaging type
; RAYEAR=internal FM date/time format; resolves to current year
;return: calendar year specific scaling factor
N RASF,RAYR S RAYEAR=$G(RAYEAR,DT) ;default to DT (current year)
S (RAYEAR,RAYR)=$E(RAYEAR,1,3)+1700
S RASF=+$O(^RA(79.2,RAITYP,"CY","B",RAYEAR,0))
;if RASF=0 for the current year, check for the most recent year
I RASF=0 D
.S RAYEAR=+$O(^RA(79.2,1,"CY","B",RAYEAR),-1)
.S RASF=+$O(^RA(79.2,RAITYP,"CY","B",RAYEAR,0))
.Q
S RASF=+$P($G(^RA(79.2,RAITYP,"CY",RASF,0)),U,2)
S:RASF=0 RASF=1 ;defaults to one
Q $J(RASF,$L(RASF),2)_$S(RAYEAR:" ("_RAYR_")",1:"")
;
CHKCY ;03/28/2007 KAM/BAY RA*5*77 Remedy Call 179232 Check for latest RVU
;data from Fee Basis
S RACYFLG=0,Y=$G(DT) D DD^%DT
I $$LASTCY^FBAAFSR()<$P(Y," ",3) S RACYFLG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAWRVUP 7067 printed Sep 23, 2025@20:16:54 Page 2
RAWRVUP ;HISC/GJC-Display procedures with their wRVU values ;10/26/05 14:57
+1 ;;5.0;Radiology/Nuclear Medicine;**64,77**;Mar 16, 1998;Build 7
+2 ;09/25/06 KAM/BAY Remedy Call 154793 PATCH *77 RVU with 0 value
+3 ; and changed CPT calls from ^ICPTCOD to ^RACPTMSC
+4 ; eliminating the need for IA's 1995 amd 1996
+5 ;03/28/07 KAM/BAY Remedy Call 179232 Patch RA*5*77
+6 ; Add check to see if current RVU data is available and if
+7 ; not use previous year RVU data and added default scaling
+8 ; factors
+9 ;
+10 ;DBIA#:4799 ($$RVU^FBRVU) return wRVU value for CPT, CPT Mod, & exam
+11 ; date/time
+12 ;DBIA#:10060 EN1^RASELCT enacts 10060 which allows lookups on the NEW
+13 ; PERSON (#200) file
+14 ;DBIA#:10063 ($$S^%ZTLOAD)
+15 ;DBIA#:10103 ($$FMTE^XLFDT) & ($$NOW^XLFDT)
+16 ;DBIA#:10104 ($$CJ^XLFSTR)
+17 ;DBIA#:1519 ($$EN^XUTMDEVQ)
+18 ;DBIA#:4432 (LASTCY^FBAAFSR) return last calendar year file
+19 ; 162.99 was updated
+20 ;
EN(RASCLD) ;entry point
+1 ;input: RASCLD=one if scaled, 0 if un-scaled
+2 KILL ^TMP($JOB,"RA PROCEDURES")
+3 ;
PROC ;allow the user to select one/many/all Rad/Nuc Med procedures
+1 SET RADIC="^RAMIS(71,"
SET RADIC(0)="QEAMZ"
SET RAUTIL="RA PROCEDURES"
+2 SET RADIC("A")="Select Procedures: "
SET RADIC("B")="All"
SET RAXIT=0
+3 ;screen: based on user selection of procedure activity and that the
+4 ;procedure must have a CPT code (only detailed and series procedures)
+5 ;must have a CPT code (detailed/series)
SET RADIC("S")="I $P(^(0),U,9)"
+6 WRITE !!
DO EN1^RASELCT(.RADIC,RAUTIL)
+7 SET RAXIT=RAQUIT
KILL %W,%Y1,DIC,RADIC,RAQUIT,RAUTIL,X,Y
+8 ;did the user select physicians to compile data on? if not, quit
+9 IF $ORDER(^TMP($JOB,"RA PROCEDURES",""))=""
Begin DoDot:1
+10 WRITE !!?3,$CHAR(7),"Rad/Nuc Med Procedures were not selected."
+11 QUIT
End DoDot:1
DO XIT
QUIT
+12 ;
+13 FOR I="RASCLD","^TMP($J,""RA PROCEDURES"","
SET ZTSAVE(I)=""
+14 SET I="RA print wRVUs for Rad/Nuc Med procedures"
+15 DO EN^XUTMDEVQ("START^RAWRVUP",I,.ZTSAVE,,1)
+16 IF +$GET(ZTSK)>0
WRITE !!,"Task Number: "_ZTSK,!
+17 KILL I,ZTSAVE,ZTSK
+18 QUIT
+19 ;
START ;
+1 if $DATA(ZTQUEUED)#2
SET ZTREQ="@"
+2 ; 03/29/07 KAM/BAY Patch RA*5*77/179232 Added RACYFLG to next line
+3 SET $PIECE(RALN,"-",IOM+1)=""
SET (RACNT,RAPG,RAXIT,RACYFLG)=0
+4 ;03/29/07 KAM/BAY RA*5*77/179232 Added Fee Basis Data Check
+5 DO CHKCY
+6 SET RARUNDT=$$FMTE^XLFDT(DT,"1P")
+7 SET RAHDR="PROCEDURE CPT CODE AND"_$SELECT(RASCLD=1:" SCALED",1:"")_" WORK RELATIVE VALUE UNITS (wRVU)"
+8 SET RAX=""
DO HDR
+9 FOR
SET RAX=$ORDER(^TMP($JOB,"RA PROCEDURES",RAX))
if RAX=""
QUIT
Begin DoDot:1
+10 SET RAY=0
+11 FOR
SET RAY=$ORDER(^TMP($JOB,"RA PROCEDURES",RAX,RAY))
if 'RAY
QUIT
Begin DoDot:2
+12 SET RACNT=RACNT+1
if RACNT#500=0
SET (RAXIT,ZTSTOP)=$$S^%ZTLOAD()
if RAXIT
QUIT
+13 SET RAMIS(0)=$GET(^RAMIS(71,RAY,0))
+14 ;truncate to thirty-five chars
SET RAPROC=$EXTRACT($PIECE(RAMIS(0),U),1,35)
+15 SET RAPTYPE=$SELECT($PIECE(RAMIS(0),U,6)="D":"Detailed",1:"Series")
+16 SET RAITYPE=$PIECE($GET(^RA(79.2,+$PIECE(RAMIS(0),U,12),0)),U,3)
+17 ;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC
+18 SET RACPT=$PIECE(RAMIS(0),U,9)
SET RACPT=$PIECE($$NAMCODE^RACPTMSC(RACPT,DT),U,1)
+19 ;determine if there are default CPT modifiers for this procedure; if
+20 ;so, does one indicate 'bilateral'? If bilateral multiply wRVU by two.
+21 SET RACPTMOD=""
SET RABILAT=0
+22 IF $ORDER(^RAMIS(71,RAY,"DCM",0))>0
SET RAI=0
Begin DoDot:3
+23 FOR
SET RAI=$ORDER(^RAMIS(71,RAY,"DCM",RAI))
if 'RAI
QUIT
Begin DoDot:4
+24 SET RACPTMOD(0)=+$GET(^RAMIS(71,RAY,"DCM",RAI,0))
+25 ;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC
+26 SET RA813(0)=$$BASICMOD^RACPTMSC(RACPTMOD(0),DT)
+27 ;bilateral multiplier=2
IF 'RABILAT
IF $PIECE(RA813(0),U,2)=50
SET RABILAT=1
+28 SET RACPTMOD=RACPTMOD_$PIECE(RA813(0),U,2)_","
+29 QUIT
End DoDot:4
+30 QUIT
End DoDot:3
+31 ;get wRVU value from FEE BASIS; returns a string: status^value^message
+32 ;where status'=1 means "in error"
+33 ;03/29/07 KAM/BAY RA*5*77/179232 Added $S to next line
+34 SET RAWRVU=$$RVU^FBRVU(RACPT,RACPTMOD,$SELECT(RACYFLG:DT-10000,1:DT))
+35 ; 09/25/2006 Remedy call 154793 Correct 0 RVUs
+36 IF $PIECE(RAWRVU,U,2)=0
IF RACPTMOD=""
Begin DoDot:3
+37 ;03/29/07 KAM/BAY RA*5*77/179232 Added $S to next line
+38 SET RAWRVU=$$RVU^FBRVU(RACPT,26,$SELECT(RACYFLG:DT-10000,1:DT))
End DoDot:3
+39 ;
+40 IF $PIECE(RAWRVU,U)=1
Begin DoDot:3
+41 ;apply bilateral multiplier if appropriate
+42 if RABILAT
SET RAWRVU=$PIECE(RAWRVU,U,2)*2
+43 ;or not...
+44 if 'RABILAT
SET RAWRVU=$PIECE(RAWRVU,U,2)
+45 QUIT
End DoDot:3
+46 ;status some other value than 1; "in error"
IF '$TEST
SET RAWRVU=0
+47 ;
+48 if RAWRVU>0
SET RAWRVU=$JUSTIFY(RAWRVU,1,2)
+49 ;
SCALED ;when scaled find scaled wRVU value
+1 IF RASCLD=1
IF (RAWRVU>0)
Begin DoDot:3
+2 ;pass i-type ptr
SET RASFACTR=$$SFCTR(+$PIECE(RAMIS(0),U,12))
+3 SET RASWRVU=$JUSTIFY((RAWRVU*RASFACTR),1,2)
+4 QUIT
End DoDot:3
+5 ;mult by zero
IF '$TEST
SET RASWRVU=0
+6 ;
+7 WRITE !,RAPROC,?37,RAPTYPE,?48,RAITYPE,?58,RACPT,?68,$SELECT(RASCLD=1:$JUSTIFY(RASWRVU,7,2),1:$JUSTIFY(RAWRVU,7,2))
+8 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HDR
+9 QUIT
End DoDot:2
if RAXIT
QUIT
+10 QUIT
End DoDot:1
if RAXIT
QUIT
+11 IF 'RAXIT
IF (RASCLD)
SET RASFACTR(0)=""
Begin DoDot:1
+12 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
DO HDR
+13 WRITE !!,"For calendar year "_($EXTRACT(DT,1,3)+1700)_" the following scaling factors apply:"
+14 SET I=0
+15 ;04/13/07 KAM/BAY RA*5*77 Modified next line to loop thru all imaging types
+16 FOR
SET I=$ORDER(^RA(79.2,I))
if 'I
QUIT
Begin DoDot:2
+17 SET I(0)=$GET(^RA(79.2,I,0))
+18 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
DO HDR
+19 ; 04/13/07 KAM/BAY RA*5*77 Added $S to next line
+20 WRITE !,$PIECE(I(0),U),?34,$PIECE(I(0),U,3),?49,$SELECT($ORDER(^RA(79.2,I,"CY",0))>0:$$SFCTR^RAWRVUP(I,DT),1:"1.00 (default)")
+21 QUIT
End DoDot:2
if RAXIT
QUIT
+22 SET RAXIT=$$EOS^RAUTL5()
+23 QUIT
End DoDot:1
+24 DO XIT
+25 QUIT
+26 ;
HDR ; Header for our report
+1 if RAPG!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET RAPG=RAPG+1
WRITE !?(IOM-$LENGTH(RAHDR)\2),RAHDR
+3 WRITE !,"Run Date: ",RARUNDT,?68,"Page: ",RAPG
+4 ;03/28/07 KAM/BAY RA*5*77/179232 Added next 2 lines
+5 IF $GET(RACYFLG)
Begin DoDot:1
+6 WRITE !,?7,"***This report was prepared with "_$$LASTCY^FBAAFSR()_" Calendar Year RVU Data***"
End DoDot:1
+7 if '$DATA(RASFACTR(0))#2
WRITE !!,"Procedure",?37,"Proc Type",?48,"Img Type",?58,"CPT Code",?68,$SELECT(RASCLD=1:" S",1:" ")_"wRVU"
+8 if $DATA(RASFACTR(0))#2
WRITE !!,"Imaging Type",?34,"Abbreviation",?51,"wRVU scaling factor"
+9 WRITE !,RALN
+10 QUIT
+11 ;
XIT ;kill variables and exit
+1 IF 'RAXIT
if 'RACNT
WRITE !,$$CJ^XLFSTR("No data found for this report",IOM)
+2 KILL DILN,DTOUT,DUOUT,I,POP,RA813,RABILAT,RACNT,RACPT,RACPTMOD,RAHDR,RAI
+3 KILL RAITYPE,RALN,RAMIS,RAPTYPE,RAPG,RAPROC,RARUNDT,RASCLD,RASFACTR
+4 KILL RASWRVU,RAWRVU,RAX,RAXIT,RAY,RAYEAR,X,Y,RACYFLG
+5 KILL ^TMP($JOB,"RA PROCEDURES")
+6 QUIT
+7 ;
SFCTR(RAITYP,RAYEAR) ;return the calendar year specific scaling factor for a
+1 ;specific imaging type
+2 ;input: RAITYP=imaging type
+3 ; RAYEAR=internal FM date/time format; resolves to current year
+4 ;return: calendar year specific scaling factor
+5 ;default to DT (current year)
NEW RASF,RAYR
SET RAYEAR=$GET(RAYEAR,DT)
+6 SET (RAYEAR,RAYR)=$EXTRACT(RAYEAR,1,3)+1700
+7 SET RASF=+$ORDER(^RA(79.2,RAITYP,"CY","B",RAYEAR,0))
+8 ;if RASF=0 for the current year, check for the most recent year
+9 IF RASF=0
Begin DoDot:1
+10 SET RAYEAR=+$ORDER(^RA(79.2,1,"CY","B",RAYEAR),-1)
+11 SET RASF=+$ORDER(^RA(79.2,RAITYP,"CY","B",RAYEAR,0))
+12 QUIT
End DoDot:1
+13 SET RASF=+$PIECE($GET(^RA(79.2,RAITYP,"CY",RASF,0)),U,2)
+14 ;defaults to one
if RASF=0
SET RASF=1
+15 QUIT $JUSTIFY(RASF,$LENGTH(RASF),2)_$SELECT(RAYEAR:" ("_RAYR_")",1:"")
+16 ;
CHKCY ;03/28/2007 KAM/BAY RA*5*77 Remedy Call 179232 Check for latest RVU
+1 ;data from Fee Basis
+2 SET RACYFLG=0
SET Y=$GET(DT)
DO DD^%DT
+3 IF $$LASTCY^FBAAFSR()<$PIECE(Y," ",3)
SET RACYFLG=1
+4 QUIT
