RAORD7A ;HISC/CAH-Log of Scheduled Requests by Procedure ;11/5/01 15:19
;;5.0;Radiology/Nuclear Medicine;**15,31**;Mar 16, 1998
;;This routine looks at orders in file 75.1 with field 23 (Scheduled date) within the date range selected. User also selects order statuses to include.
; if sort by procedure:
;^TMP($J,"RA7",Img loc name,Img loc IEN, proc name, sched day, sched time, AMIS ien, PATIENT ien, Rad Order ien)
; if sort by date:
;^TMP($J,"RA7",Img loc name,Img loc IEN, sched day, sched time, proc name, AMIS ien, PATIENT ien, Rad Order ien)
;
START ;Entry point for Scheduled Request Log task
S RAZERO="0000"
U IO K ^TMP($J,"RA7") S RAPGE=0,$P(RALNE,"-",79)="",$P(RALNE1,"=",79)="",(RAX,RAHI)="",RABEGDT=RALDTE1-.0001,RAENDDT=+$P(RALDTE2,".",1)+.9999
S Y=RALDTE1 D D^RAUTL S RALDTE1=Y S Y=RALDTE2 D D^RAUTL S RALDTE2=Y,X="NOW",%DT="T" D ^%DT D D^RAUTL S RARUNDTE=Y
S RALOCNM="" F S RALOCNM=$O(RALOC(RALOCNM)) Q:RALOCNM="" S RA791IEN="" F S RA791IEN=$O(RALOC(RALOCNM,RA791IEN)) Q:RA791IEN="" S RALOC1(RA791IEN)=""
S RALOC("UNKNOWN",99999)="",RALOC1(99999)="" ;Setup if loc is missing
S RA791IEN="" F S RA791IEN=$O(RALOC1(RA791IEN)) Q:'RA791IEN!(RA791IEN=99999) S RALOC2(+$P(^RA(79.1,RA791IEN,0),U,6))=""
K RALOCNM,RA791IEN
F RAOSCH=RABEGDT:0 S RAOSCH=$O(^RAO(75.1,"AD",RAOSCH)) Q:'RAOSCH!(RAOSCH>RAENDDT) S RADFN=0 F S RADFN=$O(^RAO(75.1,"AD",RAOSCH,RADFN)) Q:'RADFN D
.S RAOIFN=0 F S RAOIFN=$O(^RAO(75.1,"AD",RAOSCH,RADFN,RAOIFN)) Q:'RAOIFN I $D(^RAO(75.1,RAOIFN,0)) S RAORD0=^(0) I $D(RALOC1(+$P(RAORD0,U,20)))!($P(RAORD0,U,20)="") D
..I $P(RAORD0,U,20)="",'$D(RALOC2(+$P(RAORD0,U,3))) Q ;UNK is dif imgtyp
..S RAPRI=+$P(RAORD0,"^",2) D S RAPRC=$S($P($G(^RAMIS(71,RAPRI,0)),U)]"":$E($P(^(0),U),1,21),1:"UNKNOWN")
...S RAI=0,RAI=$O(^RAMIS(71,RAPRI,2,RAI)) S:'RAI RAMIS=0 Q:'RAI S RAMIS=+$G(^(RAI,0))
..S RADAY=$P(RAOSCH,".",1),RATIME=$P(RAOSCH,".",2) S:RATIME="" RATIME=0
..S RAZTIME=RATIME S:$L(RAZTIME)<4 RAZTIME=RATIME_$E(RAZERO,1,(4-$L(RATIME))) S RAZTIME=+RAZTIME ;append trailing zero(s), then remove leading zero(s)
..S RALIEN=$S($P(RAORD0,"^",20):$P(RAORD0,"^",20),1:99999)
..S RALNM=$S(RALIEN=99999:"UNKNOWN",1:$P(^SC($P($G(^RA(79.1,+RALIEN,0)),U),0),U))
..S:$E(RASORT)="P" ^TMP($J,"RA7",RALNM,RALIEN,RAPRC,RADAY,RAZTIME,RAMIS,RADFN,RAOIFN)=RATIME
..S:$E(RASORT)="D" ^TMP($J,"RA7",RALNM,RALIEN,RADAY,RAZTIME,RAPRC,RAMIS,RADFN,RAOIFN)=RATIME
Q:$G(RAX)["^" I '$D(^TMP($J,"RA7")) W !!," No scheduled requests are logged for ",RALDTE1," through ",RALDTE2,"." G Q
S I="" F S I=$O(RALOC(I)) Q:I="" I '$D(^TMP($J,"RA7",I)) S ^TMP($J,"RA7",I)="NONE"
S RALNM="" F S RALNM=$O(^TMP($J,"RA7",RALNM)) Q:RALNM=""!(RAX["^") D NEG D:'$G(RANEG) GET K RANEG
G Q
GET S (RALIEN,RA5)="" F S RALIEN=$O(^TMP($J,"RA7",RALNM,RALIEN)) Q:'RALIEN!(RAX["^") I $D(RALOC1(RALIEN)) D HD F S RA5=$O(^TMP($J,"RA7",RALNM,RALIEN,RA5)) Q:(RA5="")!(RAX["^") W:(RAPGE)&($E(RASORT)="P") !,RALNE1 D
.S RA6="" F S RA6=$O(^TMP($J,"RA7",RALNM,RALIEN,RA5,RA6)) Q:RA6=""!(RAX["^") S RA7="" F S RA7=$O(^TMP($J,"RA7",RALNM,RALIEN,RA5,RA6,RA7)) Q:(RA7="")!(RAX["^") D
..S RAMIS="" F S RAMIS=$O(^TMP($J,"RA7",RALNM,RALIEN,RA5,RA6,RA7,RAMIS)) Q:RAMIS=""!(RAX["^") S RADFN=0 F S RADFN=$O(^TMP($J,"RA7",RALNM,RALIEN,RA5,RA6,RA7,RAMIS,RADFN)) Q:RADFN=""!(RAX["^") D
...S RAOIFN=0 F S RAOIFN=$O(^TMP($J,"RA7",RALNM,RALIEN,RA5,RA6,RA7,RAMIS,RADFN,RAOIFN)) Q:'RAOIFN!(RAX["^") S RATIME=^(RAOIFN),RAORD0=$G(^RAO(75.1,RAOIFN,0)) D GETDFN
Q
GETDFN Q:RAX["^" S RANME=$P($G(^DPT(RADFN,0)),"^"),RAOSCH=$S($E(RASORT)="P":RA6,1:RA5)_"."_RATIME,RAOSCH=+RAOSCH,X=$P(RAORD0,U,5),RASTAT=$S(X=3:"HOL",X=5:"PEN",X=8:"SCH",X=11:"UNR",1:"???")
I $D(RANOSHOW),RASTAT'="SCH" Q
S RALIEN=RAHI K RARLOC,RARLOCN,RARIPOP,RACIPOP,RAIPLOC,RAIPLOCN,RADONE
D IPOP^RAUTL13,WRT
Q
WRT S RAOURG=$P(RAORD0,"^",6)
D HD:($Y+4)>IOSL!('RAPGE)!(RALIEN'=RAHI) Q:RAX["^"
W !,$E(RANME,1,12),?14,$$SSN^RAUTL(RADFN,1),?21,$S($E(RASORT)="P":RA5,1:RA7),?44,$E(RALOCN,1,10),?56,$$FMTE^XLFDT(RAOSCH,2)
S C=$P(^DD(75.1,6,0),U,2),Y=RAOURG D Y^DIQ W ?71,$E(Y,1,7),!
I $L($G(RARLOCN)) W ?28,"Requesting Loc: ",RARLOCN
Q
NEG ;Negative reporting
Q:$G(RAX)["^" K RANEG
I RALNM="UNKNOWN" Q
I $G(^TMP($J,"RA7",RALNM))="NONE" S RANEG=1 D HD Q:$G(RAX)["^" W !!," No scheduled requests are logged for ",RALDTE1," through ",RALDTE2,"."
Q
Q K ^TMP($J,"RA7"),%DT,C,DIR,DTOUT,DUOUT,I,IOP,POP,RABEGDT,RACIPOP,RADAY,RADFN,RADLOCS,RADPT0,RAENDDT,RAHI,RAI,RAIN44,RAIPLOC,RAIPLOCN,RAIPOP
K RALDTE1,RALDTE2,RALIEN,RALNE,RALNE1,RALNM,RALOC,RALOC1,RALOC2,RALOCN,RALOCSAV,RAMES,RAMIS,RANEG,RANEWLOC,RANME,RANO,RANOSHOW,RAOIFN,RAORD0,RAORST,RAORSTS,RAOSCH,RAOURG,RAPGE,RAPOP,RAPRC,RAPRI,RAQUIT
K RARIPOP,RARLOC,RARLOCN,RARUNDTE,RASSN,RAST,RASTAT,RASTX,RATIME,RAUPDLOC,RAX,RAZERO,RAZTIME,VA200,VAIN,VAIP,X,X1,Y,ZTDESC,ZTRTN,ZTSAVE,RASORT,RA5,RA6,RA7
W ! D CLOSE^RAUTL
K DDH,DIRUT,DISYS,DFN
Q
;
HD D CRCHK Q:RAX["^" W:RAPGE!($E(IOST,1,2)="C-") @IOF W !,"Scheduled Request Log by Imaging Location, ",RASORT S RAPGE=RAPGE+1
W ?70,"Page: ",RAPGE,!?5,"Includes requests scheduled from ",RALDTE1," to ",RALDTE2
W !,"Run Date: ",RARUNDTE,?31,"Imaging Location: ",RALNM ;$S($D(^SC(+$P($G(^RA(79.1,+RALIEN,0)),"^"),0)):$P(^(0),"^"),1:"UNKNOWN")
W !?5,$S($D(RANOSHOW):"(no-show's only) ",1:"")
W !,"Patient",?14,"Pt ID",?22,"Procedure",?44,"Pt Loc",?56,"Sched. Date",?71,"Urgency",!,RALNE
S RAHI=RALIEN Q
;
CRCHK I RAPGE,$E(IOST)="C" W !!,$C(7),"Press RETURN to continue or '^' to stop " R X:DTIME S RAX=X
Q
RAORD7A ;HISC/CAH-Log of Scheduled Requests by Procedure ;11/5/01 15:19
+1 ;;5.0;Radiology/Nuclear Medicine;**15,31**;Mar 16, 1998
+2 ;;This routine looks at orders in file 75.1 with field 23 (Scheduled date) within the date range selected. User also selects order statuses to include.
+3 ; if sort by procedure:
+4 ;^TMP($J,"RA7",Img loc name,Img loc IEN, proc name, sched day, sched time, AMIS ien, PATIENT ien, Rad Order ien)
+5 ; if sort by date:
+6 ;^TMP($J,"RA7",Img loc name,Img loc IEN, sched day, sched time, proc name, AMIS ien, PATIENT ien, Rad Order ien)
+7 ;
START ;Entry point for Scheduled Request Log task
+1 SET RAZERO="0000"
+2 USE IO
KILL ^TMP($JOB,"RA7")
SET RAPGE=0
SET $PIECE(RALNE,"-",79)=""
SET $PIECE(RALNE1,"=",79)=""
SET (RAX,RAHI)=""
SET RABEGDT=RALDTE1-.0001
SET RAENDDT=+$PIECE(RALDTE2,".",1)+.9999
+3 SET Y=RALDTE1
DO D^RAUTL
SET RALDTE1=Y
SET Y=RALDTE2
DO D^RAUTL
SET RALDTE2=Y
SET X="NOW"
SET %DT="T"
DO ^%DT
DO D^RAUTL
SET RARUNDTE=Y
+4 SET RALOCNM=""
FOR
SET RALOCNM=$ORDER(RALOC(RALOCNM))
IF RALOCNM=""
QUIT
SET RA791IEN=""
FOR
SET RA791IEN=$ORDER(RALOC(RALOCNM,RA791IEN))
IF RA791IEN=""
QUIT
SET RALOC1(RA791IEN)=""
+5 ;Setup if loc is missing
SET RALOC("UNKNOWN",99999)=""
SET RALOC1(99999)=""
+6 SET RA791IEN=""
FOR
SET RA791IEN=$ORDER(RALOC1(RA791IEN))
IF 'RA791IEN!(RA791IEN=99999)
QUIT
SET RALOC2(+$PIECE(^RA(79.1,RA791IEN,0),U,6))=""
+7 KILL RALOCNM,RA791IEN
+8 FOR RAOSCH=RABEGDT:0
SET RAOSCH=$ORDER(^RAO(75.1,"AD",RAOSCH))
IF 'RAOSCH!(RAOSCH>RAENDDT)
QUIT
SET RADFN=0
FOR
SET RADFN=$ORDER(^RAO(75.1,"AD",RAOSCH,RADFN))
IF 'RADFN
QUIT
Begin DoDot:1
+9 SET RAOIFN=0
FOR
SET RAOIFN=$ORDER(^RAO(75.1,"AD",RAOSCH,RADFN,RAOIFN))
IF 'RAOIFN
QUIT
IF $DATA(^RAO(75.1,RAOIFN,0))
SET RAORD0=^(0)
IF $DATA(RALOC1(+$PIECE(RAORD0,U,20)))!($PIECE(RAORD0,U,20)="")
Begin DoDot:2
+10 ;UNK is dif imgtyp
IF $PIECE(RAORD0,U,20)=""
IF '$DATA(RALOC2(+$PIECE(RAORD0,U,3)))
QUIT
+11 SET RAPRI=+$PIECE(RAORD0,"^",2)
Begin DoDot:3
+12 SET RAI=0
SET RAI=$ORDER(^RAMIS(71,RAPRI,2,RAI))
IF 'RAI
SET RAMIS=0
IF 'RAI
QUIT
SET RAMIS=+$GET(^(RAI,0))
End DoDot:3
SET RAPRC=$SELECT($PIECE($GET(^RAMIS(71,RAPRI,0)),U)]"":$EXTRACT($PIECE(^(0),U),1,21),1:"UNKNOWN")
+13 SET RADAY=$PIECE(RAOSCH,".",1)
SET RATIME=$PIECE(RAOSCH,".",2)
IF RATIME=""
SET RATIME=0
+14 ;append trailing zero(s), then remove leading zero(s)
SET RAZTIME=RATIME
IF $LENGTH(RAZTIME)<4
SET RAZTIME=RATIME_$EXTRACT(RAZERO,1,(4-$LENGTH(RATIME)))
SET RAZTIME=+RAZTIME
+15 SET RALIEN=$SELECT($PIECE(RAORD0,"^",20):$PIECE(RAORD0,"^",20),1:99999)
+16 SET RALNM=$SELECT(RALIEN=99999:"UNKNOWN",1:$PIECE(^SC($PIECE($GET(^RA(79.1,+RALIEN,0)),U),0),U))
+17 IF $EXTRACT(RASORT)="P"
SET ^TMP($JOB,"RA7",RALNM,RALIEN,RAPRC,RADAY,RAZTIME,RAMIS,RADFN,RAOIFN)=RATIME
+18 IF $EXTRACT(RASORT)="D"
SET ^TMP($JOB,"RA7",RALNM,RALIEN,RADAY,RAZTIME,RAPRC,RAMIS,RADFN,RAOIFN)=RATIME
End DoDot:2
End DoDot:1
+19 IF $GET(RAX)["^"
QUIT
IF '$DATA(^TMP($JOB,"RA7"))
WRITE !!," No scheduled requests are logged for ",RALDTE1," through ",RALDTE2,"."
GOTO Q
+20 SET I=""
FOR
SET I=$ORDER(RALOC(I))
IF I=""
QUIT
IF '$DATA(^TMP($JOB,"RA7",I))
SET ^TMP($JOB,"RA7",I)="NONE"
+21 SET RALNM=""
FOR
SET RALNM=$ORDER(^TMP($JOB,"RA7",RALNM))
IF RALNM=""!(RAX["^")
QUIT
DO NEG
IF '$GET(RANEG)
DO GET
KILL RANEG
+22 GOTO Q
GET SET (RALIEN,RA5)=""
FOR
SET RALIEN=$ORDER(^TMP($JOB,"RA7",RALNM,RALIEN))
IF 'RALIEN!(RAX["^")
QUIT
IF $DATA(RALOC1(RALIEN))
DO HD
FOR
SET RA5=$ORDER(^TMP($JOB,"RA7",RALNM,RALIEN,RA5))
IF (RA5="")!(RAX["^")
QUIT
IF (RAPGE)&($EXTRACT(RASORT)="P")
WRITE !,RALNE1
Begin DoDot:1
+1 SET RA6=""
FOR
SET RA6=$ORDER(^TMP($JOB,"RA7",RALNM,RALIEN,RA5,RA6))
IF RA6=""!(RAX["^")
QUIT
SET RA7=""
FOR
SET RA7=$ORDER(^TMP($JOB,"RA7",RALNM,RALIEN,RA5,RA6,RA7))
IF (RA7="")!(RAX["^")
QUIT
Begin DoDot:2
+2 SET RAMIS=""
FOR
SET RAMIS=$ORDER(^TMP($JOB,"RA7",RALNM,RALIEN,RA5,RA6,RA7,RAMIS))
IF RAMIS=""!(RAX["^")
QUIT
SET RADFN=0
FOR
SET RADFN=$ORDER(^TMP($JOB,"RA7",RALNM,RALIEN,RA5,RA6,RA7,RAMIS,RADFN))
IF RADFN=""!(RAX["^")
QUIT
Begin DoDot:3
+3 SET RAOIFN=0
FOR
SET RAOIFN=$ORDER(^TMP($JOB,"RA7",RALNM,RALIEN,RA5,RA6,RA7,RAMIS,RADFN,RAOIFN))
IF 'RAOIFN!(RAX["^")
QUIT
SET RATIME=^(RAOIFN)
SET RAORD0=$GET(^RAO(75.1,RAOIFN,0))
DO GETDFN
End DoDot:3
End DoDot:2
End DoDot:1
+4 QUIT
GETDFN IF RAX["^"
QUIT
SET RANME=$PIECE($GET(^DPT(RADFN,0)),"^")
SET RAOSCH=$SELECT($EXTRACT(RASORT)="P":RA6,1:RA5)_"."_RATIME
SET RAOSCH=+RAOSCH
SET X=$PIECE(RAORD0,U,5)
SET RASTAT=$SELECT(X=3:"HOL",X=5:"PEN",X=8:"SCH",X=11:"UNR",1:"???")
+1 IF $DATA(RANOSHOW)
IF RASTAT'="SCH"
QUIT
+2 SET RALIEN=RAHI
KILL RARLOC,RARLOCN,RARIPOP,RACIPOP,RAIPLOC,RAIPLOCN,RADONE
+3 DO IPOP^RAUTL13
DO WRT
+4 QUIT
WRT SET RAOURG=$PIECE(RAORD0,"^",6)
+1 IF ($Y+4)>IOSL!('RAPGE)!(RALIEN'=RAHI)
DO HD
IF RAX["^"
QUIT
+2 WRITE !,$EXTRACT(RANME,1,12),?14,$$SSN^RAUTL(RADFN,1),?21,$SELECT($EXTRACT(RASORT)="P":RA5,1:RA7),?44,$EXTRACT(RALOCN,1,10),?56,$$FMTE^XLFDT(RAOSCH,2)
+3 SET C=$PIECE(^DD(75.1,6,0),U,2)
SET Y=RAOURG
DO Y^DIQ
WRITE ?71,$EXTRACT(Y,1,7),!
+4 IF $LENGTH($GET(RARLOCN))
WRITE ?28,"Requesting Loc: ",RARLOCN
+5 QUIT
NEG ;Negative reporting
+1 IF $GET(RAX)["^"
QUIT
KILL RANEG
+2 IF RALNM="UNKNOWN"
QUIT
+3 IF $GET(^TMP($JOB,"RA7",RALNM))="NONE"
SET RANEG=1
DO HD
IF $GET(RAX)["^"
QUIT
WRITE !!," No scheduled requests are logged for ",RALDTE1," through ",RALDTE2,"."
+4 QUIT
Q KILL ^TMP($JOB,"RA7"),%DT,C,DIR,DTOUT,DUOUT,I,IOP,POP,RABEGDT,RACIPOP,RADAY,RADFN,RADLOCS,RADPT0,RAENDDT,RAHI,RAI,RAIN44,RAIPLOC,RAIPLOCN,RAIPOP
+1 KILL RALDTE1,RALDTE2,RALIEN,RALNE,RALNE1,RALNM,RALOC,RALOC1,RALOC2,RALOCN,RALOCSAV,RAMES,RAMIS,RANEG,RANEWLOC,RANME,RANO,RANOSHOW,RAOIFN,RAORD0,RAORST,RAORSTS,RAOSCH,RAOURG,RAPGE,RAPOP,RAPRC,RAPRI,RAQUIT
+2 KILL RARIPOP,RARLOC,RARLOCN,RARUNDTE,RASSN,RAST,RASTAT,RASTX,RATIME,RAUPDLOC,RAX,RAZERO,RAZTIME,VA200,VAIN,VAIP,X,X1,Y,ZTDESC,ZTRTN,ZTSAVE,RASORT,RA5,RA6,RA7
+3 WRITE !
DO CLOSE^RAUTL
+4 KILL DDH,DIRUT,DISYS,DFN
+5 QUIT
+6 ;
HD DO CRCHK
IF RAX["^"
QUIT
IF RAPGE!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
WRITE !,"Scheduled Request Log by Imaging Location, ",RASORT
SET RAPGE=RAPGE+1
+1 WRITE ?70,"Page: ",RAPGE,!?5,"Includes requests scheduled from ",RALDTE1," to ",RALDTE2
+2 ;$S($D(^SC(+$P($G(^RA(79.1,+RALIEN,0)),"^"),0)):$P(^(0),"^"),1:"UNKNOWN")
WRITE !,"Run Date: ",RARUNDTE,?31,"Imaging Location: ",RALNM
+3 WRITE !?5,$SELECT($DATA(RANOSHOW):"(no-show's only) ",1:"")
+4 WRITE !,"Patient",?14,"Pt ID",?22,"Procedure",?44,"Pt Loc",?56,"Sched. Date",?71,"Urgency",!,RALNE
+5 SET RAHI=RALIEN
QUIT
+6 ;
CRCHK IF RAPGE
IF $EXTRACT(IOST)="C"
WRITE !!,$CHAR(7),"Press RETURN to continue or '^' to stop "
READ X:DTIME
SET RAX=X
+1 QUIT
