RADEM1 ;HISC/GJC-Display Patient Demographics ;4/19/96 08:17 [ 12/05/2011 10:38 AM ]
;;5.0;Radiology/Nuclear Medicine;**45,47*1004**;Mar 16, 1998;Build 21
EXAM D HDR S RAXIT=0
S X1=DT,X2=-7 D C^%DTC S RACHKDT=X,X1=DT,X2=-3 D C^%DTC S RACHKDT1=X
S (RADTE,RASEQ)=0 F RADTI=0:0 Q:(RASEQ>4)&(RADTE<RACHKDT)!RAXIT S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0!RAXIT I $D(^(RADTI,0)) S Y=^(0),RALOC=+$P(Y,"^",4),(RADTE,Y)=+Y Q:(RASEQ>4)&(RADTE<RACHKDT) D D^RAUTL S RADATE=Y D RACN
I $G(RAXIT) G Q
D ORDER ;Check for outstanding orders
W:'RASEQ !!?5,"No registered exams filed for this patient.",!
W:$D(RABARFL) !?2," *Exam with Barium performed in last 7 days."
W:$D(RAORFL) !?2," **Oral Cholecystographic medium used in last 7 days."
I $D(RACNFL) D
.N DIWF,DIWL,DIWR,DIWT,X K ^UTILITY($J,"W")
.S:'$D(RAZDFN)#2 X="***Exam with contrast media performed in last 3 days."
.S:$D(RAZDFN)#2 X="***Exam with "_$$CM(RAZDFN,RAZDTI,RAZCNI)_" performed in last 3 days."
.S DIWL=3,DIWF="C60" D ^DIWP,^DIWW ;UTILITY($J,"W") killed in DIWW
.Q
I '$D(RACONT),('+$G(RAXIT)) R !!,"Press <RETURN> key to continue.",X:DTIME
Q K %,%H,DIC,POP,RACNFL,RAORFL,RACODE,RACONT,RABAR,RABARFL,RACHKDT,RACHKDT1,RACN,RACNI,RADATE,RADTE,RADTI,RAPR1,RAPRI,RASEQ,RAST,RASTI,RAXIT,RAZDFN,RAZDTI,RAZCNI Q
;
RACN S RALOC=$S($D(^RA(79.1,RALOC,0)):$P(^(0),"^"),1:"") S RALOC=$S($D(^SC(+RALOC,0)):$P(^(0),"^"),1:"Unknown")
F RACNI=0:0 Q:(RASEQ>4)&(RADTE<RACHKDT)!RAXIT S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!RAXIT I $D(^(RACNI,0)) S Y=^(0) D PRT
Q
;
PRT N RAESITY,RAITYPE
S RAPRI=+$P(Y,"^",2),RAPR1=99 S:$D(^RAMIS(71,RAPRI,0)) RAPR1=$P(^(0),"^") S RABAR=0
I $P(Y,U,10)="Y" D
.I RADTE'<RACHKDT,($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM","B",""))="B") S (RABAR,RABARFL)=1,RACODE=" *"
.I RADTE'<RACHKDT,(+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM","B","C",0))>0) S (RABAR,RAORFL)=1,RACODE=" **"
.I RADTE'<RACHKDT1 D
..S (RABAR,RACNFL)=1,RACODE="***"
..I +$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) S RAZDFN=RADFN,RAZDTI=RADTI,RAZCNI=RACNI
..Q
.Q
S RASTI=+$P(Y,"^",3)
S RAST=$S($D(^RA(72,RASTI,0)):$P(^(0),"^"),1:"Unknown")
S RAESITY=+$P($G(^RA(72,RASTI,0)),U,7)
S RAITYPE=$P($G(^RA(79.2,RAESITY,0)),U)
S RAITYPE=$S(RAITYPE]"":RAITYPE,1:"Unknown")
S RACN=$S($D(^RA(72,"AA",RAITYPE,9,RASTI)):"",1:+Y)
; flag if print set and if lowest case of set
N RAPRTSET,RAMEMLOW,RADISP D EN1^RAUTL20
S RADISP=$S(RAMEMLOW&(RAPRTSET):"+",RAPRTSET:".",1:" ")
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
I $$USESSAN^RAHLRU1() S RASEQ=RASEQ+1 W:RASEQ<6!(RABAR) !,RACNDSP," ",RADISP,$S(RABAR:RACODE,1:""),?18,$E(RAPR1,1,28),?47,$$DATEPRT^RAHLRU1(RADTE),?56,$E(RAST,1,12),?68,$E(RALOC,1,12)
I '$$USESSAN^RAHLRU1() S RASEQ=RASEQ+1 W:RASEQ<6!(RABAR) !,RACN,?6,RADISP,?7,$S(RABAR:RACODE,1:""),?10,$E(RAPR1,1,28),?39,$E(RADATE,1,11),?51,$E(RAST,1,12),?67,$E(RALOC,1,12)
I $E(IOST,1,2)="C-",($Y>(IOSL-4)) D
. N DIR S DIR(0)="E" D ^DIR S RAXIT=$S(Y'>0:1,1:0)
. I 'RAXIT W @IOF D HDR
. Q
Q
ORDER ; Check for pat rad orders before registering a patient in rad
; Created by GJC@1/3/94
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
. Q:$D(^RADPT("AO",RALP,RADFN))\10 ;Check for entry in file 70.
. Q:+$P($G(^RAO(75.1,RALP,0)),U,5)<3
. S RA751(0)=$G(^RAO(75.1,RALP,0)),RA751(2)=$P(RA751(0),U,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 ;GJC@4/4/94 Cancelled xam
. S Y=RA751(2),C=$P($G(^DD(75.1,2,0)),U,2) D:Y]"" Y^DIQ S RA751(2)=Y
. S Y=RA751(20),C=$P($G(^DD(75.1,20,0)),U,2) D:Y]"" Y^DIQ S RA751(20)=Y
. I $$USESSAN^RAHLRU1() W !?18,$E(RA751(2),1,28),?56,"Ord "
. I '$$USESSAN^RAHLRU1() W !?10,$E(RA751(2),1,28),?51,"Ord "
. W $S(RA751(16)]"":$$FMTE^XLFDT(RA751(16),"2D"),1:"")
. ; prints 'SUBMIT REQUEST TO' data
. I $$USESSAN^RAHLRU1() W ?68,$E(RA751(20),1,12)
. I '$$USESSAN^RAHLRU1() W ?67,$E(RA751(20),1,12)
. 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
. Q
Q
HDR ; Header
; Created by GJC@1/3/94 ; modified for SSAN by RTK 3/19/09
; The variable: RAOPT("ORDEREXAM") is defined in the entry action of
; the option RA ORDEREXAM. It is subsequently kill in the exit action
; of the option.
;
;IHS/CMI/DAY - Patch 1004 - Don't re-set HOME device
;Patch 1004 - Continue Chris Saddler Patch from 2004
;D HOME^%ZIS W:$D(RAOPT("ORDEREXAM"))#2 @IOF
W:$D(RAOPT("ORDEREXAM"))#2 @IOF
;End Patch
;
I $$USESSAN^RAHLRU1() W !!,"Case #",?18,"Last 5 Procedures/New Orders",?47,"Exam Dt",?56,"Exam Status",?68,"Imaging Loc."
I $$USESSAN^RAHLRU1() W !,"----------------",?18,"----------------------------",?47,"--------",?56,"-----------",?68,"------------"
I '$$USESSAN^RAHLRU1() W !!,"Case #",?10,"Last 5 Procedures/New Orders",?39,"Exam Date",?51,"Status of Exam",?67,"Imaging Loc."
I '$$USESSAN^RAHLRU1() W !,"------",?10,"----------------------------",?39,"---------",?51,"--------------",?67,"------------"
;
;IHS/CMI/DAY - Patch 1004 - Kill variable so requests print on 1 page
;Patch 1004 - Continue Chris Saddler Patch from 2004
K RAOPT("ORDEREXAM")
;End Patch
;
Q
;
CM(RADFN,RADTI,RACNI) ;Return the contrast media used while performing an
;exam.
;Input: RADFN=patient DFN
; RADTI=inverse date/time of exam
; RACNI=IEN of an individual case
;Return: contrast media used with exam delimited by ', '.
N I,X S X="",I=0
F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I)) Q:'I D
.S I(0)=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I,0),U)
.S X=X_$$EXTERNAL^DILFD(70.3225,.01,"",I(0))_", "
.Q
I $L(X,", ")'>2 S X=$P(X,", ")
E S X=$P(X,", ",1,($L(X,", ")-1))
Q X
;
RADEM1 ;HISC/GJC-Display Patient Demographics ;4/19/96 08:17 [ 12/05/2011 10:38 AM ]
+1 ;;5.0;Radiology/Nuclear Medicine;**45,47*1004**;Mar 16, 1998;Build 21
EXAM DO HDR
SET RAXIT=0
+1 SET X1=DT
SET X2=-7
DO C^%DTC
SET RACHKDT=X
SET X1=DT
SET X2=-3
DO C^%DTC
SET RACHKDT1=X
+2 SET (RADTE,RASEQ)=0
FOR RADTI=0:0
IF (RASEQ>4)&(RADTE<RACHKDT)!RAXIT
QUIT
SET RADTI=$ORDER(^RADPT(RADFN,"DT",RADTI))
IF RADTI'>0!RAXIT
QUIT
IF $DATA(^(RADTI,0))
SET Y=^(0)
SET RALOC=+$PIECE(Y,"^",4)
SET (RADTE,Y)=+Y
IF (RASEQ>4)&(RADTE<RACHKDT)
QUIT
DO D^RAUTL
SET RADATE=Y
DO RACN
+3 IF $GET(RAXIT)
GOTO Q
+4 ;Check for outstanding orders
DO ORDER
+5 IF 'RASEQ
WRITE !!?5,"No registered exams filed for this patient.",!
+6 IF $DATA(RABARFL)
WRITE !?2," *Exam with Barium performed in last 7 days."
+7 IF $DATA(RAORFL)
WRITE !?2," **Oral Cholecystographic medium used in last 7 days."
+8 IF $DATA(RACNFL)
Begin DoDot:1
+9 NEW DIWF,DIWL,DIWR,DIWT,X
KILL ^UTILITY($JOB,"W")
+10 IF '$DATA(RAZDFN)#2
SET X="***Exam with contrast media performed in last 3 days."
+11 IF $DATA(RAZDFN)#2
SET X="***Exam with "_$$CM(RAZDFN,RAZDTI,RAZCNI)_" performed in last 3 days."
+12 ;UTILITY($J,"W") killed in DIWW
SET DIWL=3
SET DIWF="C60"
DO ^DIWP
DO ^DIWW
+13 QUIT
End DoDot:1
+14 IF '$DATA(RACONT)
IF ('+$GET(RAXIT))
READ !!,"Press <RETURN> key to continue.",X:DTIME
Q KILL %,%H,DIC,POP,RACNFL,RAORFL,RACODE,RACONT,RABAR,RABARFL,RACHKDT,RACHKDT1,RACN,RACNI,RADATE,RADTE,RADTI,RAPR1,RAPRI,RASEQ,RAST,RASTI,RAXIT,RAZDFN,RAZDTI,RAZCNI
QUIT
+1 ;
RACN SET RALOC=$SELECT($DATA(^RA(79.1,RALOC,0)):$PIECE(^(0),"^"),1:"")
SET RALOC=$SELECT($DATA(^SC(+RALOC,0)):$PIECE(^(0),"^"),1:"Unknown")
+1 FOR RACNI=0:0
IF (RASEQ>4)&(RADTE<RACHKDT)!RAXIT
QUIT
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF RACNI'>0!RAXIT
QUIT
IF $DATA(^(RACNI,0))
SET Y=^(0)
DO PRT
+2 QUIT
+3 ;
PRT NEW RAESITY,RAITYPE
+1 SET RAPRI=+$PIECE(Y,"^",2)
SET RAPR1=99
IF $DATA(^RAMIS(71,RAPRI,0))
SET RAPR1=$PIECE(^(0),"^")
SET RABAR=0
+2 IF $PIECE(Y,U,10)="Y"
Begin DoDot:1
+3 IF RADTE'<RACHKDT
IF ($ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM","B",""))="B")
SET (RABAR,RABARFL)=1
SET RACODE=" *"
+4 IF RADTE'<RACHKDT
IF (+$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM","B","C",0))>0)
SET (RABAR,RAORFL)=1
SET RACODE=" **"
+5 IF RADTE'<RACHKDT1
Begin DoDot:2
+6 SET (RABAR,RACNFL)=1
SET RACODE="***"
+7 IF +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0))
SET RAZDFN=RADFN
SET RAZDTI=RADTI
SET RAZCNI=RACNI
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 SET RASTI=+$PIECE(Y,"^",3)
+11 SET RAST=$SELECT($DATA(^RA(72,RASTI,0)):$PIECE(^(0),"^"),1:"Unknown")
+12 SET RAESITY=+$PIECE($GET(^RA(72,RASTI,0)),U,7)
+13 SET RAITYPE=$PIECE($GET(^RA(79.2,RAESITY,0)),U)
+14 SET RAITYPE=$SELECT(RAITYPE]"":RAITYPE,1:"Unknown")
+15 SET RACN=$SELECT($DATA(^RA(72,"AA",RAITYPE,9,RASTI)):"",1:+Y)
+16 ; flag if print set and if lowest case of set
+17 NEW RAPRTSET,RAMEMLOW,RADISP
DO EN1^RAUTL20
+18 SET RADISP=$SELECT(RAMEMLOW&(RAPRTSET):"+",RAPRTSET:".",1:" ")
+19 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+20 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
+21 IF $$USESSAN^RAHLRU1()
SET RASEQ=RASEQ+1
IF RASEQ<6!(RABAR)
WRITE !,RACNDSP," ",RADISP,$SELECT(RABAR:RACODE,1:""),?18,$EXTRACT(RAPR1,1,28),?47,$$DATEPRT^RAHLRU1(RADTE),?56,$EXTRACT(RAST,1,12),?68,$EXTRACT(RALOC,1,12)
+22 IF '$$USESSAN^RAHLRU1()
SET RASEQ=RASEQ+1
IF RASEQ<6!(RABAR)
WRITE !,RACN,?6,RADISP,?7,$SELECT(RABAR:RACODE,1:""),?10,$EXTRACT(RAPR1,1,28),?39,$EXTRACT(RADATE,1,11),?51,$EXTRACT(RAST,1,12),?67,$EXTRACT(RALOC,1,12)
+23 IF $EXTRACT(IOST,1,2)="C-"
IF ($Y>(IOSL-4))
Begin DoDot:1
+24 NEW DIR
SET DIR(0)="E"
DO ^DIR
SET RAXIT=$SELECT(Y'>0:1,1:0)
+25 IF 'RAXIT
WRITE @IOF
DO HDR
+26 QUIT
End DoDot:1
+27 QUIT
ORDER ; Check for pat rad orders before registering a patient in rad
+1 ; Created by GJC@1/3/94
+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 ;Check for entry in file 70.
IF $DATA(^RADPT("AO",RALP,RADFN))\10
QUIT
+5 IF +$PIECE($GET(^RAO(75.1,RALP,0)),U,5)<3
QUIT
+6 SET RA751(0)=$GET(^RAO(75.1,RALP,0))
SET RA751(2)=$PIECE(RA751(0),U,2)
+7 SET RA751(16)=$PIECE(RA751(0),U,16)
SET RA751(20)=$PIECE(RA751(0),U,20)
+8 ;GJC@4/4/94 Cancelled xam
SET RA751(5)=+$PIECE(RA751(0),U,5)
IF RA751(5)=1
QUIT
+9 SET Y=RA751(2)
SET C=$PIECE($GET(^DD(75.1,2,0)),U,2)
IF Y]""
DO Y^DIQ
SET RA751(2)=Y
+10 SET Y=RA751(20)
SET C=$PIECE($GET(^DD(75.1,20,0)),U,2)
IF Y]""
DO Y^DIQ
SET RA751(20)=Y
+11 IF $$USESSAN^RAHLRU1()
WRITE !?18,$EXTRACT(RA751(2),1,28),?56,"Ord "
+12 IF '$$USESSAN^RAHLRU1()
WRITE !?10,$EXTRACT(RA751(2),1,28),?51,"Ord "
+13 WRITE $SELECT(RA751(16)]"":$$FMTE^XLFDT(RA751(16),"2D"),1:"")
+14 ; prints 'SUBMIT REQUEST TO' data
+15 IF $$USESSAN^RAHLRU1()
WRITE ?68,$EXTRACT(RA751(20),1,12)
+16 IF '$$USESSAN^RAHLRU1()
WRITE ?67,$EXTRACT(RA751(20),1,12)
+17 IF $EXTRACT(IOST,1,2)="C-"
IF ($Y>(IOSL-4))
Begin DoDot:2
+18 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF '+Y
SET RAXIT=1
+19 IF 'RAXIT
WRITE @IOF
DO HDR
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT
HDR ; Header
+1 ; Created by GJC@1/3/94 ; modified for SSAN by RTK 3/19/09
+2 ; The variable: RAOPT("ORDEREXAM") is defined in the entry action of
+3 ; the option RA ORDEREXAM. It is subsequently kill in the exit action
+4 ; of the option.
+5 ;
+6 ;IHS/CMI/DAY - Patch 1004 - Don't re-set HOME device
+7 ;Patch 1004 - Continue Chris Saddler Patch from 2004
+8 ;D HOME^%ZIS W:$D(RAOPT("ORDEREXAM"))#2 @IOF
+9 IF $DATA(RAOPT("ORDEREXAM"))#2
WRITE @IOF
+10 ;End Patch
+11 ;
+12 IF $$USESSAN^RAHLRU1()
WRITE !!,"Case #",?18,"Last 5 Procedures/New Orders",?47,"Exam Dt",?56,"Exam Status",?68,"Imaging Loc."
+13 IF $$USESSAN^RAHLRU1()
WRITE !,"----------------",?18,"----------------------------",?47,"--------",?56,"-----------",?68,"------------"
+14 IF '$$USESSAN^RAHLRU1()
WRITE !!,"Case #",?10,"Last 5 Procedures/New Orders",?39,"Exam Date",?51,"Status of Exam",?67,"Imaging Loc."
+15 IF '$$USESSAN^RAHLRU1()
WRITE !,"------",?10,"----------------------------",?39,"---------",?51,"--------------",?67,"------------"
+16 ;
+17 ;IHS/CMI/DAY - Patch 1004 - Kill variable so requests print on 1 page
+18 ;Patch 1004 - Continue Chris Saddler Patch from 2004
+19 KILL RAOPT("ORDEREXAM")
+20 ;End Patch
+21 ;
+22 QUIT
+23 ;
CM(RADFN,RADTI,RACNI) ;Return the contrast media used while performing an
+1 ;exam.
+2 ;Input: RADFN=patient DFN
+3 ; RADTI=inverse date/time of exam
+4 ; RACNI=IEN of an individual case
+5 ;Return: contrast media used with exam delimited by ', '.
+6 NEW I,X
SET X=""
SET I=0
+7 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I))
IF 'I
QUIT
Begin DoDot:1
+8 SET I(0)=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I,0),U)
+9 SET X=X_$$EXTERNAL^DILFD(70.3225,.01,"",I(0))_", "
+10 QUIT
End DoDot:1
+11 IF $LENGTH(X,", ")'>2
SET X=$PIECE(X,", ")
+12 IF '$TEST
SET X=$PIECE(X,", ",1,($LENGTH(X,", ")-1))
+13 QUIT X
+14 ;
