- SDOQMP1 ;DMJ/VAMCSD;MTZ/HNB;JRC/LRVAMC; ALB/SCK - NEXT AVAILABLE APPOINTMENT ;12/4/94
- ;;5.3;SCHEDULING;**47,179,1015**;AUG 13, 1993;Build 21
- ;
- ;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
- SDOQMP1 ;DMJ/VAMCSD;MTZ/HNB;JRC/LRVAMC; ALB/SCK - NEXT AVAILABLE APPOINTMENT ;12/4/94
- +1 ;;5.3;SCHEDULING;**47,179,1015**;AUG 13, 1993;Build 21
- +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
