SDWLROIS ;;IOFO BAY PINES/RLC/WAIT LIST STAT REPORT - ENROLLEE - SORT ; 011 Jan 2005 9:15 AM
;;5.3;scheduling;**412,415,446,611**;AUG 13 1993;Build 9
;
; Original routine SDWLROI was exceeding 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 ;SD*5.3*611 FIXES CODE ERROR FOR PROCESSING THE DO NOT REMOVE DATE FIELD
K ^TMP("SDWLROI1",$J),^TMP("SDWLROI2",$J) S (SDWLERR,SDWLPR,SDWLC,SDWLD,SDWLNC,SDWLSA,SDWLCC,SDWLNN,SDWLER,SDWLTR,SDWLAD,SDWLRE,SDWLNR,SDWLCL)=0 ;SD*5.3*415,446
S SDWLDA=0 F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA="" D
.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) D:'SDWLTYP S1A S 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 X1=$P(^DIC(4,+$P(SDWLX,U,3),0),U,1),Y1=SDWLTYP
.S SDWLXEN=$P(SDWLX,U,20) I SDWLXEN="" S SDWLXEN="U"
.S:'$D(^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")) ^("AD")=0
.S:'$D(^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"AD")) ^("AD")=0
.I 'SDWLOK1 D S1
.S:'$D(^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR")) ^("NR")=0
.S:'$D(^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,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("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")) ^("CL")=0
.S:'$D(^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")) ^("CL")=0
.I 'SDWLOK3 D S3
.S SDWLTYP=$P(SDWLX,U,5)
.S:'$D(^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")) ^("PR")=0
.S:'$D(^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,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("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")=^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")+1
...S ^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR")=^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,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("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR")) ^("NR")=0
...S ^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR")=^("NR")+1
...S:'$D(^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")) ^("NR")=0
...S ^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")=^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")+1
.D S2
Q
S1A ; SET WAIL LIST TYPE IF NOT IN FILE - SD*5.3*412
S N=0
F I=6:1:9 S N=N+1 I $P(SDWLX,U,I) S SDWLTYP=N D SET Q
Q
;
SET ;SD*5.3*412
S DA=SDWLDA
S DIE="^SDWL(409.3,",DR="4////^S X=SDWLTYP" D ^DIE
K DA,DIE,DR,I,N
Q
;
S1 ;ORIGINATING DATE MEETS CRITERIA
;
S ^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")=^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")+1
S ^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"AD")=^("AD")+1
Q
S2 ;DO NOT REMOVE DATE MEETS CRITERIA
;
S X0=^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR"),X2=$G(^("AD")),X3=$G(^("CL")) S X4=X0+X2-X3
S ^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"RR")=($G(^("PR"))+($G(^("AD"))))-$G(^("CL"))
S ^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")=^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")+1
Q
S3 S SDWLDIS=^SDWL(409.3,SDWLDA,"DIS") D
.S ^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")=^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")+1
.S ^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")=^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")+1
.S SDWLDP=$P(SDWLDIS,U,3),X="SDWL"_SDWLDP,@X=@X+1 S:'$D(^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)) ^(X)=0
.S ^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)=^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)+1
.S:'$D(^TMP("SDWLROI2",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,X)) ^(X)=0
.S ^TMP("SDWLROI1",$J,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,X)=^(X)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLROIS 5403 printed Dec 13, 2024@03:03:11 Page 2
SDWLROIS ;;IOFO BAY PINES/RLC/WAIT LIST STAT REPORT - ENROLLEE - SORT ; 011 Jan 2005 9:15 AM
+1 ;;5.3;scheduling;**412,415,446,611**;AUG 13 1993;Build 9
+2 ;
+3 ; Original routine SDWLROI was exceeding 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 ;SD*5.3*611 FIXES CODE ERROR FOR PROCESSING THE DO NOT REMOVE DATE FIELD
+1 ;SD*5.3*415,446
KILL ^TMP("SDWLROI1",$JOB),^TMP("SDWLROI2",$JOB)
SET (SDWLERR,SDWLPR,SDWLC,SDWLD,SDWLNC,SDWLSA,SDWLCC,SDWLNN,SDWLER,SDWLTR,SDWLAD,SDWLRE,SDWLNR,SDWLCL)=0
+2 SET SDWLDA=0
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,SDWLDA))
if SDWLDA=""
QUIT
Begin DoDot:1
+3 SET SDWLX=$GET(^SDWL(409.3,SDWLDA,0))
if SDWLX=""
QUIT
SET SDWLINSN=+$PIECE(SDWLX,U,3)
IF 'SDWLINSN
QUIT
+4 SET SDWLPRI=$PIECE(SDWLX,U,11)
IF SDWLPRI=""
SET SDWLPRI="U"
+5 SET SDWLDFN=+SDWLX
IF 'SDWLDFN
QUIT
+6 SET SDWLTYP=$PIECE(SDWLX,U,5)
if 'SDWLTYP
DO S1A
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:"")
+7 IF SDWLTYPN=""
QUIT
+8 SET SDWLFLD=$SELECT(SDWLTYP=1:5,SDWLTYP=2:6,SDWLTYP=3:7,SDWLTYP=4:8)
+9 SET SDWLTYNM=$$EXTERNAL^DILFD(409.3,SDWLFLD,,SDWLTYPN)
IF SDWLTYNM=""
SET SDWLTYNM="UNKNOWN"
+10 IF 'SDWLINSN
QUIT
+11 IF $DATA(SDWL("INS"))
Begin DoDot:2
+12 ;CHECK FOR SPECIFIC INSTITUTIONAL SORT
+13 SET SDWLINS=$PIECE(SDWLX,U,3)
SET SDWLERR=0
IF SDWLINS'="ALL"
IF '$DATA(SDWL("INS",SDWLINS))
SET SDWLERR=1
QUIT
+14 SET SDWLPRI=$PIECE(SDWLX,U,11)
IF SDWLPRI=""
SET SDWLPRI="N"
End DoDot:2
+15 IF SDWLERR
QUIT
+16 ;CHECK DATE RANGE
+17 SET SDWLOFDT=$PIECE(SDWLX,U,2)
SET SDWLOK1=1
IF SDWLOFDT>SDWLBD!(SDWLOFDT=SDWLBD)
Begin DoDot:2
+18 IF SDWLOFDT<SDWLED!(SDWLOFDT=SDWLED)
SET SDWLOK1=0
End DoDot:2
+19 SET X1=$PIECE(^DIC(4,+$PIECE(SDWLX,U,3),0),U,1)
SET Y1=SDWLTYP
+20 SET SDWLXEN=$PIECE(SDWLX,U,20)
IF SDWLXEN=""
SET SDWLXEN="U"
+21 if '$DATA(^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD"))
SET ^("AD")=0
+22 if '$DATA(^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"AD"))
SET ^("AD")=0
+23 IF 'SDWLOK1
DO S1
+24 if '$DATA(^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR"))
SET ^("NR")=0
+25 if '$DATA(^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR"))
SET ^("NR")=0
+26 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
+27 if '$DATA(^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL"))
SET ^("CL")=0
+28 if '$DATA(^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL"))
SET ^("CL")=0
+29 IF 'SDWLOK3
DO S3
+30 SET SDWLTYP=$PIECE(SDWLX,U,5)
+31 if '$DATA(^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR"))
SET ^("PR")=0
+32 if '$DATA(^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR"))
SET ^("PR")=0
+33 SET SDWLFLG=0
+34 IF SDWLOFDT'>SDWLBD
Begin DoDot:2
+35 IF SDWLOFDT=SDWLBD
QUIT
+36 IF $PIECE(SDWLX,U,17)["O"
SET SDWLFLG=1
+37 IF $DATA(^SDWL(409.3,SDWLDA,"DIS"))
Begin DoDot:3
+38 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
+39 IF SDWLFLG
Begin DoDot:3
+40 SET ^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")=^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")+1
+41 SET ^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR")=^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"PR")+1
End DoDot:3
End DoDot:2
+42 IF $PIECE(SDWLX,U,14)
Begin DoDot:2
+43 SET SDWLRDT=$PIECE(SDWLX,U,14)
+44 if SDWLRDT<SDWLBD
QUIT
if SDWLRDT>SDWLED
QUIT
Begin DoDot:3
+45 if '$DATA(^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR"))
SET ^("NR")=0
+46 SET ^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"NR")=^("NR")+1
+47 if '$DATA(^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR"))
SET ^("NR")=0
+48 SET ^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")=^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")+1
End DoDot:3
End DoDot:2
+49 DO S2
End DoDot:1
+50 QUIT
S1A ; SET WAIL LIST TYPE IF NOT IN FILE - SD*5.3*412
+1 SET N=0
+2 FOR I=6:1:9
SET N=N+1
IF $PIECE(SDWLX,U,I)
SET SDWLTYP=N
DO SET
QUIT
+3 QUIT
+4 ;
SET ;SD*5.3*412
+1 SET DA=SDWLDA
+2 SET DIE="^SDWL(409.3,"
SET DR="4////^S X=SDWLTYP"
DO ^DIE
+3 KILL DA,DIE,DR,I,N
+4 QUIT
+5 ;
S1 ;ORIGINATING DATE MEETS CRITERIA
+1 ;
+2 SET ^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")=^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"AD")+1
+3 SET ^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"AD")=^("AD")+1
+4 QUIT
S2 ;DO NOT REMOVE DATE MEETS CRITERIA
+1 ;
+2 SET X0=^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"PR")
SET X2=$GET(^("AD"))
SET X3=$GET(^("CL"))
SET X4=X0+X2-X3
+3 SET ^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"RR")=($GET(^("PR"))+($GET(^("AD"))))-$GET(^("CL"))
+4 SET ^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")=^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"NR")+1
+5 QUIT
S3 SET SDWLDIS=^SDWL(409.3,SDWLDA,"DIS")
Begin DoDot:1
+1 SET ^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")=^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,"CL")+1
+2 SET ^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")=^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,"CL")+1
+3 SET SDWLDP=$PIECE(SDWLDIS,U,3)
SET X="SDWL"_SDWLDP
SET @X=@X+1
if '$DATA(^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,X))
SET ^(X)=0
+4 SET ^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)=^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,X)+1
+5 if '$DATA(^TMP("SDWLROI2",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,X))
SET ^(X)=0
+6 SET ^TMP("SDWLROI1",$JOB,X1,SDWLXEN,Y1,SDWLTYPN,SDWLTYNM,SDWLPRI,SDWLDFN,X)=^(X)+1
End DoDot:1
+7 QUIT
