RAORDCP ;WOIFO/KLM - Log of Discontinued Requests ; May 26, 2021@10:50:10
;;5.0;Radiology/Nuclear Medicine;**179**;Mar 16, 1998;Build 4
;
; This report looks at all orders in file 75.1 with status=1 (Discontinued)
; and field 21 (Desired Date) within the date range selected.
;
; File IA Type
; -------------------------------------
; ^DPT( 10035 (S)
; ^SC( 10040 (S)
;
EN ;Option entry point - [RA ORDER DISCONTINUED]
W !!?2,"This option will generate a list of DISCONTINUED requests",!?2,"for a selected date range"
W ! S RAORDST=1 ;discontinued
S RANOSCRN="" D OMA^RAUTL13 K RANOSCRN I '$L($O(RALOC(0)))!($G(RAQUIT)=1) D KILL Q
S RADDT=1 D DATE^RAUTL K RADDT I RAPOP D KILL Q
S RAOBEG=BEGDATE,RAOEND=ENDDATE+.9 K BEGDATE,ENDDATE
S ZTSAVE("RAOBEG")="",ZTSAVE("RAOEND")=""
S ZTRTN="START^RAORDCP",ZTSAVE("RALOC(")="",ZTSAVE("RASORTBY")="",ZTSAVE("RAORDST")=""
W !!,"This report requires a 132 column output device." D ZIS^RAUTL I RAPOP D KILL Q
;
START ;report processing
N RAODD S RAODD=RAOBEG-.000001
U IO S QQ="",$P(QQ,"=",132)="=",RALOCNM="",RAOLOC="",RAHDR="LOG OF DISCONTINUED 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
N RAOIEN
F S RAODD=$O(^RAO(75.1,"BDD",RAODD)) Q:RAODD=""!(RAODD>RAOEND) D
.S RAOIEN=0 F S RAOIEN=$O(^RAO(75.1,"BDD",RAODD,RAOIEN)) Q:RAOIEN="" D
..Q:$P(^RAO(75.1,RAOIEN,0),U,5)>RAORDST
..S RAO0=$G(^RAO(75.1,RAOIEN,0)),RADFN=$P(RAO0,U)
..S RAODT=$P(RAO0,U,21),RAOREA=$P(RAO0,U,10),RALADT=$P(RAO0,U,18),RAILOC=$P(RAO0,U,20),RAIMTYP=$P(RAO0,U,3)
..N RAT S RAT=$O(^RAO(75.1,RAOIEN,"T",""),-1),RADCBY=$S($D(^RAO(75.1,RAOIEN,"T",0)):$P(^RAO(75.1,RAOIEN,"T",RAT,0),U,3),1:"Unknown")
..I $D(RALOC1(+RAILOC)) D SETTMP Q
..I RAILOC="",$D(RALOCIT(+RAIMTYP)) D SETTMP
..Q
.Q
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,"RAODC")
K QQ,RACNT,RADFN,RADDT,RADT,RAEOS,RAHDR,RAHDRDSH,RAILOC,RAIMTYP,RALOC,RALOC1,RALOCIT
K RALOCN,RAO,RAOBEG,RAODT,RAOEND,RAOIFN,RAOLOC,RAPOP,RAPR,RAQUIT,RARDT,RAREQSTA,BEGDATE,ENDDATE,RARUNDTE
K X,Y,RALADT,RAOREA,RADD,ZTDESC,ZTRTN,ZTSAVE,RADCBY,RAO0,RAORDST,RADLOCS,RAODD,RAT,RALADTX
D CLOSE^RAUTL
Q
CONT ;
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 DISCONTINUED requests 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,"RAODC",RAILOC,RADT)) Q:'RADT!($D(RAEOS)) S RADFN=0 F S RADFN=$O(^TMP($J,"RAODC",RAILOC,RADT,RADFN)) Q:'RADFN!($D(RAEOS)) D MORE
Q
MORE ;
S RAPR=0 F S RAPR=$O(^TMP($J,"RAODC",RAILOC,RADT,RADFN,RAPR)) Q:'RAPR!($D(RAEOS)) D
.S RADCBY="" F S RADCBY=$O(^TMP($J,"RAODC",RAILOC,RADT,RADFN,RAPR,RADCBY)) Q:RADCBY=""!($D(RAEOS)) D
..S RALADT=0 F S RALADT=$O(^TMP($J,"RAODC",RAILOC,RADT,RADFN,RAPR,RADCBY,RALADT)) Q:'RALADT!($D(RAEOS)) D
...S RAO=0 F S RAO=$O(^TMP($J,"RAODC",RAILOC,RADT,RADFN,RAPR,RADCBY,RALADT,RAO)) Q:'RAO!($D(RAEOS)) D
....N RAREA S RAOREA=$G(^TMP($J,"RAODC",RAILOC,RADT,RADFN,RAPR,RADCBY,RALADT,RAO))
....S RACNT=RACNT+1
....K RALOCN,RARLOCN
....D WRT
....Q
...Q
..Q
.Q
Q
WRT ;
S Y=RADT D DD^%DT S RADD=Y S Y=$P(RALADT,".") D DD^%DT S RALADTX=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(RADD,"@")
W ?67,RALADTX
W ?83,$S(RADCBY="Unknown":RADCBY,1:$E($$GET1^DIQ(200,RADCBY,.01),1,19))
;If there's no cancel reason, get cancel description (should only occur with provider DC through CPRS)
W ?104,$S(RAOREA="":$E($$GET1^DIQ(75.1,RAO,27),1,28),1:$E($$GET1^DIQ(75.2,RAOREA,.01),1,28))
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
W !?14,"Includes discontinued 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 DESIRED",?67,"CANCELLED DATE"
W ?83,"CANCELLED BY"
W ?104,"CANCEL REASON",!,QQ,!!
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS=""
Q
SETTMP ;results in TMP
;^TMP($J,"RAODC",I-LOC,DATE_DESIRED,DFN,PROCEDURE,DC'D_BY,DC'D_DATE,ORDER_IEN)=DC_REASON
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS="" Q:$D(RAEOS)
S ^TMP($J,"RAODC",$S(RAILOC:RAILOC,1:"UNKNOWN"),$P(RAO0,U,21),RADFN,$P(RAO0,U,2),RADCBY,RALADT,RAOIEN)=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
EOS ; end of screen
S X=$$EOS^RAUTL5
S:X=1 RAEOS=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDCP 5601 printed Dec 13, 2024@02:38:15 Page 2
RAORDCP ;WOIFO/KLM - Log of Discontinued Requests ; May 26, 2021@10:50:10
+1 ;;5.0;Radiology/Nuclear Medicine;**179**;Mar 16, 1998;Build 4
+2 ;
+3 ; This report looks at all orders in file 75.1 with status=1 (Discontinued)
+4 ; and field 21 (Desired Date) within the date range selected.
+5 ;
+6 ; File IA Type
+7 ; -------------------------------------
+8 ; ^DPT( 10035 (S)
+9 ; ^SC( 10040 (S)
+10 ;
EN ;Option entry point - [RA ORDER DISCONTINUED]
+1 WRITE !!?2,"This option will generate a list of DISCONTINUED requests",!?2,"for a selected date range"
+2 ;discontinued
WRITE !
SET RAORDST=1
+3 SET RANOSCRN=""
DO OMA^RAUTL13
KILL RANOSCRN
IF '$LENGTH($ORDER(RALOC(0)))!($GET(RAQUIT)=1)
DO KILL
QUIT
+4 SET RADDT=1
DO DATE^RAUTL
KILL RADDT
IF RAPOP
DO KILL
QUIT
+5 SET RAOBEG=BEGDATE
SET RAOEND=ENDDATE+.9
KILL BEGDATE,ENDDATE
+6 SET ZTSAVE("RAOBEG")=""
SET ZTSAVE("RAOEND")=""
+7 SET ZTRTN="START^RAORDCP"
SET ZTSAVE("RALOC(")=""
SET ZTSAVE("RASORTBY")=""
SET ZTSAVE("RAORDST")=""
+8 WRITE !!,"This report requires a 132 column output device."
DO ZIS^RAUTL
IF RAPOP
DO KILL
QUIT
+9 ;
START ;report processing
+1 NEW RAODD
SET RAODD=RAOBEG-.000001
+2 USE IO
SET QQ=""
SET $PIECE(QQ,"=",132)="="
SET RALOCNM=""
SET RAOLOC=""
SET RAHDR="LOG OF DISCONTINUED REQUESTS"
SET RAHDRDSH=""
SET $PIECE(RAHDRDSH,"-",$LENGTH(RAHDR))="-"
+3 SET RAOBEG("X")=+$EXTRACT(RAOBEG,4,5)_"/"_+$EXTRACT(RAOBEG,6,7)_"/"_$EXTRACT(RAOBEG,2,3)
+4 SET RAOEND("X")=+$EXTRACT(RAOEND,4,5)_"/"_+$EXTRACT(RAOEND,6,7)_"/"_$EXTRACT(RAOEND,2,3)
+5 SET X="NOW"
SET %DT="T"
DO ^%DT
DO D^RAUTL
SET RARUNDTE=Y
KILL %DT
+6 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 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))=""
+8 KILL RALOCNM,RA791IEN
+9 NEW RAOIEN
+10 FOR
SET RAODD=$ORDER(^RAO(75.1,"BDD",RAODD))
if RAODD=""!(RAODD>RAOEND)
QUIT
Begin DoDot:1
+11 SET RAOIEN=0
FOR
SET RAOIEN=$ORDER(^RAO(75.1,"BDD",RAODD,RAOIEN))
if RAOIEN=""
QUIT
Begin DoDot:2
+12 if $PIECE(^RAO(75.1,RAOIEN,0),U,5)>RAORDST
QUIT
+13 SET RAO0=$GET(^RAO(75.1,RAOIEN,0))
SET RADFN=$PIECE(RAO0,U)
+14 SET RAODT=$PIECE(RAO0,U,21)
SET RAOREA=$PIECE(RAO0,U,10)
SET RALADT=$PIECE(RAO0,U,18)
SET RAILOC=$PIECE(RAO0,U,20)
SET RAIMTYP=$PIECE(RAO0,U,3)
+15 NEW RAT
SET RAT=$ORDER(^RAO(75.1,RAOIEN,"T",""),-1)
SET RADCBY=$SELECT($DATA(^RAO(75.1,RAOIEN,"T",0)):$PIECE(^RAO(75.1,RAOIEN,"T",RAT,0),U,3),1:"Unknown")
+16 IF $DATA(RALOC1(+RAILOC))
DO SETTMP
QUIT
+17 IF RAILOC=""
IF $DATA(RALOCIT(+RAIMTYP))
DO SETTMP
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF $DATA(RAEOS)
DO KILL
QUIT
+21 SET RAILOC=""
+22 FOR
SET RAILOC=$ORDER(RALOC1(RAILOC))
if RAILOC=""!($DATA(RAEOS))
QUIT
SET RACNT=0
DO CONT
KILL WRITE !
+1 KILL ^TMP($JOB,"RAODC")
+2 KILL QQ,RACNT,RADFN,RADDT,RADT,RAEOS,RAHDR,RAHDRDSH,RAILOC,RAIMTYP,RALOC,RALOC1,RALOCIT
+3 KILL RALOCN,RAO,RAOBEG,RAODT,RAOEND,RAOIFN,RAOLOC,RAPOP,RAPR,RAQUIT,RARDT,RAREQSTA,BEGDATE,ENDDATE,RARUNDTE
+4 KILL X,Y,RALADT,RAOREA,RADD,ZTDESC,ZTRTN,ZTSAVE,RADCBY,RAO0,RAORDST,RADLOCS,RAODD,RAT,RALADTX
+5 DO CLOSE^RAUTL
+6 QUIT
CONT ;
+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 DISCONTINUED requests 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 RADT=0
FOR
SET RADT=$ORDER(^TMP($JOB,"RAODC",RAILOC,RADT))
if 'RADT!($DATA(RAEOS))
QUIT
SET RADFN=0
FOR
SET RADFN=$ORDER(^TMP($JOB,"RAODC",RAILOC,RADT,RADFN))
if 'RADFN!($DATA(RAEOS))
QUIT
DO MORE
+6 QUIT
MORE ;
+1 SET RAPR=0
FOR
SET RAPR=$ORDER(^TMP($JOB,"RAODC",RAILOC,RADT,RADFN,RAPR))
if 'RAPR!($DATA(RAEOS))
QUIT
Begin DoDot:1
+2 SET RADCBY=""
FOR
SET RADCBY=$ORDER(^TMP($JOB,"RAODC",RAILOC,RADT,RADFN,RAPR,RADCBY))
if RADCBY=""!($DATA(RAEOS))
QUIT
Begin DoDot:2
+3 SET RALADT=0
FOR
SET RALADT=$ORDER(^TMP($JOB,"RAODC",RAILOC,RADT,RADFN,RAPR,RADCBY,RALADT))
if 'RALADT!($DATA(RAEOS))
QUIT
Begin DoDot:3
+4 SET RAO=0
FOR
SET RAO=$ORDER(^TMP($JOB,"RAODC",RAILOC,RADT,RADFN,RAPR,RADCBY,RALADT,RAO))
if 'RAO!($DATA(RAEOS))
QUIT
Begin DoDot:4
+5 NEW RAREA
SET RAOREA=$GET(^TMP($JOB,"RAODC",RAILOC,RADT,RADFN,RAPR,RADCBY,RALADT,RAO))
+6 SET RACNT=RACNT+1
+7 KILL RALOCN,RARLOCN
+8 DO WRT
+9 QUIT
End DoDot:4
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
WRT ;
+1 SET Y=RADT
DO DD^%DT
SET RADD=Y
SET Y=$PIECE(RALADT,".")
DO DD^%DT
SET RALADTX=Y
+2 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(RADD,"@")
+3 WRITE ?67,RALADTX
+4 WRITE ?83,$SELECT(RADCBY="Unknown":RADCBY,1:$EXTRACT($$GET1^DIQ(200,RADCBY,.01),1,19))
+5 ;If there's no cancel reason, get cancel description (should only occur with provider DC through CPRS)
+6 WRITE ?104,$SELECT(RAOREA="":$EXTRACT($$GET1^DIQ(75.1,RAO,27),1,28),1:$EXTRACT($$GET1^DIQ(75.2,RAOREA,.01),1,28))
+7 SET RAOLOC=RAILOC
+8 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)
+9 QUIT
HDR ; header
+1 if $Y>0
WRITE @IOF
+2 WRITE !?(80-$LENGTH(RAHDR)/2),RAHDR
+3 ;W !?(80-$L(RAHDR)/2),RAHDRDSH
WRITE !?14,"Includes discontinued requests from ",RAOBEG("X")," to ",RAOEND("X")
+4 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,!
+5 WRITE !,"PATIENT NAME",?21,"SSN",?27,"PROCEDURE",?53,"DATE DESIRED",?67,"CANCELLED DATE"
+6 WRITE ?83,"CANCELLED BY"
+7 WRITE ?104,"CANCEL REASON",!,QQ,!!
+8 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAEOS=""
+9 QUIT
SETTMP ;results in TMP
+1 ;^TMP($J,"RAODC",I-LOC,DATE_DESIRED,DFN,PROCEDURE,DC'D_BY,DC'D_DATE,ORDER_IEN)=DC_REASON
+2 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAEOS=""
if $DATA(RAEOS)
QUIT
+3 SET ^TMP($JOB,"RAODC",$SELECT(RAILOC:RAILOC,1:"UNKNOWN"),$PIECE(RAO0,U,21),RADFN,$PIECE(RAO0,U,2),RADCBY,RALADT,RAOIEN)=RAOREA
Begin DoDot:1
+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:1
+6 QUIT
EOS ; end of screen
+1 SET X=$$EOS^RAUTL5
+2 if X=1
SET RAEOS=""
+3 QUIT
