SDOQMPR ;LRVAMC/JRC ;ALB/SCK - Monitoring Report ; 7/17/96
;;5.3;SCHEDULING;**47**;AUG 13, 1993
; MODIFIED FOR NATIONAL RELEASE
Q
;
START U IO
S (ALDCTOTL,ALDCNT)=0,$P(ALDCDASH,"-",133)=""
S (END,PAGE)=0
S $P(DASH,"=",132)=""
S Y=DT D DD^%DT S ALDCNOW=Y
S Y=$P($G(^TMP("SDPM",$J,0)),U) D DD^%DT S ALDCSTDT=Y
S Y=$P($G(^TMP("SDPM",$J,0)),U,2) D DD^%DT S ALDCLAST=Y
;
I '$D(^TMP("SDPM",$J,0)) D Q
. D HEADER
. W !!?5,"Either no appointment monitoring data found, or there was no data available for these clinics"
;
K ^TMP($J)
D SET,LOOP,KILL
Q
SET ;
N PMDIV
;
S ALDCIEN=0 F S ALDCIEN=$O(^TMP("SDPM",$J,ALDCIEN)) Q:ALDCIEN'>0 D
.S ALDCDATE=0 F S ALDCDATE=$O(^TMP("SDPM",$J,ALDCIEN,ALDCDATE)) Q:ALDCDATE'>0 D
..Q:'$D(^SC(ALDCIEN,0))
..S ALDCNAME=$P(^SC(ALDCIEN,0),U)
..Q:$E(ALDCNAME,1,2)="ZZ" ;ZZ clinics
..S ALDCNCT=$P($G(^SC(ALDCIEN,0)),U,17) Q:ALDCNCT="Y" ;Non-Count Clincis
..S ALDCSTOP="UNKNOWN",ALDCSCD=$P($G(^SC(ALDCIEN,0)),U,7) S:ALDCSCD]"" ALDCSTOP=$P($G(^DIC(40.7,+ALDCSCD,0)),U)
.. Q:+$P($G(^DIC(40.7,+ALDCSCD,0)),U,2)=0
.. S ALDCODE=$P($G(^DIC(40.7,+ALDCSCD,0)),U,2)
.. S ALDCGET=$G(^TMP("SDPM",$J,ALDCIEN,ALDCDATE))
.. S PMDIV=$P(ALDCGET,U,7) S:PMDIV']"" PMDIV="ND" ;Get Division
.. S ALDCGET=$P(ALDCGET,U,1,6) ;Remove division
.. S ^TMP($J,PMDIV,ALDCSTOP,ALDCNAME,ALDCDATE,ALDCIEN)=ALDCGET_U_ALDCODE
Q
;
LOOP ;
N PMDIV
S (ALDCNT,ALDCTOTL,ALDC2T,ALDCSLTA,ALDCDAYT,ALDCDAYS,ALDCAVG,ALDCOPEN,ALDCOST,ALDC2,ALDC3T,ALDC4T,ALDC4A,ALDC3A,ALDC5,ALDC5T,ALDC5A,ALDC6,ALDC6T,ALDC6A,ALDCOB)=0
;
S PMDIV="" F S PMDIV=$O(^TMP($J,PMDIV)) Q:PMDIV="" D Q:END
. D HEADER
. S ALDCSTOP="" F S ALDCSTOP=$O(^TMP($J,PMDIV,ALDCSTOP)) Q:ALDCSTOP="" D Q:END
.. D HDR2
.. S ALDCNAME="",ALDCLINE=0 F S ALDCNAME=$O(^TMP($J,PMDIV,ALDCSTOP,ALDCNAME)) Q:ALDCNAME="" D Q:END
...S ALDCDATE=0 F S ALDCDATE=$O(^TMP($J,PMDIV,ALDCSTOP,ALDCNAME,ALDCDATE)) Q:ALDCDATE'>0 D Q:END
....S ALDCIEN=0 F S ALDCIEN=$O(^TMP($J,PMDIV,ALDCSTOP,ALDCNAME,ALDCDATE,ALDCIEN)) Q:ALDCIEN'>0 D Q:END
.....S ALDCGET=$G(^TMP($J,PMDIV,ALDCSTOP,ALDCNAME,ALDCDATE,ALDCIEN))
.....S ALDC1=$P(ALDCGET,U),ALDC2=$P(ALDCGET,U,2),ALDC3=$P(ALDCGET,U,3),ALDC4=$P(ALDCGET,U,4),ALDC5=$P(ALDCGET,U,5),ALDC6=$P(ALDCGET,U,6),ALDCD=" ("_$P(ALDCGET,U,7)_") ",ALDCPSTP=" "_ALDCSTOP_ALDCD
.....K ALDCSTAR S ALDCWK=66-($L(ALDCPSTP)*.5),$P(ALDCSTAR,"*",ALDCWK)="",ALDCPSTP=ALDCSTAR_ALDCPSTP_ALDCSTAR
.....S:ALDC2>0 ALDCOPEN=ALDCOPEN+1
.....S ALDC2T=ALDC2T+ALDC2 ;# slots on run date
.....S ALDC3T=ALDC3T+ALDC3 ;# appts on run date
.....S ALDC4T=ALDC4T+ALDC4 ;# slots from run date to first avlbe appt
.....S ALDC5T=ALDC5T+ALDC5 ;# appts from run date to first avlbe appt
.....S ALDC6T=ALDC6T+ALDC6 ;# of open days (days clinic held)
.....D ADD
.....S ALDCNT=ALDCNT+1
.... D:$Y+5>IOSL HEADER Q:END
....W:ALDCSTOP'=ALDCOST !!,ALDCPSTP
....S ALDCOST=ALDCSTOP
...S ALDCTOTL=ALDCTOTL+ALDCNT
...S ALDC4A=ALDC4T/ALDCNT ;average slots to first available appt
...S ALDC5A=ALDC5T/ALDCNT ;average appts to first available appt
...S ALDC6A=ALDC6T/ALDCNT ;average open days (days clinic is held)
...I (ALDC3T>0)&(ALDCOPEN>0) S ALDC3A=ALDC3T/ALDCOPEN ;avg appts
...I (ALDC2T>0)&(ALDCOPEN>0) S ALDCSLTA=ALDC2T/ALDCOPEN ;avg slots
...I (ALDC4A>0)&(ALDC5A>0) S ALDCOB=ALDC5A/ALDC4A ;overbooks
...S ALDCAVG=ALDCDAYT/ALDCNT
...I ALDCLINE=3 W ! S ALDCLINE=0
...W !,?2,$E(ALDCNAME,1,23),?30,$J(ALDCAVG,6,2),?42,$J(ALDCSLTA,6,2),?55,$J(ALDC3A,6,2),?70,$J(ALDC4A,6,2),?82,$J(ALDC5A,6,2),?95,$J(ALDC6A,6,2),?107,$J(ALDCOPEN,6),?120,$J(ALDCOB,6,2)
...S ALDCLINE=ALDCLINE+1
...S (ALDCNT,ALDCDAYS,ALDCDAYT,ALDC2T,ALDC3T,ALDC4T,ALDCOPEN,ALDCSLTA,ALDC3A,ALDC4A,ALDC5,ALDC5A,ALDC5T,ALDC6,ALDC6T,ALDC6A,ALDCOB)=0
Q
ADD ;Calculate number of days to next available appointment
S X2=ALDCDATE,X1=ALDC1 D ^%DTC S ALDCDAYS=X
S ALDCDAYT=ALDCDAYT+ALDCDAYS
Q
I PAGE,$E(IOST,1,2)="C-" W !,"Press RETURN to continue or '^' to exit: " R X:DTIME S END='$T!(X="^") Q:END
HDR1 W:$E(IOST,1,2)'="C-" @IOF
S PAGE=PAGE+1
W !?110,"Run Date: ",ALDCNOW
W !?3,"OUTPATIENT CLINIC WAITING TIME PROJECT from "_ALDCSTDT_" thru "_ALDCLAST,?114,"PAGE: ",PAGE,!
W !?32,"[****************************** AVERAGE ******************************]"
W !,?70,"SLOTS TO",?82,"APPTS TO",?95,"OPEN"
W !,?32,"WAIT",?55,"APPTS",?70,"FIRST",?82,"FIRST",?95,"DAYS TO",?120,"OVER"
W !,?32,"IN",?42,"SLOTS PER",?55,"PER OPEN",?70,"AVAIL",?82,"AVAIL",?95,"FIRST",?109,"OPEN",?120,"BOOK"
W !?5,"Clinic",?32,"DAYS",?42,"OPEN DAY",?55,"DAY",?70,"APPT",?82,"APPT",?95,"APPT",?109,"DAYS",?120,"RATE"
W !,DASH
W !!,"DIVSION: ",$S(+PMDIV>0:$P($G(^DG(40.8,PMDIV,0)),U),1:"None Specified")
Q
;
HDR2 W:ALDCSTOP=ALDCOST !!,ALDCPSTP
S ALDCLINE=0
Q
;
KILL K X,Y,ALDCDATE,ALDC1,ALDCSTDT,ALDCLAST,ALDCNT,ALDCDAYT,ALDC3T,ALDCSTOP,ALDCOST,ALDCPAGE,ALDC2,ALDC3,ALDC4,ALDC5,ALDC6,ALDC2T
K ALDCAVG,ALDCDASH,ALDCDAYS,X1,X2,ALDCGET,ALDCIEN,ALDCNAME,ALDCOPEN,ALDCSCD,ALDCSLTA,ALDCTOTL,ALDCNCT,ALDC3A,ALDC4A,ALDC5A
K ALDC6A,ALDC4T,ALDC5T,ALDC6T,ALDCOB
K ^TMP($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDOQMPR 5167 printed Dec 13, 2024@02:59:19 Page 2
SDOQMPR ;LRVAMC/JRC ;ALB/SCK - Monitoring Report ; 7/17/96
+1 ;;5.3;SCHEDULING;**47**;AUG 13, 1993
+2 ; MODIFIED FOR NATIONAL RELEASE
+3 QUIT
+4 ;
START USE IO
+1 SET (ALDCTOTL,ALDCNT)=0
SET $PIECE(ALDCDASH,"-",133)=""
+2 SET (END,PAGE)=0
+3 SET $PIECE(DASH,"=",132)=""
+4 SET Y=DT
DO DD^%DT
SET ALDCNOW=Y
+5 SET Y=$PIECE($GET(^TMP("SDPM",$JOB,0)),U)
DO DD^%DT
SET ALDCSTDT=Y
+6 SET Y=$PIECE($GET(^TMP("SDPM",$JOB,0)),U,2)
DO DD^%DT
SET ALDCLAST=Y
+7 ;
+8 IF '$DATA(^TMP("SDPM",$JOB,0))
Begin DoDot:1
+9 DO HEADER
+10 WRITE !!?5,"Either no appointment monitoring data found, or there was no data available for these clinics"
End DoDot:1
QUIT
+11 ;
+12 KILL ^TMP($JOB)
+13 DO SET
DO LOOP
DO KILL
+14 QUIT
SET ;
+1 NEW PMDIV
+2 ;
+3 SET ALDCIEN=0
FOR
SET ALDCIEN=$ORDER(^TMP("SDPM",$JOB,ALDCIEN))
if ALDCIEN'>0
QUIT
Begin DoDot:1
+4 SET ALDCDATE=0
FOR
SET ALDCDATE=$ORDER(^TMP("SDPM",$JOB,ALDCIEN,ALDCDATE))
if ALDCDATE'>0
QUIT
Begin DoDot:2
+5 if '$DATA(^SC(ALDCIEN,0))
QUIT
+6 SET ALDCNAME=$PIECE(^SC(ALDCIEN,0),U)
+7 ;ZZ clinics
if $EXTRACT(ALDCNAME,1,2)="ZZ"
QUIT
+8 ;Non-Count Clincis
SET ALDCNCT=$PIECE($GET(^SC(ALDCIEN,0)),U,17)
if ALDCNCT="Y"
QUIT
+9 SET ALDCSTOP="UNKNOWN"
SET ALDCSCD=$PIECE($GET(^SC(ALDCIEN,0)),U,7)
if ALDCSCD]""
SET ALDCSTOP=$PIECE($GET(^DIC(40.7,+ALDCSCD,0)),U)
+10 if +$PIECE($GET(^DIC(40.7,+ALDCSCD,0)),U,2)=0
QUIT
+11 SET ALDCODE=$PIECE($GET(^DIC(40.7,+ALDCSCD,0)),U,2)
+12 SET ALDCGET=$GET(^TMP("SDPM",$JOB,ALDCIEN,ALDCDATE))
+13 ;Get Division
SET PMDIV=$PIECE(ALDCGET,U,7)
if PMDIV']""
SET PMDIV="ND"
+14 ;Remove division
SET ALDCGET=$PIECE(ALDCGET,U,1,6)
+15 SET ^TMP($JOB,PMDIV,ALDCSTOP,ALDCNAME,ALDCDATE,ALDCIEN)=ALDCGET_U_ALDCODE
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
LOOP ;
+1 NEW PMDIV
+2 SET (ALDCNT,ALDCTOTL,ALDC2T,ALDCSLTA,ALDCDAYT,ALDCDAYS,ALDCAVG,ALDCOPEN,ALDCOST,ALDC2,ALDC3T,ALDC4T,ALDC4A,ALDC3A,ALDC5,ALDC5T,ALDC5A,ALDC6,ALDC6T,ALDC6A,ALDCOB)=0
+3 ;
+4 SET PMDIV=""
FOR
SET PMDIV=$ORDER(^TMP($JOB,PMDIV))
if PMDIV=""
QUIT
Begin DoDot:1
+5 DO HEADER
+6 SET ALDCSTOP=""
FOR
SET ALDCSTOP=$ORDER(^TMP($JOB,PMDIV,ALDCSTOP))
if ALDCSTOP=""
QUIT
Begin DoDot:2
+7 DO HDR2
+8 SET ALDCNAME=""
SET ALDCLINE=0
FOR
SET ALDCNAME=$ORDER(^TMP($JOB,PMDIV,ALDCSTOP,ALDCNAME))
if ALDCNAME=""
QUIT
Begin DoDot:3
+9 SET ALDCDATE=0
FOR
SET ALDCDATE=$ORDER(^TMP($JOB,PMDIV,ALDCSTOP,ALDCNAME,ALDCDATE))
if ALDCDATE'>0
QUIT
Begin DoDot:4
+10 SET ALDCIEN=0
FOR
SET ALDCIEN=$ORDER(^TMP($JOB,PMDIV,ALDCSTOP,ALDCNAME,ALDCDATE,ALDCIEN))
if ALDCIEN'>0
QUIT
Begin DoDot:5
+11 SET ALDCGET=$GET(^TMP($JOB,PMDIV,ALDCSTOP,ALDCNAME,ALDCDATE,ALDCIEN))
+12 SET ALDC1=$PIECE(ALDCGET,U)
SET ALDC2=$PIECE(ALDCGET,U,2)
SET ALDC3=$PIECE(ALDCGET,U,3)
SET ALDC4=$PIECE(ALDCGET,U,4)
SET ALDC5=$PIECE(ALDCGET,U,5)
SET ALDC6=$PIECE(ALDCGET,U,6)
SET ALDCD=" ("_$PIECE(ALDCGET,U,7)_") "
SET ALDCPSTP=" "_ALDCSTOP_ALDCD
+13 KILL ALDCSTAR
SET ALDCWK=66-($LENGTH(ALDCPSTP)*.5)
SET $PIECE(ALDCSTAR,"*",ALDCWK)=""
SET ALDCPSTP=ALDCSTAR_ALDCPSTP_ALDCSTAR
+14 if ALDC2>0
SET ALDCOPEN=ALDCOPEN+1
+15 ;# slots on run date
SET ALDC2T=ALDC2T+ALDC2
+16 ;# appts on run date
SET ALDC3T=ALDC3T+ALDC3
+17 ;# slots from run date to first avlbe appt
SET ALDC4T=ALDC4T+ALDC4
+18 ;# appts from run date to first avlbe appt
SET ALDC5T=ALDC5T+ALDC5
+19 ;# of open days (days clinic held)
SET ALDC6T=ALDC6T+ALDC6
+20 DO ADD
+21 SET ALDCNT=ALDCNT+1
End DoDot:5
if END
QUIT
+22 if $Y+5>IOSL
DO HEADER
if END
QUIT
+23 if ALDCSTOP'=ALDCOST
WRITE !!,ALDCPSTP
+24 SET ALDCOST=ALDCSTOP
End DoDot:4
if END
QUIT
+25 SET ALDCTOTL=ALDCTOTL+ALDCNT
+26 ;average slots to first available appt
SET ALDC4A=ALDC4T/ALDCNT
+27 ;average appts to first available appt
SET ALDC5A=ALDC5T/ALDCNT
+28 ;average open days (days clinic is held)
SET ALDC6A=ALDC6T/ALDCNT
+29 ;avg appts
IF (ALDC3T>0)&(ALDCOPEN>0)
SET ALDC3A=ALDC3T/ALDCOPEN
+30 ;avg slots
IF (ALDC2T>0)&(ALDCOPEN>0)
SET ALDCSLTA=ALDC2T/ALDCOPEN
+31 ;overbooks
IF (ALDC4A>0)&(ALDC5A>0)
SET ALDCOB=ALDC5A/ALDC4A
+32 SET ALDCAVG=ALDCDAYT/ALDCNT
+33 IF ALDCLINE=3
WRITE !
SET ALDCLINE=0
+34 WRITE !,?2,$EXTRACT(ALDCNAME,1,23),?30,$JUSTIFY(ALDCAVG,6,2),?42,$JUSTIFY(ALDCSLTA,6,2),?55,$JUSTIFY(ALDC3A,6,2),?70,$JUSTIFY(ALDC4A,6,2),?82,$JUSTIFY(ALDC5A,6,2),?95,$JUSTIFY(ALDC6A,6,2),?107,$JUSTIFY(ALDCOPEN,6),?120,$
JUSTIFY(ALDCOB,6,2)
+35 SET ALDCLINE=ALDCLINE+1
+36 SET (ALDCNT,ALDCDAYS,ALDCDAYT,ALDC2T,ALDC3T,ALDC4T,ALDCOPEN,ALDCSLTA,ALDC3A,ALDC4A,ALDC5,ALDC5A,ALDC5T,ALDC6,ALDC6T,ALDC6A,ALDCOB)=0
End DoDot:3
if END
QUIT
End DoDot:2
if END
QUIT
End DoDot:1
if END
QUIT
+37 QUIT
ADD ;Calculate number of days to next available appointment
+1 SET X2=ALDCDATE
SET X1=ALDC1
DO ^%DTC
SET ALDCDAYS=X
+2 SET ALDCDAYT=ALDCDAYT+ALDCDAYS
+3 QUIT
+1 IF PAGE
IF $EXTRACT(IOST,1,2)="C-"
WRITE !,"Press RETURN to continue or '^' to exit: "
READ X:DTIME
SET END='$TEST!(X="^")
if END
QUIT
HDR1 if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+1 SET PAGE=PAGE+1
+2 WRITE !?110,"Run Date: ",ALDCNOW
+3 WRITE !?3,"OUTPATIENT CLINIC WAITING TIME PROJECT from "_ALDCSTDT_" thru "_ALDCLAST,?114,"PAGE: ",PAGE,!
+4 WRITE !?32,"[****************************** AVERAGE ******************************]"
+5 WRITE !,?70,"SLOTS TO",?82,"APPTS TO",?95,"OPEN"
+6 WRITE !,?32,"WAIT",?55,"APPTS",?70,"FIRST",?82,"FIRST",?95,"DAYS TO",?120,"OVER"
+7 WRITE !,?32,"IN",?42,"SLOTS PER",?55,"PER OPEN",?70,"AVAIL",?82,"AVAIL",?95,"FIRST",?109,"OPEN",?120,"BOOK"
+8 WRITE !?5,"Clinic",?32,"DAYS",?42,"OPEN DAY",?55,"DAY",?70,"APPT",?82,"APPT",?95,"APPT",?109,"DAYS",?120,"RATE"
+9 WRITE !,DASH
+10 WRITE !!,"DIVSION: ",$SELECT(+PMDIV>0:$PIECE($GET(^DG(40.8,PMDIV,0)),U),1:"None Specified")
+11 QUIT
+12 ;
HDR2 if ALDCSTOP=ALDCOST
WRITE !!,ALDCPSTP
+1 SET ALDCLINE=0
+2 QUIT
+3 ;
KILL KILL X,Y,ALDCDATE,ALDC1,ALDCSTDT,ALDCLAST,ALDCNT,ALDCDAYT,ALDC3T,ALDCSTOP,ALDCOST,ALDCPAGE,ALDC2,ALDC3,ALDC4,ALDC5,ALDC6,ALDC2T
+1 KILL ALDCAVG,ALDCDASH,ALDCDAYS,X1,X2,ALDCGET,ALDCIEN,ALDCNAME,ALDCOPEN,ALDCSCD,ALDCSLTA,ALDCTOTL,ALDCNCT,ALDC3A,ALDC4A,ALDC5A
+2 KILL ALDC6A,ALDC4T,ALDC5T,ALDC6T,ALDCOB
+3 KILL ^TMP($JOB)
+4 QUIT
