RAORD8 ;HISC/CAH,FPT AISC/RMO-Ward/Clinic Scheduled Request Log ;9/9/94 10:05
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
K DIC S DIC("A")="Select Ward/Clinic: ",DIC="^SC(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q:Y<0 S RALIFN=+Y,RALNM=$P(Y,"^",2)
DATE S %DT("A")="Starting Imaging Exam Scheduled Date: ",%DT="EXA" W ! D ^%DT K %DT G Q^RAORD8:Y<0 S RALDTE1=Y
S %DT("A")="Ending Imaging Exam Scheduled Date: ",%DT="EXA" W ! D ^%DT K %DT G Q^RAORD8:Y<0 S RALDTE2=Y
I RALDTE2<RALDTE1 W !?5," ?? Starting date must be before ending date. Please try again.",! G DATE
I RALDTE2#1=0 S RALDTE2=RALDTE2+.2359
S ZTRTN="START^RAORD8",ZTSAVE("RALIFN")="",ZTSAVE("RALNM")="",ZTSAVE("RALDTE1")="",ZTSAVE("RALDTE2")="" W ! D ZIS^RAUTL G Q:RAPOP
START U IO K ^TMP($J,"RAORD8"),^TMP($J,"RAORD8-XFER") S RAPGE=0,RAX="",RABEGDT=RALDTE1-.0001,RAENDDT=RALDTE2
S RAL0=$S($D(^SC(RALIFN,0)):^(0),1:0)
S RADIV=+$$SITE^VASITE(DT,+$P(RAL0,"^",15)) S:RADIV<0 RADIV=0
S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))
I $D(^RA(79,+RADIV,.1)),$P(^(.1),"^",21)="y" S RALOCFLG=""
S RALNAME=$P(RAL0,U)
S Y=RALDTE1 D D^RAUTL S RALDTE1P=Y S Y=RALDTE2 D D^RAUTL S RALDTE2P=Y
S X="NOW",%DT="T" D ^%DT D D^RAUTL S RARUNDTE=Y
F RAOSCH=RABEGDT:0 S RAOSCH=$O(^RAO(75.1,"AD",RAOSCH)) Q:'RAOSCH!(RAOSCH>RAENDDT) F RADFN=0:0 S RADFN=$O(^RAO(75.1,"AD",RAOSCH,RADFN)) Q:'RADFN D CHKORD
I '$D(^TMP($J,"RAORD8")) W !!?5,"There are no scheduled requests ",!?5,"for ",RALNM," from ",RALDTE1P," to ",RALDTE2P,"." G Q
F RAOSCH=0:0 S RAOSCH=$O(^TMP($J,"RAORD8",RAOSCH)) Q:'RAOSCH!(RAX["^") F RADFN=0:0 S RADFN=$O(^TMP($J,"RAORD8",RAOSCH,RADFN)) Q:'RADFN!(RAX["^") D CHKUTL
Q K ^TMP($J,"RAORD8"),^TMP($J,"RAORD8-XFER")
K POP,RAPOP,RABEGDT,RADFN,RADIV,RADPT0,RAENDDT,RAILCNM,RALDTE1,RALDTE1P,RALDTE2,RALDTE2P,RAL0,RALIFN,RALOCFLG,RALNAME,RALNM,RALOCN,RANME,RAOIFN,RAORD0,RAOSCH,RAPGE,RAPRC,RARLOCN,RARUNDTE,RASSN,RATIME,RAX,RAXFERIN,RAXFEROU,X,Y
K RAMES,ZTDESC,ZTRTN,ZTSAVE
K DDH,DFN,VAERR
W ! D CLOSE^RAUTL
Q
;
;Even if pt xfer'd out of the req'g loc, include pt on report
CHKORD F RAOIFN=0:0 S RAOIFN=$O(^RAO(75.1,"AD",RAOSCH,RADFN,RAOIFN)) Q:'RAOIFN S RAORD0=$G(^RAO(75.1,RAOIFN,0)) I $P(RAORD0,"^",5)=8 D XFER I ($P(RAORD0,"^",22)=RALIFN)!(RAXFERIN) S ^TMP($J,"RAORD8",RAOSCH,RADFN,RAOIFN)=RAORD0
Q
XFER ;Find out if patient transferred in or out of the requesting loc
S (RAXFERIN,RAXFEROU)=0 D IPOP^RAUTL13
I RALOCN=RALNAME,$L($G(RARLOCN)),$G(RARLOCN)'=RALNAME S RAXFERIN=1
I RALOCN'=RALNAME,$L($G(RARLOCN)),$G(RARLOCN)=RALNAME S RAXFEROU=1
I RAXFERIN!(RAXFEROU) S ^TMP($J,"RAORD8-XFER",RAOSCH,RADFN,RAOIFN)=RALOCN_U_$G(RARLOCN)
Q
;
CHKUTL F RAOIFN=0:0 S RAOIFN=$O(^TMP($J,"RAORD8",RAOSCH,RADFN,RAOIFN)) Q:'RAOIFN!(RAX["^") S RAORD0=^(RAOIFN) I $D(^DPT(RADFN,0)) S RADPT0=^(0) D PRT
Q
;
PRT D HD:($Y+4)>IOSL!('RAPGE) Q:RAX["^" S RAPRC=$S($D(^RAMIS(71,+$P(RAORD0,"^",2),0)):$P(^(0),"^"),1:"UNKNOWN"),RANME=$P(RADPT0,"^")
S RATIME=$$FMTE^XLFDT(RAOSCH,2) I $D(RALOCFLG) S RAILCNM=$S('$D(^RA(79.1,+$P(RAORD0,"^",20),0)):"UNKNOWN",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"UNKNOWN")
W !,$E(RANME,1,19),?20,$$SSN^RAUTL(RADFN,1),?28,RATIME,?43,$E(RAPRC,1,21) W:$D(RAILCNM) ?66,$E(RAILCNM,1,15)
S X=$G(^TMP($J,"RAORD8-XFER",RAOSCH,RADFN,RAOIFN)) I $L(X) D
. S RALOCN=$P(X,U),RARLOCN=$P(X,U,2)
. I RARLOCN=RALNAME W !?10,"Patient transferred to: ",RALOCN,!
. I RALOCN=RALNAME W !?10,"Requesting Location: ",RARLOCN,!
Q
;
HD D CRCHK Q:RAX["^" W:$Y>0 @IOF W !?23,">>> RADIOLOGY/NUCLEAR MEDICINE <<<",!!,"Scheduled Request Log for ",RALNM S RAPGE=RAPGE+1 W ?70,"Page: ",RAPGE
W !?5,"Schedule dates from ",RALDTE1P," to ",RALDTE2P W !,"Run Date: ",RARUNDTE
W !!,"Patient",?20,"Pt ID",?28,"Sched. Date",?43,"Procedure" W:$D(RALOCFLG) ?66,"Imaging Loc" W !,"-------------------",?20,"-----",?28,"-------------",?43,"---------------------" W:$D(RALOCFLG) ?66,"--------------"
Q
;
CRCHK I RAPGE,$E(IOST)="C" W !!,*7,"Press RETURN to continue or '^' to stop " R X:DTIME S RAX=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORD8 4015 printed Dec 13, 2024@02:38:13 Page 2
RAORD8 ;HISC/CAH,FPT AISC/RMO-Ward/Clinic Scheduled Request Log ;9/9/94 10:05
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 KILL DIC
SET DIC("A")="Select Ward/Clinic: "
SET DIC="^SC("
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO Q
SET RALIFN=+Y
SET RALNM=$PIECE(Y,"^",2)
DATE SET %DT("A")="Starting Imaging Exam Scheduled Date: "
SET %DT="EXA"
WRITE !
DO ^%DT
KILL %DT
if Y<0
GOTO Q^RAORD8
SET RALDTE1=Y
+1 SET %DT("A")="Ending Imaging Exam Scheduled Date: "
SET %DT="EXA"
WRITE !
DO ^%DT
KILL %DT
if Y<0
GOTO Q^RAORD8
SET RALDTE2=Y
+2 IF RALDTE2<RALDTE1
WRITE !?5," ?? Starting date must be before ending date. Please try again.",!
GOTO DATE
+3 IF RALDTE2#1=0
SET RALDTE2=RALDTE2+.2359
+4 SET ZTRTN="START^RAORD8"
SET ZTSAVE("RALIFN")=""
SET ZTSAVE("RALNM")=""
SET ZTSAVE("RALDTE1")=""
SET ZTSAVE("RALDTE2")=""
WRITE !
DO ZIS^RAUTL
if RAPOP
GOTO Q
START USE IO
KILL ^TMP($JOB,"RAORD8"),^TMP($JOB,"RAORD8-XFER")
SET RAPGE=0
SET RAX=""
SET RABEGDT=RALDTE1-.0001
SET RAENDDT=RALDTE2
+1 SET RAL0=$SELECT($DATA(^SC(RALIFN,0)):^(0),1:0)
+2 SET RADIV=+$$SITE^VASITE(DT,+$PIECE(RAL0,"^",15))
if RADIV<0
SET RADIV=0
+3 SET RADIV=$SELECT($DATA(^RA(79,RADIV,0)):RADIV,1:$ORDER(^RA(79,0)))
+4 IF $DATA(^RA(79,+RADIV,.1))
IF $PIECE(^(.1),"^",21)="y"
SET RALOCFLG=""
+5 SET RALNAME=$PIECE(RAL0,U)
+6 SET Y=RALDTE1
DO D^RAUTL
SET RALDTE1P=Y
SET Y=RALDTE2
DO D^RAUTL
SET RALDTE2P=Y
+7 SET X="NOW"
SET %DT="T"
DO ^%DT
DO D^RAUTL
SET RARUNDTE=Y
+8 FOR RAOSCH=RABEGDT:0
SET RAOSCH=$ORDER(^RAO(75.1,"AD",RAOSCH))
if 'RAOSCH!(RAOSCH>RAENDDT)
QUIT
FOR RADFN=0:0
SET RADFN=$ORDER(^RAO(75.1,"AD",RAOSCH,RADFN))
if 'RADFN
QUIT
DO CHKORD
+9 IF '$DATA(^TMP($JOB,"RAORD8"))
WRITE !!?5,"There are no scheduled requests ",!?5,"for ",RALNM," from ",RALDTE1P," to ",RALDTE2P,"."
GOTO Q
+10 FOR RAOSCH=0:0
SET RAOSCH=$ORDER(^TMP($JOB,"RAORD8",RAOSCH))
if 'RAOSCH!(RAX["^")
QUIT
FOR RADFN=0:0
SET RADFN=$ORDER(^TMP($JOB,"RAORD8",RAOSCH,RADFN))
if 'RADFN!(RAX["^")
QUIT
DO CHKUTL
Q KILL ^TMP($JOB,"RAORD8"),^TMP($JOB,"RAORD8-XFER")
+1 KILL POP,RAPOP,RABEGDT,RADFN,RADIV,RADPT0,RAENDDT,RAILCNM,RALDTE1,RALDTE1P,RALDTE2,RALDTE2P,RAL0,RALIFN,RALOCFLG,RALNAME,RALNM,RALOCN,RANME,RAOIFN,RAORD0,RAOSCH,RAPGE,RAPRC,RARLOCN,RARUNDTE,RASSN,RATIME,RAX,RAXFERIN,RAXFEROU,X,Y
+2 KILL RAMES,ZTDESC,ZTRTN,ZTSAVE
+3 KILL DDH,DFN,VAERR
+4 WRITE !
DO CLOSE^RAUTL
+5 QUIT
+6 ;
+7 ;Even if pt xfer'd out of the req'g loc, include pt on report
CHKORD FOR RAOIFN=0:0
SET RAOIFN=$ORDER(^RAO(75.1,"AD",RAOSCH,RADFN,RAOIFN))
if 'RAOIFN
QUIT
SET RAORD0=$GET(^RAO(75.1,RAOIFN,0))
IF $PIECE(RAORD0,"^",5)=8
DO XFER
IF ($PIECE(RAORD0,"^",22)=RALIFN)!(RAXFERIN)
SET ^TMP($JOB,"RAORD8",RAOSCH,RADFN,RAOIFN)=RAORD0
+1 QUIT
XFER ;Find out if patient transferred in or out of the requesting loc
+1 SET (RAXFERIN,RAXFEROU)=0
DO IPOP^RAUTL13
+2 IF RALOCN=RALNAME
IF $LENGTH($GET(RARLOCN))
IF $GET(RARLOCN)'=RALNAME
SET RAXFERIN=1
+3 IF RALOCN'=RALNAME
IF $LENGTH($GET(RARLOCN))
IF $GET(RARLOCN)=RALNAME
SET RAXFEROU=1
+4 IF RAXFERIN!(RAXFEROU)
SET ^TMP($JOB,"RAORD8-XFER",RAOSCH,RADFN,RAOIFN)=RALOCN_U_$GET(RARLOCN)
+5 QUIT
+6 ;
CHKUTL FOR RAOIFN=0:0
SET RAOIFN=$ORDER(^TMP($JOB,"RAORD8",RAOSCH,RADFN,RAOIFN))
if 'RAOIFN!(RAX["^")
QUIT
SET RAORD0=^(RAOIFN)
IF $DATA(^DPT(RADFN,0))
SET RADPT0=^(0)
DO PRT
+1 QUIT
+2 ;
PRT if ($Y+4)>IOSL!('RAPGE)
DO HD
if RAX["^"
QUIT
SET RAPRC=$SELECT($DATA(^RAMIS(71,+$PIECE(RAORD0,"^",2),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
SET RANME=$PIECE(RADPT0,"^")
+1 SET RATIME=$$FMTE^XLFDT(RAOSCH,2)
IF $DATA(RALOCFLG)
SET RAILCNM=$SELECT('$DATA(^RA(79.1,+$PIECE(RAORD0,"^",20),0)):"UNKNOWN",$DATA(^SC(+^(0),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
+2 WRITE !,$EXTRACT(RANME,1,19),?20,$$SSN^RAUTL(RADFN,1),?28,RATIME,?43,$EXTRACT(RAPRC,1,21)
if $DATA(RAILCNM)
WRITE ?66,$EXTRACT(RAILCNM,1,15)
+3 SET X=$GET(^TMP($JOB,"RAORD8-XFER",RAOSCH,RADFN,RAOIFN))
IF $LENGTH(X)
Begin DoDot:1
+4 SET RALOCN=$PIECE(X,U)
SET RARLOCN=$PIECE(X,U,2)
+5 IF RARLOCN=RALNAME
WRITE !?10,"Patient transferred to: ",RALOCN,!
+6 IF RALOCN=RALNAME
WRITE !?10,"Requesting Location: ",RARLOCN,!
End DoDot:1
+7 QUIT
+8 ;
HD DO CRCHK
if RAX["^"
QUIT
if $Y>0
WRITE @IOF
WRITE !?23,">>> RADIOLOGY/NUCLEAR MEDICINE <<<",!!,"Scheduled Request Log for ",RALNM
SET RAPGE=RAPGE+1
WRITE ?70,"Page: ",RAPGE
+1 WRITE !?5,"Schedule dates from ",RALDTE1P," to ",RALDTE2P
WRITE !,"Run Date: ",RARUNDTE
+2 WRITE !!,"Patient",?20,"Pt ID",?28,"Sched. Date",?43,"Procedure"
if $DATA(RALOCFLG)
WRITE ?66,"Imaging Loc"
WRITE !,"-------------------",?20,"-----",?28,"-------------",?43,"---------------------"
if $DATA(RALOCFLG)
WRITE ?66,"--------------"
+3 QUIT
+4 ;
CRCHK IF RAPGE
IF $EXTRACT(IOST)="C"
WRITE !!,*7,"Press RETURN to continue or '^' to stop "
READ X:DTIME
SET RAX=X
+1 QUIT
