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 Oct 16, 2024@18:24:54 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)
