SCRPW3.m

SCRPW3 ;RENO/KEITH,BWF - Clinic Utilization Statistical Summary (cont.) ;MAY 13, 2023

 ;;5.3;Scheduling;**139,144,184,194,540,562,845**;AUG 13, 1993;Build 8

START ;Print statistics

 F  S SDCLN=$O(^TMP("SCRPW",$J,SDIV,1,SDCLN)) Q:SDCLN=""!SDOUT  S SDCL=0 F  S SDCL=$O(^TMP("SCRPW",$J,SDIV,1,SDCLN,SDCL)) Q:'SDCL!SDOUT  D CLINE

 Q:SDOUT  D:$Y>(IOSL-12) FOOT^SCRPW2,HDR^SCRPW2 Q:SDOUT  W ! F SDI=1:1:8 W ?(22+(SDI*10)),"--------"

 W ?112,"---------  ---------",!,"*** CLINIC TOTALS ***" S SDCT=SDTAP_U_SDTOB_U_SDTSL_U_SDTNS_U_SDTVSL_U_SDTNSVS_U_SDTOS

 D F1 D FOOT^SCRPW2 Q:'$D(^TMP("SCRPW",$J,SDIV,2))

 D HDR^SCRPW2 Q:SDOUT  W !!,"*** PROVIDER SUMMARY (based on clinic default provider definition) ***"

 S SDPRN="" F  S SDPRN=$O(^TMP("SCRPW",$J,SDIV,2,SDPRN)) Q:SDPRN=""!SDOUT  S SDPR=0 F  S SDPR=$O(^TMP("SCRPW",$J,SDIV,2,SDPRN,SDPR)) Q:'SDPR!SDOUT  D PLINE

 Q:SDOUT  D FOOT^SCRPW2

 Q

 ;

STOP ;Check for stop task request

 S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0)

 Q

 ;

AC ;Evaluate all clinics

 S SDCL=0 F  S SDCL=$O(^SC(SDCL)) Q:'SDCL  S SDCL0=^SC(SDCL,0),SDIV=$P(SDCL0,U,15),SDAC=0 I $$DIV() D STOP Q:SDOUT  D A1 D:SDAC CNT,SET

 Q

 ;

A1 Q:$P(SDCL0,U,3)'="C"  S SDCLI=$G(^SC(SDCL,"I")) Q:(($P(SDCLI,U)>0)&($P(SDCLI,U)<SDBDAY)&($P(SDCLI,U,2)=""!($P(SDCLI,U,2)>SDEDAY)))  S SDAC=1

 Q

 ;

SC ;Evaluate selected clinics

 S SDCL=0 F  S SDCL=$O(SDCL(SDCL)) Q:'SDCL  S SDCL0=^SC(SDCL,0),SDIV=$P(SDCL0,U,15),SDAC=0 I $$DIV() D STOP Q:SDOUT  D A1 D:SDAC CNT,SET

 Q

 ;

RC ;Evaluate a range of clinics

 S SDCLN=$O(SDCL("")),SDECL=$O(SDCL(SDCLN)),SDCL=SDCL(SDCLN),SDCL0=^SC(SDCL,0),SDIV=$P(SDCL0,U,15),SDAC=0 I $$DIV() D STOP Q:SDOUT  D A1 D:SDAC CNT,SET

 F  S SDCLN=$O(^SC("B",SDCLN)) Q:(SDCLN=""!(SDCLN]SDECL))  S SDCL=0 F  S SDCL=$O(^SC("B",SDCLN,SDCL)) Q:'SDCL  S SDCL0=^SC(SDCL,0),SDIV=$P(SDCL0,U,15),SDAC=0 I $$DIV() D STOP Q:SDOUT  D A1 D:SDAC CNT,SET

 Q

 ;

RS ;Evaluate a range of stop codes

 S SDBCS=$O(SDCL("")),SDECS=$O(SDCL(SDBCS)),SDCL=0 S:'SDECS SDECS=SDBCS F  S SDCL=$O(^SC(SDCL)) Q:'SDCL  S SDCL0=^SC(SDCL,0),SDIV=$P(SDCL0,U,15),SDAC=0 I $$DIV() D STOP Q:SDOUT  D A1 D:SDAC RC1

 Q

 ;

RC1 S SDCSC=$P(SDCL0,U,7),SDCSC=$P($G(^DIC(40.7,+SDCSC,0)),U,2) Q:('SDCSC!(SDCSC<SDBCS!(SDCSC>SDECS)))  D CNT,SET

 Q

 ;

CG ;Evaluate by clinic group

 S SDCG=$O(SDCL(0)),SDCL=0 F  S SDCL=$O(^SC("ASCRPW",SDCG,SDCL)) Q:'SDCL  S SDCL0=^SC(SDCL,0),SDIV=$P(SDCL0,U,15),SDAC=0 I $$DIV() D STOP Q:SDOUT  D A1 D:SDAC CNT,SET

 Q

 ;

DIV() ;Check division

 S:'$L(SDIV) SDIV=$$PRIM^VASITE()

 Q:'SDDIV 1  Q $D(SDDIV(+SDIV))

 ;

CNT ;Evaluate a clinic

 S SDDAY=SDBDAY-1,(SDVSL,SDAP,SDF1,SDOB,SDSL,SDNS,SDNSVS,SDOS)=0,SDLAP=$P($G(^SC(SDCL,"SL")),U)

 D SPAT(SDCL,SDBDAY,SDMAX),CCPAT S SDOB=SDAP-SDSL S:SDOB<0 SDOB=0

 Q

 ;

CCPAT ;Count clinic patterns and patients

 F  S SDDAY=$O(^TMP(SDSUB,$J,SDCL,"ST",SDDAY)) Q:('SDDAY!(SDDAY>SDEDAY))  D CTPAT(SDDAY)

 S SDDAY=SDBDAY F  S SDDAY=$O(^SC(SDCL,"S",SDDAY)) Q:('SDDAY!(SDDAY>SDEDAY))  S SDI=0 F  S SDI=$O(^SC(SDCL,"S",SDDAY,1,SDI)) Q:'SDI  S SDCP0=$G(^SC(SDCL,"S",SDDAY,1,SDI,0)) D:$L(SDCP0) ACT

 Q

 ;

CTPAT(SDDAY) ;Count slots in availability pattern and master pattern

 ;Input: SDDAY=date to evaluate

 N SDPATT,SDPCT,SDFLAG,SDHLDPAT  ;SD*562 added last 2 variables

 S SDPATT=$E($G(^TMP(SDSUB,$J,SDCL,"ST",SDDAY,1)),6,999) Q:SDPATT'["["

 S SDFLAG=0 I SDPATT["X" S SDFLAG=1,SDHLDPAT=SDPATT  ;SD*562 check for partial canx

 S SDF1=1,SDOS=SDOS+$$PCT(SDPATT)

 S SDPATT=$E($G(^SC(SDCL,"OST",SDDAY,1)),6,999) I $L(SDPATT) S:SDPATT["X" SDFLAG=1,SDHLDPAT=SDPATT D:SDFLAG ADJUST S SDSL=SDSL+$$PCT(SDPATT) Q   ;SD*562 check for partially cancelled day

 N X,%H,%T,%Y,SDDW,SDMPDT

 S X=SDDAY D H^%DTC S SDDW="T"_%Y,SDMPDT=$O(^SC(SDCL,SDDW,SDDAY))

 I SDMPDT S SDPATT=$G(^SC(SDCL,SDDW,SDMPDT,1)) D:SDFLAG ADJUST S SDPCT=$$PCT(SDPATT) I SDPCT S SDSL=SDSL+SDPCT  ;SD*562 added API ADJUST to calculate clinic capacity for partially cancelled day

 Q

 ;

PCT(SDPATT) ;Pattern count

 ;Input: SDPATT=pattern to evaluate

 N X,I S X=0

 S SDPATT=$TR(SDPATT," |[]","")

 F I=1:1:$L(SDPATT) S X=X+$G(SD($E(SDPATT,I)))

 Q X

 ;

ADJUST ;SD*562 calculate clinic capacity for partially cancelled day

 ;SDHLDPAT equals updated pattern from "ST" node

 ;SDPATT equals Master Pattern for day

 S SDUP="",SDUP=SDHLDPAT,CT=0

 S SDUP=$TR(SDUP," |[]","")

 F I=1:1:$L(SDUP) I $E(SDUP,I)'="X" S CT=CT+1

 S SDPATT=$TR(SDPATT," |[]","")

 S SDPATT=$E(SDPATT,1,CT)

 K CT,SDUP,I

 Q

 ;

SET ;Set stats into ^TMP global

 S SDPR=0 I SDF1 S SDPR=$O(^SC("ADPR",SDCL,SDPR)),SDPR=$P($G(^SC(SDCL,"PR",+SDPR,0)),U) I SDPR S SDPRN=$P($G(^VA(200,SDPR,0)),U) S:'$L(SDPRN) SDPR=0

 D SET1(SDIV) D:SDMD SET1(0)

 Q

 ;

SET1(SDIV) S ^TMP("SCRPW",$J,SDIV,1,$P(SDCL0,U),SDCL)=$S('SDF1:"",1:SDAP_U_SDOB_U_SDSL_U_SDNS_U_SDVSL_U_SDNSVS_U_SDOS)

 Q:'SDPR  S SDPCT=$G(^TMP("SCRPW",$J,SDIV,2,SDPRN,SDPR))

 S ^TMP("SCRPW",$J,SDIV,2,SDPRN,SDPR)=($P(SDPCT,U)+SDAP)_U_($P(SDPCT,U,2)+SDOB)_U_($P(SDPCT,U,3)+SDSL)_U_($P(SDPCT,U,4)+SDNS)_U_($P(SDPCT,U,5)+SDVSL)_U_($P(SDPCT,U,6)+SDNSVS)_U_($P(SDPCT,U,7)+SDOS)

 Q

 ;

CLINE ;Print a clinic statistics line

 D:$Y>(IOSL-12) FOOT^SCRPW2,HDR^SCRPW2 Q:SDOUT  S SDCT=^TMP("SCRPW",$J,SDIV,1,SDCLN,SDCL) W !!,SDCLN I '$L(SDCT) W "  (No ava. found)" Q

 D F1 S SDTAP=SDTAP+SDAP,SDTOB=SDTOB+SDOB,SDTSL=SDTSL+SDSL,SDTNS=SDTNS+SDNS,SDTVSL=SDTVSL+SDVSL,SDTNSVS=SDTNSVS+SDNSVS,SDTOS=SDTOS+SDOS

 Q

 ;

F1 S SDAP=$P(SDCT,U),SDOB=$P(SDCT,U,2),SDSL=$P(SDCT,U,3),SDNS=$P(SDCT,U,4),SDVSL=$P(SDCT,U,5),SDNSVS=$P(SDCT,U,6),SDOS=$P(SDCT,U,7)

 W ?32,$J(SDAP,8),?42,$J(SDVSL,8),?52,$J(SDNS,8),?62,$J(SDNSVS,8),?72,$J(SDOB,8),?82,$J(SDOS,8),?92,$J((SDSL-SDAP-SDVSL),8)

 S SDCAP=SDSL W ?102,$J(SDCAP,8),?112,$J($S(SDCAP=0:0,1:(SDAP+SDVSL*100)/SDCAP),8,2),"%"

 W ?123,$J($S(SDCAP=0:0,1:((SDAP+SDVSL-SDNS-SDNSVS)*100)/SDCAP),8,2),"%"

 Q

 ;

PLINE ;Print a provider statistics line

 D:$Y>(IOSL-12) FOOT^SCRPW2,HDR^SCRPW2 Q:SDOUT  S SDCT=^TMP("SCRPW",$J,SDIV,2,SDPRN,SDPR) W !!,SDPRN,"  (",SDPR,")" D F1

 Q

 ;

ACT ;Count appointments, addl. variable appt. slots and no-shows

 Q:$P(SDCP0,U,9)="C"  ;Quit if cancelled

 S SDPLAP=$P(SDCP0,U,2),SDPESL=0 I SDLAP,SDPLAP>SDLAP S SDPESL=SDPLAP\SDLAP-1,SDVSL=SDVSL+SDPESL

 Q:'SDCP0  ;SD*5.3*540

 S SDAP=SDAP+1,SDF1=1

 S SDPAS=$G(^DPT($P(SDCP0,U),"S",SDDAY,0)),SDPAS=$P(SDPAS,U,2) Q:SDPAS=""  S:"NA"[SDPAS SDNS=SDNS+1,SDNSVS=SDNSVS+SDPESL

 Q

 ;

SPAT(SC,SDSTRTDT,MAX,SDS) ;Set patterns into ^TMP (modified clone of OVR^SDAUT1)

 ;Input: SC=clinic ifn

 ;Input: SDSTRTDT=start date for gathering patterns

 ;Input: MAX=number of days beyond start date to gather patterns

 ;Input: SDS=array namespace subscript value (optional)

 ;Output: array of clinic current availability patterns in

 ;        ^TMP(SDS,$J,clinic_ifn,"ST",date,1)

 ;

 S SDS=$G(SDS) S:'$L(SDS) SDS="SDTMP" K ^TMP(SDS,$J)

 N SI,SDIN,SDRE,SDSOH,ENDATE,X,X1,X2,SM,I,D,J,Y,SS,DAY

 S SDIN=$G(^SC(SC,"I")),SDRE=$P(SDIN,U,2),SDIN=$P(SDIN,U)

 S DAY="SU^MO^TU^WE^TH^FR^SA"

 S SI=$P($G(^SC(SC,"SL")),U,6),SI=$S(SI<3:4,1:SI)

 S SDSOH=$S('$D(^SC(SC,"SL")):0,$P(^SC(SC,"SL"),"^",8)']"":0,1:1)

 S X1=SDSTRTDT,X2=MAX,SDIN=$G(SDIN) D C^%DTC S ENDATE=X,X=SDSTRTDT

EN1 S:$O(^SC(SC,"T",0))>X X=$O(^SC(SC,"T",0))

 S Y=$$DOW^XLFDT(X,1),I=Y+32,SM=X,D=Y D WM

 K J F Y=0:1:6 I $D(^SC(+SC,"T"_Y)) S J(Y)=""

 I '$D(J) D  Q

 .S D=SDSTRTDT-1 F  S D=$O(^SC(SC,"ST",D)) Q:'D!(D>ENDATE)  D

 ..S X=$G(^SC(SC,"ST",D,1)) S:$L(X) ^TMP(SDS,$J,SC,"ST",D,1)=X Q

 .Q

X1 Q:X>ENDATE  S X1=X\100_28

 I '$$ACTIVE(X,SDIN,SDRE) S X1=X,X2=1 D C^%DTC G X1

W S X=X\1

 I $D(^SC(+SC,"ST",X,1)) S ^TMP(SDS,$J,SC,"ST",X,1)=^SC(+SC,"ST",X,1) G W1

 I '$D(^SC(SC,"ST",X,1)) S Y=D#7 G L:'$D(J(Y)),H:$D(^HOLIDAY(X))&('SDSOH) S SS=$O(^SC(SC,"T"_Y,X)) G L:SS<1,L:^SC(SC,"T"_Y,SS,1)="" D

 .S ^TMP(SDS,$J,SC,"ST",X\1,1)=$P(DAY,U,Y+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_^SC(SC,"T"_Y,SS,1) Q

W1 D WM:X>SM

L Q:X>ENDATE  S X=X+1,D=D+1 G W:X'>X1 S X2=X-X1 D C^%DTC G X1

 ;

H S ^TMP(SDS,$J,SC,"ST",X,1)="   "_$E(X,6,7)_"    "_$P(^(X,0),U,2) G W1

 ;

WM S SM=$S($E(X,4,5)[12:$E(X,1,3)+1_"01",1:$E(X,1,3)_$E(X,4,5)+1)_"00" Q

 ;

ACTIVE(X,SDIN,SDRE) ;Determine if the clinic is active on a given date

 ;Input: X=date to be examined

 ;Input: SDIN=clinic inactive date

 ;Input: SDRE=clinic reactivate date

 ;Output: '1'=active, '0'=inactive

 Q:'SDIN 1  Q:X<SDIN 1  Q:'SDRE 0  Q:X<SDRE 0  Q 1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SCRPW3   8331     printed  Mar 13, 2025@21:48:29                                                                                                                                                                                                      Page 2

SCRPW3    ;RENO/KEITH,BWF - Clinic Utilization Statistical Summary (cont.) ;MAY 13, 2023

 +1       ;;5.3;Scheduling;**139,144,184,194,540,562,845**;AUG 13, 1993;Build 8

START     ;Print statistics

 +1        FOR 

               SET SDCLN=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDCLN))

               if SDCLN=""!SDOUT

                   QUIT 

               SET SDCL=0

               FOR 

                   SET SDCL=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDCLN,SDCL))

                   if 'SDCL!SDOUT

                       QUIT 

                   DO CLINE

 +2        if SDOUT

               QUIT 

           if $Y>(IOSL-12)

               DO FOOT^SCRPW2

               DO HDR^SCRPW2

           if SDOUT

               QUIT 

           WRITE !

           FOR SDI=1:1:8

               WRITE ?(22+(SDI*10)),"--------"

 +3        WRITE ?112,"---------  ---------",!,"*** CLINIC TOTALS ***"

           SET SDCT=SDTAP_U_SDTOB_U_SDTSL_U_SDTNS_U_SDTVSL_U_SDTNSVS_U_SDTOS

 +4        DO F1

           DO FOOT^SCRPW2

           if '$DATA(^TMP("SCRPW",$JOB,SDIV,2))

               QUIT 

 +5        DO HDR^SCRPW2

           if SDOUT

               QUIT 

           WRITE !!,"*** PROVIDER SUMMARY (based on clinic default provider definition) ***"

 +6        SET SDPRN=""

           FOR 

               SET SDPRN=$ORDER(^TMP("SCRPW",$JOB,SDIV,2,SDPRN))

               if SDPRN=""!SDOUT

                   QUIT 

               SET SDPR=0

               FOR 

                   SET SDPR=$ORDER(^TMP("SCRPW",$JOB,SDIV,2,SDPRN,SDPR))

                   if 'SDPR!SDOUT

                       QUIT 

                   DO PLINE

 +7        if SDOUT

               QUIT 

           DO FOOT^SCRPW2

 +8        QUIT 

 +9       ;

STOP      ;Check for stop task request

 +1        if $GET(ZTQUEUED)

               SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)

 +2        QUIT 

 +3       ;

AC        ;Evaluate all clinics

 +1        SET SDCL=0

           FOR 

               SET SDCL=$ORDER(^SC(SDCL))

               if 'SDCL

                   QUIT 

               SET SDCL0=^SC(SDCL,0)

               SET SDIV=$PIECE(SDCL0,U,15)

               SET SDAC=0

               IF $$DIV()

                   DO STOP

                   if SDOUT

                       QUIT 

                   DO A1

                   if SDAC

                       DO CNT

                       DO SET

 +2        QUIT 

 +3       ;

A1         if $PIECE(SDCL0,U,3)'="C"

               QUIT 

           SET SDCLI=$GET(^SC(SDCL,"I"))

           if (($PIECE(SDCLI,U)>0)&($PIECE(SDCLI,U)<SDBDAY)&($PIECE(SDCLI,U,2)=""!($PIECE(SDCLI,U,2)>SDEDAY)))

               QUIT 

           SET SDAC=1

 +1        QUIT 

 +2       ;

SC        ;Evaluate selected clinics

 +1        SET SDCL=0

           FOR 

               SET SDCL=$ORDER(SDCL(SDCL))

               if 'SDCL

                   QUIT 

               SET SDCL0=^SC(SDCL,0)

               SET SDIV=$PIECE(SDCL0,U,15)

               SET SDAC=0

               IF $$DIV()

                   DO STOP

                   if SDOUT

                       QUIT 

                   DO A1

                   if SDAC

                       DO CNT

                       DO SET

 +2        QUIT 

 +3       ;

RC        ;Evaluate a range of clinics

 +1        SET SDCLN=$ORDER(SDCL(""))

           SET SDECL=$ORDER(SDCL(SDCLN))

           SET SDCL=SDCL(SDCLN)

           SET SDCL0=^SC(SDCL,0)

           SET SDIV=$PIECE(SDCL0,U,15)

           SET SDAC=0

           IF $$DIV()

               DO STOP

               if SDOUT

                   QUIT 

               DO A1

               if SDAC

                   DO CNT

                   DO SET

 +2        FOR 

               SET SDCLN=$ORDER(^SC("B",SDCLN))

               if (SDCLN=""!(SDCLN]SDECL))

                   QUIT 

               SET SDCL=0

               FOR 

                   SET SDCL=$ORDER(^SC("B",SDCLN,SDCL))

                   if 'SDCL

                       QUIT 

                   SET SDCL0=^SC(SDCL,0)

                   SET SDIV=$PIECE(SDCL0,U,15)

                   SET SDAC=0

                   IF $$DIV()

                       DO STOP

                       if SDOUT

                           QUIT 

                       DO A1

                       if SDAC

                           DO CNT

                           DO SET

 +3        QUIT 

 +4       ;

RS        ;Evaluate a range of stop codes

 +1        SET SDBCS=$ORDER(SDCL(""))

           SET SDECS=$ORDER(SDCL(SDBCS))

           SET SDCL=0

           if 'SDECS

               SET SDECS=SDBCS

           FOR 

               SET SDCL=$ORDER(^SC(SDCL))

               if 'SDCL

                   QUIT 

               SET SDCL0=^SC(SDCL,0)

               SET SDIV=$PIECE(SDCL0,U,15)

               SET SDAC=0

               IF $$DIV()

                   DO STOP

                   if SDOUT

                       QUIT 

                   DO A1

                   if SDAC

                       DO RC1

 +2        QUIT 

 +3       ;

RC1        SET SDCSC=$PIECE(SDCL0,U,7)

           SET SDCSC=$PIECE($GET(^DIC(40.7,+SDCSC,0)),U,2)

           if ('SDCSC!(SDCSC<SDBCS!(SDCSC>SDECS)))

               QUIT 

           DO CNT

           DO SET

 +1        QUIT 

 +2       ;

CG        ;Evaluate by clinic group

 +1        SET SDCG=$ORDER(SDCL(0))

           SET SDCL=0

           FOR 

               SET SDCL=$ORDER(^SC("ASCRPW",SDCG,SDCL))

               if 'SDCL

                   QUIT 

               SET SDCL0=^SC(SDCL,0)

               SET SDIV=$PIECE(SDCL0,U,15)

               SET SDAC=0

               IF $$DIV()

                   DO STOP

                   if SDOUT

                       QUIT 

                   DO A1

                   if SDAC

                       DO CNT

                       DO SET

 +2        QUIT 

 +3       ;

DIV()     ;Check division

 +1        if '$LENGTH(SDIV)

               SET SDIV=$$PRIM^VASITE()

 +2        if 'SDDIV

               QUIT 1

           QUIT $DATA(SDDIV(+SDIV))

 +3       ;

CNT       ;Evaluate a clinic

 +1        SET SDDAY=SDBDAY-1

           SET (SDVSL,SDAP,SDF1,SDOB,SDSL,SDNS,SDNSVS,SDOS)=0

           SET SDLAP=$PIECE($GET(^SC(SDCL,"SL")),U)

 +2        DO SPAT(SDCL,SDBDAY,SDMAX)

           DO CCPAT

           SET SDOB=SDAP-SDSL

           if SDOB<0

               SET SDOB=0

 +3        QUIT 

 +4       ;

CCPAT     ;Count clinic patterns and patients

 +1        FOR 

               SET SDDAY=$ORDER(^TMP(SDSUB,$JOB,SDCL,"ST",SDDAY))

               if ('SDDAY!(SDDAY>SDEDAY))

                   QUIT 

               DO CTPAT(SDDAY)

 +2        SET SDDAY=SDBDAY

           FOR 

               SET SDDAY=$ORDER(^SC(SDCL,"S",SDDAY))

               if ('SDDAY!(SDDAY>SDEDAY))

                   QUIT 

               SET SDI=0

               FOR 

                   SET SDI=$ORDER(^SC(SDCL,"S",SDDAY,1,SDI))

                   if 'SDI

                       QUIT 

                   SET SDCP0=$GET(^SC(SDCL,"S",SDDAY,1,SDI,0))

                   if $LENGTH(SDCP0)

                       DO ACT

 +3        QUIT 

 +4       ;

CTPAT(SDDAY) ;Count slots in availability pattern and master pattern

 +1       ;Input: SDDAY=date to evaluate

 +2       ;SD*562 added last 2 variables

           NEW SDPATT,SDPCT,SDFLAG,SDHLDPAT

 +3        SET SDPATT=$EXTRACT($GET(^TMP(SDSUB,$JOB,SDCL,"ST",SDDAY,1)),6,999)

           if SDPATT'["["

               QUIT 

 +4       ;SD*562 check for partial canx

           SET SDFLAG=0

           IF SDPATT["X"

               SET SDFLAG=1

               SET SDHLDPAT=SDPATT

 +5        SET SDF1=1

           SET SDOS=SDOS+$$PCT(SDPATT)

 +6       ;SD*562 check for partially cancelled day

           SET SDPATT=$EXTRACT($GET(^SC(SDCL,"OST",SDDAY,1)),6,999)

           IF $LENGTH(SDPATT)

               if SDPATT["X"

                   SET SDFLAG=1

                   SET SDHLDPAT=SDPATT

               if SDFLAG

                   DO ADJUST

               SET SDSL=SDSL+$$PCT(SDPATT)

               QUIT 

 +7        NEW X,%H,%T,%Y,SDDW,SDMPDT

 +8        SET X=SDDAY

           DO H^%DTC

           SET SDDW="T"_%Y

           SET SDMPDT=$ORDER(^SC(SDCL,SDDW,SDDAY))

 +9       ;SD*562 added API ADJUST to calculate clinic capacity for partially cancelled day

           IF SDMPDT

               SET SDPATT=$GET(^SC(SDCL,SDDW,SDMPDT,1))

               if SDFLAG

                   DO ADJUST

               SET SDPCT=$$PCT(SDPATT)

               IF SDPCT

                   SET SDSL=SDSL+SDPCT

 +10       QUIT 

 +11      ;

PCT(SDPATT) ;Pattern count

 +1       ;Input: SDPATT=pattern to evaluate

 +2        NEW X,I

           SET X=0

 +3        SET SDPATT=$TRANSLATE(SDPATT," |[]","")

 +4        FOR I=1:1:$LENGTH(SDPATT)

               SET X=X+$GET(SD($EXTRACT(SDPATT,I)))

 +5        QUIT X

 +6       ;

ADJUST    ;SD*562 calculate clinic capacity for partially cancelled day

 +1       ;SDHLDPAT equals updated pattern from "ST" node

 +2       ;SDPATT equals Master Pattern for day

 +3        SET SDUP=""

           SET SDUP=SDHLDPAT

           SET CT=0

 +4        SET SDUP=$TRANSLATE(SDUP," |[]","")

 +5        FOR I=1:1:$LENGTH(SDUP)

               IF $EXTRACT(SDUP,I)'="X"

                   SET CT=CT+1

 +6        SET SDPATT=$TRANSLATE(SDPATT," |[]","")

 +7        SET SDPATT=$EXTRACT(SDPATT,1,CT)

 +8        KILL CT,SDUP,I

 +9        QUIT 

 +10      ;

SET       ;Set stats into ^TMP global

 +1        SET SDPR=0

           IF SDF1

               SET SDPR=$ORDER(^SC("ADPR",SDCL,SDPR))

               SET SDPR=$PIECE($GET(^SC(SDCL,"PR",+SDPR,0)),U)

               IF SDPR

                   SET SDPRN=$PIECE($GET(^VA(200,SDPR,0)),U)

                   if '$LENGTH(SDPRN)

                       SET SDPR=0

 +2        DO SET1(SDIV)

           if SDMD

               DO SET1(0)

 +3        QUIT 

 +4       ;

SET1(SDIV)  SET ^TMP("SCRPW",$JOB,SDIV,1,$PIECE(SDCL0,U),SDCL)=$SELECT('SDF1:"",1:SDAP_U_SDOB_U_SDSL_U_SDNS_U_SDVSL_U_SDNSVS_U_SDOS)

 +1        if 'SDPR

               QUIT 

           SET SDPCT=$GET(^TMP("SCRPW",$JOB,SDIV,2,SDPRN,SDPR))

 +2        SET ^TMP("SCRPW",$JOB,SDIV,2,SDPRN,SDPR)=($PIECE(SDPCT,U)+SDAP)_U_($PIECE(SDPCT,U,2)+SDOB)_U_($PIECE(SDPCT,U,3)+SDSL)_U_($PIECE(SDPCT,U,4)+SDNS)_U_($PIECE(SDPCT,U,5)+SDVSL)_U_($PIECE(SDPCT,U,6)+SDNSVS)_U_($PIECE(SDPCT,U,7)+SDOS)

 +3        QUIT 

 +4       ;

CLINE     ;Print a clinic statistics line

 +1        if $Y>(IOSL-12)

               DO FOOT^SCRPW2

               DO HDR^SCRPW2

           if SDOUT

               QUIT 

           SET SDCT=^TMP("SCRPW",$JOB,SDIV,1,SDCLN,SDCL)

           WRITE !!,SDCLN

           IF '$LENGTH(SDCT)

               WRITE "  (No ava. found)"

               QUIT 

 +2        DO F1

           SET SDTAP=SDTAP+SDAP

           SET SDTOB=SDTOB+SDOB

           SET SDTSL=SDTSL+SDSL

           SET SDTNS=SDTNS+SDNS

           SET SDTVSL=SDTVSL+SDVSL

           SET SDTNSVS=SDTNSVS+SDNSVS

           SET SDTOS=SDTOS+SDOS

 +3        QUIT 

 +4       ;

F1         SET SDAP=$PIECE(SDCT,U)

           SET SDOB=$PIECE(SDCT,U,2)

           SET SDSL=$PIECE(SDCT,U,3)

           SET SDNS=$PIECE(SDCT,U,4)

           SET SDVSL=$PIECE(SDCT,U,5)

           SET SDNSVS=$PIECE(SDCT,U,6)

           SET SDOS=$PIECE(SDCT,U,7)

 +1        WRITE ?32,$JUSTIFY(SDAP,8),?42,$JUSTIFY(SDVSL,8),?52,$JUSTIFY(SDNS,8),?62,$JUSTIFY(SDNSVS,8),?72,$JUSTIFY(SDOB,8),?82,$JUSTIFY(SDOS,8),?92,$JUSTIFY((SDSL-SDAP-SDVSL),8)

 +2        SET SDCAP=SDSL

           WRITE ?102,$JUSTIFY(SDCAP,8),?112,$JUSTIFY($SELECT(SDCAP=0:0,1:(SDAP+SDVSL*100)/SDCAP),8,2),"%"

 +3        WRITE ?123,$JUSTIFY($SELECT(SDCAP=0:0,1:((SDAP+SDVSL-SDNS-SDNSVS)*100)/SDCAP),8,2),"%"

 +4        QUIT 

 +5       ;

PLINE     ;Print a provider statistics line

 +1        if $Y>(IOSL-12)

               DO FOOT^SCRPW2

               DO HDR^SCRPW2

           if SDOUT

               QUIT 

           SET SDCT=^TMP("SCRPW",$JOB,SDIV,2,SDPRN,SDPR)

           WRITE !!,SDPRN,"  (",SDPR,")"

           DO F1

 +2        QUIT 

 +3       ;

ACT       ;Count appointments, addl. variable appt. slots and no-shows

 +1       ;Quit if cancelled

           if $PIECE(SDCP0,U,9)="C"

               QUIT 

 +2        SET SDPLAP=$PIECE(SDCP0,U,2)

           SET SDPESL=0

           IF SDLAP

               IF SDPLAP>SDLAP

                   SET SDPESL=SDPLAP\SDLAP-1

                   SET SDVSL=SDVSL+SDPESL

 +3       ;SD*5.3*540

           if 'SDCP0

               QUIT 

 +4        SET SDAP=SDAP+1

           SET SDF1=1

 +5        SET SDPAS=$GET(^DPT($PIECE(SDCP0,U),"S",SDDAY,0))

           SET SDPAS=$PIECE(SDPAS,U,2)

           if SDPAS=""

               QUIT 

           if "NA"[SDPAS

               SET SDNS=SDNS+1

               SET SDNSVS=SDNSVS+SDPESL

 +6        QUIT 

 +7       ;

SPAT(SC,SDSTRTDT,MAX,SDS) ;Set patterns into ^TMP (modified clone of OVR^SDAUT1)

 +1       ;Input: SC=clinic ifn

 +2       ;Input: SDSTRTDT=start date for gathering patterns

 +3       ;Input: MAX=number of days beyond start date to gather patterns

 +4       ;Input: SDS=array namespace subscript value (optional)

 +5       ;Output: array of clinic current availability patterns in

 +6       ;        ^TMP(SDS,$J,clinic_ifn,"ST",date,1)

 +7       ;

 +8        SET SDS=$GET(SDS)

           if '$LENGTH(SDS)

               SET SDS="SDTMP"

           KILL ^TMP(SDS,$JOB)

 +9        NEW SI,SDIN,SDRE,SDSOH,ENDATE,X,X1,X2,SM,I,D,J,Y,SS,DAY

 +10       SET SDIN=$GET(^SC(SC,"I"))

           SET SDRE=$PIECE(SDIN,U,2)

           SET SDIN=$PIECE(SDIN,U)

 +11       SET DAY="SU^MO^TU^WE^TH^FR^SA"

 +12       SET SI=$PIECE($GET(^SC(SC,"SL")),U,6)

           SET SI=$SELECT(SI<3:4,1:SI)

 +13       SET SDSOH=$SELECT('$DATA(^SC(SC,"SL")):0,$PIECE(^SC(SC,"SL"),"^",8)']"":0,1:1)

 +14       SET X1=SDSTRTDT

           SET X2=MAX

           SET SDIN=$GET(SDIN)

           DO C^%DTC

           SET ENDATE=X

           SET X=SDSTRTDT

EN1        if $ORDER(^SC(SC,"T",0))>X

               SET X=$ORDER(^SC(SC,"T",0))

 +1        SET Y=$$DOW^XLFDT(X,1)

           SET I=Y+32

           SET SM=X

           SET D=Y

           DO WM

 +2        KILL J

           FOR Y=0:1:6

               IF $DATA(^SC(+SC,"T"_Y))

                   SET J(Y)=""

 +3        IF '$DATA(J)

               Begin DoDot:1

 +4                SET D=SDSTRTDT-1