Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDM0

SDM0.m

Go to the documentation of this file.
  1. SDM0 ;SF/GFT,ANU - MAKE APPOINTMENT ;1/5/16 12:26pm
  1. ;;5.3;Scheduling;**140,167,206,186,223,237,241,384,334,547,621,622,645,674,726,796,797**;Aug 13, 1993;Build 8
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. I $D(SDXXX) S SDOK=1 Q
  1. N SDSRTY,SDDATE,SDSDATE,SDDATE2,SDSRFU,SDDMAX,SDONCE
  1. ;Prompt for scheduling request type
  1. M N SDHX,SDXF,SDXD
  1. Q:'$$SRTY(.SDSRTY) S:SDSRTY SDDATE=DT
  1. ; SD*5.3*622 - let user see desired date
  1. ; SD*5.3*645 - replaced DESIRED DATE with CID/PREFERRED DATE
  1. I $D(SDDATE) S Y=SDDATE,SDDATE2=$$FMTE^XLFDT(Y) W !!,"APPOINTMENT CID/PREFERRED DATE: "_SDDATE2 W ! H 3
  1. ;Calculate appointment follow-up indicator
  1. S SDSRFU=$$PTFU(DFN,SC)
  1. ;Determine maximum days for scheduling
  1. S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
  1. S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
  1. ; SD*5.3*796 - Anu - Remove prompt for PID and default to today's date
  1. ;Prompt for desired date
  1. ;Q:'$$DDATE(.SDDATE,SDSRTY,.SDMAX)
  1. S SDDATE=DT
  1. ; SD*5.3*796 - Anu - Remove prompt - End
  1. ;If date and time, schedule appt. directly
  1. W ! I SDDATE#1 S SDSDATE=SDDATE,SDDATE=SDDATE\1 G ^SDM1
  1. S (X,Y)=SDDATE K SDHX
  1. ;Find first available after specified date
  1. I X="F"!(X="f") D SUP,DT1 G NEXT
  1. ;Find next available appointment
  1. I SDSRTY,SDDATE D SUP S SDSTRTDT=SDDATE D OVR^SDMULT0 G NEXT
  1. ;
  1. EN 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"
  1. D Q:Y<1
  1. .N %DT
  1. .S %DT="T" D ^%DT
  1. .I Y<1 W !!,"Unable to evaluate date value """_X_""".",!
  1. .Q
  1. S:$S($D(DUZ)'[0:1,1:0) ^DISV(DUZ_U_+SC)=Y
  1. DISP 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
  1. 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 D PAUSE^VALM1 Q:'SDRE
  1. S:Y#100=0 Y=Y+1 S X=Y D D:$E(X,4,5) S (SDX,X1)=X,X2=1 D C^%DTC S X=SDX K SDX G:SDAV ^SDM1 Q
  1. ;
  1. NEXT D SET I $S('$D(FND):1,'FND:1,1:0) D G EN
  1. .K ^DISV($S($D(DUZ)'[0:DUZ,1:0)_U_+SC)
  1. .I '$O(^SC(+SC,"ST",SDDATE-1)) S (X,Y)=SDDATE Q
  1. .W $C(7),!?6,"No open slots found in the date range "
  1. .W $$FMTE^XLFDT(SDDATE)," to ",$$FMTE^XLFDT(SDDMAX),"!",!
  1. .H 3 S (X,Y)=SDDATE
  1. .Q
  1. S (X,Y)=SDAPP K SDXXX G DISP
  1. ; SD*5.3*622 - display clinic name all the time
  1. D W #!?36,$P(^SC(+SC,0),U,1) S:$O(^SC(+SC,"T",0))>X X=+$O(^(0)) D DOW S I=Y+32,D=Y S SDXF=0 D WM I SDXF D WMH
  1. X1 S X1=X\100_$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+$E(X,4,5)) ;28
  1. ;SD*5.3*547 next line don't allow past dates to be added to pattern if prior to date DOW was added
  1. W I '$D(^SC(+SC,"ST",X,1)) S DWFLG=1,POP=0,XDT=X D DOWCHK K DWFLG,XDT G L:POP
  1. ;Add date start date check - SD*5.3*674
  1. I '$D(^SC(+SC,"ST",X,1)) S Y=D#7 G L:'$D(J(Y)),H:$D(^HOLIDAY(X))&('SDSOH) I '$$BEGDAT(X,Y) S SS=+$O(^SC(+SC,"T"_Y,X)) G L:SS'>0,L:^(SS,1)="" S ^SC(+SC,"ST",$P(X,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(X,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(X,".")
  1. S SDHX=X,SDAV=1 D:X>SM WM I SDXF<2 D WMH
  1. I $D(^SC(+SC,"ST",X,1)),^(1)["["!(^(1)["CANCELLED")!($D(^HOLIDAY(X))) W !,$E(^SC(+SC,"ST",X,1),1,80) S:'$D(^HOLIDAY(X))&('SDAV) SDAV=1
  1. I $Y>18 W ! Q
  1. L K POP
  1. S X=X+1,D=D+1
  1. I $D(SDINA),X>SDINA,SDRE>X!('SDRE) D:'SDAV NOAV S SDHY=Y,Y=SDINA D DTS^SDUTL W !,*7,?8,"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 D DIFF
  1. G W:X'>X1 S X2=X-X1 D C^%DTC
  1. I $D(SDINA),X>SDINA,SDRE>X!('SDRE) D:'SDAV NOAV S SDHY=Y,Y=SDINA D DTS^SDUTL W !,*7,?8,"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
  1. G X1:D<I W ! D:'SDAV MNTH Q
  1. ;
  1. NOAV W !,"No availability found between date chosen and inactivate date!" Q
  1. H S ^SC(+SC,"ST",X,1)=" "_$E(X,6,7)_" "_$P(^(X,0),U,2),^(0)=X G W
  1. ;
  1. WM W !?36 S Y=$E(X,1,5)_"00",SM=$S($E(X,4,5)[12:$E(X,1,3)+1_"01",1:$E(X,1,3)_$E(X,4,5)+1)_"00"
  1. S SDXF=SDXF+1 I $E(X,6,7)>20 D
  1. . S SDXD=$O(^SC(+SC,"ST",X-1)) Q:SDXD=""
  1. . I $E(SDXD,4,5)'=$E(X,4,5) S SDXF=0
  1. D:SDXF DT
  1. Q
  1. WMH ;Write month heading lines
  1. W !!," TIME",?SI+SI-1 F Y=STARTDAY:1:65\(SI+SI)+STARTDAY W $E("|"_$S('Y:0,1:(Y-1#12+1))_" ",1,SI+SI)
  1. W !," DATE",?SI+SI-1,"|" K J F Y=0:1:6 I $D(^SC(+SC,"T"_Y)) S J(Y)=""
  1. F Y=1:1:65\(SI+SI) W $J("|",SI+SI)
  1. S SDXF=2
  1. Q
  1. DT W $$FMTE^XLFDT(Y) Q
  1. ;
  1. DOW S Y=$$DOW^XLFDT(X,1) Q
  1. ;
  1. DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
  1. MORDIS I '$D(SDHX) W *7," ??" G ADT^SDM1
  1. S SDXF=0,X1=SDHX,X2=1 D C^%DTC
  1. MORD2 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^SDM1
  1. G EN
  1. INPAT S SDI=$O(^DGPM("ATID1",DFN,9999999-X)) I SDI>0 D I1
  1. S:'$D(SDINP) SDINP="" K SDI,SDI1 Q
  1. I1 F SDI1=0:0 S SDI1=$O(^DGPM("ATID1",DFN,SDI,SDI1)) Q:SDI1'>0 I $D(^DGPM(SDI1,0)) S SDX=^(0) I $S($P(SDX,U,17)']"":1,+^DGPM($P(SDX,U,17),0)>X!(+^DGPM($P(SDX,U,17),0)=0):1,1:0) S SDINP="I" Q
  1. Q
  1. ;
  1. SUP ;Set up variables for availability search
  1. S SDNEXT=1,SDCT=1,G1=+SC,SDC(1)=SC,FND=0,SDAV=0 K SDC1
  1. D SAVE S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
  1. Q
  1. ;
  1. SET S I1="" F I=0:0 S I1=$O(SDZ(I1)) Q:I1']"" S @I1=SDZ(I1)
  1. K SDZ Q
  1. SAVE K SDZ F I="SDDIF","STR","SC","DFN","SL","SI","HSI","SB" S Z="SDZ("_""""_I_""")" S:$D(@I) @Z=@I
  1. Q
  1. MNTH W !," *** No availability found for one full calendar month",!," Search stopped at " S Y=X D DTS^SDUTL W Y," ***",! Q
  1. DIFF S X1=SDRE,X2=X D ^%DTC S D=D+X,X=SDRE,X1=X\100_28 Q
  1. ;
  1. SRTY(SDSRTY) ;Prompt for scheduling request type
  1. ;Input: SDSRTY=variable to return user response (pass by reference)
  1. ;Output: '1' if successful, '0' otherwise
  1. ;
  1. I $G(DFN)<1 S SDSRTY="M" Q 1 ;patient not defined
  1. I $G(SDMM)=1 S SDSRTY="M" Q 1 ;multiple appointment booking
  1. N DIR,DTOUT,DUOUT
  1. S DIR(0)="Y"
  1. S DIR("A")="IS THIS A 'NEXT AVAILABLE' APPOINTMENT REQUEST"
  1. S DIR("?")="Answer 'yes' if scheduling to the next available appointment is desired."
  1. W ! D ^DIR I $D(DTOUT)!$D(DUOUT) Q 0
  1. S SDSRTY=Y,SDSRTY(0)=$$TXRT^SDM1A(.SDSRTY) Q 1
  1. ;
  1. PTFU(DFN,SC) ;Determine if this is a follow-up (return to clinic within 24 months)
  1. ;Input: DFN=patient ifn
  1. ;Input: SC=clinic ifn
  1. ;Output: '1' if seen within 24 months, '0' otherwise
  1. ;
  1. Q:'DFN!'SC 0 ;variable check
  1. N SDBDT,SDT,SDX,SDY,SDZ,SDCP,SDCP1,SC0,SDENC,SDCT
  1. ;set up variables
  1. S SDBDT=(DT-20000)+.24,SDT=DT_.999999,(SDCT,SDY)=0
  1. S SC0=$G(^SC(+SC,0)),SDX=$$CPAIR^SCRPW71(SC0,.SDCP) ;get credit pair for this clinic
  1. ;Iterate through encounters
  1. W !!,"Calculating follow-up status"
  1. F S SDT=$O(^SCE("ADFN",DFN,SDT),-1) Q:SDT<SDBDT!SDY D
  1. .S SDENC=0 F S SDENC=$O(^SCE("ADFN",DFN,SDT,SDENC)) Q:'SDENC!SDY D
  1. ..S SDENC0=$G(^SCE(SDENC,0)) ;get encounter node
  1. ..Q:$P(SDENC0,U,6) ;parent encounters only
  1. ..S SDX=$P(SDENC0,U,4) Q:'SDX ;get clinic
  1. ..S SC0=$G(^SC(SDX,0))
  1. ..S SDX=$$CPAIR^SCRPW71(SC0,.SDCP1) ;get credit pair for encounter
  1. ..S SDY=SDCP=SDCP1 ;compare credit pairs
  1. ..S SDCT=SDCT+1 W:SDCT#10=0 "."
  1. ..Q
  1. .Q
  1. Q SDY
  1. ;
  1. DDATE(SDDATE,SDSRTY,SDMAX) ;Desired date selection
  1. ;Input: SDDATE=variable to return date selection (pass by reference)
  1. ;Input: SDSRTY=variable to return request type
  1. ;Input: SDMAX=variable to return max. days to sched. (pass by ref.)
  1. ;Output: '1' for success, otherwise '0'
  1. ;
  1. Q:SDSRTY 1
  1. W !!?2,"Select one of the following:",!
  1. W !?5,"'F'",?19,"for First available following a specified date"
  1. ; SD*5.3*645 - replaced desired date with CID/Preferred date, adjusted format
  1. ; W !?5,"Date",?19,"(or date computation such as 'T+2M') for a desired date"
  1. W !?5,"Date",?19,"(or date computation such as 'T+2M') for a CID/Preferred date"
  1. I DFN>0 W !?5,"Date/time",?19,"to schedule a specific appointment - Note: PAST dates",!?19,"must include the Year in the input." ;added note SD*5.3*547
  1. W !?5,"'?'",?19,"for detailed help"
  1. DASK N DIR,X,Y,SDX,DTOUT,DUOUT
  1. ;
  1. ;BP OIFO/TEH PATCH SD*5.3*384 ; SD*5.3*547 added note to help text
  1. ;
  1. S DIR(0)="F^1:30"
  1. ; SD*5.3*645 - replaced DATE DESIRED with CID/PREFERRED DATE
  1. ; S DIR("A")="ENTER THE DATE DESIRED FOR THIS APPOINTMENT"
  1. S DIR("A")="ENTER THE CID/PREFERRED DATE FOR THIS APPOINTMENT"
  1. S DIR("?",1)=" Enter the date that is desired for this appointment."
  1. S DIR("?",2)=" NOTE: PAST dates must include the Year in the input."
  1. S DIR("?",3)=""
  1. S DIR("?",4)=" You may enter 'F' to find the first available slot after a specified date."
  1. S DIR("?",5)=" You will be prompted for begin and end dates for this search."
  1. S DIR("?",6)=""
  1. S DIR("?",7)=" A date may be entered to begin the display of clinic availability at the"
  1. I DFN<1 S DIR("?")=" requested date."
  1. I DFN>0 D
  1. .S DIR("?",8)=" requested date."
  1. .S DIR("?",9)=""
  1. .S DIR("?",10)=" The entry of a date/time will result in the scheduling of an appointment at"
  1. .S DIR("?")=" that time, if possible."
  1. .Q
  1. W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT) 0
  1. I Y=" " S SDX=$G(^DISV(DUZ_U_+SC)) I SDX?7N S (X,Y)=SDX
  1. I $L(Y)=1,"fF"[Y D Q 1
  1. .W " First available"
  1. .S (SDDATE,SDSRTY)=$TR(Y,"f","F")
  1. .Q
  1. N %DT,SDX,SDI,POP
  1. S SDX="N^n^NOW^now^Now" F SDI=1:1:5 S:X=$P(SDX,U,SDI) X="T"
  1. S %DT="EFT" D ^%DT
  1. G:Y<1 DASK S SDDATE=Y
  1. I DFN<1 S SDDATE=SDDATE\1
  1. ;SD*5.3*621 - check if desired date if prior to DOB and if clinic schedule is available.
  1. I DFN>0 S POP=0 D DDCHK I POP G DASK
  1. I DFN>0,Y'<DT,(Y\1)>SDMAX D G DASK
  1. .W !,$C(7)
  1. .W "Scheduling cannot be more than ",SDMAX(1)," days in the future"
  1. .Q
  1. Q 1
  1. ;
  1. DDCHK ;SD*5.3*621 - check if desired date if prior to DOB and if clinic schedule is available.
  1. N X
  1. S X=SDDATE D AVCHK^SDM1 I POP Q
  1. D AVCHK1^SDM1
  1. Q
  1. ;
  1. DOWCHK ;SD*5.3*547 check if date is prior to date DOW was added to pattern
  1. S (DY,DYW)="" S:'$D(DWFLG) DWFLG=0
  1. I '$D(^SC(+SC,"ST",$P(XDT,"."),1)) D Q:DWFLG I POP D DWWRT Q
  1. .S DY=$$DOW^XLFDT($P(XDT,"."))
  1. .S DYW=$E(DY,1,2),DYW=$TR(DYW,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. .S PCDT=$P(XDT,"."),CT=0,POP=1
  1. .F S PCDT=$O(^SC(+SC,"ST",PCDT),-1) Q:'PCDT!('POP)!(CT>30) D
  1. ..S CT=CT+1
  1. ..Q:'$D(^SC(+SC,"ST",PCDT,0))
  1. ..Q:'$D(^SC(+SC,"ST",PCDT,1))
  1. ..Q:$E($G(^SC(+SC,"ST",PCDT,1)),1,2)'=DYW
  1. ..I $E($G(^SC(+SC,"ST",PCDT,1)),1,2)=DYW S POP=0 Q
  1. .Q
  1. K PCDT,CT,DY,DYW
  1. Q
  1. ;
  1. DWWRT ;added SD*5.3*547
  1. S DY=$TR(DY,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. W *7,!!,"That date is prior to the date ",DY," was added to the"
  1. W !,"availability pattern for this clinic.",!!
  1. K DY,DYW,PCDT,CT
  1. Q
  1. ;
  1. BEGDAT(SDDT,SDY) ;Add begin date check - SD*5.3*674, Quit 0 if successful, 1 if fails
  1. N SDX,SDBEG,SDDOW,SDBEGO,SDCNT
  1. F SDX=0:1:6 S SDDOW(SDX,9999999)="" ;SD*5.3*674
  1. S SDBEGO="",SDCNT=0 F S SDCNT=$O(^SC(+SC,"T"_$$DOW^XLFDT(SDDT,1),SDCNT)) Q:'SDCNT S SDBEGO=SDBEGO_U_SDCNT
  1. S SDX="" F S SDX=$O(^SC(+SC,"T",SDX),-1) Q:'SDX D ;SD*5.3*726
  1. .I '$D(^SC(+SC,"OST",SDX))!(($G(^SC(+SC,"T"_$$DOW^XLFDT(SDX,1),9999999,1))'="")&(SDBEGO="^9999999"!(SDBEGO[SDX))) S SDBEG=$G(^SC(+SC,"T",SDX,0),SDX) S SDDOW($$DOW^XLFDT(SDBEG,1),SDBEG)="" ;SD*5.3*674/SD*5.3*726
  1. I $O(SDDOW(SDY,(SDDT+1)),-1) Q 0 ;Successful check, Quit 0
  1. Q 1 ;Chec failed, Quit 1
  1. ;
  1. 1 S SDNEXT="",SDCT=0 G RD^SDMULT
  1. DT1 S FND=0,%DT(0)=-SDMAX,%DT="AEF",%DT("A")=" START SEARCH FOR NEXT AVAILABLE FROM WHAT DATE: " D ^%DT K %DT G:"^"[X 1:$S('$D(SDNEXT):1,'SDNEXT:1,1:0),END^SDMULT0 G:Y<0 DT S (SDDATE,SDSTRTDT)=+Y
  1. LIM W !," ENTER LATEST DATE TO CHECK FOR 1ST AVAILABLE SLOT: " S Y=SDMAX D DT^DIQ R "// ",X:DTIME G:X["^"!'($T) END^SDMULT0 I X']"" G OVR^SDMULT0
  1. I X?.E1"?" W !," The latest date for future bookings for ",$P(SDC(1),"^",2)," is: " S Y=SDMAX D DTS^SDUTL W Y,!," If you enter a date here, it must be less than this date to further limit the",!," search" G LIM
  1. S %DT="EF",%DT(0)=-SDMAX D ^%DT K %DT G:Y<0!(Y<SDSTRTDT) LIM S:Y>0 (SDDMAX,SDMAX)=+Y
  1. G OVR^SDMULT0