SDWLRSRS ;;IOFO BAY PINES/OG/WAIT LIST STAT REPORT - SORT ; Compiled September 22, 2005 10:32:25
;;5.3;scheduling;**415,469,446**;AUG 13 1993;Build 77
;
; Original routine SDWLRSR exceeded SACC maximum size of 10000.
; This new routine added to do the Sort portion of the report.
;
;
SORT(SDWLBD,SDWLED,SDWLINS,SDWL) ;SORT AND CALCULATE STAT REPORT ;SD*5.3*415
N SDWLAD,SDWLC,SDWLCC,SDWLD,SDWLDA,SDWLDFDT,SDWLDFN,SDWLDIS,SDWLDP,SDWLER,SDWLERR,SDWLFLD,SDWLFLG,SDWLINSN,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT
N SDWLOK1,SDWLOK3,SDWLPR,SDWLPRI,SDWLRDT,SDWLRE,SDWLSA,SDWLTR,SDWLTYNM,SDWLTYP,SDWLTYPN,SDWLX,SDWLX1,SDWLY1,SDWLCL ;SD*5.3*446
K ^TMP("SDWLRSR1",$J),^TMP("SDWLRSR2",$J) S (SDWLERR,SDWLPR,SDWLC,SDWLD,SDWLNC,SDWLSA,SDWLCC,SDWLNN,SDWLER,SDWLTR,SDWLCL,SDWLAD,SDWLRE,SDWLNR)=0 ;SD*5.3*446
S SDWLDA=0 F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA="" D
.I $D(DUOUT) Q
.S SDWLX=$G(^SDWL(409.3,SDWLDA,0)) Q:SDWLX="" S SDWLINSN=+$P(SDWLX,U,3) I 'SDWLINSN Q
.S SDWLPRI=$P(SDWLX,U,11) I SDWLPRI="" S SDWLPRI="U"
.S SDWLDFN=+SDWLX I 'SDWLDFN Q
.S SDWLTYP=$P(SDWLX,U,5),SDWLTYPN=$S(SDWLTYP=1:$P(SDWLX,U,6),SDWLTYP=2:$P(SDWLX,U,7),SDWLTYP=3:$P(SDWLX,U,8),SDWLTYP=4:$P(SDWLX,U,9),1:"")
.I SDWLTYPN="" Q
.S SDWLFLD=$S(SDWLTYP=1:5,SDWLTYP=2:6,SDWLTYP=3:7,SDWLTYP=4:8)
.S SDWLTYNM=$$EXTERNAL^DILFD(409.3,SDWLFLD,,SDWLTYPN) I SDWLTYNM="" S SDWLTYNM="UNKNOWN"
.I 'SDWLINSN Q
.I $D(SDWL("INS")) D
..;CHECK FOR SPECIFIC INSTITUTIONAL SORT
..S SDWLINS=$P(SDWLX,U,3),SDWLERR=0 I SDWLINS'="ALL",'$D(SDWL("INS",SDWLINS)) S SDWLERR=1 Q
..S SDWLPRI=$P(SDWLX,U,11) I SDWLPRI="" S SDWLPRI="N"
.I SDWLERR Q
.;CHECK DATE RANGE
.S SDWLOFDT=$P(SDWLX,U,2),SDWLOK1=1 I SDWLOFDT>SDWLBD!(SDWLOFDT=SDWLBD) D
..I SDWLOFDT<SDWLED!(SDWLOFDT=SDWLED) S SDWLOK1=0
.S SDWLX1=$P(^DIC(4,+$P(SDWLX,U,3),0),U,1),SDWLY1=SDWLTYP
.S:'$D(^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")) ^("AD")=0
.S:'$D(^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"AD")) ^("AD")=0
.I 'SDWLOK1 D S1
.S:'$D(^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR")) ^("NR")=0
.S:'$D(^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")) ^("NR")=0
.S SDWLDFDT=0,SDWLOK3=1 I $D(^SDWL(409.3,SDWLDA,"DIS")) S SDWLDFDT=$P(^("DIS"),U,1),SDWLOK3=0 I SDWLDFDT<SDWLBD!(SDWLDFDT>SDWLED) S SDWLOK3=1
.S:'$D(^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")) ^("CL")=0
.S:'$D(^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")) ^("CL")=0
.I 'SDWLOK3 D S3
.S SDWLTYP=$P(SDWLX,U,5)
.S:'$D(^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")) ^("PR")=0
.S:'$D(^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR")) ^("PR")=0
.S SDWLFLG=0
.I SDWLOFDT'>SDWLBD D
..I SDWLOFDT=SDWLBD Q
..I $P(SDWLX,U,17)["O" S SDWLFLG=1
..I $D(^SDWL(409.3,SDWLDA,"DIS")) D
...I 'SDWLFLG,($P($G(^SDWL(409.3,SDWLDA,"DIS")),U,1)>SDWLBD)!($P($G(^SDWL(409.3,SDWLDA,"DIS")),U,1)=SDWLBD) S SDWLFLG=1
..I SDWLFLG D
...S ^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")=^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")+1
...S ^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR")=^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR")+1
.I $P(SDWLX,U,14) D
..S SDWLRDT=$P(SDWLX,U,14)
..Q:SDWLRDT<SDWLBD Q:SDWLRDT>SDWLED D
...S:'$D(^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR")) ^("NR")=0
...S ^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR")=^("NR")+1
...S:'$D(^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")) ^("NR")=0
...S ^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")=^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")+1
.D S2
.I $$S^%ZTLOAD S DUOUT=""
Q
S1 ;ORIGINATING DATE MEETS CRITERIA
;
S ^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")=^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")+1
S ^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"AD")=^("AD")+1
Q
S2 ;DO NOT REMOVE DATE MEETS CRITERIA
;
N X1,X2,X3,X4
S X1=^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR"),X2=$G(^("AD")),X3=$G(^("CL")) S X4=X1+X2-X3
S ^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"RR")=($G(^("PR"))+($G(^("AD"))))-$G(^("CL"))
S ^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")=^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")+1
Q
S3 S SDWLDIS=^SDWL(409.3,SDWLDA,"DIS") D
.N X
.S ^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")=^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")+1
.S ^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")=^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")+1
.S SDWLDP=$P(SDWLDIS,U,3),X="SDWL"_SDWLDP,@X=@X+1 S:'$D(^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)) ^(X)=0
.S ^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)=^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)+1
.S:'$D(^TMP("SDWLRSR2",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,X)) ^(X)=0
.S ^TMP("SDWLRSR1",$J,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,X)=^(X)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLRSRS 5359 printed Dec 13, 2024@03:03:24 Page 2
SDWLRSRS ;;IOFO BAY PINES/OG/WAIT LIST STAT REPORT - SORT ; Compiled September 22, 2005 10:32:25
+1 ;;5.3;scheduling;**415,469,446**;AUG 13 1993;Build 77
+2 ;
+3 ; Original routine SDWLRSR exceeded SACC maximum size of 10000.
+4 ; This new routine added to do the Sort portion of the report.
+5 ;
+6 ;
SORT(SDWLBD,SDWLED,SDWLINS,SDWL) ;SORT AND CALCULATE STAT REPORT ;SD*5.3*415
+1 NEW SDWLAD,SDWLC,SDWLCC,SDWLD,SDWLDA,SDWLDFDT,SDWLDFN,SDWLDIS,SDWLDP,SDWLER,SDWLERR,SDWLFLD,SDWLFLG,SDWLINSN,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT
+2 ;SD*5.3*446
NEW SDWLOK1,SDWLOK3,SDWLPR,SDWLPRI,SDWLRDT,SDWLRE,SDWLSA,SDWLTR,SDWLTYNM,SDWLTYP,SDWLTYPN,SDWLX,SDWLX1,SDWLY1,SDWLCL
+3 ;SD*5.3*446
KILL ^TMP("SDWLRSR1",$JOB),^TMP("SDWLRSR2",$JOB)
SET (SDWLERR,SDWLPR,SDWLC,SDWLD,SDWLNC,SDWLSA,SDWLCC,SDWLNN,SDWLER,SDWLTR,SDWLCL,SDWLAD,SDWLRE,SDWLNR)=0
+4 SET SDWLDA=0
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,SDWLDA))
if SDWLDA=""
QUIT
Begin DoDot:1
+5 IF $DATA(DUOUT)
QUIT
+6 SET SDWLX=$GET(^SDWL(409.3,SDWLDA,0))
if SDWLX=""
QUIT
SET SDWLINSN=+$PIECE(SDWLX,U,3)
IF 'SDWLINSN
QUIT
+7 SET SDWLPRI=$PIECE(SDWLX,U,11)
IF SDWLPRI=""
SET SDWLPRI="U"
+8 SET SDWLDFN=+SDWLX
IF 'SDWLDFN
QUIT
+9 SET SDWLTYP=$PIECE(SDWLX,U,5)
SET SDWLTYPN=$SELECT(SDWLTYP=1:$PIECE(SDWLX,U,6),SDWLTYP=2:$PIECE(SDWLX,U,7),SDWLTYP=3:$PIECE(SDWLX,U,8),SDWLTYP=4:$PIECE(SDWLX,U,9),1:"")
+10 IF SDWLTYPN=""
QUIT
+11 SET SDWLFLD=$SELECT(SDWLTYP=1:5,SDWLTYP=2:6,SDWLTYP=3:7,SDWLTYP=4:8)
+12 SET SDWLTYNM=$$EXTERNAL^DILFD(409.3,SDWLFLD,,SDWLTYPN)
IF SDWLTYNM=""
SET SDWLTYNM="UNKNOWN"
+13 IF 'SDWLINSN
QUIT
+14 IF $DATA(SDWL("INS"))
Begin DoDot:2
+15 ;CHECK FOR SPECIFIC INSTITUTIONAL SORT
+16 SET SDWLINS=$PIECE(SDWLX,U,3)
SET SDWLERR=0
IF SDWLINS'="ALL"
IF '$DATA(SDWL("INS",SDWLINS))
SET SDWLERR=1
QUIT
+17 SET SDWLPRI=$PIECE(SDWLX,U,11)
IF SDWLPRI=""
SET SDWLPRI="N"
End DoDot:2
+18 IF SDWLERR
QUIT
+19 ;CHECK DATE RANGE
+20 SET SDWLOFDT=$PIECE(SDWLX,U,2)
SET SDWLOK1=1
IF SDWLOFDT>SDWLBD!(SDWLOFDT=SDWLBD)
Begin DoDot:2
+21 IF SDWLOFDT<SDWLED!(SDWLOFDT=SDWLED)
SET SDWLOK1=0
End DoDot:2
+22 SET SDWLX1=$PIECE(^DIC(4,+$PIECE(SDWLX,U,3),0),U,1)
SET SDWLY1=SDWLTYP
+23 if '$DATA(^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD"))
SET ^("AD")=0
+24 if '$DATA(^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"AD"))
SET ^("AD")=0
+25 IF 'SDWLOK1
DO S1
+26 if '$DATA(^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR"))
SET ^("NR")=0
+27 if '$DATA(^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR"))
SET ^("NR")=0
+28 SET SDWLDFDT=0
SET SDWLOK3=1
IF $DATA(^SDWL(409.3,SDWLDA,"DIS"))
SET SDWLDFDT=$PIECE(^("DIS"),U,1)
SET SDWLOK3=0
IF SDWLDFDT<SDWLBD!(SDWLDFDT>SDWLED)
SET SDWLOK3=1
+29 if '$DATA(^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL"))
SET ^("CL")=0
+30 if '$DATA(^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL"))
SET ^("CL")=0
+31 IF 'SDWLOK3
DO S3
+32 SET SDWLTYP=$PIECE(SDWLX,U,5)
+33 if '$DATA(^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR"))
SET ^("PR")=0
+34 if '$DATA(^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR"))
SET ^("PR")=0
+35 SET SDWLFLG=0
+36 IF SDWLOFDT'>SDWLBD
Begin DoDot:2
+37 IF SDWLOFDT=SDWLBD
QUIT
+38 IF $PIECE(SDWLX,U,17)["O"
SET SDWLFLG=1
+39 IF $DATA(^SDWL(409.3,SDWLDA,"DIS"))
Begin DoDot:3
+40 IF 'SDWLFLG
IF ($PIECE($GET(^SDWL(409.3,SDWLDA,"DIS")),U,1)>SDWLBD)!($PIECE($GET(^SDWL(409.3,SDWLDA,"DIS")),U,1)=SDWLBD)
SET SDWLFLG=1
End DoDot:3
+41 IF SDWLFLG
Begin DoDot:3
+42 SET ^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")=^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")+1
+43 SET ^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR")=^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR")+1
End DoDot:3
End DoDot:2
+44 IF $PIECE(SDWLX,U,14)
Begin DoDot:2
+45 SET SDWLRDT=$PIECE(SDWLX,U,14)
+46 if SDWLRDT<SDWLBD
QUIT
if SDWLRDT>SDWLED
QUIT
Begin DoDot:3
+47 if '$DATA(^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR"))
SET ^("NR")=0
+48 SET ^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR")=^("NR")+1
+49 if '$DATA(^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR"))
SET ^("NR")=0
+50 SET ^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")=^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")+1
End DoDot:3
End DoDot:2
+51 DO S2
+52 IF $$S^%ZTLOAD
SET DUOUT=""
End DoDot:1
+53 QUIT
S1 ;ORIGINATING DATE MEETS CRITERIA
+1 ;
+2 SET ^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")=^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")+1
+3 SET ^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"AD")=^("AD")+1
+4 QUIT
S2 ;DO NOT REMOVE DATE MEETS CRITERIA
+1 ;
+2 NEW X1,X2,X3,X4
+3 SET X1=^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")
SET X2=$GET(^("AD"))
SET X3=$GET(^("CL"))
SET X4=X1+X2-X3
+4 SET ^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"RR")=($GET(^("PR"))+($GET(^("AD"))))-$GET(^("CL"))
+5 SET ^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")=^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")+1
+6 QUIT
S3 SET SDWLDIS=^SDWL(409.3,SDWLDA,"DIS")
Begin DoDot:1
+1 NEW X
+2 SET ^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")=^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")+1
+3 SET ^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")=^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")+1
+4 SET SDWLDP=$PIECE(SDWLDIS,U,3)
SET X="SDWL"_SDWLDP
SET @X=@X+1
if '$DATA(^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,X))
SET ^(X)=0
+5 SET ^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)=^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)+1
+6 if '$DATA(^TMP("SDWLRSR2",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,X))
SET ^(X)=0
+7 SET ^TMP("SDWLRSR1",$JOB,SDWLX1,SDWLY1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,X)=^(X)+1
End DoDot:1
+8 QUIT
