SDC0 ;MAN/GRR,ALB/TMP/LDB - Continuation of SDC (cancel a clinic) ; 16 JUL 2003 1:27 pm
;;5.3;PIMS;**303,330,379,398,467,478,1002,1011,1015,1016**;JUN 30, 2012;Build 20
;
;IHS/ANMC/LJF 8/18/2000 changed $N to $O
; changed defaults to NO
;
;SD/467 - open matched EWL entries with canceled appointments
;
CHKEND G:$G(NOAP) END ;ihs/cmi/maw 07/17/2012 PATCH 1015 added $G
;S %=1,DTOUT=0 W !,"WANT TO AUTO-REBOOK APPOINTMENTS NOW" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G CHKEND ;IHS/ANMC/LJF 8/18/2000
S %=2,DTOUT=0 W !,"WANT TO AUTO-REBOOK APPOINTMENTS NOW" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G CHKEND ;IHS/ANMC/LJF 8/18/2000
S ANS=$S('(%-1):"Y",1:"N") I %<0 W " NO" Q:'DTOUT
ASKL ;S SDLT1="",%=1,(SDLET,SDFORM)="" W !,"WANT LETTERS PRINTED NOW" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G ASKL ;IHS/ANMC/LJF 8/18/2000
S SDLT1="",%=2,(SDLET,SDFORM)="" W !,"WANT LETTERS PRINTED NOW" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G ASKL ;IHS/ANMC/LJF 8/18/2000
W:%<0 " NO" S ALS=$S('(%-1):"Y",1:"N") G:ALS'["Y" AOR
EN ;Q:($P(^SC(SC,0),"^",3)'="C")!($D(SDVAUTC(+SC))) S SDIV=$P(^SC(SC,0),"^",15),SDIV=$S(SDIV:SDIV,1:$N(^DG(40.8,0))) I $D(SDLT),SDIV'=SDV1 Q ;IHS/ANMCLJF 8/18/2000
Q:($P(^SC(SC,0),"^",3)'="C")!($D(SDVAUTC(+SC))) S SDIV=$P(^SC(SC,0),"^",15),SDIV=$S(SDIV:SDIV,1:$O(^DG(40.8,0))) I $D(SDLT),SDIV'=SDV1 Q ;IHS/ANMC/LJF 8/18/2000
K SDRE,SDIN I $D(SDLT)&($D(^SC(SC,"I"))) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2) I $D(SDIN),SDIN,SDIN'>SDBD&('$D(SDRE)!('SDRE)!(SDRE>SDED)) Q
S:'SDLT1 SDLET=$S($D(^SC(SC,"LTR")):$P(^("LTR"),"^",3),1:"") S ALS=$S(SDLET:"Y",1:"N")
I ALS="N"!(ANS="Y") S SDFFFF=1
I ALS="N" W !,"NO LETTERS ARE ASSIGNED TO THE ",$P(^SC(SC,0),"^")," CLINIC" Q:$D(SDLT)
I SDFORM="",$D(^DG(40.8,SDIV,"LTR")),^("LTR") S SDFORM=^("LTR")
I $D(SDLT),(ALS'="N") D CHK Q
Q:$D(SDLT)
AOR G:ANS'["Y"&(ALS'["Y") END
I '$D(SDLT) S DGPGM="START^SDC0",DGVAR="SC^SI^CDATE^ALS^ANS^SDLET^SDTIME"_$S($D(SDIN):"^SDIN^SDRE",1:"")_"^SDFORM^SDV1^SDFFFF^AUTO#"
;I '$D(SDLT) D FZIS^DGUTQ G:POP END
I '$D(SDLT) D ZIS^DGUTQ G:POP END ;ihs/cmi/maw 11/6/2012 PATCH 1016
START U IO I ANS'["Y"&('$D(SDLT)) D:ALS["Y" APP D END Q
BEG1 N SDFIRST
I $D(SDLT) S SDAR=$S('VAUTC:"VAUTC",1:"^SC"),ANS="N",ALS="Y" D
.F SC=0:0 S SC=$O(@(SDAR_"("_SC_")")) Q:SC'>0 D
..K SDOK1 D EN I $D(SDOK1),SDLET D
...F SD=(SDBD-.1):0 S SD=$O(^SC(SC,"S",SD)) S CDATE=SD Q:SD>(SDED+.999999)!(SD'>0) D
....D DUP
S SDFIRST=$S($G(SDFFFF)=1:0,1:1)
I $D(SDLT),$D(^UTILITY("SDLT",$J)) D PR^SDC3,END Q
Q:$D(SDLT) D ^SDAUT1
I MAX=0 W !,"AUTO-REBOOKING NOT ALLOWED FOR THIS CLINIC" G APP:ALS["Y",END
F GDATE=CDATE:0 S GDATE=$O(^SC(SC,"S",GDATE)) Q:GDATE=""!(GDATE>(CDATE+1)) D
.F L=0:0 S L=$O(^SC(SC,"S",GDATE,1,L)) Q:L="" D Q:POP S A=^SC(SC,"S",GDATE,1,L,0) I $D(^DPT(+A,"S",GDATE,0)),$P(^(0),"^",2)="C",$P(^(0),"^",14)=SDTIME D ^SDAUT2,^SDCCP
..S POP=0
..I '$D(^SC(SC,"S",GDATE,1,L,0)) I $D(^("C")) S J=GDATE,J2=L D DELETE^SDC1 K J,J2 S POP=1 Q ;SD*545 delete corrupt record
..I '+$G(^SC(SC,"S",GDATE,1,L,0)) S J=GDATE,J2=L D DELETE^SDC1 K J,J2 S POP=1 Q ;SD*545 delete corrupt record
K POP
W @IOF ;IHS/ITSC/WAR 1/12/05 PATCH #1002 Needed a formfeed after autobook Rpt & prior to letters printing
D:ALS["Y" APP
END ;
D:$G(SC)>0&($G(CDATE)>0) RESOLVE
K %,%DT,%H,%I,%DT,%IS,%ZIS,A,ALS,ANS,BY,CDATE,CHAR,DA,DFN,DH,DHD,DIC,DIS,DO,DOW,FLDS,FR,GDATE,I,L,LET,MAX,NOAP,P,POP,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B,CLIN,HX,L0,L1,L2,LL,PDAT,S,TIME,Z,D,ENDATE,J,SM,STIME,X1,X2,SDX1,SDX2,SDRE,SDRE1,SDIN,FSW
K ^TMP("SDC0",$J),SDAP,SDAPNUM
K SC,SD,Z0,Z5,DGPGM,DUPE,J2,MESS,NDATE,SDDIF,SDFORM,SDINP,SDFORM,SDLET,SDLT1,SDNODE,SDRT,SDSOH,SDST,SDV1,DGVAR,SD1,SD8,SD81,SDANS,SDCNT,SDERR,SDHTO,SDJ,SDTIME,SDZ,STARTDAY,SD82,SDOK,SDOK1,SDLE,SDZ,SDOK1,TST,W,^UTILITY("SD")
K SDFFFF,DIW,DIWF,DIWL,DIWR,DIWT,DN,DUPE,J2,MESS,NDATE,SDADD,SDC,SDCL,SDDAT,SDDIF,SDFORM,SDHX,SDINP,SDIV,SDLET,SDNODE,SDRT,SDSOH,SDST,SDT0,TST,SDV1,^TMP($J,"BADADD") D CLOSE^DGUTQ Q
CHK K SDOK1 I $D(^SC(SC,"SL")) S SL=^("SL"),%=$P(SL,"^",6),SI=$S(%="":4,%<3:4,%:%,1:4) S SDOK1=1 K SL,% E W $P(^SC(SC,0),"^")," does not have an appointment length indicated."
Q
RESOLVE ;evaluate canceled and rebooked appointments with relation to EWL
S GDATE=CDATE K ^TMP("SDWLREB",$J),^TMP($J,"SDWLPL")
F S GDATE=$O(^SC(SC,"S",GDATE)) Q:GDATE=""!(GDATE>(CDATE+1)) S L=0 F S L=$O(^SC(SC,"S",GDATE,1,L)) Q:L="" D
.I '$D(^SC(SC,"S",GDATE,1,L,0)) I $D(^("C")) S J=GDATE,J2=L D DELETE^SDC1 K J,J2 Q ;SD*5.3*545 delete corrupt record
.I '+$G(^SC(SC,"S",GDATE,1,L,0)) S J=GDATE,J2=L D DELETE^SDC1 K J,J2 Q ;SD*5.3*545 delete corrupt record with missing DFN
.S DFN=+^SC(SC,"S",GDATE,1,L,0)
.N RBFLG,SDTRB,SDCAN,SDREB S SDREB=0 D REBOOK^SDWLREB(DFN,GDATE,SC,.RBFLG,.SDTRB,.SDCAN) Q:SDCAN'=SDTIME
.I $E(RBFLG,1,2)'="CC" Q ;not canceled by clinic
.I RBFLG="CCR" S SDREB=1 D DISREB^SDWLREB(DFN,SDTRB,SC)
.D OPENEWL^SDWLREB(DFN,GDATE,SC,SDREB) K ^TMP($J,"APPT"),^TMP($J,"SDWLPL")
I $D(^TMP("SDWLREB",$J)) D MESS^SDWLREB
Q
;
DUP ;SCREEN FOR DUPLICATE PATIENTS - SD*5.3*379
S SDAP="" F S SDAP=$O(^SC(SC,"S",SD,SDAP)) Q:SDAP="" D
.S SDAPNUM="" F S SDAPNUM=$O(^SC(SC,"S",SD,SDAP,SDAPNUM)) Q:SDAPNUM="" D
..I '$D(^SC(SC,"S",SD,SDAP,SDAPNUM,0)) I $D(^("C")) S J=SD,J2=SDAPNUM D DELETE^SDC1 Q ;SD*545 delete corrupt record
..I '+$G(^SC(SC,"S",SD,SDAP,SDAPNUM,0)) S J=SD,J2=SDAPNUM D DELETE^SDC1 Q ;SD*545 if DFN missing delete record
..I $D(^SC(SC,"S",SD,SDAP,SDAPNUM,0)) D
...S A=$P(^SC(SC,"S",SD,SDAP,SDAPNUM,0),"^",1)
...I '$D(^TMP("SDC0",$J,SD,A)) S ^TMP("SDC0",$J,SD,A)="" D ^SDC3
Q
APP I $G(SDFFFF)=1 S SDFIRST=0
F GDATE=CDATE:0 S GDATE=$O(^SC(+SC,"S",GDATE)) Q:GDATE=""!(GDATE>(CDATE+1)) F L=0:0 S L=$O(^SC(+SC,"S",GDATE,1,L)) Q:L="" D Q:POP S A=^SC(+SC,"S",GDATE,1,L,0) D CHECK
.S POP=0
.I '$D(^SC(+SC,"S",GDATE,1,L,0)) I $D(^("C")) S J=GDATE,J2=L D DELETE^SDC1 K J,J2 S POP=1 Q ;SD*545 delete corrupt record
.I '+$G(^SC(+SC,"S",GDATE,1,L,0)) S J=GDATE,J2=L D DELETE^SDC1 K J,J2 S POP=1 Q ;SD*545 if DFN missing delete record
.Q
K POP
I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD")
Q
CHK1 S (SDX,X)=GDATE D WRAPP^SDLT
I $P(S,"^",2)'["A" D REST^SDLT Q
S SDX=$P(S,"^",10) I '$D(^DPT(+A,"S",SDX,0)) D REST^SDLT Q
W !!,"The cancelled appointment(s) were rescheduled as follows:",!
S S=^DPT(+A,"S",SDX,0) D WRAPP^SDLT,REST^SDLT
Q
CHECK I $$BADADR^DGUTL3(+A) S ^TMP($J,"BADADD",$P(^DPT(+A,0),"^"),+A)="" Q
;
;SCREEN FOR DUPLICATES - SD*5.3*379
;
I $D(^TMP("SDC0",$J,GDATE,A)) Q
S ^TMP("SDC0",$J,GDATE,A)=""
I $S('$D(^DPT(+A,.35)):1,$P(^DPT(+A,.35),"^",1)']"":1,1:0),$D(^DPT(+A,"S",GDATE)),$P(^DPT(+A,"S",GDATE,0),"^",2)["C",$P(^(0),"^",14)=SDTIME!(SDTIME="*") S S=^DPT(+A,"S",GDATE,0) D ^SDLT,CHK1
SDC0 ;MAN/GRR,ALB/TMP/LDB - Continuation of SDC (cancel a clinic) ; 16 JUL 2003 1:27 pm
+1 ;;5.3;PIMS;**303,330,379,398,467,478,1002,1011,1015,1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;IHS/ANMC/LJF 8/18/2000 changed $N to $O
+4 ; changed defaults to NO
+5 ;
+6 ;SD/467 - open matched EWL entries with canceled appointments
+7 ;
CHKEND ;ihs/cmi/maw 07/17/2012 PATCH 1015 added $G
IF $GET(NOAP)
GOTO END
+1 ;S %=1,DTOUT=0 W !,"WANT TO AUTO-REBOOK APPOINTMENTS NOW" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G CHKEND ;IHS/ANMC/LJF 8/18/2000
+2 ;IHS/ANMC/LJF 8/18/2000
SET %=2
SET DTOUT=0
WRITE !,"WANT TO AUTO-REBOOK APPOINTMENTS NOW"
DO YN^DICN
IF '%
WRITE !,"REPLY YES (Y) OR NO (N)"
GOTO CHKEND
+3 SET ANS=$SELECT('(%-1):"Y",1:"N")
IF %<0
WRITE " NO"
IF 'DTOUT
QUIT
ASKL ;S SDLT1="",%=1,(SDLET,SDFORM)="" W !,"WANT LETTERS PRINTED NOW" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G ASKL ;IHS/ANMC/LJF 8/18/2000
+1 ;IHS/ANMC/LJF 8/18/2000
SET SDLT1=""
SET %=2
SET (SDLET,SDFORM)=""
WRITE !,"WANT LETTERS PRINTED NOW"
DO YN^DICN
IF '%
WRITE !,"REPLY YES (Y) OR NO (N)"
GOTO ASKL
+2 IF %<0
WRITE " NO"
SET ALS=$SELECT('(%-1):"Y",1:"N")
IF ALS'["Y"
GOTO AOR
EN ;Q:($P(^SC(SC,0),"^",3)'="C")!($D(SDVAUTC(+SC))) S SDIV=$P(^SC(SC,0),"^",15),SDIV=$S(SDIV:SDIV,1:$N(^DG(40.8,0))) I $D(SDLT),SDIV'=SDV1 Q ;IHS/ANMCLJF 8/18/2000
+1 ;IHS/ANMC/LJF 8/18/2000
IF ($PIECE(^SC(SC,0),"^",3)'="C")!($DATA(SDVAUTC(+SC)))
QUIT
SET SDIV=$PIECE(^SC(SC,0),"^",15)
SET SDIV=$SELECT(SDIV:SDIV,1:$ORDER(^DG(40.8,0)))
IF $DATA(SDLT)
IF SDIV'=SDV1
QUIT
+2 KILL SDRE,SDIN
IF $DATA(SDLT)&($DATA(^SC(SC,"I")))
SET SDIN=+^("I")
SET SDRE=+$PIECE(^("I"),"^",2)
IF $DATA(SDIN)
IF SDIN
IF SDIN'>SDBD&('$DATA(SDRE)!('SDRE)!(SDRE>SDED))
QUIT
+3 IF 'SDLT1
SET SDLET=$SELECT($DATA(^SC(SC,"LTR")):$PIECE(^("LTR"),"^",3),1:"")
SET ALS=$SELECT(SDLET:"Y",1:"N")
+4 IF ALS="N"!(ANS="Y")
SET SDFFFF=1
+5 IF ALS="N"
WRITE !,"NO LETTERS ARE ASSIGNED TO THE ",$PIECE(^SC(SC,0),"^")," CLINIC"
IF $DATA(SDLT)
QUIT
+6 IF SDFORM=""
IF $DATA(^DG(40.8,SDIV,"LTR"))
IF ^("LTR")
SET SDFORM=^("LTR")
+7 IF $DATA(SDLT)
IF (ALS'="N")
DO CHK
QUIT
+8 IF $DATA(SDLT)
QUIT
AOR IF ANS'["Y"&(ALS'["Y")
GOTO END
+1 IF '$DATA(SDLT)
SET DGPGM="START^SDC0"
SET DGVAR="SC^SI^CDATE^ALS^ANS^SDLET^SDTIME"_$SELECT($DATA(SDIN):"^SDIN^SDRE",1:"")_"^SDFORM^SDV1^SDFFFF^AUTO#"
+2 ;I '$D(SDLT) D FZIS^DGUTQ G:POP END
+3 ;ihs/cmi/maw 11/6/2012 PATCH 1016
IF '$DATA(SDLT)
DO ZIS^DGUTQ
IF POP
GOTO END
START USE IO
IF ANS'["Y"&('$DATA(SDLT))
IF ALS["Y"
DO APP
DO END
QUIT
BEG1 NEW SDFIRST
+1 IF $DATA(SDLT)
SET SDAR=$SELECT('VAUTC:"VAUTC",1:"^SC")
SET ANS="N"
SET ALS="Y"
Begin DoDot:1
+2 FOR SC=0:0
SET SC=$ORDER(@(SDAR_"("_SC_")"))
IF SC'>0
QUIT
Begin DoDot:2
+3 KILL SDOK1
DO EN
IF $DATA(SDOK1)
IF SDLET
Begin DoDot:3
+4 FOR SD=(SDBD-.1):0
SET SD=$ORDER(^SC(SC,"S",SD))
SET CDATE=SD
IF SD>(SDED+.999999)!(SD'>0)
QUIT
Begin DoDot:4
+5 DO DUP
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+6 SET SDFIRST=$SELECT($GET(SDFFFF)=1:0,1:1)
+7 IF $DATA(SDLT)
IF $DATA(^UTILITY("SDLT",$JOB))
DO PR^SDC3
DO END
QUIT
+8 IF $DATA(SDLT)
QUIT
DO ^SDAUT1
+9 IF MAX=0
WRITE !,"AUTO-REBOOKING NOT ALLOWED FOR THIS CLINIC"
IF ALS["Y"
GOTO APP
GOTO END
+10 FOR GDATE=CDATE:0
SET GDATE=$ORDER(^SC(SC,"S",GDATE))
IF GDATE=""!(GDATE>(CDATE+1))
QUIT
Begin DoDot:1
+11 FOR L=0:0
SET L=$ORDER(^SC(SC,"S",GDATE,1,L))
IF L=""
QUIT
Begin DoDot:2
+12 SET POP=0
+13 ;SD*545 delete corrupt record
IF '$DATA(^SC(SC,"S",GDATE,1,L,0))
IF $DATA(^("C"))
SET J=GDATE
SET J2=L
DO DELETE^SDC1
KILL J,J2
SET POP=1
QUIT
+14 ;SD*545 delete corrupt record
IF '+$GET(^SC(SC,"S",GDATE,1,L,0))
SET J=GDATE
SET J2=L
DO DELETE^SDC1
KILL J,J2
SET POP=1
QUIT
End DoDot:2
IF POP
QUIT
SET A=^SC(SC,"S",GDATE,1,L,0)
IF $DATA(^DPT(+A,"S",GDATE,0))
IF $PIECE(^(0),"^",2)="C"
IF $PIECE(^(0),"^",14)=SDTIME
DO ^SDAUT2
DO ^SDCCP
End DoDot:1
+15 KILL POP
+16 ;IHS/ITSC/WAR 1/12/05 PATCH #1002 Needed a formfeed after autobook Rpt & prior to letters printing
WRITE @IOF
+17 IF ALS["Y"
DO APP
END ;
+1 IF $GET(SC)>0&($GET(CDATE)>0)
DO RESOLVE
+2 KILL %,%DT,%H,%I,%DT,%IS,%ZIS,A,ALS,ANS,BY,CDATE,CHAR,DA,DFN,DH,DHD,DIC,DIS,DO,DOW,FLDS,FR,GDATE,I,L,LET,MAX,NOAP,P,POP,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B,CLIN,HX,L0,L1,L2,LL,PDAT,S,TIME,Z,D,ENDATE,J,SM,STIME,X1,X2,SDX1,SDX2,SDRE,SDRE1,SDIN,FSW
+3 KILL ^TMP("SDC0",$JOB),SDAP,SDAPNUM
+4 KILL SC,SD,Z0,Z5,DGPGM,DUPE,J2,MESS,NDATE,SDDIF,SDFORM,SDINP,SDFORM,SDLET,SDLT1,SDNODE,SDRT,SDSOH,SDST,SDV1,DGVAR,SD1,SD8,SD81,SDANS,SDCNT,SDERR,SDHTO,SDJ,SDTIME,SDZ,STARTDAY,SD82,SDOK,SDOK1,SDLE,SDZ,SDOK1,TST,W,^UTILITY("SD")
+5 KILL SDFFFF,DIW,DIWF,DIWL,DIWR,DIWT,DN,DUPE,J2,MESS,NDATE,SDADD,SDC,SDCL,SDDAT,SDDIF,SDFORM,SDHX,SDINP,SDIV,SDLET,SDNODE,SDRT,SDSOH,SDST,SDT0,TST,SDV1,^TMP($JOB,"BADADD")
DO CLOSE^DGUTQ
QUIT
CHK KILL SDOK1
IF $DATA(^SC(SC,"SL"))
SET SL=^("SL")
SET %=$PIECE(SL,"^",6)
SET SI=$SELECT(%="":4,%<3:4,%:%,1:4)
SET SDOK1=1
KILL SL,%
IF '$TEST
WRITE $PIECE(^SC(SC,0),"^")," does not have an appointment length indicated."
+1 QUIT
RESOLVE ;evaluate canceled and rebooked appointments with relation to EWL
+1 SET GDATE=CDATE
KILL ^TMP("SDWLREB",$JOB),^TMP($JOB,"SDWLPL")
+2 FOR
SET GDATE=$ORDER(^SC(SC,"S",GDATE))
IF GDATE=""!(GDATE>(CDATE+1))
QUIT
SET L=0
FOR
SET L=$ORDER(^SC(SC,"S",GDATE,1,L))
IF L=""
QUIT
Begin DoDot:1
+3 ;SD*5.3*545 delete corrupt record
IF '$DATA(^SC(SC,"S",GDATE,1,L,0))
IF $DATA(^("C"))
SET J=GDATE
SET J2=L
DO DELETE^SDC1
KILL J,J2
QUIT
+4 ;SD*5.3*545 delete corrupt record with missing DFN
IF '+$GET(^SC(SC,"S",GDATE,1,L,0))
SET J=GDATE
SET J2=L
DO DELETE^SDC1
KILL J,J2
QUIT
+5 SET DFN=+^SC(SC,"S",GDATE,1,L,0)
+6 NEW RBFLG,SDTRB,SDCAN,SDREB
SET SDREB=0
DO REBOOK^SDWLREB(DFN,GDATE,SC,.RBFLG,.SDTRB,.SDCAN)
IF SDCAN'=SDTIME
QUIT
+7 ;not canceled by clinic
IF $EXTRACT(RBFLG,1,2)'="CC"
QUIT
+8 IF RBFLG="CCR"
SET SDREB=1
DO DISREB^SDWLREB(DFN,SDTRB,SC)
+9 DO OPENEWL^SDWLREB(DFN,GDATE,SC,SDREB)
KILL ^TMP($JOB,"APPT"),^TMP($JOB,"SDWLPL")
End DoDot:1
+10 IF $DATA(^TMP("SDWLREB",$JOB))
DO MESS^SDWLREB
+11 QUIT
+12 ;
DUP ;SCREEN FOR DUPLICATE PATIENTS - SD*5.3*379
+1 SET SDAP=""
FOR
SET SDAP=$ORDER(^SC(SC,"S",SD,SDAP))
IF SDAP=""
QUIT
Begin DoDot:1
+2 SET SDAPNUM=""
FOR
SET SDAPNUM=$ORDER(^SC(SC,"S",SD,SDAP,SDAPNUM))
IF SDAPNUM=""
QUIT
Begin DoDot:2
+3 ;SD*545 delete corrupt record
IF '$DATA(^SC(SC,"S",SD,SDAP,SDAPNUM,0))
IF $DATA(^("C"))
SET J=SD
SET J2=SDAPNUM
DO DELETE^SDC1
QUIT
+4 ;SD*545 if DFN missing delete record
IF '+$GET(^SC(SC,"S",SD,SDAP,SDAPNUM,0))
SET J=SD
SET J2=SDAPNUM
DO DELETE^SDC1
QUIT
+5 IF $DATA(^SC(SC,"S",SD,SDAP,SDAPNUM,0))
Begin DoDot:3
+6 SET A=$PIECE(^SC(SC,"S",SD,SDAP,SDAPNUM,0),"^",1)
+7 IF '$DATA(^TMP("SDC0",$JOB,SD,A))
SET ^TMP("SDC0",$JOB,SD,A)=""
DO ^SDC3
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
APP IF $GET(SDFFFF)=1
SET SDFIRST=0
+1 FOR GDATE=CDATE:0
SET GDATE=$ORDER(^SC(+SC,"S",GDATE))
IF GDATE=""!(GDATE>(CDATE+1))
QUIT
FOR L=0:0
SET L=$ORDER(^SC(+SC,"S",GDATE,1,L))
IF L=""
QUIT
Begin DoDot:1
+2 SET POP=0
+3 ;SD*545 delete corrupt record
IF '$DATA(^SC(+SC,"S",GDATE,1,L,0))
IF $DATA(^("C"))
SET J=GDATE
SET J2=L
DO DELETE^SDC1
KILL J,J2
SET POP=1
QUIT
+4 ;SD*545 if DFN missing delete record
IF '+$GET(^SC(+SC,"S",GDATE,1,L,0))
SET J=GDATE
SET J2=L
DO DELETE^SDC1
KILL J,J2
SET POP=1
QUIT
+5 QUIT
End DoDot:1
IF POP
QUIT
SET A=^SC(+SC,"S",GDATE,1,L,0)
DO CHECK
+6 KILL POP
+7 IF $DATA(^TMP($JOB,"BADADD"))
DO BADADD^SDLT
KILL ^TMP($JOB,"BADADD")
+8 QUIT
CHK1 SET (SDX,X)=GDATE
DO WRAPP^SDLT
+1 IF $PIECE(S,"^",2)'["A"
DO REST^SDLT
QUIT
+2 SET SDX=$PIECE(S,"^",10)
IF '$DATA(^DPT(+A,"S",SDX,0))
DO REST^SDLT
QUIT
+3 WRITE !!,"The cancelled appointment(s) were rescheduled as follows:",!
+4 SET S=^DPT(+A,"S",SDX,0)
DO WRAPP^SDLT
DO REST^SDLT
+5 QUIT
CHECK IF $$BADADR^DGUTL3(+A)
SET ^TMP($JOB,"BADADD",$PIECE(^DPT(+A,0),"^"),+A)=""
QUIT
+1 ;
+2 ;SCREEN FOR DUPLICATES - SD*5.3*379
+3 ;
+4 IF $DATA(^TMP("SDC0",$JOB,GDATE,A))
QUIT
+5 SET ^TMP("SDC0",$JOB,GDATE,A)=""
+6 IF $SELECT('$DATA(^DPT(+A,.35)):1,$PIECE(^DPT(+A,.35),"^",1)']"":1,1:0)
IF $DATA(^DPT(+A,"S",GDATE))
IF $PIECE(^DPT(+A,"S",GDATE,0),"^",2)["C"
IF $PIECE(^(0),"^",14)=SDTIME!(SDTIME="*")
SET S=^DPT(+A,"S",GDATE,0)
DO ^SDLT
DO CHK1
