RAPTLU ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Patient's Exam Lookup ;11/13/00 09:13
;;5.0;Radiology/Nuclear Medicine;**2,8,15,23,56,47**;Mar 16, 1998;Build 21
;Supported EA #10001 DT^DIO2
;Supported IA #2378 ORCHK^GMRAOR
;Supported IA #10035 ^DPT(
;Supported IA #10040 ^SC(
;Private IA #1123 RACHK^GMRARAD, RADD^GMRARAD
;***********************************************************************
; <<< NOTE >>>
; 'RANOSCRN' is set in the entry actions of various options.
; If the variable exists, the screen is ignored. Code is in line
; label PRT+0.
;***********************************************************************
CASE ;
N RAHDCNT S RAHDCNT=0 D SEL S:'RACNT X="^" G Q:X="^"!($D(RAF1)) F I=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I)=$P(Y,"^",I)
S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
Q K RTESC,RTFL,RACNT,RAERR,RASTP,RAELOC,RADTPRT,^TMP("MAG",$J,"COL"),^TMP("MAG",$J,"ROW") Q
;
SEL ;
;Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") K ^TMP($J,"RAEX") D HOME^%ZIS D HD S X="",RACNT=0
Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") K ^TMP($J,"RAEX") D HOME^%ZIS S X="",RACNT=0
;I $$IMAGE^RARIC1 D MED^MAGSET3,ERASE^MAGSET3 ;don't call MAG 111300
S X=""
F RADTI=0:0 Q:X="^"!(X>0) S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 I $D(^(RADTI,0)) S RANODE=^(0),RADTE=+^(0) D SEL2 ;swm080398
Q:X="^"!(X>0) I 'RACNT W !?3,$C(7),"No matches found!" Q
;**Next line commented out - was causing selection screen to disappear
; and automatically go on to detailed screen if there was only one
; case for the patient
D ASK^RAUTL4 S:X="" X="^"
Q
SEL2 ; per RACNLU, check loc access, need split For Loop,swm080398
S RADIV=+$P(RANODE,"^",3),RAIMAGE=+$P(RANODE,"^",2)
S RADIV=+$G(^RA(79,RADIV,0)),RADIV=$P($G(^DIC(4,RADIV,0)),"^")
S:RADIV']"" RADIV="Unknown"
S RAIMAGE=$P($G(^RA(79.2,RAIMAGE,0)),"^")
S:RAIMAGE']"" RAIMAGE="Unknown"
I '$D(ORVP),($D(RANOSCRN)),('$D(RADUPSCN)) I $D(^TMP($J,"RA D-TYPE"))!($D(^TMP($J,"RA I-TYPE"))) Q:'$D(^TMP($J,"RA D-TYPE",RADIV))!('$D(^TMP($J,"RA I-TYPE",RAIMAGE))) ;this stmt taken from RACNLU
; continue, since user has loc access
F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S RACN=^(0) D PRT Q:X="^"!(X>0)
Q
PRT ; Screen only if entered through Rad/Nuc Med
I '$D(ORVP),'$D(RANOSCRN),'$D(RAOPT("DOSAGE TICKET")),'$D(RAOPT("UNCORRECTED REPORTS")) Q:$$IMGTY^RAUTL12("e",RADFN,RADTI)'=RAIMGTY
; "Duplicate Dosage Ticket" option has its own screen
I $D(RAOPT("DOSAGE TICKET")) Q:$P($G(^RA(79.2,+$P(^RADPT(RADFN,"DT",RADTI,0),U,2),0)),U,5)'="Y"
S RARPT=+$P(RACN,"^",17)
Q:$D(RAOPT("UNCORRECTED REPORTS"))&('$O(^RARPT(RARPT,"ERR",0)))
S RAST=+$P(RACN,"^",3),RAPRC=$S($D(^RAMIS(71,+$P(RACN,"^",2),0)):$P(^(0),"^"),1:"Unknown"),RACN=+RACN S (RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y
S RAELOC=$P($G(^SC(+$P($G(^RA(79.1,+$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,4),0)),U),0)),U),RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3)
S:RAELOC="" RAELOC="* MISSING *"
S RACNT=RACNT+1,^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST
I $D(RAREPORT) D
. S RAIMGTYI=$$IMGTY^RAUTL12("e",RADFN,RADTI)
. S RASTP=$E($$GET1^DIQ(74,+RARPT,5),1,16) ;get all possible Rpt Statuss
. I RASTP="",RAIMGTYI'="" S RASTP=RASTP_$S($D(^RA(72,"AA",RAIMGTYI,0,+RAST)):" (Exam Dc'd)",1:"")
. Q
I '$D(RAREPORT) S RASTP=$S($D(^RA(72,RAST,0)):$P(^(0),"^"),1:"Unknown")
; D:$$IMAGE^RARIC1 DISPA^MAGRIC ;don't call MAG 111300
N RAPRTSET,RAMEMLOW D EN1^RAUTL20
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
;
D HD
I $$USESSAN^RAHLRU1() W !,RACNT,?3,$S(RAMEMLOW:"+",RAPRTSET:".",1:" "),?4,RACNDSP,?19,$$IMGDISP(RARPT),?21,$E(RAPRC,1,26),?49,RADTPRT,?59,$E(RASTP,1,8),?68,$E(RAELOC,1,12)
I '$$USESSAN^RAHLRU1() W !,RACNT,?5,$S(RAMEMLOW:"+",RAPRTSET:".",1:" "),?6,RACN,?11,$$IMGDISP(RARPT),?13,$E(RAPRC,1,26),?41,RADTPRT,?52,$E(RASTP,1,16),?69,$E(RAELOC,1,11)
I (($Y+6)>IOSL),($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI))!($O(^RADPT(RADFN,"DT",RADTI)))) D ASK^RAUTL4 W @IOF
Q
;
HD ;
Q:RAHDCNT>0
S RAHDCNT=1
I '$D(RTFL) W @IOF,?25,RAHEAD,!!,"Patient's Name: ",$E(RANME,1,20)," ",RASSN,?55,"Run Date: " S Y=DT D DT^DIO2
I $D(RTFL) D ESC^RTRD:($Y+6)>IOSL Q:$D(RTESC) W !!,"============================ Exam Procedure Profile =========================="
I $$USESSAN^RAHLRU1() W !!?3,"Case No.",?21,"Procedure",?49,"Exam Dt",?59 W $S($D(RAREPORT):"Rpt",1:"Exam")," St",?68,"Imaging Loc"
I $$USESSAN^RAHLRU1() W !?3,"--------",?21,"-------------",?49,"---------",?59,"--------",?68,"-----------" Q
I '$$USESSAN^RAHLRU1() W !!?3,"Case No.",?13,"Procedure",?41,"Exam Date",?52,"Status of " W $S($D(RAREPORT):"Report",1:"Exam"),?69,"Imaging Loc"
I '$$USESSAN^RAHLRU1() W !?3,"--------",?13,"-------------",?41,"---------",?52,"----------------",?69,"-----------" Q
;
PTUPD ;Update Patient Info
S DIC(0)="AEMQL" D ^RADPA K DIC,RAIC Q:Y<0 S DIE="^RADPT(",DA=+Y,DR=".04;1" D ^DIE
PTUPD0 K DIR S DIR(0)="SOMA^Y:YES;N:NO;",DIR("A")="CONTRAST MEDIUM ALLERGY: "
S ALLERGY=$$ORCHK^GMRAOR(DA,"CM")
I ALLERGY]"" S DIR("B")=$S(ALLERGY=1:"YES",1:"NO")
S DIR("?")="^D PTUPDH1^RAPTLU",DIR("??")="^D PTUPDH2^RAPTLU"
D ^DIR K DIR I $D(DIRUT) G PTUPDX
I ALLERGY'=$TR(Y,"YN","10") S X=0 D G:'X PTUPDX W " ??",$C(7) G PTUPD0
. I Y="N" S X=$$RACHK^GMRARAD(DA,Y)
. I Y="Y" S X=($$RADD^GMRARAD(DA,"p",Y)'>0)
. Q
PTUPDX K %,%Y,ALLERGY,C,D,D0,DA,DE,DQ,DIE,DIR,DR,RAPTFL,DIC,X,Y
Q
PTUPDH1 W !?5,"If this patient has had an allergic reaction to contrast medium, enter 'Y'"
W !?5,"for YES at this prompt. If not, enter 'N' for NO."
D PTUPDH3
Q
PTUPDH2 ;
W !?5,"The value in this field is used to indicate if this Radiology"
W !?5,"/Nuclear Medicine patient has had an allergic reaction to the contrast"
W !?5,"medium during a Radiology/Nuclear Medicine procedure. It may contain a"
W !?5,"'Y' for YES, or 'N' for NO. If YES, then a warning message is"
W !?5,"displayed to the receptionist whenever this patient is"
W !?5,"registered for a procedure that may involve contrast material."
D PTUPDH3
Q
PTUPDH3 W !?5,"CHOOSE FROM:"
W !?5," Y YES"
W !?5," N NO"
Q
IMGDISP(RARPT) ; Display "i" if an image is associated with the Rad/Nuc Med
; Report. Called from RAPROS - Exam Profile (Selected Sort)
; Input : RARPT - ien of the report
; Output: "i" if an image exists, else null ("")
Q $S(+$O(^RARPT(RARPT,2005,0)):"i",1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPTLU 6767 printed Oct 16, 2024@18:39:34 Page 2
RAPTLU ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Patient's Exam Lookup ;11/13/00 09:13
+1 ;;5.0;Radiology/Nuclear Medicine;**2,8,15,23,56,47**;Mar 16, 1998;Build 21
+2 ;Supported EA #10001 DT^DIO2
+3 ;Supported IA #2378 ORCHK^GMRAOR
+4 ;Supported IA #10035 ^DPT(
+5 ;Supported IA #10040 ^SC(
+6 ;Private IA #1123 RACHK^GMRARAD, RADD^GMRARAD
+7 ;***********************************************************************
+8 ; <<< NOTE >>>
+9 ; 'RANOSCRN' is set in the entry actions of various options.
+10 ; If the variable exists, the screen is ignored. Code is in line
+11 ; label PRT+0.
+12 ;***********************************************************************
CASE ;
+1 NEW RAHDCNT
SET RAHDCNT=0
DO SEL
if 'RACNT
SET X="^"
if X="^"!($DATA(RAF1))
GOTO Q
FOR I=1:1:11
SET @$PIECE("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I)=$PIECE(Y,"^",I)
+2 SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI
SET Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
Q KILL RTESC,RTFL,RACNT,RAERR,RASTP,RAELOC,RADTPRT,^TMP("MAG",$JOB,"COL"),^TMP("MAG",$JOB,"ROW")
QUIT
+1 ;
SEL ;
+1 ;Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") K ^TMP($J,"RAEX") D HOME^%ZIS D HD S X="",RACNT=0
+2 if '$DATA(^DPT(RADFN,0))
QUIT
SET RANME=^(0)
SET RASSN=$$SSN^RAUTL
SET RANME=$PIECE(RANME,"^")
KILL ^TMP($JOB,"RAEX")
DO HOME^%ZIS
SET X=""
SET RACNT=0
+3 ;I $$IMAGE^RARIC1 D MED^MAGSET3,ERASE^MAGSET3 ;don't call MAG 111300
+4 SET X=""
+5 ;swm080398
FOR RADTI=0:0
if X="^"!(X>0)
QUIT
SET RADTI=$ORDER(^RADPT(RADFN,"DT",RADTI))
if RADTI'>0
QUIT
IF $DATA(^(RADTI,0))
SET RANODE=^(0)
SET RADTE=+^(0)
DO SEL2
+6 if X="^"!(X>0)
QUIT
IF 'RACNT
WRITE !?3,$CHAR(7),"No matches found!"
QUIT
+7 ;**Next line commented out - was causing selection screen to disappear
+8 ; and automatically go on to detailed screen if there was only one
+9 ; case for the patient
+10 DO ASK^RAUTL4
if X=""
SET X="^"
+11 QUIT
SEL2 ; per RACNLU, check loc access, need split For Loop,swm080398
+1 SET RADIV=+$PIECE(RANODE,"^",3)
SET RAIMAGE=+$PIECE(RANODE,"^",2)
+2 SET RADIV=+$GET(^RA(79,RADIV,0))
SET RADIV=$PIECE($GET(^DIC(4,RADIV,0)),"^")
+3 if RADIV']""
SET RADIV="Unknown"
+4 SET RAIMAGE=$PIECE($GET(^RA(79.2,RAIMAGE,0)),"^")
+5 if RAIMAGE']""
SET RAIMAGE="Unknown"
+6 ;this stmt taken from RACNLU
IF '$DATA(ORVP)
IF ($DATA(RANOSCRN))
IF ('$DATA(RADUPSCN))
IF $DATA(^TMP($JOB,"RA D-TYPE"))!($DATA(^TMP($JOB,"RA I-TYPE")))
if '$DATA(^TMP($JOB,"RA D-TYPE",RADIV))!('$DATA(^TMP($JOB,"RA I-TYPE",RAIMAGE)))
QUIT
+7 ; continue, since user has loc access
+8 FOR RACNI=0:0
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if RACNI'>0
QUIT
IF $DATA(^(RACNI,0))
SET RACN=^(0)
DO PRT
if X="^"!(X>0)
QUIT
+9 QUIT
PRT ; Screen only if entered through Rad/Nuc Med
+1 IF '$DATA(ORVP)
IF '$DATA(RANOSCRN)
IF '$DATA(RAOPT("DOSAGE TICKET"))
IF '$DATA(RAOPT("UNCORRECTED REPORTS"))
if $$IMGTY^RAUTL12("e",RADFN,RADTI)'=RAIMGTY
QUIT
+2 ; "Duplicate Dosage Ticket" option has its own screen
+3 IF $DATA(RAOPT("DOSAGE TICKET"))
if $PIECE($GET(^RA(79.2,+$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,2),0)),U,5)'="Y"
QUIT
+4 SET RARPT=+$PIECE(RACN,"^",17)
+5 if $DATA(RAOPT("UNCORRECTED REPORTS"))&('$ORDER(^RARPT(RARPT,"ERR",0)))
QUIT
+6 SET RAST=+$PIECE(RACN,"^",3)
SET RAPRC=$SELECT($DATA(^RAMIS(71,+$PIECE(RACN,"^",2),0)):$PIECE(^(0),"^"),1:"Unknown")
SET RACN=+RACN
SET (RADTPRT,Y)=RADTE
DO D^RAUTL
SET RADATE=Y
+7 SET RAELOC=$PIECE($GET(^SC(+$PIECE($GET(^RA(79.1,+$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,4),0)),U),0)),U)
SET RADTPRT=$EXTRACT(RADTPRT,4,5)_"/"_$EXTRACT(RADTPRT,6,7)_"/"_$EXTRACT(RADTPRT,2,3)
+8 if RAELOC=""
SET RAELOC="* MISSING *"
+9 SET RACNT=RACNT+1
SET ^TMP($JOB,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST
+10 IF $DATA(RAREPORT)
Begin DoDot:1
+11 SET RAIMGTYI=$$IMGTY^RAUTL12("e",RADFN,RADTI)
+12 ;get all possible Rpt Statuss
SET RASTP=$EXTRACT($$GET1^DIQ(74,+RARPT,5),1,16)
+13 IF RASTP=""
IF RAIMGTYI'=""
SET RASTP=RASTP_$SELECT($DATA(^RA(72,"AA",RAIMGTYI,0,+RAST)):" (Exam Dc'd)",1:"")
+14 QUIT
End DoDot:1
+15 IF '$DATA(RAREPORT)
SET RASTP=$SELECT($DATA(^RA(72,RAST,0)):$PIECE(^(0),"^"),1:"Unknown")
+16 ; D:$$IMAGE^RARIC1 DISPA^MAGRIC ;don't call MAG 111300
+17 NEW RAPRTSET,RAMEMLOW
DO EN1^RAUTL20
+18 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+19 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
+20 ;
+21 DO HD
+22 IF $$USESSAN^RAHLRU1()
WRITE !,RACNT,?3,$SELECT(RAMEMLOW:"+",RAPRTSET:".",1:" "),?4,RACNDSP,?19,$$IMGDISP(RARPT),?21,$EXTRACT(RAPRC,1,26),?49,RADTPRT,?59,$EXTRACT(RASTP,1,8),?68,$EXTRACT(RAELOC,1,12)
+23 IF '$$USESSAN^RAHLRU1()
WRITE !,RACNT,?5,$SELECT(RAMEMLOW:"+",RAPRTSET:".",1:" "),?6,RACN,?11,$$IMGDISP(RARPT),?13,$EXTRACT(RAPRC,1,26),?41,RADTPRT,?52,$EXTRACT(RASTP,1,16),?69,$EXTRACT(RAELOC,1,11)
+24 IF (($Y+6)>IOSL)
IF ($ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))!($ORDER(^RADPT(RADFN,"DT",RADTI))))
DO ASK^RAUTL4
WRITE @IOF
+25 QUIT
+26 ;
HD ;
+1 if RAHDCNT>0
QUIT
+2 SET RAHDCNT=1
+3 IF '$DATA(RTFL)
WRITE @IOF,?25,RAHEAD,!!,"Patient's Name: ",$EXTRACT(RANME,1,20)," ",RASSN,?55,"Run Date: "
SET Y=DT
DO DT^DIO2
+4 IF $DATA(RTFL)
if ($Y+6)>IOSL
DO ESC^RTRD
if $DATA(RTESC)
QUIT
WRITE !!,"============================ Exam Procedure Profile =========================="
+5 IF $$USESSAN^RAHLRU1()
WRITE !!?3,"Case No.",?21,"Procedure",?49,"Exam Dt",?59
WRITE $SELECT($DATA(RAREPORT):"Rpt",1:"Exam")," St",?68,"Imaging Loc"
+6 IF $$USESSAN^RAHLRU1()
WRITE !?3,"--------",?21,"-------------",?49,"---------",?59,"--------",?68,"-----------"
QUIT
+7 IF '$$USESSAN^RAHLRU1()
WRITE !!?3,"Case No.",?13,"Procedure",?41,"Exam Date",?52,"Status of "
WRITE $SELECT($DATA(RAREPORT):"Report",1:"Exam"),?69,"Imaging Loc"
+8 IF '$$USESSAN^RAHLRU1()
WRITE !?3,"--------",?13,"-------------",?41,"---------",?52,"----------------",?69,"-----------"
QUIT
+9 ;
PTUPD ;Update Patient Info
+1 SET DIC(0)="AEMQL"
DO ^RADPA
KILL DIC,RAIC
if Y<0
QUIT
SET DIE="^RADPT("
SET DA=+Y
SET DR=".04;1"
DO ^DIE
PTUPD0 KILL DIR
SET DIR(0)="SOMA^Y:YES;N:NO;"
SET DIR("A")="CONTRAST MEDIUM ALLERGY: "
+1 SET ALLERGY=$$ORCHK^GMRAOR(DA,"CM")
+2 IF ALLERGY]""
SET DIR("B")=$SELECT(ALLERGY=1:"YES",1:"NO")
+3 SET DIR("?")="^D PTUPDH1^RAPTLU"
SET DIR("??")="^D PTUPDH2^RAPTLU"
+4 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO PTUPDX
+5 IF ALLERGY'=$TRANSLATE(Y,"YN","10")
SET X=0
Begin DoDot:1
+6 IF Y="N"
SET X=$$RACHK^GMRARAD(DA,Y)
+7 IF Y="Y"
SET X=($$RADD^GMRARAD(DA,"p",Y)'>0)
+8 QUIT
End DoDot:1
if 'X
GOTO PTUPDX
WRITE " ??",$CHAR(7)
GOTO PTUPD0
PTUPDX KILL %,%Y,ALLERGY,C,D,D0,DA,DE,DQ,DIE,DIR,DR,RAPTFL,DIC,X,Y
+1 QUIT
PTUPDH1 WRITE !?5,"If this patient has had an allergic reaction to contrast medium, enter 'Y'"
+1 WRITE !?5,"for YES at this prompt. If not, enter 'N' for NO."
+2 DO PTUPDH3
+3 QUIT
PTUPDH2 ;
+1 WRITE !?5,"The value in this field is used to indicate if this Radiology"
+2 WRITE !?5,"/Nuclear Medicine patient has had an allergic reaction to the contrast"
+3 WRITE !?5,"medium during a Radiology/Nuclear Medicine procedure. It may contain a"
+4 WRITE !?5,"'Y' for YES, or 'N' for NO. If YES, then a warning message is"
+5 WRITE !?5,"displayed to the receptionist whenever this patient is"
+6 WRITE !?5,"registered for a procedure that may involve contrast material."
+7 DO PTUPDH3
+8 QUIT
PTUPDH3 WRITE !?5,"CHOOSE FROM:"
+1 WRITE !?5," Y YES"
+2 WRITE !?5," N NO"
+3 QUIT
IMGDISP(RARPT) ; Display "i" if an image is associated with the Rad/Nuc Med
+1 ; Report. Called from RAPROS - Exam Profile (Selected Sort)
+2 ; Input : RARPT - ien of the report
+3 ; Output: "i" if an image exists, else null ("")
+4 QUIT $SELECT(+$ORDER(^RARPT(RARPT,2005,0)):"i",1:"")
