Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSDC

BSDC.m

Go to the documentation of this file. 
  1. BSDC ;MAN/GRR,ALB/LDB - CANCEL A CLINIC'S AVAILABILITY BY DATE RANGE ; [ 01/09/2003  1:52 PM ]
  1.  ;;5.3;Scheduling;**15,32,79,132,167,1003,1011**;Aug 13, 1993
  1.  ;IHS/ANMC/LJF  8/18/2000 added DIC("W") to warn if clinic inactivated
  1.  ;             12/13/2000 added setting of cancellation comment into
  1.  ;                          each patient's record
  1.  ;             12/18/2002 added check so only onwers could cancel clinic
  1.  ;IHS/ITSC/LJF 06/09/2005 PATCH 1003 added message to whole day cancellations
  1.  ;
  1.  N SDATA,SDCNHDL ; for evt dvr
  1. SDC1 K SDLT,SDCP S NOAP="" D LO^DGUTL
  1.  ;S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0  ;IHS/ANMC/LJF 8/18/2000
  1.  S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: ",DIC("W")=$$INACTMSG^BSDU D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0  ;IHS/ANMC/LJF 8/18/2000
  1.  ;1/9/2003 WAR per P46,LJF37
  1.  I '$$OWNER^BSDU(+Y,+$G(DUZ)) D MSG^BDGF("You are NOT an owner of this clinic.  Please select again.",2,1) G SDC1   ;IHS/ANMC/LJF 12/18/2002
  1.  I $D(^SC(+Y,0))  ;IHS/ANMC/LJF 12/18/2002 restoring naked reference
  1.  N BSDCLN,BSDSL,BSDQ
  1.  S BSDQ=0
  1.  S SC=+Y,SL=^("SL")
  1.  S BSDCLN=SC,BSDSL=$G(^SC(SC,"SL"))
  1.  D GETDATES($P(Y,U,2))
  1.  Q:'$G(BSDBDT)
  1.  Q:$$READ^BDGF("Y","Are you sure you want to cancel appointments for "_$$FMTE^XLFDT(BSDBDT)_" to "_$$FMTE^XLFDT(BSDEDT),"YES")'=1
  1.  N BSDII
  1.  F BSDII=1:1 D  Q:$G(BSDQ)
  1.  . I BSDII=1 S BSDI=BSDBDT
  1.  . S BSDI=$S(BSDII=1:BSDBDT,1:$$FMADD^XLFDT(BSDI,+1))
  1.  . I BSDI>BSDEDT S BSDQ=1 Q
  1.  . S SC=BSDCLN,SL=BSDSL
  1.  . S (SD,CDATE)=BSDI
  1.  . W !,"Cancelling clinic for date: "_$$FMTE^XLFDT(SD)
  1.  . ;S %DT="AEXF",%DT("A")="CANCEL '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT G:Y<0 END^SDC0 ;NAKED REFERNCE - ^SC(IFN,"SL")
  1.  . S %=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=%
  1.  . K SDRE,SDIN,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D:Y DTS^SDUTL S SDRE1=$S(SDRE:" to "_Y,1:"")
  1.  . I $S('$D(SDIN):0,SDIN'>0!(SDIN>SD):0,SDRE'>SD&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S('SDRE:"as of ",1:"from ") S Y=SDIN D DTS^SDUTL W Y,SDRE1 Q
  1.  . I '$D(^SC(SC,"ST",SD,1)) S DH="" D B S ^SC(SC,"ST",SD,1)=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_DH,^(0)=SD G N
  1.  . I ^(1)["CANCELLED" W !,"APPOINTMENTS HAVE ALREADY BEEN CANCELLED",!,*7 S ANS="N",SDTIME="*",SDV1=$S($P(^SC(SC,0),"^",15):$P(^(0),"^",15),1:+$O(^DG(40.8,0))) K SDX G ASKL^SDC0 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
  1. N . I '$F(^SC(SC,"ST",SD,1),"[") K:^(1)?2U.E ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON "_$$FMTE^XLFDT(SD) Q  ; KILLs node if not holiday
  1.  . I $O(^SC(SC,"S",SD))\1-SD W *7,!?5,"NO APPOINTMENTS SCHEDULED" S NOAP=1 G W
  1.  . W !,"FIRST, I'LL LIST THE EXISTING APPOINTMENTS",!
  1.  . K DUOUT,DTOUT D ^SDC1 I $D(DUOUT)!$D(DTOUT) D END^SDC0 S BSDQ=1 Q
  1.  . I ^SC(SC,"ST",SD,1)["X" G ^SDC2
  1. W . S DH=0,%="" W !,"WANT TO CANCEL THE WHOLE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G W
  1.  . I %=1 G WP:$$COED^SDC4(SC,SD,SD+.2359,1),ALL
  1.  . I %<1 S BSDQ=1 Q
  1. WP . S %="" W !,"WANT TO CANCEL PART OF THE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G WP
  1.  . I %-1 S BSDQ=1 Q
  1. F . R !,"STARTING TIME: ",X:DTIME Q:U[X  D TC^SDC2 G F:Y<0 S FR=Y,ST=%
  1. T . R !,"ENDING TIME: ",X:DTIME Q:U[X  D TC^SDC2 G T:Y<0 S SDHTO=X,TO=Y I TO'>FR W !,"Ending time must be greater than starting time",*7 G T
  1.  . I $$COED^SDC4(SC,FR,TO,1) K FR,SDHTO,TO,ST W ! G F
  1. ROPT . R !,"(OPTIONAL) MESSAGE: ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G ROPT
  1.  . Q:I["^"  I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP
  1.  . NEW BSDMSG I I]"" S BSDMSG=I   ;IHS/ANMC/LJF 12/13/2000
  1.  . S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1)
  1. SKIP . S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO
  1.  . S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0)
  1.  . S ^SC(SC,"S",FR,0)=FR,^("MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")") D S S I=^(1),I=I_$J("",%-$L(I)),Y=""
  1.  . F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X<ST:DH_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:DH)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(DH="]":"",DH="[":DH,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
  1.  . S:'$F(I,"[") I5=$F(I,"X"),I=$E(I,1,(I5-2))_"["_$E(I,I5,999) K I5
  1.  . S DH=0,^(1)=I,FR=FR-.0001 G C ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
  1.  ;
  1.  Q
  1. S S ^("CAN")=^SC(SC,"ST",SD,1) Q
  1.  ;
  1.  ;IHS/ITSC/LJF 6/9/2005 PATCH 1003 add message to stored cancel message
  1. ALL ;D S S ^(1)="   "_$E(SD,6,7)_"    **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
  1.  NEW BSDMSG S BSDMSG=$$READ^BDGF("FO^1:50","(OPTIONAL) MESSAGE")  ;IHS/ANMC/LJF 12/13/2000
  1.  D S S ^SC(SC,"ST",SD,1)="   "_$E(SD,6,7)_"    **CANCELLED** "_BSDMSG,FR=SD,TO=SD+.9
  1.  ;end of PATCH 1003 changes
  1.  ;
  1. C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'<TO) W !!,"CANCELLED!  " K SDX G CHKEND^SDC0
  1.  F I=0:0 S I=$O(^SC(SC,"S",FR,1,I)) Q:I'>0  D
  1.  .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1)
  1.  .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL)
  1.  .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C"
  1.  .I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1 D MORE
  1.  G C
  1.  ;
  1. B S X=SD D DOW^SDM0 S DOW=Y,SS=+$O(^SC(SC,"T"_Y,X)) I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC
  1.  Q
  1. MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N"
  1.  I $G(BSDMSG)]"" S ^DPT(DFN,"S",FR,"R")=BSDMSG  ;IHS/ANMC/LJF 12/13/2000
  1.  S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN)
  1.  S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=I,SDRT="D" D RT^SDUTL
  1.  S DH=SDH K SDH D CK1,EVT
  1.  K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q
  1. CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1))  I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q
  1.  Q:SDX  F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q
  1.  Q:SDX  IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1
  1.  Q:SDX  K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q
  1.  ;
  1. EVT ; -- separate tag if need to NEW vars
  1.  ; -- cancel event
  1.  N FR,I,SDTIME,DH,SC
  1.  D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL
  1.  Q
  1.  ;
  1. GETDATES(CLNE) ;-- get date range to cancel availability
  1.  S %DT="AEXF",%DT("A")="CANCEL '"_CLNE_"' FOR WHAT BEGIN DATE: " D ^%DT K %DT ;NAKED REFERNCE - ^SC(IFN,"SL")
  1.  I Y<0 K BSDBDT Q
  1.  S BSDBDT=+Y
  1.  S %DT="AEXF",%DT("A")="CANCEL '"_CLNE_"' FOR WHAT END DATE: " D ^%DT K %DT ;NAKED REFERNCE - ^SC(IFN,"SL")
  1.  I Y<0 K BSDBDT,BSDEDT Q
  1.  S BSDEDT=+Y
  1.  Q
  1.  ;
  1. ASKQUIT ;-- ask if they want to quit cancelling
  1.  N BSDQUIT
  1.  S BSDQUIT=$$READ^BDGF("Y","Do you want to quit cancelling the clinic availability","YES")
  1.  Q BSDQUIT
  1.  ;