- SDCLDOW ;ALB/TMP - PRINT LIST OF CLINICS BY DAY OF WEEK ; 22 MAR 1999 2:22 pm
- ;;5.3;Scheduling;**188,1011,1012,1015**;Aug 13, 1993;Build 21
- ;IHS/ANMC/LJF 10/04/2000 added choice of clinics; removed page #
- ; and call to list manager code
- ;
- S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL
- ;IHS/ANMC/LJF 10/04/2000
- ;S DIV="" I $D(^DIC(4,+$$SITE^VASITE,"DIV")),^("DIV")="Y" S DIC("A")="CLINIC LIST BY DOW FOR WHICH DIVISION: " D ASK^SDDIV Q:Y<0
- S DIV="" D CLINIC^BSDU(1) I $D(BSDQ) K BSDQ G END
- ;I DIV="" S DIV=$O(^DG(40.8,"C",DUZ(2),0)) ;cmi/maw 9/1/09 orig PATCH 1011
- I DIV="" S DIV=$O(^DG(40.8,"AD",DUZ(2),0)) ;cmi/maw 9/1/09 modified PATCH 1011
- ;S VAR="DIV",VAL=DIV,PGM="START^SDCLDOW" D ZIS^DGUTQ Q:POP
- S VAR="VAUTC#^VAUTD#^DIV",PGM="START^BSDCLDOW" ;IHS/ANMC/LJF 10/4/2000
- I $$BROWSE^BDGF="B" D START^BSDCLDOW Q
- D ZIS^DGUTQ Q:POP D START^BSDCLDOW Q
- ;IHS/ANMC/LJF 10/04/2000 end of mods
- ;
- START U IO S (END,SDPG)=0
- S LINE1="|------------------------------------|-----|-----|-----|-----|-----|-----|-----|",SDIV=$S(DIV:DIV,1:1)
- D TOF
- S SCN=0
- F S SCN=$O(^SC("B",SCN)) G:SCN=""!(END) END D
- . S SC=""
- . I VAUTC=0 Q:'$D(VAUTC(SCN)) ;ihs/cmi/maw 04/07/2012 PIMS Patch 1015
- . F S SC=$O(^SC("B",SCN,SC)) Q:SC="" D CHECK I $T D SET,PRT
- G END
- END K I,SDCL,LINE1,PGM,NAME,POP,SDALL,SCN,END,M,L,DOW,SDOS,SC,SDPG,X,Y D CLOSE^DGUTQ Q
- SET S NAME=$P(^SC(SC,0),"^",1)
- K DOW F L=DT-.1:0 S L=$O(^SC(SC,"T",L)) Q:L="" S X=L D DW^%DTC S:'$D(^SC(SC,"T"_Y,L,1)) DOW(Y+1)="F"
- F L=0:1:6 I '$D(DOW(L+1)) F M=DT-.1:0 S M=$O(^SC(SC,"T"_L,M)) Q:M="" I $D(^(M,1)),^(1)]"" S DOW(L+1)=$S($O(^SC(SC,"T"_L,DT))=M:"C",1:"F") Q
- F M=DT-.1:0 S M=$O(^SC(SC,"OST",M)) Q:M="" S X=M D DW^%DTC I '$D(DOW(Y+1)),$D(^SC(SC,"OST",M,1)),^(1)["[" S DOW(Y+1)="C"
- Q
- PRT I $Y+7>IOSL D:IOSL<25 SEEND:IOST?1"C-".E Q:END D TOF
- I $D(DOW) W !,"|",NAME W ?37,"|" F M=1:1:7 S SDOS=(M+6)*6-3 W:$D(DOW(M)) ?SDOS,"*",DOW(M),"*" S SDOS=SDOS+4 W ?SDOS,"|" K SDOS
- I $D(DOW) W ! W LINE1
- Q
- SEEND R !,"Press return to continue or ""^"" to escape ",CXEND:DTIME I '$T!(CXEND="^") S END=1 Q
- Q
- TOF ;W @IOF,!!,?2,"FACILITY: ",$P(^DG(40.8,+SDIV,0),"^",1),!,?2,"CLINIC LIST BY DAY OF WEEK AS OF " S Y=DT D DT^DIQ S SDPG=SDPG+1 W ?(IOM-10),"PAGE: ",SDPG ;IHS/ANMC/LJF 10/4/2000
- W @IOF,!,?2,"FACILITY: ",$P(^DG(40.8,+SDIV,0),"^",1),!,?2,"CLINIC LIST BY DAY OF WEEK AS OF " S Y=DT D DT^DIQ ;S SDPG=SDPG+1 W ?(IOM-10),"PAGE: ",SDPG ;IHS/ANMC/LJF 10/4/2000
- W !!,?3,"*C* = CLINIC CURRENTLY MEETS ON THIS DAY",!,?3,"*F* = CLINIC WILL MEET IN THE FUTURE ON THIS DAY",!!
- W !,"CLINIC:",?37,"| SUN | MON | TUE | WED | THU | FRI | SAT |"
- S I="",$P(I,"=",81)="" W !,I Q
- CHECK I $P(^SC(SC,0),"^",3)="C",$S(DIV="":1,$P(^SC(SC,0),"^",15)=DIV:1,1:0)
- Q
- SDCLDOW ;ALB/TMP - PRINT LIST OF CLINICS BY DAY OF WEEK ; 22 MAR 1999 2:22 pm
- +1 ;;5.3;Scheduling;**188,1011,1012,1015**;Aug 13, 1993;Build 21
- +2 ;IHS/ANMC/LJF 10/04/2000 added choice of clinics; removed page #
- +3 ; and call to list manager code
- +4 ;
- +5 IF '$DATA(DTIME)
- SET DTIME=300
- IF '$DATA(DT)
- DO DT^SDUTL
- +6 ;IHS/ANMC/LJF 10/04/2000
- +7 ;S DIV="" I $D(^DIC(4,+$$SITE^VASITE,"DIV")),^("DIV")="Y" S DIC("A")="CLINIC LIST BY DOW FOR WHICH DIVISION: " D ASK^SDDIV Q:Y<0
- +8 SET DIV=""
- DO CLINIC^BSDU(1)
- IF $DATA(BSDQ)
- KILL BSDQ
- GOTO END
- +9 ;I DIV="" S DIV=$O(^DG(40.8,"C",DUZ(2),0)) ;cmi/maw 9/1/09 orig PATCH 1011
- +10 ;cmi/maw 9/1/09 modified PATCH 1011
- IF DIV=""
- SET DIV=$ORDER(^DG(40.8,"AD",DUZ(2),0))
- +11 ;S VAR="DIV",VAL=DIV,PGM="START^SDCLDOW" D ZIS^DGUTQ Q:POP
- +12 ;IHS/ANMC/LJF 10/4/2000
- SET VAR="VAUTC#^VAUTD#^DIV"
- SET PGM="START^BSDCLDOW"
- +13 IF $$BROWSE^BDGF="B"
- DO START^BSDCLDOW
- QUIT
- +14 DO ZIS^DGUTQ
- IF POP
- QUIT
- DO START^BSDCLDOW
- QUIT
- +15 ;IHS/ANMC/LJF 10/04/2000 end of mods
- +16 ;
- START USE IO
- SET (END,SDPG)=0
- +1 SET LINE1="|------------------------------------|-----|-----|-----|-----|-----|-----|-----|"
- SET SDIV=$SELECT(DIV:DIV,1:1)
- +2 DO TOF
- +3 SET SCN=0
- +4 FOR
- SET SCN=$ORDER(^SC("B",SCN))
- IF SCN=""!(END)
- GOTO END
- Begin DoDot:1
- +5 SET SC=""
- +6 ;ihs/cmi/maw 04/07/2012 PIMS Patch 1015
- IF VAUTC=0
- IF '$DATA(VAUTC(SCN))
- QUIT
- +7 FOR
- SET SC=$ORDER(^SC("B",SCN,SC))
- IF SC=""
- QUIT
- DO CHECK
- IF $TEST
- DO SET
- DO PRT
- End DoDot:1
- +8 GOTO END
- END KILL I,SDCL,LINE1,PGM,NAME,POP,SDALL,SCN,END,M,L,DOW,SDOS,SC,SDPG,X,Y
- DO CLOSE^DGUTQ
- QUIT
- SET SET NAME=$PIECE(^SC(SC,0),"^",1)
- +1 KILL DOW
- FOR L=DT-.1:0
- SET L=$ORDER(^SC(SC,"T",L))
- IF L=""
- QUIT
- SET X=L
- DO DW^%DTC
- IF '$DATA(^SC(SC,"T"_Y,L,1))
- SET DOW(Y+1)="F"
- +2 FOR L=0:1:6
- IF '$DATA(DOW(L+1))
- FOR M=DT-.1:0
- SET M=$ORDER(^SC(SC,"T"_L,M))
- IF M=""
- QUIT
- IF $DATA(^(M,1))
- IF ^(1)]""
- SET DOW(L+1)=$SELECT($ORDER(^SC(SC,"T"_L,DT))=M:"C",1:"F")
- QUIT
- +3 FOR M=DT-.1:0
- SET M=$ORDER(^SC(SC,"OST",M))
- IF M=""
- QUIT
- SET X=M
- DO DW^%DTC
- IF '$DATA(DOW(Y+1))
- IF $DATA(^SC(SC,"OST",M,1))
- IF ^(1)["["
- SET DOW(Y+1)="C"
- +4 QUIT
- PRT IF $Y+7>IOSL
- IF IOSL<25
- IF IOST?1"C-".E
- DO SEEND
- IF END
- QUIT
- DO TOF
- +1 IF $DATA(DOW)
- WRITE !,"|",NAME
- WRITE ?37,"|"
- FOR M=1:1:7
- SET SDOS=(M+6)*6-3
- IF $DATA(DOW(M))
- WRITE ?SDOS,"*",DOW(M),"*"
- SET SDOS=SDOS+4
- WRITE ?SDOS,"|"
- KILL SDOS
- +2 IF $DATA(DOW)
- WRITE !
- WRITE LINE1
- +3 QUIT
- SEEND READ !,"Press return to continue or ""^"" to escape ",CXEND:DTIME
- IF '$TEST!(CXEND="^")
- SET END=1
- QUIT
- +1 QUIT
- TOF ;W @IOF,!!,?2,"FACILITY: ",$P(^DG(40.8,+SDIV,0),"^",1),!,?2,"CLINIC LIST BY DAY OF WEEK AS OF " S Y=DT D DT^DIQ S SDPG=SDPG+1 W ?(IOM-10),"PAGE: ",SDPG ;IHS/ANMC/LJF 10/4/2000
- +1 ;S SDPG=SDPG+1 W ?(IOM-10),"PAGE: ",SDPG ;IHS/ANMC/LJF 10/4/2000
- WRITE @IOF,!,?2,"FACILITY: ",$PIECE(^DG(40.8,+SDIV,0),"^",1),!,?2,"CLINIC LIST BY DAY OF WEEK AS OF "
- SET Y=DT
- DO DT^DIQ
- +2 WRITE !!,?3,"*C* = CLINIC CURRENTLY MEETS ON THIS DAY",!,?3,"*F* = CLINIC WILL MEET IN THE FUTURE ON THIS DAY",!!
- +3 WRITE !,"CLINIC:",?37,"| SUN | MON | TUE | WED | THU | FRI | SAT |"
- +4 SET I=""
- SET $PIECE(I,"=",81)=""
- WRITE !,I
- QUIT
- CHECK IF $PIECE(^SC(SC,0),"^",3)="C"
- IF $SELECT(DIV="":1,$PIECE(^SC(SC,0),"^",15)=DIV:1,1:0)
- +1 QUIT
