- 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 ;
