- 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 Feb 19, 2025@00:25:20 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