SDCNP1 ;ALB/LDB - CANCEL APPOINTMENT (cont.) ; 14 MAR 88@13:00
;;5.3;Scheduling;**398,467,478,1015**;Aug 13, 1993;Build 21
;
;SD/467 - EWL Open Matched Entry with rebook
NOPE W !,*7,$S(CNT:CNT_" Appointment"_$S(CNT>1:"s",1:"")_" cancelled",1:"NOTHING CANCELLED")
S SDCNT=CNT,SDA=1,SDCNT1=0 I CNT,$S('$D(^DPT(DFN,.35)):1,'$P(^(.35),U):1,1:0) S (SDA,X8)=0 D ASK G:X8="^" END
;no rebooking to take place; open EWL entries only if applicable
I $D(DFN)>0 D EWL(DFN) ;SD/467
I SDA,SDCNT W !,*7,"NO AUTO-REBOOKING --Patient has died."
I 'SDA,SDCNT S A=DFN D LOOP1^SDCNP1A,LET
END K:'$D(DIROUT) DFN D END^SDCNP Q:$D(DIROUT) G RD^SDCNP
ASK S (SDCTR,SDCTRL)=0,%=2 W !!,"DO YOU WISH TO REBOOK ANY APPOINTMENT(S) THAT YOU HAVE CANCELLED" D YN^DICN S ALS=% D:'% REASK G:'% ASK I %-1 S CNT=0 S:%<0 X8="^" D Q
.W !,"OK"
W !!,"PLEASE NOTE THAT YOU MUST ENTER A DEVICE TO AUTO-REBOOK",!
ZIS S %ZIS("A")="DEVICE TO OUTPUT REBOOKED APPT(S). :",%ZIS="QN" D ^%ZIS I POP S X8="^" Q
S L=0 F S L=$O(^UTILITY($J,"SDCNP",L)) Q:'L I $P(^(L),U,4)="*** JUST CANCELLED ***" S ^UTILITY($J,"SDCNP1",DFN,$P(^(L),"^",2),$P(^(L),"^"))=^(L)
D SDLST
LST S B=0 F S B=$O(^UTILITY($J,"SDCNP2",DFN,B)) Q:'B W !!,$J($S(B\1=B:"("_$J(B,2)_") ",1:""),5) S AT=$S($P(^(B),"^",2)'?.N:1,1:0),Y=$P($P(^(B),"^"),".") D DT^SDM0 S X=$P(^(B),"^") X ^DD("FUNC",2,1) W " ",$J(X,8) S Z1(B)="" D MORE Q:SDCTRL
D WH
I B>0 G:SDCTRL&(A8']"") NOPE1 G:SDCTRL DEL
Q
SDLST S L1=0 S Z5=0 F S Z5=$O(^UTILITY($J,"SDCNP1",DFN,Z5)) Q:'Z5 F Z6=0:0 S Z7=Z6,Z6=$O(^UTILITY($J,"SDCNP1",DFN,Z5,Z6)) I Z6="" S L1=L1+1,^UTILITY($J,"SDCNP2",DFN,L1)=Z7_"^"_Z5_"^"_$P(^(Z7),"^",3,6) Q
Q
MORE S SDCTR=SDCTR+2 I AT W ?41,$P(^UTILITY($J,"SDCNP2",B),"^",2) G OVR
S S5=^UTILITY($J,"SDCNP2",DFN,B) W " (",$P(S5,"^",6)," MINUTES) ",$S($D(^SC($P(S5,"^",2),0)):$P(^(0),"^",1),1:"DELETED CLINIC"),$P(S5,"^",3) S M1=$P(^SC($P(S5,"^",2),"SDP"),"^",4) W !,?41,"Max days for rebooking= ",M1
OVR I SDCTR>20,$O(^UTILITY($J,"SDCNP2",B))>0 S (SDCTRL,SDCTR)=0 W *7 D WH W:'SDCTRL @IOF
Q
WH W !!,"SELECT APPOINTMENT(S) TO BE REBOOKED" W:B>0 " OR HIT RETURN TO CONTINUE DISPLAY" R ": ",A8:DTIME I '$T!(A8="^") S SDCTRL=1,A8="",X8="^" Q
I A8["?" X SDMSG G WH
DEL S SDERR=0 F J=1:1 S SDDH=$P(A8,",",J) Q:SDDH']"" D MTCH
I SDERR G LST
DEL1 S SDERR=0 F J=1:1 S SDDH=$P(A8,",",J) Q:SDDH']"" S SDDI=$P(SDDH,"-"),SDDM=$P(SDDH,"-",2) D CKK^SDCNP1A Q:SDERR D CKK2^SDCNP1A Q:SDERR F Z9=SDDI:1:$S(SDDM:SDDM,1:SDDI) D:SDDI REBK I 'SDDI S SDERR=1 Q
G:SDERR LST Q:A8["^"!(A8="") S SDERR=0 D ^SDCNP1A Q:X8="^"
D:MAX QUE
D NOPE1
Q
LET S %=2 W !!,"DO YOU WISH TO PRINT LETTERS FOR THE CANCELLED APPOINTMENT(S)" D YN^DICN S ANS="Y" D:'% REASK G:'% LET Q:(%-1)
I $$BADADR^DGUTL3(+DFN) D Q ;display, don't print BAI list
. W *7,!,"** THIS PATIENT HAS BEEN FLAGGED WITH A BAD ADDRESS INDICATOR, NO LETTER"
. W !,"WILL BE PRINTED."
. S DIR(0)="E" D ^DIR K DIR(0)
QUE2 ;S DGPGM="SDLET^SDCNP1A",DGVAR="SDCL#^DUZ^DFN^DT^A^SDWH" D ZIS^DGUTQ D:POP CLOSE^DGUTQ Q:POP D SDLET^SDCNP1A Q
S %ZIS="MQ" K IO("Q") D ^%ZIS Q:POP ;SD/478
I $D(IO("Q")) D D:IO'=IO(0) NOTELTR D ^%ZISC W @IOF Q ;SD/478
.S ZTRTN="SDLET^SDCNP1A" F ZTS="SDCL(","DUZ","DFN","DT","A","SDWH","AUTO(" S ZTSAVE(ZTS)="" ;SD/478
.K ZTS D ^%ZTLOAD ;SD/478
D:IO'=IO(0) NOTELTR D SDLET^SDCNP1A,^%ZISC W @IOF ;SD/478
Q ;SD/478
NOTELTR I ANS["Y",ALS=1 S:$D(CNDIE) @(CNDIE_CNDA_",1,CNINDX,0)")="CANCEL APPOINTMENT AUTO REBOOK letter printed." K CNDIE,CNDA,CNINDX ;SD/478 CANCEL APPT AUTO REBOOK LETTER PRINTED.
I ANS["Y" S:$D(CNDIE) @(CNDIE_CNDA_",1,CNINDX,0)")="CANCEL APPOINTMENT letter printed." K CNDIE,CNDA,CNINDX ;SD/478 CANCEL APPT LETTER IS PRINTED.
Q
QUE I IO'=IO(0) S DGPGM="^SDCNP2",DGVAR="SDCL#^NDATE^A^GDATE^DT^DUZ",IOP=IO,X="NOW" D Q1^DGUTQ Q
U IO I IO=IO(0),$E(IOST,1,2)="C-" S SDIO=1 D ^SDCNP2 Q
NOPE1 W @IOF,!,*7,$S(SDCNT1:SDCNT1_" Appointment"_$S(SDCNT1>1:"s",1:"")_" rebooked",1:"NOTHING REBOOKED") Q
REBK K ^UTILITY($J,"SDCNP") S ^UTILITY($J,"SDCNP2","REBK",DFN,Z9)=^UTILITY($J,"SDCNP2",DFN,Z9)
Q
F A9=SDDI,SDDM Q:'SDDM&(SDDI-A9) I '$D(Z1(A9)) S SDERR=1 W !,*7,"There is no appointment number ",A9
Q
REASK W !,"ANSWER (Y)ES OR (N)O" Q
CLRK S $P(^DPT(DFN,"S",S,0),"^",19)=$P(SDNODE,"^",7),$P(^DPT(DFN,"S",S,0),"^",18)=$P(SDNODE,"^",6) Q
MTCH Q:SDDH?1N.N!(SDDH?1.N1"-".N) S SDERR=1 X SDMSG
Q
EWL(DFN) ;
I '$D(^UTILITY($J,"SDCNP1")) I '$D(^UTILITY($J,"SDCNP")) Q
;call to EWL to open and optionally close EWL entry with rebooked appointment
N SDFRB,SDT,SC,SDREB K ^TMP("SDWLREB",$J),^TMP($J,"SDWPL"),^TMP($J,"APPT")
I $D(^UTILITY($J,"SDCNP1")) S SDFRB="^UTILITY($J,""SDCNP1"")" D REB I $D(^TMP("SDWLREB",$J)) D MESS^SDWLREB Q
E S SDFRB="^UTILITY($J,""SDCNP"")" D CAN I $D(^TMP("SDWLREB",$J)) D MESS^SDWLREB
Q
REB I $D(^UTILITY($J,"SDCNP1")) F S SDFRB=$Q(@SDFRB) Q:SDFRB'["SDCNP1" S SDT=$P(@SDFRB,U),SC=$P(@SDFRB,U,2),SDREB=0 D
.;N NN F NN=1:1 Q:'$D(^UTILITY($J,"SDCNP","REBK",DFN,NN)) I $P($G(^UTILITY($J,"SDCNP2","REBK",DFN,NN)),U)=SDT S SDREB=1 Q
.N RBFLG,SDTRB D REBOOK^SDWLREB(DFN,SDT,SC,.RBFLG,.SDTRB)
.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,SDT,SC,SDREB) K ^TMP($J,"APPT"),^TMP($J,"SDWLPL")
Q
CAN I $D(^UTILITY($J,"SDCNP")) F S SDFRB=$Q(@SDFRB) Q:SDFRB'["SDCNP" I @SDFRB["CANCELLED" S SDT=$P(@SDFRB,U),SC=$P(@SDFRB,U,2),SDREB=0 D
.N RBFLG,SDTRB D REBOOK^SDWLREB(DFN,SDT,SC,.RBFLG,.SDTRB)
.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,SDT,SC,SDREB) K ^TMP($J,"APPT"),^TMP($J,"SDWLPL")
Q
SDCNP1 ;ALB/LDB - CANCEL APPOINTMENT (cont.) ; 14 MAR 88@13:00
+1 ;;5.3;Scheduling;**398,467,478,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;SD/467 - EWL Open Matched Entry with rebook
NOPE WRITE !,*7,$SELECT(CNT:CNT_" Appointment"_$SELECT(CNT>1:"s",1:"")_" cancelled",1:"NOTHING CANCELLED")
+1 SET SDCNT=CNT
SET SDA=1
SET SDCNT1=0
IF CNT
IF $SELECT('$DATA(^DPT(DFN,.35)):1,'$PIECE(^(.35),U):1,1:0)
SET (SDA,X8)=0
DO ASK
IF X8="^"
GOTO END
+2 ;no rebooking to take place; open EWL entries only if applicable
+3 ;SD/467
IF $DATA(DFN)>0
DO EWL(DFN)
+4 IF SDA
IF SDCNT
WRITE !,*7,"NO AUTO-REBOOKING --Patient has died."
+5 IF 'SDA
IF SDCNT
SET A=DFN
DO LOOP1^SDCNP1A
DO LET
END IF '$DATA(DIROUT)
KILL DFN
DO END^SDCNP
IF $DATA(DIROUT)
QUIT
GOTO RD^SDCNP
ASK SET (SDCTR,SDCTRL)=0
SET %=2
WRITE !!,"DO YOU WISH TO REBOOK ANY APPOINTMENT(S) THAT YOU HAVE CANCELLED"
DO YN^DICN
SET ALS=%
IF '%
DO REASK
IF '%
GOTO ASK
IF %-1
SET CNT=0
IF %<0
SET X8="^"
Begin DoDot:1
+1 WRITE !,"OK"
End DoDot:1
QUIT
+2 WRITE !!,"PLEASE NOTE THAT YOU MUST ENTER A DEVICE TO AUTO-REBOOK",!
ZIS SET %ZIS("A")="DEVICE TO OUTPUT REBOOKED APPT(S). :"
SET %ZIS="QN"
DO ^%ZIS
IF POP
SET X8="^"
QUIT
+1 SET L=0
FOR
SET L=$ORDER(^UTILITY($JOB,"SDCNP",L))
IF 'L
QUIT
IF $PIECE(^(L),U,4)="*** JUST CANCELLED ***"
SET ^UTILITY($JOB,"SDCNP1",DFN,$PIECE(^(L),"^",2),$PIECE(^(L),"^"))=^(L)
+2 DO SDLST
LST SET B=0
FOR
SET B=$ORDER(^UTILITY($JOB,"SDCNP2",DFN,B))
IF 'B
QUIT
WRITE !!,$JUSTIFY($SELECT(B\1=B:"("_$JUSTIFY(B,2)_") ",1:""),5)
SET AT=$SELECT($PIECE(^(B),"^",2)'?.N:1,1:0)
SET Y=$PIECE($PIECE(^(B),"^"),".")
DO DT^SDM0
SET X=$PIECE(^(B),"^")
XECUTE ^DD("FUNC",2,1)
WRITE " ",$JUSTIFY(X,8)
SET Z1(B)=""
DO MORE
IF SDCTRL
QUIT
+1 DO WH
+2 IF B>0
IF SDCTRL&(A8']"")
GOTO NOPE1
IF SDCTRL
GOTO DEL
+3 QUIT
SDLST SET L1=0
SET Z5=0
FOR
SET Z5=$ORDER(^UTILITY($JOB,"SDCNP1",DFN,Z5))
IF 'Z5
QUIT
FOR Z6=0:0
SET Z7=Z6
SET Z6=$ORDER(^UTILITY($JOB,"SDCNP1",DFN,Z5,Z6))
IF Z6=""
SET L1=L1+1
SET ^UTILITY($JOB,"SDCNP2",DFN,L1)=Z7_"^"_Z5_"^"_$PIECE(^(Z7),"^",3,6)
QUIT
+1 QUIT
MORE SET SDCTR=SDCTR+2
IF AT
WRITE ?41,$PIECE(^UTILITY($JOB,"SDCNP2",B),"^",2)
GOTO OVR
+1 SET S5=^UTILITY($JOB,"SDCNP2",DFN,B)
WRITE " (",$PIECE(S5,"^",6)," MINUTES) ",$SELECT($DATA(^SC($PIECE(S5,"^",2),0)):$PIECE(^(0),"^",1),1:"DELETED CLINIC"),$PIECE(S5,"^",3)
SET M1=$PIECE(^SC($PIECE(S5,"^",2),"SDP"),"^",4)
WRITE !,?41,"Max days for rebooking= ",M1
OVR IF SDCTR>20
IF $ORDER(^UTILITY($JOB,"SDCNP2",B))>0
SET (SDCTRL,SDCTR)=0
WRITE *7
DO WH
IF 'SDCTRL
WRITE @IOF
+1 QUIT
WH WRITE !!,"SELECT APPOINTMENT(S) TO BE REBOOKED"
IF B>0
WRITE " OR HIT RETURN TO CONTINUE DISPLAY"
READ ": ",A8:DTIME
IF '$TEST!(A8="^")
SET SDCTRL=1
SET A8=""
SET X8="^"
QUIT
+1 IF A8["?"
XECUTE SDMSG
GOTO WH
DEL SET SDERR=0
FOR J=1:1
SET SDDH=$PIECE(A8,",",J)
IF SDDH']""
QUIT
DO MTCH
+1 IF SDERR
GOTO LST
DEL1 SET SDERR=0
FOR J=1:1
SET SDDH=$PIECE(A8,",",J)
IF SDDH']""
QUIT
SET SDDI=$PIECE(SDDH,"-")
SET SDDM=$PIECE(SDDH,"-",2)
DO CKK^SDCNP1A
IF SDERR
QUIT
DO CKK2^SDCNP1A
IF SDERR
QUIT
FOR Z9=SDDI:1:$SELECT(SDDM:SDDM,1:SDDI)
IF SDDI
DO REBK
IF 'SDDI
SET SDERR=1
QUIT
+1 IF SDERR
GOTO LST
IF A8["^"!(A8="")
QUIT
SET SDERR=0
DO ^SDCNP1A
IF X8="^"
QUIT
+2 IF MAX
DO QUE
+3 DO NOPE1
+4 QUIT
LET SET %=2
WRITE !!,"DO YOU WISH TO PRINT LETTERS FOR THE CANCELLED APPOINTMENT(S)"
DO YN^DICN
SET ANS="Y"
IF '%
DO REASK
IF '%
GOTO LET
IF (%-1)
QUIT
+1 ;display, don't print BAI list
IF $$BADADR^DGUTL3(+DFN)
Begin DoDot:1
+2 WRITE *7,!,"** THIS PATIENT HAS BEEN FLAGGED WITH A BAD ADDRESS INDICATOR, NO LETTER"
+3 WRITE !,"WILL BE PRINTED."
+4 SET DIR(0)="E"
DO ^DIR
KILL DIR(0)
End DoDot:1
QUIT
QUE2 ;S DGPGM="SDLET^SDCNP1A",DGVAR="SDCL#^DUZ^DFN^DT^A^SDWH" D ZIS^DGUTQ D:POP CLOSE^DGUTQ Q:POP D SDLET^SDCNP1A Q
+1 ;SD/478
SET %ZIS="MQ"
KILL IO("Q")
DO ^%ZIS
IF POP
QUIT
+2 ;SD/478
IF $DATA(IO("Q"))
Begin DoDot:1
+3 ;SD/478
SET ZTRTN="SDLET^SDCNP1A"
FOR ZTS="SDCL(","DUZ","DFN","DT","A","SDWH","AUTO("
SET ZTSAVE(ZTS)=""
+4 ;SD/478
KILL ZTS
DO ^%ZTLOAD
End DoDot:1
IF IO'=IO(0)
DO NOTELTR
DO ^%ZISC
WRITE @IOF
QUIT
+5 ;SD/478
IF IO'=IO(0)
DO NOTELTR
DO SDLET^SDCNP1A
DO ^%ZISC
WRITE @IOF
+6 ;SD/478
QUIT
NOTELTR ;SD/478 CANCEL APPT AUTO REBOOK LETTER PRINTED.
IF ANS["Y"
IF ALS=1
IF $DATA(CNDIE)
SET @(CNDIE_CNDA_",1,CNINDX,0)")="CANCEL APPOINTMENT AUTO REBOOK letter printed."
KILL CNDIE,CNDA,CNINDX
+1 ;SD/478 CANCEL APPT LETTER IS PRINTED.
IF ANS["Y"
IF $DATA(CNDIE)
SET @(CNDIE_CNDA_",1,CNINDX,0)")="CANCEL APPOINTMENT letter printed."
KILL CNDIE,CNDA,CNINDX
+2 QUIT
QUE IF IO'=IO(0)
SET DGPGM="^SDCNP2"
SET DGVAR="SDCL#^NDATE^A^GDATE^DT^DUZ"
SET IOP=IO
SET X="NOW"
DO Q1^DGUTQ
QUIT
+1 USE IO
IF IO=IO(0)
IF $EXTRACT(IOST,1,2)="C-"
SET SDIO=1
DO ^SDCNP2
QUIT
NOPE1 WRITE @IOF,!,*7,$SELECT(SDCNT1:SDCNT1_" Appointment"_$SELECT(SDCNT1>1:"s",1:"")_" rebooked",1:"NOTHING REBOOKED")
QUIT
REBK KILL ^UTILITY($JOB,"SDCNP")
SET ^UTILITY($JOB,"SDCNP2","REBK",DFN,Z9)=^UTILITY($JOB,"SDCNP2",DFN,Z9)
+1 QUIT
+2 FOR A9=SDDI,SDDM
IF 'SDDM&(SDDI-A9)
QUIT
IF '$DATA(Z1(A9))
SET SDERR=1
WRITE !,*7,"There is no appointment number ",A9
+3 QUIT
REASK WRITE !,"ANSWER (Y)ES OR (N)O"
QUIT
CLRK SET $PIECE(^DPT(DFN,"S",S,0),"^",19)=$PIECE(SDNODE,"^",7)
SET $PIECE(^DPT(DFN,"S",S,0),"^",18)=$PIECE(SDNODE,"^",6)
QUIT
MTCH IF SDDH?1N.N!(SDDH?1.N1"-".N)
QUIT
SET SDERR=1
XECUTE SDMSG
+1 QUIT
EWL(DFN) ;
+1 IF '$DATA(^UTILITY($JOB,"SDCNP1"))
IF '$DATA(^UTILITY($JOB,"SDCNP"))
QUIT
+2 ;call to EWL to open and optionally close EWL entry with rebooked appointment
+3 NEW SDFRB,SDT,SC,SDREB
KILL ^TMP("SDWLREB",$JOB),^TMP($JOB,"SDWPL"),^TMP($JOB,"APPT")
+4 IF $DATA(^UTILITY($JOB,"SDCNP1"))
SET SDFRB="^UTILITY($J,""SDCNP1"")"
DO REB
IF $DATA(^TMP("SDWLREB",$JOB))
DO MESS^SDWLREB
QUIT
+5 IF '$TEST
SET SDFRB="^UTILITY($J,""SDCNP"")"
DO CAN
IF $DATA(^TMP("SDWLREB",$JOB))
DO MESS^SDWLREB
+6 QUIT
REB IF $DATA(^UTILITY($JOB,"SDCNP1"))
FOR
SET SDFRB=$QUERY(@SDFRB)
IF SDFRB'["SDCNP1"
QUIT
SET SDT=$PIECE(@SDFRB,U)
SET SC=$PIECE(@SDFRB,U,2)
SET SDREB=0
Begin DoDot:1
+1 ;N NN F NN=1:1 Q:'$D(^UTILITY($J,"SDCNP","REBK",DFN,NN)) I $P($G(^UTILITY($J,"SDCNP2","REBK",DFN,NN)),U)=SDT S SDREB=1 Q
+2 NEW RBFLG,SDTRB
DO REBOOK^SDWLREB(DFN,SDT,SC,.RBFLG,.SDTRB)
+3 ;not canceled by clinic
IF $EXTRACT(RBFLG,1,2)'="CC"
QUIT
+4 IF RBFLG="CCR"
SET SDREB=1
DO DISREB^SDWLREB(DFN,SDTRB,SC)
+5 DO OPENEWL^SDWLREB(DFN,SDT,SC,SDREB)
KILL ^TMP($JOB,"APPT"),^TMP($JOB,"SDWLPL")
End DoDot:1
+6 QUIT
CAN IF $DATA(^UTILITY($JOB,"SDCNP"))
FOR
SET SDFRB=$QUERY(@SDFRB)
IF SDFRB'["SDCNP"
QUIT
IF @SDFRB["CANCELLED"
SET SDT=$PIECE(@SDFRB,U)
SET SC=$PIECE(@SDFRB,U,2)
SET SDREB=0
Begin DoDot:1
+1 NEW RBFLG,SDTRB
DO REBOOK^SDWLREB(DFN,SDT,SC,.RBFLG,.SDTRB)
+2 ;not canceled by clinic
IF $EXTRACT(RBFLG,1,2)'="CC"
QUIT
+3 IF RBFLG="CCR"
SET SDREB=1
DO DISREB^SDWLREB(DFN,SDTRB,SC)
+4 DO OPENEWL^SDWLREB(DFN,SDT,SC,SDREB)
KILL ^TMP($JOB,"APPT"),^TMP($JOB,"SDWLPL")
End DoDot:1
+5 QUIT
