RASTAT ;HISC/GJC,FPT,SS AISC/TMP-Status Tracking Statistics Report ;8/4/97 07:59
;;5.0;Radiology/Nuclear Medicine;**8,20,24,26**;Mar 16, 1998
;last modified by SS OCT 10,2000 P26
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
I $O(RACCESS(DUZ,""))="" D ACCVIO^RAUTL19 Q
REMOVE F I="RASTAT","DIV-IMG","RA D-TYPE","RAST","RA REQ-LOC" K ^TMP($J,I)
D SELDIV^RAUTL7 I $O(^TMP($J,"RA D-TYPE",""))=""!$G(RAQUIT) W !!?5,"No divisions selected." G EXIT
N RA20RLOC S RA20RLOC=$$SELREQ^RASTRPT2() G:+RA20RLOC<0 EXIT ;P20 by SS select requesting locations
K DIC S DIC="^RA(79.2,",DIC(0)="AEMQZ",DIC("A")="Select IMAGING TYPE: "
S DIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),($D(RACCESS(DUZ,""IMG"",+Y)))"
W ! D DIVIACC^RAUTL7,SETUP^RAUTL7A,^DIC K DIC G:Y'>0 EXIT S RAIMAGE=+Y,RAIMAGE(0)=$P(Y(0,0),U)
S RA(1)=+$O(^RA(72,"AA",RAIMAGE(0),1,0)) I RA(1)'>0 W *7,!,"No 'STATUS #1' in the status file" G EXIT
S RA=+$O(^RA(72,"AA",RAIMAGE(0),9,0)) I RA'>0 W *7,!,"No 'COMPLETE' status in the status file" G EXIT
N RAPROCED S RAPROCED=$$SELPROC^RASTRPT2(RAIMAGE) G:RAPROCED<0 EXIT ;P20 by SS select requesting locations
BP1 D DATE^RAUTL I RAPOP D EXIT Q
N RADRPTYN S RADRPTYN=$$ASKDTRPT^RASTRPT2 G:RADRPTYN=-1 EXIT ;ask for detailed report P20A
F I="RA20RLOC","RAPROCED","BEGDATE","ENDDATE","RA","RA(1)","RACCESS*","RAIMAGE","RAIMAGE(0)","^TMP($J,""RA D-TYPE"",","^TMP($J,""RA REQ-LOC""," S ZTSAVE(I)="" ;mod P20 by SS
S ZTSAVE("^TMP($J,""RA REQ-LOC"",")=""
S ZTRTN="START^RASTAT" W ! D ZIS^RAUTL I RAPOP D EXIT Q
START ; start processing
U IO S RADT=(BEGDATE-1)_".9999",RADT1=ENDDATE_".9999",RAXIT=0
S:$D(ZTQUEUED) ZTREQ="@"
S I="" F S I=$O(^TMP($J,"RA D-TYPE",I)) Q:I="" S I(0)=0 F S I(0)=$O(^TMP($J,"RA D-TYPE",I,I(0))) Q:I(0)'>0 S ^TMP($J,"RASTAT",I(0))=0
K I
F I=0:0 S RADT=$O(^RADPT("AR",RADT)) Q:RADT>RADT1!(RADT'>0)!(RAXIT) F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADT,RADFN)) Q:RADFN'>0!(RAXIT) F RADTI=0:0 S RADTI=$O(^RADPT("AR",RADT,RADFN,RADTI)) Q:RADTI'>0!(RAXIT) D CASE
K RADFN,RADT,RADT1,RADTI,RACNI,RASTAT,RADV,RAST1,RAST9,RAFR,RATO,RAPRC
K RACOMP,RAUT,RAX1
D:'RAXIT ^RASTRPT
EXIT ; Kill & quit
F I="RASTAT","DIV-IMG","RA D-TYPE","RAST","RA REQ-LOC" K ^TMP($J,I)
K ^TMP($J,"RA REQ-LOC")
K %DT,BEGDATE,C,ENDDATE,DIROUT,DIRUT,DTOUT,DUOUT,RA,RAIMAGE,RAMES,X,Y
K ZTDESC,ZTSAVE,ZTRTN,ZTSK
K I,RAPOP,RAQUIT K:$D(RAPSTX) RACCESS,RAPSTX,POP
Q
CASE S X=$G(^RADPT(RADFN,"DT",RADTI,0)),X(2)=+$P(X,U,2),X(3)=+$P(X,U,3)
I X(2)'=RAIMAGE Q
S (RADIVN,RADV,Y)=X(3),C=$P(^DD(70.02,3,0),U,2) D Y^DIQ S RADIVN(0)=Y
I $D(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN))[0 Q
;Search for exams IF status=2 (COMPLETED) do STATUS
F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!(RAXIT) I $D(^(RACNI,0)) S X1=^(0) I $$ISOK()=1 D STATUS Q:RAXIT D:$D(RAST1)&($D(RAST9)) UPD2 ;modif P20 by SS
Q
ISOK() ;P20 by SS
Q:$P(X1,"^",3)'=RA 0
Q:+RA20RLOC<0 0
I +RA20RLOC=1 I $P(X1,"^",22)'=$P(RA20RLOC,"^",3) Q 0
I +RA20RLOC>1 I $$ISLOCOK^RASTRPT2($P(X1,"^",22),$J)=0 Q 0 ;if it isn't selected location
I (+RAPROCED'=0)&(+RAPROCED'=$P(X1,"^",2)) Q 0
N RA11A,RA11B
S RA11A=$P(X1,"^",22) ; P26
S RA11B=$S(RA11A="":"Unknown",1:$E($P(^SC(RA11A,0),"^",1),1,200))
S ^TMP($J,"RAST",RAIMAGE,RADV,RA11B,"COUNT")=$G(^TMP($J,"RAST",RAIMAGE,RADV,RA11B,"COUNT"),0)+1
Q 1
STATUS K RAUT,RAFR,RAST1,RAST9 S RAPRC=$P(X1,"^",2)
F RASTAT=0:0 S RASTAT=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"T",RASTAT)) Q:RASTAT'>0!(RAXIT) I $D(^(RASTAT,0)) S Y(0)=^(0) D:$D(RAFR) UPD1 Q:RAXIT I '$D(RAFR) S RAFR=+$P(Y(0),"^",2),X=+Y(0)
Q:'$D(RAUT) F RAFR=0:0 S RAFR=$O(RAUT(RAFR)) Q:RAFR'>0!(RAXIT) F RATO=0:0 S RATO=$O(RAUT(RAFR,RATO)) Q:RATO'>0!(RAXIT) S Y1=+RAUT(RAFR,RATO),Y=$P(RAUT(RAFR,RATO),"^",2) D STATS
Q
UPD1 ; Update ^TMP global for procedure data
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
S:RAFR=RA(1)&('$D(RAST1)) RAST1=X S RATO=+$P(Y(0),"^",2),X1=+Y(0),RAX1=X1 Q:RAFR=RATO!(RAFR=0)!(RATO=0) D ELAPSED^RAUTL1 S X=RAX1 I Y1<0!('$D(RAMTIME)) S RAFR=RATO Q
D SETTMP^RASTRPT2 ;Q:RACURREC=0 ;P20 by SS
S:RATO=RA RAST9=X I '$D(^TMP($J,"RASTAT",RADV,"PROC",RAFR,RATO,RAPRC)) S ^(RAPRC)=Y1_"^"_Y_"^"_Y1_"^"_Y_"^0^0"
I '$D(^TMP($J,"RASTAT",RADV,"SUM",RAFR,RATO)) S ^(RATO)=Y1_"^"_Y_"^"_Y1_"^"_Y_"^0^0"
I $D(RAUT(RAFR,RATO)) S X=Y1+(+RAUT(RAFR,RATO)),Y1=X D MINUTS^RAUTL1 S RAUT(RAFR,RATO)=Y1_"^"_Y,X=RAX1
S:'$D(RAUT(RAFR,RATO)) RAUT(RAFR,RATO)=Y1_"^"_Y
S RAFR=RATO Q
STATS ; Update the division and procedure ^TMP globals
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
S RASUM=^TMP($J,"RASTAT",RADV,"SUM",RAFR,RATO),RAPROC=^TMP($J,"RASTAT",RADV,"PROC",RAFR,RATO,RAPRC)
S ^TMP($J,"RASTAT",RADV)=^TMP($J,"RASTAT",RADV)+1 ;ft 9/30/94
;MAXIMUM AMOUNT OF ELAPSED TIME
S:Y1>+RAPROC RAPROC=Y1_"^"_Y_"^"_$P(RAPROC,"^",3,6)
S:Y1>+RASUM RASUM=Y1_"^"_Y_"^"_$P(RASUM,"^",3,6)
;MINIMUM AMOUNT OF ELAPSED TIME
S:Y1<+$P(RAPROC,"^",3) RAPROC=$P(RAPROC,"^",1,2)_"^"_Y1_"^"_Y_"^"_$P(RAPROC,"^",5,6)
S:Y1<+$P(RASUM,"^",3) RASUM=$P(RASUM,"^",1,2)_"^"_Y1_"^"_Y_"^"_$P(RASUM,"^",5,6)
;TOTAL # OF PROCEDURES AND TOTAL # OF ELAPSED MINUTES
S RAPROC=$P(RAPROC,"^",1,4)_"^"_($P(RAPROC,"^",5)+1)_"^"_(+$P(RAPROC,"^",6)+Y1)
S RASUM=$P(RASUM,"^",1,4)_"^"_(+$P(RASUM,"^",5)+1)_"^"_(+$P(RASUM,"^",6)+Y1)
S ^TMP($J,"RASTAT",RADV,"SUM",RAFR,RATO)=RASUM,^TMP($J,"RASTAT",RADV,"PROC",RAFR,RATO,RAPRC)=RAPROC K RAPROC,RASUM
Q
UPD2 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
K RACOMP S X=RAST1,X1=RAST9 D ELAPSED^RAUTL1 Q:Y1<0!('$D(RAMTIME))
I '$D(^TMP($J,"RASTAT",RADV,"COMPLETE")) S ^("COMPLETE")=Y1_"^"_Y_"^"_Y1_"^"_Y_"^1^"_Y1 Q
S RACOMP=^TMP($J,"RASTAT",RADV,"COMPLETE"),RACOMP=$P(RACOMP,"^",1,4)_"^"_($P(RACOMP,"^",5)+1)_"^"_($P(RACOMP,"^",6)+Y1)
S:Y1>+RACOMP RACOMP=Y1_"^"_Y_"^"_$P(RACOMP,"^",3,6)
S:Y1<+$P(RACOMP,"^",3) RACOMP=$P(RACOMP,"^",1,2)_"^"_Y1_"^"_Y_"^"_$P(RACOMP,"^",5,6)
S ^TMP($J,"RASTAT",RADV,"COMPLETE")=RACOMP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRASTAT 5979 printed Dec 13, 2024@02:39:51 Page 2
RASTAT ;HISC/GJC,FPT,SS AISC/TMP-Status Tracking Statistics Report ;8/4/97 07:59
+1 ;;5.0;Radiology/Nuclear Medicine;**8,20,24,26**;Mar 16, 1998
+2 ;last modified by SS OCT 10,2000 P26
+3 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
SET RAPSTX=""
+4 IF $ORDER(RACCESS(DUZ,""))=""
DO ACCVIO^RAUTL19
QUIT
REMOVE FOR I="RASTAT","DIV-IMG","RA D-TYPE","RAST","RA REQ-LOC"
KILL ^TMP($JOB,I)
+1 DO SELDIV^RAUTL7
IF $ORDER(^TMP($JOB,"RA D-TYPE",""))=""!$GET(RAQUIT)
WRITE !!?5,"No divisions selected."
GOTO EXIT
+2 ;P20 by SS select requesting locations
NEW RA20RLOC
SET RA20RLOC=$$SELREQ^RASTRPT2()
if +RA20RLOC<0
GOTO EXIT
+3 KILL DIC
SET DIC="^RA(79.2,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select IMAGING TYPE: "
+4 SET DIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),($D(RACCESS(DUZ,""IMG"",+Y)))"
+5 WRITE !
DO DIVIACC^RAUTL7
DO SETUP^RAUTL7A
DO ^DIC
KILL DIC
if Y'>0
GOTO EXIT
SET RAIMAGE=+Y
SET RAIMAGE(0)=$PIECE(Y(0,0),U)
+6 SET RA(1)=+$ORDER(^RA(72,"AA",RAIMAGE(0),1,0))
IF RA(1)'>0
WRITE *7,!,"No 'STATUS #1' in the status file"
GOTO EXIT
+7 SET RA=+$ORDER(^RA(72,"AA",RAIMAGE(0),9,0))
IF RA'>0
WRITE *7,!,"No 'COMPLETE' status in the status file"
GOTO EXIT
+8 ;P20 by SS select requesting locations
NEW RAPROCED
SET RAPROCED=$$SELPROC^RASTRPT2(RAIMAGE)
if RAPROCED<0
GOTO EXIT
BP1 DO DATE^RAUTL
IF RAPOP
DO EXIT
QUIT
+1 ;ask for detailed report P20A
NEW RADRPTYN
SET RADRPTYN=$$ASKDTRPT^RASTRPT2
if RADRPTYN=-1
GOTO EXIT
+2 ;mod P20 by SS
FOR I="RA20RLOC","RAPROCED","BEGDATE","ENDDATE","RA","RA(1)","RACCESS*","RAIMAGE","RAIMAGE(0)","^TMP($J,""RA D-TYPE"",","^TMP($J,""RA REQ-LOC"","
SET ZTSAVE(I)=""
+3 SET ZTSAVE("^TMP($J,""RA REQ-LOC"",")=""
+4 SET ZTRTN="START^RASTAT"
WRITE !
DO ZIS^RAUTL
IF RAPOP
DO EXIT
QUIT
START ; start processing
+1 USE IO
SET RADT=(BEGDATE-1)_".9999"
SET RADT1=ENDDATE_".9999"
SET RAXIT=0
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"RA D-TYPE",I))
if I=""
QUIT
SET I(0)=0
FOR
SET I(0)=$ORDER(^TMP($JOB,"RA D-TYPE",I,I(0)))
if I(0)'>0
QUIT
SET ^TMP($JOB,"RASTAT",I(0))=0
+4 KILL I
+5 FOR I=0:0
SET RADT=$ORDER(^RADPT("AR",RADT))
if RADT>RADT1!(RADT'>0)!(RAXIT)
QUIT
FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT("AR",RADT,RADFN))
if RADFN'>0!(RAXIT)
QUIT
FOR RADTI=0:0
SET RADTI=$ORDER(^RADPT("AR",RADT,RADFN,RADTI))
if RADTI'>0!(RAXIT)
QUIT
DO CASE
+6 KILL RADFN,RADT,RADT1,RADTI,RACNI,RASTAT,RADV,RAST1,RAST9,RAFR,RATO,RAPRC
+7 KILL RACOMP,RAUT,RAX1
+8 if 'RAXIT
DO ^RASTRPT
EXIT ; Kill & quit
+1 FOR I="RASTAT","DIV-IMG","RA D-TYPE","RAST","RA REQ-LOC"
KILL ^TMP($JOB,I)
+2 KILL ^TMP($JOB,"RA REQ-LOC")
+3 KILL %DT,BEGDATE,C,ENDDATE,DIROUT,DIRUT,DTOUT,DUOUT,RA,RAIMAGE,RAMES,X,Y
+4 KILL ZTDESC,ZTSAVE,ZTRTN,ZTSK
+5 KILL I,RAPOP,RAQUIT
if $DATA(RAPSTX)
KILL RACCESS,RAPSTX,POP
+6 QUIT
CASE SET X=$GET(^RADPT(RADFN,"DT",RADTI,0))
SET X(2)=+$PIECE(X,U,2)
SET X(3)=+$PIECE(X,U,3)
+1 IF X(2)'=RAIMAGE
QUIT
+2 SET (RADIVN,RADV,Y)=X(3)
SET C=$PIECE(^DD(70.02,3,0),U,2)
DO Y^DIQ
SET RADIVN(0)=Y
+3 IF $DATA(^TMP($JOB,"RA D-TYPE",RADIVN(0),RADIVN))[0
QUIT
+4 ;Search for exams IF status=2 (COMPLETED) do STATUS
+5 ;modif P20 by SS
FOR RACNI=0:0
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if RACNI'>0!(RAXIT)
QUIT
IF $DATA(^(RACNI,0))
SET X1=^(0)
IF $$ISOK()=1
DO STATUS
if RAXIT
QUIT
if $DATA(RAST1)&($DATA(RAST9))
DO UPD2
+6 QUIT
ISOK() ;P20 by SS
+1 if $PIECE(X1,"^",3)'=RA
QUIT 0
+2 if +RA20RLOC<0
QUIT 0
+3 IF +RA20RLOC=1
IF $PIECE(X1,"^",22)'=$PIECE(RA20RLOC,"^",3)
QUIT 0
+4 ;if it isn't selected location
IF +RA20RLOC>1
IF $$ISLOCOK^RASTRPT2($PIECE(X1,"^",22),$JOB)=0
QUIT 0
+5 IF (+RAPROCED'=0)&(+RAPROCED'=$PIECE(X1,"^",2))
QUIT 0
+6 NEW RA11A,RA11B
+7 ; P26
SET RA11A=$PIECE(X1,"^",22)
+8 SET RA11B=$SELECT(RA11A="":"Unknown",1:$EXTRACT($PIECE(^SC(RA11A,0),"^",1),1,200))
+9 SET ^TMP($JOB,"RAST",RAIMAGE,RADV,RA11B,"COUNT")=$GET(^TMP($JOB,"RAST",RAIMAGE,RADV,RA11B,"COUNT"),0)+1
+10 QUIT 1
STATUS KILL RAUT,RAFR,RAST1,RAST9
SET RAPRC=$PIECE(X1,"^",2)
+1 FOR RASTAT=0:0
SET RASTAT=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"T",RASTAT))
if RASTAT'>0!(RAXIT)
QUIT
IF $DATA(^(RASTAT,0))
SET Y(0)=^(0)
if $DATA(RAFR)
DO UPD1
if RAXIT
QUIT
IF '$DATA(RAFR)
SET RAFR=+$PIECE(Y(0),"^",2)
SET X=+Y(0)
+2 if '$DATA(RAUT)
QUIT
FOR RAFR=0:0
SET RAFR=$ORDER(RAUT(RAFR))
if RAFR'>0!(RAXIT)
QUIT
FOR RATO=0:0
SET RATO=$ORDER(RAUT(RAFR,RATO))
if RATO'>0!(RAXIT)
QUIT
SET Y1=+RAUT(RAFR,RATO)
SET Y=$PIECE(RAUT(RAFR,RATO),"^",2)
DO STATS
+3 QUIT
UPD1 ; Update ^TMP global for procedure data
+1 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+2 if RAFR=RA(1)&('$DATA(RAST1))
SET RAST1=X
SET RATO=+$PIECE(Y(0),"^",2)
SET X1=+Y(0)
SET RAX1=X1
if RAFR=RATO!(RAFR=0)!(RATO=0)
QUIT
DO ELAPSED^RAUTL1
SET X=RAX1
IF Y1<0!('$DATA(RAMTIME))
SET RAFR=RATO
QUIT
+3 ;Q:RACURREC=0 ;P20 by SS
DO SETTMP^RASTRPT2
+4 if RATO=RA
SET RAST9=X
IF '$DATA(^TMP($JOB,"RASTAT",RADV,"PROC",RAFR,RATO,RAPRC))
SET ^(RAPRC)=Y1_"^"_Y_"^"_Y1_"^"_Y_"^0^0"
+5 IF '$DATA(^TMP($JOB,"RASTAT",RADV,"SUM",RAFR,RATO))
SET ^(RATO)=Y1_"^"_Y_"^"_Y1_"^"_Y_"^0^0"
+6 IF $DATA(RAUT(RAFR,RATO))
SET X=Y1+(+RAUT(RAFR,RATO))
SET Y1=X
DO MINUTS^RAUTL1
SET RAUT(RAFR,RATO)=Y1_"^"_Y
SET X=RAX1
+7 if '$DATA(RAUT(RAFR,RATO))
SET RAUT(RAFR,RATO)=Y1_"^"_Y
+8 SET RAFR=RATO
QUIT
STATS ; Update the division and procedure ^TMP globals
+1 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+2 SET RASUM=^TMP($JOB,"RASTAT",RADV,"SUM",RAFR,RATO)
SET RAPROC=^TMP($JOB,"RASTAT",RADV,"PROC",RAFR,RATO,RAPRC)
+3 ;ft 9/30/94
SET ^TMP($JOB,"RASTAT",RADV)=^TMP($JOB,"RASTAT",RADV)+1
+4 ;MAXIMUM AMOUNT OF ELAPSED TIME
+5 if Y1>+RAPROC
SET RAPROC=Y1_"^"_Y_"^"_$PIECE(RAPROC,"^",3,6)
+6 if Y1>+RASUM
SET RASUM=Y1_"^"_Y_"^"_$PIECE(RASUM,"^",3,6)
+7 ;MINIMUM AMOUNT OF ELAPSED TIME
+8 if Y1<+$PIECE(RAPROC,"^",3)
SET RAPROC=$PIECE(RAPROC,"^",1,2)_"^"_Y1_"^"_Y_"^"_$PIECE(RAPROC,"^",5,6)
+9 if Y1<+$PIECE(RASUM,"^",3)
SET RASUM=$PIECE(RASUM,"^",1,2)_"^"_Y1_"^"_Y_"^"_$PIECE(RASUM,"^",5,6)
+10 ;TOTAL # OF PROCEDURES AND TOTAL # OF ELAPSED MINUTES
+11 SET RAPROC=$PIECE(RAPROC,"^",1,4)_"^"_($PIECE(RAPROC,"^",5)+1)_"^"_(+$PIECE(RAPROC,"^",6)+Y1)
+12 SET RASUM=$PIECE(RASUM,"^",1,4)_"^"_(+$PIECE(RASUM,"^",5)+1)_"^"_(+$PIECE(RASUM,"^",6)+Y1)
+13 SET ^TMP($JOB,"RASTAT",RADV,"SUM",RAFR,RATO)=RASUM
SET ^TMP($JOB,"RASTAT",RADV,"PROC",RAFR,RATO,RAPRC)=RAPROC
KILL RAPROC,RASUM
+14 QUIT
UPD2 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+1 KILL RACOMP
SET X=RAST1
SET X1=RAST9
DO ELAPSED^RAUTL1
if Y1<0!('$DATA(RAMTIME))
QUIT
+2 IF '$DATA(^TMP($JOB,"RASTAT",RADV,"COMPLETE"))
SET ^("COMPLETE")=Y1_"^"_Y_"^"_Y1_"^"_Y_"^1^"_Y1
QUIT
+3 SET RACOMP=^TMP($JOB,"RASTAT",RADV,"COMPLETE")
SET RACOMP=$PIECE(RACOMP,"^",1,4)_"^"_($PIECE(RACOMP,"^",5)+1)_"^"_($PIECE(RACOMP,"^",6)+Y1)
+4 if Y1>+RACOMP
SET RACOMP=Y1_"^"_Y_"^"_$PIECE(RACOMP,"^",3,6)
+5 if Y1<+$PIECE(RACOMP,"^",3)
SET RACOMP=$PIECE(RACOMP,"^",1,2)_"^"_Y1_"^"_Y_"^"_$PIECE(RACOMP,"^",5,6)
+6 SET ^TMP($JOB,"RASTAT",RADV,"COMPLETE")=RACOMP
+7 QUIT
