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

Last change on this file since 1375 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.5 KB
Line 
1SDN ;SF/GFT,ALB/LDB - RECORD NO SHOWS ; 5/26/05 11:55am
2 ;;5.3;Scheduling;**32,79,398,478**;Aug 13, 1993
3 N SDATA ; for evt driver
4 S U="^" D NOW^%DTC S SDTIME=%,SDLT1="" K ^UTILITY($J),SDCP,SDLT D LO^DGUTL
5 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
67 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=""
7 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"
8 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"
971 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)"
10 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!"
1172 Q:$D(SDNSACT) S SD1=SDT,DIC="^DPT(",DIC(0)="AEMQ",DIC("S")=SM
12 K SDT S SDT=SD1
13 D ^DIC K DIC("S") G 71:"^"[X,72:Y<0 S DFN=+Y X SM1 D SDMLT Q:'SDCT S I=SDT(SDCT)
14EN1 ; -- entry pt for protocol action
15 S SDSTAT=$P(^DPT(+DFN,"S",I,0),U,2) I SDSTAT="I" D NS^SDN2 G 72
16 I SDSTAT=""!(SDSTAT="NT") D G 72
17 .N SDNSHDL,SDDA S SDNSHDL=$$HANDLE^SDAMEVT(1),SDDA=$$FIND^SDAM2(DFN,I,SC)
18 .S SDDTM=I D BEFORE^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,SDNSHDL)
19 .S $P(^DPT(+DFN,"S",I,0),U,2)="N",$P(^(0),"^",14)=SDTIME S:$D(DUZ) $P(^(0),"^",12)=DUZ
20 .S:'SDYES SDYES=1
21 .S:'$D(^UTILITY($J,"CL",DFN,SC,I))&(SDSTAT'="C") ^(I)=""
22 .W "...OK New Status: ",$P($$STATUS^SDAM1(DFN,I,SC,^DPT(DFN,"S",I,0),SDDA),";",3)
23 .D EVT K SDATA
24 W:$P(^DPT(+DFN,"S",I,0),U,2)["A" *7,!,"THIS APPOINTMENT ALREADY A NO-SHOW AND REBOOKED... ARE YOU SURE YOU"
25ALNS 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
26 I (%-1) G 72
27 I '(%-1) W "...NO LONGER A NO-SHOW!" D
28 .N SDNSHDL,SDDA S SDNSHDL=$$HANDLE^SDAMEVT(1),SDDA=$$FIND^SDAM2(DFN,I,SC)
29 .S SDDTM=I D BEFORE^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,SDNSHDL)
30 .S SDINP=$$INP^SDAM2(DFN,SDDTM),X=I,Y=DFN
31 .S $P(^DPT(+Y,"S",SDDTM,0),U,2)=$S(SDINP["I":SDINP,1:""),$P(^(0),"^",14)="",$P(^(0),"^",12)=""
32 .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
33 .D EVT K SDATA
34 .K SDINP,^UTILITY($J,"CL",+Y,SC,SDDTM),SDDTM
35 G 72
3673 ;
37 G:SDYES ASKA G END^SDN0
38CK1 S SD1=I X SM I I<SD2,$P(^DPT(+Y,"S",I,0),U,2)["C" S POP=1
39 S:I'<SD2 POP=1 Q:'POP I I'<SD2 S POP=1 Q
40 G CK1
41ASKA 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
42 W:DTOUT " NO" S ANS=$S(%=1:"Y",1:"N"),(SDED,DATEND)=SDT+.9
43 I $D(SDNSACT),'SDNSACT,%=1 S SDNSACT=1 ;No-show action flag
44ASKL S %=1,DTOUT=0,SDLET="" W !,"WANT LETTERS PRINTED NOW" D YN^DICN I '% W !,"RESPOND YES (Y) OR NO (N)" G ASKL
45 W:DTOUT " NO" S ALS=$S(%=1:"Y",1:"N")
46 I $D(SDNSACT),(ALS="Y"),$$BADADR^DGUTL3(+DFN) D ;display, don't print BAI list
47 . W *7,!,"** THIS PATIENT HAS BEEN FLAGGED WITH A BAD ADDRESS INDICATOR, NO LETTER"
48 . W !,"WILL BE PRINTED."
49 . S ALS="N"
50 . S DIR(0)="E" D ^DIR K DIR(0)
51 I ALS'["Y"&(ANS'["Y") D DIS^SDNDIS G END^SDN0
52RD1 I $D(SDNSACT) S Y=SC G RD2
53 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
54 S DIC(0)="QEM",DIC=44,DIC("S")="I $P(^(0),""^"",3)=""C""" D ^DIC K DIC("S") G:Y<0 RD1
55RD2 S C=+Y I '$D(^SC(C,"LTR")) W !,$P(^SC(C,0),"^")_SDMSG S ALS="N"
56 I $D(^SC(C,"LTR")),'+^("LTR") W !,$P(^SC(C,0),"^")_SDMSG S ALS="N"
57 I $D(^SC(C,"LTR")),+^("LTR") S SDLET=+^("LTR")
58AOR S:'$D(C) C="ALL" I ANS'["Y"&(ALS'["Y") D DIS^SDNDIS G END^SDN0
59 D DIS^SDNDIS
60 ;S DGPGM="START^SDN0",DGVAR="SC^SDDT^ALS^ANS^SDLET^SDV1^SDT^C^DATEND^SDTIME^SDLT1"
61 ;S POP=0 D ZIS^DGUTQ G:POP END^SDN0
62 S %ZIS="MQ" K IO("Q") D ^%ZIS G:POP END^SDN0
63 I $D(IO("Q")) D D:IO'=IO(0) NSLTR W @IOF G END^SDN0
64 .S ZTRTN="START^SDN0" F ZTS="SC","SDDT","ALS","ANS","SDLET","SDV1","SDT","C","DATEND","SDTIME","SDLT1","AUTO(" S ZTSAVE(ZTS)=""
65 .K ZTS D ^%ZTLOAD
66 D:IO'=IO(0) NSLTR D START^SDN0,^%ZISC W @IOF G END^SDN0
67 ;G START^SDN0 ;???
68 Q
69NSLTR 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.
70 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.
71 Q
72SDMLT ;
73 N SDCNT,SDSTAT
74 S SDCNT=SDCT,SDCT=0
75 F S SDCT=$O(SDT(SDCT)) Q:'SDCT D
76 .S SDSTAT=$$STATUS^SDAM1(DFN,SDT(SDCT),SC,^DPT(DFN,"S",SDT(SDCT),0))
77 .W !,SDCT,"). ",$$FTIME^VALM1(SDT(SDCT))," Status: ",$P(SDSTAT,";",3) W:$P(SDSTAT,";",4) *7
78 S SDCT=SDCNT
79ASK 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
80 W ! Q
81 ;
82EVT ; -- separate tag if need to NEW vars
83 N I,SDINP,Y,SDSTAT,SDTIME,SDYES,SM,SM1,SD1,SD2,SDMSG,SDT,SDCT,CNSTLNK,CN,CNPAT
84 D NOSHOW^SDAMEVT(.SDATA,DFN,SDDTM,SC,SDDA,0,SDNSHDL)
85 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
86 D:+CNSTLNK NOSHOW^SDCNSLT(SC,SDDTM,CNPAT,CNSTLNK,CN,.AUTO,.NSDIE,.NSDA) ;SD/478
87 Q
88 ;
Note: See TracBrowser for help on using the repository browser.