FSCEVENP ;SLC/STAFF-NOIS Events Processing ;1/13/98 11:27
;;1.1;NOIS;;Sep 06, 1998
EVENT(MODE,D0,FROM,TO) ; from FSCEVENT
N CNT,DATE,DESC,DOW,NEWDATE,NEXTDATE,NEXTDAY,NUM,OCC,OK,START,TYPE,ZERO K DESC
S ZERO=^FSC("REVENT",D0,0)
M DESC=^FSC("REVENT",D0,1)
S NUM=0 F S NUM=$O(^FSC("REVENT",D0,.5,NUM)) Q:NUM<1 S TYPE=+$G(^(NUM,0)) I TYPE D
TEST .;S FROM=2941201,TO=2951201,ZERO=1,DESC(0)=""
.;S TYPE=19 F S TYPE=$O(^FSC("ETYPE",TYPE)) Q:TYPE<1 W !,^(TYPE,0) D
.I TYPE=1 D DAILY Q
.I TYPE<20 D DOW Q
.I TYPE<70 D NUMDOW Q
.I TYPE<80 D ODD Q
.I TYPE<90 D EVEN Q
.I TYPE<100 D LAST Q
Q
;
DAILY ;
S DATE=FROM F D Q:DATE>TO
.S DOW=$$DOW^XLFDT(DATE,1)
.I '(DOW=0!(DOW=6)) D TRANSFER(DATE,ZERO,.DESC)
.S DATE=$$FMADD^XLFDT(DATE,1)
Q
;
DOW ;
S DOW=TYPE#10,START=0,DATE=FROM F D Q:START Q:DATE>TO
.I $$DOW^XLFDT(DATE,1)=DOW S START=DATE Q
.S DATE=$$FMADD^XLFDT(DATE,1)
I 'START Q
I DATE>TO Q
S DATE=START F D Q:DATE>TO
.D TRANSFER(DATE,ZERO,.DESC)
.S DATE=$$FMADD^XLFDT(DATE,7)
Q
;
NUMDOW ;
S DOW=TYPE#10,OCC=$E(TYPE)-1,DATE=$E(FROM,1,5)_$S(OCC=1:"01",OCC=2:"08",1:(OCC-1)*7+1)
D LEAPCHK(.DATE)
I DATE>TO Q
S CNT=0 F D Q:DATE>TO
.I OCC=5,$E(DATE,6,7)'>28 S CNT=0 S DATE=$E(DATE,1,5)_"29" D LEAPCHK(.DATE) Q
.S CNT=CNT+1 I CNT>7 S CNT=0 D NEWDATE(.DATE) Q
.I DOW=$$DOW^XLFDT(DATE,1),DATE'<FROM S CNT=0 D TRANSFER(DATE,ZERO,.DESC),NEWDATE(.DATE) Q
.S DATE=$$FMADD^XLFDT(DATE,1)
Q
;
NEWDATE(DATE) ;
S NEWDATE=$E(DATE,1,5)
I $E(NEWDATE,4,5)="12" S NEWDATE=$E(NEWDATE,1,3)+1_"01"
E S NEWDATE=NEWDATE+1
S DATE=NEWDATE_$S(OCC=1:"01",OCC=2:"08",1:(OCC-1)*7+1)
D LEAPCHK(.DATE)
Q
;
LEAPCHK(DATE) ;
I $E(DATE,4,7)="0229" S DATE=$E(DATE,1,3)_"0228" S DATE=$$FMADD^XLFDT(DATE,1) I $E(DATE,4,5)="03" S DATE=$E(DATE,1,5)_$S(OCC=1:"01",OCC=2:"08",1:(OCC-1)*7+1)
Q
;
EVEN ;
S DOW=TYPE#10,START=0,DATE=FROM F D Q:START Q:DATE>TO
.I $$DOW^XLFDT(DATE,1)=DOW S OK=1 D I 'OK Q
..I '($$DOW^XLFDT(DATE,1)#2),$$FMDIFF^XLFDT(DATE,2950101)+1#2 S START=DATE,OK=0 Q
..I $$DOW^XLFDT(DATE,1)#2,'($$FMDIFF^XLFDT(DATE,2950101)+1#2) S START=DATE,OK=0 Q
.S DATE=$$FMADD^XLFDT(DATE,1)
I 'START Q
I DATE>TO Q
S DATE=START F D Q:DATE>TO
.D TRANSFER(DATE,ZERO,.DESC)
.S DATE=$$FMADD^XLFDT(DATE,14)
Q
;
ODD ;
S DOW=TYPE#10,START=0,DATE=FROM F D Q:START Q:DATE>TO
.I $$DOW^XLFDT(DATE,1)=DOW S OK=1 D I 'OK Q
..I '($$DOW^XLFDT(DATE,1)#2),'($$FMDIFF^XLFDT(DATE,2950101)+1#2) S START=DATE,OK=0 Q
..I $$DOW^XLFDT(DATE,1)#2,$$FMDIFF^XLFDT(DATE,2950101)+1#2 S START=DATE,OK=0 Q
.S DATE=$$FMADD^XLFDT(DATE,1)
I 'START Q
I DATE>TO Q
S DATE=START F D Q:DATE>TO
.D TRANSFER(DATE,ZERO,.DESC)
.S DATE=$$FMADD^XLFDT(DATE,14)
Q
;
LAST ;
S DOW=TYPE#10,DATE=$$GETSTART(FROM)
I DATE>TO Q
F D Q:DATE>TO
.I DOW=$$DOW^XLFDT(DATE,1),DATE'<FROM D GETLAST(.DATE,.NEXTDATE),TRANSFER(DATE,ZERO,.DESC) S DATE=NEXTDATE Q
.I DATE>TO Q
.S DATE=$$FMADD^XLFDT(DATE,1)
Q
;
GETLAST(DATE,NEXTDAY) ;
N NEWDATE
S NEWDATE=$$FMADD^XLFDT(DATE,7)
I $E(NEWDATE,4,5)=$E(DATE,4,5) S DATE=NEWDATE
I $E(DATE,4,5)="12" S NEXTDAY=$E(DATE,1,3)+1_"0122"
E S NEXTDAY=$E(DATE,1,3)_$E(DATE,4,5)+1_"22"
Q
;
GETSTART(DATE) ; $$(date) -> next start date
I $E(DATE,6,7)<23 Q $E(DATE,1,5)_"22"
I $E(DATE,4,5)="01" Q $E(DATE,1,3)-1_"1222"
Q $E(DATE,1,3)_$E(DATE,4,5)-1_"22"
;
TRANSFER(DATE,ZERO,DESC) ;
I MODE="DELETE" D Q
.N DA,DIK
.S DA=$$DUP(DATE,ZERO),DIK="^FSCD(""EVENTS"","
.I 'DA Q
.D ^DIK
.D DISPLAY
I $D(^FSCD("EVENTS","B",DATE)),$D(^FSCD("EVENTS","C",$P(ZERO,U))) I $$DUP(DATE,ZERO) Q
N DA,DIK,NUM
S NUM=1+$P(^FSCD("EVENTS",0),U,3)
L +^FSCD("EVENTS",0):30 I '$T Q ; *** needs ok
F Q:'$D(^FSCD("EVENTS",NUM,0)) S NUM=NUM+1
S ^FSCD("EVENTS",NUM,0)=DATE_U_ZERO
S $P(^FSCD("EVENTS",0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1
L -^FSCD("EVENTS",0)
M ^FSCD("EVENTS",NUM,1)=DESC
S DIK="^FSCD(""EVENTS"",",DA=NUM D IX1^DIK
D DISPLAY
Q
;
DISPLAY W !,+$E(DATE,4,5),"/",+$E(DATE,6,7),"/",$E(DATE,2,3),?17,$P(ZERO,U)
Q
;
DUP(DATE,ZERO) ; $$(date,zero node) -> # if duplicate, else ""
N NODE,NUM,OK
S OK=0,NODE=DATE_U_ZERO
S NUM=0 F S NUM=$O(^FSCD("EVENTS","B",DATE,NUM)) Q:NUM<1 D Q:OK
.I $G(^FSCD("EVENTS",NUM,0))=NODE S OK=1 Q
Q NUM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFSCEVENP 4311 printed Sep 23, 2025@19:53:59 Page 2
FSCEVENP ;SLC/STAFF-NOIS Events Processing ;1/13/98 11:27
+1 ;;1.1;NOIS;;Sep 06, 1998
EVENT(MODE,D0,FROM,TO) ; from FSCEVENT
+1 NEW CNT,DATE,DESC,DOW,NEWDATE,NEXTDATE,NEXTDAY,NUM,OCC,OK,START,TYPE,ZERO
KILL DESC
+2 SET ZERO=^FSC("REVENT",D0,0)
+3 MERGE DESC=^FSC("REVENT",D0,1)
+4 SET NUM=0
FOR
SET NUM=$ORDER(^FSC("REVENT",D0,.5,NUM))
if NUM<1
QUIT
SET TYPE=+$GET(^(NUM,0))
IF TYPE
Begin DoDot:1
TEST ;S FROM=2941201,TO=2951201,ZERO=1,DESC(0)=""
+1 ;S TYPE=19 F S TYPE=$O(^FSC("ETYPE",TYPE)) Q:TYPE<1 W !,^(TYPE,0) D
+2 IF TYPE=1
DO DAILY
QUIT
+3 IF TYPE<20
DO DOW
QUIT
+4 IF TYPE<70
DO NUMDOW
QUIT
+5 IF TYPE<80
DO ODD
QUIT
+6 IF TYPE<90
DO EVEN
QUIT
+7 IF TYPE<100
DO LAST
QUIT
End DoDot:1
+8 QUIT
+9 ;
DAILY ;
+1 SET DATE=FROM
FOR
Begin DoDot:1
+2 SET DOW=$$DOW^XLFDT(DATE,1)
+3 IF '(DOW=0!(DOW=6))
DO TRANSFER(DATE,ZERO,.DESC)
+4 SET DATE=$$FMADD^XLFDT(DATE,1)
End DoDot:1
if DATE>TO
QUIT
+5 QUIT
+6 ;
DOW ;
+1 SET DOW=TYPE#10
SET START=0
SET DATE=FROM
FOR
Begin DoDot:1
+2 IF $$DOW^XLFDT(DATE,1)=DOW
SET START=DATE
QUIT
+3 SET DATE=$$FMADD^XLFDT(DATE,1)
End DoDot:1
if START
QUIT
if DATE>TO
QUIT
+4 IF 'START
QUIT
+5 IF DATE>TO
QUIT
+6 SET DATE=START
FOR
Begin DoDot:1
+7 DO TRANSFER(DATE,ZERO,.DESC)
+8 SET DATE=$$FMADD^XLFDT(DATE,7)
End DoDot:1
if DATE>TO
QUIT
+9 QUIT
+10 ;
NUMDOW ;
+1 SET DOW=TYPE#10
SET OCC=$EXTRACT(TYPE)-1
SET DATE=$EXTRACT(FROM,1,5)_$SELECT(OCC=1:"01",OCC=2:"08",1:(OCC-1)*7+1)
+2 DO LEAPCHK(.DATE)
+3 IF DATE>TO
QUIT
+4 SET CNT=0
FOR
Begin DoDot:1
+5 IF OCC=5
IF $EXTRACT(DATE,6,7)'>28
SET CNT=0
SET DATE=$EXTRACT(DATE,1,5)_"29"
DO LEAPCHK(.DATE)
QUIT
+6 SET CNT=CNT+1
IF CNT>7
SET CNT=0
DO NEWDATE(.DATE)
QUIT
+7 IF DOW=$$DOW^XLFDT(DATE,1)
IF DATE'<FROM
SET CNT=0
DO TRANSFER(DATE,ZERO,.DESC)
DO NEWDATE(.DATE)
QUIT
+8 SET DATE=$$FMADD^XLFDT(DATE,1)
End DoDot:1
if DATE>TO
QUIT
+9 QUIT
+10 ;
NEWDATE(DATE) ;
+1 SET NEWDATE=$EXTRACT(DATE,1,5)
+2 IF $EXTRACT(NEWDATE,4,5)="12"
SET NEWDATE=$EXTRACT(NEWDATE,1,3)+1_"01"
+3 IF '$TEST
SET NEWDATE=NEWDATE+1
+4 SET DATE=NEWDATE_$SELECT(OCC=1:"01",OCC=2:"08",1:(OCC-1)*7+1)
+5 DO LEAPCHK(.DATE)
+6 QUIT
+7 ;
LEAPCHK(DATE) ;
+1 IF $EXTRACT(DATE,4,7)="0229"
SET DATE=$EXTRACT(DATE,1,3)_"0228"
SET DATE=$$FMADD^XLFDT(DATE,1)
IF $EXTRACT(DATE,4,5)="03"
SET DATE=$EXTRACT(DATE,1,5)_$SELECT(OCC=1:"01",OCC=2:"08",1:(OCC-1)*7+1)
+2 QUIT
+3 ;
EVEN ;
+1 SET DOW=TYPE#10
SET START=0
SET DATE=FROM
FOR
Begin DoDot:1
+2 IF $$DOW^XLFDT(DATE,1)=DOW
SET OK=1
Begin DoDot:2
+3 IF '($$DOW^XLFDT(DATE,1)#2)
IF $$FMDIFF^XLFDT(DATE,2950101)+1#2
SET START=DATE
SET OK=0
QUIT
+4 IF $$DOW^XLFDT(DATE,1)#2
IF '($$FMDIFF^XLFDT(DATE,2950101)+1#2)
SET START=DATE
SET OK=0
QUIT
End DoDot:2
IF 'OK
QUIT
+5 SET DATE=$$FMADD^XLFDT(DATE,1)
End DoDot:1
if START
QUIT
if DATE>TO
QUIT
+6 IF 'START
QUIT
+7 IF DATE>TO
QUIT
+8 SET DATE=START
FOR
Begin DoDot:1
+9 DO TRANSFER(DATE,ZERO,.DESC)
+10 SET DATE=$$FMADD^XLFDT(DATE,14)
End DoDot:1
if DATE>TO
QUIT
+11 QUIT
+12 ;
ODD ;
+1 SET DOW=TYPE#10
SET START=0
SET DATE=FROM
FOR
Begin DoDot:1
+2 IF $$DOW^XLFDT(DATE,1)=DOW
SET OK=1
Begin DoDot:2
+3 IF '($$DOW^XLFDT(DATE,1)#2)
IF '($$FMDIFF^XLFDT(DATE,2950101)+1#2)
SET START=DATE
SET OK=0
QUIT
+4 IF $$DOW^XLFDT(DATE,1)#2
IF $$FMDIFF^XLFDT(DATE,2950101)+1#2
SET START=DATE
SET OK=0
QUIT
End DoDot:2
IF 'OK
QUIT
+5 SET DATE=$$FMADD^XLFDT(DATE,1)
End DoDot:1
if START
QUIT
if DATE>TO
QUIT
+6 IF 'START
QUIT
+7 IF DATE>TO
QUIT
+8 SET DATE=START
FOR
Begin DoDot:1
+9 DO TRANSFER(DATE,ZERO,.DESC)
+10 SET DATE=$$FMADD^XLFDT(DATE,14)
End DoDot:1
if DATE>TO
QUIT
+11 QUIT
+12 ;
LAST ;
+1 SET DOW=TYPE#10
SET DATE=$$GETSTART(FROM)
+2 IF DATE>TO
QUIT
+3 FOR
Begin DoDot:1
+4 IF DOW=$$DOW^XLFDT(DATE,1)
IF DATE'<FROM
DO GETLAST(.DATE,.NEXTDATE)
DO TRANSFER(DATE,ZERO,.DESC)
SET DATE=NEXTDATE
QUIT
+5 IF DATE>TO
QUIT
+6 SET DATE=$$FMADD^XLFDT(DATE,1)
End DoDot:1
if DATE>TO
QUIT
+7 QUIT
+8 ;
GETLAST(DATE,NEXTDAY) ;
+1 NEW NEWDATE
+2 SET NEWDATE=$$FMADD^XLFDT(DATE,7)
+3 IF $EXTRACT(NEWDATE,4,5)=$EXTRACT(DATE,4,5)
SET DATE=NEWDATE
+4 IF $EXTRACT(DATE,4,5)="12"
SET NEXTDAY=$EXTRACT(DATE,1,3)+1_"0122"
+5 IF '$TEST
SET NEXTDAY=$EXTRACT(DATE,1,3)_$EXTRACT(DATE,4,5)+1_"22"
+6 QUIT
+7 ;
GETSTART(DATE) ; $$(date) -> next start date
+1 IF $EXTRACT(DATE,6,7)<23
QUIT $EXTRACT(DATE,1,5)_"22"
+2 IF $EXTRACT(DATE,4,5)="01"
QUIT $EXTRACT(DATE,1,3)-1_"1222"
+3 QUIT $EXTRACT(DATE,1,3)_$EXTRACT(DATE,4,5)-1_"22"
+4 ;
TRANSFER(DATE,ZERO,DESC) ;
+1 IF MODE="DELETE"
Begin DoDot:1
+2 NEW DA,DIK
+3 SET DA=$$DUP(DATE,ZERO)
SET DIK="^FSCD(""EVENTS"","
+4 IF 'DA
QUIT
+5 DO ^DIK
+6 DO DISPLAY
End DoDot:1
QUIT
+7 IF $DATA(^FSCD("EVENTS","B",DATE))
IF $DATA(^FSCD("EVENTS","C",$PIECE(ZERO,U)))
IF $$DUP(DATE,ZERO)
QUIT
+8 NEW DA,DIK,NUM
+9 SET NUM=1+$PIECE(^FSCD("EVENTS",0),U,3)
+10 ; *** needs ok
LOCK +^FSCD("EVENTS",0):30
IF '$TEST
QUIT
+11 FOR
if '$DATA(^FSCD("EVENTS",NUM,0))
QUIT
SET NUM=NUM+1
+12 SET ^FSCD("EVENTS",NUM,0)=DATE_U_ZERO
+13 SET $PIECE(^FSCD("EVENTS",0),U,3)=NUM
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
+14 LOCK -^FSCD("EVENTS",0)
+15 MERGE ^FSCD("EVENTS",NUM,1)=DESC
+16 SET DIK="^FSCD(""EVENTS"","
SET DA=NUM
DO IX1^DIK
+17 DO DISPLAY
+18 QUIT
+19 ;
DISPLAY WRITE !,+$EXTRACT(DATE,4,5),"/",+$EXTRACT(DATE,6,7),"/",$EXTRACT(DATE,2,3),?17,$PIECE(ZERO,U)
+1 QUIT
+2 ;
DUP(DATE,ZERO) ; $$(date,zero node) -> # if duplicate, else ""
+1 NEW NODE,NUM,OK
+2 SET OK=0
SET NODE=DATE_U_ZERO
+3 SET NUM=0
FOR
SET NUM=$ORDER(^FSCD("EVENTS","B",DATE,NUM))
if NUM<1
QUIT
Begin DoDot:1
+4 IF $GET(^FSCD("EVENTS",NUM,0))=NODE
SET OK=1
QUIT
End DoDot:1
if OK
QUIT
+5 QUIT NUM
