SCRPW71 ;BP-CIOFO/KEITH - Clinic appointment availability extract (cont.) ; 14 May 99 9:19 PM
;;5.3;Scheduling;**192,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 10/6/2000 IHS uses only one clinic code
;
CLINIC(SC,SDFMT,SDSTRTDT,MAXDT,MAX,SDPAST) ;Evaluate a clinic
;Input: SC=clinic ifn
;Input: SDFMT='S' for totals only, 'D' for detail and totals
;Input: SDSTRTDT=begin date for data extraction
;Input: MAXDT=end date for data extraction
;Input: MAX=number of days in date range
;Input: SDPAST='0' for future dates, '1' for past dates
;Output: # of slots found^maximum capacity^error condition (1=success,-1=failure)^comment (if failure) or sort value (if success)
N SC0,SDCP,X1,X2,X,%H,SDIV
S SC0=$G(^SC(SC,0)) Q:$P(SC0,U,3)'="C" "0^0^-1^Not a clinic location type"
Q:$P(SC0,U,17)="Y" "0^0^-1^Clinic defined as non-count"
Q:'$$CPAIR(SC0,.SDCP) "0^0^-1^Not a valid primary clinic Stop Code"
S X2=$P($G(^SC(SC,"SDP")),U,2) I X2 S X1=DT D C^%DTC S:X<MAXDT MAXDT=X
Q:'$$ACTC(SC,SDSTRTDT,MAXDT) "0^0^-1^Clinic is inactivated during these dates"
S SDIV=$$DIV(SC0) Q:'$L(SDIV) "0^0^-1^Invalid division number"
D SPAT(SC,SDSTRTDT,MAXDT)
Q $$CCNT(SC,MAX,SDCP,SDFMT,SDSTRTDT,SDIV,SDPAST)_"^1^"_SDCP_U_SC
;
DIV(SC0) ;Get facility division name and number
;Input: SC0=hospital location zeroeth node
N SDIV S SDIV=$P(SC0,U,15)
Q:SDIV>0 $P($$SITE^VASITE(,SDIV),U,2,3)
Q $P($$SITE^VASITE(),U,2,3)
;
CPAIR(SC0,SDCP) ;Validate primary stop code, get credit pair
;Input: SC0=zeroeth node of HOSPITAL LOCATION record
;Input: SDCP=variable to return clinic credit pair (pass by reference)
;Output: 1=success, 0=invalid primary stop code
S SDCP=+$P($G(^DIC(40.7,+$P(SC0,U,7),0)),U,2) Q $S(SDCP<1:0,1:1) ;IHS/ANMC/LJF 10/6/2000
N SDSSC
S SDCP=$P($G(^DIC(40.7,+$P(SC0,U,7),0)),U,2),SDCP=$S(SDCP<100:0,SDCP>999:0,1:SDCP)
Q:SDCP'>0 0
S SDSSC=$P($G(^DIC(40.7,+$P(SC0,U,18),0)),U,2),SDCP=SDCP_$S(SDSSC<100:"000",SDSSC>999:"000",1:SDSSC)
Q 1
;
ACTC(SC,SDSTRTDT,MAXDT) ;Determine if clinic is active during date range
;Input: SC=clinic ifn
;Input: SDSTRTDT=begin date for evaluation (TODAY+1)
;Input: MAXDT=maximum date in the future to evaluate (end date)
;Output: 1=active, 0=inactive during entire date range
N SDIN,SDRE,X1,X2,X,%H
S SDIN=$G(^SC(SC,"I")),SDRE=$P(SDIN,U,2),SDIN=$P(SDIN,U)
Q:SDIN<1 1 Q:SDIN>SDSTRTDT 1
I SDRE,SDRE'>MAXDT Q 1
Q 0
;
SPAT(SC,SDSTRTDT,ENDATE,SDS) ;Set patterns into ^TMP (modified clone of OVR^SDAUT1)
;Input: SC=clinic ifn
;Input: SDSTRTDT=start date for gathering patterns
;Input: ENDATE=date in future to evaluate to
;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,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 SDIN=$G(SDIN),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
;
INIT ;Initialize array for counting patterns
K SD N SDI
S SD="123456789jklmnopqrstuvwxyz"
F I=1:1:26 S SD($E(SD,I))=I
Q
;
CCNT(SC,MAX,SDCP,SDFMT,SDSTRTDT,SDIV,SDPAST) ;Count clinic availability and capacity
;Input: SC=clinic ifn
;Input: MAX=maximum days to evaluate availability
;Input: SDCP=credit pair
;Input: SDFMT=report format
;Input: SDSTRTDT=begin date of report
;Input: SDIV=clinic division number
;Input: SDPAST='0' for future dates, '1' for past dates
;Output: total # of open slots found^maximum capacity
;Output: Creates an array of:
; ^TMP("SD",$J,SDIV,SDCP)=open slots^maximum capacity^encounters
; ^TMP("SD",$J,SDIV,SDCP,SC)=open slots^maximum capacity^encounters
; ^TMP("SD",$J,SDIV,SDCP,SC,sub)=slots~capacity~encounters^slots~capacity~encounters ... etc. (up to 12 slots~capacity~encounters values)
; where 'sub' is a number 0 to nnn, 'sub' * 12 + "^" $PIECE where the data
; is stored equals the day which that data represents.
;
N SDTOE
S SDTOE=U_$P($G(^TMP("SD",$J,SDIV,SDCP,SC)),U,3) S:$L(SDTOE)=1 SDTOE=""
Q:'$D(^TMP("SDTMP",$J)) "0^0"_SDTOE
D:'$D(^TMP("SD",$J,SDIV,SDCP,SC)) ARRINI(SDCP,SC,MAX,SDPAST)
N SDDAY,SDI,SDPATT,SDTSL,SDSL,SDTCAP,SDCAP,SDY
S X1=SDSTRTDT,X2=-1 D C^%DTC S SDY=X
S (SDTSL,SDTCAP)=0 F SDI=1:1:MAX D
.S (SDSL,SDCAP)=0,X1=SDY,X2=SDI D C^%DTC S SDDAY=X
.;Count open slots
.S SDPATT=$E($G(^TMP("SDTMP",$J,SC,"ST",SDDAY,1)),6,999)
.I SDPATT["[" D
..S SDSL=$$PCT(SDPATT),SDTSL=SDTSL+SDSL
..;Count maximum slots
..N X,%H,%T,%Y,SDDW,SDMPDT
..S SDCAP=0
..S SDPATT=$E($G(^SC(SC,"OST",SDDAY,1)),6,999) I $L(SDPATT) S SDCAP=$$PCT(SDPATT),SDTCAP=SDTCAP+SDCAP Q:SDCAP
..S X=SDDAY D H^%DTC S SDDW="T"_%Y,SDMPDT=$O(^SC(SC,SDDW,SDDAY))
..S SDPATT=$G(^SC(SC,SDDW,+SDMPDT,1)),SDCAP=$$PCT(SDPATT),SDTCAP=SDTCAP+SDCAP
..Q
.D:SDFMT="D" ARRSET(SDCP,SC,SDI,SDSL,SDCAP) Q
S $P(^TMP("SD",$J,SDIV,SDCP),U)=$P(^TMP("SD",$J,SDIV,SDCP),U)+SDTSL
S $P(^TMP("SD",$J,SDIV,SDCP),U,2)=$P(^TMP("SD",$J,SDIV,SDCP),U,2)+SDTCAP
S $P(^TMP("SD",$J,SDIV,SDCP,SC),U)=$P(^TMP("SD",$J,SDIV,SDCP,SC),U)+SDTSL
S $P(^TMP("SD",$J,SDIV,SDCP,SC),U,2)=$P(^TMP("SD",$J,SDIV,SDCP,SC),U,2)+SDTCAP
I SDPAST D
.S $P(^TMP("SD",$J,SDIV,SDCP),U,3)=$P(^TMP("SD",$J,SDIV,SDCP),U,3)+0
.S $P(^TMP("SD",$J,SDIV,SDCP,SC),U,3)=$P(^TMP("SD",$J,SDIV,SDCP,SC),U,3)+0 Q
Q SDTSL_U_SDTCAP_SDTOE
;
PCT(SDPATT) ;Pattern count
;Input: SDPATT=pattern to evaluate
Q:SDPATT'["[" 0
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
;
ARRINI(SDCP,SC,MAX,SDPAST) ;Initialize array for counts
;Input: SDCP=credit pair
;Input: SC=clinic ifn
;Input: MAX=maximum days to report
;Input: SDPAST='0' for future dates, '1' for past dates
N SDI,SDX,SDY,SDS,SDP
S SDY="0~0" S:SDPAST SDY=SDY_"~0"
S SDX="" F SDI=1:1:(2+SDPAST) S $P(SDX,U,SDI)=0
S:'$D(^TMP("SD",$J,SDIV,SDCP)) ^TMP("SD",$J,SDIV,SDCP)=SDX
S ^TMP("SD",$J,SDIV,SDCP,SC)=SDX Q:SDFMT'="D"
F SDI=0:1:(MAX-1\12) S ^TMP("SD",$J,SDIV,SDCP,SC,SDI)=""
F SDI=1:1:MAX D
.S SDS=SDI-1\12,SDP=SDI#12 S:SDP=0 SDP=12
.S $P(^TMP("SD",$J,SDIV,SDCP,SC,SDS),U,SDP)=SDY
.Q
Q
;
ARRSET(SDCP,SC,SDI,SDSL,SDCAP) ;Set daily counts into array
;Input: SDCP=credit pair
;Input: SC=clinic ifn
;Input: SDI=number of days from report date
;Input: SDSL=number of open slots for day SDI
;Input: SDCAP=maximum slots for day SDI
N SDS,SDP,SDX
S SDS=SDI-1\12,SDP=SDI#12 S:SDP=0 SDP=12
S SDX=$P(^TMP("SD",$J,SDIV,SDCP,SC,SDS),U,SDP)
S $P(SDX,"~")=$P(SDX,"~")+SDSL
S $P(SDX,"~",2)=$P(SDX,"~",2)+SDCAP
I $G(SDPAST),$P(SDX,"~",3)="" S $P(SDX,"~",3)=0
S $P(^TMP("SD",$J,SDIV,SDCP,SC,SDS),U,SDP)=SDX
Q
;
PCNT(X) ;Count open slots in a pattern
;Input: X=^SC(SC,"ST",SDT,1) node
;Output: number of open slots in a single date pattern
N I,CT
S CT=0 Q:X'["[" CT
S X=$E(X,6,999),X=$TR(X,"|[] ","")
F I=1:1:$L(X) S CT=CT+$G(SD($E(X,I)))
Q CT
SCRPW71 ;BP-CIOFO/KEITH - Clinic appointment availability extract (cont.) ; 14 May 99 9:19 PM
+1 ;;5.3;Scheduling;**192,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 10/6/2000 IHS uses only one clinic code
+3 ;
CLINIC(SC,SDFMT,SDSTRTDT,MAXDT,MAX,SDPAST) ;Evaluate a clinic
+1 ;Input: SC=clinic ifn
+2 ;Input: SDFMT='S' for totals only, 'D' for detail and totals
+3 ;Input: SDSTRTDT=begin date for data extraction
+4 ;Input: MAXDT=end date for data extraction
+5 ;Input: MAX=number of days in date range
+6 ;Input: SDPAST='0' for future dates, '1' for past dates
+7 ;Output: # of slots found^maximum capacity^error condition (1=success,-1=failure)^comment (if failure) or sort value (if success)
+8 NEW SC0,SDCP,X1,X2,X,%H,SDIV
+9 SET SC0=$GET(^SC(SC,0))
IF $PIECE(SC0,U,3)'="C"
QUIT "0^0^-1^Not a clinic location type"
+10 IF $PIECE(SC0,U,17)="Y"
QUIT "0^0^-1^Clinic defined as non-count"
+11 IF '$$CPAIR(SC0,.SDCP)
QUIT "0^0^-1^Not a valid primary clinic Stop Code"
+12 SET X2=$PIECE($GET(^SC(SC,"SDP")),U,2)
IF X2
SET X1=DT
DO C^%DTC
IF X<MAXDT
SET MAXDT=X
+13 IF '$$ACTC(SC,SDSTRTDT,MAXDT)
QUIT "0^0^-1^Clinic is inactivated during these dates"
+14 SET SDIV=$$DIV(SC0)
IF '$LENGTH(SDIV)
QUIT "0^0^-1^Invalid division number"
+15 DO SPAT(SC,SDSTRTDT,MAXDT)
+16 QUIT $$CCNT(SC,MAX,SDCP,SDFMT,SDSTRTDT,SDIV,SDPAST)_"^1^"_SDCP_U_SC
+17 ;
DIV(SC0) ;Get facility division name and number
+1 ;Input: SC0=hospital location zeroeth node
+2 NEW SDIV
SET SDIV=$PIECE(SC0,U,15)
+3 IF SDIV>0
QUIT $PIECE($$SITE^VASITE(,SDIV),U,2,3)
+4 QUIT $PIECE($$SITE^VASITE(),U,2,3)
+5 ;
CPAIR(SC0,SDCP) ;Validate primary stop code, get credit pair
+1 ;Input: SC0=zeroeth node of HOSPITAL LOCATION record
+2 ;Input: SDCP=variable to return clinic credit pair (pass by reference)
+3 ;Output: 1=success, 0=invalid primary stop code
+4 ;IHS/ANMC/LJF 10/6/2000
SET SDCP=+$PIECE($GET(^DIC(40.7,+$PIECE(SC0,U,7),0)),U,2)
QUIT $SELECT(SDCP<1:0,1:1)
+5 NEW SDSSC
+6 SET SDCP=$PIECE($GET(^DIC(40.7,+$PIECE(SC0,U,7),0)),U,2)
SET SDCP=$SELECT(SDCP<100:0,SDCP>999:0,1:SDCP)
+7 IF SDCP'>0
QUIT 0
+8 SET SDSSC=$PIECE($GET(^DIC(40.7,+$PIECE(SC0,U,18),0)),U,2)
SET SDCP=SDCP_$SELECT(SDSSC<100:"000",SDSSC>999:"000",1:SDSSC)
+9 QUIT 1
+10 ;
ACTC(SC,SDSTRTDT,MAXDT) ;Determine if clinic is active during date range
+1 ;Input: SC=clinic ifn
+2 ;Input: SDSTRTDT=begin date for evaluation (TODAY+1)
+3 ;Input: MAXDT=maximum date in the future to evaluate (end date)
+4 ;Output: 1=active, 0=inactive during entire date range
+5 NEW SDIN,SDRE,X1,X2,X,%H
+6 SET SDIN=$GET(^SC(SC,"I"))
SET SDRE=$PIECE(SDIN,U,2)
SET SDIN=$PIECE(SDIN,U)
+7 IF SDIN<1
QUIT 1
IF SDIN>SDSTRTDT
QUIT 1
+8 IF SDRE
IF SDRE'>MAXDT
QUIT 1
+9 QUIT 0
+10 ;
SPAT(SC,SDSTRTDT,ENDATE,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: ENDATE=date in future to evaluate to
+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,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 SDIN=$GET(SDIN)
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
FOR
SET D=$ORDER(^SC(SC,"ST",D))
IF 'D!(D>ENDATE)
QUIT
Begin DoDot:2
+5 SET X=$GET(^SC(SC,"ST",D,1))
IF $LENGTH(X)
SET ^TMP(SDS,$JOB,SC,"ST",D,1)=X
QUIT
End DoDot:2
+6 QUIT
End DoDot:1
QUIT
X1 IF X>ENDATE
QUIT
SET X1=X\100_28
+1 IF '$$ACTIVE(X,SDIN,SDRE)
SET X1=X
SET X2=1
DO C^%DTC
GOTO X1
W SET X=X\1
+1 IF $DATA(^SC(+SC,"ST",X,1))
SET ^TMP(SDS,$JOB,SC,"ST",X,1)=^SC(+SC,"ST",X,1)
GOTO W1
+2 IF '$DATA(^SC(SC,"ST",X,1))
SET Y=D#7
IF '$DATA(J(Y))
GOTO L
IF $DATA(^HOLIDAY(X))&('SDSOH)
GOTO H
SET SS=$ORDER(^SC(SC,"T"_Y,X))
IF SS<1
GOTO L
IF ^SC(SC,"T"_Y,SS,1)=""
GOTO L
Begin DoDot:1
+3 SET ^TMP(SDS,$JOB,SC,"ST",X\1,1)=$PIECE(DAY,U,Y+1)_" "_$EXTRACT(X,6,7)_$JUSTIFY("",SI+SI-6)_^SC(SC,"T"_Y,SS,1)
QUIT
End DoDot:1
W1 IF X>SM
DO WM
L IF X>ENDATE
QUIT
SET X=X+1
SET D=D+1
IF X'>X1
GOTO W
SET X2=X-X1
DO C^%DTC
GOTO X1
+1 ;
H SET ^TMP(SDS,$JOB,SC,"ST",X,1)=" "_$EXTRACT(X,6,7)_" "_$PIECE(^(X,0),U,2)
GOTO W1
+1 ;
WM SET SM=$SELECT($EXTRACT(X,4,5)[12:$EXTRACT(X,1,3)+1_"01",1:$EXTRACT(X,1,3)_$EXTRACT(X,4,5)+1)_"00"
QUIT
+1 ;
ACTIVE(X,SDIN,SDRE) ;Determine if the clinic is active on a given date
+1 ;Input: X=date to be examined
+2 ;Input: SDIN=clinic inactive date
+3 ;Input: SDRE=clinic reactivate date
+4 ;Output: '1'=active, '0'=inactive
+5 IF 'SDIN
QUIT 1
IF X<SDIN
QUIT 1
IF 'SDRE
QUIT 0
IF X<SDRE
QUIT 0
QUIT 1
+6 ;
INIT ;Initialize array for counting patterns
+1 KILL SD
NEW SDI
+2 SET SD="123456789jklmnopqrstuvwxyz"
+3 FOR I=1:1:26
SET SD($EXTRACT(SD,I))=I
+4 QUIT
+5 ;
CCNT(SC,MAX,SDCP,SDFMT,SDSTRTDT,SDIV,SDPAST) ;Count clinic availability and capacity
+1 ;Input: SC=clinic ifn
+2 ;Input: MAX=maximum days to evaluate availability
+3 ;Input: SDCP=credit pair
+4 ;Input: SDFMT=report format
+5 ;Input: SDSTRTDT=begin date of report
+6 ;Input: SDIV=clinic division number
+7 ;Input: SDPAST='0' for future dates, '1' for past dates
+8 ;Output: total # of open slots found^maximum capacity
+9 ;Output: Creates an array of:
+10 ; ^TMP("SD",$J,SDIV,SDCP)=open slots^maximum capacity^encounters
+11 ; ^TMP("SD",$J,SDIV,SDCP,SC)=open slots^maximum capacity^encounters
+12 ; ^TMP("SD",$J,SDIV,SDCP,SC,sub)=slots~capacity~encounters^slots~capacity~encounters ... etc. (up to 12 slots~capacity~encounters values)
+13 ; where 'sub' is a number 0 to nnn, 'sub' * 12 + "^" $PIECE where the data
+14 ; is stored equals the day which that data represents.
+15 ;
+16 NEW SDTOE
+17 SET SDTOE=U_$PIECE($GET(^TMP("SD",$JOB,SDIV,SDCP,SC)),U,3)
IF $LENGTH(SDTOE)=1
SET SDTOE=""
+18 IF '$DATA(^TMP("SDTMP",$JOB))
QUIT "0^0"_SDTOE
+19 IF '$DATA(^TMP("SD",$JOB,SDIV,SDCP,SC))
DO ARRINI(SDCP,SC,MAX,SDPAST)
+20 NEW SDDAY,SDI,SDPATT,SDTSL,SDSL,SDTCAP,SDCAP,SDY
+21 SET X1=SDSTRTDT
SET X2=-1
DO C^%DTC
SET SDY=X
+22 SET (SDTSL,SDTCAP)=0
FOR SDI=1:1:MAX
Begin DoDot:1
+23 SET (SDSL,SDCAP)=0
SET X1=SDY
SET X2=SDI
DO C^%DTC
SET SDDAY=X
+24 ;Count open slots
+25 SET SDPATT=$EXTRACT($GET(^TMP("SDTMP",$JOB,SC,"ST",SDDAY,1)),6,999)
+26 IF SDPATT["["
Begin DoDot:2
+27 SET SDSL=$$PCT(SDPATT)
SET SDTSL=SDTSL+SDSL
+28 ;Count maximum slots
+29 NEW X,%H,%T,%Y,SDDW,SDMPDT
+30 SET SDCAP=0
+31 SET SDPATT=$EXTRACT($GET(^SC(SC,"OST",SDDAY,1)),6,999)
IF $LENGTH(SDPATT)
SET SDCAP=$$PCT(SDPATT)
SET SDTCAP=SDTCAP+SDCAP
IF SDCAP
QUIT
+32 SET X=SDDAY
DO H^%DTC
SET SDDW="T"_%Y
SET SDMPDT=$ORDER(^SC(SC,SDDW,SDDAY))
+33 SET SDPATT=$GET(^SC(SC,SDDW,+SDMPDT,1))
SET SDCAP=$$PCT(SDPATT)
SET SDTCAP=SDTCAP+SDCAP
+34 QUIT
End DoDot:2
+35 IF SDFMT="D"
DO ARRSET(SDCP,SC,SDI,SDSL,SDCAP)
QUIT
End DoDot:1
+36 SET $PIECE(^TMP("SD",$JOB,SDIV,SDCP),U)=$PIECE(^TMP("SD",$JOB,SDIV,SDCP),U)+SDTSL
+37 SET $PIECE(^TMP("SD",$JOB,SDIV,SDCP),U,2)=$PIECE(^TMP("SD",$JOB,SDIV,SDCP),U,2)+SDTCAP
+38 SET $PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC),U)=$PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC),U)+SDTSL
+39 SET $PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC),U,2)=$PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC),U,2)+SDTCAP
+40 IF SDPAST
Begin DoDot:1
+41 SET $PIECE(^TMP("SD",$JOB,SDIV,SDCP),U,3)=$PIECE(^TMP("SD",$JOB,SDIV,SDCP),U,3)+0
+42 SET $PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC),U,3)=$PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC),U,3)+0
QUIT
End DoDot:1
+43 QUIT SDTSL_U_SDTCAP_SDTOE
+44 ;
PCT(SDPATT) ;Pattern count
+1 ;Input: SDPATT=pattern to evaluate
+2 IF SDPATT'["["
QUIT 0
+3 NEW X,I
SET X=0
+4 SET SDPATT=$TRANSLATE(SDPATT," |[]","")
+5 FOR I=1:1:$LENGTH(SDPATT)
SET X=X+$GET(SD($EXTRACT(SDPATT,I)))
+6 QUIT X
+7 ;
ARRINI(SDCP,SC,MAX,SDPAST) ;Initialize array for counts
+1 ;Input: SDCP=credit pair
+2 ;Input: SC=clinic ifn
+3 ;Input: MAX=maximum days to report
+4 ;Input: SDPAST='0' for future dates, '1' for past dates
+5 NEW SDI,SDX,SDY,SDS,SDP
+6 SET SDY="0~0"
IF SDPAST
SET SDY=SDY_"~0"
+7 SET SDX=""
FOR SDI=1:1:(2+SDPAST)
SET $PIECE(SDX,U,SDI)=0
+8 IF '$DATA(^TMP("SD",$JOB,SDIV,SDCP))
SET ^TMP("SD",$JOB,SDIV,SDCP)=SDX
+9 SET ^TMP("SD",$JOB,SDIV,SDCP,SC)=SDX
IF SDFMT'="D"
QUIT
+10 FOR SDI=0:1:(MAX-1\12)
SET ^TMP("SD",$JOB,SDIV,SDCP,SC,SDI)=""
+11 FOR SDI=1:1:MAX
Begin DoDot:1
+12 SET SDS=SDI-1\12
SET SDP=SDI#12
IF SDP=0
SET SDP=12
+13 SET $PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC,SDS),U,SDP)=SDY
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
ARRSET(SDCP,SC,SDI,SDSL,SDCAP) ;Set daily counts into array
+1 ;Input: SDCP=credit pair
+2 ;Input: SC=clinic ifn
+3 ;Input: SDI=number of days from report date
+4 ;Input: SDSL=number of open slots for day SDI
+5 ;Input: SDCAP=maximum slots for day SDI
+6 NEW SDS,SDP,SDX
+7 SET SDS=SDI-1\12
SET SDP=SDI#12
IF SDP=0
SET SDP=12
+8 SET SDX=$PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC,SDS),U,SDP)
+9 SET $PIECE(SDX,"~")=$PIECE(SDX,"~")+SDSL
+10 SET $PIECE(SDX,"~",2)=$PIECE(SDX,"~",2)+SDCAP
+11 IF $GET(SDPAST)
IF $PIECE(SDX,"~",3)=""
SET $PIECE(SDX,"~",3)=0
+12 SET $PIECE(^TMP("SD",$JOB,SDIV,SDCP,SC,SDS),U,SDP)=SDX
+13 QUIT
+14 ;
PCNT(X) ;Count open slots in a pattern
+1 ;Input: X=^SC(SC,"ST",SDT,1) node
+2 ;Output: number of open slots in a single date pattern
+3 NEW I,CT
+4 SET CT=0
IF X'["["
QUIT CT
+5 SET X=$EXTRACT(X,6,999)
SET X=$TRANSLATE(X,"|[] ","")
+6 FOR I=1:1:$LENGTH(X)
SET CT=CT+$GET(SD($EXTRACT(X,I)))
+7 QUIT CT
