SDD.m

SDD ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84  3:00 pm

 ;;5.3;Scheduling;**1015**;Aug 13, 1993;Build 21

 ;IHS/ANMC/LJF 8/2/2000 removed intro comment & changed $N to $O

 ;IHS/ANMC/LJF 8/2/2000

 ;W !,"REMAP will set the patterns for the holiday if the clinic was set up",!,"to not schedule on Holidays",!,"REMAP should always be done if a clinic is changed from not scheduling",!,"on holidays to schedule on holidays"

 ;

 W !,"REMAP will set the patterns for the holiday if the clinic was set up",!,"to not schedule on Holidays",!,"REMAP should always be done if a clinic is changed from not scheduling",!,"on holidays to schedule on holidays"

CL W !! D LO^DGUTL D ASK2^SDDIV G:Y<0 END S VAUTNI=1 D CLINIC^VAUTOMA G:Y<0 END

DT D DATE^SDUTL G:POP END S DGVAR="SDBD^SDED^VAUTD#^VAUTC#^DUZ",DGPGM="START^SDD"

 D ZIS^DGUTQ G:POP END

START D:'$D(DT) DT^SDUTL S (YP,PG,SD,SDU)=0,Y=DT X ^DD("DD") S DAT=Y D HD

 ;F SCI=0:0 S SD=$S(VAUTC:$N(^SC("B",SD)),1:$N(VAUTC(SD))) Q:SD<0  S SC=0 F SCC=0:0 S SC=$N(^SC("B",SD,SC)) Q:SC<0  S SD0=^SC(SC,0) I $P(SD0,U,3)="C" S SDNM=SD D SETX^SDD0 G:SDU END  ;IHS/ANMC/LJF 8/2/2000

 F SCI=0:0 S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD=""  S SC=0 F SCC=0:0 S SC=$O(^SC("B",SD,SC)) Q:SC=""  S SD0=^SC(SC,0) I $P(SD0,U,3)="C" S SDNM=SD D SETX^SDD0 G:SDU END  ;IHS/ANMC/LJF 8/2/2000

END K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q

ESC S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1

HD U IO S PG=PG+1 W @IOF,!,DAT,?30,"Clinic Remap Function",?70,"pg ",PG,!!?5,"Clinic Name",?27,"Clinic Date",?50,"Remark",!?5,"-----------",?27,"-----------",?50,"------",! S YP=4 Q

SDD       ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84  3:00 pm

 +1       ;;5.3;Scheduling;**1015**;Aug 13, 1993;Build 21

 +2       ;IHS/ANMC/LJF 8/2/2000 removed intro comment & changed $N to $O

 +3       ;IHS/ANMC/LJF 8/2/2000

 +4       ;W !,"REMAP will set the patterns for the holiday if the clinic was set up",!,"to not schedule on Holidays",!,"REMAP should always be done if a clinic is changed from not scheduling",!,"on holidays to schedule on holidays"

 +5       ;

 +6        WRITE !,"REMAP will set the patterns for the holiday if the clinic was set up",!,"to not schedule on Holidays",!,"REMAP should always be done if a clinic is changed from not scheduling",!,"on holidays to schedule on holidays"

CL         WRITE !!

           DO LO^DGUTL

           DO ASK2^SDDIV

           IF Y<0

               GOTO END

           SET VAUTNI=1

           DO CLINIC^VAUTOMA

           IF Y<0

               GOTO END

DT         DO DATE^SDUTL

           IF POP

               GOTO END

           SET DGVAR="SDBD^SDED^VAUTD#^VAUTC#^DUZ"

           SET DGPGM="START^SDD"

 +1        DO ZIS^DGUTQ

           IF POP

               GOTO END

START      IF '$DATA(DT)

               DO DT^SDUTL

           SET (YP,PG,SD,SDU)=0

           SET Y=DT

           XECUTE ^DD("DD")

           SET DAT=Y

           DO HD

 +1       ;F SCI=0:0 S SD=$S(VAUTC:$N(^SC("B",SD)),1:$N(VAUTC(SD))) Q:SD<0  S SC=0 F SCC=0:0 S SC=$N(^SC("B",SD,SC)) Q:SC<0  S SD0=^SC(SC,0) I $P(SD0,U,3)="C" S SDNM=SD D SETX^SDD0 G:SDU END  ;IHS/ANMC/LJF 8/2/2000

 +2       ;IHS/ANMC/LJF 8/2/2000

           FOR SCI=0:0

               SET SD=$SELECT(VAUTC:$ORDER(^SC("B",SD)),1:$ORDER(VAUTC(SD)))

               IF SD=""

                   QUIT 

               SET SC=0

               FOR SCC=0:0

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

                   IF SC=""

                       QUIT 

                   SET SD0=^SC(SC,0)

                   IF $PIECE(SD0,U,3)="C"

                       SET SDNM=SD

                       DO SETX^SDD0

                       IF SDU

                           GOTO END

END        KILL %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE

           DO CLOSE^DGUTQ

           QUIT 

ESC        SET SDU=0

           IF $EXTRACT(IOST,1,2)="C-"

               WRITE *7

               READ ESC:DTIME

               IF U=ESC

                   SET SDU=1

HD         USE IO

           SET PG=PG+1

           WRITE @IOF,!,DAT,?30,"Clinic Remap Function",?70,"pg ",PG,!!?5,"Clinic Name",?27,"Clinic Date",?50,"Remark",!?5,"-----------",?27,"-----------",?50,"------",!

           SET YP=4

           QUIT