source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDM1.m@ 724

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

initial load of WorldVistAEHR

File size: 7.1 KB
Line 
1SDM1 ;SF/GFT - MAKE APPOINTMENT ; 3/29/05 12:35pm [5/5/05 9:41am] ; Compiled March 8, 2007 14:55:24 ; Compiled May 9, 2007 13:19:18 ; Compiled August 28, 2007 12:19:08
2 ;;5.3;Scheduling;**32,167,168,80,223,263,273,408,327,478,490,446**;Aug 13, 1993;Build 77
31 L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
4 S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
5 S X2=SDEDT D C^%DTC S SDEDT=X D WRT
6 I $D(^SC(SC,"SI")),$O(^("SI",0))>0 W !,*7,?8,"**** SPECIAL INSTRUCTIONS ****",! S %I=0 F %=0:1 S %I=$O(^SC(SC,"SI",%I)) Q:%I'>0 W ^(%I,0) W:% ! I '%,$O(^SC(SC,"SI",%I))>0 S POP=0 D SPIN Q:POP
7 I $D(SDINA),SDINA>DT D IN W !,?8,@SDMSG K SDMSG
8 G:SDMM RDTY^SDMM
9 ;
10ADT S:'$D(SDW) SDW=""
11 S SDSOH=$S('$D(^SC(SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1),CCX=""
12 S SDONCE=$G(SDONCE)+1 ;Prevent repetitive iteration
13 ; Section introduced in 446.
14 N SDDATE1,SDQT,Y ; Do not allow progress if there is no availability > 120 days after the desired date.
15 S SDDATE1=$S($G(SDDATE)="":DT,1:SDDATE)
16 S Y="" D Q:Y="^"
17 .F Q:Y="^"!$$WLCL120^SDM2A(SC,SDDATE1) D
18 ..S Y=$$WLCLASK^SDM2A() Q:Y="^" ; Y=0: New date, Y=1: place on EWL, Y="^": quit
19 ..I Y=0 D Q
20 ...N SDMAX,SDDMAX
21 ...S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
22 ...S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
23 ...S Y=$$DDATE^SDM0(.SDDATE,"0^0",.SDMAX) Q:'Y ; Y=0: "^" entered, Y=1: date entered
24 ...D D^SDM0
25 ...S SDDATE1=SDDATE
26 ...Q
27 ..D WL^SDM2A(SC)
28 ..S Y="^" ; quit
29 ..Q
30 .Q
31 ;
32 S X=$S(SDONCE<2:$G(SDSDATE),1:"") ;Use default date/time if specified as 'desired date'
33 I 'X R !,"DATE/TIME: ",X:DTIME Q:X="^"!'$$WLCL120A^SDM2A(X,SDDATE1,SC) ;sd/327,446
34 I X="" D WL(SC) Q ;sd/446
35 G:X="M"!(X="m") MORDIS^SDM0
36 I X="D"!(X="d") S X=$$REDDT() G:X>0 MORD2^SDM0 S X="" W " ??",! G ADT
37 I X?1"?".E D G ADT
38 .W !,"Enter a date/time for the appointment"
39 .W:$D(SD) " or a space to choose the same date/time as the patient you have just previously scheduled into this clinic"
40 .W ".",!,"You may also select 'M' to display the next month's availability or"
41 .W !,"'D' to specify an earlier or later date to begin the availability display."
42 I X=" ",$D(SD),SD S Y=SD D AT^SDUTL W Y S Y=SD G OVR
43 I $E($P(X,"@",2),1,4)?1.4"0" K %DT S X=$P(X,"@"),X=$S($L(X):X,1:"T"),%DT="XF" D ^%DT G ADT:Y'>0 S X1=Y,X2=-1 D C^%DTC S X=X_.24
44 K %DT S %DT="TXEF" D ^%DT
45 ;SD*5.3*408 verify that day hasn't been canceled via "SET UP A CLINIC"
46 I $G(^SC(+SC,"ST",$P(Y,"."),1))'="",^SC(+SC,"ST",$P(Y,"."),1)'["[" D G ADT
47 .W !,"There is no availability for this date/time.",!
48 I $P(Y,".",2)=24 S X1=$P(Y,"."),X2=1 D C^%DTC S Y=X_".000001"
49OVR I $D(^HOLIDAY($P(Y,"."),0)),'SDSOH W *7,?50,$P(^(0),U,2),"??" K SDSDATE G ADT
50 I $D(SDINA),$P(Y,".")'<SDINA,$S('$D(SDRE):1,SDRE>$P(Y,".")!('SDRE):1,1:0) D IN W !,*7,@SDMSG K SDMSG K SDSDATE G ADT
51 I Y#1=0 K SDSDATE G 1
52 I $P(Y,".")'<SDEDT W !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7 K SDSDATE G ADT
53 ;
54EN1 S (TMPD,X,SD)=Y,SM=0 D DOW ;SD/478
55 F S=$P(SD,"."):0 S S=+$O(^DPT(DFN,"S",S)) Q:$P(S,".")-($P(SD,".")) S I=+^(S,0) G ^SDM2:$P(^(0),U,2)'["C"
56 ;
57PRECAN I $D(^DPT(DFN,"S",SD,0)),$P(^(0),U,2)["P" S %=1 W !,"THIS TIME WAS PREVIOUSLY CANCELLED BY THE PATIENT",!,"ARE YOU SURE THAT YOU WANT TO PROCEED" D YN^DICN W:'% !,"ANSWER WITH (Y)ES OR (N)O" I (%-1) K SDSDATE G ADT
58 W !
59 ;SD*5.3*490 - AVCHK/AVCHK1 to check against pat DOB and clinic avail dt
60S N POP S POP=0 D AVCHK G:POP 1
61 N POP S POP=0 D AVCHK1 G:POP 1
62 I '$D(^SC(SC,"ST",$P(SD,"."),1)) S SS=+$O(^SC(+SC,"T"_Y,SD)) G XW:SS'>0,XW:^(SS,1)="" S ^SC(+SC,"ST",$P(SD,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(SD,".")
63 ;
64LEN I $P(SL,U,2)]"" W !,"LENGTH OF APPOINTMENT (IN MINUTES): ",+SL,"// " R S:DTIME I S]"" G:$L(S)>3 LEN Q:U[S S POP=0 D L G LEN:POP,S:S\5*5'=S,S:S>360,S:S<5 S SL=S_U_$P(SL,U,2,99)
65 ;
66SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) G:SDLOCK>9 LOCK
67 L ^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
68 S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
69 S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
70 G X:(I<1!'$F(S,"["))&(S'["CAN")
71 I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
72 ;
73SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
74 S SDNOT=1 ;SD*5.3*490 naked Do added below
75 F I=ST+ST:SDDIF:SS-SDDIF S ST=$E(S,I+1) S:ST="" ST=" " S Y=$E(STR,$F(STR,ST)-2) G C:S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))),X:Y="" S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) D S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
76 .Q:ST'=""
77 .Q:+SL'>+^SC(SC,"SL")
78 .S ST=" "
79 .Q
80 Q:SDMM G OK^SDM1A:SM#9=0,^SDM3:$P(SL,U,7)]""&('$D(MXOK))
81 ;
82E G:'$D(^XUSEC("SDOB",DUZ)) NOOB
83 S %=2 W *7,!,$E($T(@SM),5,99),"...OK" D YN^DICN
84 I '% W !,"RESPOND YES OR NO" G E
85 S SM=9 G SC:'(%-1) K SDSDATE G 1
86 ;
87LOCK Q:SDMM W !,*7,"ANOTHER USER HAS LOCKED THIS DATE - TRY AGAIN LATER" Q
88 ;
896 ;;OVERBOOK!
907 ;;THAT TIME IS NOT WITHIN SCHEDULED PERIOD!
91C S POP=1 W !,*7,"CAN'T BOOK WITHIN A CANCELLED TIME PERIOD!",!
92 Q:SDMM K SDSDATE G 1
93 ;
94DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
95 ;
96DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
97 F %=%:-1:281 S Y=%#4=1+1+Y
98 S Y=$E(X,6,7)+Y#7 Q
99 ;
100X I SDMM S POP=1 Q
101 G:I<1 XW
102 S:Y'?1NL&(SM<6) SM=6
103 G OK^SDM1A:SM#9=0,^SDM3:$P(SL,U,7)]""&('$D(MXOK))
104XW W *7," WHEN??" K SDSDATE G 1
105 ;
106AVCHK ;added SD*5.3*490
107 I '$D(VADM) Q:'DFN S VADM(3)=$P(^DPT(DFN,0),U,3)
108 Q:$P(X,".",1)=$P(VADM(3),U,1)
109 I $P(X,".",1)<$P(VADM(3),U,1) W *7,!!,"That date is prior to the patient's date of birth.",!! S POP=1 K SDSDATE Q
110 Q
111 ;
112AVCHK1 ;added SD*5.3*490
113 S AVDT=0,AVDT=$O(^SC(+SC,"T",AVDT)) Q:'AVDT
114 I $P(X,".",1)<AVDT W *7,!!,"That date is prior to the clinic's availability date.",!! S POP=1 K SDSDATE,AVDT Q
115 Q
116 ;
117NOOB W !,"NO OPEN SLOTS THEN",*7 K SDSDATE G 1
118 ;
119WRT W !,+SL," MINUTE APPOINTMENTS "
120 W $S($P(SL,U,2)["V":"(VARIABLE LENGTH)",1:"") Q
121 ;
122L S SDSL=$S($P(SL,"^",6)]"":60/$P(SL,"^",6),1:"") Q:'SDSL
123 I S\(SDSL)*(SDSL)'=S W *7,!,"Appt. length must = or be a multiple of the increment minutes per hour (",SDSL,")",! S POP=1
124 Q
125 ;
126IN S SDHY=$S($D(Y):Y,1:""),Y=SDINA D DTS^SDUTL S Y1=Y,Y=SDRE
127 D:Y DTS^SDUTL
128 S SDMSG="""*** Note: Clinic is scheduled to be inactivated on "","_""""_Y1_""""_$S(SDRE:",!,?10,"_""" and reactivated on "","_""""_Y_"""",1:""),Y=SDHY K Y1,SDHY
129 Q
130 ;
131SPIN W !,"There are more special instructions. Do you want to display them"
132 S %=2 D YN^DICN
133 I '% W !,"Enter Y to see the remaining special instructions, or N if you don't wish to see them" G SPIN
134 I (%-1) S POP=1 Q
135 W !,^SC(SC,"SI",%I,0),! Q
136 ;
137REDDT() ;Prompt for availability redisplay date
138 N %DT,X,Y
139 S %DT="AEX"
140 S %DT("A")="DATE TO BEGIN THE RE-DISPLAY OF CLINIC AVAILABILITY: "
141 W ! D ^%DT
142 Q Y
143WL(SC) ;Wait List Hook/teh patch 263 ;SD/327 passed 'SC'
144 Q:$G(SC)'>0
145 I '$D(^SC(SC)) Q
146 I $D(SC) S SDWLFLG=0 D
147 .I $D(^SDWL(409.32,"B",+SC)) S SDWLFLG=1
148 .I 'SDWLFLG S SDWLDSS=$P($G(^SC(+SC,0)),U,7) I $D(^SDWL(409.31,"B",SDWLDSS)) S SDWLFLG=2 D
149 ..I SDWLFLG=1 S SDWLSC=$O(^SDWL(409.32,"B",+SC,0)) I $P(^SDWL(409.32,SDWLSC,0),U,4) S SDWLFLG=0
150 .I SDWLFLG=2 S SDWLDS=$O(^SDWL(409.31,"E",DUZ(2),0)) I $D(^SDWL(409.31,SDWLDSS,"I",+SDWLDS,0)),$P(^(0),U,4) S SDWLFLG=0
151 .I SDWLFLG D
152 ..K SDWLSC,SDWLDSS,SDWLDS,SDWLFLG
153 ..S SDWLOPT=1,SDWLERR=0 D OPT^SDWLE D EN^SDWLKIL
154 Q
Note: See TracBrowser for help on using the repository browser.