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

BSDX07A.m

Go to the documentation of this file. 
  1. BSDX07A ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ; 
  1.  ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
  1.  ;
  1. APPOVB(BSDXY,SDCL,NSDT,BSDXRES) ; RPC - BSDX OVERBOOK - CHECK FOR OVERBOOK FOR GIVEN CLINIC, DATE, AND RESOURCE
  1.  ;  .BSDXY   = returned pointer to OVERBOOK data
  1.  ;   SDCL    = clinic code - pointer to Hospital Location file ^SC
  1.  ;   NSDT    = date/time of new appointment
  1.  ;   BSDXRES = resource to check for overbook
  1.  N %DT,AP,BSDXI,OB,OBC,OBCNT,OBMAX,SDCLSL,SDT,X,Y
  1.  ; SDTD  = new schedule Date only in FM format
  1.  ; SDT   = loop value for $o through schedules
  1.  ; SDTE  = end of loop schedule
  1.  ; NSDT  = new appointment schedule Date/Time will be converted to FM format
  1.  D ^XBKVAR S X="ERROR^BSDX07A",@^%ZOSF("TRAP")
  1.  S BSDXI=0
  1.  K ^BSDXTMP($J)
  1.  S BSDXY="^BSDXTMP("_$J_")"
  1.  S ^BSDXTMP($J,0)="T00020ERRORID"_$C(30)
  1.  ;check for valid Hospital location
  1.  I '+SDCL D ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.") Q
  1.  I '$D(^SC(SDCL,0)) D ERR1("Invalid Clinic ID - Cannot determine if Overbook is allowed.") Q
  1.  ;check for valid resource ID
  1.  I '+BSDXRES D ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.") Q
  1.  I '$D(^BSDXRES(BSDXRES,0)) D ERR1("Invalid Resource ID - Cannot determine if Overbook is allowed.") Q
  1.  ;check for valid DATE/TIME
  1.  S %DT="T"
  1.  S X=NSDT
  1.  D ^%DT   ; GET FM FORMAT FOR APPOINTMENT DATE/TIME
  1.  S NSDT=Y
  1.  I NSDT=-1 D ERR1("Invalid Appointment Date.") Q
  1.  S SDTD=$P(NSDT,".")
  1.  ; data header
  1.  ; OVERBOOK  0=not overbooked; 1=overbooked
  1.  S ^BSDXTMP($J,0)="T00020OVERBOOK"_$C(30)
  1.  ;get allowed number of overbookings for clinic
  1.  S SDCLSL=$G(^SC(SDCL,"SL"))
  1.  S OBMAX=$P(SDCLSL,U,7)
  1.  ;loop thru schedule
  1.  ; OBC(<appt time>,<appt end time>)=overlap counter starting at 0
  1.  K OBC  ;overbook counter array
  1.  S SDT=(SDTD-1)_"."_235959
  1.  F  S SDT=$O(^SC(SDCL,"S",SDT)) Q:(SDT'>0)  Q:($P(SDT,".")'=SDTD)  D
  1.  . S AP=0
  1.  . F  S AP=$O(^SC(SDCL,"S",SDT,1,AP)) Q:(AP'>0)  D
  1.  . . S DFN=$P(^SC(SDCL,"S",SDT,1,AP,0),U,1)
  1.  . . S SDCLRES=$$BSDXAP(SDT,DFN)
  1.  . . ;if resource for this appointment is passed in resource
  1.  . . I SDCLRES=BSDXRES D
  1.  . . . ;S SDCLN=^SC(SDCL,"S",SDT,1,AP,1)
  1.  . . . S SDCLN=$G(^SC(SDCL,"S",SDT,1,AP,0))
  1.  . . . ;determine end of appointment
  1.  . . . S SDTE=$$FMADD^XLFDT(SDT,,,$P(SDCLN,U,2))
  1.  . . . D CKOB(SDT,SDTE,.OBC)
  1.  S OBCNT=$$CNTOB(.OBC,BSDXRES)
  1.  S BSDXI=BSDXI+1
  1.  S ^BSDXTMP($J,BSDXI)=$S(OBCNT<OBMAX:"YES",1:"NO")
  1.  S BSDXI=BSDXI+1
  1.  S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  S BSDXI=BSDXI+1
  1.  S ^BSDXTMP($J,BSDXI)=$C(31)
  1.  Q
  1.  ;
  1.  ;find appointment in BSDX APPOINTMENT file
  1. BSDXAP(BSDXSDT,DFN) ;
  1.  N BSDXAPN,BSDXRES,ID
  1.  S BSDXRES=0
  1.  S ID=0
  1.  F  S ID=$O(^BSDXAPPT("B",BSDXSDT,ID)) Q:ID'>0  Q:BSDXRES'=0  D
  1.  . S BSDXAPN=$G(^BSDXAPPT(ID,0))
  1.  . I $P(BSDXAPN,U,5)=DFN S BSDXRES=$P(BSDXAPN,U,7)
  1.  Q BSDXRES
  1.  ;
  1.  ;check if appointment start/stop is in range of an existing appointment
  1. CKOB(START,STOP,OBC) ;called internally
  1.  ;  START   = appointment start date/time in FM format
  1.  ;  STOP    = appointment stop date/time in FM format
  1.  ; .OBC     = Overbook Array as defined above
  1.  N B,E,OB,OBF
  1.  S OBF=0
  1.  S B=""
  1.  F  S B=$O(OBC(B)) Q:B'>0  D
  1.  . S E="" F  S E=$O(OBC(B,E),1,OB) Q:E'>0  D
  1.  . . 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)))
  1.  . . 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
  1.  I 'OBF S OBC(START,STOP)=1
  1.  ;
  1.  Q
  1.  ;
  1.  ;count overbookings
  1. CNTOB(OBC,BSDXRES) ;called internally
  1.  N AB,ABF,ABN,CNT,OB,SLOTS,START,STOP
  1.  S CNT=0
  1.  S START="" F  S START=$O(OBC(START)) Q:START=""  D
  1.  . S STOP="" F  S STOP=$O(OBC(START,STOP),1,OB) Q:STOP=""  Q:OB=0  D
  1.  . . S SLOTS=0
  1.  . . ;find access block
  1.  . . S AB="" F  S AB=$O(^BSDXAB("B",BSDXRES,AB)) Q:AB'>0  D
  1.  . . . S ABN=^BSDXAB(AB,0)
  1.  . . . S ABF=((START>=$P(ABN,U,2))&(START<=$P(ABN,U,3)))!((STOP>=$P(ABN,U,2))&(STOP<=$P(ABN,U,3)))
  1.  . . . I ABF D
  1.  . . . . S SLOTS=$P(ABN,U,4)
  1.  . . . . S OB=OB-SLOTS
  1.  . . . . S:OB<0 OB=0
  1.  . . . . S CNT=CNT+OB
  1.  . . . . Q  ;quit find access block loop
  1.  . . I 'ABF D  ;if access block not found, appointments are overbook
  1.  . . . S CNT=CNT+OB
  1.  Q CNT
  1.  ;
  1. ERROR ;
  1.  D ERR1("RPMS Error")
  1.  Q
  1.  ;
  1. ERR1(BSDXERR) ;Error processing
  1.  I +BSDXERR S BSDXERR=ERRNO+134234112 ;vbObjectError
  1.  S BSDXI=BSDXI+1
  1.  S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
  1.  S BSDXI=BSDXI+1
  1.  S ^BSDXTMP($J,BSDXI)=$C(31)
  1.  Q