source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDMM.m@ 1078

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

initial load of WorldVistAEHR
File size: 6.5 KB
RevLine 
[613]1SDMM ;SF/GFT,MAN/GRR - MULTIPLE APPOINTMENTS ; 2/7/05 12:51pm ; Compiled September 25, 2006 13:33:14
2 ;;5.3;Scheduling;**26,32,167,241,327,446**;Aug 13, 1993;Build 77
3 N SDHX,SDAPDT S SDMM=1 D ^SDM K SDMM Q
4RDTY K ^TMP($J,"APPT"),^TMP($J,"SDAMA301") ;SD/327
5 R !,"WANT TO MAKE DAILY OR WEEKLY APPOINTMENTS?: WEEKLY// ",SDTYP:DTIME Q:SDTYP["^"!('$T) S:SDTYP="" SDTYP="W" S SDTYP=$$UP^XLFSTR($E(SDTYP)) I "WD"'[SDTYP W !,"ENTER 'D' FOR DAILY OR PRESS RETURN" G RDTY
6RD22 I SDTYP["D" S %=2 W !,"WANT APPOINTMENTS MADE ON SATURDAYS AND SUNDAYS" D YN^DICN S SDWE=$S(%<0:"^",%=2:"N",%=1:"Y",1:"?") Q:SDWE["^" G:SDWE["?" HLP22
7ADT K SDERRFT S CCX=""
8 S X=$G(SDSDATE) S:X SDHX=X\1 K SDSDATE
9 W:X#1 !,"APPOINTMENT DATE/TIME REQUESTED: "
10 I '(X#1) R !,"DATE/TIME: ",X:DTIME I "^"[X K X,SD Q
11 I X="M"!(X="m") D MORDIS G ADT
12 I X="D"!(X="d") S X=$$REDDT^SDM1() D:X>0 MORD2 W:X="" $C(7)," ??",! G ADT
13 I X?1"?".E D HLP1 G ADT
14 I X=" ",$G(SDAPDT) S Y=SDAPDT D AT^SDUTL W Y S Y=SDAPDT G OVR
15 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
16 K %DT S %DT="TXEF" D ^%DT
17 I $P(Y,".",2)=24 S X1=$P(Y,"."),X2=1 D C^%DTC S Y=X_".000001"
18 S SDSOH=$S('$D(^SC(+SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1)
19OVR S SDY1=$P(Y,".") I $D(^HOLIDAY(SDY1,0)),'SDSOH W *7,?50,$P(^(0),U,2),"??" G ADT
20 I $D(SDINA),SDY1'<SDINA,$S('$D(SDRE):1,SDRE>SDY1!('SDRE):1,1:0) S SDY=Y,Y=SDINA D DTS^SDUTL W !,*7,"Clinic is scheduled to be inactivated on ",Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" and reactivated on "_Y,1:"") S Y=SDY K SDY G ADT
21 I Y#1=0 G ADT
22 D SDFT I $P(Y,".")'<SDEDT W !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7 G ADT
23LEN I $P(SL,U,2)]"" W !,"LENGTH OF APPOINTMENTS (IN MINUTES): ",+SL,"// " R S:DTIME I S]"" G:$L(S)>3 LEN Q:U[S S POP=0 D L^SDM1 G LEN:POP I S\5*5=S,S'>360,S'<5 S SL=S_U_$P(SL,U,2,99)
24 S SDOT=Y#1,SDDAT=$P(Y,"."),X=Y D DOW^SDM0
25RDC W !,"FOR HOW MANY CONSECUTIVE ",$S(SDTYP["W":$P($T(DAY),"^",Y+2)_"DAY'S",1:"DAYS")," DO YOU WANT APPOINTMENTS SCHEDULED",!," AT " S X=SDOT D TM W X,"?: "
26 R SDCN:DTIME G:SDCN=""!(SDCN="^") ADT G HLP:SDCN'?.N,HLP:SDCN<1,HLP:SDCN>60
27 S Y=SDDAT_SDOT,SDMCNT=0,SDMADE=0
28OTHER R !," OTHER INFO: ",D:DTIME I D["^" W !,*7,"'^' not allowed - hit return if no 'OTHER INFO' is to be entered" G OTHER
29 I $L(D)>150 D MSG G OTHER
30 I D]"",D?."?"!(D'?.ANP) W " ENTER LAB, SCAN, ETC." G OTHER
31 I $L(D)+$L(SDW)>250 D MSG G OTHER
32BEGIN S SDZM=1,SDZY=Y,SDX9=X,SDM9=D D SDMM^SDM1A K SDZM S Y=SDZY,X=SDX9,D=SDM9
33 F SDZ=1:1:SDCN D MAKE^SDMM1 Q:$D(SDERRFT) D Q:POP
34 .S:SDMADE SDMCNT=SDMCNT+1 I SDMADE,SDZ=1 S SDAPDT=SD
35 .S SDMADE=0,POP=0 D GETNEX:SDTYP["W",GETNXD:SDTYP["D"
36 .Q
37 G:$D(SDERRFT) ADT
38END W !,SDMCNT," APPOINTMENTS MADE",!
39 ;display all created appointments
40 I $D(^TMP($J,"APPT")) N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
41 .K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
42 .D INIT^SDWLPL(DFN,"M")
43 .Q:'$D(^TMP($J,"SDWLPL")) ;
44 .;D LIST^SDWLPL("M",DFN) ;display EWL entries
45 .F Q:'$D(^TMP($J,"SDWLPL")) D LIST^SDWLPL("M",DFN) N SDR D ANSW^SDWLEVAL(1,.SDR) I 'SDR D ;D LIST^SDWLPL("M",DFN) D
46 ..F N SDR D ANSW^SDWLEVAL(0,.SDR) Q:'$D(^TMP($J,"SDWLPL")) I 'SDR W !,"MUST ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
47 I $D(^TMP($J,"APPT")) N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
48 .;N SDTC D EWLANS^SDWLEVAL(.SDTC) ;user may reject EWL; 446/;
49 .;ask for selection of EWL to display
50 .;ASKS - returned answer (A/C/S/^)
51 .; ^TMP("SDWLPL",$J) and ^TMP($J,"SDWLPL") are used
52 .; to generate EWL open entries
53 .;I SDTC N SDCTN S SDCTN=0 F N ASKS K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL") D ANS2^SDWLPL(DFN,.ASKS) Q:ASKS="^" D Q:SDCTN ;446/;
54 .Q:'$D(^TMP($J,"SDWLPL")) D ASKREM^SDWLEVAL S SDCTN=1 ;display and process selected open EWL entries ;446/;
55 .;I 'SDTC Q ;no EWL evaluation per user's decision
56 .Q
57 ;
58 K CCX,COLLAT,COV,D,I,POP,S,SC,SD,SDAPTYP,SDEDT,SDEMP,SDINA,SDLOCK,SDM9,SDMES,SDNOT,SDRE,SDSOH,SDW,SDWEE,SDX3,SDX7,SDX9,SDY1,SDYC,SDZ,SDZY,SDMES,SDCN,SDDAT,SDMADE,SDMCNT,SDOT,SDPL,SDRT,SDSC,SDTTM,SDTYP
59 K SDALLE,SDATD,SDAV,SDDECOD,SDEC,SDHX,SDIN,SDINP,SDOEL,SDT,SDY,%H,%T,C,DISYS,SDW,SDWE,SDX3,SDX7,SDX9,SDY1,SDYC,SDZY,SI,SL,SM,SS,X1,X2,Y,SDXF,% Q
60GETNEX I SDDAT#100<22 S SDDAT=SDDAT+7 S POP=0 D INACT Q:POP G:$D(^HOLIDAY(SDDAT,0))&('SDSOH) GETNEX S Y=SDDAT_SDOT Q
61 S X1=SDDAT,X2=7 D C^%DTC S POP=0 D INACT Q:POP S SDDAT=X G:$D(^HOLIDAY(SDDAT,0))&('SDSOH) GETNEX S Y=SDDAT_SDOT
62 Q
63GETNXD I SDDAT#100<28 S SDDAT=SDDAT+1 S POP=0 D INACT Q:POP G:$D(^HOLIDAY(SDDAT,0))&('SDSOH) GETNXD S X=SDDAT D DOW^SDM0 S:SDWE["Y" Y=SDDAT_SDOT Q:SDWE["Y" G:Y=0!(Y=6) GETNXD S Y=SDDAT_SDOT Q
64 S X1=SDDAT,X2=1 D C^%DTC S POP=0 D INACT Q:POP S SDDAT=X G:$D(^HOLIDAY(SDDAT,0))&('SDSOH) GETNXD S X=SDDAT D DOW^SDM0 S:SDWE["Y" Y=SDDAT_SDOT Q:SDWE["Y" G:Y=0!(Y=6) GETNXD S Y=SDDAT_SDOT
65 Q
66DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
67 ;
68TM S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
69HLP W !,"Enter the number of appointments you want made (between 1 and 60)." G RDC
70HLP22 W !,"ENTER 'YES' IF YOU WANT THE SYSTEM TO TRY TO MAKE APPOINTMENTS ON SATURDAYS AND SUNDAYS" G RD22
71INACT I $D(SDINA),SDINA'>SDDAT,SDRE>SDDAT!('SDRE) W !,*7,"Appointments can't be made while clinic is inactivated" S POP=1
72 Q
73HLP1 W !,"Enter a date/time for the appointment"
74 W:$D(SD) " or a space to choose the same date/time",!,"as the patient you have just previously scheduled into this clinic"
75 W ".",!,"You may also select 'M' to display the next month's availability or"
76 W !,"'D' to specify an earlier or later date to begin the availability display."
77 Q
78SDFT S X1=DT,SDEDT=$S($D(^SC(SC,"SDP")):$P(^("SDP"),U,2),1:365) S:'SDEDT SDEDT=365 S X2=SDEDT D C^%DTC S SDEDT=X Q
79MSG W !!?5,"Text entered at OTHER INFO prompt was too long. Please re-enter.",! Q
80 ;
81MORDIS I '$D(SDHX) W *7," ??" G ADT
82 S SDXF=0,X1=SDHX,X2=1 D C^%DTC
83MORD2 I $D(SDINA),SDINA'>X,SDRE>X!('SDRE) S SDHY=$S($D(Y):Y,1:""),Y=SDINA D DTS^SDUTL W *7,!,"Clinic is inactivated as of ",Y S Y=SDHY K SDHY G ADT
84EN S:$L(X)=1 X=$TR(X,"tnN","TTT") S:X="NOW" X="T" I X?.A!(+X=X),X<13,X'?1"T".E S X=X_" 1"
85 D Q:Y<1
86 .N %DT
87 .S %DT="T" D ^%DT
88 .I Y<1 W !!,"Unable to evaluate date value """_X_""".",!
89 .Q
90 S:$S($D(DUZ)'[0:1,1:0) ^DISV(DUZ_U_+SC)=Y
91DISP S IOF=$S('$D(IOF):"!#",IOF']"":"!#",1:IOF) W @IOF S SDSOH=$S('$D(^SC(+SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1),SDAV=0
92 I $D(SDINA),Y'<SDINA,SDRE>Y!('SDRE) S SDHY=Y,Y=SDINA D DTS^SDUTL W !,*7,"Clinic is inactive ",$S(SDRE:"from ",1:"as of "),Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"") S Y=SDHY K SDHY Q:'SDRE
93 S:Y#100=0 Y=Y+1 S X=Y D D^SDM0:$E(X,4,5) S (SDX,X1)=X,X2=1 D C^%DTC S X=SDX K SDX Q
Note: See TracBrowser for help on using the repository browser.