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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORD2 8439 printed Apr 09, 2024@21:42:05 Page 2
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
