SDN1 ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84 4:34 pm
;;5.3;Scheduling;**330,340,398,455,523**;Aug 13, 1993;Build 6
N SDBAD
I ANS["Y"&($D(C)) F A=0:0 S A=$O(^UTILITY($J,A)) Q:A'>0 F C=0:0 S C=$O(^(A,C)) Q:C'>0 S SC=+^(C),SDLET="" S:$D(^SC(SC,"LTR")) SDLET=+^("LTR") S:SDLET ^UTILITY($J,"SDLT",SDLET,A,C)=^UTILITY($J,A,C) S:'SDLET ^UTILITY($J,"NO",A,C)=SC D KLL
S SDFORM=$S($D(^DG(40.8,SDV1,"LTR")):^("LTR"),1:"") G:ANS["Y"&($D(C)) LST
BC K:$D(SDLT) C S:$D(SDLT) SDT=SDBD,DATEND=SDED K ^UTILITY($J) I $D(C) K VAUTC S (VAUTC,VAUTC(C))=""
I $D(VAUTC),'VAUTC F C=0:0 S C=$O(VAUTC(C)) Q:C'>0 D:$D(SDLT) LT D CHECK1 I $T D OVER
I $D(VAUTC),'VAUTC G LST
LST1 F C=0:0 S C=$O(^SC(C)) Q:C'>0 D LT,CHECK1 I $T,$S(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0),'$D(SDVAUTC(+C)),$D(^SC(C,"S")) D OVER
LST N SDFIRST S SDFIRST=1
F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0 F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0 I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) N POP S POP=0 D ^SDLT Q:POP D WR ;SD*523 added quit
I $D(^UTILITY($J,"NO")) W @IOF F A=0:0 S A=$O(^UTILITY($J,"NO",A)) Q:A'>0 F A1=0:0 S A1=$O(^(A,A1)) Q:A1'>0 Q:$$BADADR^DGUTL3(A) W !,$P(^DPT(A,0),"^")," ",$P(^(0),"^",9)," has failed to keep the following appointment(s):" D NDT
W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!!
I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD")
G END
OVER S GDATE=SDT Q:'$D(^SC(C,"S")) F J=0:0 S GDATE=$O(^SC(C,"S",GDATE)) Q:GDATE=""!(GDATE>(DATEND+.9999)) F K=0:0 S K=$O(^SC(C,"S",GDATE,1,K)) Q:K="" I $D(^(K,0)) S DFN=+^(0) D CHECK
Q
END K %,%DT,%IS,A,A0,A1,A2,ALL,ALS,ANS,BY,C,CDATE,DA,DFN,DGPGM,DGVAR,DH,DHD,DIC,DIS,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DO,DOW,DN,DUPE,FLDS,F,F1,FR,GDATE,I,I1,L,L0,LET,MAX,MESS,MIN,NOAP,P,POP,SC,SD,SDFOR,SDLET,SDTIME,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B
K CLIN,HX,LL,PDAT,S,TIME,Z,D,NDATE,ENDATE,J,SDMDT,SDMSTIME,X1,X2,SDTADE,SDADTB,SDRE,SDRE1,SDIN,SDIS,SDYES,CNN,SDT,DATEND,SDV1,K,SDR,SDJ1,^UTILITY($J),SD1,SD2,SDADD,SDC,SDCL,SDCMAX,SDCONS,SDD,SDDAT,SDDIF,SDDT,SDED,SDFORM,SDHX,SDINP,SDIP
K %ZIS,Y1,SDBD,SDCT,SDVAUTC,VAUTC,SDX,SDX1,SDNOSH,SDLT1,SDMSG,SDNODE,SDQ,SDRT,SDSOH,SDSTAT,SDT0,SDZSC,SM,SM1,STARTDAY,STIME,SDV,Z0,Z5 D CLOSE^DGUTQ Q
CHECK I $S('$D(^DPT(DFN,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(DFN,"S",GDATE,0)),$S($P(^(0),U,2)="N":1,$P(^(0),U,2)="NA":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(DFN,.1)) D
.D BAD Q:SDBAD
.D SET
Q ;above logic changed SD*5.3*455
SET I SDLT1!SDLET S ^UTILITY($J,"SDLT",$S(SDLT1:SDLT1,1:SDLET),DFN,GDATE)=C_"^"_$P(^DPT(DFN,"S",GDATE,0),"^",10) Q
S ^UTILITY($J,"NO",DFN,GDATE)=C Q
CHECK1 S SDV=$P(^SC(C,0),"^",15) I $P(^(0),"^",3)="C",$S('$D(^SC(C,"I")):1,'(+^("I")):1,+^("I")>DATEND:1,+$P(^("I"),"^",2)'>DATEND&(+$P(^("I"),"^",2)):1,1:0)
Q
WR K CNN F J=0:0 S J=$O(^UTILITY($J,"SDLT",SDLET,A,J)) Q:J="" S SDR=0,SDX=J,CNN(J)=^(J),CLIN=$P(^SC(+$P(CNN(J),"^",1),0),"^",1),SDC=+CNN(J),S=$S($D(^DPT(A,"S",J,0)):^(0),1:"") D WRAPP^SDLT,SET1
D:SDR SDR D REST^SDLT Q
SDR W !!,"The appointment(s) have been rescheduled as follows:",!
F J=0:0 S J=$O(CNN(J)) Q:J="" S SDX=$P(CNN(J),"^",2),SDC=$P(CNN(J),"^") I SDX S S=$S($D(^DPT(A,"S",SDX,0)):^(0),1:"") D WRAPP^SDLT
Q
SET1 S:'SDR SDR=$S($P(CNN(J),"^",2)]"":1,1:0) Q
Q
LT S:'SDLT1 SDLET=0 I $D(^SC(C,"LTR")),^("LTR") S SDLET=+^("LTR")
Q
NDT W !?15,$P(^SC(+^UTILITY($J,"NO",A,A1),0),"^")," on " S Y=A1 D DT^DIQ Q
KLL K ^UTILITY($J,A,C) Q
BAD S SDBAD=$$BADADR^DGUTL3(+DFN)
S:SDBAD ^TMP($J,"BADADD",$P(^DPT(+DFN,0),"^"),+DFN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDN1 3607 printed Oct 16, 2024@18:59:13 Page 2
SDN1 ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84 4:34 pm
+1 ;;5.3;Scheduling;**330,340,398,455,523**;Aug 13, 1993;Build 6
+2 NEW SDBAD
+3 IF ANS["Y"&($DATA(C))
FOR A=0:0
SET A=$ORDER(^UTILITY($JOB,A))
if A'>0
QUIT
FOR C=0:0
SET C=$ORDER(^(A,C))
if C'>0
QUIT
SET SC=+^(C)
SET SDLET=""
if $DATA(^SC(SC,"LTR"))
SET SDLET=+^("LTR")
if SDLET
SET ^UTILITY($JOB,"SDLT",SDLET,A,C)=^UTILITY($JOB,A,C)
if 'SDLET
SET ^UTILITY($JOB,"NO",A,C)=SC
DO KLL
+4 SET SDFORM=$SELECT($DATA(^DG(40.8,SDV1,"LTR")):^("LTR"),1:"")
if ANS["Y"&($DATA(C))
GOTO LST
BC if $DATA(SDLT)
KILL C
if $DATA(SDLT)
SET SDT=SDBD
SET DATEND=SDED
KILL ^UTILITY($JOB)
IF $DATA(C)
KILL VAUTC
SET (VAUTC,VAUTC(C))=""
+1 IF $DATA(VAUTC)
IF 'VAUTC
FOR C=0:0
SET C=$ORDER(VAUTC(C))
if C'>0
QUIT
if $DATA(SDLT)
DO LT
DO CHECK1
IF $TEST
DO OVER
+2 IF $DATA(VAUTC)
IF 'VAUTC
GOTO LST
LST1 FOR C=0:0
SET C=$ORDER(^SC(C))
if C'>0
QUIT
DO LT
DO CHECK1
IF $TEST
IF $SELECT(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0)
IF '$DATA(SDVAUTC(+C))
IF $DATA(^SC(C,"S"))
DO OVER
LST NEW SDFIRST
SET SDFIRST=1
+1 ;SD*523 added quit
FOR SDLET=0:0
SET SDLET=$ORDER(^UTILITY($JOB,"SDLT",SDLET))
if SDLET'>0
QUIT
FOR A=0:0
SET A=$ORDER(^UTILITY($JOB,"SDLT",SDLET,A))
if A'>0
QUIT
IF $SELECT('$DATA(^DPT(A,.35)):1,$PIECE(^(.35),"^",1)']"":1,1:0)
NEW POP
SET POP=0
DO ^SDLT
if POP
QUIT
DO WR
+2 IF $DATA(^UTILITY($JOB,"NO"))
WRITE @IOF
FOR A=0:0
SET A=$ORDER(^UTILITY($JOB,"NO",A))
if A'>0
QUIT
FOR A1=0:0
SET A1=$ORDER(^(A,A1))
if A1'>0
QUIT
if $$BADADR^DGUTL3(A)
QUIT
WRITE !,$PIECE(^DPT(A,0),"^")," ",$PIECE(^(0),"^",9)," has failed to keep the following appointment(s):"
DO NDT
+3 if $DATA(^UTILITY($JOB,"NO"))
WRITE !,"However, there are no letters assigned to the clinic(s).",!!
+4 IF $DATA(^TMP($JOB,"BADADD"))
DO BADADD^SDLT
KILL ^TMP($JOB,"BADADD")
+5 GOTO END
OVER SET GDATE=SDT
if '$DATA(^SC(C,"S"))
QUIT
FOR J=0:0
SET GDATE=$ORDER(^SC(C,"S",GDATE))
if GDATE=""!(GDATE>(DATEND+.9999))
QUIT
FOR K=0:0
SET K=$ORDER(^SC(C,"S",GDATE,1,K))
if K=""
QUIT
IF $DATA(^(K,0))
SET DFN=+^(0)
DO CHECK
+1 QUIT
END KILL %,%DT,%IS,A,A0,A1,A2,ALL,ALS,ANS,BY,C,CDATE,DA,DFN,DGPGM,DGVAR,DH,DHD,DIC,DIS,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DO,DOW,DN,DUPE,FLDS,F,F1,FR,GDATE,I,I1,L,L0,LET,MAX,MESS,MIN,NOAP,P,POP,SC,SD,SDFOR,SDLET,SDTIME,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B
+1 KILL CLIN,HX,LL,PDAT,S,TIME,Z,D,NDATE,ENDATE,J,SDMDT,SDMSTIME,X1,X2,SDTADE,SDADTB,SDRE,SDRE1,SDIN,SDIS,SDYES,CNN,SDT,DATEND,SDV1,K,SDR,SDJ1,^UTILITY($JOB),SD1,SD2,SDADD,SDC,SDCL,SDCMAX,SDCONS,SDD,SDDAT,SDDIF,SDDT,SDED,SDFORM,SDHX,SDINP,SDIP
+2 KILL %ZIS,Y1,SDBD,SDCT,SDVAUTC,VAUTC,SDX,SDX1,SDNOSH,SDLT1,SDMSG,SDNODE,SDQ,SDRT,SDSOH,SDSTAT,SDT0,SDZSC,SM,SM1,STARTDAY,STIME,SDV,Z0,Z5
DO CLOSE^DGUTQ
QUIT
CHECK IF $SELECT('$DATA(^DPT(DFN,.35)):1,$PIECE(^(.35),"^",1)']"":1,1:0)
IF $DATA(^DPT(DFN,"S",GDATE,0))
IF $SELECT($PIECE(^(0),U,2)="N":1,$PIECE(^(0),U,2)="NA":1,$DATA(SDCP)&$PIECE(^(0),"^",2)["C":1,1:0)
IF $PIECE(^(0),"^",14)=SDTIME!(SDTIME="*")
IF '$DATA(^DPT(DFN,.1))
Begin DoDot:1
+1 DO BAD
if SDBAD
QUIT
+2 DO SET
End DoDot:1
+3 ;above logic changed SD*5.3*455
QUIT
SET IF SDLT1!SDLET
SET ^UTILITY($JOB,"SDLT",$SELECT(SDLT1:SDLT1,1:SDLET),DFN,GDATE)=C_"^"_$PIECE(^DPT(DFN,"S",GDATE,0),"^",10)
QUIT
+1 SET ^UTILITY($JOB,"NO",DFN,GDATE)=C
QUIT
CHECK1 SET SDV=$PIECE(^SC(C,0),"^",15)
IF $PIECE(^(0),"^",3)="C"
IF $SELECT('$DATA(^SC(C,"I")):1,'(+^("I")):1,+^("I")>DATEND:1,+$PIECE(^("I"),"^",2)'>DATEND&(+$PIECE(^("I"),"^",2)):1,1:0)
+1 QUIT
WR KILL CNN
FOR J=0:0
SET J=$ORDER(^UTILITY($JOB,"SDLT",SDLET,A,J))
if J=""
QUIT
SET SDR=0
SET SDX=J
SET CNN(J)=^(J)
SET CLIN=$PIECE(^SC(+$PIECE(CNN(J),"^",1),0),"^",1)
SET SDC=+CNN(J)
SET S=$SELECT($DATA(^DPT(A,"S",J,0)):^(0),1:"")
DO WRAPP^SDLT
DO SET1
+1 if SDR
DO SDR
DO REST^SDLT
QUIT
SDR WRITE !!,"The appointment(s) have been rescheduled as follows:",!
+1 FOR J=0:0
SET J=$ORDER(CNN(J))
if J=""
QUIT
SET SDX=$PIECE(CNN(J),"^",2)
SET SDC=$PIECE(CNN(J),"^")
IF SDX
SET S=$SELECT($DATA(^DPT(A,"S",SDX,0)):^(0),1:"")
DO WRAPP^SDLT
+2 QUIT
SET1 if 'SDR
SET SDR=$SELECT($PIECE(CNN(J),"^",2)]"":1,1:0)
QUIT
+1 QUIT
LT if 'SDLT1
SET SDLET=0
IF $DATA(^SC(C,"LTR"))
IF ^("LTR")
SET SDLET=+^("LTR")
+1 QUIT
NDT WRITE !?15,$PIECE(^SC(+^UTILITY($JOB,"NO",A,A1),0),"^")," on "
SET Y=A1
DO DT^DIQ
QUIT
KLL KILL ^UTILITY($JOB,A,C)
QUIT
BAD SET SDBAD=$$BADADR^DGUTL3(+DFN)
+1 if SDBAD
SET ^TMP($JOB,"BADADD",$PIECE(^DPT(+DFN,0),"^"),+DFN)=""
+2 QUIT
