SDOQMP1 ;DMJ/VAMCSD;MTZ/HNB;JRC/LRVAMC; ALB/SCK - NEXT AVAILABLE APPOINTMENT ;12/4/94
;;5.3;SCHEDULING;**47,179**;AUG 13, 1993
;
;2.1;;**1,2**;12/4/94
; Modified for national release ; 7/16/96
Q
END ;
K %,X,X1,X2,Y,Z,ZTSK,AMMS,AMMS1,AMMS2,AMMS3,AMMSCNT,AMMSD0,AMMI,AMMSFSL,AMMSFDT,AMMSLAST,AMMSZDT
K ALCD,ALDCLINE,ALDCODE,ALDCPSTP,ALDCSTAR,ALDCWK,AMMSRDT,AMMSZNUM,CNT3,CNT4,DASH,END,FSLOT,FTCNT,PAGE,SLOT,TDCNT
K ALDCD,ALDCNOW,SDWHN,XCNT,XCNT1,PMDIV,SLDATE,AMMSNDT,GET,POP,NMBR,NODE,NODE2,NUMBER,SAVE,DIC,VAUTNI,VAUTSTR,VAUTVB,SLOTWK
K SLOTWK1,SW,SW2
Q
;
DATES ; Set-up 1 year dates
; This array is used for available appointments
F AMMI=1:1:365 D
. S X1=DT,X2=AMMI D C^%DTC,H^%DTC
. S ^TMP("SDAMMS",$J,"DATE",X)=%Y I $D(^HOLIDAY(X)) S $P(^TMP("SDAMMS",$J,"DATE",X),U,2)=1
Q
;
AMMSCNT S ^TMP("SDAMMS",$J,"DN")=0,^TMP("SDAMMS",$J,"HOL")=0
S ^TMP("SDAMMS",$J,"ZERO")=^SC(AMMSD0,0)
Q:$P(^TMP("SDAMMS",$J,"ZERO"),U,3)'="C"
S ^TMP("SDAMMS",$J,"ACTIVE")=$G(^SC(AMMSD0,"I"))
Q:(^TMP("SDAMMS",$J,"ACTIVE")'="")&($P(^TMP("SDAMMS",$J,"ACTIVE"),U)<DT)&($P(^TMP("SDAMMS",$J,"ACTIVE"),U,2)>DT)
Q:('$P(^TMP("SDAMMS",$J,"ACTIVE"),U,2))&($P(^TMP("SDAMMS",$J,"ACTIVE"),U,1))
I $P($G(^SC(AMMSD0,"SL")),U,8)="Y" S ^TMP("SDAMMS",$J,"HOL")=1
;
; no availability
S ^TMP("SDAMMS",$J,"NOAV")=0
I '$O(^SC(AMMSD0,"OST",AMMSZDT)),'$O(^SC(AMMSD0,"ST",AMMSZDT,0)) D
. F AMMI=0:1:6 S ^TMP("SDAMMS",$J,"DOW")=$O(^SC(AMMSD0,"T"_AMMI,AMMSZDT)) Q:^TMP("SDAMMS",$J,"DOW") S:^TMP("SDAMMS",$J,"DOW") ^TMP("SDAMMS",$J,"NOAV")=1
I $G(^TMP("SDAMMS",$J,"NOAV")) S ^TMP("APPT",$J,AMMSD0)=AMMSRDT_U_"0^0" S AMMSLAST=0,AMMSZDT=DT,AMMSFDT=20,AMMSFSL=33 Q
;
S ^TMP("SDAMMS",$J,"FDT")=AMMSZDT,AMMSZNUM=0
F S ^TMP("SDAMMS",$J,"FDT")=$O(^TMP("SDAMMS",$J,"DATE",^TMP("SDAMMS",$J,"FDT"))) Q:'+^TMP("SDAMMS",$J,"FDT")!(^TMP("SDAMMS",$J,"DN")) D
. S ^TMP("SDAMMS",$J,"FDT1")=^TMP("SDAMMS",$J,"FDT"),^TMP("SDAMMS",$J,"T")="T"_+^TMP("SDAMMS",$J,"DATE",^TMP("SDAMMS",$J,"FDT"))
. Q:'^TMP("SDAMMS",$J,"HOL")&($P(^TMP("SDAMMS",$J,"DATE",^TMP("SDAMMS",$J,"FDT")),U,2))
NOST . ;I '$D(^SC(AMMSD0,"ST",^TMP("SDAMMS",$J,"FDT"))) S ^TMP("APPT",$J,AMMSD0)=AMMSRDT_U_"0^0" Q
. I '$D(^SC(AMMSD0,"ST",^TMP("SDAMMS",$J,"FDT"),1)) S IEN=AMMSD0,DATE=^TMP("SDAMMS",$J,"FDT") D FIX^SDOQMP2
. Q:'$D(^SC(AMMSD0,"ST",^TMP("SDAMMS",$J,"FDT"),1))
. S ^TMP("SDAMMS",$J,"PAT")=^SC(AMMSD0,"ST",^TMP("SDAMMS",$J,"FDT"),1),AMMS=^TMP("SDAMMS",$J,"PAT")
. S AMMSCNT=0,SLOTS=0
. ; Check the pattern for available slots
. S AMMS=$E(AMMS,6,$L(AMMS)),AMMS=$TR(AMMS,"|[] ","")
. F %=1:1:$L(AMMS) S AMMS2=$A(AMMS,%) D
. . I (AMMS2>48&(AMMS2<58))!((AMMS2>105)&(AMMS2<123)) S AMMSCNT=AMMSCNT+$S(AMMS2<58:$C(AMMS2),1:AMMS2-96)
. . Q
. S ^TMP("SDAMMS",$J,"DN")=AMMSCNT Q
DIS I '^TMP("SDAMMS",$J,"DN")&(AMMSLAST=0) S ^TMP("APPT",$J,AMMSD0)=AMMSRDT_U_"0" Q
I '^TMP("SDAMMS",$J,"DN") S AMMSLAST=0,AMMSZDT=DT,AMMSFDT=20,AMMSFSL=33 Q
S (AMMSNDT,Y)=^TMP("SDAMMS",$J,"FDT1")
S:AMMSLAST=0 ^TMP("APPT",$J,AMMSD0)=AMMSRDT_U_AMMSNDT_U_AMMSCNT
S AMMSFDT=AMMSFDT+20,AMMSFSL=AMMSFSL+20,AMMSCNT="",AMMSLAST=AMMSLAST+1,^TMP("SDAMMS",$J,"DN")=0
I AMMSLAST'=3 S AMMSZDT=^TMP("SDAMMS",$J,"FDT1")
I AMMSLAST=2,^TMP("SDAMMS",$J,"MGN")=0 S AMMSZDT=DT,AMMSLAST=0,^TMP("SDAMMS",$J,"DN")=0,AMMSFDT=20,AMMSFSL=33
I AMMSLAST=3 S AMMSZDT=DT,AMMSLAST=0,^TMP("SDAMMS",$J,"DN")=0,AMMSFDT=20,AMMSFSL=33
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDOQMP1 3392 printed Oct 16, 2024@18:59:38 Page 2
SDOQMP1 ;DMJ/VAMCSD;MTZ/HNB;JRC/LRVAMC; ALB/SCK - NEXT AVAILABLE APPOINTMENT ;12/4/94
+1 ;;5.3;SCHEDULING;**47,179**;AUG 13, 1993
+2 ;
+3 ;2.1;;**1,2**;12/4/94
+4 ; Modified for national release ; 7/16/96
+5 QUIT
END ;
+1 KILL %,X,X1,X2,Y,Z,ZTSK,AMMS,AMMS1,AMMS2,AMMS3,AMMSCNT,AMMSD0,AMMI,AMMSFSL,AMMSFDT,AMMSLAST,AMMSZDT
+2 KILL ALCD,ALDCLINE,ALDCODE,ALDCPSTP,ALDCSTAR,ALDCWK,AMMSRDT,AMMSZNUM,CNT3,CNT4,DASH,END,FSLOT,FTCNT,PAGE,SLOT,TDCNT
+3 KILL ALDCD,ALDCNOW,SDWHN,XCNT,XCNT1,PMDIV,SLDATE,AMMSNDT,GET,POP,NMBR,NODE,NODE2,NUMBER,SAVE,DIC,VAUTNI,VAUTSTR,VAUTVB,SLOTWK
+4 KILL SLOTWK1,SW,SW2
+5 QUIT
+6 ;
DATES ; Set-up 1 year dates
+1 ; This array is used for available appointments
+2 FOR AMMI=1:1:365
Begin DoDot:1
+3 SET X1=DT
SET X2=AMMI
DO C^%DTC
DO H^%DTC
+4 SET ^TMP("SDAMMS",$JOB,"DATE",X)=%Y
IF $DATA(^HOLIDAY(X))
SET $PIECE(^TMP("SDAMMS",$JOB,"DATE",X),U,2)=1
End DoDot:1
+5 QUIT
+6 ;
AMMSCNT SET ^TMP("SDAMMS",$JOB,"DN")=0
SET ^TMP("SDAMMS",$JOB,"HOL")=0
+1 SET ^TMP("SDAMMS",$JOB,"ZERO")=^SC(AMMSD0,0)
+2 if $PIECE(^TMP("SDAMMS",$JOB,"ZERO"),U,3)'="C"
QUIT
+3 SET ^TMP("SDAMMS",$JOB,"ACTIVE")=$GET(^SC(AMMSD0,"I"))
+4 if (^TMP("SDAMMS",$JOB,"ACTIVE")'="")&($PIECE(^TMP("SDAMMS",$JOB,"ACTIVE"),U)<DT)&($PIECE(^TMP("SDAMMS",$JOB,"ACTIVE"),U,2)>DT)
QUIT
+5 if ('$PIECE(^TMP("SDAMMS",$JOB,"ACTIVE"),U,2))&($PIECE(^TMP("SDAMMS",$JOB,"ACTIVE"),U,1))
QUIT
+6 IF $PIECE($GET(^SC(AMMSD0,"SL")),U,8)="Y"
SET ^TMP("SDAMMS",$JOB,"HOL")=1
+7 ;
+8 ; no availability
+9 SET ^TMP("SDAMMS",$JOB,"NOAV")=0
+10 IF '$ORDER(^SC(AMMSD0,"OST",AMMSZDT))
IF '$ORDER(^SC(AMMSD0,"ST",AMMSZDT,0))
Begin DoDot:1
+11 FOR AMMI=0:1:6
SET ^TMP("SDAMMS",$JOB,"DOW")=$ORDER(^SC(AMMSD0,"T"_AMMI,AMMSZDT))
if ^TMP("SDAMMS",$JOB,"DOW")
QUIT
if ^TMP("SDAMMS",$JOB,"DOW")
SET ^TMP("SDAMMS",$JOB,"NOAV")=1
End DoDot:1
+12 IF $GET(^TMP("SDAMMS",$JOB,"NOAV"))
SET ^TMP("APPT",$JOB,AMMSD0)=AMMSRDT_U_"0^0"
SET AMMSLAST=0
SET AMMSZDT=DT
SET AMMSFDT=20
SET AMMSFSL=33
QUIT
+13 ;
+14 SET ^TMP("SDAMMS",$JOB,"FDT")=AMMSZDT
SET AMMSZNUM=0
+15 FOR
SET ^TMP("SDAMMS",$JOB,"FDT")=$ORDER(^TMP("SDAMMS",$JOB,"DATE",^TMP("SDAMMS",$JOB,"FDT")))
if '+^TMP("SDAMMS",$JOB,"FDT")!(^TMP("SDAMMS",$JOB,"DN"))
QUIT
Begin DoDot:1
+16 SET ^TMP("SDAMMS",$JOB,"FDT1")=^TMP("SDAMMS",$JOB,"FDT")
SET ^TMP("SDAMMS",$JOB,"T")="T"_+^TMP("SDAMMS",$JOB,"DATE",^TMP("SDAMMS",$JOB,"FDT"))
+17 if '^TMP("SDAMMS",$JOB,"HOL")&($PIECE(^TMP("SDAMMS",$JOB,"DATE",^TMP("SDAMMS",$JOB,"FDT")),U,2))
QUIT
NOST ;I '$D(^SC(AMMSD0,"ST",^TMP("SDAMMS",$J,"FDT"))) S ^TMP("APPT",$J,AMMSD0)=AMMSRDT_U_"0^0" Q
+1 IF '$DATA(^SC(AMMSD0,"ST",^TMP("SDAMMS",$JOB,"FDT"),1))
SET IEN=AMMSD0
SET DATE=^TMP("SDAMMS",$JOB,"FDT")
DO FIX^SDOQMP2
+2 if '$DATA(^SC(AMMSD0,"ST",^TMP("SDAMMS",$JOB,"FDT"),1))
QUIT
+3 SET ^TMP("SDAMMS",$JOB,"PAT")=^SC(AMMSD0,"ST",^TMP("SDAMMS",$JOB,"FDT"),1)
SET AMMS=^TMP("SDAMMS",$JOB,"PAT")
+4 SET AMMSCNT=0
SET SLOTS=0
+5 ; Check the pattern for available slots
+6 SET AMMS=$EXTRACT(AMMS,6,$LENGTH(AMMS))
SET AMMS=$TRANSLATE(AMMS,"|[] ","")
+7 FOR %=1:1:$LENGTH(AMMS)
SET AMMS2=$ASCII(AMMS,%)
Begin DoDot:2
+8 IF (AMMS2>48&(AMMS2<58))!((AMMS2>105)&(AMMS2<123))
SET AMMSCNT=AMMSCNT+$SELECT(AMMS2<58:$CHAR(AMMS2),1:AMMS2-96)
+9 QUIT
End DoDot:2
+10 SET ^TMP("SDAMMS",$JOB,"DN")=AMMSCNT
QUIT
End DoDot:1
DIS IF '^TMP("SDAMMS",$JOB,"DN")&(AMMSLAST=0)
SET ^TMP("APPT",$JOB,AMMSD0)=AMMSRDT_U_"0"
QUIT
+1 IF '^TMP("SDAMMS",$JOB,"DN")
SET AMMSLAST=0
SET AMMSZDT=DT
SET AMMSFDT=20
SET AMMSFSL=33
QUIT
+2 SET (AMMSNDT,Y)=^TMP("SDAMMS",$JOB,"FDT1")
+3 if AMMSLAST=0
SET ^TMP("APPT",$JOB,AMMSD0)=AMMSRDT_U_AMMSNDT_U_AMMSCNT
+4 SET AMMSFDT=AMMSFDT+20
SET AMMSFSL=AMMSFSL+20
SET AMMSCNT=""
SET AMMSLAST=AMMSLAST+1
SET ^TMP("SDAMMS",$JOB,"DN")=0
+5 IF AMMSLAST'=3
SET AMMSZDT=^TMP("SDAMMS",$JOB,"FDT1")
+6 IF AMMSLAST=2
IF ^TMP("SDAMMS",$JOB,"MGN")=0
SET AMMSZDT=DT
SET AMMSLAST=0
SET ^TMP("SDAMMS",$JOB,"DN")=0
SET AMMSFDT=20
SET AMMSFSL=33
+7 IF AMMSLAST=3
SET AMMSZDT=DT
SET AMMSLAST=0
SET ^TMP("SDAMMS",$JOB,"DN")=0
SET AMMSFDT=20
SET AMMSFSL=33
+8 QUIT
