SDN ;SF/GFT,ALB/LDB - RECORD NO SHOWS ; 5/26/05 11:55am
;;5.3;Scheduling;**32,79,398,478,1013,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 11/09/2000 allow rebook & print letters anytime
; 11/30/2000 changed $N to $O
; 12/01/2000 added ability to select letter to print
; 12/13/2000 changed default to NO on printing letters
; added message to device prompt
;
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=$N(^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 ;IHS/ANMC/LJF 11/30/2000
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 ;IHS/ANMC/LJF 11/30/2000 $N->$O
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" ;IHS/ANMC/LJF 11/30/2000
S SM="S SDCT=0 F I=SD1:0:SD2 S I=$O(^DPT(+Y,""S"",I)) S:I<1!(I'<SD2) I=9999999 I I\1=SDT,$D(^(I,0)),+^(0)=SC,$P(^(0),U,2)'[""C"",'$$CODT^SDCOU(+Y,I,SC) Q" ;IHS/ANMC/LJF 11/30/2000 $N->$O
;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" ;IHS/ANMC/LJF 11/30/2000
S SM1="S SDCT=0 F I=SD1:0 S I=$O(^DPT(+Y,""S"",I)) Q:I<1!(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" ;IHS/ANMC/LJF 11/30/2000 $N->$O
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)
.I '$G(I) S I=SDDTM ;ihs/cmi/maw 11/22/2010 patch 1013 bug found at swinomish, call to BEFORE^SDAMEVT calls OE which apparently messes up I
.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 ;IHS/ANMC/LJF 11/09/2000
I (%-1) S SDTIME=$P(^DPT(+DFN,"S",I,0),U,14),SDYES=1 G 72 ;IHS/ANMC/LJF 11/09/2000 letter won't print unless SDTIME set to date/time no-show entered
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 ;IHS/ANMC/LJF 12/13/2000
S %=2,DTOUT=0,SDLET="" W !,"WANT LETTERS PRINTED NOW" D YN^DICN I '% W !,"RESPOND YES (Y) OR NO (N)" G ASKL ;IHS/ANMC/LJF 12/13/2000
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
NEW BSDALS S BSDALS=ALS ;IHS/ANMC/LJF 12/01/2000 save user's answer
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")
I BSDALS="Y" S BSDLET=+$$READ^BDGF("P^407.5:EMQZ","Select Letter to Print",$$GET1^DIQ(407.5,+$G(SDLET),.01),"","I $P(^VA(407.5,+Y,0),U,2)=""N""") ;IHS/ANMC/LJF 12/01/2000
S ALS=$S($G(BSDLET):"Y",1:"N") ;IHS/ANMC/LJF 12/01/2000
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)
;Q ;ihs/cmi/maw 02/27/2012 patch 1015 no consult link in IHS for NOSHOW
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
;
SDN ;SF/GFT,ALB/LDB - RECORD NO SHOWS ; 5/26/05 11:55am
+1 ;;5.3;Scheduling;**32,79,398,478,1013,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/09/2000 allow rebook & print letters anytime
+3 ; 11/30/2000 changed $N to $O
+4 ; 12/01/2000 added ability to select letter to print
+5 ; 12/13/2000 changed default to NO on printing letters
+6 ; added message to device prompt
+7 ;
+8 ; for evt driver
NEW SDATA
+9 SET U="^"
DO NOW^%DTC
SET SDTIME=%
SET SDLT1=""
KILL ^UTILITY($JOB),SDCP,SDLT
DO LO^DGUTL
+10 ;S SDDT=DT,SDV1=$N(^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 ;IHS/ANMC/LJF 11/30/2000
+11 ;IHS/ANMC/LJF 11/30/2000 $N->$O
SET SDDT=DT
SET SDV1=$ORDER(^DG(40.8,0))
DO DIV^SDUTL
IF $TEST
SET DIC=40.8
SET DIC(0)="AEQM"
SET SDLT=1
DO NSLET1^SDDIV
KILL SDLT
IF Y<0
GOTO END^SDN0
SET SDV1=DIV
7 READ !!,"NO-SHOWS FOR WHAT DATE: ",X:DTIME
IF U[X
QUIT
SET %DT="EP"
SET %DT(0)=-DT
DO ^%DT
IF Y<0
GOTO 7
SET SDT=Y
SET SDYES=""
+1 ;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" ;IHS/ANMC/LJF 11/30/2000
+2 ;IHS/ANMC/LJF 11/30/2000 $N->$O
SET SM="S SDCT=0 F I=SD1:0:SD2 S I=$O(^DPT(+Y,""S"",I)) S:I<1!(I'<SD2) I=9999999 I I\1=SDT,$D(^(I,0)),+^(0)=SC,$P(^(0),U,2)'[""C"",'$$CODT^SDCOU(+Y,I,SC) Q"
+3 ;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" ;IHS/ANMC/LJF 11/30/2000
+4 ;IHS/ANMC/LJF 11/30/2000 $N->$O
SET SM1="S SDCT=0 F I=SD1:0 S I=$O(^DPT(+Y,""S"",I)) Q:I<1!(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 WRITE !
KILL DIC
SET SC=0
SET DIC="^SC("
SET DIC(0)="AEMQ"
SET DIC("A")="Select CLINIC NAME: "
SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS"")),$S($P(^(0),""^"",15)=SDV1:1,'$P(^(0),""^"",15):1,'SDV1:1,1:0)"
+1 DO ^DIC
KILL DIC("A"),DIC("S")
IF Y<0
GOTO 73
SET SC=+Y
SET SD1=SDT
SET SD2=SDT+1
SET SDMSG=" DOES NOT HAVE A NO-SHOW LETTER ASSIGNED TO IT!"
72 IF $DATA(SDNSACT)
QUIT
SET SD1=SDT
SET DIC="^DPT("
SET DIC(0)="AEMQ"
SET DIC("S")=SM
+1 KILL SDT
SET SDT=SD1
+2 DO ^DIC
KILL DIC("S")
IF "^"[X
GOTO 71
IF Y<0
GOTO 72
SET DFN=+Y
XECUTE SM1
DO SDMLT
IF 'SDCT
QUIT
SET I=SDT(SDCT)
EN1 ; -- entry pt for protocol action
+1 SET SDSTAT=$PIECE(^DPT(+DFN,"S",I,0),U,2)
IF SDSTAT="I"
DO NS^SDN2
GOTO 72
+2 IF SDSTAT=""!(SDSTAT="NT")
Begin DoDot:1
+3 NEW SDNSHDL,SDDA
SET SDNSHDL=$$HANDLE^SDAMEVT(1)
SET SDDA=$$FIND^SDAM2(DFN,I,SC)
+4 SET SDDTM=I
DO BEFORE^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,SDNSHDL)
+5 ;ihs/cmi/maw 11/22/2010 patch 1013 bug found at swinomish, call to BEFORE^SDAMEVT calls OE which apparently messes up I
IF '$GET(I)
SET I=SDDTM
+6 SET $PIECE(^DPT(+DFN,"S",I,0),U,2)="N"
SET $PIECE(^(0),"^",14)=SDTIME
IF $DATA(DUZ)
SET $PIECE(^(0),"^",12)=DUZ
+7 IF 'SDYES
SET SDYES=1
+8 IF '$DATA(^UTILITY($JOB,"CL",DFN,SC,I))&(SDSTAT'="C")
SET ^(I)=""
+9 WRITE "...OK New Status: ",$PIECE($$STATUS^SDAM1(DFN,I,SC,^DPT(DFN,"S",I,0),SDDA),";",3)
+10 DO EVT
KILL SDATA
End DoDot:1
GOTO 72
+11 IF $PIECE(^DPT(+DFN,"S",I,0),U,2)["A"
WRITE *7,!,"THIS APPOINTMENT ALREADY A NO-SHOW AND REBOOKED... ARE YOU SURE YOU"
ALNS SET %=2
IF $PIECE(^DPT(+DFN,"S",I,0),U,2)'["A"
WRITE !,*7," ALREADY RECORDED AS NO-SHOW..."
WRITE " WANT TO ERASE"
DO YN^DICN
IF '%
WRITE !,"RESPOND YES OR NO"
GOTO ALNS
+1 ;I (%-1) G 72 ;IHS/ANMC/LJF 11/09/2000
+2 ;IHS/ANMC/LJF 11/09/2000 letter won't print unless SDTIME set to date/time no-show entered
IF (%-1)
SET SDTIME=$PIECE(^DPT(+DFN,"S",I,0),U,14)
SET SDYES=1
GOTO 72
+3 IF '(%-1)
WRITE "...NO LONGER A NO-SHOW!"
Begin DoDot:1
+4 NEW SDNSHDL,SDDA
SET SDNSHDL=$$HANDLE^SDAMEVT(1)
SET SDDA=$$FIND^SDAM2(DFN,I,SC)
+5 SET SDDTM=I
DO BEFORE^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,SDNSHDL)
+6 SET SDINP=$$INP^SDAM2(DFN,SDDTM)
SET X=I
SET Y=DFN
+7 SET $PIECE(^DPT(+Y,"S",SDDTM,0),U,2)=$SELECT(SDINP["I":SDINP,1:"")
SET $PIECE(^(0),"^",14)=""
SET $PIECE(^(0),"^",12)=""
+8 ; not inpt and not ci
IF SDINP=""
IF $$CHK^SDM1A(SC,SDDTM)
IF +$$STATUS^SDAM1(DFN,SDDTM,SC,^DPT(DFN,"S",SDDTM,0),SDDA)'=1
SET $PIECE(^DPT(DFN,"S",SDDTM,0),U,2)="NT"
+9 DO EVT
KILL SDATA
+10 KILL SDINP,^UTILITY($JOB,"CL",+Y,SC,SDDTM),SDDTM
End DoDot:1
+11 GOTO 72
73 ;
+1 IF SDYES
GOTO ASKA
GOTO END^SDN0
CK1 SET SD1=I
XECUTE SM
IF I<SD2
IF $PIECE(^DPT(+Y,"S",I,0),U,2)["C"
SET POP=1
+1 IF I'<SD2
SET POP=1
IF 'POP
QUIT
IF I'<SD2
SET POP=1
QUIT
+2 GOTO CK1
ASKA SET %=2
SET DTOUT=0
WRITE !,"WANT TO AUTO-REBOOK NO-SHOW APPOINTMENTS NOW"
DO YN^DICN
IF '%
WRITE !,"RESPOND YES (Y) OR NO (N)"
GOTO ASKA
+1 IF DTOUT
WRITE " NO"
SET ANS=$SELECT(%=1:"Y",1:"N")
SET (SDED,DATEND)=SDT+.9
+2 ;No-show action flag
IF $DATA(SDNSACT)
IF 'SDNSACT
IF %=1
SET SDNSACT=1
ASKL ;S %=1,DTOUT=0,SDLET="" W !,"WANT LETTERS PRINTED NOW" D YN^DICN I '% W !,"RESPOND YES (Y) OR NO (N)" G ASKL ;IHS/ANMC/LJF 12/13/2000
+1 ;IHS/ANMC/LJF 12/13/2000
SET %=2
SET DTOUT=0
SET SDLET=""
WRITE !,"WANT LETTERS PRINTED NOW"
DO YN^DICN
IF '%
WRITE !,"RESPOND YES (Y) OR NO (N)"
GOTO ASKL
+2 IF DTOUT
WRITE " NO"
SET ALS=$SELECT(%=1:"Y",1:"N")
+3 ;display, don't print BAI list
IF $DATA(SDNSACT)
IF (ALS="Y")
IF $$BADADR^DGUTL3(+DFN)
Begin DoDot:1
+4 WRITE *7,!,"** THIS PATIENT HAS BEEN FLAGGED WITH A BAD ADDRESS INDICATOR, NO LETTER"
+5 WRITE !,"WILL BE PRINTED."
+6 SET ALS="N"
+7 SET DIR(0)="E"
DO ^DIR
KILL DIR(0)
End DoDot:1
+8 IF ALS'["Y"&(ANS'["Y")
DO DIS^SDNDIS
GOTO END^SDN0
+9 ;IHS/ANMC/LJF 12/01/2000 save user's answer
NEW BSDALS
SET BSDALS=ALS
RD1 IF $DATA(SDNSACT)
SET Y=SC
GOTO RD2
+1 READ !!,"FOR CLINIC: ALL// ",X:DTIME
KILL C,DIC
IF X="^"
QUIT
SET X=$$UP^XLFSTR(X)
IF X="ALL"!(X="")
GOTO AOR
IF X?.E1"?"
WRITE !,?3,"ENTER A CLINIC NAME, OR 'ALL' FOR ALL CLINICS"
GOTO RD1
+2 SET DIC(0)="QEM"
SET DIC=44
SET DIC("S")="I $P(^(0),""^"",3)=""C"""
DO ^DIC
KILL DIC("S")
IF Y<0
GOTO RD1
RD2 SET C=+Y
IF '$DATA(^SC(C,"LTR"))
WRITE !,$PIECE(^SC(C,0),"^")_SDMSG
SET ALS="N"
+1 IF $DATA(^SC(C,"LTR"))
IF '+^("LTR")
WRITE !,$PIECE(^SC(C,0),"^")_SDMSG
SET ALS="N"
+2 IF $DATA(^SC(C,"LTR"))
IF +^("LTR")
SET SDLET=+^("LTR")
+3 ;IHS/ANMC/LJF 12/01/2000
IF BSDALS="Y"
SET BSDLET=+$$READ^BDGF("P^407.5:EMQZ","Select Letter to Print",$$GET1^DIQ(407.5,+$GET(SDLET),.01),"","I $P(^VA(407.5,+Y,0),U,2)=""N""")
+4 ;IHS/ANMC/LJF 12/01/2000
SET ALS=$SELECT($GET(BSDLET):"Y",1:"N")
AOR IF '$DATA(C)
SET C="ALL"
IF ANS'["Y"&(ALS'["Y")
DO DIS^SDNDIS
GOTO END^SDN0
+1 DO DIS^SDNDIS
+2 ;S DGPGM="START^SDN0",DGVAR="SC^SDDT^ALS^ANS^SDLET^SDV1^SDT^C^DATEND^SDTIME^SDLT1"
+3 ;S POP=0 D ZIS^DGUTQ G:POP END^SDN0
+4 SET %ZIS="MQ"
KILL IO("Q")
DO ^%ZIS
IF POP
GOTO END^SDN0
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 SET ZTRTN="START^SDN0"
FOR ZTS="SC","SDDT","ALS","ANS","SDLET","SDV1","SDT","C","DATEND","SDTIME","SDLT1","AUTO("
SET ZTSAVE(ZTS)=""
+7 KILL ZTS
DO ^%ZTLOAD
End DoDot:1
IF IO'=IO(0)
DO NSLTR
WRITE @IOF
GOTO END^SDN0
+8 IF IO'=IO(0)
DO NSLTR
DO START^SDN0
DO ^%ZISC
WRITE @IOF
GOTO END^SDN0
+9 ;G START^SDN0 ;???
+10 QUIT
NSLTR ;SD/478 AT THIS POINT NO SHOW AUTO REBOOK LETTER IS PRINTED.
IF ANS["Y"
IF ALS["Y"
IF $DATA(NSDIE)
SET @(NSDIE_NSDA_",1,2,0)")="NO-SHOW AUTO-REBOOK letter printed."
KILL NSDIE,NSDA
+1 ;SD/478 AT THIS POINT NO SHOW LETTER IS PRINTED.
IF ALS["Y"
IF $DATA(NSDIE)
SET @(NSDIE_NSDA_",1,2,0)")="NO-SHOW letter printed."
KILL NSDIE,NSDA
+2 QUIT
SDMLT ;
+1 NEW SDCNT,SDSTAT
+2 SET SDCNT=SDCT
SET SDCT=0
+3 FOR
SET SDCT=$ORDER(SDT(SDCT))
IF 'SDCT
QUIT
Begin DoDot:1
+4 SET SDSTAT=$$STATUS^SDAM1(DFN,SDT(SDCT),SC,^DPT(DFN,"S",SDT(SDCT),0))
+5 WRITE !,SDCT,"). ",$$FTIME^VALM1(SDT(SDCT))," Status: ",$PIECE(SDSTAT,";",3)
IF $PIECE(SDSTAT,";",4)
WRITE *7
End DoDot:1
+6 SET SDCT=SDCNT
ASK IF SDCT>1!($PIECE(SDSTAT,";",4))
READ !!,"SELECT APPOINTMENT: ",SDCT:DTIME
IF '$TEST!(U[SDCT)
QUIT
IF SDCT["?"!('$DATA(SDT(SDCT)))
WRITE !,"Please enter one number to indicate which appointment."
SET SDCT=SDCNT
GOTO ASK
+1 WRITE !
QUIT
+2 ;
EVT ; -- separate tag if need to NEW vars
+1 NEW I,SDINP,Y,SDSTAT,SDTIME,SDYES,SM,SM1,SD1,SD2,SDMSG,SDT,SDCT,CNSTLNK,CN,CNPAT
+2 DO NOSHOW^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,0,SDNSHDL)
+3 ;Q ;ihs/cmi/maw 02/27/2012 patch 1015 no consult link in IHS for NOSHOW
+4 ;SD/478
SET CNSTLNK=""
SET CN=0
FOR
SET CN=$ORDER(^SC(SC,"S",SDDTM,1,CN))
IF '+CN
QUIT
SET CNPAT=$PIECE($GET(^SC(SC,"S",SDDTM,1,CN,0)),U)
IF CNPAT=DFN
SET CNSTLNK=$PIECE($GET(^SC(SC,"S",SDDTM,1,CN,"CONS")),U)
QUIT
+5 ;SD/478
IF +CNSTLNK
DO NOSHOW^SDCNSLT(SC,SDDTM,CNPAT,CNSTLNK,CN,.AUTO,.NSDIE,.NSDA)
+6 QUIT
+7 ;
