BSDX07A ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
APPOVB(BSDXY,SDCL,NSDT,BSDXRES) ; RPC - BSDX OVERBOOK - CHECK FOR OVERBOOK FOR GIVEN CLINIC, DATE, AND RESOURCE
; .BSDXY = returned pointer to OVERBOOK data
; SDCL = clinic code - pointer to Hospital Location file ^SC
; NSDT = date/time of new appointment
; BSDXRES = resource to check for overbook
N %DT,AP,BSDXI,OB,OBC,OBCNT,OBMAX,SDCLSL,SDT,X,Y
; SDTD = new schedule Date only in FM format
; SDT = loop value for $o through schedules
; SDTE = end of loop schedule
; NSDT = new appointment schedule Date/Time will be converted to FM format
D ^XBKVAR S X="ERROR^BSDX07A",@^%ZOSF("TRAP")
S BSDXI=0
K ^BSDXTMP($J)
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="T00020ERRORID"_$C(30)
;check for valid Hospital location
I '+SDCL D ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.") Q
I '$D(^SC(SDCL,0)) D ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.") Q
;check for valid resource ID
I '+BSDXRES D ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.") Q
I '$D(^BSDXRES(BSDXRES,0)) D ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.") Q
;check for valid DATE/TIME
S %DT="T"
S X=NSDT
D ^%DT ; GET FM FORMAT FOR APPOINTMENT DATE/TIME
S NSDT=Y
I NSDT=-1 D ERR1("Invalid Appointment Date.") Q
S SDTD=$P(NSDT,".")
; data header
; OVERBOOK 0=not overbooked; 1=overbooked
S ^BSDXTMP($J,0)="T00020OVERBOOK"_$C(30)
;get allowed number of overbookings for clinic
S SDCLSL=$G(^SC(SDCL,"SL"))
S OBMAX=$P(SDCLSL,U,7)
;loop thru schedule
; OBC(<appt time>,<appt end time>)=overlap counter starting at 0
K OBC ;overbook counter array
S SDT=(SDTD-1)_"."_235959
F S SDT=$O(^SC(SDCL,"S",SDT)) Q:(SDT'>0) Q:($P(SDT,".")'=SDTD) D
. S AP=0
. F S AP=$O(^SC(SDCL,"S",SDT,1,AP)) Q:(AP'>0) D
. . S DFN=$P(^SC(SDCL,"S",SDT,1,AP,0),U,1)
. . S SDCLRES=$$BSDXAP(SDT,DFN)
. . ;if resource for this appointment is passed in resource
. . I SDCLRES=BSDXRES D
. . . ;S SDCLN=^SC(SDCL,"S",SDT,1,AP,1)
. . . S SDCLN=$G(^SC(SDCL,"S",SDT,1,AP,0))
. . . ;determine end of appointment
. . . S SDTE=$$FMADD^XLFDT(SDT,,,$P(SDCLN,U,2))
. . . D CKOB(SDT,SDTE,.OBC)
S OBCNT=$$CNTOB(.OBC,BSDXRES)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$S(OBCNT<OBMAX:"YES",1:"NO")
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
;find appointment in BSDX APPOINTMENT file
BSDXAP(BSDXSDT,DFN) ;
N BSDXAPN,BSDXRES,ID
S BSDXRES=0
S ID=0
F S ID=$O(^BSDXAPPT("B",BSDXSDT,ID)) Q:ID'>0 Q:BSDXRES'=0 D
. S BSDXAPN=$G(^BSDXAPPT(ID,0))
. I $P(BSDXAPN,U,5)=DFN S BSDXRES=$P(BSDXAPN,U,7)
Q BSDXRES
;
;check if appointment start/stop is in range of an existing appointment
CKOB(START,STOP,OBC) ;called internally
; START = appointment start date/time in FM format
; STOP = appointment stop date/time in FM format
; .OBC = Overbook Array as defined above
N B,E,OB,OBF
S OBF=0
S B=""
F S B=$O(OBC(B)) Q:B'>0 D
. S E="" F S E=$O(OBC(B,E),1,OB) Q:E'>0 D
. . S OBF=(($P(START,".",2)>=$P(B,".",2))&($P(START,".",2)<=$P(E,".",2)))!(($P(STOP,".",2)>=$P(B,".",2))&($P(STOP,".",2)<=$P(E,".",2)))
. . I OBF S OBC($S($P(START,".",2)>=$P(B,".",2):B,1:START),$S($P(STOP,".",2)<=$P(E,".",2):E,1:STOP))=(OB+1) Q
I 'OBF S OBC(START,STOP)=1
;
Q
;
;count overbookings
CNTOB(OBC,BSDXRES) ;called internally
N AB,ABF,ABN,CNT,OB,SLOTS,START,STOP
S CNT=0
S START="" F S START=$O(OBC(START)) Q:START="" D
. S STOP="" F S STOP=$O(OBC(START,STOP),1,OB) Q:STOP="" Q:OB=0 D
. . S SLOTS=0
. . ;find access block
. . S AB="" F S AB=$O(^BSDXAB("B",BSDXRES,AB)) Q:AB'>0 D
. . . S ABN=^BSDXAB(AB,0)
. . . S ABF=((START>=$P(ABN,U,2))&(START<=$P(ABN,U,3)))!((STOP>=$P(ABN,U,2))&(STOP<=$P(ABN,U,3)))
. . . I ABF D
. . . . S SLOTS=$P(ABN,U,4)
. . . . S OB=OB-SLOTS
. . . . S:OB<0 OB=0
. . . . S CNT=CNT+OB
. . . . Q ;quit find access block loop
. . I 'ABF D ;if access block not found, appointments are overbook
. . . S CNT=CNT+OB
Q CNT
;
ERROR ;
D ERR1("RPMS Error")
Q
;
ERR1(BSDXERR) ;Error processing
I +BSDXERR S BSDXERR=ERRNO+134234112 ;vbObjectError
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
BSDX07A ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
APPOVB(BSDXY,SDCL,NSDT,BSDXRES) ; RPC - BSDX OVERBOOK - CHECK FOR OVERBOOK FOR GIVEN CLINIC, DATE, AND RESOURCE
+1 ; .BSDXY = returned pointer to OVERBOOK data
+2 ; SDCL = clinic code - pointer to Hospital Location file ^SC
+3 ; NSDT = date/time of new appointment
+4 ; BSDXRES = resource to check for overbook
+5 NEW %DT,AP,BSDXI,OB,OBC,OBCNT,OBMAX,SDCLSL,SDT,X,Y
+6 ; SDTD = new schedule Date only in FM format
+7 ; SDT = loop value for $o through schedules
+8 ; SDTE = end of loop schedule
+9 ; NSDT = new appointment schedule Date/Time will be converted to FM format
+10 DO ^XBKVAR
SET X="ERROR^BSDX07A"
SET @^%ZOSF("TRAP")
+11 SET BSDXI=0
+12 KILL ^BSDXTMP($JOB)
+13 SET BSDXY="^BSDXTMP("_$JOB_")"
+14 SET ^BSDXTMP($JOB,0)="T00020ERRORID"_$CHAR(30)
+15 ;check for valid Hospital location
+16 IF '+SDCL
DO ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.")
QUIT
+17 IF '$DATA(^SC(SDCL,0))
DO ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.")
QUIT
+18 ;check for valid resource ID
+19 IF '+BSDXRES
DO ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.")
QUIT
+20 IF '$DATA(^BSDXRES(BSDXRES,0))
DO ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.")
QUIT
+21 ;check for valid DATE/TIME
+22 SET %DT="T"
+23 SET X=NSDT
+24 ; GET FM FORMAT FOR APPOINTMENT DATE/TIME
DO ^%DT
+25 SET NSDT=Y
+26 IF NSDT=-1
DO ERR1("Invalid Appointment Date.")
QUIT
+27 SET SDTD=$PIECE(NSDT,".")
+28 ; data header
+29 ; OVERBOOK 0=not overbooked; 1=overbooked
+30 SET ^BSDXTMP($JOB,0)="T00020OVERBOOK"_$CHAR(30)
+31 ;get allowed number of overbookings for clinic
+32 SET SDCLSL=$GET(^SC(SDCL,"SL"))
+33 SET OBMAX=$PIECE(SDCLSL,U,7)
+34 ;loop thru schedule
+35 ; OBC(<appt time>,<appt end time>)=overlap counter starting at 0
+36 ;overbook counter array
KILL OBC
+37 SET SDT=(SDTD-1)_"."_235959
+38 FOR
SET SDT=$ORDER(^SC(SDCL,"S",SDT))
IF (SDT'>0)
QUIT
IF ($PIECE(SDT,".")'=SDTD)
QUIT
Begin DoDot:1
+39 SET AP=0
+40 FOR
SET AP=$ORDER(^SC(SDCL,"S",SDT,1,AP))
IF (AP'>0)
QUIT
Begin DoDot:2
+41 SET DFN=$PIECE(^SC(SDCL,"S",SDT,1,AP,0),U,1)
+42 SET SDCLRES=$$BSDXAP(SDT,DFN)
+43 ;if resource for this appointment is passed in resource
+44 IF SDCLRES=BSDXRES
Begin DoDot:3
+45 ;S SDCLN=^SC(SDCL,"S",SDT,1,AP,1)
+46 SET SDCLN=$GET(^SC(SDCL,"S",SDT,1,AP,0))
+47 ;determine end of appointment
+48 SET SDTE=$$FMADD^XLFDT(SDT,,,$PIECE(SDCLN,U,2))
+49 DO CKOB(SDT,SDTE,.OBC)
End DoDot:3
End DoDot:2
End DoDot:1
+50 SET OBCNT=$$CNTOB(.OBC,BSDXRES)
+51 SET BSDXI=BSDXI+1
+52 SET ^BSDXTMP($JOB,BSDXI)=$SELECT(OBCNT<OBMAX:"YES",1:"NO")
+53 SET BSDXI=BSDXI+1
+54 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+55 SET BSDXI=BSDXI+1
+56 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+57 QUIT
+58 ;
+59 ;find appointment in BSDX APPOINTMENT file
BSDXAP(BSDXSDT,DFN) ;
+1 NEW BSDXAPN,BSDXRES,ID
+2 SET BSDXRES=0
+3 SET ID=0
+4 FOR
SET ID=$ORDER(^BSDXAPPT("B",BSDXSDT,ID))
IF ID'>0
QUIT
IF BSDXRES'=0
QUIT
Begin DoDot:1
+5 SET BSDXAPN=$GET(^BSDXAPPT(ID,0))
+6 IF $PIECE(BSDXAPN,U,5)=DFN
SET BSDXRES=$PIECE(BSDXAPN,U,7)
End DoDot:1
+7 QUIT BSDXRES
+8 ;
+9 ;check if appointment start/stop is in range of an existing appointment
CKOB(START,STOP,OBC) ;called internally
+1 ; START = appointment start date/time in FM format
+2 ; STOP = appointment stop date/time in FM format
+3 ; .OBC = Overbook Array as defined above
+4 NEW B,E,OB,OBF
+5 SET OBF=0
+6 SET B=""
+7 FOR
SET B=$ORDER(OBC(B))
IF B'>0
QUIT
Begin DoDot:1
+8 SET E=""
FOR
SET E=$ORDER(OBC(B,E),1,OB)
IF E'>0
QUIT
Begin DoDot:2
+9 SET OBF=(($PIECE(START,".",2)>=$PIECE(B,".",2))&($PIECE(START,".",2)<=$PIECE(E,".",2)))!(($PIECE(STOP,".",2)>=$PIECE(B,".",2))&($PIECE(STOP,".",2)<=$PIECE(E,".",2)))
+10 IF OBF
SET OBC($SELECT($PIECE(START,".",2)>=$PIECE(B,".",2):B,1:START),$SELECT($PIECE(STOP,".",2)<=$PIECE(E,".",2):E,1:STOP))=(OB+1)
QUIT
End DoDot:2
End DoDot:1
+11 IF 'OBF
SET OBC(START,STOP)=1
+12 ;
+13 QUIT
+14 ;
+15 ;count overbookings
CNTOB(OBC,BSDXRES) ;called internally
+1 NEW AB,ABF,ABN,CNT,OB,SLOTS,START,STOP
+2 SET CNT=0
+3 SET START=""
FOR
SET START=$ORDER(OBC(START))
IF START=""
QUIT
Begin DoDot:1
+4 SET STOP=""
FOR
SET STOP=$ORDER(OBC(START,STOP),1,OB)
IF STOP=""
QUIT
IF OB=0
QUIT
Begin DoDot:2
+5 SET SLOTS=0
+6 ;find access block
+7 SET AB=""
FOR
SET AB=$ORDER(^BSDXAB("B",BSDXRES,AB))
IF AB'>0
QUIT
Begin DoDot:3
+8 SET ABN=^BSDXAB(AB,0)
+9 SET ABF=((START>=$PIECE(ABN,U,2))&(START<=$PIECE(ABN,U,3)))!((STOP>=$PIECE(ABN,U,2))&(STOP<=$PIECE(ABN,U,3)))
+10 IF ABF
Begin DoDot:4
+11 SET SLOTS=$PIECE(ABN,U,4)
+12 SET OB=OB-SLOTS
+13 IF OB<0
SET OB=0
+14 SET CNT=CNT+OB
+15 ;quit find access block loop
QUIT
End DoDot:4
End DoDot:3
+16 ;if access block not found, appointments are overbook
IF 'ABF
Begin DoDot:3
+17 SET CNT=CNT+OB
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT CNT
+19 ;
ERROR ;
+1 DO ERR1("RPMS Error")
+2 QUIT
+3 ;
ERR1(BSDXERR) ;Error processing
+1 ;vbObjectError
IF +BSDXERR
SET BSDXERR=ERRNO+134234112
+2 SET BSDXI=BSDXI+1
+3 SET ^BSDXTMP($JOB,BSDXI)=BSDXERR_$CHAR(30)
+4 SET BSDXI=BSDXI+1
+5 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+6 QUIT
