XLFDT3 ;SEA/RDS - Library Function Schedule ;02/09/2000 09:21
;;8.0;KERNEL;**71,120,141**;Jul 10, 1995
;
MONTH2 ;DECODE--Complex Month Increment Specification
N %,%A,%B,%C,%D,%H,%L,%M,%O,%T,%Y,XL,XLCT,XLW,XLX,XLF,XLFS,XLL,XLLW,XLO,XLT
S %H=LTM D YMD^XLFDT S %L=%Y+1700,%L=$$LEAP(%L)
S LTMA="31^"_(%L+28)_"^31^30^31^30^31^31^30^31^30^31",%=$P(LTM,",",2),XLCT=%#60/100+(%#3600\60)/100+(%\3600)/100
;Check if a date in current month
S XLF=LTM-%D+5#7+1,XLFS=2-XLF,XLL=$P(LTMA,"^",%M),XLLW=XLF-29+XLL S:XLLW=0 XLLW=7 S:XLLW>7 XLLW=XLLW#8+1
K %A F XLX=1:1:$L(SCHL,",") D BUILD
I $O(%A(%D+XLCT))]"" S XLO=$O(%A(%D+XLCT)),%1=XLO\1-%D,XLT=XLO#1,XLT=$E(XLT_0,2,3)*60+$E(XLT_"000",4,5)*60+$E(XLT_"00000",6,7),Y=LTM+%1_","_XLT Q
;Check the next months
S %C=XLL-%D,XL=$P(SCH,"M")-1,%M=%M+1 S:%M=13 %Y=%Y+1,%M=1,$P(LTMA,"^",2)=28+$$LEAP(%Y)
F Q:'XL S %C=%C+$P(LTMA,"^",%M),%M=%M+1,XL=XL-1 I %M=13 S %Y=%Y+1,%M=1,$P(LTMA,"^",2)=28+$$LEAP(%Y)
S LTM=LTM+%C_","_$P(LTM,",",2),XLF=LTM+5#7+1,XLFS=2-XLF,XLL=$P(LTMA,"^",%M),XLLW=XLF-29+XLL S:XLLW=0 XLLW=7 S:XLLW>7 XLLW=XLLW#8+1
K %A F XLX=1:1:$L(SCHL,",") D BUILD
S %O=$O(%A("")) I %O="" S %O=$$FLD() ;Q ;Bad input, force last day
S %=%O#1,%=$E(%_0,2,3)*60+$E(%_"000",4,5)*60+$E(%_"00000",6,7),Y=%O\1+LTM_","_%
Q
;
BUILD ;MONTH2--Building Array Of Run Incidents For Month
S %B=$P(SCHL,",",XLX),XLT=""
;Build for a day in month (15)
I $P(%B,"@")?1.2N S %A=%B\1 Q:%A>XLL!'%A S XLT=$$TIME($P(%B,"@",2)) S %A(%A+XLT)="" Q
;Build for 1st.. DOW in month ("2W")
I $P(%B,"@")?1N1U,"UMTWRFS"[$E(%B,2) S %A=XLFS+$F("UMTWRFS",$E(%B,2))-2,%A=%B-(%A>0)*7+%A\1 Q:%A>XLL!'%A S XLT=$$TIME($P(%B,"@",2)) S %A(%A+XLT)="" Q
;Build for Last day of month ("L")
I $P(%B,"@")="L" S %A=XLL,XLT=$$TIME($P(%B,"@",2)) S %A(%A+XLT)="" Q
;Build for last DOW in month ("LF") last friday
I $P(%B,"@")?1"L"1U,"UMTWRFS"[$E(%B,2) S XLW=$F("UMTWRFS",$E(%B,2))-1,%A=XLL-$S(XLLW-XLW<0:XLLW+7-XLW,1:XLLW-XLW),XLT=$$TIME($P(%B,"@",2)) S %A(%A+XLT)="" Q
Q
;
TIME(%X) ;BUILD--Build Time Node For Incidents That Include Times
N %Y,%M,%D,%T,%DT,X,Y
I %X="" Q XLCT ;use current time
S %DT="RS",X="T@"_%X D ^%DT
Q $S(Y=-1:XLCT,1:Y#1)
;
LEAP(%) ;Check if a Leap year
S:%<1700 %=%+1700
Q (%#4=0)&'(%#100=0)!(%#400=0)
;
FLD() ;Force to last day of month.
S XLT=""
F XLX=1:1:$L(SCHL,",") S %B=$P(SCHL,",",XLX) I +%B>XLL S XLT=$$TIME($P(%B,"@",2))
Q XLL+XLT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFDT3 2430 printed Dec 13, 2024@02:02:40 Page 2
XLFDT3 ;SEA/RDS - Library Function Schedule ;02/09/2000 09:21
+1 ;;8.0;KERNEL;**71,120,141**;Jul 10, 1995
+2 ;
MONTH2 ;DECODE--Complex Month Increment Specification
+1 NEW %,%A,%B,%C,%D,%H,%L,%M,%O,%T,%Y,XL,XLCT,XLW,XLX,XLF,XLFS,XLL,XLLW,XLO,XLT
+2 SET %H=LTM
DO YMD^XLFDT
SET %L=%Y+1700
SET %L=$$LEAP(%L)
+3 SET LTMA="31^"_(%L+28)_"^31^30^31^30^31^31^30^31^30^31"
SET %=$PIECE(LTM,",",2)
SET XLCT=%#60/100+(%#3600\60)/100+(%\3600)/100
+4 ;Check if a date in current month
+5 SET XLF=LTM-%D+5#7+1
SET XLFS=2-XLF
SET XLL=$PIECE(LTMA,"^",%M)
SET XLLW=XLF-29+XLL
if XLLW=0
SET XLLW=7
if XLLW>7
SET XLLW=XLLW#8+1
+6 KILL %A
FOR XLX=1:1:$LENGTH(SCHL,",")
DO BUILD
+7 IF $ORDER(%A(%D+XLCT))]""
SET XLO=$ORDER(%A(%D+XLCT))
SET %1=XLO\1-%D
SET XLT=XLO#1
SET XLT=$EXTRACT(XLT_0,2,3)*60+$EXTRACT(XLT_"000",4,5)*60+$EXTRACT(XLT_"00000",6,7)
SET Y=LTM+%1_","_XLT
QUIT
+8 ;Check the next months
+9 SET %C=XLL-%D
SET XL=$PIECE(SCH,"M")-1
SET %M=%M+1
if %M=13
SET %Y=%Y+1
SET %M=1
SET $PIECE(LTMA,"^",2)=28+$$LEAP(%Y)
+10 FOR
if 'XL
QUIT
SET %C=%C+$PIECE(LTMA,"^",%M)
SET %M=%M+1
SET XL=XL-1
IF %M=13
SET %Y=%Y+1
SET %M=1
SET $PIECE(LTMA,"^",2)=28+$$LEAP(%Y)
+11 SET LTM=LTM+%C_","_$PIECE(LTM,",",2)
SET XLF=LTM+5#7+1
SET XLFS=2-XLF
SET XLL=$PIECE(LTMA,"^",%M)
SET XLLW=XLF-29+XLL
if XLLW=0
SET XLLW=7
if XLLW>7
SET XLLW=XLLW#8+1
+12 KILL %A
FOR XLX=1:1:$LENGTH(SCHL,",")
DO BUILD
+13 ;Q ;Bad input, force last day
SET %O=$ORDER(%A(""))
IF %O=""
SET %O=$$FLD()
+14 SET %=%O#1
SET %=$EXTRACT(%_0,2,3)*60+$EXTRACT(%_"000",4,5)*60+$EXTRACT(%_"00000",6,7)
SET Y=%O\1+LTM_","_%
+15 QUIT
+16 ;
BUILD ;MONTH2--Building Array Of Run Incidents For Month
+1 SET %B=$PIECE(SCHL,",",XLX)
SET XLT=""
+2 ;Build for a day in month (15)
+3 IF $PIECE(%B,"@")?1.2N
SET %A=%B\1
if %A>XLL!'%A
QUIT
SET XLT=$$TIME($PIECE(%B,"@",2))
SET %A(%A+XLT)=""
QUIT
+4 ;Build for 1st.. DOW in month ("2W")
+5 IF $PIECE(%B,"@")?1N1U
IF "UMTWRFS"[$EXTRACT(%B,2)
SET %A=XLFS+$FIND("UMTWRFS",$EXTRACT(%B,2))-2
SET %A=%B-(%A>0)*7+%A\1
if %A>XLL!'%A
QUIT
SET XLT=$$TIME($PIECE(%B,"@",2))
SET %A(%A+XLT)=""
QUIT
+6 ;Build for Last day of month ("L")
+7 IF $PIECE(%B,"@")="L"
SET %A=XLL
SET XLT=$$TIME($PIECE(%B,"@",2))
SET %A(%A+XLT)=""
QUIT
+8 ;Build for last DOW in month ("LF") last friday
+9 IF $PIECE(%B,"@")?1"L"1U
IF "UMTWRFS"[$EXTRACT(%B,2)
SET XLW=$FIND("UMTWRFS",$EXTRACT(%B,2))-1
SET %A=XLL-$SELECT(XLLW-XLW<0:XLLW+7-XLW,1:XLLW-XLW)
SET XLT=$$TIME($PIECE(%B,"@",2))
SET %A(%A+XLT)=""
QUIT
+10 QUIT
+11 ;
TIME(%X) ;BUILD--Build Time Node For Incidents That Include Times
+1 NEW %Y,%M,%D,%T,%DT,X,Y
+2 ;use current time
IF %X=""
QUIT XLCT
+3 SET %DT="RS"
SET X="T@"_%X
DO ^%DT
+4 QUIT $SELECT(Y=-1:XLCT,1:Y#1)
+5 ;
LEAP(%) ;Check if a Leap year
+1 if %<1700
SET %=%+1700
+2 QUIT (%#4=0)&'(%#100=0)!(%#400=0)
+3 ;
FLD() ;Force to last day of month.
+1 SET XLT=""
+2 FOR XLX=1:1:$LENGTH(SCHL,",")
SET %B=$PIECE(SCHL,",",XLX)
IF +%B>XLL
SET XLT=$$TIME($PIECE(%B,"@",2))
+3 QUIT XLL+XLT
