RAORD2.m

RAORD2 ;HISC/CAH,FPT,GJC,DAD AISC/RMO-Detailed Request Display ;9/3/99  13:48

 ;;5.0;Radiology/Nuclear Medicine;**5,10,51,45,75**;Mar 16, 1998;Build 4

 K XQADATA

 D HOME^%ZIS K DIC S DIC="^DPT(",DIC(0)="AEMQ"

 W ! D ^DIC G Q:Y<0

 S RADFN=+Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown")

 S RAOFNS="Display",RAOVSTS="1;2;3;5;6;8" D LOCATN I $G(RAQUIT) D Q Q

 I RAONE]"" S ^TMP($J,"RA L-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))=""

 S ^TMP($J,"RA L-TYPE","Unknown")=""

 I '$D(^TMP($J,"RA L-TYPE")) D ERROR^RAUTL7A D Q QUIT

 S X=0 W !!,"Imaging Location(s) included:"

 F  S X=$O(^TMP($J,"RA L-TYPE",X)) Q:X']""  D

 . W:($X+$L(X)+2)'<IOM !?$L("Imaging Location(s) included:") W ?($X+3),X

 . Q

 W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) D Q Q

 D ^RAORDS G Q:'$D(RAORDS)

OERR ; Entry Point for OE/RR Cancel/Hold Alert

 I $D(XQADATA) D

 . S RAORDS(1)=+XQADATA

 . I $P(XQADATA,",",2)'="" S RADFN=$P(XQADATA,",",2)

 S RAPKG="",RAOSTSYM="dc^c^h^^p^^^s",$P(RALNE,"-",79)="",RAX=""

 F RAOLP=1:1 S RAOIFN=$S($D(RAORDS(RAOLP)):RAORDS(RAOLP),1:0) Q:'RAOIFN!(RAX=U)  D DISORD

 ;

 K:RAX="^" XQAID,XQAKILL I $D(XQAID) S DFN=$P(XQAID,",",2) D DELETE^XQALERT

Q K %,DIC,I,OREND,RA,RACI,RACNI,RADFN,RADIV,RADIVPAR,RADPT0,RADTI,RALNE

 K RANME,RAOFNS,RAOIFN,RAOLP,RAORD0,RAORDS,RAOSTS,RAOSTSYM,RAOVSTS,RAPKG

 K RAONE,RAQUIT,RASSN,X,XQAID,XQALERT,Y,RAX,VA200,VAERR,VAIP

 K RAPARENT,RACMFLG

 K DFN,DIPGM,DISYS,DIW,DIWI,DIWT,DIWTC,DIWX,DN,RA6,RA7,POP,^TMP($J,"PRO-ORD")

 K ^TMP($J,"RA L-TYPE"),^TMP($J,"RAORDS"),^TMP($J,"RA DIFF PRC") Q

 ;

 ;

DISORD Q:'$D(^DPT(RADFN,0))  S RADPT0=^(0),RA("NME")=$P(RADPT0,"^"),RA("DOB")=$P(RADPT0,"^",3),RASSN=$$SSN^RAUTL Q:'$D(^RAO(75.1,RAOIFN,0))  S RAORD0=^(0)

 ;determine if ordered procedure has CM assoc.; return null if none

 S RAZPRC0=$G(^RAMIS(71,+$P(RAORD0,U,2),0))

 S RACMFLG("O")=$$CMEDIA^RAO7UTL(+$P(RAORD0,U,2),$P(RAZPRC0,U,6))

 K RAZPRC0

 I $D(^RADPT("AO",RAOIFN,RADFN)) D DPRC(RAOIFN,RADFN)

 S RA("PROC. NODE")=$G(^RAMIS(71,+$P(RAORD0,U,2),0))

 S RA("PRC")=$E($P(RA("PROC. NODE"),U),1,36)

 S RA("PRCTY")=$P(RA("PROC. NODE"),U,6)

 S RA("PRCTY")=$$XTERNAL^RAUTL5(RA("PRCTY"),$P($G(^DD(71,6,0)),U,2))

 S RA("PRCTY")=$E(RA("PRCTY"))_$$LOW^XLFSTR($E(RA("PRCTY"),2,99))

 S RA("CPT")=+$P(RA("PROC. NODE"),U,9)

 ; don't find CPT code if procedure has type = Parent

 S RA("CPT")=$S($E(RA("PRCTY"))="P":"",1:$P($$NAMCODE^RACPTMSC(RA("CPT"),DT),U))

 S RA("PRCIT")=+$P(RA("PROC. NODE"),U,12)

 S RA("PRCIT")=$P($G(^RA(79.2,RA("PRCIT"),0)),U,3)

 S RA("PROC INFO")="",$E(RA("PROC INFO"),1,36)=RA("PRC")

 S RA("CNCAT")="("_RA("PRCIT")_" "_RA("PRCTY")_" "_RA("CPT")_")"

 S $E(RA("PROC INFO"),38,60)=RA("CNCAT") K RA("CNCAT"),RA("PRCIT")

 K RA("PRCTY"),RA("CPT")

 S RA("STY_REA")=$P($G(^RAO(75.1,RAOIFN,.1)),U) ;P75

 K RA("MOD") F I=0:0 S I=$O(^RAO(75.1,RAOIFN,"M","B",I)) Q:'I  I $D(^RAMIS(71.2,+I,0)) S RA("MOD")=$S('$D(RA("MOD")):$P(^(0),"^"),1:RA("MOD")_", "_$P(^(0),"^"))

 S RA("OST")=$P($P(^DD(75.1,5,0),$P(RAORD0,"^",5)_":",2),";")_$S($P(RAOSTSYM,"^",$P(RAORD0,"^",5))="":"",1:" ("_$P(RAOSTSYM,"^",$P(RAORD0,"^",5))_")")

 S RA("PHY")=$S($D(^VA(200,+$P(RAORD0,"^",14),0)):$P(^(0),"^"),1:"")

 ; Requesting Physician phone/pager info

 D PHONE^RAORD5("R",+$P(RAORD0,"^",14))

 S RA("HLC")=$S($D(^SC(+$P(RAORD0,"^",22),0)):$P(^(0),"^"),1:"")

 S DFN=RADFN,VA200=1 D IN5^VADPT I VAIP(1) S RA("ROOM-BED")=$S(+VAIP(6):$P(VAIP(6),"^",2),1:"")

 K RA("ODT") S X=$P(RAORD0,"^",16) I X S:$P(X,".",2) X=$P(X,".")_"."_$$NOSECNDS^RAORD3($P(X,".",2)) S RA("ODT")=$$FMTE^XLFDT(X,"1P")

 S RA("USR")=$S($D(^VA(200,+$P(RAORD0,"^",15),0)):$P(^(0),"^"),1:"")

 D HDR ; display a header

 W !,"Requested :",?12,RA("PROC INFO")

 I $D(^TMP($J,"RA DIFF PRC")) D

 .N CRTN,I S CRTN=0,I="" W !,"Registered:"

 .F  S I=$O(^TMP($J,"RA DIFF PRC",I)) Q:I']""  D

 ..W:CRTN ! W ?12,I S CRTN=1

 .Q

 I $G(RACMFLG("O"))'="" W:$X ! W ?12,"** The requested procedure has contrast media assigned **"

 I $G(RACMFLG("R"))'="" W:$X ! W ?12,"** A registered procedure uses contrast media **"

 W:$D(RA("MOD")) !,"Procedure Modifiers:",?22,RA("MOD")

 W !!,"Current Status:",?22,$E(RA("OST"),1,24)

 W !,"Requester:",?22,$E(RA("PHY"),1,24)

 W !?1,"Tel/Page/Dig Page: ",RA("RPHOINFO")

 W !,"Patient Location:",?22,$E(RA("HLC"),1,20)

 W:$D(RA("ROOM-BED")) !,"Room-Bed:",?22,$E(RA("ROOM-BED"),1,20)

 W !,"Entered:",?22,$S($D(RA("ODT")):RA("ODT"),1:""),"  by ",$E(RA("USR"),1,20)

 ;

ENDIS ;OE/RR Entry Point for the PRINT ACTION Option

 I '$D(RAPKG) Q:'$D(ORPK)  S RAOIFN=+ORPK Q:'$D(^RAO(75.1,RAOIFN,0))  S RAORD0=^(0),RADFN=+$P(RAORD0,"^")

 S RA("TRAN")=$S($P(RAORD0,"^",19)']"":"",1:$P($P(^DD(75.1,19,0),$P(RAORD0,"^",19)_":",2),";"))

 K RA("ST") I $D(^RADPT("AO",RAOIFN,RADFN)) S RADTI=+$O(^(RADFN,0)),RACNI=+$O(^(RADTI,0)) I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RA(0)=^(0) I $D(^RA(72,+$P(RA(0),"^",3),0)) S RA("ST")=$P(^(0),"^")

 I '$D(RAPKG) D DPRC(RAOIFN,RADFN) K ^TMP($J,"RA DIFF PRC")

 S RADIV(0)=$G(^SC(+$P(RAORD0,"^",22),0))

 S RADIV=+$$SITE^VASITE(DT,+$P(RADIV(0),"^",15)) S:RADIV<0 RADIV=0

 S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))

 S RADIVPAR=$S($D(^RA(79,+RADIV,.1)):^(.1),1:"")

 K RA("RDT") S Y=$P(RAORD0,"^",21) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("RDT")=$$FMTE^XLFDT(Y,"1P")

 K RA("PDT") S Y=$P(RAORD0,"^",12) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("PDT")=$$FMTE^XLFDT(Y,"1P")

 K RA("VDT") S Y=$P(RAORD0,"^",17) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("VDT")=$$FMTE^XLFDT(Y,"1P")

 K RA("SDT") S Y=$P(RAORD0,"^",23) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("SDT")=$$FMTE^XLFDT(Y,"1P")

 S RA("ILC")=$S('$P(RAORD0,"^",20):"UNKNOWN",'$D(^RA(79.1,+$P(RAORD0,"^",20),0)):"UNKNOWN",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"UNKNOWN")

 I $S('$D(XQORNOD(0)):0,$P(XQORNOD(0),"^",3)'="Results Display":0,1:1),$D(RA(0)) D ^RAORR3 Q

 D ^RAORD3 K RA,RACI,RACNI,RADIV,RADIVPAR,RADPT0,RADTI,RAORD0,RAOSTS,X,Y I '$D(RAPKG) K RADFN,RAOIFN

 Q

LOCATN ; Select or default to a Rad/Nuc Med location.

 S RAONE=$$LOC1() Q:RAONE]""

 S RADIC="^RA(79.1,",RADIC(0)="QEAMZ"

 S RADIC("A")="Select Rad/Nuc Med Location: "

 S RADIC("B")="All",RAUTIL="RA L-TYPE"

 W !! D EN1^RASELCT(.RADIC,RAUTIL) K DIC,RADIC,RAUTIL,X,Y

 Q

LOC1() ; Checking for only one Imaging Location

 ; Pass back null if more that one entry exists in 79.1 

 ; If one entry, pass back: external Hosp. Loc. file_"^"_IEN of file 79.1

 N X,Y S X=""

 I $P($G(^RA(79.1,0)),"^",4)=1 D

 . S Y=+$O(^RA(79.1,0)) Q:'Y

 . S Y(0)=$G(^RA(79.1,Y,0)),Y(1)=+$P(Y(0),"^")

 . S Y(44)=$P($G(^SC(Y(1),0)),"^"),X=Y(44)_"^"_Y

 . Q

 Q X

HDR ; Header for the 'Detailed Request Display' option.  Called from above

 ; (D HDR) and from RAORD3

 W @IOF,?22,"**** Detailed Display ****",!!,"Name: ",RA("NME"),"    (",RASSN,")" S Y=RA("DOB") D D^RAUTL W ?45,"Date of Birth: ",Y,!,RALNE

 Q

 ;

DPRC(RAOIFN,RADFN) ; If the ordered procedure has been registered check

 ;if this is an examset. If not an examset, find the status of the exam

 ;RA("ST"). Also, check if the ordered procedure has been changed at

 ;time of registration (DPROC^RAUTL15). If it has, store the data off

 ;in ^TMP($J,"RA DIFF PRC").

 ;

 ; NOTE: The only time we don't set ^TMP($J,"RA DIFF PRC") is when

 ; we are using the 'Detailed Request Display' option and the ordered

 ; procedure is the same as the registered procedure.  All other

 ; Request display options output the ordered procedure, the

 ; registered procedure and exam case number if the order

 ; is active.

 ;

 ;Set the variable RACMFLG("R") to "Y" if an exam, either a single or

 ;descendant, has used contrast media during the examination.

 ;

 N RA7003,RACNI,RADTI,RAFLG K RA("ST"),^TMP($J,"RA DIFF PRC")

 S (RADTI,RAFLG)=0

 F  S RADTI=+$O(^RADPT("AO",RAOIFN,RADFN,RADTI)) Q:RADTI'>0  D

 . S RACNI=0

 . F  S RACNI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI)) Q:RACNI'>0  D

 .. I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) D

 ... S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),RAFLG=RAFLG+1

 ... S:$G(RACMFLG("R"))="" RACMFLG("R")=$S($P(RA7003,U,10)="Y":"Y",1:"")

 ... S RA("ST")=$$GET1^DIQ(72,+$P(RA7003,"^",3)_",",.01)

 ... N RAPRC S RAPRC=$$DPROC^RAUTL15(RADFN,RADTI,RACNI,RAOIFN)

 ... S:RAPRC]"" ^TMP($J,"RA DIFF PRC",RAPRC)=""

 ... Q

 .. Q

 . Q

 K:RAFLG>1 RA("ST") ; >1 reg. xam for this order, RA("ST") not valid

 Q

RAORD2    ;HISC/CAH,FPT,GJC,DAD AISC/RMO-Detailed Request Display ;9/3/99  13:48

 +1       ;;5.0;Radiology/Nuclear Medicine;**5,10,51,45,75**;Mar 16, 1998;Build 4

 +2        KILL XQADATA

 +3        DO HOME^%ZIS

           KILL DIC

           SET DIC="^DPT("

           SET DIC(0)="AEMQ"

 +4        WRITE !

           DO ^DIC

           IF Y<0

               GOTO Q

 +5        SET RADFN=+Y

           SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")

 +6        SET RAOFNS="Display"

           SET RAOVSTS="1;2;3;5;6;8"

           DO LOCATN

           IF $GET(RAQUIT)

               DO Q

               QUIT 

 +7        IF RAONE]""

               SET ^TMP($JOB,"RA L-TYPE",$PIECE(RAONE,"^"),$PIECE(RAONE,"^",2))=""

 +8        SET ^TMP($JOB,"RA L-TYPE","Unknown")=""

 +9        IF '$DATA(^TMP($JOB,"RA L-TYPE"))

               DO ERROR^RAUTL7A

               DO Q

               QUIT 

 +10       SET X=0

           WRITE !!,"Imaging Location(s) included:"

 +11       FOR 

               SET X=$ORDER(^TMP($JOB,"RA L-TYPE",X))

               IF X']""

                   QUIT 

               Begin DoDot:1

 +12               IF ($X+$LENGTH(X)+2)'<IOM

                       WRITE !?$LENGTH("Imaging Location(s) included:")

                   WRITE ?($X+3),X

 +13               QUIT 

               End DoDot:1

 +14       WRITE !

           KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)!($DATA(DTOUT))

               DO Q

               QUIT 

 +15       DO ^RAORDS

           IF '$DATA(RAORDS)

               GOTO Q

OERR      ; Entry Point for OE/RR Cancel/Hold Alert

 +1        IF $DATA(XQADATA)

               Begin DoDot:1

 +2                SET RAORDS(1)=+XQADATA

 +3                IF $PIECE(XQADATA,",",2)'=""

                       SET RADFN=$PIECE(XQADATA,",",2)

               End DoDot:1

 +4        SET RAPKG=""

           SET RAOSTSYM="dc^c^h^^p^^^s"

           SET $PIECE(RALNE,"-",79)=""

           SET RAX=""

 +5        FOR RAOLP=1:1

               SET RAOIFN=$SELECT($DATA(RAORDS(RAOLP)):RAORDS(RAOLP),1:0)

               IF 'RAOIFN!(RAX=U)

                   QUIT 

               DO DISORD

 +6       ;

 +7        IF RAX="^"

               KILL XQAID,XQAKILL

           IF $DATA(XQAID)

               SET DFN=$PIECE(XQAID,",",2)

               DO DELETE^XQALERT

Q          KILL %,DIC,I,OREND,RA,RACI,RACNI,RADFN,RADIV,RADIVPAR,RADPT0,RADTI,RALNE

 +1        KILL RANME,RAOFNS,RAOIFN,RAOLP,RAORD0,RAORDS,RAOSTS,RAOSTSYM,RAOVSTS,RAPKG

 +2        KILL RAONE,RAQUIT,RASSN,X,XQAID,XQALERT,Y,RAX,VA200,VAERR,VAIP

 +3        KILL RAPARENT,RACMFLG

 +4        KILL DFN,DIPGM,DISYS,DIW,DIWI,DIWT,DIWTC,DIWX,DN,RA6,RA7,POP,^TMP($JOB,"PRO-ORD")

 +5        KILL ^TMP($JOB,"RA L-TYPE"),^TMP($JOB,"RAORDS"),^TMP($JOB,"RA DIFF PRC")

           QUIT 

 +6       ;

 +7       ;

DISORD     IF '$DATA(^DPT(RADFN,0))

               QUIT 

           SET RADPT0=^(0)

           SET RA("NME")=$PIECE(RADPT0,"^")

           SET RA("DOB")=$PIECE(RADPT0,"^",3)

           SET RASSN=$$SSN^RAUTL

           IF '$DATA(^RAO(75.1,RAOIFN,0))

               QUIT 

           SET RAORD0=^(0)

 +1       ;determine if ordered procedure has CM assoc.; return null if none

 +2        SET RAZPRC0=$GET(^RAMIS(71,+$PIECE(RAORD0,U,2),0))

 +3        SET RACMFLG("O")=$$CMEDIA^RAO7UTL(+$PIECE(RAORD0,U,2),$PIECE(RAZPRC0,U,6))

 +4        KILL RAZPRC0

 +5        IF $DATA(^RADPT("AO",RAOIFN,RADFN))

               DO DPRC(RAOIFN,RADFN)

 +6        SET RA("PROC. NODE")=$GET(^RAMIS(71,+$PIECE(RAORD0,U,2),0))

 +7        SET RA("PRC")=$EXTRACT($PIECE(RA("PROC. NODE"),U),1,36)

 +8        SET RA("PRCTY")=$PIECE(RA("PROC. NODE"),U,6)

 +9        SET RA("PRCTY")=$$XTERNAL^RAUTL5(RA("PRCTY"),$PIECE($GET(^DD(71,6,0)),U,2))

 +10       SET RA("PRCTY")=$EXTRACT(RA("PRCTY"))_$$LOW^XLFSTR($EXTRACT(RA("PRCTY"),2,99))

 +11       SET RA("CPT")=+$PIECE(RA("PROC. NODE"),U,9)

 +12      ; don't find CPT code if procedure has type = Parent

 +13       SET RA("CPT")=$SELECT($EXTRACT(RA("PRCTY"))="P":"",1:$PIECE($$NAMCODE^RACPTMSC(RA("CPT"),DT),U))

 +14       SET RA("PRCIT")=+$PIECE(RA("PROC. NODE"),U,12)

 +15       SET RA("PRCIT")=$PIECE($GET(^RA(79.2,RA("PRCIT"),0)),U,3)

 +16       SET RA("PROC INFO")=""

           SET $EXTRACT(RA("PROC INFO"),1,36)=RA("PRC")

 +17       SET RA("CNCAT")="("_RA("PRCIT")_" "_RA("PRCTY")_" "_RA("CPT")_")"

 +18       SET $EXTRACT(RA("PROC INFO"),38,60)=RA("CNCAT")

           KILL RA("CNCAT"),RA("PRCIT")

 +19       KILL RA("PRCTY"),RA("CPT")

 +20      ;P75

           SET RA("STY_REA")=$PIECE($GET(^RAO(75.1,RAOIFN,.1)),U)

 +21       KILL RA("MOD")

           FOR I=0:0

               SET I=$ORDER(^RAO(75.1,RAOIFN,"M","B",I))

               IF 'I

                   QUIT 

               IF $DATA(^RAMIS(71.2,+I,0))

                   SET RA("MOD")=$SELECT('$DATA(RA("MOD")):$PIECE(^(0),"^"),1:RA("MOD")_", "_$PIECE(^(0),"^"))

 +22       SET RA("OST")=$PIECE($PIECE(^DD(75.1,5,0),$PIECE(RAORD0,"^",5)_":",2),";")_$SELECT($PIECE(RAOSTSYM,"^",$PIECE(RAORD0,"^",5))="":"",1:" ("_$PIECE(RAOSTSYM,"^",$PIECE(RAORD0,"^",5))_")")

 +23       SET RA("PHY")=$SELECT($DATA(^VA(200,+$PIECE(RAORD0,"^",14),0)):$PIECE(^(0),"^"),1:"")

 +24      ; Requesting Physician phone/pager info

 +25       DO PHONE^RAORD5("R",+$PIECE(RAORD0,"^",14))

 +26       SET RA("HLC")=$SELECT($DATA(^SC(+$PIECE(RAORD0,"^",22),0)):$PIECE(^(0),"^"),1:"")

 +27       SET DFN=RADFN

           SET VA200=1

           DO IN5^VADPT

           IF VAIP(1)

               SET RA("ROOM-BED")=$SELECT(+VAIP(6):$PIECE(VAIP(6),"^",2),1:"")

 +28       KILL RA("ODT")

           SET X=$PIECE(RAORD0,"^",16)

           IF X

               IF $PIECE(X,".",2)

                   SET X=$PIECE(X,".")_"."_$$NOSECNDS^RAORD3($PIECE(X,".",2))

               SET RA("ODT")=$$FMTE^XLFDT(X,"1P")

 +29       SET RA("USR")=$SELECT($DATA(^VA(200,+$PIECE(RAORD0,"^",15),0)):$PIECE(^(0),"^"),1:"")

 +30      ; display a header

           DO HDR

 +31       WRITE !,"Requested :",?12,RA("PROC INFO")

 +32       IF $DATA(^TMP($JOB,"RA DIFF PRC"))

               Begin DoDot:1

 +33               NEW CRTN,I

                   SET CRTN=0

                   SET I=""

                   WRITE !,"Registered:"

 +34               FOR 

                       SET I=$ORDER(^TMP($JOB,"RA DIFF PRC",I))

                       IF I']""

                           QUIT 

                       Begin DoDot:2

 +35                       IF CRTN

                               WRITE !

                           WRITE ?12,I

                           SET CRTN=1

                       End DoDot:2

 +36               QUIT 

               End DoDot:1

 +37       IF $GET(RACMFLG("O"))'=""

               IF $X

                   WRITE !

               WRITE ?12,"** The requested procedure has contrast media assigned **"

 +38       IF $GET(RACMFLG("R"))'=""

               IF $X

                   WRITE !

               WRITE ?12,"** A registered procedure uses contrast media **"

 +39       IF $DATA(RA("MOD"))

               WRITE !,"Procedure Modifiers:",?22,RA("MOD")

 +40       WRITE !!,"Current Status:",?22,$EXTRACT(RA("OST"),1,24)

 +41       WRITE !,"Requester:",?22,$EXTRACT(RA("PHY"),1,24)

 +42       WRITE !?1,"Tel/Page/Dig Page: ",RA("RPHOINFO")

 +43       WRITE !,"Patient Location:",?22,$EXTRACT(RA("HLC"),1,20)

 +44       IF $DATA(RA("ROOM-BED"))

               WRITE !,"Room-Bed:",?22,$EXTRACT(RA("ROOM-BED"),1,20)

 +45       WRITE !,"Entered:",?22,$SELECT($DATA(RA("ODT")):RA("ODT"),1:""),"  by ",$EXTRACT(RA("USR"),1,20)

 +46      ;

ENDIS     ;OE/RR Entry Point for the PRINT ACTION Option

 +1        IF '$DATA(RAPKG)

               IF '$DATA(ORPK)

                   QUIT 

               SET RAOIFN=+ORPK

               IF '$DATA(^RAO(75.1,RAOIFN,0))

                   QUIT 

               SET RAORD0=^(0)

               SET RADFN=+$PIECE(RAORD0,"^")

 +2        SET RA("TRAN")=$SELECT($PIECE(RAORD0,"^",19)']"":"",1:$PIECE($PIECE(^DD(75.1,19,0),$PIECE(RAORD0,"^",19)_":",2),";"))

 +3        KILL RA("ST")

           IF $DATA(^RADPT("AO",RAOIFN,RADFN))

               SET RADTI=+$ORDER(^(RADFN,0))

               SET RACNI=+$ORDER(^(RADTI,0))

               IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))

                   SET RA(0)=^(0)

                   IF $DATA(^RA(72,+$PIECE(RA(0),"^",3),0))

                       SET RA("ST")=$PIECE(^(0),"^")

 +4        IF '$DATA(RAPKG)

               DO DPRC(RAOIFN,RADFN)

               KILL ^TMP($JOB,"RA DIFF PRC")

 +5        SET RADIV(0)=$GET(^SC(+$PIECE(RAORD0,"^",22),0))

 +6        SET RADIV=+$$SITE^VASITE(DT,+$PIECE(RADIV(0),"^",15))

           IF RADIV<0

               SET RADIV=0

 +7        SET RADIV=$SELECT($DATA(^RA(79,RADIV,0)):RADIV,1:$ORDER(^RA(79,0)))

 +8        SET RADIVPAR=$SELECT($DATA(^RA(79,+RADIV,.1)):^(.1),1:"")

 +9        KILL RA("RDT")

           SET Y=$PIECE(RAORD0,"^",21)

           IF Y

               IF $PIECE(Y,".",2)

                   SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))

               SET RA("RDT")=$$FMTE^XLFDT(Y,"1P")

 +10       KILL RA("PDT")

           SET Y=$PIECE(RAORD0,"^",12)

           IF Y

               IF $PIECE(Y,".",2)

                   SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))

               SET RA("PDT")=$$FMTE^XLFDT(Y,"1P")

 +11       KILL RA("VDT")

           SET Y=$PIECE(RAORD0,"^",17)

           IF Y

               IF $PIECE(Y,".",2)

                   SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))

               SET RA("VDT")=$$FMTE^XLFDT(Y,"1P")

 +12       KILL RA("SDT")

           SET Y=$PIECE(RAORD0,"^",23)

           IF Y

               IF $PIECE(Y,".",2)

                   SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))

               SET RA("SDT")=$$FMTE^XLFDT(Y,"1P")

 +13       SET RA("ILC")=$SELECT('$PIECE(RAORD0,"^",20):"UNKNOWN",'$DATA(^RA(79.1,+$PIECE(RAORD0,"^",20),0)):"UNKNOWN",$DATA(^SC(+^(0),0)):$PIECE(^(0),"^"),1:"UNKNOWN")

 +14       IF $SELECT('$DATA(XQORNOD(0)):0,$PIECE(XQORNOD(0),"^",3)'="Results Display":0,1:1)

               IF $DATA(RA(0))

                   DO ^RAORR3

                   QUIT 

 +15       DO ^RAORD3

           KILL RA,RACI,RACNI,RADIV,RADIVPAR,RADPT0,RADTI,RAORD0,RAOSTS,X,Y

           IF '$DATA(RAPKG)

               KILL RADFN,RAOIFN

 +16       QUIT 

LOCATN    ; Select or default to a Rad/Nuc Med location.

 +1        SET RAONE=$$LOC1()

           IF RAONE]""

               QUIT 

 +2        SET RADIC="^RA(79.1,"

           SET RADIC(0)="QEAMZ"

 +3        SET RADIC("A")="Select Rad/Nuc Med Location: "

 +4        SET RADIC("B")="All"

           SET RAUTIL="RA L-TYPE"

 +5        WRITE !!

           DO EN1^RASELCT(.RADIC,RAUTIL)

           KILL DIC,RADIC,RAUTIL,X,Y

 +6        QUIT 

LOC1()    ; Checking for only one Imaging Location

 +1       ; Pass back null if more that one entry exists in 79.1 

 +2       ; If one entry, pass back: external Hosp. Loc. file_"^"_IEN of file 79.1

 +3        NEW X,Y

           SET X=""

 +4        IF $PIECE($GET(^RA(79.1,0)),"^",4)=1

               Begin DoDot:1

 +5                SET Y=+$ORDER(^RA(79.1,0))

                   IF 'Y

                       QUIT 

 +6                SET Y(0)=$GET(^RA(79.1,Y,0))

                   SET Y(1)=+$PIECE(Y(0),"^")

 +7                SET Y(44)=$PIECE($GET(^SC(Y(1),0)),"^")

                   SET X=Y(44)_"^"_Y

 +8                QUIT 

               End DoDot:1

 +9        QUIT X

HDR       ; Header for the 'Detailed Request Display' option.  Called from above

 +1       ; (D HDR) and from RAORD3

 +2        WRITE @IOF,?22,"**** Detailed Display ****",!!,"Name: ",RA("NME"),"    (",RASSN,")"

           SET Y=RA("DOB")

           DO D^RAUTL

           WRITE ?45,"Date of Birth: ",Y,!,RALNE

 +3        QUIT 

 +4       ;

DPRC(RAOIFN,RADFN) ; If the ordered procedure has been registered check

 +1       ;if this is an examset. If not an examset, find the status of the exam

 +2       ;RA("ST"). Also, check if the ordered procedure has been changed at

 +3       ;time of registration (DPROC^RAUTL15). If it has, store the data off

 +4       ;in ^TMP($J,"RA DIFF PRC").

 +5       ;

 +6       ; NOTE: The only time we don't set ^TMP($J,"RA DIFF PRC") is when

 +7       ; we are using the 'Detailed Request Display' option and the ordered

 +8       ; procedure is the same as the registered procedure.  All other

 +9       ; Request display options output the ordered procedure, the

 +10      ; registered procedure and exam case number if the order

 +11      ; is active.

 +12      ;

 +13      ;Set the variable RACMFLG("R") to "Y" if an exam, either a single or

 +14      ;descendant, has used contrast media during the examination.

 +15      ;

 +16       NEW RA7003,RACNI,RADTI,RAFLG

           KILL RA("ST"),^TMP($JOB,"RA DIFF PRC")

 +17       SET (RADTI,RAFLG)=0

 +18       FOR 

               SET RADTI=+$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI))

               IF RADTI'>0

                   QUIT 

               Begin DoDot:1

 +19               SET RACNI=0

 +20               FOR 

                       SET RACNI=$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI))

                       IF RACNI'>0

                           QUIT 

                       Begin DoDot:2

 +21                       IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))

                               Begin DoDot:3

 +22                               SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))

                                   SET RAFLG=RAFLG+1

 +23                               IF $GET(RACMFLG("R"))=""

                                       SET RACMFLG("R")=$SELECT($PIECE(RA7003,U,10)="Y":"Y",1:"")

 +24                               SET RA("ST")=$$GET1^DIQ(72,+$PIECE(RA7003,"^",3)_",",.01)

 +25                               NEW RAPRC

                                   SET RAPRC=$$DPROC^RAUTL15(RADFN,RADTI,RACNI,RAOIFN)

 +26                               IF RAPRC]""

                                       SET ^TMP($JOB,"RA DIFF PRC",RAPRC)=""

 +27                               QUIT 

                               End DoDot:3

 +28                       QUIT 

                       End DoDot:2

 +29               QUIT 

               End DoDot:1

 +30      ; >1 reg. xam for this order, RA("ST") not valid

           IF RAFLG>1

               KILL RA("ST")

 +31       QUIT