source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDN.m@ 1104

SDN ;SF/GFT,ALB/LDB - RECORD NO SHOWS ; 5/26/05 11:55am
 ;;5.3;Scheduling;**32,79,398,478**;Aug 13, 1993
 N SDATA ; for evt driver
 S U="^" D NOW^%DTC S SDTIME=%,SDLT1="" K ^UTILITY($J),SDCP,SDLT D LO^DGUTL
 S SDDT=DT,SDV1=$O(^DG(40.8,0)) D DIV^SDUTL I $T S DIC=40.8,DIC(0)="AEQM" S SDLT=1 D NSLET1^SDDIV K SDLT G:Y<0 END^SDN0 S SDV1=DIV
7 R !!,"NO-SHOWS FOR WHAT DATE: ",X:DTIME Q:U[X  S %DT="EP",%DT(0)=-DT D ^%DT G 7:Y<0 S SDT=Y,SDYES=""
 S SM="S SDCT=0 F I=SD1:0:SD2 S I=$N(^DPT(+Y,""S"",I)) S:I<0!(I'<SD2) I=9999999 I I\1=SDT,$D(^(I,0)),+^(0)=SC,$P(^(0),U,2)'[""C"",'$$CODT^SDCOU(+Y,I,SC) Q"
 S SM1="S SDCT=0 F I=SD1:0 S I=$N(^DPT(+Y,""S"",I)) Q:I<0!(I'<SD2)  I I\1=SDT,$D(^(I,0)),+^(0)=SC,$P(^(0),""^"",2)'[""C"",'$$CODT^SDCOU(+Y,I,SC) S SDCT=SDCT+1,SDT(SDCT)=I"
71 W ! K DIC S SC=0,DIC="^SC(",DIC(0)="AEMQ",DIC("A")="Select CLINIC NAME: ",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS"")),$S($P(^(0),""^"",15)=SDV1:1,'$P(^(0),""^"",15):1,'SDV1:1,1:0)"
 D ^DIC K DIC("A"),DIC("S") G 73:Y<0 S SC=+Y,SD1=SDT,SD2=SDT+1 S SDMSG=" DOES NOT HAVE A NO-SHOW LETTER ASSIGNED TO IT!"
72 Q:$D(SDNSACT)  S SD1=SDT,DIC="^DPT(",DIC(0)="AEMQ",DIC("S")=SM
 K SDT S SDT=SD1
 D ^DIC K DIC("S") G 71:"^"[X,72:Y<0 S DFN=+Y X SM1 D SDMLT Q:'SDCT  S I=SDT(SDCT)
EN1 ; -- entry pt for protocol action
 S SDSTAT=$P(^DPT(+DFN,"S",I,0),U,2) I SDSTAT="I" D NS^SDN2 G 72
 I SDSTAT=""!(SDSTAT="NT") D  G 72
 .N SDNSHDL,SDDA S SDNSHDL=$$HANDLE^SDAMEVT(1),SDDA=$$FIND^SDAM2(DFN,I,SC)
 .S SDDTM=I D BEFORE^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,SDNSHDL)
 .S $P(^DPT(+DFN,"S",I,0),U,2)="N",$P(^(0),"^",14)=SDTIME S:$D(DUZ) $P(^(0),"^",12)=DUZ
 .S:'SDYES SDYES=1
 .S:'$D(^UTILITY($J,"CL",DFN,SC,I))&(SDSTAT'="C") ^(I)=""
 .W "...OK   New Status: ",$P($$STATUS^SDAM1(DFN,I,SC,^DPT(DFN,"S",I,0),SDDA),";",3)
 .D EVT K SDATA
 W:$P(^DPT(+DFN,"S",I,0),U,2)["A" *7,!,"THIS APPOINTMENT ALREADY A NO-SHOW AND REBOOKED... ARE YOU SURE YOU"
ALNS S %=2 W:$P(^DPT(+DFN,"S",I,0),U,2)'["A" !,*7,"  ALREADY RECORDED AS NO-SHOW..." W " WANT TO ERASE" D YN^DICN I '% W !,"RESPOND YES OR NO" G ALNS
 I (%-1) G 72
 I '(%-1) W "...NO LONGER A NO-SHOW!" D
 .N SDNSHDL,SDDA S SDNSHDL=$$HANDLE^SDAMEVT(1),SDDA=$$FIND^SDAM2(DFN,I,SC)
 .S SDDTM=I D BEFORE^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,SDNSHDL)
 .S SDINP=$$INP^SDAM2(DFN,SDDTM),X=I,Y=DFN
 .S $P(^DPT(+Y,"S",SDDTM,0),U,2)=$S(SDINP["I":SDINP,1:""),$P(^(0),"^",14)="",$P(^(0),"^",12)=""
 .I SDINP="",$$CHK^SDM1A(SC,SDDTM),+$$STATUS^SDAM1(DFN,SDDTM,SC,^DPT(DFN,"S",SDDTM,0),SDDA)'=1 S $P(^DPT(DFN,"S",SDDTM,0),U,2)="NT" ; not inpt and not ci
 .D EVT K SDATA
 .K SDINP,^UTILITY($J,"CL",+Y,SC,SDDTM),SDDTM
 G 72
73 ;
 G:SDYES ASKA G END^SDN0
CK1 S SD1=I X SM I I<SD2,$P(^DPT(+Y,"S",I,0),U,2)["C" S POP=1
 S:I'<SD2 POP=1 Q:'POP  I I'<SD2 S POP=1 Q
 G CK1
ASKA S %=2,DTOUT=0 W !,"WANT TO AUTO-REBOOK NO-SHOW APPOINTMENTS NOW" D YN^DICN I '% W !,"RESPOND YES (Y) OR NO (N)" G ASKA
 W:DTOUT " NO" S ANS=$S(%=1:"Y",1:"N"),(SDED,DATEND)=SDT+.9
 I $D(SDNSACT),'SDNSACT,%=1 S SDNSACT=1 ;No-show action flag
ASKL S %=1,DTOUT=0,SDLET="" W !,"WANT LETTERS PRINTED NOW" D YN^DICN I '% W !,"RESPOND YES (Y) OR NO (N)" G ASKL
 W:DTOUT " NO" S ALS=$S(%=1:"Y",1:"N")
 I $D(SDNSACT),(ALS="Y"),$$BADADR^DGUTL3(+DFN) D  ;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 ALS="N"
 . S DIR(0)="E" D ^DIR K DIR(0)
 I ALS'["Y"&(ANS'["Y") D DIS^SDNDIS G END^SDN0
RD1 I $D(SDNSACT) S Y=SC G RD2
 R !!,"FOR CLINIC: ALL// ",X:DTIME K C,DIC Q:X="^"  S X=$$UP^XLFSTR(X) G AOR:X="ALL"!(X="") I X?.E1"?" W !,?3,"ENTER A CLINIC NAME, OR 'ALL' FOR ALL CLINICS" G RD1
 S DIC(0)="QEM",DIC=44,DIC("S")="I $P(^(0),""^"",3)=""C""" D ^DIC K DIC("S") G:Y<0 RD1
RD2 S C=+Y I '$D(^SC(C,"LTR")) W !,$P(^SC(C,0),"^")_SDMSG S ALS="N"
 I $D(^SC(C,"LTR")),'+^("LTR") W !,$P(^SC(C,0),"^")_SDMSG S ALS="N"
 I $D(^SC(C,"LTR")),+^("LTR") S SDLET=+^("LTR")
AOR S:'$D(C) C="ALL" I ANS'["Y"&(ALS'["Y") D DIS^SDNDIS G END^SDN0
 D DIS^SDNDIS
 ;S DGPGM="START^SDN0",DGVAR="SC^SDDT^ALS^ANS^SDLET^SDV1^SDT^C^DATEND^SDTIME^SDLT1"
 ;S POP=0 D ZIS^DGUTQ G:POP END^SDN0
 S %ZIS="MQ" K IO("Q") D ^%ZIS G:POP END^SDN0
 I $D(IO("Q")) D  D:IO'=IO(0) NSLTR W @IOF G END^SDN0
 .S ZTRTN="START^SDN0" F ZTS="SC","SDDT","ALS","ANS","SDLET","SDV1","SDT","C","DATEND","SDTIME","SDLT1","AUTO(" S ZTSAVE(ZTS)=""
 .K ZTS D ^%ZTLOAD
 D:IO'=IO(0) NSLTR D START^SDN0,^%ZISC W @IOF G END^SDN0
 ;G START^SDN0     ;???
 Q
NSLTR I ANS["Y",ALS["Y" S:$D(NSDIE) @(NSDIE_NSDA_",1,2,0)")="NO-SHOW AUTO-REBOOK letter printed." K NSDIE,NSDA ;SD/478 AT THIS POINT NO SHOW AUTO REBOOK LETTER IS PRINTED.
 I ALS["Y" S:$D(NSDIE) @(NSDIE_NSDA_",1,2,0)")="NO-SHOW letter printed." K NSDIE,NSDA ;SD/478 AT THIS POINT NO SHOW LETTER IS PRINTED.
 Q
SDMLT ;
 N SDCNT,SDSTAT
 S SDCNT=SDCT,SDCT=0
 F  S SDCT=$O(SDT(SDCT)) Q:'SDCT  D
 .S SDSTAT=$$STATUS^SDAM1(DFN,SDT(SDCT),SC,^DPT(DFN,"S",SDT(SDCT),0))
 .W !,SDCT,"). ",$$FTIME^VALM1(SDT(SDCT)),"   Status: ",$P(SDSTAT,";",3) W:$P(SDSTAT,";",4) *7
 S SDCT=SDCNT
ASK I SDCT>1!($P(SDSTAT,";",4)) R !!,"SELECT APPOINTMENT: ",SDCT:DTIME Q:'$T!(U[SDCT)  I SDCT["?"!('$D(SDT(SDCT))) W !,"Please enter one number to indicate which appointment." S SDCT=SDCNT G ASK
 W ! Q
 ;
EVT ; -- separate tag if need to NEW vars
 N I,SDINP,Y,SDSTAT,SDTIME,SDYES,SM,SM1,SD1,SD2,SDMSG,SDT,SDCT,CNSTLNK,CN,CNPAT
 D NOSHOW^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,0,SDNSHDL)
 S CNSTLNK="",CN=0 F  S CN=$O(^SC(SC,"S",SDDTM,1,CN)) Q:'+CN  S CNPAT=$P($G(^SC(SC,"S",SDDTM,1,CN,0)),U) I CNPAT=DFN S CNSTLNK=$P($G(^SC(SC,"S",SDDTM,1,CN,"CONS")),U) Q  ;SD/478
 D:+CNSTLNK NOSHOW^SDCNSLT(SC,SDDTM,CNPAT,CNSTLNK,CN,.AUTO,.NSDIE,.NSDA) ;SD/478
 Q
 ;