- SDM0 ;SF/GFT,ANU - MAKE APPOINTMENT ;1/5/16 12:26pm
- ;;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
- ;;Per VHA Directive 6402, this routine should not be modified
- I $D(SDXXX) S SDOK=1 Q
- N SDSRTY,SDDATE,SDSDATE,SDDATE2,SDSRFU,SDDMAX,SDONCE
- ;Prompt for scheduling request type
- M N SDHX,SDXF,SDXD
- Q:'$$SRTY(.SDSRTY) S:SDSRTY SDDATE=DT
- ; SD*5.3*622 - let user see desired date
- ; SD*5.3*645 - replaced DESIRED DATE with CID/PREFERRED DATE
- I $D(SDDATE) S Y=SDDATE,SDDATE2=$$FMTE^XLFDT(Y) W !!,"APPOINTMENT CID/PREFERRED DATE: "_SDDATE2 W ! H 3
- ;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
- S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
- ; SD*5.3*796 - Anu - Remove prompt for PID and default to today's date
- ;Prompt for desired date
- ;Q:'$$DDATE(.SDDATE,SDSRTY,.SDMAX)
- S SDDATE=DT
- ; SD*5.3*796 - Anu - Remove prompt - End
- ;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
- .Q
- S (X,Y)=SDAPP K SDXXX G DISP
- ; SD*5.3*622 - display clinic name all the time
- 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
- 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
- ;Add date start date check - SD*5.3*674
- 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,".")
- 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
- ;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)
- ;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'",?19,"for First available following a specified date"
- ; SD*5.3*645 - replaced desired date with CID/Preferred date, adjusted format
- ; W !?5,"Date",?19,"(or date computation such as 'T+2M') for a desired date"
- W !?5,"Date",?19,"(or date computation such as 'T+2M') for a CID/Preferred date"
- 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
- W !?5,"'?'",?19,"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"
- ; SD*5.3*645 - replaced DATE DESIRED with CID/PREFERRED DATE
- ; S DIR("A")="ENTER THE DATE DESIRED FOR THIS APPOINTMENT"
- S DIR("A")="ENTER THE CID/PREFERRED DATE 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
- 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,POP
- 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
- ;SD*5.3*621 - check if desired date if prior to DOB and if clinic schedule is available.
- I DFN>0 S POP=0 D DDCHK I POP G DASK
- 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
- ;
- DDCHK ;SD*5.3*621 - check if desired date if prior to DOB and if clinic schedule is available.
- N X
- S X=SDDATE D AVCHK^SDM1 I POP Q
- D AVCHK1^SDM1
- Q
- ;
- 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
- ;
- BEGDAT(SDDT,SDY) ;Add begin date check - SD*5.3*674, Quit 0 if successful, 1 if fails
- N SDX,SDBEG,SDDOW,SDBEGO,SDCNT
- F SDX=0:1:6 S SDDOW(SDX,9999999)="" ;SD*5.3*674
- S SDBEGO="",SDCNT=0 F S SDCNT=$O(^SC(+SC,"T"_$$DOW^XLFDT(SDDT,1),SDCNT)) Q:'SDCNT S SDBEGO=SDBEGO_U_SDCNT
- S SDX="" F S SDX=$O(^SC(+SC,"T",SDX),-1) Q:'SDX D ;SD*5.3*726
- .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
- I $O(SDDOW(SDY,(SDDT+1)),-1) Q 0 ;Successful check, Quit 0
- Q 1 ;Chec failed, Quit 1
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDM0 11947 printed Feb 19, 2025@00:24:47 Page 2
- 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
- +2 ;;Per VHA Directive 6402, this routine should not be modified
- +3 IF $DATA(SDXXX)
- SET SDOK=1
- QUIT
- +4 NEW SDSRTY,SDDATE,SDSDATE,SDDATE2,SDSRFU,SDDMAX,SDONCE
- +5 ;Prompt for scheduling request type
- M NEW SDHX,SDXF,SDXD
- +1 if '$$SRTY(.SDSRTY)
- QUIT
- if SDSRTY
- SET SDDATE=DT
- +2 ; SD*5.3*622 - let user see desired date
- +3 ; SD*5.3*645 - replaced DESIRED DATE with CID/PREFERRED DATE
- +4 IF $DATA(SDDATE)
- SET Y=SDDATE
- SET SDDATE2=$$FMTE^XLFDT(Y)
- WRITE !!,"APPOINTMENT CID/PREFERRED DATE: "_SDDATE2
- WRITE !
- HANG 3
- +5 ;Calculate appointment follow-up indicator
- +6 SET SDSRFU=$$PTFU(DFN,SC)
- +7 ;Determine maximum days for scheduling
- +8 SET SDMAX(1)=$PIECE($GET(^SC(+SC,"SDP")),U,2)
- if 'SDMAX(1)
- SET SDMAX(1)=365
- +9 SET (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
- +10 ; SD*5.3*796 - Anu - Remove prompt for PID and default to today's date
- +11 ;Prompt for desired date
- +12 ;Q:'$$DDATE(.SDDATE,SDSRTY,.SDMAX)
- +13 SET SDDATE=DT
- +14 ; SD*5.3*796 - Anu - Remove prompt - End
- +15 ;If date and time, schedule appt. directly
- +16 WRITE !
- IF SDDATE#1
- SET SDSDATE=SDDATE
- SET SDDATE=SDDATE\1
- GOTO ^SDM1
- +17 SET (X,Y)=SDDATE
- KILL SDHX
- +18 ;Find first available after specified date
- +19 IF X="F"!(X="f")
- DO SUP
- DO DT1
- GOTO NEXT
- +20 ;Find next available appointment
- +21 IF SDSRTY
- IF SDDATE
- DO SUP
- SET SDSTRTDT=SDDATE
- DO OVR^SDMULT0
- GOTO NEXT
- +22 ;
- 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 HANG 3
- SET (X,Y)=SDDATE
- +6 QUIT
- End DoDot:1
- GOTO EN
- +7 SET (X,Y)=SDAPP
- KILL SDXXX
- GOTO DISP
- +8 ; SD*5.3*622 - display clinic name all the time
- D WRITE #!?36,$PIECE(^SC(+SC,0),U,1)
- 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 ;Add date start date check - SD*5.3*674
- +2 IF '$DATA(^SC(+SC,"ST",X,1))
- SET Y=D#7
- if '$DATA(J(Y))
- GOTO L
- if $DATA(^HOLIDAY(X))&('SDSOH)
- GOTO H
- IF '$$BEGDAT(X,Y)
- 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,".")
- +3 SET SDHX=X
- SET SDAV=1
- if X>SM
- DO WM
- IF SDXF<2
- DO WMH
- +4 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
- +5 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 ;Input: SDSRTY=variable to return user response (pass by reference)
- +2 ;Output: '1' if successful, '0' otherwise
- +3 ;
- +4 ;patient not defined
- IF $GET(DFN)<1
- SET SDSRTY="M"
- QUIT 1
- +5 ;multiple appointment booking
- IF $GET(SDMM)=1
- SET SDSRTY="M"
- QUIT 1
- +6 NEW DIR,DTOUT,DUOUT
- +7 SET DIR(0)="Y"
- +8 SET DIR("A")="IS THIS A 'NEXT AVAILABLE' APPOINTMENT REQUEST"
- +9 SET DIR("?")="Answer 'yes' if scheduling to the next available appointment is desired."
- +10 WRITE !
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT 0
- +11 SET SDSRTY=Y
- SET SDSRTY(0)=$$TXRT^SDM1A(.SDSRTY)
- QUIT 1
- +12 ;
- PTFU(DFN,SC) ;Determine if this is a follow-up (return to clinic within 24 months)
- +1 ;Input: DFN=patient ifn
- +2 ;Input: SC=clinic ifn
- +3 ;Output: '1' if seen within 24 months, '0' otherwise
- +4 ;
- +5 ;variable check
- if 'DFN!'SC
- QUIT 0
- +6 NEW SDBDT,SDT,SDX,SDY,SDZ,SDCP,SDCP1,SC0,SDENC,SDCT
- +7 ;set up variables
- +8 SET SDBDT=(DT-20000)+.24
- SET SDT=DT_.999999
- SET (SDCT,SDY)=0
- +9 ;get credit pair for this clinic
- SET SC0=$GET(^SC(+SC,0))
- SET SDX=$$CPAIR^SCRPW71(SC0,.SDCP)
- +10 ;Iterate through encounters
- +11 WRITE !!,"Calculating follow-up status"
- +12 FOR
- SET SDT=$ORDER(^SCE("ADFN",DFN,SDT),-1)
- if SDT<SDBDT!SDY
- QUIT
- Begin DoDot:1
- +13 SET SDENC=0
- FOR
- SET SDENC=$ORDER(^SCE("ADFN",DFN,SDT,SDENC))
- if 'SDENC!SDY
- QUIT
- Begin DoDot:2
- +14 ;get encounter node
- SET SDENC0=$GET(^SCE(SDENC,0))
- +15 ;parent encounters only
- if $PIECE(SDENC0,U,6)
- QUIT
- +16 ;get clinic
- SET SDX=$PIECE(SDENC0,U,4)
- if 'SDX
- QUIT
- +17 SET SC0=$GET(^SC(SDX,0))
- +18 ;get credit pair for encounter
- SET SDX=$$CPAIR^SCRPW71(SC0,.SDCP1)
- +19 ;compare credit pairs
- SET SDY=SDCP=SDCP1
- +20 SET SDCT=SDCT+1
- if SDCT#10=0
- WRITE "."
- +21 QUIT
- End DoDot:2
- +22 QUIT
- End DoDot:1
- +23 QUIT SDY
- +24 ;
- 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'",?19,"for First available following a specified date"
- +9 ; SD*5.3*645 - replaced desired date with CID/Preferred date, adjusted format
- +10 ; W !?5,"Date",?19,"(or date computation such as 'T+2M') for a desired date"
- +11 WRITE !?5,"Date",?19,"(or date computation such as 'T+2M') for a CID/Preferred date"
- +12 ;added note SD*5.3*547
- IF DFN>0
- WRITE !?5,"Date/time",?19,"to schedule a specific appointment - Note: PAST dates",!?19,"must include the Year in the input."
- +13 WRITE !?5,"'?'",?19,"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 ; SD*5.3*645 - replaced DATE DESIRED with CID/PREFERRED DATE
- +6 ; S DIR("A")="ENTER THE DATE DESIRED FOR THIS APPOINTMENT"
- +7 SET DIR("A")="ENTER THE CID/PREFERRED DATE FOR THIS APPOINTMENT"
- +8 SET DIR("?",1)=" Enter the date that is desired for this appointment."
- +9 SET DIR("?",2)=" NOTE: PAST dates must include the Year in the input."
- +10 SET DIR("?",3)=""
- +11 SET DIR("?",4)=" You may enter 'F' to find the first available slot after a specified date."
- +12 SET DIR("?",5)=" You will be prompted for begin and end dates for this search."
- +13 SET DIR("?",6)=""
- +14 SET DIR("?",7)=" A date may be entered to begin the display of clinic availability at the"
- +15 IF DFN<1
- SET DIR("?")=" requested date."
- +16 IF DFN>0
- Begin DoDot:1
- +17 SET DIR("?",8)=" requested date."
- +18 SET DIR("?",9)=""
- +19 SET DIR("?",10)=" The entry of a date/time will result in the scheduling of an appointment at"
- +20 SET DIR("?")=" that time, if possible."
- +21 QUIT
- End DoDot:1
- +22 WRITE !
- DO ^DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- QUIT 0
- +23 IF Y=" "
- SET SDX=$GET(^DISV(DUZ_U_+SC))
- IF SDX?7N
- SET (X,Y)=SDX
- +24 IF $LENGTH(Y)=1
- IF "fF"[Y
- Begin DoDot:1
- +25 WRITE " First available"
- +26 SET (SDDATE,SDSRTY)=$TRANSLATE(Y,"f","F")
- +27 QUIT
- End DoDot:1
- QUIT 1
- +28 NEW %DT,SDX,SDI,POP
- +29 SET SDX="N^n^NOW^now^Now"
- FOR SDI=1:1:5
- if X=$PIECE(SDX,U,SDI)
- SET X="T"
- +30 SET %DT="EFT"
- DO ^%DT
- +31 if Y<1
- GOTO DASK
- SET SDDATE=Y
- +32 IF DFN<1
- SET SDDATE=SDDATE\1
- +33 ;SD*5.3*621 - check if desired date if prior to DOB and if clinic schedule is available.
- +34 IF DFN>0
- SET POP=0
- DO DDCHK
- IF POP
- GOTO DASK
- +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 ;
- DDCHK ;SD*5.3*621 - check if desired date if prior to DOB and if clinic schedule is available.
- +1 NEW X
- +2 SET X=SDDATE
- DO AVCHK^SDM1
- IF POP
- QUIT
- +3 DO AVCHK1^SDM1
- +4 QUIT
- +5 ;
- 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 ;
- BEGDAT(SDDT,SDY) ;Add begin date check - SD*5.3*674, Quit 0 if successful, 1 if fails
- +1 NEW SDX,SDBEG,SDDOW,SDBEGO,SDCNT
- +2 ;SD*5.3*674
- FOR SDX=0:1:6
- SET SDDOW(SDX,9999999)=""
- +3 SET SDBEGO=""
- SET SDCNT=0
- FOR
- SET SDCNT=$ORDER(^SC(+SC,"T"_$$DOW^XLFDT(SDDT,1),SDCNT))
- if 'SDCNT
- QUIT
- SET SDBEGO=SDBEGO_U_SDCNT
- +4 ;SD*5.3*726
- SET SDX=""
- FOR
- SET SDX=$ORDER(^SC(+SC,"T",SDX),-1)
- if 'SDX
- QUIT
- Begin DoDot:1
- +5 ;SD*5.3*674/SD*5.3*726
- IF '$DATA(^SC(+SC,"OST",SDX))!(($GET(^SC(+SC,"T"_$$DOW^XLFDT(SDX,1),9999999,1))'="")&(SDBEGO="^9999999"!(SDBEGO[SDX)))
- SET SDBEG=$GET(^SC(+SC,"T",SDX,0),SDX)
- SET SDDOW($$DOW^XLFDT(SDBEG,1),SDBEG)=""
- End DoDot:1
- +6 ;Successful check, Quit 0
- IF $ORDER(SDDOW(SDY,(SDDT+1)),-1)
- QUIT 0
- +7 ;Chec failed, Quit 1
- QUIT 1
- +8 ;
- 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