PRSARC06.m

PRSARC06 ;WOIFO/JAH - Recess Tracking ListManger Inteface ;10/16/06

 ;;4.0;PAID;**112**;Sep 21, 1995;Build 54

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 Q

MAIN(LSTART,LISTI,LINE,PRSDT,PRSFYRNG) ; BUILD LIST OF CALENDER FROM PP WITH PRSDT

 ; THROUGH PP CONTAINING SEPTEMBER 30

 ;

 ; PRSNMDT - date for new month

 ;

 ; Q:$G(PRSOUT)=1

 N FIRSTPP,PRSNMDT,FFPPE,LFPPE,EOFYDT,OUT,PRSDY,PRSMO,PRSNXTMO,PRSYR

 ;

 ; Get PP with PRSDT and convert PRSDT to the 1st day of that pp

 ;

 S FIRSTPP=$$GETPPDY^PRSARC04(PRSDT)

 S FFPPE=$P(FIRSTPP,U,2)

 S (PRSDT,PRSNMDT)=$P(FIRSTPP,U,1)

 ;

 ; lookup which week of the fiscal year the schedule begins

 ; this week # will be the first selectable item in the list

 ;

 S (LSTART,LISTI)=$G(FMWKS(PRSDT))

 ;

 ; Get the last PP of the fiscal year and it's last day.

 S LFPPE=$P(PRSFYRNG,U,4)

 S EOFYDT=$P(PRSFYRNG,U,2)

 ;

 ; if the first week in the AWS schedule is not both the 1st day

 ; of a PP and the first day of the month, then we need

 ; special code for that month, so that a partial month is used

 ; including only the pps that are part of the schedule.

 ;

 S (OUT,LINE,MONTHCNT)=0

 I $E(PRSDT,6,7)'="01" D

 .  S STARTDAY=$E(PRSDT,6,7)

 .  D ARAYMO(.LISTI,.LINE,PRSDT,MONTHCNT,STARTDAY,0)

 .  S PRSMO=$E(PRSDT,4,5),PRSYR=$E(PRSDT,1,3),PRSDY=$E(PRSDT,6,7)

 .  S PRSNXTMO=PRSMO+1 I $L(PRSNXTMO)=1 S PRSNXTMO="0"_PRSNXTMO

 .  S PRSNMDT=$S(PRSMO=12:PRSYR+1_"01"_PRSDY,1:PRSYR_PRSNXTMO_"01")

 ;

 ; loop through the calendar building list items for every week in 

 ; the year until we reach october.  All agreements are through

 ; the end of the fiscal year.

 ;

 S OUT=0

 F  D  Q:OUT

 .  S MONTHCNT=MONTHCNT+1

 .  D ARAYMO(.LISTI,.LINE,PRSNMDT,MONTHCNT,1,0)

 .  S PRSMO=$E(PRSNMDT,4,5),PRSYR=$E(PRSNMDT,1,3),PRSDY=$E(PRSNMDT,6,7)

 .  S PRSNXTMO=PRSMO+1 I $L(PRSNXTMO)=1 S PRSNXTMO="0"_PRSNXTMO

 .  S PRSNMDT=$S(PRSMO=12:PRSYR+1_"01"_PRSDY,1:PRSYR_PRSNXTMO_"01")

 .  ;if we hit september 30 or october quit

 .  I PRSNXTMO=10!(PRSNMDT>EOFYDT) S OUT=1

 ;

 ; Include any weeks in October that are part of the PP

 ; with September 30, thus the fiscal year spills into october by

 ; no more than 13 days 

 ;

 I PRSNXTMO=10&(PRSNMDT'>EOFYDT) D

 .  S MONTHCNT=MONTHCNT+1

 .  D ARAYMO(.LISTI,.LINE,PRSNMDT,MONTHCNT,1,+$E(EOFYDT,6,7))

 Q

 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = 

 ;

ARAYMO(LISTI,LINE,PRSDT,MONTHCNT,STARTDAY,SHORT) ;SILENT CALL TO PLACE MONTH IN ARRAY

 ;  INPUT: PRSDT - must be fileman date

 ;         SHORT - set to # of days to show if a short month

 ;                 is desired.  i.e. to stop listing after the 

 ;                  first PP then specify the # of

 ;                 days to that date from the 1st of the month

 ;

 N X,Y,%DT,DAY1,Y,MONTH,DAYS,YEAR,FIRSTDAY,LASTDAY,COUNT,HDR

 S X=PRSDT D ^%DT Q:Y<0

 S MONTH=$E(PRSDT,4,5),YEAR=$E(PRSDT,1,3)+1700

 I SHORT D

 .   S DAYS=SHORT

 E  D

 .   S DAYS=$$DAYSINMO(YEAR,MONTH)

 S FIRSTDAY=$E(PRSDT,1,5)_"01",LASTDAY=$E(PRSDT,1,5)_DAYS

 ;

 ;Get day #s of pps in month

 N PPS

 I FIRSTDAY<3130000 D GETPPS(FIRSTDAY,LASTDAY)

 S DAY1=$$WEEKDAY1(PRSDT)

 S HDR=$$GETHEAD(Y)

 S LINE=LINE+1

 S ^TMP("PRSARC",$J,LINE,0)="        ============="_HDR_"============"

 ;

 D DISPMO(.LISTI,.LINE,DAY1,DAYS,1,STARTDAY)

 ;S LINE=LINE+1

 ;D HOLIDAY

 Q

 ;

 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

DISPMO(LISTI,LINE,DAYNO,NODAYS,SKPW1,STRTDY) ;store a month into an array

 ;SAMPLE CALL:  D DISPMO(4,30,.L,0) Produces a 30 day month with day 1

 ;                                 beginning on Wednesday.

 ;SAMPLE CALL:  D DISPMO(4,30,.L,1) Produces a 30 day month starting

 ;                                  in week 2 Sunday--day 5

 ;

 ;INPUT:

 ;  DAYNO : integer value of weekday (0=sun,1=mon,2=tues,...,6=sat)

 ;  NODAYS: integer value of days in month, i.e. 30 days has sept...

 ;  SKIPW1: set to true if you want to skip partial 1st week

 ;  STRTDY: set to day of month to start calendar.

 ;

 N DAYS,DAYPOS,I,PPOFFSET,CNTDWN,BLNKS,LEADBLNK,WRTAB

 S PPOFFSET="     ",CNTDWN=NODAYS

 ;

 ; keep track of selectable items in the list (LISTI) and 

 ; lines in the list

 ;

 ; start with second week when SKPW1 is true and the first week

 ; of the month isn't a full week.

 ;   also I STARTDAY is > 1 then use it (we only want a partial month)

 I (STRTDY=1)&SKPW1&(DAYNO'=0) S STRTDY=8-DAYNO

 F I=STRTDY:1:NODAYS D

 . S DAYPOS=(DAYNO+I-1)#7

 . I DAYPOS=0 D

 ..  S LINE=LINE+1

 ..  S LEADBLNK=$E("   ",1,(3-$L(LISTI)))

 ..  S BLNKS="     "

 ..  I $G(PPS(I))'="" D

 ...   ; index of items that are selectable (weeks only, no month heads)

 ...   S ^TMP("PRSLI",$J,LISTI)=LINE

 ...   ; ListManager's items

 ...   S ^TMP("PRSARC",$J,LINE,0)=LEADBLNK_LISTI_BLNKS_PPS(I)

 ..  E  D

 ...   S ^TMP("PRSLI",$J,LISTI)=LINE

 ...   S ^TMP("PRSARC",$J,LINE,0)=LEADBLNK_LISTI_BLNKS_PPOFFSET

 ..  S LISTI=LISTI+1

 . I ($G(CNTDWN)>0) D

 ..   S WRTAB=$S($L(I)=2:"  ",1:"   ")

 ..   S ^TMP("PRSARC",$J,LINE,0)=$G(^TMP("PRSARC",$J,LINE,0))_WRTAB_I

 ..   S CNTDWN=CNTDWN-1

 ;

 ; add first days of next month to the last week

 ;

 I DAYPOS'=6 D

 .  F I=1:1:7-(DAYPOS+1) S ^TMP("PRSARC",$J,LINE,0)=$G(^TMP("PRSARC",$J,LINE,0))_"   "_I

 Q

 ;

 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

 ;

GETPPS(FIRSTDAY,LASTDAY) ;

 N D1,PPE,PPDAY,PPI,PP4Y

 S D1=FIRSTDAY D PP^PRSAPPU

 D NX^PRSAPPU

 I D1<FIRSTDAY S PPE=$E($$NXTPP^PRSAPPU(PPE),3,7) D NX^PRSAPPU

 S PPDAY=+$E(D1,6,7)

 S PPS(PPDAY)=PPE

 F  D  Q:D1>LASTDAY

 .  S PPE=$E($$NXTPP^PRSAPPU(PPE),3,7) D NX^PRSAPPU

 .  Q:D1>LASTDAY

 .  S PPDAY=+$E(D1,6,7)

 .  S PPS(PPDAY)=PPE

 Q

 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

 ;

GETHEAD(Y) ;

 N YEAR,MONTH,HDR,LENOFDT

 S HDR=$$FMTE^XLFDT(Y,"1D")

 S MONTH=$P(HDR," ")

 S LENOFDT=$L(HDR," ")

 S YEAR=$P(HDR," ",LENOFDT)

 Q MONTH_" "_YEAR

 ;

 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

 ;

WEEKDAY1(ZDATE) ;get the weekday of the 1st day of the month

 ; INPUT:   ZDATE   - FileMan date, used as the month to display

 ; OUTPUT:  return - Integer corresponding to day of week 

 ;                   (i.e. Sunday[1], Monday[2]) for the 1st day of

 ;                   the month

 S ZDATE=$E(ZDATE,1,5)_"01"

 Q $$DOW^XLFDT(ZDATE,1)

 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

 ;

DAYSINMO(Y,M) ; Return # of days in month based on year and month

 ;  Input:  Y = year in 4 digit format between 1700 and 3000

 ;          M = month expressed as an integer from 1 to 12 (Jan - Dec)

 ;

 N GOODY,GOODM S (GOODY,GOODM)=0

 I Y<2700,Y>1700 S GOODY=1

 I M>0,M<13 S GOODM=1

 Q:'(GOODM&GOODY) 0

 Q $P("31^"_(28+$$LEAPYR^PRSLIB00(YEAR))_"^31^30^31^30^31^31^30^31^30^31",U,MONTH)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRSARC06   6828     printed  Feb 18, 2025@23:50:40                                                                                                                                                                                                    Page 2

PRSARC06  ;WOIFO/JAH - Recess Tracking ListManger Inteface ;10/16/06

 +1       ;;4.0;PAID;**112**;Sep 21, 1995;Build 54

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3        QUIT 

MAIN(LSTART,LISTI,LINE,PRSDT,PRSFYRNG) ; BUILD LIST OF CALENDER FROM PP WITH PRSDT

 +1       ; THROUGH PP CONTAINING SEPTEMBER 30

 +2       ;

 +3       ; PRSNMDT - date for new month

 +4       ;

 +5       ; Q:$G(PRSOUT)=1

 +6        NEW FIRSTPP,PRSNMDT,FFPPE,LFPPE,EOFYDT,OUT,PRSDY,PRSMO,PRSNXTMO,PRSYR

 +7       ;

 +8       ; Get PP with PRSDT and convert PRSDT to the 1st day of that pp

 +9       ;

 +10       SET FIRSTPP=$$GETPPDY^PRSARC04(PRSDT)

 +11       SET FFPPE=$PIECE(FIRSTPP,U,2)

 +12       SET (PRSDT,PRSNMDT)=$PIECE(FIRSTPP,U,1)

 +13      ;

 +14      ; lookup which week of the fiscal year the schedule begins

 +15      ; this week # will be the first selectable item in the list

 +16      ;

 +17       SET (LSTART,LISTI)=$GET(FMWKS(PRSDT))

 +18      ;

 +19      ; Get the last PP of the fiscal year and it's last day.

 +20       SET LFPPE=$PIECE(PRSFYRNG,U,4)

 +21       SET EOFYDT=$PIECE(PRSFYRNG,U,2)

 +22      ;

 +23      ; if the first week in the AWS schedule is not both the 1st day

 +24      ; of a PP and the first day of the month, then we need

 +25      ; special code for that month, so that a partial month is used

 +26      ; including only the pps that are part of the schedule.

 +27      ;

 +28       SET (OUT,LINE,MONTHCNT)=0

 +29       IF $EXTRACT(PRSDT,6,7)'="01"

               Begin DoDot:1

 +30               SET STARTDAY=$EXTRACT(PRSDT,6,7)

 +31               DO ARAYMO(.LISTI,.LINE,PRSDT,MONTHCNT,STARTDAY,0)

 +32               SET PRSMO=$EXTRACT(PRSDT,4,5)

                   SET PRSYR=$EXTRACT(PRSDT,1,3)

                   SET PRSDY=$EXTRACT(PRSDT,6,7)

 +33               SET PRSNXTMO=PRSMO+1

                   IF $LENGTH(PRSNXTMO)=1

                       SET PRSNXTMO="0"_PRSNXTMO

 +34               SET PRSNMDT=$SELECT(PRSMO=12:PRSYR+1_"01"_PRSDY,1:PRSYR_PRSNXTMO_"01")

               End DoDot:1

 +35      ;

 +36      ; loop through the calendar building list items for every week in 

 +37      ; the year until we reach october.  All agreements are through

 +38      ; the end of the fiscal year.

 +39      ;

 +40       SET OUT=0

 +41       FOR 

               Begin DoDot:1

 +42               SET MONTHCNT=MONTHCNT+1

 +43               DO ARAYMO(.LISTI,.LINE,PRSNMDT,MONTHCNT,1,0)

 +44               SET PRSMO=$EXTRACT(PRSNMDT,4,5)

                   SET PRSYR=$EXTRACT(PRSNMDT,1,3)

                   SET PRSDY=$EXTRACT(PRSNMDT,6,7)

 +45               SET PRSNXTMO=PRSMO+1

                   IF $LENGTH(PRSNXTMO)=1

                       SET PRSNXTMO="0"_PRSNXTMO

 +46               SET PRSNMDT=$SELECT(PRSMO=12:PRSYR+1_"01"_PRSDY,1:PRSYR_PRSNXTMO_"01")

 +47      ;if we hit september 30 or october quit

 +48               IF PRSNXTMO=10!(PRSNMDT>EOFYDT)

                       SET OUT=1

               End DoDot:1

               if OUT

                   QUIT 

 +49      ;

 +50      ; Include any weeks in October that are part of the PP

 +51      ; with September 30, thus the fiscal year spills into october by

 +52      ; no more than 13 days 

 +53      ;

 +54       IF PRSNXTMO=10&(PRSNMDT'>EOFYDT)

               Begin DoDot:1

 +55               SET MONTHCNT=MONTHCNT+1

 +56               DO ARAYMO(.LISTI,.LINE,PRSNMDT,MONTHCNT,1,+$EXTRACT(EOFYDT,6,7))

               End DoDot:1

 +57       QUIT 

 +58      ;= = = = = = = = = = = = = = = = = = = = = = = = = = = 

 +59      ;

ARAYMO(LISTI,LINE,PRSDT,MONTHCNT,STARTDAY,SHORT) ;SILENT CALL TO PLACE MONTH IN ARRAY

 +1       ;  INPUT: PRSDT - must be fileman date

 +2       ;         SHORT - set to # of days to show if a short month

 +3       ;                 is desired.  i.e. to stop listing after the 

 +4       ;                  first PP then specify the # of

 +5       ;                 days to that date from the 1st of the month

 +6       ;

 +7        NEW X,Y,%DT,DAY1,Y,MONTH,DAYS,YEAR,FIRSTDAY,LASTDAY,COUNT,HDR

 +8        SET X=PRSDT

           DO ^%DT

           if Y<0

               QUIT 

 +9        SET MONTH=$EXTRACT(PRSDT,4,5)

           SET YEAR=$EXTRACT(PRSDT,1,3)+1700

 +10       IF SHORT

               Begin DoDot:1

 +11               SET DAYS=SHORT

               End DoDot:1

 +12      IF '$TEST

               Begin DoDot:1

 +13               SET DAYS=$$DAYSINMO(YEAR,MONTH)

               End DoDot:1

 +14       SET FIRSTDAY=$EXTRACT(PRSDT,1,5)_"01"

           SET LASTDAY=$EXTRACT(PRSDT,1,5)_DAYS

 +15      ;

 +16      ;Get day #s of pps in month

 +17       NEW PPS

 +18       IF FIRSTDAY<3130000

               DO GETPPS(FIRSTDAY,LASTDAY)

 +19       SET DAY1=$$WEEKDAY1(PRSDT)

 +20       SET HDR=$$GETHEAD(Y)

 +21       SET LINE=LINE+1

 +22       SET ^TMP("PRSARC",$JOB,LINE,0)="        ============="_HDR_"============"

 +23      ;

 +24       DO DISPMO(.LISTI,.LINE,DAY1,DAYS,1,STARTDAY)

 +25      ;S LINE=LINE+1

 +26      ;D HOLIDAY

 +27       QUIT 

 +28      ;

 +29      ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

DISPMO(LISTI,LINE,DAYNO,NODAYS,SKPW1,STRTDY) ;store a month into an array

 +1       ;SAMPLE CALL:  D DISPMO(4,30,.L,0) Produces a 30 day month with day 1

 +2       ;                                 beginning on Wednesday.

 +3       ;SAMPLE CALL:  D DISPMO(4,30,.L,1) Produces a 30 day month starting

 +4       ;                                  in week 2 Sunday--day 5

 +5       ;

 +6       ;INPUT:

 +7       ;  DAYNO : integer value of weekday (0=sun,1=mon,2=tues,...,6=sat)

 +8       ;  NODAYS: integer value of days in month, i.e. 30 days has sept...

 +9       ;  SKIPW1: set to true if you want to skip partial 1st week

 +10      ;  STRTDY: set to day of month to start calendar.

 +11      ;

 +12       NEW DAYS,DAYPOS,I,PPOFFSET,CNTDWN,BLNKS,LEADBLNK,WRTAB

 +13       SET PPOFFSET="     "

           SET CNTDWN=NODAYS

 +14      ;

 +15      ; keep track of selectable items in the list (LISTI) and 

 +16      ; lines in the list

 +17      ;

 +18      ; start with second week when SKPW1 is true and the first week

 +19      ; of the month isn't a full week.

 +20      ;   also I STARTDAY is > 1 then use it (we only want a partial month)

 +21       IF (STRTDY=1)&SKPW1&(DAYNO'=0)

               SET STRTDY=8-DAYNO

 +22       FOR I=STRTDY:1:NODAYS

               Begin DoDot:1

 +23               SET DAYPOS=(DAYNO+I-1)#7

 +24               IF DAYPOS=0

                       Begin DoDot:2

 +25                       SET LINE=LINE+1

 +26                       SET LEADBLNK=$EXTRACT("   ",1,(3-$LENGTH(LISTI)))

 +27                       SET BLNKS="     "

 +28                       IF $GET(PPS(I))'=""

                               Begin DoDot:3

 +29      ; index of items that are selectable (weeks only, no month heads)

 +30                               SET ^TMP("PRSLI",$JOB,LISTI)=LINE

 +31      ; ListManager's items

 +32                               SET ^TMP("PRSARC",$JOB,LINE,0)=LEADBLNK_LISTI_BLNKS_PPS(I)

                               End DoDot:3

 +33                      IF '$TEST

                               Begin DoDot:3

 +34                               SET ^TMP("PRSLI",$JOB,LISTI)=LINE

 +35                               SET ^TMP("PRSARC",$JOB,LINE,0)=LEADBLNK_LISTI_BLNKS_PPOFFSET

                               End DoDot:3

 +36                       SET LISTI=LISTI+1

                       End DoDot:2

 +37               IF ($GET(CNTDWN)>0)

                       Begin DoDot:2

 +38                       SET WRTAB=$SELECT($LENGTH(I)=2:"  ",1:"   ")

 +39                       SET ^TMP("PRSARC",$JOB,LINE,0)=$GET(^TMP("PRSARC",$JOB,LINE,0))_WRTAB_I

 +40                       SET CNTDWN=CNTDWN-1

                       End DoDot:2

               End DoDot:1

 +41      ;

 +42      ; add first days of next month to the last week

 +43      ;

 +44       IF DAYPOS'=6

               Begin DoDot:1

 +45               FOR I=1:1:7-(DAYPOS+1)

                       SET ^TMP("PRSARC",$JOB,LINE,0)=$GET(^TMP("PRSARC",$JOB,LINE,0))_"   "_I

               End DoDot:1

 +46       QUIT 

 +47      ;

 +48      ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

 +49      ;

GETPPS(FIRSTDAY,LASTDAY) ;

 +1        NEW D1,PPE,PPDAY,PPI,PP4Y

 +2        SET D1=FIRSTDAY

           DO PP^PRSAPPU

 +3        DO NX^PRSAPPU

 +4        IF D1<FIRSTDAY

               SET PPE=$EXTRACT($$NXTPP^PRSAPPU(PPE),3,7)

               DO NX^PRSAPPU

 +5        SET PPDAY=+$EXTRACT(D1,6,7)

 +6        SET PPS(PPDAY)=PPE

 +7        FOR 

               Begin DoDot:1

 +8                SET PPE=$EXTRACT($$NXTPP^PRSAPPU(PPE),3,7)

                   DO NX^PRSAPPU

 +9                if D1>LASTDAY

                       QUIT 

 +10               SET PPDAY=+$EXTRACT(D1,6,7)

 +11               SET PPS(PPDAY)=PPE

               End DoDot:1

               if D1>LASTDAY

                   QUIT 

 +12       QUIT 

 +13      ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

 +14      ;

GETHEAD(Y) ;

 +1        NEW YEAR,MONTH,HDR,LENOFDT

 +2        SET HDR=$$FMTE^XLFDT(Y,"1D")

 +3        SET MONTH=$PIECE(HDR," ")

 +4        SET LENOFDT=$LENGTH(HDR," ")

 +5        SET YEAR=$PIECE(HDR," ",LENOFDT)

 +6        QUIT MONTH_" "_YEAR

 +7       ;

 +8       ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

 +9       ;

WEEKDAY1(ZDATE) ;get the weekday of the 1st day of the month

 +1       ; INPUT:   ZDATE   - FileMan date, used as the month to display

 +2       ; OUTPUT:  return - Integer corresponding to day of week 

 +3       ;                   (i.e. Sunday[1], Monday[2]) for the 1st day of

 +4       ;                   the month

 +5        SET ZDATE=$EXTRACT(ZDATE,1,5)_"01"

 +6        QUIT $$DOW^XLFDT(ZDATE,1)

 +7       ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

 +8       ;

DAYSINMO(Y,M) ; Return # of days in month based on year and month

 +1       ;  Input:  Y = year in 4 digit format between 1700 and 3000

 +2       ;          M = month expressed as an integer from 1 to 12 (Jan - Dec)

 +3       ;

 +4        NEW GOODY,GOODM

           SET (GOODY,GOODM)=0

 +5        IF Y<2700

               IF Y>1700

                   SET GOODY=1

 +6        IF M>0

               IF M<13

                   SET GOODM=1

 +7        if '(GOODM&GOODY)

               QUIT 0

 +8        QUIT $PIECE("31^"_(28+$$LEAPYR^PRSLIB00(YEAR))_"^31^30^31^30^31^31^30^31^30^31",U,MONTH)