- SDAUT2 ;MAN/GRR - LOOK FOR OPEN SLOTS ;JAN 15, 2016
- ;;5.3;Scheduling;**206,168,186,478,627**;Aug 13, 1993;Build 249
- 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)
- 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 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"
- 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)
- N SDGDATE S SDGDATE=GDATE ;ALB/SAT 627 - save prev appt datetime
- ; -- 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)
- ;ALB/SAT 627 - also change SDEC files on auto rebook
- D ADDSDEC(DFN,SDTTM,SDSC,SDGDATE)
- Q
- ADDSDEC(DFN,SD,SC,SDGDATE) ;ALB/SAT 627 - Add SDEC file changes
- N APIEN,APPTYPE,EESTAT,FOUND,PROVIEN
- N SDAPTYP,SDDDT,SDECATID,SDECEND,SDECNOTE,SDECRESD
- N STATUS,WALKIN,ZNODE
- S FOUND=0
- S APIEN="" F S APIEN=$O(^SDEC(409.84,"B",SDGDATE,APIEN)) Q:APIEN=""!(FOUND) D
- .I $P(^SDEC(409.84,APIEN,0),U,5)=DFN D
- ..S ZNODE=^SDEC(409.84,APIEN,0),FOUND=1
- ..S SDECEND=$P(ZNODE,U,2)
- ..S APPTYPE=$P(ZNODE,U,6)
- ..S SDECRESD=$P(ZNODE,U,7)
- ..S WALKIN=$P(ZNODE,U,13)
- ..S PROVIEN=$P(ZNODE,U,16)
- ..S STATUS=$P(ZNODE,U,17)
- ..S SDDDT=$P(ZNODE,U,20)
- ..S SDAPTYP=$P(^SDEC(409.84,APIEN,2),U)
- ..S EESTAT=$P(^SDEC(409.84,APIEN,2),U,2)
- ..S SDECNOTE=$$GETNOTE(APIEN)
- Q:'FOUND
- S SDAPTYP=$S($P(SDAPTYP,";",2)="SDWL(409.3,":"E",$P(SDAPTYP,";",2)="GMR(123,":"C",$P(SDAPTYP,";",2)="SD(403.5,":"R",$P(SDAPTYP,";",2)="SDEC(409.85,":"A",1:"")_"|"_$P(SDAPTYP,";")
- S SDECATID=$S(WALKIN="y":"WALKIN",1:0)
- D SDECADD^SDEC07(SD,SDECEND,DFN,SDECRESD,SDECATID,SDDDT,"",SDAPTYP,PROVIEN,SC,SDECNOTE,SD,"",APPTYPE,EESTAT)
- I $P(SDAPTYP,"|")="A" D
- .N RET,INP,ARIEN
- .S ARIEN=$P(SDAPTYP,"|",2)
- .S INP(1)=ARIEN,INP(2)="SA",INP(3)=$G(DUZ),INP(4)=DT
- .D ARCLOSE1^SDEC(.RET,.INP)
- Q
- GETNOTE(APIEN) ;ALB/SAT 627 - Add SDEC file changes
- N SDECIEN,SDNOTE
- S SDNOTE=""
- I $D(^SDEC(409.84,APIEN,1)) D
- .S SDECIEN=0 F S SDECIEN=$O(^SDEC(409.84,APIEN,1,SDECIEN)) Q:'+SDECIEN D
- ..S SDNOTE=SDNOTE_$G(^SDEC(409.84,APIEN,1,SDECIEN,0))
- Q SDNOTE
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAUT2 6912 printed Feb 19, 2025@00:15 Page 2
- SDAUT2 ;MAN/GRR - LOOK FOR OPEN SLOTS ;JAN 15, 2016
- +1 ;;5.3;Scheduling;**206,168,186,478,627**;Aug 13, 1993;Build 249
- +2 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 NEW LNK,CY
- +17 ;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
- +18 ;SD/478
- SET ^(CY,0)=+A_"^"_LEN
- SET $PIECE(^SC(SC,"S",NDATE,1,CY,0),"^",4,8)=$PIECE(SDNODE,"^",4)_"^^"_$SELECT($DATA(DUZ):DUZ,1:"")_"^"_DT_"^"_$PIECE(SDNODE,"^",8)
- +19 ;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)
- +20 ;SD/478
- SET QT=""
- End DoDot:1
- if $DATA(QT)
- QUIT
- +21 ;SD/478
- SET $PIECE(^SC(SC,"S",NDATE,1,CY,0),"^",10)=$PIECE(SDNODE,"^",10)
- +22 IF $DATA(^SC("ARAD",SC,GDATE,+A))
- SET ^SC("ARAD",SC,NDATE,+A)=""
- +23 ;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 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)_"^^^"_DT_"^^^^^^A^0"
- +2 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
- +3 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 ;ALB/SAT 627 - save prev appt datetime
- NEW SDGDATE
- SET SDGDATE=GDATE
- +6 ; -- make appt evt
- +7 NEW NDATE,GDATE,A,SDCL,B,A8,SDCTRL,CNT,SDWH,SDCP,SDMSG,SDCTR
- KILL SDATA
- +8 DO MAKE^SDAMEVT(DFN,SDTTM,SDSC,SDPL,0)
- +9 ;ALB/SAT 627 - also change SDEC files on auto rebook
- +10 DO ADDSDEC(DFN,SDTTM,SDSC,SDGDATE)
- +11 QUIT
- ADDSDEC(DFN,SD,SC,SDGDATE) ;ALB/SAT 627 - Add SDEC file changes
- +1 NEW APIEN,APPTYPE,EESTAT,FOUND,PROVIEN
- +2 NEW SDAPTYP,SDDDT,SDECATID,SDECEND,SDECNOTE,SDECRESD
- +3 NEW STATUS,WALKIN,ZNODE
- +4 SET FOUND=0
- +5 SET APIEN=""
- FOR
- SET APIEN=$ORDER(^SDEC(409.84,"B",SDGDATE,APIEN))
- if APIEN=""!(FOUND)
- QUIT
- Begin DoDot:1
- +6 IF $PIECE(^SDEC(409.84,APIEN,0),U,5)=DFN
- Begin DoDot:2
- +7 SET ZNODE=^SDEC(409.84,APIEN,0)
- SET FOUND=1
- +8 SET SDECEND=$PIECE(ZNODE,U,2)
- +9 SET APPTYPE=$PIECE(ZNODE,U,6)
- +10 SET SDECRESD=$PIECE(ZNODE,U,7)
- +11 SET WALKIN=$PIECE(ZNODE,U,13)
- +12 SET PROVIEN=$PIECE(ZNODE,U,16)
- +13 SET STATUS=$PIECE(ZNODE,U,17)
- +14 SET SDDDT=$PIECE(ZNODE,U,20)
- +15 SET SDAPTYP=$PIECE(^SDEC(409.84,APIEN,2),U)
- +16 SET EESTAT=$PIECE(^SDEC(409.84,APIEN,2),U,2)
- +17 SET SDECNOTE=$$GETNOTE(APIEN)
- End DoDot:2
- End DoDot:1
- +18 if 'FOUND
- QUIT
- +19 SET SDAPTYP=$SELECT($PIECE(SDAPTYP,";",2)="SDWL(409.3,":"E",$PIECE(SDAPTYP,";",2)="GMR(123,":"C",$PIECE(SDAPTYP,";",2)="SD(403.5,":"R",$PIECE(SDAPTYP,";",2)="SDEC(409.85,":"A",1:"")_"|"_$PIECE(SDAPTYP,";")
- +20 SET SDECATID=$SELECT(WALKIN="y":"WALKIN",1:0)
- +21 DO SDECADD^SDEC07(SD,SDECEND,DFN,SDECRESD,SDECATID,SDDDT,"",SDAPTYP,PROVIEN,SC,SDECNOTE,SD,"",APPTYPE,EESTAT)
- +22 IF $PIECE(SDAPTYP,"|")="A"
- Begin DoDot:1
- +23 NEW RET,INP,ARIEN
- +24 SET ARIEN=$PIECE(SDAPTYP,"|",2)
- +25 SET INP(1)=ARIEN
- SET INP(2)="SA"
- SET INP(3)=$GET(DUZ)
- SET INP(4)=DT
- +26 DO ARCLOSE1^SDEC(.RET,.INP)
- End DoDot:1
- +27 QUIT
- GETNOTE(APIEN) ;ALB/SAT 627 - Add SDEC file changes
- +1 NEW SDECIEN,SDNOTE
- +2 SET SDNOTE=""
- +3 IF $DATA(^SDEC(409.84,APIEN,1))
- Begin DoDot:1
- +4 SET SDECIEN=0
- FOR
- SET SDECIEN=$ORDER(^SDEC(409.84,APIEN,1,SDECIEN))
- if '+SDECIEN
- QUIT
- Begin DoDot:2
- +5 SET SDNOTE=SDNOTE_$GET(^SDEC(409.84,APIEN,1,SDECIEN,0))
- End DoDot:2
- End DoDot:1
- +6 QUIT SDNOTE