- 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 ---[H[J[2J[HPRSARC06 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)