RABWORD2 ;HOIFO/KAR - Radiology Billing Awareness ;12/20/04 3:55pm
;;5.0;Radiology/Nuclear Medicine;**41,70**;Mar 16, 1998;Build 7
;
; Rtn invokes IA #1300-A, #2083, #4419
Q
ORDER ; List Exam Orders to select to copy ICD-9 SC/EC Indicator values from
D HDR S (RAXIT,RACOPY)=0
N RALP,RA751,DIROUT,DIRUT,DTOUT,DUOUT S (RALP,RAXIT)=0
F S RALP=$O(^RAO(75.1,"B",RADFN,RALP)) Q:RALP'>0!(RAXIT) D
.S RA751(0)=$G(^RAO(75.1,RALP,0)),RA751(2)=$P(RA751(0),U,2)
.Q:RA751(2)=""
.S RA751(16)=$P(RA751(0),U,16),RA751(20)=$P(RA751(0),U,20)
.S RA751(5)=+$P(RA751(0),U,5) Q:RA751(5)=1
.S Y=RA751(2),C=$P($G(^DD(75.1,2,0)),U,2) D Y^DIQ S RA751(2)=Y
.S Y=RA751(20),C=$P($G(^DD(75.1,20,0)),U,2) D Y^DIQ S RA751(20)=Y
.S RACOPY=RACOPY+1,RACOPY(RACOPY)=RALP
.W !,RACOPY,?10,$E(RA751(2),1,28),?39
.W $S(RA751(16)]"":$$FMTE^XLFDT(RA751(16),"2D"),1:"")
.W ?52,$E(RA751(20),1,12) ; prints 'SUBMIT REQUEST TO' data
.I $E(IOST,1,2)="C-",($Y>(IOSL-4)) D
..K DIR S DIR(0)="E" D ^DIR K DIR S:'+Y RAXIT=1
..I 'RAXIT W @IOF D HDR
Q
HDR ; Header
D HOME^%ZIS W:$D(RAOPT("ORDEREXAM"))#2 @IOF
W !!,"#",?10,"Last Procedures/New Orders",?39,"Order Date",?52,"Imaging Loc."
W !,"------",?10,"----------------------------",?39,"------------",?52,"------------"
Q
PREV ;Prompt for Copying a previous Order's DX/SC/EC values.
Q:'$D(^XUSEC("PROVIDER",DUZ)) ;user provider key check
Q:'$$CIDC^IBBAPI(RADFN) ;patient insurance & CIDC switch check
N RAPREV S RAPREV=0 K DIR
I $P($G(VAEL(3)),"^") D
.S DIR("B")="NO",DIR("A")="Copy a previous order's ICD codes and SC/EI values",DIR(0)="YO"
.S DIR("?")="Answer 'Y' if you plan to copy ICD-9 Diagnosis codes and Service Connected/Environmental Indicator values to this order." D ^DIR
I '$P($G(VAEL(3)),"^") D
.S DIR("B")="NO",DIR("A")="Copy a previous order's ICD codes",DIR(0)="YO"
.S DIR("?")="Answer 'Y' if you plan to copy ICD-9 Diagnosis codes to this order." D ^DIR
I Y D
.N RACOPY D ORDER
.K DIR S DIR("A")="Select Order # to copy",DIR(0)="NO" D ^DIR
.I '$D(RACOPY(+Y)) W !,"*Invalid selection" S RAPREV=1 Q
.I +Y>0 D
..I '$D(^RAO(75.1,RACOPY(+Y),"BA")) W !,"*No Previous ICD codes entered for this order" Q
..S ^TMP("RACOPY",$J,"BA")=^RAO(75.1,RACOPY(+Y),"BA")
..N RABASEC S RABASEC=0 F S RABASEC=$O(^RAO(75.1,RACOPY(+Y),"BAS",RABASEC)) Q:RABASEC<1 D
...S ^TMP("RACOPY",$J,"BA",$P(^RAO(75.1,RACOPY(+Y),"BAS",RABASEC,0),U,1))=^RAO(75.1,RACOPY(+Y),"BAS",RABASEC,0)
G:RAPREV PREV
Q
ELIG ;List the Service Connected ratios for the patient
N RAY,RAELIG,RASC,RAPERC,RAAO,RAIR,RAEC,RASHAD
D DEM^VADPT,ELIG^VADPT,SVC^VADPT
S RAELIG=$P(VAEL(1),"^",2),RASC=$P(VAEL(3),"^"),RASC=$S(RASC:"YES",RASC=0:"NO",1:""),RAPERC=$P(VAEL(3),"^",2)
S RAAO=$S(VASV(2):"YES",1:"NO"),RAIR=$S(VASV(3):"YES",1:"NO"),RASHAD=$S($G(VASV(11)):"YES",1:"NO")
S DIC=2,DA=RADFN,DR=".322013",DIQ="RAY",DIQ(0)="I" D EN^DIQ1 K DA,DIC,DIQ,DR
S RAEC=RAY(2,RADFN,.322013,"I"),RAEC=$S(RAEC="Y":"YES",1:"NO")
W @IOF,!,VADM(1)_" ("_VA("PID")_") ",$P(VAEL(6),"^",2),!!," * * * Eligibility Information and Service Connected Conditions * * *"
W !!,?5,"Primary Eligibility: "_RAELIG,!,?5,"A/O Exp.: "_RAAO,?22,"ION Rad.: "_RAIR,?40,"SWAC: "_RAEC,?57,"SHAD: "_RASHAD,!
Q
ADDEXAM ;Add DX/SC/EI data to new order when adding order to Last Visit
Q:'$D(^XUSEC("PROVIDER",DUZ)) ;user provider key check
Q:'$$CIDC^IBBAPI(RADFN) ;patient insurance & CIDC switch check
N RAOIEN,RACOPY,RABASEC
S RAOIEN=$P(^RADPT(RADFN,"DT",RAVLEDTI,"P",RAVLECNI,0),U,11)
Q:'$D(^RAO(75.1,RAOIEN,"BA"))
S ^TMP("RACOPY",$J,"BA")=^RAO(75.1,RAOIEN,"BA")
S RABASEC=0 F S RABASEC=$O(^RAO(75.1,RAOIEN,"BAS",RABASEC)) Q:RABASEC<1 D
.S ^TMP("RACOPY",$J,"BA",$P(^RAO(75.1,RAOIEN,"BAS",RABASEC,0),U,1))=^RAO(75.1,RAOIEN,"BAS",RABASEC,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRABWORD2 3811 printed Sep 23, 2025@20:09:59 Page 2
RABWORD2 ;HOIFO/KAR - Radiology Billing Awareness ;12/20/04 3:55pm
+1 ;;5.0;Radiology/Nuclear Medicine;**41,70**;Mar 16, 1998;Build 7
+2 ;
+3 ; Rtn invokes IA #1300-A, #2083, #4419
+4 QUIT
ORDER ; List Exam Orders to select to copy ICD-9 SC/EC Indicator values from
+1 DO HDR
SET (RAXIT,RACOPY)=0
+2 NEW RALP,RA751,DIROUT,DIRUT,DTOUT,DUOUT
SET (RALP,RAXIT)=0
+3 FOR
SET RALP=$ORDER(^RAO(75.1,"B",RADFN,RALP))
if RALP'>0!(RAXIT)
QUIT
Begin DoDot:1
+4 SET RA751(0)=$GET(^RAO(75.1,RALP,0))
SET RA751(2)=$PIECE(RA751(0),U,2)
+5 if RA751(2)=""
QUIT
+6 SET RA751(16)=$PIECE(RA751(0),U,16)
SET RA751(20)=$PIECE(RA751(0),U,20)
+7 SET RA751(5)=+$PIECE(RA751(0),U,5)
if RA751(5)=1
QUIT
+8 SET Y=RA751(2)
SET C=$PIECE($GET(^DD(75.1,2,0)),U,2)
DO Y^DIQ
SET RA751(2)=Y
+9 SET Y=RA751(20)
SET C=$PIECE($GET(^DD(75.1,20,0)),U,2)
DO Y^DIQ
SET RA751(20)=Y
+10 SET RACOPY=RACOPY+1
SET RACOPY(RACOPY)=RALP
+11 WRITE !,RACOPY,?10,$EXTRACT(RA751(2),1,28),?39
+12 WRITE $SELECT(RA751(16)]"":$$FMTE^XLFDT(RA751(16),"2D"),1:"")
+13 ; prints 'SUBMIT REQUEST TO' data
WRITE ?52,$EXTRACT(RA751(20),1,12)
+14 IF $EXTRACT(IOST,1,2)="C-"
IF ($Y>(IOSL-4))
Begin DoDot:2
+15 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if '+Y
SET RAXIT=1
+16 IF 'RAXIT
WRITE @IOF
DO HDR
End DoDot:2
End DoDot:1
+17 QUIT
HDR ; Header
+1 DO HOME^%ZIS
if $DATA(RAOPT("ORDEREXAM"))#2
WRITE @IOF
+2 WRITE !!,"#",?10,"Last Procedures/New Orders",?39,"Order Date",?52,"Imaging Loc."
+3 WRITE !,"------",?10,"----------------------------",?39,"------------",?52,"------------"
+4 QUIT
PREV ;Prompt for Copying a previous Order's DX/SC/EC values.
+1 ;user provider key check
if '$DATA(^XUSEC("PROVIDER",DUZ))
QUIT
+2 ;patient insurance & CIDC switch check
if '$$CIDC^IBBAPI(RADFN)
QUIT
+3 NEW RAPREV
SET RAPREV=0
KILL DIR
+4 IF $PIECE($GET(VAEL(3)),"^")
Begin DoDot:1
+5 SET DIR("B")="NO"
SET DIR("A")="Copy a previous order's ICD codes and SC/EI values"
SET DIR(0)="YO"
+6 SET DIR("?")="Answer 'Y' if you plan to copy ICD-9 Diagnosis codes and Service Connected/Environmental Indicator values to this order."
DO ^DIR
End DoDot:1
+7 IF '$PIECE($GET(VAEL(3)),"^")
Begin DoDot:1
+8 SET DIR("B")="NO"
SET DIR("A")="Copy a previous order's ICD codes"
SET DIR(0)="YO"
+9 SET DIR("?")="Answer 'Y' if you plan to copy ICD-9 Diagnosis codes to this order."
DO ^DIR
End DoDot:1
+10 IF Y
Begin DoDot:1
+11 NEW RACOPY
DO ORDER
+12 KILL DIR
SET DIR("A")="Select Order # to copy"
SET DIR(0)="NO"
DO ^DIR
+13 IF '$DATA(RACOPY(+Y))
WRITE !,"*Invalid selection"
SET RAPREV=1
QUIT
+14 IF +Y>0
Begin DoDot:2
+15 IF '$DATA(^RAO(75.1,RACOPY(+Y),"BA"))
WRITE !,"*No Previous ICD codes entered for this order"
QUIT
+16 SET ^TMP("RACOPY",$JOB,"BA")=^RAO(75.1,RACOPY(+Y),"BA")
+17 NEW RABASEC
SET RABASEC=0
FOR
SET RABASEC=$ORDER(^RAO(75.1,RACOPY(+Y),"BAS",RABASEC))
if RABASEC<1
QUIT
Begin DoDot:3
+18 SET ^TMP("RACOPY",$JOB,"BA",$PIECE(^RAO(75.1,RACOPY(+Y),"BAS",RABASEC,0),U,1))=^RAO(75.1,RACOPY(+Y),"BAS",RABASEC,0)
End DoDot:3
End DoDot:2
End DoDot:1
+19 if RAPREV
GOTO PREV
+20 QUIT
ELIG ;List the Service Connected ratios for the patient
+1 NEW RAY,RAELIG,RASC,RAPERC,RAAO,RAIR,RAEC,RASHAD
+2 DO DEM^VADPT
DO ELIG^VADPT
DO SVC^VADPT
+3 SET RAELIG=$PIECE(VAEL(1),"^",2)
SET RASC=$PIECE(VAEL(3),"^")
SET RASC=$SELECT(RASC:"YES",RASC=0:"NO",1:"")
SET RAPERC=$PIECE(VAEL(3),"^",2)
+4 SET RAAO=$SELECT(VASV(2):"YES",1:"NO")
SET RAIR=$SELECT(VASV(3):"YES",1:"NO")
SET RASHAD=$SELECT($GET(VASV(11)):"YES",1:"NO")
+5 SET DIC=2
SET DA=RADFN
SET DR=".322013"
SET DIQ="RAY"
SET DIQ(0)="I"
DO EN^DIQ1
KILL DA,DIC,DIQ,DR
+6 SET RAEC=RAY(2,RADFN,.322013,"I")
SET RAEC=$SELECT(RAEC="Y":"YES",1:"NO")
+7 WRITE @IOF,!,VADM(1)_" ("_VA("PID")_") ",$PIECE(VAEL(6),"^",2),!!," * * * Eligibility Information and Service Connected Conditions * * *"
+8 WRITE !!,?5,"Primary Eligibility: "_RAELIG,!,?5,"A/O Exp.: "_RAAO,?22,"ION Rad.: "_RAIR,?40,"SWAC: "_RAEC,?57,"SHAD: "_RASHAD,!
+9 QUIT
ADDEXAM ;Add DX/SC/EI data to new order when adding order to Last Visit
+1 ;user provider key check
if '$DATA(^XUSEC("PROVIDER",DUZ))
QUIT
+2 ;patient insurance & CIDC switch check
if '$$CIDC^IBBAPI(RADFN)
QUIT
+3 NEW RAOIEN,RACOPY,RABASEC
+4 SET RAOIEN=$PIECE(^RADPT(RADFN,"DT",RAVLEDTI,"P",RAVLECNI,0),U,11)
+5 if '$DATA(^RAO(75.1,RAOIEN,"BA"))
QUIT
+6 SET ^TMP("RACOPY",$JOB,"BA")=^RAO(75.1,RAOIEN,"BA")
+7 SET RABASEC=0
FOR
SET RABASEC=$ORDER(^RAO(75.1,RAOIEN,"BAS",RABASEC))
if RABASEC<1
QUIT
Begin DoDot:1
+8 SET ^TMP("RACOPY",$JOB,"BA",$PIECE(^RAO(75.1,RAOIEN,"BAS",RABASEC,0),U,1))=^RAO(75.1,RAOIEN,"BAS",RABASEC,0)
End DoDot:1
+9 QUIT
