- 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
