SDM0 ;SF/GFT - MAKE APPOINTMENT ; 11 Jun 2001 5:20 PM
;;5.3;PIMS;**140,167,206,186,223,237,241,384,334,1005,1015,1016**;JUN 30, 2012;Build 20
;IHS/ANMC/LJF 06/29/2000 bypassed asking scheduling request type
; calls BSDM0 for month-at-a-glance display
; 06/15/2001 bypassed calculate f/u status
; 07/12/2001 switch hang 3 for Press Enter to Continue
;IHS/OIT/LJF 12/30/2005 PATCH 1005 cleaned up confusion on Enter Date for Appt question
; 03/08/2006 PATCH 1005 if max days for future <3, allow Monday appts
;
I $D(SDXXX) S SDOK=1 Q
N SDSRTY,SDDATE,SDSDATE,SDSRFU,SDDMAX,SDONCE
;Prompt for scheduling request type
M N SDHX,SDXF,SDXD
Q:'$$SRTY(.SDSRTY) S:SDSRTY SDDATE=DT
;Calculate appointment follow-up indicator
S SDSRFU=$$PTFU(DFN,SC)
;Determine maximum days for scheduling
S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
I $$DOW^XLFDT(DT)="Friday",SDMAX(1)<3 S SDMAX(1)=3 ;IHS/OIT/LJF 03/08/2006 PATCH 1005
S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
;Prompt for desired date
Q:'$$DDATE(.SDDATE,SDSRTY,.SDMAX)
;If date and time, schedule appt. directly
W ! I SDDATE#1 S SDSDATE=SDDATE,SDDATE=SDDATE\1 G ^SDM1
S (X,Y)=SDDATE K SDHX
;Find first available after specified date
I X="F"!(X="f") D SUP,DT1 G NEXT
;Find next available appointment
I SDSRTY,SDDATE D SUP S SDSTRTDT=SDDATE D OVR^SDMULT0 G NEXT
;
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"
D Q:Y<1
.N %DT
.S %DT="T" D ^%DT
.I Y<1 W !!,"Unable to evaluate date value """_X_""".",!
.Q
S:$S($D(DUZ)'[0:1,1:0) ^DISV(DUZ_U_+SC)=Y
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
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
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
;
NEXT D SET I $S('$D(FND):1,'FND:1,1:0) D G EN
.K ^DISV($S($D(DUZ)'[0:DUZ,1:0)_U_+SC)
.I '$O(^SC(+SC,"ST",SDDATE-1)) S (X,Y)=SDDATE Q
.W $C(7),!?6,"No open slots found in the date range "
.W $$FMTE^XLFDT(SDDATE)," to ",$$FMTE^XLFDT(SDDMAX),"!",!
.;
.;H 3 S (X,Y)=SDDATE ;IHS/ANMC/LJF 7/12/2001
.D PAUSE^BDGF S (X,Y)=SDDATE ;IHS/ANMC/LJF 7/12/2001
.;
.Q
S (X,Y)=SDAPP K SDXXX G DISP
D ;IHS/ANMC/LJF 6/29/2000 separated line to add code
D EN^BSDM0(X),FULL^VALM1 Q ;IHS/ANMC/LJF 6/29/2000
W #!?36,$P(SC,U,2) 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
X1 S X1=X\100_$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+$E(X,4,5)) ;28
;SD*5.3*547 next line don't allow past dates to be added to pattern if prior to date DOW was added
W I '$D(^SC(+SC,"ST",X,1)) S DWFLG=1,POP=0,XDT=X D DOWCHK K DWFLG,XDT G L:POP
I '$D(^SC(+SC,"ST",X,1)) S Y=D#7 G L:'$D(J(Y)),H:$D(^HOLIDAY(X))&('SDSOH) 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,".")
S SDHX=X,SDAV=1 D:X>SM WM I SDXF<2 D WMH
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
I $Y>18 W ! Q
L K POP
S X=X+1,D=D+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
G W:X'>X1 S X2=X-X1 D C^%DTC
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
G X1:D<I W ! D:'SDAV MNTH Q
;
NOAV W !,"No availability found between date chosen and inactivate date!" Q
H S ^SC(+SC,"ST",X,1)=" "_$E(X,6,7)_" "_$P(^(X,0),U,2),^(0)=X G W
;
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"
S SDXF=SDXF+1 I $E(X,6,7)>20 D
. S SDXD=$O(^SC(+SC,"ST",X-1)) Q:SDXD=""
. I $E(SDXD,4,5)'=$E(X,4,5) S SDXF=0
D:SDXF DT
Q
WMH ;Write month heading lines
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)
W !," DATE",?SI+SI-1,"|" K J F Y=0:1:6 I $D(^SC(+SC,"T"_Y)) S J(Y)=""
F Y=1:1:65\(SI+SI) W $J("|",SI+SI)
S SDXF=2
Q
DT W $$FMTE^XLFDT(Y) Q
;
DOW S Y=$$DOW^XLFDT(X,1) Q
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
MORDIS I '$D(SDHX) W *7," ??" G ADT^SDM1
S SDXF=0,X1=SDHX,X2=1 D C^%DTC
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
G EN
INPAT S SDI=$O(^DGPM("ATID1",DFN,9999999-X)) I SDI>0 D I1
S:'$D(SDINP) SDINP="" K SDI,SDI1 Q
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
Q
;
SUP ;Set up variables for availability search
S SDNEXT=1,SDCT=1,G1=+SC,SDC(1)=SC,FND=0,SDAV=0 K SDC1
D SAVE S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
Q
;
SET S I1="" F I=0:0 S I1=$O(SDZ(I1)) Q:I1']"" S @I1=SDZ(I1)
K SDZ Q
SAVE K SDZ F I="SDDIF","STR","SC","DFN","SL","SI","HSI","SB" S Z="SDZ("_""""_I_""")" S:$D(@I) @Z=@I
Q
MNTH W !," *** No availability found for one full calendar month",!," Search stopped at " S Y=X D DTS^SDUTL W Y," ***",! Q
DIFF S X1=SDRE,X2=X D ^%DTC S D=D+X,X=SDRE,X1=X\100_28 Q
;
SRTY(SDSRTY) ;Prompt for scheduling request type
S SDSRTY="N" Q 1 ;IHS/ANMC/LJF 6/29/2000
;Input: SDSRTY=variable to return user response (pass by reference)
;Output: '1' if successful, '0' otherwise
;
I $G(DFN)<1 S SDSRTY="M" Q 1 ;patient not defined
I $G(SDMM)=1 S SDSRTY="M" Q 1 ;multiple appointment booking
N DIR,DTOUT,DUOUT
S DIR(0)="Y"
S DIR("A")="IS THIS A 'NEXT AVAILABLE' APPOINTMENT REQUEST"
S DIR("?")="Answer 'yes' if scheduling to the next available appointment is desired."
W ! D ^DIR I $D(DTOUT)!$D(DUOUT) Q 0
S SDSRTY=Y,SDSRTY(0)=$$TXRT^SDM1A(.SDSRTY) Q 1
;
PTFU(DFN,SC) ;Determine if this is a follow-up (return to clinic within 24 months)
Q 0 ;IHS/ANMC/LJF 6/15/2001
;Input: DFN=patient ifn
;Input: SC=clinic ifn
;Output: '1' if seen within 24 months, '0' otherwise
;
Q:'DFN!'SC 0 ;variable check
N SDBDT,SDT,SDX,SDY,SDZ,SDCP,SDCP1,SC0,SDENC,SDCT
;set up variables
S SDBDT=(DT-20000)+.24,SDT=DT_.999999,(SDCT,SDY)=0
S SC0=$G(^SC(+SC,0)),SDX=$$CPAIR^SCRPW71(SC0,.SDCP) ;get credit pair for this clinic
;Iterate through encounters
W !!,"Calculating follow-up status"
F S SDT=$O(^SCE("ADFN",DFN,SDT),-1) Q:SDT<SDBDT!SDY D
.S SDENC=0 F S SDENC=$O(^SCE("ADFN",DFN,SDT,SDENC)) Q:'SDENC!SDY D
..S SDENC0=$G(^SCE(SDENC,0)) ;get encounter node
..Q:$P(SDENC0,U,6) ;parent encounters only
..S SDX=$P(SDENC0,U,4) Q:'SDX ;get clinic
..S SC0=$G(^SC(SDX,0))
..S SDX=$$CPAIR^SCRPW71(SC0,.SDCP1) ;get credit pair for encounter
..S SDY=SDCP=SDCP1 ;compare credit pairs
..S SDCT=SDCT+1 W:SDCT#10=0 "."
..Q
.Q
Q SDY
;
DDATE(SDDATE,SDSRTY,SDMAX) ;Desired date selection
;Input: SDDATE=variable to return date selection (pass by reference)
;Input: SDSRTY=variable to return request type
;Input: SDMAX=variable to return max. days to sched. (pass by ref.)
;Output: '1' for success, otherwise '0'
;
Q:SDSRTY 1
W !!?2,"Select one of the following:",!
W !?5,"'F'",?20,"for First available following a specified date"
W !?5,"Date",?20,"(or date computation such as 'T+2M') for a desired date"
I DFN>0 W !?5,"Date/time",?20,"to schedule a specific appointment - Note: PAST dates",!?20,"must include the Year in the input." ;added note SD*5.3*547
W !?5,"'?'",?20,"for detailed help"
DASK N DIR,X,Y,SDX,DTOUT,DUOUT
;
;BP OIFO/TEH PATCH SD*5.3*384 ; SD*5.3*547 added note to help text
;
S DIR(0)="F^1:30"
S DIR("A")="ENTER THE DATE DESIRED FOR THIS APPOINTMENT"
S DIR("?",1)=" Enter the date that is desired for this appointment."
S DIR("?",2)=" NOTE: PAST dates must include the Year in the input."
S DIR("?",3)=""
S DIR("?",4)=" You may enter 'F' to find the first available slot after a specified date."
S DIR("?",5)=" You will be prompted for begin and end dates for this search."
S DIR("?",6)=""
S DIR("?",7)=" A date may be entered to begin the display of clinic availability at the"
I DFN<1 S DIR("?")=" requested date."
I DFN>0 D
.S DIR("?",8)=" requested date."
.S DIR("?",9)=""
.S DIR("?",10)=" The entry of a date/time will result in the scheduling of an appointment at"
.S DIR("?")=" that time, if possible."
.Q
;
;IHS/OIT/LJF 12/30/2005 PATCH 1005 adding TODAY as default answer & changing prompt
S DIR("B")="TODAY",DIR("A")="ENTER THE EARLIEST DATE DESIRED FOR THIS APPOINTMENT"
;
W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT) 0
I Y=" " S SDX=$G(^DISV(DUZ_U_+SC)) I SDX?7N S (X,Y)=SDX
I $L(Y)=1,"fF"[Y D Q 1
.W " First available"
.S (SDDATE,SDSRTY)=$TR(Y,"f","F")
.Q
N %DT,SDX,SDI
S SDX="N^n^NOW^now^Now" F SDI=1:1:5 S:X=$P(SDX,U,SDI) X="T"
S %DT="EFT" D ^%DT
G:Y<1 DASK S SDDATE=Y
I DFN<1 S SDDATE=SDDATE\1
I DFN>0,Y'<DT,(Y\1)>SDMAX D G DASK
.W !,$C(7)
.W "Scheduling cannot be more than ",SDMAX(1)," days in the future"
.Q
Q 1
;
DOWCHK ;SD*5.3*547 check if date is prior to date DOW was added to pattern
S (DY,DYW)="" S:'$D(DWFLG) DWFLG=0
I '$D(^SC(+SC,"ST",$P(XDT,"."),1)) D Q:DWFLG I POP D DWWRT Q
.S DY=$$DOW^XLFDT($P(XDT,"."))
.S DYW=$E(DY,1,2),DYW=$TR(DYW,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.S PCDT=$P(XDT,"."),CT=0,POP=1
.F S PCDT=$O(^SC(+SC,"ST",PCDT),-1) Q:'PCDT!('POP)!(CT>30) D
..S CT=CT+1
..Q:'$D(^SC(+SC,"ST",PCDT,0))
..Q:'$D(^SC(+SC,"ST",PCDT,1))
..Q:$E($G(^SC(+SC,"ST",PCDT,1)),1,2)'=DYW
..I $E($G(^SC(+SC,"ST",PCDT,1)),1,2)=DYW S POP=0 Q
.Q
K PCDT,CT,DY,DYW
Q
;
DWWRT ;added SD*5.3*547
S DY=$TR(DY,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
W *7,!!,"That date is prior to the date ",DY," was added to the"
W !,"availability pattern for this clinic.",!!
K DY,DYW,PCDT,CT
Q
;
1 S SDNEXT="",SDCT=0 G RD^SDMULT
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
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
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
S %DT="EF",%DT(0)=-SDMAX D ^%DT K %DT G:Y<0!(Y<SDSTRTDT) LIM S:Y>0 (SDDMAX,SDMAX)=+Y
G OVR^SDMULT0
SDM0 ;SF/GFT - MAKE APPOINTMENT ; 11 Jun 2001 5:20 PM
+1 ;;5.3;PIMS;**140,167,206,186,223,237,241,384,334,1005,1015,1016**;JUN 30, 2012;Build 20
+2 ;IHS/ANMC/LJF 06/29/2000 bypassed asking scheduling request type
+3 ; calls BSDM0 for month-at-a-glance display
+4 ; 06/15/2001 bypassed calculate f/u status
+5 ; 07/12/2001 switch hang 3 for Press Enter to Continue
+6 ;IHS/OIT/LJF 12/30/2005 PATCH 1005 cleaned up confusion on Enter Date for Appt question
+7 ; 03/08/2006 PATCH 1005 if max days for future <3, allow Monday appts
+8 ;
+9 IF $DATA(SDXXX)
SET SDOK=1
QUIT
+10 NEW SDSRTY,SDDATE,SDSDATE,SDSRFU,SDDMAX,SDONCE
+11 ;Prompt for scheduling request type
M NEW SDHX,SDXF,SDXD
+1 IF '$$SRTY(.SDSRTY)
QUIT
IF SDSRTY
SET SDDATE=DT
+2 ;Calculate appointment follow-up indicator
+3 SET SDSRFU=$$PTFU(DFN,SC)
+4 ;Determine maximum days for scheduling
+5 SET SDMAX(1)=$PIECE($GET(^SC(+SC,"SDP")),U,2)
IF 'SDMAX(1)
SET SDMAX(1)=365
+6 ;IHS/OIT/LJF 03/08/2006 PATCH 1005
IF $$DOW^XLFDT(DT)="Friday"
IF SDMAX(1)<3
SET SDMAX(1)=3
+7 SET (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
+8 ;Prompt for desired date
+9 IF '$$DDATE(.SDDATE,SDSRTY,.SDMAX)
QUIT
+10 ;If date and time, schedule appt. directly
+11 WRITE !
IF SDDATE#1
SET SDSDATE=SDDATE
SET SDDATE=SDDATE\1
GOTO ^SDM1
+12 SET (X,Y)=SDDATE
KILL SDHX
+13 ;Find first available after specified date
+14 IF X="F"!(X="f")
DO SUP
DO DT1
GOTO NEXT
+15 ;Find next available appointment
+16 IF SDSRTY
IF SDDATE
DO SUP
SET SDSTRTDT=SDDATE
DO OVR^SDMULT0
GOTO NEXT
+17 ;
EN IF $LENGTH(X)=1
SET X=$TRANSLATE(X,"tnN","TTT")
IF X="NOW"
SET X="T"
IF X?.A!(+X=X)
IF X<13
IF X'?1"T".E
SET X=X_" 1"
+1 Begin DoDot:1
+2 NEW %DT
+3 SET %DT="T"
DO ^%DT
+4 IF Y<1
WRITE !!,"Unable to evaluate date value """_X_""".",!
+5 QUIT
End DoDot:1
IF Y<1
QUIT
+6 IF $SELECT($DATA(DUZ)'[0
SET ^DISV(DUZ_U_+SC)=Y
DISP SET IOF=$SELECT('$DATA(IOF):"!#",IOF']"":"!#",1:IOF)
WRITE @IOF
SET SDSOH=$SELECT('$DATA(^SC(+SC,"SL")):0,$PIECE(^("SL"),"^",8)']"":0,1:1)
SET SDAV=0
+1 IF $DATA(SDINA)
IF Y'<SDINA
IF SDRE>Y!('SDRE)
SET SDHY=Y
SET Y=SDINA
DO DTS^SDUTL
WRITE !,*7,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),Y
SET Y=SDRE
IF Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" to "_Y,1:"")
SET Y=SDHY
KILL SDHY
DO PAUSE^VALM1
IF 'SDRE
QUIT
+2 IF Y#100=0
SET Y=Y+1
SET X=Y
IF $EXTRACT(X,4,5)
DO D
SET (SDX,X1)=X
SET X2=1
DO C^%DTC
SET X=SDX
KILL SDX
IF SDAV
GOTO ^SDM1
QUIT
+3 ;
NEXT DO SET
IF $SELECT('$DATA(FND):1,'FND:1,1:0)
Begin DoDot:1
+1 KILL ^DISV($SELECT($DATA(DUZ)'[0:DUZ,1:0)_U_+SC)
+2 IF '$ORDER(^SC(+SC,"ST",SDDATE-1))
SET (X,Y)=SDDATE
QUIT
+3 WRITE $CHAR(7),!?6,"No open slots found in the date range "
+4 WRITE $$FMTE^XLFDT(SDDATE)," to ",$$FMTE^XLFDT(SDDMAX),"!",!
+5 ;
+6 ;H 3 S (X,Y)=SDDATE ;IHS/ANMC/LJF 7/12/2001
+7 ;IHS/ANMC/LJF 7/12/2001
DO PAUSE^BDGF
SET (X,Y)=SDDATE
+8 ;
+9 QUIT
End DoDot:1
GOTO EN
+10 SET (X,Y)=SDAPP
KILL SDXXX
GOTO DISP
D ;IHS/ANMC/LJF 6/29/2000 separated line to add code
+1 ;IHS/ANMC/LJF 6/29/2000
DO EN^BSDM0(X)
DO FULL^VALM1
QUIT
+2 WRITE #!?36,$PIECE(SC,U,2)
IF $ORDER(^SC(+SC,"T",0))>X
SET X=+$ORDER(^(0))
DO DOW
SET I=Y+32
SET D=Y
SET SDXF=0
DO WM
IF SDXF
DO WMH
X1 ;28
SET X1=X\100_$PIECE("31^28^31^30^31^30^31^31^30^31^30^31",U,+$EXTRACT(X,4,5))
+1 ;SD*5.3*547 next line don't allow past dates to be added to pattern if prior to date DOW was added
W IF '$DATA(^SC(+SC,"ST",X,1))
SET DWFLG=1
SET POP=0
SET XDT=X
DO DOWCHK
KILL DWFLG,XDT
IF POP
GOTO L
+1 IF '$DATA(^SC(+SC,"ST",X,1))
SET Y=D#7
IF '$DATA(J(Y))
GOTO L
IF $DATA(^HOLIDAY(X))&('SDSOH)
GOTO H
SET SS=+$ORDER(^SC(+SC,"T"_Y,X))
IF SS'>0
GOTO L
IF ^(SS,1)=""
GOTO L
SET ^SC(+SC,"ST",$PIECE(X,"."),1)=$EXTRACT($PIECE($TEXT(DAY),U,Y+2),1,2)_" "_$EXTRACT(X,6,7)_$JUSTIFY("",SI+SI-6)_^(1)
SET ^(0)=$PIECE(X,".")
+2 SET SDHX=X
SET SDAV=1
IF X>SM
DO WM
IF SDXF<2
DO WMH
+3 IF $DATA(^SC(+SC,"ST",X,1))
IF ^(1)["["!(^(1)["CANCELLED")!($DATA(^HOLIDAY(X)))
WRITE !,$EXTRACT(^SC(+SC,"ST",X,1),1,80)
IF '$DATA(^HOLIDAY(X))&('SDAV)
SET SDAV=1
+4 IF $Y>18
WRITE !
QUIT
L KILL POP
+1 SET X=X+1
SET D=D+1
+2 IF $DATA(SDINA)
IF X>SDINA
IF SDRE>X!('SDRE)
IF 'SDAV
DO NOAV
SET SDHY=Y
SET Y=SDINA
DO DTS^SDUTL
WRITE !,*7,?8,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),Y
SET Y=SDRE
IF Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" to "_Y,1:"")
SET Y=SDHY
KILL SDHY
IF 'SDRE
QUIT
DO DIFF
+3 IF X'>X1
GOTO W
SET X2=X-X1
DO C^%DTC
+4 IF $DATA(SDINA)
IF X>SDINA
IF SDRE>X!('SDRE)
IF 'SDAV
DO NOAV
SET SDHY=Y
SET Y=SDINA
DO DTS^SDUTL
WRITE !,*7,?8,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),Y
SET Y=SDRE
IF Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" to "_Y,1:"")
SET Y=SDHY
KILL SDHY
IF 'SDRE
QUIT
+5 IF D<I
GOTO X1
WRITE !
IF 'SDAV
DO MNTH
QUIT
+6 ;
NOAV WRITE !,"No availability found between date chosen and inactivate date!"
QUIT
H SET ^SC(+SC,"ST",X,1)=" "_$EXTRACT(X,6,7)_" "_$PIECE(^(X,0),U,2)
SET ^(0)=X
GOTO W
+1 ;
WM WRITE !?36
SET Y=$EXTRACT(X,1,5)_"00"
SET SM=$SELECT($EXTRACT(X,4,5)[12:$EXTRACT(X,1,3)+1_"01",1:$EXTRACT(X,1,3)_$EXTRACT(X,4,5)+1)_"00"
+1 SET SDXF=SDXF+1
IF $EXTRACT(X,6,7)>20
Begin DoDot:1
+2 SET SDXD=$ORDER(^SC(+SC,"ST",X-1))
IF SDXD=""
QUIT
+3 IF $EXTRACT(SDXD,4,5)'=$EXTRACT(X,4,5)
SET SDXF=0
End DoDot:1
+4 IF SDXF
DO DT
+5 QUIT
WMH ;Write month heading lines
+1 WRITE !!," TIME",?SI+SI-1
FOR Y=STARTDAY:1:65\(SI+SI)+STARTDAY
WRITE $EXTRACT("|"_$SELECT('Y:0,1:(Y-1#12+1))_" ",1,SI+SI)
+2 WRITE !," DATE",?SI+SI-1,"|"
KILL J
FOR Y=0:1:6
IF $DATA(^SC(+SC,"T"_Y))
SET J(Y)=""
+3 FOR Y=1:1:65\(SI+SI)
WRITE $JUSTIFY("|",SI+SI)
+4 SET SDXF=2
+5 QUIT
DT WRITE $$FMTE^XLFDT(Y)
QUIT
+1 ;
DOW SET Y=$$DOW^XLFDT(X,1)
QUIT
+1 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
MORDIS IF '$DATA(SDHX)
WRITE *7," ??"
GOTO ADT^SDM1
+1 SET SDXF=0
SET X1=SDHX
SET X2=1
DO C^%DTC
MORD2 IF $DATA(SDINA)
IF SDINA'>X
IF SDRE>X!('SDRE)
SET SDHY=$SELECT($DATA(Y):Y,1:"")
SET Y=SDINA
DO DTS^SDUTL
WRITE *7,!,"Clinic is inactivated as of ",Y
SET Y=SDHY
KILL SDHY
GOTO ADT^SDM1
+1 GOTO EN
INPAT SET SDI=$ORDER(^DGPM("ATID1",DFN,9999999-X))
IF SDI>0
DO I1
+1 IF '$DATA(SDINP)
SET SDINP=""
KILL SDI,SDI1
QUIT
I1 FOR SDI1=0:0
SET SDI1=$ORDER(^DGPM("ATID1",DFN,SDI,SDI1))
IF SDI1'>0
QUIT
IF $DATA(^DGPM(SDI1,0))
SET SDX=^(0)
IF $SELECT($PIECE(SDX,U,17)']"":1,+^DGPM($PIECE(SDX,U,17),0)>X!(+^DGPM($PIECE(SDX,U,17),0)=0):1,1:0)
SET SDINP="I"
QUIT
+1 QUIT
+2 ;
SUP ;Set up variables for availability search
+1 SET SDNEXT=1
SET SDCT=1
SET G1=+SC
SET SDC(1)=SC
SET FND=0
SET SDAV=0
KILL SDC1
+2 DO SAVE
SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
+3 QUIT
+4 ;
SET SET I1=""
FOR I=0:0
SET I1=$ORDER(SDZ(I1))
IF I1']""
QUIT
SET @I1=SDZ(I1)
+1 KILL SDZ
QUIT
SAVE KILL SDZ
FOR I="SDDIF","STR","SC","DFN","SL","SI","HSI","SB"
SET Z="SDZ("_""""_I_""")"
IF $DATA(@I)
SET @Z=@I
+1 QUIT
MNTH WRITE !," *** No availability found for one full calendar month",!," Search stopped at "
SET Y=X
DO DTS^SDUTL
WRITE Y," ***",!
QUIT
DIFF SET X1=SDRE
SET X2=X
DO ^%DTC
SET D=D+X
SET X=SDRE
SET X1=X\100_28
QUIT
+1 ;
SRTY(SDSRTY) ;Prompt for scheduling request type
+1 ;IHS/ANMC/LJF 6/29/2000
SET SDSRTY="N"
QUIT 1
+2 ;Input: SDSRTY=variable to return user response (pass by reference)
+3 ;Output: '1' if successful, '0' otherwise
+4 ;
+5 ;patient not defined
IF $GET(DFN)<1
SET SDSRTY="M"
QUIT 1
+6 ;multiple appointment booking
IF $GET(SDMM)=1
SET SDSRTY="M"
QUIT 1
+7 NEW DIR,DTOUT,DUOUT
+8 SET DIR(0)="Y"
+9 SET DIR("A")="IS THIS A 'NEXT AVAILABLE' APPOINTMENT REQUEST"
+10 SET DIR("?")="Answer 'yes' if scheduling to the next available appointment is desired."
+11 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
+12 SET SDSRTY=Y
SET SDSRTY(0)=$$TXRT^SDM1A(.SDSRTY)
QUIT 1
+13 ;
PTFU(DFN,SC) ;Determine if this is a follow-up (return to clinic within 24 months)
+1 ;IHS/ANMC/LJF 6/15/2001
QUIT 0
+2 ;Input: DFN=patient ifn
+3 ;Input: SC=clinic ifn
+4 ;Output: '1' if seen within 24 months, '0' otherwise
+5 ;
+6 ;variable check
IF 'DFN!'SC
QUIT 0
+7 NEW SDBDT,SDT,SDX,SDY,SDZ,SDCP,SDCP1,SC0,SDENC,SDCT
+8 ;set up variables
+9 SET SDBDT=(DT-20000)+.24
SET SDT=DT_.999999
SET (SDCT,SDY)=0
+10 ;get credit pair for this clinic
SET SC0=$GET(^SC(+SC,0))
SET SDX=$$CPAIR^SCRPW71(SC0,.SDCP)
+11 ;Iterate through encounters
+12 WRITE !!,"Calculating follow-up status"
+13 FOR
SET SDT=$ORDER(^SCE("ADFN",DFN,SDT),-1)
IF SDT<SDBDT!SDY
QUIT
Begin DoDot:1
+14 SET SDENC=0
FOR
SET SDENC=$ORDER(^SCE("ADFN",DFN,SDT,SDENC))
IF 'SDENC!SDY
QUIT
Begin DoDot:2
+15 ;get encounter node
SET SDENC0=$GET(^SCE(SDENC,0))
+16 ;parent encounters only
IF $PIECE(SDENC0,U,6)
QUIT
+17 ;get clinic
SET SDX=$PIECE(SDENC0,U,4)
IF 'SDX
QUIT
+18 SET SC0=$GET(^SC(SDX,0))
+19 ;get credit pair for encounter
SET SDX=$$CPAIR^SCRPW71(SC0,.SDCP1)
+20 ;compare credit pairs
SET SDY=SDCP=SDCP1
+21 SET SDCT=SDCT+1
IF SDCT#10=0
WRITE "."
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 QUIT SDY
+25 ;
DDATE(SDDATE,SDSRTY,SDMAX) ;Desired date selection
+1 ;Input: SDDATE=variable to return date selection (pass by reference)
+2 ;Input: SDSRTY=variable to return request type
+3 ;Input: SDMAX=variable to return max. days to sched. (pass by ref.)
+4 ;Output: '1' for success, otherwise '0'
+5 ;
+6 IF SDSRTY
QUIT 1
+7 WRITE !!?2,"Select one of the following:",!
+8 WRITE !?5,"'F'",?20,"for First available following a specified date"
+9 WRITE !?5,"Date",?20,"(or date computation such as 'T+2M') for a desired date"
+10 ;added note SD*5.3*547
IF DFN>0
WRITE !?5,"Date/time",?20,"to schedule a specific appointment - Note: PAST dates",!?20,"must include the Year in the input."
+11 WRITE !?5,"'?'",?20,"for detailed help"
DASK NEW DIR,X,Y,SDX,DTOUT,DUOUT
+1 ;
+2 ;BP OIFO/TEH PATCH SD*5.3*384 ; SD*5.3*547 added note to help text
+3 ;
+4 SET DIR(0)="F^1:30"
+5 SET DIR("A")="ENTER THE DATE DESIRED FOR THIS APPOINTMENT"
+6 SET DIR("?",1)=" Enter the date that is desired for this appointment."
+7 SET DIR("?",2)=" NOTE: PAST dates must include the Year in the input."
+8 SET DIR("?",3)=""
+9 SET DIR("?",4)=" You may enter 'F' to find the first available slot after a specified date."
+10 SET DIR("?",5)=" You will be prompted for begin and end dates for this search."
+11 SET DIR("?",6)=""
+12 SET DIR("?",7)=" A date may be entered to begin the display of clinic availability at the"
+13 IF DFN<1
SET DIR("?")=" requested date."
+14 IF DFN>0
Begin DoDot:1
+15 SET DIR("?",8)=" requested date."
+16 SET DIR("?",9)=""
+17 SET DIR("?",10)=" The entry of a date/time will result in the scheduling of an appointment at"
+18 SET DIR("?")=" that time, if possible."
+19 QUIT
End DoDot:1
+20 ;
+21 ;IHS/OIT/LJF 12/30/2005 PATCH 1005 adding TODAY as default answer & changing prompt
+22 SET DIR("B")="TODAY"
SET DIR("A")="ENTER THE EARLIEST DATE DESIRED FOR THIS APPOINTMENT"
+23 ;
+24 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
+25 IF Y=" "
SET SDX=$GET(^DISV(DUZ_U_+SC))
IF SDX?7N
SET (X,Y)=SDX
+26 IF $LENGTH(Y)=1
IF "fF"[Y
Begin DoDot:1
+27 WRITE " First available"
+28 SET (SDDATE,SDSRTY)=$TRANSLATE(Y,"f","F")
+29 QUIT
End DoDot:1
QUIT 1
+30 NEW %DT,SDX,SDI
+31 SET SDX="N^n^NOW^now^Now"
FOR SDI=1:1:5
IF X=$PIECE(SDX,U,SDI)
SET X="T"
+32 SET %DT="EFT"
DO ^%DT
+33 IF Y<1
GOTO DASK
SET SDDATE=Y
+34 IF DFN<1
SET SDDATE=SDDATE\1
+35 IF DFN>0
IF Y'<DT
IF (Y\1)>SDMAX
Begin DoDot:1
+36 WRITE !,$CHAR(7)
+37 WRITE "Scheduling cannot be more than ",SDMAX(1)," days in the future"
+38 QUIT
End DoDot:1
GOTO DASK
+39 QUIT 1
+40 ;
DOWCHK ;SD*5.3*547 check if date is prior to date DOW was added to pattern
+1 SET (DY,DYW)=""
IF '$DATA(DWFLG)
SET DWFLG=0
+2 IF '$DATA(^SC(+SC,"ST",$PIECE(XDT,"."),1))
Begin DoDot:1
+3 SET DY=$$DOW^XLFDT($PIECE(XDT,"."))
+4 SET DYW=$EXTRACT(DY,1,2)
SET DYW=$TRANSLATE(DYW,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+5 SET PCDT=$PIECE(XDT,".")
SET CT=0
SET POP=1
+6 FOR
SET PCDT=$ORDER(^SC(+SC,"ST",PCDT),-1)
IF 'PCDT!('POP)!(CT>30)
QUIT
Begin DoDot:2
+7 SET CT=CT+1
+8 IF '$DATA(^SC(+SC,"ST",PCDT,0))
QUIT
+9 IF '$DATA(^SC(+SC,"ST",PCDT,1))
QUIT
+10 IF $EXTRACT($GET(^SC(+SC,"ST",PCDT,1)),1,2)'=DYW
QUIT
+11 IF $EXTRACT($GET(^SC(+SC,"ST",PCDT,1)),1,2)=DYW
SET POP=0
QUIT
End DoDot:2
+12 QUIT
End DoDot:1
IF DWFLG
QUIT
IF POP
DO DWWRT
QUIT
+13 KILL PCDT,CT,DY,DYW
+14 QUIT
+15 ;
DWWRT ;added SD*5.3*547
+1 SET DY=$TRANSLATE(DY,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 WRITE *7,!!,"That date is prior to the date ",DY," was added to the"
+3 WRITE !,"availability pattern for this clinic.",!!
+4 KILL DY,DYW,PCDT,CT
+5 QUIT
+6 ;
1 SET SDNEXT=""
SET SDCT=0
GOTO RD^SDMULT
DT1 SET FND=0
SET %DT(0)=-SDMAX
SET %DT="AEF"
SET %DT("A")=" START SEARCH FOR NEXT AVAILABLE FROM WHAT DATE: "
DO ^%DT
KILL %DT
IF "^"[X
IF $SELECT('$DATA(SDNEXT):1,'SDNEXT:1,1:0)
GOTO 1
GOTO END^SDMULT0
IF Y<0
GOTO DT
SET (SDDATE,SDSTRTDT)=+Y
LIM WRITE !," ENTER LATEST DATE TO CHECK FOR 1ST AVAILABLE SLOT: "
SET Y=SDMAX
DO DT^DIQ
READ "// ",X:DTIME
IF X["^"!'($TEST)
GOTO END^SDMULT0
IF X']""
GOTO OVR^SDMULT0
+1 IF X?.E1"?"
WRITE !," The latest date for future bookings for ",$PIECE(SDC(1),"^",2)," is: "
SET Y=SDMAX
DO DTS^SDUTL
WRITE Y,!," If you enter a date here, it must be less than this date to further limit the",!," search"
GOTO LIM
+2 SET %DT="EF"
SET %DT(0)=-SDMAX
DO ^%DT
KILL %DT
IF Y<0!(Y<SDSTRTDT)
GOTO LIM
IF Y>0
SET (SDDMAX,SDMAX)=+Y
+3 GOTO OVR^SDMULT0
