RASTEXT ;HISC/CAH,FPT,GJC AISC/TMP,TAC,RMO-Called by Status Tracking display,edit. Allow selection/edit of case if called from edit option ;18 Dec 2017 12:39 PM
;;5.0;Radiology/Nuclear Medicine;**48,47,137**;Mar 16, 1998;Build 4
S RAED=1 ;If called from beginning of routine, allow case edit
;If called at EN1, display exams by status but don't allow editing
EN1 D SET^RAPSET1 I $D(XQUIT) K RAED,XQUIT Q
D HOME^%ZIS S:'$D(RAED) RAED=0 S (RACTR,RAORD,RAXIT)=0 K RASTAT,RADTI
N RADLOCS,RAQUIT,RATEMP,RATOTAL S (RATOTAL,X)=0
F S X=$O(^RA(79.1,X)) Q:X'>0 D
. S Y=$G(^RA(79.1,X,0)),Y(6)=+$P(Y,U,6) Q:'Y(6)
. I $D(RACCESS(DUZ,"LOC",+X)),(Y(6)=+$O(^RA(79.2,"B",RAIMGTY,0))),($D(RACCESS(DUZ,"DIV",+RAMDIV,X))) D
.. S RATOTAL=RATOTAL+1,RATEMP=$P($G(^SC(+$P(Y,"^"),0)),"^")_"^"_X
.. Q
. Q
I 'RATOTAL D D Q QUIT
. W !?5,"Your access to Imaging Locations is nonexistent."
. W !?5,"Contact your ADPAC for further assistance."
. Q
W !!?5,"Current Division: ",$P(^DIC(4,+RAMDIV,0),U,1)
W !?5,"Current Imaging Type: ",RAIMGTY,!
I RATOTAL=1 D
. N DIR,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="E" D ^DIR
. S:'+Y RAXIT=1 Q:RAXIT
. S ^TMP($J,"RADLOCS",$P(RATEMP,"^"),$P(RATEMP,"^",2))=""
. S RADLOCS($P(RATEMP,"^"),$P(RATEMP,"^",2))="",RAQUIT=0
. Q
I RAXIT D Q QUIT
K X,Y I RATOTAL>1 D
. N RAARRY,RADIC,RAUTIL
. S RADIC="^RA(79.1,",(RAARRY,RAUTIL)="RADLOCS",RADIC(0)="QEAFMZ"
. S RADIC("A")="Select the Location(s) you wish to track: "
. S RADIC("B")="All"
. S RADIC("S")="I $D(RACCESS(DUZ,""DIV"",+RAMDIV,+Y)),(+$P(^(0),""^"",6)=+$O(^RA(79.2,""B"",RAIMGTY,0)))"
. D EN1^RASELCT(.RADIC,RAUTIL,RAARRY)
. Q
I +$G(RAQUIT) D Q Q
K ^TMP($J,"RADLOCS")
S RAIMGTYI=$O(^RA(79.2,"B",RAIMGTY,0)) G Q:'RAIMGTYI
; set up RASEQARR(order seq)=ien of file 72
; if order seq is null, set it to -1, -2, etc., so each img typ gets
; gets a different negative subscript to represent a null order seq
S X=0 F S X=$O(^RADPT("AS",X)) Q:X'=+X I $P($G(^RA(72,X,0)),U,7)=RAIMGTYI,$P(^(0),U,5)="Y" S RAX=$P(^(0),U,3) D:RAX="" S RASEQARR(RAX)=X
. S RAX=$O(RASEQARR(""))
. I RAX>0 S RAX=-1 Q
. S:RAX<0 RAX=RAX-1
S RAORD=""
F K ^TMP($J,"RASTEXT") S RAORD=$O(RASEQARR(RAORD)) Q:RAORD=""!(RAORD>8) S RASTAT=RASEQARR(RAORD) I $D(^RA(72,+RASTAT,0)),$P(^(0),"^",5)="Y" D START I RACTR S RACTR=0 D SCRN Q:RAQ
I 'RACTR&('$D(RADTI)) W *7,!,"No incomplete statuses on file"
G Q
START S (RACTR,RAQ)=0 F RADFN=0:0 S RADFN=$O(^RADPT("AS",RASTAT,RADFN)) Q:RADFN'>0 F RADTI=0:0 S RADTI=$O(^RADPT("AS",RASTAT,RADFN,RADTI)) Q:RADTI'>0 I $D(^RADPT(RADFN,"DT",RADTI,0)) S Y=^(0) D GETCN
Q
GETCN Q:'$D(^RA(79.1,+$P(Y,"^",4),0)) ;If imaging loc is broken pointer
Q:'$D(RADLOCS($P($G(^SC(+$P($G(^RA(79.1,+$P(Y,"^",4),0)),"^"),0)),"^")))
F RACNI=0:0 S RACNI=$O(^RADPT("AS",RASTAT,RADFN,RADTI,RACNI)) Q:RACNI'>0 I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S Y(0)=^(0) D EXT
Q
EXT ;p137/KLM - updated for printset SSAN display - use RACNI.
;Also use RADTI~RADFN combo for third subscript to allow for two studies with same d/t.
S:$D(^XUSEC("RA MGR",DUZ))!(RAMDIV=+$P(Y,"^",3)) RAY=+Y_"~"_RADFN,^TMP($J,"RASTEXT",RAY,RACNI)=RADFN_"^"_+Y(0)_"^"_$P(Y(0),"^",2)_"^"_$P(Y(0),"^",18),RACTR=1
Q
;
;p137 - Modified SCRN F-loop below to accomdate the new RADTI string format (RADTI~RADFN)
;Note that RADTI is actually the FM D/T of the study
SCRN D HD S RADTI="" Q:RAQ!(RAXIT) F S RADTI=$O(^TMP($J,"RASTEXT",RADTI)) Q:RAQ!(RADTI="") F I1=0:0 S I1=$O(^TMP($J,"RASTEXT",RADTI,I1)) Q:I1'>0!(RAXIT) D:$$LMAX HD D WRT D:$$LMAX SELECT^RASTEXT1 Q:RAQ!(RADTI'>0)!(RAXIT)
Q:RAQ!(RAXIT) D:$$LMAX HD
D SELECT^RASTEXT1 Q:RAQ!(RAXIT)
G SCRN:RADTI=0
Q
;
;p137 - Updated WRT for new RADTI format (RADTI~RADFN)
WRT I $P($P(RADTI,"~"),".")=DT S X=$P(RADTI,"~") D TIME^RAUTL1 S RATI=X
I $P($P(RADTI,"~"),".")'=DT S RATI=$E($P(RADTI,"~"),4,5)_"/"_$E($P(RADTI,"~"),6,7)_"/"_$E($P(RADTI,"~"),2,3)
S RACTR=RACTR+1
N RASSAN,RACNDSP,RADFNXX,RADTIXX,RACNIXX
S RADFNXX=+^TMP($J,"RASTEXT",RADTI,I1),RADTIXX=9999999.9999-$P(RADTI,"~")
S RACNIXX=I1,RASSAN=$$SSANVAL^RAHLRU1(RADFNXX,RADTIXX,RACNIXX)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P(^TMP($J,"RASTEXT",RADTI,I1),"^",2))
I $$USESSAN^RAHLRU1() D
.W !,?1,RACNDSP,?18,$J(RATI,8),?27,$E($S($D(^DPT(+^TMP($J,"RASTEXT",RADTI,I1),0)):$P(^(0),"^"),1:"Unknown"),1,18),?46,$S($D(^RAMIS(71,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",3),0)):$E($P(^(0),"^"),1,25),1:"Unknown")
I '$$USESSAN^RAHLRU1() D
.W !,?1,$P(^TMP($J,"RASTEXT",RADTI,I1),"^",2),?10,$J(RATI,8),?20,$E($S($D(^DPT(+^TMP($J,"RASTEXT",RADTI,I1),0)):$P(^(0),"^"),1:"Unknown"),1,20),?42,$S($D(^RAMIS(71,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",3),0)):$E($P(^(0),"^"),1,25),1:"Unknown")
W:$D(^RA(78.6,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",4),0)) ?72,$E($P(^(0),"^"),1,8)
Q
;
HD N RADIVHD,RAGENTXT
S X=$H D NOW^RAUTL1 S RATIME=X,RASTOUT=$S($D(^RA(72,RASTAT,0)):$P(^(0),"^"),1:"")
S RALOC(0)=$P(RAMLC,"^"),RALOC(1)=$P($G(^RA(79.1,RALOC(0),0)),"^")
S RALOC=$P($G(^SC(RALOC(1),0)),"^"),RADIV=$P($G(^DIC(4,+RAMDIV,0)),"^")
S RADIVHD="Division: "_RADIV
S RAGENTXT="Exam Status Tracking Module"
W @IOF,!?1,RAGENTXT,?39,RADIVHD
W !?1,"Date : ",$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3)," ",RATIME,?39,"Status : ",RASTOUT
W !?1,"Locations: " S X="" F S X=$O(RADLOCS(X)) Q:X']"" W:($X+$L(X))>IOM !?($X+5) W X W:$O(RADLOCS(X))'="" ?($X+5)
I $$USESSAN^RAHLRU1() D
.W !!?1,"Case #",?18,"Date",?27,"Patient",?46,"Procedure",?72,"Equip/Rm",!
.W ?1,"----------------",?18,"----",?27,"-------",?46,"---------",?72,"--------"
I '$$USESSAN^RAHLRU1() D
.W !!?1,"Case #",?10,"Date",?20,"Patient",?42,"Procedure",?72,"Equip/Rm",!
.W ?1,"------",?10,"----",?20,"-------",?42,"---------",?72,"--------"
Q
Q ; Kill and quit
K %,%H,%W,%Y,%Y1,A,C,DIC,I,I1,ORX,POP,RACNI,RACNT,RACONTIN,RACS,RACTR,RADA,RADATE,RADFN,RADIV,RADTI,RAED,RAJ1,RAI,RAIMAGE,RALOC,RAMIS,RANODE,RAORD,RAPRIT,RAQ,RASTAT,RASTOUT,RATI,RATICTR,RATIME,RATXTLP,RAX,RAXIT,SDCLST,X,XQUIT,Y
K RASEQARR,RAY
K ^TMP($J,"RASTEXT"),^TMP($J,"RAEX")
D KILLVAR^RAUTL2,KMV^RAUTL15
K DIOV,RAOR,X1
Q
LMAX() ;
Q:($Y+4)>IOSL 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRASTEXT 6153 printed Apr 09, 2024@21:36:58 Page 2
RASTEXT ;HISC/CAH,FPT,GJC AISC/TMP,TAC,RMO-Called by Status Tracking display,edit. Allow selection/edit of case if called from edit option ;18 Dec 2017 12:39 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**48,47,137**;Mar 16, 1998;Build 4
+2 ;If called from beginning of routine, allow case edit
SET RAED=1
+3 ;If called at EN1, display exams by status but don't allow editing
EN1 DO SET^RAPSET1
IF $DATA(XQUIT)
KILL RAED,XQUIT
QUIT
+1 DO HOME^%ZIS
if '$DATA(RAED)
SET RAED=0
SET (RACTR,RAORD,RAXIT)=0
KILL RASTAT,RADTI
+2 NEW RADLOCS,RAQUIT,RATEMP,RATOTAL
SET (RATOTAL,X)=0
+3 FOR
SET X=$ORDER(^RA(79.1,X))
if X'>0
QUIT
Begin DoDot:1
+4 SET Y=$GET(^RA(79.1,X,0))
SET Y(6)=+$PIECE(Y,U,6)
if 'Y(6)
QUIT
+5 IF $DATA(RACCESS(DUZ,"LOC",+X))
IF (Y(6)=+$ORDER(^RA(79.2,"B",RAIMGTY,0)))
IF ($DATA(RACCESS(DUZ,"DIV",+RAMDIV,X)))
Begin DoDot:2
+6 SET RATOTAL=RATOTAL+1
SET RATEMP=$PIECE($GET(^SC(+$PIECE(Y,"^"),0)),"^")_"^"_X
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 IF 'RATOTAL
Begin DoDot:1
+10 WRITE !?5,"Your access to Imaging Locations is nonexistent."
+11 WRITE !?5,"Contact your ADPAC for further assistance."
+12 QUIT
End DoDot:1
DO Q
QUIT
+13 WRITE !!?5,"Current Division: ",$PIECE(^DIC(4,+RAMDIV,0),U,1)
+14 WRITE !?5,"Current Imaging Type: ",RAIMGTY,!
+15 IF RATOTAL=1
Begin DoDot:1
+16 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
SET DIR(0)="E"
DO ^DIR
+17 if '+Y
SET RAXIT=1
if RAXIT
QUIT
+18 SET ^TMP($JOB,"RADLOCS",$PIECE(RATEMP,"^"),$PIECE(RATEMP,"^",2))=""
+19 SET RADLOCS($PIECE(RATEMP,"^"),$PIECE(RATEMP,"^",2))=""
SET RAQUIT=0
+20 QUIT
End DoDot:1
+21 IF RAXIT
DO Q
QUIT
+22 KILL X,Y
IF RATOTAL>1
Begin DoDot:1
+23 NEW RAARRY,RADIC,RAUTIL
+24 SET RADIC="^RA(79.1,"
SET (RAARRY,RAUTIL)="RADLOCS"
SET RADIC(0)="QEAFMZ"
+25 SET RADIC("A")="Select the Location(s) you wish to track: "
+26 SET RADIC("B")="All"
+27 SET RADIC("S")="I $D(RACCESS(DUZ,""DIV"",+RAMDIV,+Y)),(+$P(^(0),""^"",6)=+$O(^RA(79.2,""B"",RAIMGTY,0)))"
+28 DO EN1^RASELCT(.RADIC,RAUTIL,RAARRY)
+29 QUIT
End DoDot:1
+30 IF +$GET(RAQUIT)
DO Q
QUIT
+31 KILL ^TMP($JOB,"RADLOCS")
+32 SET RAIMGTYI=$ORDER(^RA(79.2,"B",RAIMGTY,0))
if 'RAIMGTYI
GOTO Q
+33 ; set up RASEQARR(order seq)=ien of file 72
+34 ; if order seq is null, set it to -1, -2, etc., so each img typ gets
+35 ; gets a different negative subscript to represent a null order seq
+36 SET X=0
FOR
SET X=$ORDER(^RADPT("AS",X))
if X'=+X
QUIT
IF $PIECE($GET(^RA(72,X,0)),U,7)=RAIMGTYI
IF $PIECE(^(0),U,5)="Y"
SET RAX=$PIECE(^(0),U,3)
if RAX=""
Begin DoDot:1
+37 SET RAX=$ORDER(RASEQARR(""))
+38 IF RAX>0
SET RAX=-1
QUIT
+39 if RAX<0
SET RAX=RAX-1
End DoDot:1
SET RASEQARR(RAX)=X
+40 SET RAORD=""
+41 FOR
KILL ^TMP($JOB,"RASTEXT")
SET RAORD=$ORDER(RASEQARR(RAORD))
if RAORD=""!(RAORD>8)
QUIT
SET RASTAT=RASEQARR(RAORD)
IF $DATA(^RA(72,+RASTAT,0))
IF $PIECE(^(0),"^",5)="Y"
DO START
IF RACTR
SET RACTR=0
DO SCRN
if RAQ
QUIT
+42 IF 'RACTR&('$DATA(RADTI))
WRITE *7,!,"No incomplete statuses on file"
+43 GOTO Q
START SET (RACTR,RAQ)=0
FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT("AS",RASTAT,RADFN))
if RADFN'>0
QUIT
FOR RADTI=0:0
SET RADTI=$ORDER(^RADPT("AS",RASTAT,RADFN,RADTI))
if RADTI'>0
QUIT
IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
SET Y=^(0)
DO GETCN
+1 QUIT
GETCN ;If imaging loc is broken pointer
if '$DATA(^RA(79.1,+$PIECE(Y,"^",4),0))
QUIT
+1 if '$DATA(RADLOCS($PIECE($GET(^SC(+$PIECE($GET(^RA(79.1,+$PIECE(Y,"^",4),0)),"^"),0)),"^")))
QUIT
+2 FOR RACNI=0:0
SET RACNI=$ORDER(^RADPT("AS",RASTAT,RADFN,RADTI,RACNI))
if RACNI'>0
QUIT
IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
SET Y(0)=^(0)
DO EXT
+3 QUIT
EXT ;p137/KLM - updated for printset SSAN display - use RACNI.
+1 ;Also use RADTI~RADFN combo for third subscript to allow for two studies with same d/t.
+2 if $DATA(^XUSEC("RA MGR",DUZ))!(RAMDIV=+$PIECE(Y,"^",3))
SET RAY=+Y_"~"_RADFN
SET ^TMP($JOB,"RASTEXT",RAY,RACNI)=RADFN_"^"_+Y(0)_"^"_$PIECE(Y(0),"^",2)_"^"_$PIECE(Y(0),"^",18)
SET RACTR=1
+3 QUIT
+4 ;
+5 ;p137 - Modified SCRN F-loop below to accomdate the new RADTI string format (RADTI~RADFN)
+6 ;Note that RADTI is actually the FM D/T of the study
SCRN DO HD
SET RADTI=""
if RAQ!(RAXIT)
QUIT
FOR
SET RADTI=$ORDER(^TMP($JOB,"RASTEXT",RADTI))
if RAQ!(RADTI="")
QUIT
FOR I1=0:0
SET I1=$ORDER(^TMP($JOB,"RASTEXT",RADTI,I1))
if I1'>0!(RAXIT)
QUIT
if $$LMAX
DO HD
DO WRT
if $$LMAX
DO SELECT^RASTEXT1
if RAQ!(RADTI'>0)!(RAXIT)
QUIT
+1 if RAQ!(RAXIT)
QUIT
if $$LMAX
DO HD
+2 DO SELECT^RASTEXT1
if RAQ!(RAXIT)
QUIT
+3 if RADTI=0
GOTO SCRN
+4 QUIT
+5 ;
+6 ;p137 - Updated WRT for new RADTI format (RADTI~RADFN)
WRT IF $PIECE($PIECE(RADTI,"~"),".")=DT
SET X=$PIECE(RADTI,"~")
DO TIME^RAUTL1
SET RATI=X
+1 IF $PIECE($PIECE(RADTI,"~"),".")'=DT
SET RATI=$EXTRACT($PIECE(RADTI,"~"),4,5)_"/"_$EXTRACT($PIECE(RADTI,"~"),6,7)_"/"_$EXTRACT($PIECE(RADTI,"~"),2,3)
+2 SET RACTR=RACTR+1
+3 NEW RASSAN,RACNDSP,RADFNXX,RADTIXX,RACNIXX
+4 SET RADFNXX=+^TMP($JOB,"RASTEXT",RADTI,I1)
SET RADTIXX=9999999.9999-$PIECE(RADTI,"~")
+5 SET RACNIXX=I1
SET RASSAN=$$SSANVAL^RAHLRU1(RADFNXX,RADTIXX,RACNIXX)
+6 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:$PIECE(^TMP($JOB,"RASTEXT",RADTI,I1),"^",2))
+7 IF $$USESSAN^RAHLRU1()
Begin DoDot:1
+8 WRITE !,?1,RACNDSP,?18,$JUSTIFY(RATI,8),?27,$EXTRACT($SELECT($DATA(^DPT(+^TMP($JOB,"RASTEXT",RADTI,I1),0)):$PIECE(^(0),"^"),1:"Unknown"),1,18),?46,$SELECT($DATA(^RAMIS(71,+$PIECE(^TMP(...
... $JOB,"RASTEXT",RADTI,I1),"^",3),0)):$EXTRACT($PIECE(^(0),"^"),1,25),1:"Unknown")
End DoDot:1
+9 IF '$$USESSAN^RAHLRU1()
Begin DoDot:1
+10 WRITE !,?1,$PIECE(^TMP($JOB,"RASTEXT",RADTI,I1),"^",2),?10,$JUSTIFY(RATI,8),?20,...
... $EXTRACT($SELECT($DATA(^DPT(+^TMP($JOB,"RASTEXT",RADTI,I1),0)):$PIECE(^(0),"^"),1:"Unknown"),1,20),?42,$SELECT($DATA(^RAMIS(71,+$PIECE(^TMP($JOB,"RASTEXT",RADTI,I1),"^",3),0)):$EXTRACT($PIECE(^(0),"^"),1,25),1:"Unknown")
End DoDot:1
+11 if $DATA(^RA(78.6,+$PIECE(^TMP($JOB,"RASTEXT",RADTI,I1),"^",4),0))
WRITE ?72,$EXTRACT($PIECE(^(0),"^"),1,8)
+12 QUIT
+13 ;
HD NEW RADIVHD,RAGENTXT
+1 SET X=$HOROLOG
DO NOW^RAUTL1
SET RATIME=X
SET RASTOUT=$SELECT($DATA(^RA(72,RASTAT,0)):$PIECE(^(0),"^"),1:"")
+2 SET RALOC(0)=$PIECE(RAMLC,"^")
SET RALOC(1)=$PIECE($GET(^RA(79.1,RALOC(0),0)),"^")
+3 SET RALOC=$PIECE($GET(^SC(RALOC(1),0)),"^")
SET RADIV=$PIECE($GET(^DIC(4,+RAMDIV,0)),"^")
+4 SET RADIVHD="Division: "_RADIV
+5 SET RAGENTXT="Exam Status Tracking Module"
+6 WRITE @IOF,!?1,RAGENTXT,?39,RADIVHD
+7 WRITE !?1,"Date : ",$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,2,3)," ",RATIME,?39,"Status : ",RASTOUT
+8 WRITE !?1,"Locations: "
SET X=""
FOR
SET X=$ORDER(RADLOCS(X))
if X']""
QUIT
if ($X+$LENGTH(X))>IOM
WRITE !?($X+5)
WRITE X
if $ORDER(RADLOCS(X))'=""
WRITE ?($X+5)
+9 IF $$USESSAN^RAHLRU1()
Begin DoDot:1
+10 WRITE !!?1,"Case #",?18,"Date",?27,"Patient",?46,"Procedure",?72,"Equip/Rm",!
+11 WRITE ?1,"----------------",?18,"----",?27,"-------",?46,"---------",?72,"--------"
End DoDot:1
+12 IF '$$USESSAN^RAHLRU1()
Begin DoDot:1
+13 WRITE !!?1,"Case #",?10,"Date",?20,"Patient",?42,"Procedure",?72,"Equip/Rm",!
+14 WRITE ?1,"------",?10,"----",?20,"-------",?42,"---------",?72,"--------"
End DoDot:1
+15 QUIT
Q ; Kill and quit
+1 KILL %,%H,%W,%Y,%Y1,A,C,DIC,I,I1,ORX,POP,RACNI,RACNT,RACONTIN,RACS,RACTR,RADA,RADATE,RADFN,RADIV,RADTI,RAED,RAJ1,RAI,RAIMAGE,RALOC,RAMIS,RANODE,RAORD,RAPRIT,RAQ,RASTAT,RASTOUT,RATI,RATICTR,RATIME,RATXTLP,RAX,RAXIT,SDCLST,X,XQUIT,Y
+2 KILL RASEQARR,RAY
+3 KILL ^TMP($JOB,"RASTEXT"),^TMP($JOB,"RAEX")
+4 DO KILLVAR^RAUTL2
DO KMV^RAUTL15
+5 KILL DIOV,RAOR,X1
+6 QUIT
LMAX() ;
+1 if ($Y+4)>IOSL
QUIT 1
+2 QUIT 0
