source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDM1.m@ 658

SDM1 ;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
 ;;5.3;Scheduling;**32,167,168,80,223,263,273,408,327,478,490,446**;Aug 13, 1993;Build 77
1 L  Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
 S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
 S X2=SDEDT D C^%DTC S SDEDT=X D WRT
 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
 I $D(SDINA),SDINA>DT D IN W !,?8,@SDMSG K SDMSG
 G:SDMM RDTY^SDMM
 ;
ADT S:'$D(SDW) SDW=""
 S SDSOH=$S('$D(^SC(SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1),CCX=""
 S SDONCE=$G(SDONCE)+1  ;Prevent repetitive iteration
 ; Section introduced in 446.
 N SDDATE1,SDQT,Y  ; Do not allow progress if there is no availability > 120 days after the desired date.
 S SDDATE1=$S($G(SDDATE)="":DT,1:SDDATE)
 S Y="" D  Q:Y="^"
 .F  Q:Y="^"!$$WLCL120^SDM2A(SC,SDDATE1)  D
 ..S Y=$$WLCLASK^SDM2A() Q:Y="^"  ; Y=0: New date, Y=1: place on EWL, Y="^": quit
 ..I Y=0 D  Q
 ...N SDMAX,SDDMAX
 ...S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
 ...S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
 ...S Y=$$DDATE^SDM0(.SDDATE,"0^0",.SDMAX) Q:'Y  ; Y=0: "^" entered, Y=1: date entered
 ...D D^SDM0
 ...S SDDATE1=SDDATE
 ...Q
 ..D WL^SDM2A(SC)
 ..S Y="^"  ; quit
 ..Q
 .Q
 ;
 S X=$S(SDONCE<2:$G(SDSDATE),1:"")  ;Use default date/time if specified as 'desired date'  
 I 'X R !,"DATE/TIME: ",X:DTIME Q:X="^"!'$$WLCL120A^SDM2A(X,SDDATE1,SC)  ;sd/327,446
 I X="" D WL(SC) Q  ;sd/446
 G:X="M"!(X="m") MORDIS^SDM0
 I X="D"!(X="d") S X=$$REDDT() G:X>0 MORD2^SDM0 S X="" W "  ??",! G ADT
 I X?1"?".E D  G ADT
 .W !,"Enter a date/time for the appointment"
 .W:$D(SD) " or a space to choose the same date/time as the patient you have just previously scheduled into this clinic"
 .W ".",!,"You may also select 'M' to display the next month's availability or"
 .W !,"'D' to specify an earlier or later date to begin the availability display."
 I X=" ",$D(SD),SD S Y=SD D AT^SDUTL W Y S Y=SD G OVR
 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
 K %DT S %DT="TXEF" D ^%DT
 ;SD*5.3*408  verify that day hasn't been canceled via "SET UP A CLINIC"
 I $G(^SC(+SC,"ST",$P(Y,"."),1))'="",^SC(+SC,"ST",$P(Y,"."),1)'["[" D  G ADT
 .W !,"There is no availability for this date/time.",!
 I $P(Y,".",2)=24 S X1=$P(Y,"."),X2=1 D C^%DTC S Y=X_".000001"
OVR I $D(^HOLIDAY($P(Y,"."),0)),'SDSOH W *7,?50,$P(^(0),U,2),"??" K SDSDATE G ADT
 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
 I Y#1=0 K SDSDATE G 1
 I $P(Y,".")'<SDEDT W !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7 K SDSDATE G ADT
 ;
EN1 S (TMPD,X,SD)=Y,SM=0 D DOW  ;SD/478
 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"
 ;
PRECAN 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
 W !
 ;SD*5.3*490 - AVCHK/AVCHK1 to check against pat DOB and clinic avail dt
S N POP S POP=0 D AVCHK G:POP 1
 N POP S POP=0 D AVCHK1 G:POP 1
 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,".")
 ;
LEN 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)
 ;
SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) G:SDLOCK>9 LOCK
 L ^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
 S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
 S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
 G X:(I<1!'$F(S,"["))&(S'["CAN")
 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
 ;
SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
 S SDNOT=1   ;SD*5.3*490 naked Do added below
 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
 .Q:ST'=""
 .Q:+SL'>+^SC(SC,"SL")
 .S ST="   "
 .Q
 Q:SDMM  G OK^SDM1A:SM#9=0,^SDM3:$P(SL,U,7)]""&('$D(MXOK))
 ;
E G:'$D(^XUSEC("SDOB",DUZ)) NOOB
 S %=2 W *7,!,$E($T(@SM),5,99),"...OK" D YN^DICN
 I '% W !,"RESPOND YES OR NO" G E
 S SM=9 G SC:'(%-1) K SDSDATE G 1
 ;
LOCK Q:SDMM  W !,*7,"ANOTHER USER HAS LOCKED THIS DATE - TRY AGAIN LATER" Q
 ;
6 ;;OVERBOOK!
7 ;;THAT TIME IS NOT WITHIN SCHEDULED PERIOD!
C S POP=1 W !,*7,"CAN'T BOOK WITHIN A CANCELLED TIME PERIOD!",!
 Q:SDMM  K SDSDATE G 1
 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
 ;
DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
 F %=%:-1:281 S Y=%#4=1+1+Y
 S Y=$E(X,6,7)+Y#7 Q
 ;
X I SDMM S POP=1 Q
 G:I<1 XW
 S:Y'?1NL&(SM<6) SM=6
 G OK^SDM1A:SM#9=0,^SDM3:$P(SL,U,7)]""&('$D(MXOK))
XW W *7,"  WHEN??" K SDSDATE G 1
 ;
AVCHK ;added SD*5.3*490
 I '$D(VADM) Q:'DFN  S VADM(3)=$P(^DPT(DFN,0),U,3)
 Q:$P(X,".",1)=$P(VADM(3),U,1)
 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
 Q
 ;
AVCHK1 ;added SD*5.3*490
 S AVDT=0,AVDT=$O(^SC(+SC,"T",AVDT)) Q:'AVDT
 I $P(X,".",1)<AVDT W *7,!!,"That date is prior to the clinic's availability date.",!! S POP=1 K SDSDATE,AVDT Q
 Q
 ;
NOOB W !,"NO OPEN SLOTS THEN",*7 K SDSDATE G 1
 ;
WRT W !,+SL," MINUTE APPOINTMENTS "
 W $S($P(SL,U,2)["V":"(VARIABLE LENGTH)",1:"") Q
 ;
L S SDSL=$S($P(SL,"^",6)]"":60/$P(SL,"^",6),1:"") Q:'SDSL
 I S\(SDSL)*(SDSL)'=S W *7,!,"Appt. length must = or be a multiple of the increment minutes per hour (",SDSL,")",! S POP=1
 Q
 ;
IN S SDHY=$S($D(Y):Y,1:""),Y=SDINA D DTS^SDUTL S Y1=Y,Y=SDRE
 D:Y DTS^SDUTL
 S SDMSG="""*** Note: Clinic is scheduled to be inactivated on "","_""""_Y1_""""_$S(SDRE:",!,?10,"_""" and reactivated on "","_""""_Y_"""",1:""),Y=SDHY K Y1,SDHY
 Q
 ;
SPIN W !,"There are more special instructions. Do you want to display them"
 S %=2 D YN^DICN
 I '% W !,"Enter Y to see the remaining special instructions, or N if you don't wish to see them" G SPIN
 I (%-1) S POP=1 Q
 W !,^SC(SC,"SI",%I,0),! Q
 ;
REDDT() ;Prompt for availability redisplay date
 N %DT,X,Y
 S %DT="AEX"
 S %DT("A")="DATE TO BEGIN THE RE-DISPLAY OF CLINIC AVAILABILITY: "
 W ! D ^%DT
 Q Y
WL(SC) ;Wait List Hook/teh patch 263 ;SD/327 passed 'SC'
 Q:$G(SC)'>0
 I '$D(^SC(SC)) Q
 I $D(SC) S SDWLFLG=0 D
 .I $D(^SDWL(409.32,"B",+SC)) S SDWLFLG=1
 .I 'SDWLFLG S SDWLDSS=$P($G(^SC(+SC,0)),U,7) I $D(^SDWL(409.31,"B",SDWLDSS)) S SDWLFLG=2 D
 ..I SDWLFLG=1 S SDWLSC=$O(^SDWL(409.32,"B",+SC,0)) I $P(^SDWL(409.32,SDWLSC,0),U,4) S SDWLFLG=0
 .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
 .I SDWLFLG D
 ..K SDWLSC,SDWLDSS,SDWLDS,SDWLFLG
 ..S SDWLOPT=1,SDWLERR=0 D OPT^SDWLE D EN^SDWLKIL
 Q