Routine: RABWORD2

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

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

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,"------------"

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

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,!

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRABWORD2   3811     printed  Feb 19, 2025@00:00:14                                                                                                                                                                                                    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

RABWORD2.m