SDNEXT ;ALB/TMP - FIND NEXT AVAILABLE APPOINTMENT FOR A CLINIC ; 18 APR 86
;;5.3;Scheduling;**41,45,165,549**;AUG 13, 1993;Build 2
;
S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
1 S SDNEXT="",SDCT=0 G RD^SDMULT
DT 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 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 SDMAX=+Y
G OVR^SDMULT0
;
NEW ;entry point to be use for next available appt. 3/29/96
K VAUTT,VAUTC,SCUP
N SCOKNULL
S SCOKNULL=1
S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
S SDNEXT="",SDCT=0
S VAUTNA="" ;don't allow all to be selected
S VAUTCA="" ;allow any clinic to be selected
S VAUTD=1 ;all divisions
D CLINIC^SCRPU1 ;prompt for clinics (none,one,many)
Q:$D(SCUP) ; "^" SELECTED
D PRMTT^SCRPU1 ;prompt for team (none,one,many)
Q:('$D(VAUTT))&('$D(VAUTC))
Q:$D(SCUP) ; "^" SELECTED
S APPTL=$$LENGTH()
Q:APPTL<0
S FIRST="First date to check for 1st available appointments: "
S SECOND="Latest date to check for available appointments: "
S RANG=$$DTRANG^SCRPU2(FIRST,SECOND)
I RANG=-1 D CLEAN,EXIT Q
I $D(VAUTT) D GETCLN(.VAUTT,.VAUTC)
;all clinics selected & position assoc clinics in VAUTC(ien)=clinic name
D DRIVE(.VAUTC,APPTL,RANG)
D CLEAN,EXIT
Q
EXIT ;
K VAUTD,VAUTNA,VAUTT,VAUTC,FIRST,SECOND,RANG,APPTL,SCPCMM,SDNEXT,SDCT
K VAUTCA,SCUP
Q
;
LENGTH() ;
;prompt for appointment length
N LEN
ST S DIR(0)="N"
S DIR("A")="Appointment Length Needed "
D ^DIR
I Y=""!(X="^")!(X="") S LEN=-1 G EX
S LEN=X
EX K DIR,Y,X
Q LEN
;
GETCLN(TEAM,CLINIC) ;add assoc. clinics for teams to clinic array
;TEAM - team array
;CLINIC - clinic array
;
N TM,LIST,ERR,OKAY
S TM=0,LIST="TPLIST",ERR="ERR1"
F S TM=$O(TEAM(TM)) Q:TM=""!(TM'?.N) D
.K @LIST,@ERR
.S OKAY=$$TPTM^SCAPMC24(TM,"","","",LIST,ERR)
.;@LIST contains all positions for team TM
.I $G(@LIST@(0))>0 D ADDCL(.CLINIC,LIST)
Q
;
ADDCL(CLINIC,PTLIST) ;add team's associated clinics to clinic list
;CLINIC - array of selected clinics
;PTLIST - array of all positions for a selected team
N CNAME,CIEN,TPNODE,TPIEN,NODE,EN
S EN=0
F S EN=$O(@PTLIST@(EN)) Q:EN=""!(EN'?.N) D
.S NODE=$G(@PTLIST@(EN))
.S TPIEN=+$P(NODE,"^") ;team position ien
.S TPNODE=$G(^SCTM(404.57,TPIEN,0))
.Q:TPNODE=""
.Q:'$D(^SCTM(404.57,TPIEN,5,0)) ;no associated clinics
.S SDA=0 ;SD/549 change logic to pull from new multiple field
.F S SDA=$O(^SCTM(404.57,TPIEN,5,SDA)) Q:'SDA D
..Q:'$D(^SCTM(404.57,TPIEN,5,SDA,0))
..S CIEN=+$G(^SCTM(404.57,TPIEN,5,SDA,0))
..Q:CIEN=0 ;no associated clinic
..S CNAME=$P($G(^SC(CIEN,0)),"^") ;clinic name
..S CLINIC(CIEN)=CNAME
K SDA
Q
;
DRIVE(CLINICA,LEN,BEGEND) ;driver
;CLINICA - clinic array
;LEN - appt. length wanted
;BEGEND - begin date ^ end date
;
N CIEN,COUNT,CONT,FND
S SDNEXT="",SDCT=1
S CIEN=0,STOP=0,COUNT=1
F S CIEN=$O(CLINICA(CIEN)) Q:CIEN=""!(CIEN'?.N)!(STOP) D
.S SDNEXT=""
.S SDSTRTDT=$P(BEGEND,"^")
.S SDMAX=$P(BEGEND,"^",2)
.S SDC(COUNT)=CIEN,SDC1(CIEN)=$G(CLINICA(CIEN))_"^"_LEN
.S SDCT=COUNT,SC=CIEN,FND=0
.D OVR^SDMULT0 S CONT=$$CONMA(CIEN,$S($O(CLINICA(CIEN)):0,1:1))
.K SDC(COUNT),SDC1(CIEN)
.;S CONT=$$CONMA(CIEN)
.Q:STOP
I $G(CONT)="M" D CLEAN S:$$ONE(.CLINICA) SDCLN=$O(CLINICA(0)) G ^SDM
Q
CLEAN ;
D END^SDMULT0
K SDSTRTDT,SDNEXT,SDMAX,SDC,SDCT,SDC1,SDL,STOP,SDAPP,SDPCMM,SDCLN,FND
K SCPCC,SDPCM1,SC
Q
;
ONE(CLNA) ;one clinic selected? 1 or 0
N CNT,FIRST,RET,STP
S (CNT,STP)=0,RET=1
F S CNT=$O(CLNA(CNT)) Q:CNT=""!(STP) D
.I $D(FIRST) S STOP=1,RET=0
.I '$D(FIRST) S FIRST=1
Q RET
;
CONMA(CIEN,CONT) ;continue to view, exit or make appointment
;
PRT ;
S CONT=$G(CONT)
I $G(SDPCMM(CIEN))'>0&('CONT) Q -1
W !,"'^' TO EXIT"_$S('CONT:", 'C' TO CONTINUE",1:"")_" OR 'M' TO GOTO MAKE APPOINTMENT: "_$S(CONT:"^",1:"CONTINUE")_"//" R X:DTIME
I '$T!(X="^") S STOP=1,X=-1 G EX2
I (X'="^")&(X'="C")&(X'="M")&(X'="") G PRT
I CONT&(X="C") G PRT
I X="M" S STOP=1
I X="" S X="C"
EX2 Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDNEXT 4536 printed Nov 22, 2024@18:08:46 Page 2
SDNEXT ;ALB/TMP - FIND NEXT AVAILABLE APPOINTMENT FOR A CLINIC ; 18 APR 86
+1 ;;5.3;Scheduling;**41,45,165,549**;AUG 13, 1993;Build 2
+2 ;
+3 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
1 SET SDNEXT=""
SET SDCT=0
GOTO RD^SDMULT
DT 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 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 SDMAX=+Y
+3 GOTO OVR^SDMULT0
+4 ;
NEW ;entry point to be use for next available appt. 3/29/96
+1 KILL VAUTT,VAUTC,SCUP
+2 NEW SCOKNULL
+3 SET SCOKNULL=1
+4 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
+5 SET SDNEXT=""
SET SDCT=0
+6 ;don't allow all to be selected
SET VAUTNA=""
+7 ;allow any clinic to be selected
SET VAUTCA=""
+8 ;all divisions
SET VAUTD=1
+9 ;prompt for clinics (none,one,many)
DO CLINIC^SCRPU1
+10 ; "^" SELECTED
if $DATA(SCUP)
QUIT
+11 ;prompt for team (none,one,many)
DO PRMTT^SCRPU1
+12 if ('$DATA(VAUTT))&('$DATA(VAUTC))
QUIT
+13 ; "^" SELECTED
if $DATA(SCUP)
QUIT
+14 SET APPTL=$$LENGTH()
+15 if APPTL<0
QUIT
+16 SET FIRST="First date to check for 1st available appointments: "
+17 SET SECOND="Latest date to check for available appointments: "
+18 SET RANG=$$DTRANG^SCRPU2(FIRST,SECOND)
+19 IF RANG=-1
DO CLEAN
DO EXIT
QUIT
+20 IF $DATA(VAUTT)
DO GETCLN(.VAUTT,.VAUTC)
+21 ;all clinics selected & position assoc clinics in VAUTC(ien)=clinic name
+22 DO DRIVE(.VAUTC,APPTL,RANG)
+23 DO CLEAN
DO EXIT
+24 QUIT
EXIT ;
+1 KILL VAUTD,VAUTNA,VAUTT,VAUTC,FIRST,SECOND,RANG,APPTL,SCPCMM,SDNEXT,SDCT
+2 KILL VAUTCA,SCUP
+3 QUIT
+4 ;
LENGTH() ;
+1 ;prompt for appointment length
+2 NEW LEN
ST SET DIR(0)="N"
+1 SET DIR("A")="Appointment Length Needed "
+2 DO ^DIR
+3 IF Y=""!(X="^")!(X="")
SET LEN=-1
GOTO EX
+4 SET LEN=X
EX KILL DIR,Y,X
+1 QUIT LEN
+2 ;
GETCLN(TEAM,CLINIC) ;add assoc. clinics for teams to clinic array
+1 ;TEAM - team array
+2 ;CLINIC - clinic array
+3 ;
+4 NEW TM,LIST,ERR,OKAY
+5 SET TM=0
SET LIST="TPLIST"
SET ERR="ERR1"
+6 FOR
SET TM=$ORDER(TEAM(TM))
if TM=""!(TM'?.N)
QUIT
Begin DoDot:1
+7 KILL @LIST,@ERR
+8 SET OKAY=$$TPTM^SCAPMC24(TM,"","","",LIST,ERR)
+9 ;@LIST contains all positions for team TM
+10 IF $GET(@LIST@(0))>0
DO ADDCL(.CLINIC,LIST)
End DoDot:1
+11 QUIT
+12 ;
ADDCL(CLINIC,PTLIST) ;add team's associated clinics to clinic list
+1 ;CLINIC - array of selected clinics
+2 ;PTLIST - array of all positions for a selected team
+3 NEW CNAME,CIEN,TPNODE,TPIEN,NODE,EN
+4 SET EN=0
+5 FOR
SET EN=$ORDER(@PTLIST@(EN))
if EN=""!(EN'?.N)
QUIT
Begin DoDot:1
+6 SET NODE=$GET(@PTLIST@(EN))
+7 ;team position ien
SET TPIEN=+$PIECE(NODE,"^")
+8 SET TPNODE=$GET(^SCTM(404.57,TPIEN,0))
+9 if TPNODE=""
QUIT
+10 ;no associated clinics
if '$DATA(^SCTM(404.57,TPIEN,5,0))
QUIT
+11 ;SD/549 change logic to pull from new multiple field
SET SDA=0
+12 FOR
SET SDA=$ORDER(^SCTM(404.57,TPIEN,5,SDA))
if 'SDA
QUIT
Begin DoDot:2
+13 if '$DATA(^SCTM(404.57,TPIEN,5,SDA,0))
QUIT
+14 SET CIEN=+$GET(^SCTM(404.57,TPIEN,5,SDA,0))
+15 ;no associated clinic
if CIEN=0
QUIT
+16 ;clinic name
SET CNAME=$PIECE($GET(^SC(CIEN,0)),"^")
+17 SET CLINIC(CIEN)=CNAME
End DoDot:2
End DoDot:1
+18 KILL SDA
+19 QUIT
+20 ;
DRIVE(CLINICA,LEN,BEGEND) ;driver
+1 ;CLINICA - clinic array
+2 ;LEN - appt. length wanted
+3 ;BEGEND - begin date ^ end date
+4 ;
+5 NEW CIEN,COUNT,CONT,FND
+6 SET SDNEXT=""
SET SDCT=1
+7 SET CIEN=0
SET STOP=0
SET COUNT=1
+8 FOR
SET CIEN=$ORDER(CLINICA(CIEN))
if CIEN=""!(CIEN'?.N)!(STOP)
QUIT
Begin DoDot:1
+9 SET SDNEXT=""
+10 SET SDSTRTDT=$PIECE(BEGEND,"^")
+11 SET SDMAX=$PIECE(BEGEND,"^",2)
+12 SET SDC(COUNT)=CIEN
SET SDC1(CIEN)=$GET(CLINICA(CIEN))_"^"_LEN
+13 SET SDCT=COUNT
SET SC=CIEN
SET FND=0
+14 DO OVR^SDMULT0
SET CONT=$$CONMA(CIEN,$SELECT($ORDER(CLINICA(CIEN)):0,1:1))
+15 KILL SDC(COUNT),SDC1(CIEN)
+16 ;S CONT=$$CONMA(CIEN)
+17 if STOP
QUIT
End DoDot:1
+18 IF $GET(CONT)="M"
DO CLEAN
if $$ONE(.CLINICA)
SET SDCLN=$ORDER(CLINICA(0))
GOTO ^SDM
+19 QUIT
CLEAN ;
+1 DO END^SDMULT0
+2 KILL SDSTRTDT,SDNEXT,SDMAX,SDC,SDCT,SDC1,SDL,STOP,SDAPP,SDPCMM,SDCLN,FND
+3 KILL SCPCC,SDPCM1,SC
+4 QUIT
+5 ;
ONE(CLNA) ;one clinic selected? 1 or 0
+1 NEW CNT,FIRST,RET,STP
+2 SET (CNT,STP)=0
SET RET=1
+3 FOR
SET CNT=$ORDER(CLNA(CNT))
if CNT=""!(STP)
QUIT
Begin DoDot:1
+4 IF $DATA(FIRST)
SET STOP=1
SET RET=0
+5 IF '$DATA(FIRST)
SET FIRST=1
End DoDot:1
+6 QUIT RET
+7 ;
CONMA(CIEN,CONT) ;continue to view, exit or make appointment
+1 ;
PRT ;
+1 SET CONT=$GET(CONT)
+2 IF $GET(SDPCMM(CIEN))'>0&('CONT)
QUIT -1
+3 WRITE !,"'^' TO EXIT"_$SELECT('CONT:", 'C' TO CONTINUE",1:"")_" OR 'M' TO GOTO MAKE APPOINTMENT: "_$SELECT(CONT:"^",1:"CONTINUE")_"//"
READ X:DTIME
+4 IF '$TEST!(X="^")
SET STOP=1
SET X=-1
GOTO EX2
+5 IF (X'="^")&(X'="C")&(X'="M")&(X'="")
GOTO PRT
+6 IF CONT&(X="C")
GOTO PRT
+7 IF X="M"
SET STOP=1
+8 IF X=""
SET X="C"
EX2 QUIT X
