- SDCNL ;ALB/LDB - CANCELLED APPOINTMENT LETTER ; 25 MAR 88@13:00
- ;;5.3;Scheduling;**330,340,407,398,1015**;Aug 13, 1993;Build 21
- ;IHS/ANMC/LJF 8/18/2000 changed $N to $O
- ; 11/24/2000 moved letter's left margin in 5 spaces
- ; 11/29/2000 added count of rescheduled appts (BSDCNT)
- ;
- N SDBAD S (SDOK,SDV)=0 I $D(^DG(43,1,"GL")),$P(^("GL"),"^",2) S SDV=1
- G:"Cc"[S1 ASDCN
- PT S (SDPT,SDINP)=0 F B=0:0 S SDPT=$O(VAUTN(SDPT)) Q:SDPT="" D
- .S SDBAD=$$BADADR^DGUTL3(SDPT) I SDBAD S ^TMP($J,"BADADD",$P(^DPT(+SDPT,0),"^"),+SDPT)="" Q
- .W:$D(^DPT(SDPT,.1)) !,$P(^DPT(SDPT,0),"^")," ",$P(^(0),"^",9)," is currently an inpatient!" S:$D(^DPT(SDPT,.1)) SDINP=1 D:'SDINP START S SDINP=0
- D:$O(^UTILITY($J,0)) PR Q
- START ;F SDX=SDBD:0 S SDX=$N(^DPT(SDPT,"S",SDX)) Q:SDX>(SDED+.9999)!(SDX'>0) S SDAP=^DPT(SDPT,"S",SDX,0),SDV2=0 I $P(SDAP,"^",2)["C" D MDIV I SDV2!'SDV S SDC=+SDAP D CHK1 I 'SDOK D CHK ;IHS/ANMC/LJF 8/18/2000
- F SDX=SDBD:0 S SDX=$O(^DPT(SDPT,"S",SDX)) Q:SDX>(SDED+.9999)!(SDX'>0) S SDAP=^DPT(SDPT,"S",SDX,0),SDV2=0 I $P(SDAP,"^",2)["C" D MDIV I SDV2!'SDV S SDC=+SDAP D CHK1 I 'SDOK D CHK ;IHS/ANMC/LJF 8/18/2000
- Q
- PR N SDFIRST S SDFIRST=1
- S SDLET="" F A0=0:0 S SDLET=$O(^UTILITY($J,SDLET)) Q:'SDLET S (B0,X7)="" F A1=0:0 S A5=B0,B0=$O(^UTILITY($J,SDLET,B0)) D:B0="" R Q:B0="" D R:A5&(B0'=A5) S A=B0 D ^SDLT F A2=0:0 S X7=$O(^UTILITY($J,SDLET,B0,X7)) Q:X7="" D S,WRAPP^SDLT
- I $D(^UTILITY($J,"NO")) D NO W:$D(DUZ) !!,"Printed by: ",$P(^VA(200,DUZ,0),"^")
- I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD")
- D END
- Q
- END D END^SDN1 K ^UTILITY($J),A0,A1,A3,A5,ALL,B0,SDA,SDINP,SDOK,SDS,SDV,SDV21,SDX,SDX1,SDX8,Z0,Z5,ZTSK,SDAP,X7,DIC,DGPGM,DGVAR,SDPT
- K BEGDATE,DTOUT,DUOUT,ENDDATE,SDBD,SDBD1,SDCP,SDED,SDLET,SDLET1,SDV,SDV2,X8,Y Q
- MDIV S SDAP=^DPT(SDPT,"S",SDX,0),SDV=$P(^SC(+SDAP,0),"^",15) I SDV=SDV1 S SDV2=1 Q
- Q
- CAN S SDAP=^DPT(SDPT,"S",SDX,0),SDC=+SDAP
- S SDLET="" I $D(^SC(SDC,"LTR")),'SDLT1 S SDLET=$S('SD9:$P(^("LTR"),"^",4),1:$P(^("LTR"),"^",3))
- I 'SDLET&'SDLT1 S ^UTILITY($J,"NO",SDPT,SDC,SDX)=""
- S SDAP=^DPT(SDPT,"S",SDX,0) I SDLET!SDLT1 S ^UTILITY($J,$S(SDLET:SDLET,1:SDLT1),SDPT,SDX)=SDC
- I (SDLET!SDLT1),$P(SDAP,"^",10),$D(^DPT(SDPT,"S",$P(SDAP,"^",10))),$P(^DPT(SDPT,"S",$P(SDAP,"^",10),0),"^",2)'["C" S ^UTILITY($J,$S(SDLET:SDLET,1:SDLT1),SDPT,SDX)=$P(SDAP,"^")_"^"_$P(SDAP,"^",10)
- Q
- ASDCN I 'VAUTC S SDC=0 F Z=0:0 S SDC=$O(VAUTC(SDC)) Q:SDC="" S SDAP=SDC D ASDCN1
- G:'VAUTC PR
- I VAUTC S SDC=0 F Z=0:0 S SDC=$O(^SC(SDC)) Q:'SDC I $P(^SC(SDC,0),"^",3)="C",$S($P(^(0),"^",15)=SDV1:1,'$P(^(0),"^",15):1,1:0),'$D(SDVAUTC(SDC)) S SDAP=SDC D ASDCN1
- G:VAUTC PR
- ASDCN1 S SDX=SDBD F W=0:0 S SDX=$O(^DPT("ASDCN",SDC,SDX)) Q:(SDX>(SDED+.9))!(SDX="") S SDPT=0 F T=0:0 S SDPT=$O(^DPT("ASDCN",SDC,SDX,SDPT)) Q:SDPT="" I $D(^DPT(SDPT,"S",SDX,0)),$P(^(0),"^")=SDC,'$D(^DPT(SDPT,.1)) D CHK1 D:'SDOK CHK
- Q
- R S SDR=0,SDX8="",SDA=A5
- ;
- ;IHS/ANMC/LJF 11/24/2000;11/29/2000
- ;F A3=0:0 S SDX8=$O(^UTILITY($J,SDLET,A5,SDX8)) Q:SDX8="" I ^(SDX8),$P(^(SDX8),"^",2) S SDX=$P(^(SDX8),"^",2),SDC=$P(^(SDX8),"^"),(DFN,A)=A5,SDS=^DPT(DFN,"S",SDX,0) W:'SDR !!,"The rescheduled appointment(s) follow:",! D WRAPP^SDLT S SDR=1
- K BSDCNT
- F A3=0:0 S SDX8=$O(^UTILITY($J,SDLET,A5,SDX8)) Q:SDX8="" I ^(SDX8),$P(^(SDX8),"^",2) D
- . S SDX=$P(^(SDX8),"^",2),SDC=$P(^(SDX8),"^"),(DFN,A)=A5,SDS=^DPT(DFN,"S",SDX,0)
- . W:'SDR !!?5,"The rescheduled appointment(s) follow:",! D WRAPP^SDLT S BSDCNT=$G(BSDCNT)+1 S SDR=1
- ;
- D REST^SDLT Q
- S S A=B0,SDX=X7,SDS=^DPT(A,"S",SDX,0),SDC=+^(0) Q
- NO W @IOF S SDPT=""
- F A3=0:0 S SDPT=$O(^UTILITY($J,"NO",SDPT)) Q:SDPT="" S SDC="" F A4=0:0 S SDC=$O(^UTILITY($J,"NO",SDPT,SDC)) Q:SDC="" D NOAP S SDAP="" F A5=0:0 S SDAP=$O(^UTILITY($J,"NO",SDPT,SDC,SDAP)) D:SDAP="" NOAP2 Q:SDAP="" W ! D NOAP1
- Q
- NOAP W !!,$P(^DPT(SDPT,0),"^")," ",$P(^(0),"^",9),!,"has the following cancelled appointment(s) in ",$P(^SC(SDC,0),"^")," CLINIC" Q
- NOAP1 S Y=SDAP D DT^DIQ Q
- NOAP2 W !,"but no letter is assigned to the clinic" Q
- S Y=SDAP D DT^DIQ W ! Q
- Q
- CHK S DFN=SDPT D DEM^VADPT I VADM(6) D KVAR^VADPT Q
- S SDBAD=$$BADADR^DGUTL3(SDPT) I SDBAD S ^TMP($J,"BADADD",$P(^DPT(+SDPT,0),"^"),+SDPT)="" Q
- D CAN:$D(^DPT("ASDCN",SDC,SDX,SDPT)),KVAR^VADPT Q
- CHK1 S SDOK=0 I '$D(^SC(+SDAP,"S",SDX)) Q
- I $D(^SC(+SDAP,"S",SDX)) F P=0:0 S P=$O(^SC(+SDAP,"S",SDX,1,P)) Q:P'>0 I $P(^(P,0),"^")=SDPT S SDOK=1
- Q
- SDCNL ;ALB/LDB - CANCELLED APPOINTMENT LETTER ; 25 MAR 88@13:00
- +1 ;;5.3;Scheduling;**330,340,407,398,1015**;Aug 13, 1993;Build 21
- +2 ;IHS/ANMC/LJF 8/18/2000 changed $N to $O
- +3 ; 11/24/2000 moved letter's left margin in 5 spaces
- +4 ; 11/29/2000 added count of rescheduled appts (BSDCNT)
- +5 ;
- +6 NEW SDBAD
- SET (SDOK,SDV)=0
- IF $DATA(^DG(43,1,"GL"))
- IF $PIECE(^("GL"),"^",2)
- SET SDV=1
- +7 IF "Cc"[S1
- GOTO ASDCN
- PT SET (SDPT,SDINP)=0
- FOR B=0:0
- SET SDPT=$ORDER(VAUTN(SDPT))
- IF SDPT=""
- QUIT
- Begin DoDot:1
- +1 SET SDBAD=$$BADADR^DGUTL3(SDPT)
- IF SDBAD
- SET ^TMP($JOB,"BADADD",$PIECE(^DPT(+SDPT,0),"^"),+SDPT)=""
- QUIT
- +2 IF $DATA(^DPT(SDPT,.1))
- WRITE !,$PIECE(^DPT(SDPT,0),"^")," ",$PIECE(^(0),"^",9)," is currently an inpatient!"
- IF $DATA(^DPT(SDPT,.1))
- SET SDINP=1
- IF 'SDINP
- DO START
- SET SDINP=0
- End DoDot:1
- +3 IF $ORDER(^UTILITY($JOB,0))
- DO PR
- QUIT
- START ;F SDX=SDBD:0 S SDX=$N(^DPT(SDPT,"S",SDX)) Q:SDX>(SDED+.9999)!(SDX'>0) S SDAP=^DPT(SDPT,"S",SDX,0),SDV2=0 I $P(SDAP,"^",2)["C" D MDIV I SDV2!'SDV S SDC=+SDAP D CHK1 I 'SDOK D CHK ;IHS/ANMC/LJF 8/18/2000
- +1 ;IHS/ANMC/LJF 8/18/2000
- FOR SDX=SDBD:0
- SET SDX=$ORDER(^DPT(SDPT,"S",SDX))
- IF SDX>(SDED+.9999)!(SDX'>0)
- QUIT
- SET SDAP=^DPT(SDPT,"S",SDX,0)
- SET SDV2=0
- IF $PIECE(SDAP,"^",2)["C"
- DO MDIV
- IF SDV2!'SDV
- SET SDC=+SDAP
- DO CHK1
- IF 'SDOK
- DO CHK
- +2 QUIT
- PR NEW SDFIRST
- SET SDFIRST=1
- +1 SET SDLET=""
- FOR A0=0:0
- SET SDLET=$ORDER(^UTILITY($JOB,SDLET))
- IF 'SDLET
- QUIT
- SET (B0,X7)=""
- FOR A1=0:0
- SET A5=B0
- SET B0=$ORDER(^UTILITY($JOB,SDLET,B0))
- IF B0=""
- DO R
- IF B0=""
- QUIT
- IF A5&(B0'=A5)
- DO R
- SET A=B0
- DO ^SDLT
- FOR A2=0:0
- SET X7=$ORDER(^UTILITY($JOB,SDLET,B0,X7))
- IF X7=""
- QUIT
- DO S
- DO WRAPP^SDLT
- +2 IF $DATA(^UTILITY($JOB,"NO"))
- DO NO
- IF $DATA(DUZ)
- WRITE !!,"Printed by: ",$PIECE(^VA(200,DUZ,0),"^")
- +3 IF $DATA(^TMP($JOB,"BADADD"))
- DO BADADD^SDLT
- KILL ^TMP($JOB,"BADADD")
- +4 DO END
- +5 QUIT
- END DO END^SDN1
- KILL ^UTILITY($JOB),A0,A1,A3,A5,ALL,B0,SDA,SDINP,SDOK,SDS,SDV,SDV21,SDX,SDX1,SDX8,Z0,Z5,ZTSK,SDAP,X7,DIC,DGPGM,DGVAR,SDPT
- +1 KILL BEGDATE,DTOUT,DUOUT,ENDDATE,SDBD,SDBD1,SDCP,SDED,SDLET,SDLET1,SDV,SDV2,X8,Y
- QUIT
- MDIV SET SDAP=^DPT(SDPT,"S",SDX,0)
- SET SDV=$PIECE(^SC(+SDAP,0),"^",15)
- IF SDV=SDV1
- SET SDV2=1
- QUIT
- +1 QUIT
- CAN SET SDAP=^DPT(SDPT,"S",SDX,0)
- SET SDC=+SDAP
- +1 SET SDLET=""
- IF $DATA(^SC(SDC,"LTR"))
- IF 'SDLT1
- SET SDLET=$SELECT('SD9:$PIECE(^("LTR"),"^",4),1:$PIECE(^("LTR"),"^",3))
- +2 IF 'SDLET&'SDLT1
- SET ^UTILITY($JOB,"NO",SDPT,SDC,SDX)=""
- +3 SET SDAP=^DPT(SDPT,"S",SDX,0)
- IF SDLET!SDLT1
- SET ^UTILITY($JOB,$SELECT(SDLET:SDLET,1:SDLT1),SDPT,SDX)=SDC
- +4 IF (SDLET!SDLT1)
- IF $PIECE(SDAP,"^",10)
- IF $DATA(^DPT(SDPT,"S",$PIECE(SDAP,"^",10)))
- IF $PIECE(^DPT(SDPT,"S",$PIECE(SDAP,"^",10),0),"^",2)'["C"
- SET ^UTILITY($JOB,$SELECT(SDLET:SDLET,1:SDLT1),SDPT,SDX)=$PIECE(SDAP,"^")_"^"_$PIECE(SDAP,"^",10)
- +5 QUIT
- ASDCN IF 'VAUTC
- SET SDC=0
- FOR Z=0:0
- SET SDC=$ORDER(VAUTC(SDC))
- IF SDC=""
- QUIT
- SET SDAP=SDC
- DO ASDCN1
- +1 IF 'VAUTC
- GOTO PR
- +2 IF VAUTC
- SET SDC=0
- FOR Z=0:0
- SET SDC=$ORDER(^SC(SDC))
- IF 'SDC
- QUIT
- IF $PIECE(^SC(SDC,0),"^",3)="C"
- IF $SELECT($PIECE(^(0),"^",15)=SDV1:1,'$PIECE(^(0),"^",15):1,1:0)
- IF '$DATA(SDVAUTC(SDC))
- SET SDAP=SDC
- DO ASDCN1
- +3 IF VAUTC
- GOTO PR
- ASDCN1 SET SDX=SDBD
- FOR W=0:0
- SET SDX=$ORDER(^DPT("ASDCN",SDC,SDX))
- IF (SDX>(SDED+.9))!(SDX="")
- QUIT
- SET SDPT=0
- FOR T=0:0
- SET SDPT=$ORDER(^DPT("ASDCN",SDC,SDX,SDPT))
- IF SDPT=""
- QUIT
- IF $DATA(^DPT(SDPT,"S",SDX,0))
- IF $PIECE(^(0),"^")=SDC
- IF '$DATA(^DPT(SDPT,.1))
- DO CHK1
- IF 'SDOK
- DO CHK
- +1 QUIT
- R SET SDR=0
- SET SDX8=""
- SET SDA=A5
- +1 ;
- +2 ;IHS/ANMC/LJF 11/24/2000;11/29/2000
- +3 ;F A3=0:0 S SDX8=$O(^UTILITY($J,SDLET,A5,SDX8)) Q:SDX8="" I ^(SDX8),$P(^(SDX8),"^",2) S SDX=$P(^(SDX8),"^",2),SDC=$P(^(SDX8),"^"),(DFN,A)=A5,SDS=^DPT(DFN,"S",SDX,0) W:'SDR !!,"The rescheduled appointment(s) follow:",! D WRAPP^SDLT S SDR=1
- +4 KILL BSDCNT
- +5 FOR A3=0:0
- SET SDX8=$ORDER(^UTILITY($JOB,SDLET,A5,SDX8))
- IF SDX8=""
- QUIT
- IF ^(SDX8)
- IF $PIECE(^(SDX8),"^",2)
- Begin DoDot:1
- +6 SET SDX=$PIECE(^(SDX8),"^",2)
- SET SDC=$PIECE(^(SDX8),"^")
- SET (DFN,A)=A5
- SET SDS=^DPT(DFN,"S",SDX,0)
- +7 IF 'SDR
- WRITE !!?5,"The rescheduled appointment(s) follow:",!
- DO WRAPP^SDLT
- SET BSDCNT=$GET(BSDCNT)+1
- SET SDR=1
- End DoDot:1
- +8 ;
- +9 DO REST^SDLT
- QUIT
- S SET A=B0
- SET SDX=X7
- SET SDS=^DPT(A,"S",SDX,0)
- SET SDC=+^(0)
- QUIT
- NO WRITE @IOF
- SET SDPT=""
- +1 FOR A3=0:0
- SET SDPT=$ORDER(^UTILITY($JOB,"NO",SDPT))
- IF SDPT=""
- QUIT
- SET SDC=""
- FOR A4=0:0
- SET SDC=$ORDER(^UTILITY($JOB,"NO",SDPT,SDC))
- IF SDC=""
- QUIT
- DO NOAP
- SET SDAP=""
- FOR A5=0:0
- SET SDAP=$ORDER(^UTILITY($JOB,"NO",SDPT,SDC,SDAP))
- IF SDAP=""
- DO NOAP2
- IF SDAP=""
- QUIT
- WRITE !
- DO NOAP1
- +2 QUIT
- NOAP WRITE !!,$PIECE(^DPT(SDPT,0),"^")," ",$PIECE(^(0),"^",9),!,"has the following cancelled appointment(s) in ",$PIECE(^SC(SDC,0),"^")," CLINIC"
- QUIT
- NOAP1 SET Y=SDAP
- DO DT^DIQ
- QUIT
- NOAP2 WRITE !,"but no letter is assigned to the clinic"
- QUIT
- +1 SET Y=SDAP
- DO DT^DIQ
- WRITE !
- QUIT
- +2 QUIT
- CHK SET DFN=SDPT
- DO DEM^VADPT
- IF VADM(6)
- DO KVAR^VADPT
- QUIT
- +1 SET SDBAD=$$BADADR^DGUTL3(SDPT)
- IF SDBAD
- SET ^TMP($JOB,"BADADD",$PIECE(^DPT(+SDPT,0),"^"),+SDPT)=""
- QUIT
- +2 IF $DATA(^DPT("ASDCN",SDC,SDX,SDPT))
- DO CAN
- DO KVAR^VADPT
- QUIT
- CHK1 SET SDOK=0
- IF '$DATA(^SC(+SDAP,"S",SDX))
- QUIT
- +1 IF $DATA(^SC(+SDAP,"S",SDX))
- FOR P=0:0
- SET P=$ORDER(^SC(+SDAP,"S",SDX,1,P))
- IF P'>0
- QUIT
- IF $PIECE(^(P,0),"^")=SDPT
- SET SDOK=1
- +2 QUIT
