- 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
- 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
