SDAUT2 ;MAN/GRR - LOOK FOR OPEN SLOTS ; 3/3/05 12:08pm
;;5.3;Scheduling;**206,168,186,478,1015,1016**;Aug 13, 1993;Build 20
;IHS/ANMC/LJF 7/06/2000 hard set of date appt made now includes time
;
K SDNOSH
EN1 S (FND,DUPE)=0,NDATE="",SDSOH=$S('$D(^SC(SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1) I $S('$D(^DPT(+A,.35)):0,$P(^(.35),"^",1)']"":0,1:1) S MESS="NOT REBOOKED, PATIENT HAS DIED" G END
S MESS="" K SDPAT S:'$D(J) SDPAT="" F NDATE=SDSTRTDT-1:0 S NDATE=$O(^SC(SC,"ST",NDATE)) Q:NDATE'>0!(NDATE>ENDATE)!(FND) I ^(NDATE,1)["[",$E(NDATE,6,7) S Z=^(1) I '$D(^HOLIDAY(NDATE))!(SDSOH) S HNDATE=NDATE D SRCH Q:FND
I 'FND,$D(SDPAT) S NDATE="",MESS="NOT REBOOKED, NO PATTERN FOUND" G END
I 'FND S NDATE="",MESS="NOT REBOOKED, NO OPEN SLOTS" G END
;
;**186** MLR 11/30/00 Checking date for "non-cancelled" appointments
D DUPE
;
N SDATA,SDDA,SDABHDL S SDDA=L,SDABHDL=$$HANDLE^SDAMEVT(1) D BEFORE^SDAMEVT(.SDATA,+A,GDATE,SC,SDDA,SDABHDL)
S NDATE=CKDATE,DNODE=^DPT(+A,"S",GDATE,0),$P(DNODE,"^",2)=$S($D(SDNOSH):"NA",$D(SDCP):$S(SDCP:"PCA",1:"CA"),1:"CA"),$P(DNODE,"^",10)=NDATE D STORE S ^DPT(+A,"S",NDATE,0)=HOLD,^DPT(+A,"S",GDATE,0)=DNODE,^SC(SC,"S",NDATE,1,0)="^44.003PA^^"
;xref DATE APPT. MADE field
D
.N DIV,DA,DIK
.S DA=NDATE,DA(1)=+A,DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
.Q
I '$D(SDCP) S SDNODE=^SC(SC,"S",GDATE,1,L,0)
;
;IHS/ANMC/LJF 7/06/2000
;S ^SC(SC,"ST",HNDATE,1)=Z,^SC(SC,"S",NDATE,0)=NDATE F Y=1:1 I '$D(^SC(SC,"S",NDATE,1,Y)) S ^(Y,0)=+A_"^"_LEN,$P(^SC(SC,"S",NDATE,1,Y,0),"^",4,8)=$P(SDNODE,"^",4)_"^^"_$S($D(DUZ):DUZ,1:"")_"^"_DT_"^"_$P(SDNODE,"^",8) Q
;ihs/cmi/maw 11/7/2012 PIMS 1016 remove lindas code and use va but make DT NOW^XLFDT
;S ^SC(SC,"ST",HNDATE,1)=Z,^SC(SC,"S",NDATE,0)=NDATE F Y=1:1 I '$D(^SC(SC,"S",NDATE,1,Y)) S ^(Y,0)=+A_"^"_LEN,$P(^SC(SC,"S",NDATE,1,Y,0),"^",4,8)=$P(SDNODE,"^",4)_"^^"_$S($D(DUZ):DUZ,1:"")_"^"_$$NOW^XLFDT_"^"_$P(SDNODE,"^",8) Q
;
N LNK,CY
K QT S ^SC(SC,"ST",HNDATE,1)=Z,^SC(SC,"S",NDATE,0)=NDATE F CY=1:1 I '$D(^SC(SC,"S",NDATE,1,CY)) D Q:$D(QT) ;SD/478
.;S ^(CY,0)=+A_"^"_LEN,$P(^SC(SC,"S",NDATE,1,CY,0),"^",4,8)=$P(SDNODE,"^",4)_"^^"_$S($D(DUZ):DUZ,1:"")_"^"_DT_"^"_$P(SDNODE,"^",8) ;SD/478
.S ^(CY,0)=+A_"^"_LEN,$P(^SC(SC,"S",NDATE,1,CY,0),"^",4,8)=$P(SDNODE,"^",4)_"^^"_$S($D(DUZ):DUZ,1:"")_"^"_$$NOW^XLFDT_"^"_$P(SDNODE,"^",8) ;ihs/cmi/maw 11/7/2012 PATCH 1016 change DT to NOW^XLFDT
.S TPAT=$P(SDNODE,U) I $D(AUTO(SC,$S($D(SDCP):SD,1:GDATE),TPAT)) S LNK=AUTO(SC,GDATE,TPAT) D AUTOREB^SDCNSLT(SC,NDATE,LNK,CY) ;SD/478
.S QT="" ;SD/478
S $P(^SC(SC,"S",NDATE,1,CY,0),"^",10)=$P(SDNODE,"^",10) ;SD/478
I $D(^SC("ARAD",SC,GDATE,+A)) S ^SC("ARAD",SC,NDATE,+A)=""
S SDTTM=NDATE,SDPL=CY,SDSC=SC,DFN=+A,SDRT="A" D RT^SDUTL,EVT ;SD/478
END K ARG,BTIM,CKDATE,CNT,DIF,DISBEG,DNODE,FND,GOT,HDIF,HH1,HH2,HH3,HNDATE,HOLD,HSTM,HT1,HT2,HT3,INC,INCM,J,K,LEN,M,MM1,MM2,MM3,MMD,MMD2,NC,NS,NSTM,NTIM,REM,SDPAT,SDPL,SDSC,SDT20,SDTEST,SDTTM,STM,STR,TEMP,TM,WH,XK,^UTILITY($J,"I")
Q
;
DUPE ;**186** MLR Checking date for "non-cancelled" appointments prior to
;11/30/00 setting "MULTIPLE APPNTS. ON CANCELLED DATE" message
N I S I=$P(GDATE,"."),DUPE=0
F S I=$O(^DPT(+A,"S",I)) Q:'I!DUPE!($P(I,".")>GDATE) D
. Q:I=GDATE
. I $P(^DPT(+A,"S",I,0),U,2)="I" S DUPE=1 Q
. I $P(^DPT(+A,"S",I,0),U,2)="" S DUPE=1 Q
. Q
Q ;DUPE
;
SRCH I $D(SDCP),(GDATE\1)=NDATE Q
S LEN=$P(A,"^",2),INC=$P(^SC(SC,"SL"),"^",6),DISBEG=$P(^("SL"),"^",3),STR="123456789jklmnopqrstuvwxyz",INCM=$S(INC=4:15,INC=3:20,INC=6:10,INC=2:30,INC=1:60,1:0) G:INCM=0 NO S SDDIF=$S(INC<3:8/INC,1:2) K SDTEST N SDIV S SDIV=""
S:$D(^SC(+SC,0)) SDIV=$S('$P(^(0),"^",15):$O(^DG(40.8,0)),1:$P(^(0),"^",15)) I $D(^DG(40.8,+SDIV,"LTR")) F XK=3,4,5 I $P(^DPT(+A,"S",GDATE,0),"^",XK)]"" S TEMP=$P($P(^(0),"^",XK),".",2),SDTEST(XK)=$P(^DG(40.8,SDIV,"LTR"),"^",(XK-1)) D FTM,FTM3
S BTIM=$S($D(^SC(SC,"SDP")):$P(^("SDP"),"^",3),1:""),BTIM=$S($E(+$O(SDTEST("")),2,999)>BTIM:$E(+$O(SDTEST("")),2,999),1:BTIM) S:DISBEG="" DISBEG=8
S NS=LEN\INCM,ST=$F(Z,"["),GOT=0,INC=$S(INC<3:4,1:INC)
I BTIM]"" S ARG=INC*2,DIF=BTIM-DISBEG S:DIF>0 ST=DIF*ARG+ARG+1
S CNT=0 F J=0:SDDIF:80 Q:$E(Z,ST+J,80)'["]" S K=$E(Z,ST+J),CNT=$S(K]""&(STR[K):CNT+1,1:0) S:$S(STR[K:0,K?1A!(K=0):0,1:1) SDST=$F(Z,"[",ST+J),J=$S('SDST:80,1:SDST-SDDIF-ST) I CNT=NS D MORE Q:GOT S CNT=0
Q
MORE S TM=(NS-1)*SDDIF,STM=ST+J-TM,NSTM=STM-1/(INC*2)-1,HSTM=$P(NSTM,".",1)+DISBEG,HSTM=$S(HSTM<10:".0"_HSTM,1:"."_HSTM)
I NSTM\1'=NSTM S REM="."_$E($P(NSTM,".",2),1,3),MIN=REM*60+.1,HSTM=HSTM_$P(MIN,".",1)
S CKDATE=NDATE_HSTM,CKDATE=+CKDATE I $D(^DPT(+A,"S",CKDATE,0)),$P(^(0),"^",2)'["C" Q
S FND=1,GOT=1 F M=STM:SDDIF:STM+(NS*SDDIF)-2 S CHAR=$E(Z,M,M),WH=$F(STR,CHAR)-2,NC=$S(WH<1:0,1:$E(STR,WH,WH)),Z=$E(Z,1,M-1)_NC_$E(Z,M+1,99)
Q
STORE S SDINP=$$INP^SDAM2(+A,NDATE)
;S HOLD=SC_"^"_$$STATUS^SDM1A(SC,SDINP,NDATE)_"^"_$P(^DPT(+A,"S",GDATE,0),"^",3,5)_"^^"_$P(^(0),"^",7,9)_"^^"_$P(^(0),"^",11)_"^^"_$P(^(0),"^",13)_"^^^"_$P(^(0),"^",16)_"^^^"_DT_"^^^^^^A^0" ;IHS/ANMC/LJF 7/06/2000
S HOLD=SC_"^"_$$STATUS^SDM1A(SC,SDINP,NDATE)_"^"_$P(^DPT(+A,"S",GDATE,0),"^",3,5)_"^^"_$P(^(0),"^",7,9)_"^^"_$P(^(0),"^",11)_"^^"_$P(^(0),"^",13)_"^^^"_$P(^(0),"^",16)_"^^^"_$$NOW^XLFDT_"^^^^^^A^0" ;IHS/ANMC/LJF 7/06/2000
F XK=3,4,5 I $P(HOLD,"^",XK)]"" S TEMP=$P($P(HOLD,"^",XK),".",2) D FTM,FTM1 S TEMP=HNDATE_NTIM,$P(HOLD,"^",XK)=TEMP K SDINP
Q
FTM S HT1="."_$P(GDATE,".",2)+.000001,HT2="."_TEMP+.000001,HT3="."_$P(NDATE,".",2)+.000001,HH1=$E(HT1,1,3),MM1=$E(HT1,4,5),HH2=$E(HT2,1,3),MM2=$E(HT2,4,5)
I MM2>MM1 S MM1=MM1+60,HH1=HH1-.01
S MMD=MM1-MM2,HDIF=HH1-HH2 Q
FTM1 S HH3=$E(HT3,1,3),MM3=$E(HT3,4,5)
I MMD>MM3 S MM3=MM3+60,HH3=HH3-.01
S MMD2=MM3-MMD,HH3=HH3-HDIF,NTIM=HH3_MMD2,NTIM=+NTIM
Q
FTM3 S HH1="."_$E(SDTEST(XK),1,2),MM1=$E(SDTEST(XK),3,4),MM2=MM1+MMD S:MM2>59 MM2=MM2-60,HDIF=HDIF+.01 S HH2=HH1+HDIF,HH2=HH2*100 S:MM2>0 HH1=HH1+.01 S SDTEST(-(HH2))="" K SDTEST(XK)
Q
NO W !,"THIS CLINIC IS MISSING THE INCREMENTS PER HOUR FIELD, CANNOT REBOOK",! K ^UTILITY($J,"I") Q
;
EVT ; -- separate tag if need to NEW vars
; -- noshow event
I $D(SDNOSH) D NOSHOW^SDAMEVT(.SDATA,DFN,GDATE,SDSC,SDDA,0,SDABHDL)
; -- cancel event
I '$D(SDNOSH) D CANCEL^SDAMEVT(.SDATA,DFN,GDATE,SDSC,SDDA,0,SDABHDL)
; -- make appt evt
N NDATE,GDATE,A,SDCL,B,A8,SDCTRL,CNT,SDWH,SDCP,SDMSG,SDCTR K SDATA
D MAKE^SDAMEVT(DFN,SDTTM,SDSC,SDPL,0)
Q
SDAUT2 ;MAN/GRR - LOOK FOR OPEN SLOTS ; 3/3/05 12:08pm
+1 ;;5.3;Scheduling;**206,168,186,478,1015,1016**;Aug 13, 1993;Build 20
+2 ;IHS/ANMC/LJF 7/06/2000 hard set of date appt made now includes time
+3 ;
+4 KILL SDNOSH
EN1 SET (FND,DUPE)=0
SET NDATE=""
SET SDSOH=$SELECT('$DATA(^SC(SC,"SL")):0,$PIECE(^("SL"),"^",8)']"":0,1:1)
IF $SELECT('$DATA(^DPT(+A,.35)):0,$PIECE(^(.35),"^",1)']"":0,1:1)
SET MESS="NOT REBOOKED, PATIENT HAS DIED"
GOTO END
+1 SET MESS=""
KILL SDPAT
IF '$DATA(J)
SET SDPAT=""
FOR NDATE=SDSTRTDT-1:0
SET NDATE=$ORDER(^SC(SC,"ST",NDATE))
IF NDATE'>0!(NDATE>ENDATE)!(FND)
QUIT
IF ^(NDATE,1)["["
IF $EXTRACT(NDATE,6,7)
SET Z=^(1)
IF '$DATA(^HOLIDAY(NDATE))!(SDSOH)
SET HNDATE=NDATE
DO SRCH
IF FND
QUIT
+2 IF 'FND
IF $DATA(SDPAT)
SET NDATE=""
SET MESS="NOT REBOOKED, NO PATTERN FOUND"
GOTO END
+3 IF 'FND
SET NDATE=""
SET MESS="NOT REBOOKED, NO OPEN SLOTS"
GOTO END
+4 ;
+5 ;**186** MLR 11/30/00 Checking date for "non-cancelled" appointments
+6 DO DUPE
+7 ;
+8 NEW SDATA,SDDA,SDABHDL
SET SDDA=L
SET SDABHDL=$$HANDLE^SDAMEVT(1)
DO BEFORE^SDAMEVT(.SDATA,+A,GDATE,SC,SDDA,SDABHDL)
+9 SET NDATE=CKDATE
SET DNODE=^DPT(+A,"S",GDATE,0)
SET $PIECE(DNODE,"^",2)=$SELECT($DATA(SDNOSH):"NA",$DATA(SDCP):$SELECT(SDCP:"PCA",1:"CA"),1:"CA")
SET $PIECE(DNODE,"^",10)=NDATE
DO STORE
SET ^DPT(+A,"S",NDATE,0)=HOLD
SET ^DPT(+A,"S",GDATE,0)=DNODE
SET ^SC(SC,"S",NDATE,1,0)="^44.003PA^^"
+10 ;xref DATE APPT. MADE field
+11 Begin DoDot:1
+12 NEW DIV,DA,DIK
+13 SET DA=NDATE
SET DA(1)=+A
SET DIK="^DPT(DA(1),""S"","
SET DIK(1)=20
DO EN1^DIK
+14 QUIT
End DoDot:1
+15 IF '$DATA(SDCP)
SET SDNODE=^SC(SC,"S",GDATE,1,L,0)
+16 ;
+17 ;IHS/ANMC/LJF 7/06/2000
+18 ;S ^SC(SC,"ST",HNDATE,1)=Z,^SC(SC,"S",NDATE,0)=NDATE F Y=1:1 I '$D(^SC(SC,"S",NDATE,1,Y)) S ^(Y,0)=+A_"^"_LEN,$P(^SC(SC,"S",NDATE,1,Y,0),"^",4,8)=$P(SDNODE,"^",4)_"^^"_$S($D(DUZ):DUZ,1:"")_"^"_DT_"^"_$P(SDNODE,"^",8) Q
+19 ;ihs/cmi/maw 11/7/2012 PIMS 1016 remove lindas code and use va but make DT NOW^XLFDT
+20 ;S ^SC(SC,"ST",HNDATE,1)=Z,^SC(SC,"S",NDATE,0)=NDATE F Y=1:1 I '$D(^SC(SC,"S",NDATE,1,Y)) S ^(Y,0)=+A_"^"_LEN,$P(^SC(SC,"S",NDATE,1,Y,0),"^",4,8)=$P(SDNODE,"^",4)_"^^"_$S($D(DUZ):DUZ,1:"")_"^"_$$NOW^XLFDT_"^"_$P(SDNODE,"^",8) Q
+21 ;
+22 NEW LNK,CY
+23 ;SD/478
KILL QT
SET ^SC(SC,"ST",HNDATE,1)=Z
SET ^SC(SC,"S",NDATE,0)=NDATE
FOR CY=1:1
IF '$DATA(^SC(SC,"S",NDATE,1,CY))
Begin DoDot:1
+24 ;S ^(CY,0)=+A_"^"_LEN,$P(^SC(SC,"S",NDATE,1,CY,0),"^",4,8)=$P(SDNODE,"^",4)_"^^"_$S($D(DUZ):DUZ,1:"")_"^"_DT_"^"_$P(SDNODE,"^",8) ;SD/478
+25 ;ihs/cmi/maw 11/7/2012 PATCH 1016 change DT to NOW^XLFDT
SET ^(CY,0)=+A_"^"_LEN
SET $PIECE(^SC(SC,"S",NDATE,1,CY,0),"^",4,8)=$PIECE(SDNODE,"^",4)_"^^"_$SELECT($DATA(DUZ):DUZ,1:"")_"^"_$$NOW^XLFDT_"^"_$P(SDNODE,"^",8)
+26 ;SD/478
SET TPAT=$PIECE(SDNODE,U)
IF $DATA(AUTO(SC,$SELECT($DATA(SDCP):SD,1:GDATE),TPAT))
SET LNK=AUTO(SC,GDATE,TPAT)
DO AUTOREB^SDCNSLT(SC,NDATE,LNK,CY)
+27 ;SD/478
SET QT=""
End DoDot:1
IF $DATA(QT)
QUIT
+28 ;SD/478
SET $PIECE(^SC(SC,"S",NDATE,1,CY,0),"^",10)=$PIECE(SDNODE,"^",10)
+29 IF $DATA(^SC("ARAD",SC,GDATE,+A))
SET ^SC("ARAD",SC,NDATE,+A)=""
+30 ;SD/478
SET SDTTM=NDATE
SET SDPL=CY
SET SDSC=SC
SET DFN=+A
SET SDRT="A"
DO RT^SDUTL
DO EVT
END KILL ARG,BTIM,CKDATE,CNT,DIF,DISBEG,DNODE,FND,GOT,HDIF,HH1,HH2,HH3,HNDATE,HOLD,HSTM,HT1,HT2,HT3,INC,INCM,J,K,LEN,M,MM1,MM2,MM3,MMD,MMD2,NC,NS,NSTM,NTIM,REM,SDPAT,SDPL,SDSC,SDT20,SDTEST,SDTTM,STM,STR,TEMP,TM,WH,XK,^UTILITY($JOB,"I")
+1 QUIT
+2 ;
DUPE ;**186** MLR Checking date for "non-cancelled" appointments prior to
+1 ;11/30/00 setting "MULTIPLE APPNTS. ON CANCELLED DATE" message
+2 NEW I
SET I=$PIECE(GDATE,".")
SET DUPE=0
+3 FOR
SET I=$ORDER(^DPT(+A,"S",I))
IF 'I!DUPE!($PIECE(I,".")>GDATE)
QUIT
Begin DoDot:1
+4 IF I=GDATE
QUIT
+5 IF $PIECE(^DPT(+A,"S",I,0),U,2)="I"
SET DUPE=1
QUIT
+6 IF $PIECE(^DPT(+A,"S",I,0),U,2)=""
SET DUPE=1
QUIT
+7 QUIT
End DoDot:1
+8 ;DUPE
QUIT
+9 ;
SRCH IF $DATA(SDCP)
IF (GDATE\1)=NDATE
QUIT
+1 SET LEN=$PIECE(A,"^",2)
SET INC=$PIECE(^SC(SC,"SL"),"^",6)
SET DISBEG=$PIECE(^("SL"),"^",3)
SET STR="123456789jklmnopqrstuvwxyz"
SET INCM=$SELECT(INC=4:15,INC=3:20,INC=6:10,INC=2:30,INC=1:60,1:0)
IF INCM=0
GOTO NO
SET SDDIF=$SELECT(INC<3:8/INC,1:2)
KILL SDTEST
NEW SDIV
SET SDIV=""
+2 IF $DATA(^SC(+SC,0))
SET SDIV=$SELECT('$PIECE(^(0),"^",15):$ORDER(^DG(40.8,0)),1:$PIECE(^(0),"^",15))
IF $DATA(^DG(40.8,+SDIV,"LTR"))
FOR XK=3,4,5
IF $PIECE(^DPT(+A,"S",GDATE,0),"^",XK)]""
SET TEMP=$PIECE($PIECE(^(0),"^",XK),".",2)
SET SDTEST(XK)=$PIECE(^DG(40.8,SDIV,"LTR"),"^",(XK-1))
DO FTM
DO FTM3
+3 SET BTIM=$SELECT($DATA(^SC(SC,"SDP")):$PIECE(^("SDP"),"^",3),1:"")
SET BTIM=$SELECT($EXTRACT(+$ORDER(SDTEST("")),2,999)>BTIM:$EXTRACT(+$ORDER(SDTEST("")),2,999),1:BTIM)
IF DISBEG=""
SET DISBEG=8
+4 SET NS=LEN\INCM
SET ST=$FIND(Z,"[")
SET GOT=0
SET INC=$SELECT(INC<3:4,1:INC)
+5 IF BTIM]""
SET ARG=INC*2
SET DIF=BTIM-DISBEG
IF DIF>0
SET ST=DIF*ARG+ARG+1
+6 SET CNT=0
FOR J=0:SDDIF:80
IF $EXTRACT(Z,ST+J,80)'["]"
QUIT
SET K=$EXTRACT(Z,ST+J)
SET CNT=$SELECT(K]""&(STR[K):CNT+1,1:0)
IF $SELECT(STR[K
SET SDST=$FIND(Z,"[",ST+J)
SET J=$SELECT('SDST:80,1:SDST-SDDIF-ST)
IF CNT=NS
DO MORE
IF GOT
QUIT
SET CNT=0
+7 QUIT
MORE SET TM=(NS-1)*SDDIF
SET STM=ST+J-TM
SET NSTM=STM-1/(INC*2)-1
SET HSTM=$PIECE(NSTM,".",1)+DISBEG
SET HSTM=$SELECT(HSTM<10:".0"_HSTM,1:"."_HSTM)
+1 IF NSTM\1'=NSTM
SET REM="."_$EXTRACT($PIECE(NSTM,".",2),1,3)
SET MIN=REM*60+.1
SET HSTM=HSTM_$PIECE(MIN,".",1)
+2 SET CKDATE=NDATE_HSTM
SET CKDATE=+CKDATE
IF $DATA(^DPT(+A,"S",CKDATE,0))
IF $PIECE(^(0),"^",2)'["C"
QUIT
+3 SET FND=1
SET GOT=1
FOR M=STM:SDDIF:STM+(NS*SDDIF)-2
SET CHAR=$EXTRACT(Z,M,M)
SET WH=$FIND(STR,CHAR)-2
SET NC=$SELECT(WH<1:0,1:$EXTRACT(STR,WH,WH))
SET Z=$EXTRACT(Z,1,M-1)_NC_$EXTRACT(Z,M+1,99)
+4 QUIT
STORE SET SDINP=$$INP^SDAM2(+A,NDATE)
+1 ;S HOLD=SC_"^"_$$STATUS^SDM1A(SC,SDINP,NDATE)_"^"_$P(^DPT(+A,"S",GDATE,0),"^",3,5)_"^^"_$P(^(0),"^",7,9)_"^^"_$P(^(0),"^",11)_"^^"_$P(^(0),"^",13)_"^^^"_$P(^(0),"^",16)_"^^^"_DT_"^^^^^^A^0" ;IHS/ANMC/LJF 7/06/2000
+2 ;IHS/ANMC/LJF 7/06/2000
SET HOLD=SC_"^"_$$STATUS^SDM1A(SC,SDINP,NDATE)_"^"_$PIECE(^DPT(+A,"S",GDATE,0),"^",3,5)_"^^"_$PIECE(^(0),"^",7,9)_"^^"_$PIECE(^(0),"^",11)_"^^"_$PIECE(^(0),"^",13)_"^^^"_$PIECE(^(0),"^",16)_"^^^"_$$NOW^XLFDT_"^^^^^^A^0"
+3 FOR XK=3,4,5
IF $PIECE(HOLD,"^",XK)]""
SET TEMP=$PIECE($PIECE(HOLD,"^",XK),".",2)
DO FTM
DO FTM1
SET TEMP=HNDATE_NTIM
SET $PIECE(HOLD,"^",XK)=TEMP
KILL SDINP
+4 QUIT
FTM SET HT1="."_$PIECE(GDATE,".",2)+.000001
SET HT2="."_TEMP+.000001
SET HT3="."_$PIECE(NDATE,".",2)+.000001
SET HH1=$EXTRACT(HT1,1,3)
SET MM1=$EXTRACT(HT1,4,5)
SET HH2=$EXTRACT(HT2,1,3)
SET MM2=$EXTRACT(HT2,4,5)
+1 IF MM2>MM1
SET MM1=MM1+60
SET HH1=HH1-.01
+2 SET MMD=MM1-MM2
SET HDIF=HH1-HH2
QUIT
FTM1 SET HH3=$EXTRACT(HT3,1,3)
SET MM3=$EXTRACT(HT3,4,5)
+1 IF MMD>MM3
SET MM3=MM3+60
SET HH3=HH3-.01
+2 SET MMD2=MM3-MMD
SET HH3=HH3-HDIF
SET NTIM=HH3_MMD2
SET NTIM=+NTIM
+3 QUIT
FTM3 SET HH1="."_$EXTRACT(SDTEST(XK),1,2)
SET MM1=$EXTRACT(SDTEST(XK),3,4)
SET MM2=MM1+MMD
IF MM2>59
SET MM2=MM2-60
SET HDIF=HDIF+.01
SET HH2=HH1+HDIF
SET HH2=HH2*100
IF MM2>0
SET HH1=HH1+.01
SET SDTEST(-(HH2))=""
KILL SDTEST(XK)
+1 QUIT
NO WRITE !,"THIS CLINIC IS MISSING THE INCREMENTS PER HOUR FIELD, CANNOT REBOOK",!
KILL ^UTILITY($JOB,"I")
QUIT
+1 ;
EVT ; -- separate tag if need to NEW vars
+1 ; -- noshow event
+2 IF $DATA(SDNOSH)
DO NOSHOW^SDAMEVT(.SDATA,DFN,GDATE,SDSC,SDDA,0,SDABHDL)
+3 ; -- cancel event
+4 IF '$DATA(SDNOSH)
DO CANCEL^SDAMEVT(.SDATA,DFN,GDATE,SDSC,SDDA,0,SDABHDL)
+5 ; -- make appt evt
+6 NEW NDATE,GDATE,A,SDCL,B,A8,SDCTRL,CNT,SDWH,SDCP,SDMSG,SDCTR
KILL SDATA
+7 DO MAKE^SDAMEVT(DFN,SDTTM,SDSC,SDPL,0)
+8 QUIT
