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

SDECUT1A.m

Go to the documentation of this file. 
  1. SDECUT1A ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
  1.  ;;5.3;Scheduling;**627,658**;Aug 13, 1993;Build 23
  1.  ;
  1.  Q
  1.  ;
  1. A(STA,SDCL,SDBEG,SDSI,SDCLS) ;get array of start times
  1.  N HR,HR1,MIN,NOD,OFFSET,SDAY,SDI,SDTDAY,SDTDONE,SDTAR
  1.  S SDTDONE=0
  1.  S SDTDAY=$$GETDAY^SDECUTL1($P(SDBEG,".",1))
  1.  S SDAY=$$FMADD^XLFDT(SDBEG,1) F  S SDAY=$O(^SC(SDCL,"T",SDAY),-1) Q:SDAY'>0  D  Q:+SDTDONE
  1.  .Q:$$GETDAY^SDECUTL1(SDAY)'=SDTDAY
  1.  .I SDAY'=$P(SDBEG,".",1),$D(^SC(SDCL,"ST",SDAY,9)) Q
  1.  .K SDTAR
  1.  .M SDTAR=^SC(SDCL,"T",SDAY)
  1.  .S SDTDONE=1
  1.  D @("A"_SDSI)
  1.  Q
  1. A1 ;
  1.  S SDI=0 F  S SDI=$O(SDTAR(2,SDI)) Q:SDI=""  D
  1.  .S OFFSET=""   ;alb/sat 658 initialize OFFSET for each iteration
  1.  .S NOD=SDTAR(2,SDI,0)
  1.  .S HR=$E($P(NOD,U,1),1,2)
  1.  .S MIN=$E($P(NOD,U,1),3,4)
  1.  .I +MIN'<0,+MIN<15 S OFFSET=+MIN
  1.  .I OFFSET="",+MIN'<15,+MIN<30 S OFFSET=(+MIN)-15
  1.  .I OFFSET="",+MIN'<30,+MIN<45 S OFFSET=(+MIN)-30
  1.  .I OFFSET="",+MIN'<45,+MIN'>59 S OFFSET=(+MIN)-45
  1.  .D B1(.STA,HR,OFFSET)
  1.  S HR1=""
  1.  S HR="" F  S HR=$O(STA(HR)) Q:HR=""  D
  1.  .I HR1="" S HR1=HR
  1.  .E  S:+HR<+HR1 HR1=HR
  1.  I SDCLS<(+HR1) D  ;fill in gaps
  1.  .S HR=HR1
  1.  .F  Q:SDCLS=+HR  D
  1.  ..S HR=(+HR)-1
  1.  ..S HR=$S($L(HR)=1:0_HR,1:HR)
  1.  ..D B1(.STA,HR,OFFSET)
  1.  Q
  1. B1(STA,HR,OFFSET) ;
  1.  N MIN
  1.  S MIN=15+OFFSET
  1.  S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=30+OFFSET
  1.  S STA(HR,6)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=45+OFFSET
  1.  S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=+OFFSET
  1.  S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  Q
  1. A2 ;
  1.  ;S OFFSET=""
  1.  S SDI=0 F  S SDI=$O(SDTAR(2,SDI)) Q:SDI=""  D
  1.  .S OFFSET=""   ;alb/sat 658 initialize OFFSET for each iteration
  1.  .S NOD=SDTAR(2,SDI,0)
  1.  .S HR=$E($P(NOD,U,1),1,2)
  1.  .S MIN=$E($P(NOD,U,1),3,4)
  1.  .I +MIN'<0,+MIN<15 S OFFSET=+MIN
  1.  .I OFFSET="",+MIN'<15,+MIN<30 S OFFSET=(+MIN)-15
  1.  .I OFFSET="",+MIN'<30,+MIN<45 S OFFSET=(+MIN)-30
  1.  .I OFFSET="",+MIN'<45,+MIN'>59 S OFFSET=(+MIN)-45
  1.  .D B2(.STA,HR,OFFSET)
  1.  S HR1=""
  1.  S HR="" F  S HR=$O(STA(HR)) Q:HR=""  D
  1.  .I HR1="" S HR1=HR
  1.  .E  S:+HR<+HR1 HR1=HR
  1.  I SDCLS<(+HR1) D  ;fill in gaps
  1.  .S HR=HR1
  1.  .F  Q:SDCLS=+HR  D
  1.  ..S HR=(+HR)-1
  1.  ..S HR=$S($L(HR)=1:0_HR,1:HR)
  1.  ..D B2(.STA,HR,OFFSET)
  1.  Q
  1. B2(STA,HR,OFFSET) ;
  1.  N MIN
  1.  S MIN=15+OFFSET
  1.  S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=30+OFFSET
  1.  S STA(HR,6)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=45+OFFSET
  1.  S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=+OFFSET
  1.  S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  Q
  1. A3 ;get array of start times
  1.  N HR,HR1,MIN,NOD,OFFSET,SDAY,SDI,SDTDAY,SDTDONE
  1.  S SDTDONE=0
  1.  S SDTDAY=$$GETDAY^SDECUTL1($P(SDBEG,".",1))
  1.  S SDAY=$$FMADD^XLFDT(SDBEG,1) F  S SDAY=$O(^SC(SDCL,"T",SDAY),-1) Q:SDAY'>0  D  Q:+SDTDONE
  1.  .Q:$$GETDAY^SDECUTL1(SDAY)'=SDTDAY
  1.  .I SDAY'=$P(SDBEG,".",1),$D(^SC(SDCL,"ST",SDAY,9)) Q
  1.  .K SDTAR
  1.  .M SDTAR=^SC(SDCL,"T",SDAY)
  1.  .S SDTDONE=1
  1.  ;S OFFSET=""
  1.  S SDI=0 F  S SDI=$O(SDTAR(2,SDI)) Q:SDI=""  D
  1.  .S OFFSET=""   ;alb/sat 658 initialize OFFSET for each iteration
  1.  .S NOD=SDTAR(2,SDI,0)
  1.  .S HR=$E($P(NOD,U,1),1,2)
  1.  .S MIN=$E($P(NOD,U,1),3,4)
  1.  .I +MIN'<0,+MIN<20 S OFFSET=+MIN
  1.  .I OFFSET="",+MIN'<20,+MIN<40 S OFFSET=(+MIN)-20   ; S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  .I OFFSET="",+MIN'<40,+MIN'>59 S OFFSET=(+MIN)-40 S STA(HR,2)=MIN_U_$S(MIN="00":"",$E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  .D B3(.STA,HR,OFFSET)
  1.  S HR1=""
  1.  S HR="" F  S HR=$O(STA(HR)) Q:HR=""  D
  1.  .I HR1="" S HR1=HR
  1.  .E  S:+HR<+HR1 HR1=HR
  1.  I SDCLS<(+HR1) D  ;fill in gaps
  1.  .S HR=HR1
  1.  .F  Q:SDCLS=+HR  D
  1.  ..S HR=(+HR)-1
  1.  ..S HR=$S($L(HR)=1:0_HR,1:HR)
  1.  ..D B3(.STA,HR,OFFSET)
  1.  Q
  1. B3(STA,HR,OFFSET) ;
  1.  N MIN
  1.  S MIN=20+OFFSET
  1.  S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=40+OFFSET
  1.  S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=+OFFSET
  1.  S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  Q
  1. A4 ;
  1.  ;S OFFSET=""
  1.  S SDI=0 F  S SDI=$O(SDTAR(2,SDI)) Q:SDI=""  D
  1.  .S OFFSET=""   ;alb/sat 658 initialize OFFSET for each iteration
  1.  .S NOD=SDTAR(2,SDI,0)
  1.  .S HR=$E($P(NOD,U,1),1,2)
  1.  .S MIN=$E($P(NOD,U,1),3,4)
  1.  .I +MIN'<0,+MIN<15 S OFFSET=+MIN
  1.  .I OFFSET="",+MIN'<15,+MIN<30 S OFFSET=(+MIN)-15
  1.  .I OFFSET="",+MIN'<30,+MIN<45 S OFFSET=(+MIN)-30
  1.  .I OFFSET="",+MIN'<45,+MIN'>59 S OFFSET=(+MIN)-45
  1.  .D B4(.STA,HR,OFFSET)
  1.  S HR1=""
  1.  S HR="" F  S HR=$O(STA(HR)) Q:HR=""  D
  1.  .I HR1="" S HR1=HR
  1.  .E  S:+HR<+HR1 HR1=HR
  1.  I SDCLS<(+HR1) D  ;fill in gaps
  1.  .S HR=HR1
  1.  .F  Q:SDCLS=+HR  D
  1.  ..S HR=(+HR)-1
  1.  ..S HR=$S($L(HR)=1:0_HR,1:HR)
  1.  ..D B4(.STA,HR,OFFSET)
  1.  Q
  1. B4(STA,HR,OFFSET) ;
  1.  N MIN
  1.  S MIN=15+OFFSET
  1.  S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=30+OFFSET
  1.  S STA(HR,6)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=45+OFFSET
  1.  S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=+OFFSET
  1.  S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  Q
  1. A6 ;
  1.  ;S OFFSET=""
  1.  S SDI=0 F  S SDI=$O(SDTAR(2,SDI)) Q:SDI=""  D
  1.  .S OFFSET=""   ;alb/sat 658 initialize OFFSET for each iteration
  1.  .S NOD=SDTAR(2,SDI,0)
  1.  .S HR=$E($P(NOD,U,1),1,2)
  1.  .S MIN=$E($P(NOD,U,1),3,4)
  1.  .I +MIN'<0,+MIN<10 S OFFSET=+MIN
  1.  .I OFFSET="",+MIN'<10,+MIN<20 S OFFSET=(+MIN)-10
  1.  .I OFFSET="",+MIN'<20,+MIN<30 S OFFSET=(+MIN)-20
  1.  .I OFFSET="",+MIN'<30,+MIN<40 S OFFSET=(+MIN)-30
  1.  .I OFFSET="",+MIN'<40,+MIN<50 S OFFSET=(+MIN)-40
  1.  .I OFFSET="",+MIN'<50,+MIN'>59 S OFFSET=(+MIN)-50
  1.  .D B6(.STA,HR,OFFSET)
  1.  S HR1=""
  1.  S HR="" F  S HR=$O(STA(HR)) Q:HR=""  D
  1.  .I HR1="" S HR1=HR
  1.  .E  S:+HR<+HR1 HR1=HR
  1.  I SDCLS<(+HR1) D  ;fill in gaps
  1.  .S HR=HR1
  1.  .F  Q:SDCLS=+HR  D
  1.  ..S HR=(+HR)-1
  1.  ..S HR=$S($L(HR)=1:0_HR,1:HR)
  1.  ..D B6(.STA,HR,OFFSET)
  1.  Q
  1. B6(STA,HR,OFFSET) ;
  1.  N MIN
  1.  S MIN=10+OFFSET
  1.  S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=20+OFFSET
  1.  S STA(HR,6)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=30+OFFSET
  1.  S STA(HR,8)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=40+OFFSET
  1.  S STA(HR,10)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=50+OFFSET
  1.  S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  S MIN=+OFFSET
  1.  S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
  1.  Q
  1. MAKE(SDBLKS,SDI,START,STOP,SLOT)  ;make block
  1.  N SDATAV,SDATUN
  1.  S SDATAV=$O(^SDEC(409.823,"B","AVAILABLE",0))
  1.  S SDATUN=$O(^SDEC(409.823,"B","UNAVAILABLE",0))
  1.  S SDI=SDI+1 S SDBLKS(SDI)=START_U_STOP_U_SLOT_U_$S(+SLOT:SDATAV,1:SDATUN)
  1.  Q
  1.  ;
  1. RESNB(SDAB,SDBLKS,SDCL,SDAY,SDRES)  ;create/update access blocks for 1 day
  1.  N SDI,SDJ,SDNOD,SDRESP
  1.  Q:'$D(SDBLKS)
  1.  Q:$G(SDAY)'?7N
  1.  S SDRESP=$G(SDRES)
  1.  ;delete all related access blocks
  1.  ;build new access blocks with calls to RESNB1
  1.  S SDI="" F  S SDI=$O(SDBLKS(SDI)) Q:SDI=""  D
  1.  .S SDNOD=SDBLKS(SDI)
  1.  .Q:$P($P(SDNOD,U,1),".",1)'=SDAY
  1.  .D RESNB1(SDAB,SDCL,$P(SDNOD,U,1),$P(SDNOD,U,2),$P(SDNOD,U,3),$P(SDNOD,U,4))
  1.  Q
  1.  ;
  1. RESNBD(SDCL,SDAY,SDRESP) ;delete access blocks for the day
  1.  Q
  1.  ;
  1. RESNB1(SDAB,SDCL,SDSTART,SDSTOP,SDSLOTS,SDAT,SDRES)  ;create/update 1 access block
  1.  ;INPUT:
  1.  ; SDAB    - global name for access blocks - "^TMP("_$J_",""SDEC"",""BLKS"")"
  1.  ; SDCL    - clinic ID pointer to HOSPITAL LOCATION file
  1.  ;           not used if SDRES is passed in
  1.  ; SDSTART - start time in FM format
  1.  ; SDSTOP  - stop time in FM format
  1.  ; SDSLOTS - number of slots
  1.  ; SDAT    - access type ID pointer to SDEC ACCESS TYPE file
  1.  ; SDRES   - resource ID pointer to SDEC RESOURCE file
  1.  ;           only update this resource if passed in
  1.  ;           calling routine needs to make sure SDRES belongs to the proper HOSPITAL LOCATION (sdcl)
  1.  S SDRES=$G(SDRES)
  1.  D RESNBR
  1.  Q
  1.  ;only update passed in resource
  1.  I SDRES'="" I $D(^SDEC(409.831,"ALOC",SDCL,SDRES)) D RESNBR  Q
  1.  ;update all resources if no resource passed in
  1.  I SDRES="" S SDRES=0 F  S SDRES=$O(^SDEC(409.831,"ALOC",SDCL,SDRES)) Q:SDRES'>0  D RESNBR
  1.  Q
  1. RESNBR  ;create access block for 1 resource
  1.  N SDCNT,SDFDA,SDIEN,SDIENS,SDMSG
  1.  S (SDCNT,@SDAB@("CNT"))=$G(@SDAB@("CNT"))+1
  1.  S @SDAB@(SDCNT)=SDRES_U_SDSTART_U_SDSTOP_U_SDSLOTS_U_SDAT
  1.  Q
  1.  ;
  1. DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
  1.  ;
  1. GETDAY(DATE)  ;return day of the week
  1.  N DOW,RET
  1.  S RET=""
  1.  S DATE=$P($G(DATE),".",1)
  1.  Q:DATE'?7N RET
  1.  S DOW="S %=$E(DATE,1,3),I=$E(DATE,4,5),I=I>2&'(%#4)+$E(""144025036146"",I) X ""F %=%:-1:281 S I=%#4=1+1+I"" S RET=$P(""SUN^MON^TUES^WEDNES^THURS^FRI^SATUR"",U,$E(DATE,6,7)+I#7+1)_""DAY"""
  1.  X DOW
  1.  Q RET