RAORDP ;HISC/CAH,FPT,AISC/DMK - Log of Pending/Hold Requests ; Feb 28, 2024@06:25:27
;;5.0;Radiology/Nuclear Medicine;**15,133,182,193,209**;Mar 16, 1998;Build 3
;
; This report looks at all orders in file 75.1 with status=5 (pending)
; or status=3 (hold) and field 21 (Desired Date) or field 16 (Request Date)
; within the date range selected.
;
W !!,"This option will generate a list of requests for a selected date",!,"range with the status of 'PENDING' or 'HOLD'",!
K DIR S DIR(0)="S^H:HOLD;P:PENDING",DIR("A")="Select REQUEST STATUS",DIR("B")="P" D ^DIR K DIR
I $D(DIRUT) D KILL Q
W ! S RAREQSTA=$S(Y="P":5,1:3)
S RANOSCRN="" D OMA^RAUTL13 K RANOSCRN I '$L($O(RALOC(0)))!($G(RAQUIT)=1) D KILL Q
;KLM/p209 add sort criteria
K DIR S DIR(0)="S^1:DATE DESIRED;2:REQUEST ENTERED DATE",DIR("A")="Select date to sort by",DIR("B")="1" D ^DIR K DIR
I $D(DIRUT) D KILL Q
W ! S RASORT=Y_U_Y(0)
S RADDT=1 D DATE^RAUTL K RADDT G KILL:RAPOP S RAOBEG=BEGDATE,RAOEND=ENDDATE+.9 K BEGDATE,ENDDATE
S ZTRTN="START^RAORDP",ZTSAVE("RALOC(")="",ZTSAVE("RAOBEG")="",ZTSAVE("RAOEND")="",ZTSAVE("RAREQSTA")="",ZTSAVE("RASORT")=""
W !!,"This report requires a 132 column output device." D ZIS^RAUTL G KILL:RAPOP
START ; start report processing
U IO S QQ="",$P(QQ,"=",132)="=",RALOCNM="",RAOLOC="",RAHDR="LOG OF "_$S(RAREQSTA=5:"PENDING",1:"HOLD")_" REQUESTS",RAHDRDSH="",$P(RAHDRDSH,"-",$L(RAHDR))="-"
S RAOBEG("X")=+$E(RAOBEG,4,5)_"/"_+$E(RAOBEG,6,7)_"/"_$E(RAOBEG,2,3)
S RAOEND("X")=+$E(RAOEND,4,5)_"/"_+$E(RAOEND,6,7)_"/"_$E(RAOEND,2,3)
S X="NOW",%DT="T" D ^%DT D D^RAUTL S RARUNDTE=Y K %DT
I $D(ZTQUEUED) S ZTREQ="@"
F S RALOCNM=$O(RALOC(RALOCNM)) Q:RALOCNM="" S RA791IEN="" F S RA791IEN=$O(RALOC(RALOCNM,RA791IEN)) Q:RA791IEN="" S RALOC1(RA791IEN)=0,RALOCIT(+$P(^RA(79.1,RA791IEN,0),"^",6))=""
K RALOCNM,RA791IEN S RADFN=0
F S RADFN=$O(^RAO(75.1,"AS",RADFN)) Q:'RADFN!($D(RAEOS)) D
.S RAOIFN=0 F S RAOIFN=$O(^RAO(75.1,"AS",RADFN,RAREQSTA,RAOIFN)) Q:'RAOIFN!($D(RAEOS)) D
..I $D(^RAO(75.1,RAOIFN,0)) S RAO(0)=^(0),RAODT=$P(RAO(0),"^",21),RARDT=$P($P(RAO(0),"^",16),"."),RAOREA=$P(RAO(0),"^",10),RAOPHY=$P(RAO(0),"^",14),RALADT=$P(RAO(0),"^",18),RAILOC=$P(RAO(0),"^",20),RAIMTYP=$P(RAO(0),"^",3) D
...I $D(RALOC1(+RAILOC)) D SETTMP Q
...I RAILOC="",$D(RALOCIT(+RAIMTYP)) D SETTMP
I $D(RAEOS) D KILL Q
S RAILOC=""
F S RAILOC=$O(RALOC1(RAILOC)) Q:RAILOC=""!($D(RAEOS)) S RACNT=0 D CONT
KILL W !
K ^TMP($J,"RA")
K CNT,DIC,DIROUT,DIRUT,DTOUT,DUOUT,I,QQ,RACNT,RADFN,RADDT,RADLOCS,RADT,RAEOS,RAHDR,RAHDRDSH,RAILOC,RAIMTYP,RALOC,RALOC1,RALOCIT
K RALOCS,RALOCSAV,RALOCN,RAO,RAOBEG,RAODT,RAOEND,RAOIFN,RAOLOC,RAORD0,RAPOP,RAPR,RAQUIT,RARDT,RAREQSTA,BEGDATE,ENDDATE,RARUNDTE
K X,Y,RAMES,RALADT,RAOPHY,RAOREA,RADD,ZTDESC,ZTRTN,ZTSAVE,RALADTX,RASORT,RAORDT
D CLOSE^RAUTL
K POP,DDH,DISYS,DFN,VAERR
Q
CONT ;
I +RASORT=2 D CONT2 Q
I $E(IOST,1,2)="C-",RAOLOC]"",RAOLOC'=RAILOC D EOS Q:$D(RAEOS)
D HDR Q:$D(RAEOS)
I +RALOC1(RAILOC)=0 W !?2,"No requests "_$S(RAREQSTA=5:"pending",1:"on hold")_" for "_RAOBEG("X")_" to "_RAOEND("X")_".",! I $E(IOST,1,2)="C-"&($O(RALOC1(RAILOC))]"") D EOS Q:$D(RAEOS) D Q
.S RAOLOC(0)=$O(RALOC1(RAILOC)) S:RAOLOC(0)]"" RAOLOC=RAOLOC(0) K RAOLOC(0)
S RADT=0 F S RADT=$O(^TMP($J,"RA",RAILOC,RADT)) Q:'RADT!($D(RAEOS)) D DATE S RADFN=0 F S RADFN=$O(^TMP($J,"RA",RAILOC,RADT,RADFN)) Q:'RADFN!($D(RAEOS)) D MORE
Q
MORE ;
S RARDT=0 F S RARDT=$O(^TMP($J,"RA",RAILOC,RADT,RADFN,RARDT)) Q:'RARDT!($D(RAEOS)) S RAPR=0 F S RAPR=$O(^TMP($J,"RA",RAILOC,RADT,RADFN,RARDT,RAPR)) Q:'RAPR!($D(RAEOS)) D
.S RAOPHY=0 F S RAOPHY=$O(^TMP($J,"RA",RAILOC,RADT,RADFN,RARDT,RAPR,RAOPHY)) Q:'RAOPHY!($D(RAEOS)) S RALADT=0 F S RALADT=$O(^(RAOPHY,RALADT)) Q:'RALADT!($D(RAEOS)) D
..;p182/KLM Moved RAO $O to new line and removed naked ref as duplicate orders were not picked up
..S RAO=0 F S RAO=$O(^TMP($J,"RA",RAILOC,RADT,RADFN,RARDT,RAPR,RAOPHY,RALADT,RAO)) Q:'RAO!($D(RAEOS)) D
...N RAOREA S RAOREA=$G(^TMP($J,"RA",RAILOC,RADT,RADFN,RARDT,RAPR,RAOPHY,RALADT,RAO))
...S RAORD0=^RAO(75.1,+RAO,0),RACNT=RACNT+1
...K RALOCN,RARLOCN
...D IPOP^RAUTL13
...D WRT
...Q
..Q
.Q
Q
CONT2 ;p209
I $E(IOST,1,2)="C-",RAOLOC]"",RAOLOC'=RAILOC D EOS Q:$D(RAEOS)
D HDR Q:$D(RAEOS)
I +RALOC1(RAILOC)=0 W !?2,"No requests "_$S(RAREQSTA=5:"pending",1:"on hold")_" for "_RAOBEG("X")_" to "_RAOEND("X")_".",! I $E(IOST,1,2)="C-"&($O(RALOC1(RAILOC))]"") D EOS Q:$D(RAEOS) D Q
.S RAOLOC(0)=$O(RALOC1(RAILOC)) S:RAOLOC(0)]"" RAOLOC=RAOLOC(0) K RAOLOC(0)
S RARDT=0 F S RARDT=$O(^TMP($J,"RA",RAILOC,RARDT)) Q:'RARDT!($D(RAEOS)) D DATE S RADFN=0 F S RADFN=$O(^TMP($J,"RA",RAILOC,RARDT,RADFN)) Q:'RADFN!($D(RAEOS)) D MORE2
Q
MORE2 ;p209
S RADT=0 F S RADT=$O(^TMP($J,"RA",RAILOC,RARDT,RADFN,RADT)) Q:'RADT!($D(RAEOS)) S RAPR=0 F S RAPR=$O(^TMP($J,"RA",RAILOC,RARDT,RADFN,RADT,RAPR)) Q:'RAPR!($D(RAEOS)) D
.S RAOPHY=0 F S RAOPHY=$O(^TMP($J,"RA",RAILOC,RARDT,RADFN,RADT,RAPR,RAOPHY)) Q:'RAOPHY!($D(RAEOS)) S RALADT=0 F S RALADT=$O(^(RAOPHY,RALADT)) Q:'RALADT!($D(RAEOS)) D
..;p182/KLM Moved RAO $O to new line and removed naked ref as duplicate orders were not picked up
..S RAO=0 F S RAO=$O(^TMP($J,"RA",RAILOC,RARDT,RADFN,RADT,RAPR,RAOPHY,RALADT,RAO)) Q:'RAO!($D(RAEOS)) D
...N RAOREA S RAOREA=$G(^TMP($J,"RA",RAILOC,RARDT,RADFN,RADT,RAPR,RAOPHY,RALADT,RAO))
...S RAORD0=^RAO(75.1,+RAO,0),RACNT=RACNT+1
...K RALOCN,RARLOCN
...D IPOP^RAUTL13
...D WRT
...Q
..Q
.Q
Q
WRT ;
S Y=RADT D DD^%DT S RADD=Y S Y=$P(RALADT,".") D DD^%DT S RALADTX=Y ;p182/KLM use diff var.
S Y=$P(RARDT,".") D DD^%DT S RAORDT=Y
W !,$S($D(^DPT(RADFN,0)):$E($P(^(0),"^"),1,19),1:"Unknown"),?21,$E($P(^DPT(RADFN,0),"^",9),6,9),?27,$S($D(^RAMIS(71,RAPR,0)):$E($P(^(0),"^"),1,24),1:"Unknown"),?53,$P(RAORDT,"@") ;$P(RADD,"@")
W ?67,$P(RADD,"@")
;S Y=$P(RARDT,".") D DD^%DT W ?67,Y
W ?81,$S(RAREQSTA=3:RALADTX,1:$E($$GET1^DIQ(200,RAOPHY,.01),1,19))
I RAREQSTA=3 W ?95,$E($$GET1^DIQ(75.2,RAOREA,.01),1,28)
E W ?102,$E(RALOCN,1,28)
;I $L($G(RARLOCN)) W !?36,"Requesting Loc: ",RARLOCN
S RAOLOC=RAILOC
I ($Y+6)>IOSL D EOS Q:$D(RAEOS) D:RACNT<RALOC1(RAILOC) HDR Q:$D(RAEOS) I RACNT=RALOC1(RAILOC) S RAOLOC(0)=$O(RALOC1(RAILOC)) S:RAOLOC(0)]"" RAOLOC=RAOLOC(0) K RAOLOC(0)
Q
HDR ; header
W:$Y>0 @IOF
W !?(80-$L(RAHDR)/2),RAHDR
;p193/KLM - next line removed 'scheduled' from header. These are not scheduled requests. Updated column to re-center.
W !?19,"Includes requests from ",RAOBEG("X")," to ",RAOEND("X") ;W !?(80-$L(RAHDR)/2),RAHDRDSH
W !,"IMAGING LOCATION: ",$S('RAILOC:"Unknown",$D(^RA(79.1,RAILOC,0)):$S($D(^SC($P(^(0),"^"),0)):$P(^(0),"^"),1:"Unknown"),1:"Unknown"),?51,"Run Date: ",RARUNDTE,!
W !,"PATIENT NAME",?21,"SSN",?27,"PROCEDURE",?53,"DATE ORDERED",?67,"DATE DESIRED"
W ?81,$S(RAREQSTA=3:"HOLD DATE",1:"ORDERING PROVIDER")
I RAREQSTA=3 W ?95,"HOLD REASON",!,QQ,!!
E W ?102,"PT LOC",!,QQ,!!
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS=""
Q
DATE ; Output 'Desired Date'
;S Y=RADT D DD^%DT S X=$L(Y)+32 W !!?(80-X/2),"Desired Date (Time optional): ",Y,!?(80-X/2) S Y="",$P(Y,"-",X)="-" W Y,!
Q
SETTMP ; set-up ^TMP($J
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS="" Q:$D(RAEOS)
I +RASORT=1 D ;Sort by date desired
.I $S('RAODT:0,'RADFN:0,'$P(RAO(0),"^",16):0,'$P(RAO(0),"^",2):0,1:1),RAODT'<RAOBEG,RAODT'>RAOEND S ^TMP($J,"RA",$S(RAILOC:RAILOC,1:"UNKNOWN"),$P(RAO(0),"^",21),RADFN,$P(RAO(0),"^",16),$P(RAO(0),"^",2),RAOPHY,RALADT,RAOIFN)=RAOREA D
..I RAILOC="" S:'$D(RALOC1("UNKNOWN")) RALOC1("UNKNOWN")=0 S RALOC1("UNKNOWN")=RALOC1("UNKNOWN")+1 Q
..S:RAILOC>0 RALOC1(RAILOC)=RALOC1(RAILOC)+1
.Q
I +RASORT=2 D ;p209-Sort by order date
.I $S('RAODT:0,'RADFN:0,'$P(RAO(0),"^",16):0,'$P(RAO(0),"^",2):0,1:1),RARDT'<RAOBEG,RARDT'>RAOEND S ^TMP($J,"RA",$S(RAILOC:RAILOC,1:"UNKNOWN"),$P(RAO(0),"^",16),RADFN,$P(RAO(0),"^",21),$P(RAO(0),"^",2),RAOPHY,RALADT,RAOIFN)=RAOREA D
..I RAILOC="" S:'$D(RALOC1("UNKNOWN")) RALOC1("UNKNOWN")=0 S RALOC1("UNKNOWN")=RALOC1("UNKNOWN")+1 Q
..S:RAILOC>0 RALOC1(RAILOC)=RALOC1(RAILOC)+1
.Q
Q
EOS ; end of screen
S X=$$EOS^RAUTL5
S:X=1 RAEOS=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDP 8204 printed Oct 16, 2024@18:38:51 Page 2
RAORDP ;HISC/CAH,FPT,AISC/DMK - Log of Pending/Hold Requests ; Feb 28, 2024@06:25:27
+1 ;;5.0;Radiology/Nuclear Medicine;**15,133,182,193,209**;Mar 16, 1998;Build 3
+2 ;
+3 ; This report looks at all orders in file 75.1 with status=5 (pending)
+4 ; or status=3 (hold) and field 21 (Desired Date) or field 16 (Request Date)
+5 ; within the date range selected.
+6 ;
+7 WRITE !!,"This option will generate a list of requests for a selected date",!,"range with the status of 'PENDING' or 'HOLD'",!
+8 KILL DIR
SET DIR(0)="S^H:HOLD;P:PENDING"
SET DIR("A")="Select REQUEST STATUS"
SET DIR("B")="P"
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
DO KILL
QUIT
+10 WRITE !
SET RAREQSTA=$SELECT(Y="P":5,1:3)
+11 SET RANOSCRN=""
DO OMA^RAUTL13
KILL RANOSCRN
IF '$LENGTH($ORDER(RALOC(0)))!($GET(RAQUIT)=1)
DO KILL
QUIT
+12 ;KLM/p209 add sort criteria
+13 KILL DIR
SET DIR(0)="S^1:DATE DESIRED;2:REQUEST ENTERED DATE"
SET DIR("A")="Select date to sort by"
SET DIR("B")="1"
DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
DO KILL
QUIT
+15 WRITE !
SET RASORT=Y_U_Y(0)
+16 SET RADDT=1
DO DATE^RAUTL
KILL RADDT
if RAPOP
GOTO KILL
SET RAOBEG=BEGDATE
SET RAOEND=ENDDATE+.9
KILL BEGDATE,ENDDATE
+17 SET ZTRTN="START^RAORDP"
SET ZTSAVE("RALOC(")=""
SET ZTSAVE("RAOBEG")=""
SET ZTSAVE("RAOEND")=""
SET ZTSAVE("RAREQSTA")=""
SET ZTSAVE("RASORT")=""
+18 WRITE !!,"This report requires a 132 column output device."
DO ZIS^RAUTL
if RAPOP
GOTO KILL
START ; start report processing
+1 USE IO
SET QQ=""
SET $PIECE(QQ,"=",132)="="
SET RALOCNM=""
SET RAOLOC=""
SET RAHDR="LOG OF "_$SELECT(RAREQSTA=5:"PENDING",1:"HOLD")_" REQUESTS"
SET RAHDRDSH=""
SET $PIECE(RAHDRDSH,"-",$LENGTH(RAHDR))="-"
+2 SET RAOBEG("X")=+$EXTRACT(RAOBEG,4,5)_"/"_+$EXTRACT(RAOBEG,6,7)_"/"_$EXTRACT(RAOBEG,2,3)
+3 SET RAOEND("X")=+$EXTRACT(RAOEND,4,5)_"/"_+$EXTRACT(RAOEND,6,7)_"/"_$EXTRACT(RAOEND,2,3)
+4 SET X="NOW"
SET %DT="T"
DO ^%DT
DO D^RAUTL
SET RARUNDTE=Y
KILL %DT
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 FOR
SET RALOCNM=$ORDER(RALOC(RALOCNM))
if RALOCNM=""
QUIT
SET RA791IEN=""
FOR
SET RA791IEN=$ORDER(RALOC(RALOCNM,RA791IEN))
if RA791IEN=""
QUIT
SET RALOC1(RA791IEN)=0
SET RALOCIT(+$PIECE(^RA(79.1,RA791IEN,0),"^",6))=""
+7 KILL RALOCNM,RA791IEN
SET RADFN=0
+8 FOR
SET RADFN=$ORDER(^RAO(75.1,"AS",RADFN))
if 'RADFN!($DATA(RAEOS))
QUIT
Begin DoDot:1
+9 SET RAOIFN=0
FOR
SET RAOIFN=$ORDER(^RAO(75.1,"AS",RADFN,RAREQSTA,RAOIFN))
if 'RAOIFN!($DATA(RAEOS))
QUIT
Begin DoDot:2
+10 IF $DATA(^RAO(75.1,RAOIFN,0))
SET RAO(0)=^(0)
SET RAODT=$PIECE(RAO(0),"^",21)
SET RARDT=$PIECE($PIECE(RAO(0),"^",16),".")
SET RAOREA=$PIECE(RAO(0),"^",10)
SET RAOPHY=$PIECE(RAO(0),"^",14)
SET RALADT=$PIECE(RAO(0),"^",18)
SET RAILOC=$PIECE(RAO(0),"^",20)
SET RAIMTYP=$PIECE(RAO(0),"^",3)
Begin DoDot:3
+11 IF $DATA(RALOC1(+RAILOC))
DO SETTMP
QUIT
+12 IF RAILOC=""
IF $DATA(RALOCIT(+RAIMTYP))
DO SETTMP
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF $DATA(RAEOS)
DO KILL
QUIT
+14 SET RAILOC=""
+15 FOR
SET RAILOC=$ORDER(RALOC1(RAILOC))
if RAILOC=""!($DATA(RAEOS))
QUIT
SET RACNT=0
DO CONT
KILL WRITE !
+1 KILL ^TMP($JOB,"RA")
+2 KILL CNT,DIC,DIROUT,DIRUT,DTOUT,DUOUT,I,QQ,RACNT,RADFN,RADDT,RADLOCS,RADT,RAEOS,RAHDR,RAHDRDSH,RAILOC,RAIMTYP,RALOC,RALOC1,RALOCIT
+3 KILL RALOCS,RALOCSAV,RALOCN,RAO,RAOBEG,RAODT,RAOEND,RAOIFN,RAOLOC,RAORD0,RAPOP,RAPR,RAQUIT,RARDT,RAREQSTA,BEGDATE,ENDDATE,RARUNDTE
+4 KILL X,Y,RAMES,RALADT,RAOPHY,RAOREA,RADD,ZTDESC,ZTRTN,ZTSAVE,RALADTX,RASORT,RAORDT
+5 DO CLOSE^RAUTL
+6 KILL POP,DDH,DISYS,DFN,VAERR
+7 QUIT
CONT ;
+1 IF +RASORT=2
DO CONT2
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"
IF RAOLOC]""
IF RAOLOC'=RAILOC
DO EOS
if $DATA(RAEOS)
QUIT
+3 DO HDR
if $DATA(RAEOS)
QUIT
+4 IF +RALOC1(RAILOC)=0
WRITE !?2,"No requests "_$SELECT(RAREQSTA=5:"pending",1:"on hold")_" for "_RAOBEG("X")_" to "_RAOEND("X")_".",!
IF $EXTRACT(IOST,1,2)="C-"&($ORDER(RALOC1(RAILOC))]"")
DO EOS
if $DATA(RAEOS)
QUIT
Begin DoDot:1
+5 SET RAOLOC(0)=$ORDER(RALOC1(RAILOC))
if RAOLOC(0)]""
SET RAOLOC=RAOLOC(0)
KILL RAOLOC(0)
End DoDot:1
QUIT
+6 SET RADT=0
FOR
SET RADT=$ORDER(^TMP($JOB,"RA",RAILOC,RADT))
if 'RADT!($DATA(RAEOS))
QUIT
DO DATE
SET RADFN=0
FOR
SET RADFN=$ORDER(^TMP($JOB,"RA",RAILOC,RADT,RADFN))
if 'RADFN!($DATA(RAEOS))
QUIT
DO MORE
+7 QUIT
MORE ;
+1 SET RARDT=0
FOR
SET RARDT=$ORDER(^TMP($JOB,"RA",RAILOC,RADT,RADFN,RARDT))
if 'RARDT!($DATA(RAEOS))
QUIT
SET RAPR=0
FOR
SET RAPR=$ORDER(^TMP($JOB,"RA",RAILOC,RADT,RADFN,RARDT,RAPR))
if 'RAPR!($DATA(RAEOS))
QUIT
Begin DoDot:1
+2 SET RAOPHY=0
FOR
SET RAOPHY=$ORDER(^TMP($JOB,"RA",RAILOC,RADT,RADFN,RARDT,RAPR,RAOPHY))
if 'RAOPHY!($DATA(RAEOS))
QUIT
SET RALADT=0
FOR
SET RALADT=$ORDER(^(RAOPHY,RALADT))
if 'RALADT!($DATA(RAEOS))
QUIT
Begin DoDot:2
+3 ;p182/KLM Moved RAO $O to new line and removed naked ref as duplicate orders were not picked up
+4 SET RAO=0
FOR
SET RAO=$ORDER(^TMP($JOB,"RA",RAILOC,RADT,RADFN,RARDT,RAPR,RAOPHY,RALADT,RAO))
if 'RAO!($DATA(RAEOS))
QUIT
Begin DoDot:3
+5 NEW RAOREA
SET RAOREA=$GET(^TMP($JOB,"RA",RAILOC,RADT,RADFN,RARDT,RAPR,RAOPHY,RALADT,RAO))
+6 SET RAORD0=^RAO(75.1,+RAO,0)
SET RACNT=RACNT+1
+7 KILL RALOCN,RARLOCN
+8 DO IPOP^RAUTL13
+9 DO WRT
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
CONT2 ;p209
+1 IF $EXTRACT(IOST,1,2)="C-"
IF RAOLOC]""
IF RAOLOC'=RAILOC
DO EOS
if $DATA(RAEOS)
QUIT
+2 DO HDR
if $DATA(RAEOS)
QUIT
+3 IF +RALOC1(RAILOC)=0
WRITE !?2,"No requests "_$SELECT(RAREQSTA=5:"pending",1:"on hold")_" for "_RAOBEG("X")_" to "_RAOEND("X")_".",!
IF $EXTRACT(IOST,1,2)="C-"&($ORDER(RALOC1(RAILOC))]"")
DO EOS
if $DATA(RAEOS)
QUIT
Begin DoDot:1
+4 SET RAOLOC(0)=$ORDER(RALOC1(RAILOC))
if RAOLOC(0)]""
SET RAOLOC=RAOLOC(0)
KILL RAOLOC(0)
End DoDot:1
QUIT
+5 SET RARDT=0
FOR
SET RARDT=$ORDER(^TMP($JOB,"RA",RAILOC,RARDT))
if 'RARDT!($DATA(RAEOS))
QUIT
DO DATE
SET RADFN=0
FOR
SET RADFN=$ORDER(^TMP($JOB,"RA",RAILOC,RARDT,RADFN))
if 'RADFN!($DATA(RAEOS))
QUIT
DO MORE2
+6 QUIT
MORE2 ;p209
+1 SET RADT=0
FOR
SET RADT=$ORDER(^TMP($JOB,"RA",RAILOC,RARDT,RADFN,RADT))
if 'RADT!($DATA(RAEOS))
QUIT
SET RAPR=0
FOR
SET RAPR=$ORDER(^TMP($JOB,"RA",RAILOC,RARDT,RADFN,RADT,RAPR))
if 'RAPR!($DATA(RAEOS))
QUIT
Begin DoDot:1
+2 SET RAOPHY=0
FOR
SET RAOPHY=$ORDER(^TMP($JOB,"RA",RAILOC,RARDT,RADFN,RADT,RAPR,RAOPHY))
if 'RAOPHY!($DATA(RAEOS))
QUIT
SET RALADT=0
FOR
SET RALADT=$ORDER(^(RAOPHY,RALADT))
if 'RALADT!($DATA(RAEOS))
QUIT
Begin DoDot:2
+3 ;p182/KLM Moved RAO $O to new line and removed naked ref as duplicate orders were not picked up
+4 SET RAO=0
FOR
SET RAO=$ORDER(^TMP($JOB,"RA",RAILOC,RARDT,RADFN,RADT,RAPR,RAOPHY,RALADT,RAO))
if 'RAO!($DATA(RAEOS))
QUIT
Begin DoDot:3
+5 NEW RAOREA
SET RAOREA=$GET(^TMP($JOB,"RA",RAILOC,RARDT,RADFN,RADT,RAPR,RAOPHY,RALADT,RAO))
+6 SET RAORD0=^RAO(75.1,+RAO,0)
SET RACNT=RACNT+1
+7 KILL RALOCN,RARLOCN
+8 DO IPOP^RAUTL13
+9 DO WRT
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
WRT ;
+1 ;p182/KLM use diff var.
SET Y=RADT
DO DD^%DT
SET RADD=Y
SET Y=$PIECE(RALADT,".")
DO DD^%DT
SET RALADTX=Y
+2 SET Y=$PIECE(RARDT,".")
DO DD^%DT
SET RAORDT=Y
+3 ;$P(RADD,"@")
WRITE !,$SELECT($DATA(^DPT(RADFN,0)):$EXTRACT($PIECE(^(0),"^"),1,19),1:"Unknown"),?21,$EXTRACT($PIECE(^DPT(RADFN,0),"^",9),6,9),?27,$SELECT($DATA(^RAMIS(71,RAPR,0)):$EXTRACT($PIECE(^(0),"^"),1,24),1:"Unknown"),?53,$PIECE(RAORDT,"@")
+4 WRITE ?67,$PIECE(RADD,"@")
+5 ;S Y=$P(RARDT,".") D DD^%DT W ?67,Y
+6 WRITE ?81,$SELECT(RAREQSTA=3:RALADTX,1:$EXTRACT($$GET1^DIQ(200,RAOPHY,.01),1,19))
+7 IF RAREQSTA=3
WRITE ?95,$EXTRACT($$GET1^DIQ(75.2,RAOREA,.01),1,28)
+8 IF '$TEST
WRITE ?102,$EXTRACT(RALOCN,1,28)
+9 ;I $L($G(RARLOCN)) W !?36,"Requesting Loc: ",RARLOCN
+10 SET RAOLOC=RAILOC
+11 IF ($Y+6)>IOSL
DO EOS
if $DATA(RAEOS)
QUIT
if RACNT<RALOC1(RAILOC)
DO HDR
if $DATA(RAEOS)
QUIT
IF RACNT=RALOC1(RAILOC)
SET RAOLOC(0)=$ORDER(RALOC1(RAILOC))
if RAOLOC(0)]""
SET RAOLOC=RAOLOC(0)
KILL RAOLOC(0)
+12 QUIT
HDR ; header
+1 if $Y>0
WRITE @IOF
+2 WRITE !?(80-$LENGTH(RAHDR)/2),RAHDR
+3 ;p193/KLM - next line removed 'scheduled' from header. These are not scheduled requests. Updated column to re-center.
+4 ;W !?(80-$L(RAHDR)/2),RAHDRDSH
WRITE !?19,"Includes requests from ",RAOBEG("X")," to ",RAOEND("X")
+5 WRITE !,"IMAGING LOCATION: ",$SELECT('RAILOC:"Unknown",$DATA(^RA(79.1,RAILOC,0)):$SELECT($DATA(^SC($PIECE(^(0),"^"),0)):$PIECE(^(0),"^"),1:"Unknown"),1:"Unknown"),?51,"Run Date: ",RARUNDTE,!
+6 WRITE !,"PATIENT NAME",?21,"SSN",?27,"PROCEDURE",?53,"DATE ORDERED",?67,"DATE DESIRED"
+7 WRITE ?81,$SELECT(RAREQSTA=3:"HOLD DATE",1:"ORDERING PROVIDER")
+8 IF RAREQSTA=3
WRITE ?95,"HOLD REASON",!,QQ,!!
+9 IF '$TEST
WRITE ?102,"PT LOC",!,QQ,!!
+10 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAEOS=""
+11 QUIT
DATE ; Output 'Desired Date'
+1 ;S Y=RADT D DD^%DT S X=$L(Y)+32 W !!?(80-X/2),"Desired Date (Time optional): ",Y,!?(80-X/2) S Y="",$P(Y,"-",X)="-" W Y,!
+2 QUIT
SETTMP ; set-up ^TMP($J
+1 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAEOS=""
if $DATA(RAEOS)
QUIT
+2 ;Sort by date desired
IF +RASORT=1
Begin DoDot:1
+3 IF $SELECT('RAODT:0,'RADFN:0,'$PIECE(RAO(0),"^",16):0,'$PIECE(RAO(0),"^",2):0,1:1)
IF RAODT'<RAOBEG
IF RAODT'>RAOEND
SET ^TMP($JOB,"RA",$SELECT(RAILOC:RAILOC,1:"UNKNOWN"),$PIECE(RAO(0),"^",21),RADFN,$PIECE(RAO(0),"^",16),$PIECE(RAO(0),"^",2),RAOPHY,RALADT,RAOIFN)=RAOREA
Begin DoDot:2
+4 IF RAILOC=""
if '$DATA(RALOC1("UNKNOWN"))
SET RALOC1("UNKNOWN")=0
SET RALOC1("UNKNOWN")=RALOC1("UNKNOWN")+1
QUIT
+5 if RAILOC>0
SET RALOC1(RAILOC)=RALOC1(RAILOC)+1
End DoDot:2
+6 QUIT
End DoDot:1
+7 ;p209-Sort by order date
IF +RASORT=2
Begin DoDot:1
+8 IF $SELECT('RAODT:0,'RADFN:0,'$PIECE(RAO(0),"^",16):0,'$PIECE(RAO(0),"^",2):0,1:1)
IF RARDT'<RAOBEG
IF RARDT'>RAOEND
SET ^TMP($JOB,"RA",$SELECT(RAILOC:RAILOC,1:"UNKNOWN"),$PIECE(RAO(0),"^",16),RADFN,$PIECE(RAO(0),"^",21),$PIECE(RAO(0),"^",2),RAOPHY,RALADT,RAOIFN)=RAOREA
Begin DoDot:2
+9 IF RAILOC=""
if '$DATA(RALOC1("UNKNOWN"))
SET RALOC1("UNKNOWN")=0
SET RALOC1("UNKNOWN")=RALOC1("UNKNOWN")+1
QUIT
+10 if RAILOC>0
SET RALOC1(RAILOC)=RALOC1(RAILOC)+1
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
EOS ; end of screen
+1 SET X=$$EOS^RAUTL5
+2 if X=1
SET RAEOS=""
+3 QUIT
