Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSARC03

PRSARC03.m

Go to the documentation of this file.
  1. PRSARC03 ;WOIFO/JAH - Recess Tracking Functions ;10/25/06
  1. ;;4.0;PAID;**112**;Sep 21, 1995;Build 54
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. Q
  1. NEWSTART(OUT,PRSDT) ; change alternate work schedule start date.
  1. ;
  1. N FD,LD,ALLFY,GOOD,LINE,LISTI
  1. S OUT=0
  1. S FD=$P(PRSFYRNG,U,1)
  1. S LD=$P(PRSFYRNG,U,2)
  1. S ALLFY=$$ALLFYAWS^PRSARC04()
  1. I ALLFY<0 S OUT=1 Q
  1. I ALLFY=1 D
  1. . S PRSDT=$P(PRSFY,U,5)
  1. E D
  1. . S PRSDT=$$AWSTART(FD,LD,"Enter Date 9 mo. AWS begins")
  1. . I PRSDT'>0 S OUT=1
  1. Q:OUT
  1. ; convert start to 1st day of pp and
  1. ; update the PRSFY var with new start date info
  1. N D1,DAY S D1=PRSDT D PP^PRSAPPU
  1. I DAY'=1 N X1,X2,X,%H S X1=D1,X2=-(DAY-1) D C^%DTC S PRSDT=X
  1. S $P(PRSFY,U,12)=PPE
  1. S $P(PRSFY,U,10)=$E(PRSDT,4,5)_"/"_$E(PRSDT,6,7)_"/"_$E(PRSDT,2,3)
  1. S $P(PRSFY,U,11)=PRSDT
  1. ;
  1. ;
  1. S PRSFSCYR=$$GETFSCYR^PRSARC04(PRSDT)
  1. I PRSDT<2006 S OUT=1
  1. ;
  1. ;GET total available hours based on fiscal year and start date.
  1. ;
  1. S PRSRWHRS=$$GETAVHRS^PRSARC04(.FMWKS,PRSDT)
  1. ;
  1. ; clean out old list data and rebuild everything
  1. ;
  1. D CLEAN^VALM10
  1. S (LISTI,LINE)=0
  1. K ^TMP("PRSARC",$J) ; array-all items in list, incl. non selectable
  1. ; items such as month headings.
  1. K ^TMP("PRSLI",$J) ; index of all selectable items in the list.
  1. K ^TMP("PRSSW",$J) ; index of items selected as recess weeks.
  1. K ^TMP("PRSRW",$J) ; index of recess weeks with hours.
  1. D MAIN^PRSARC06(.PRSLSTRT,.LISTI,.LINE,PRSDT,PRSFYRNG)
  1. D HDR^PRSARC
  1. S PRSWKLST=LISTI-1
  1. S VALMCNT=LINE
  1. ;
  1. Q
  1. ;
  1. AWSTART(FD,LD,PROMPT) ;function returns date within range FD-LD using PROMPT.
  1. ;
  1. ; since %DT will not restrict the valid date to a range we can use
  1. ; %DT to create the lower bound and then check the upper bound
  1. ; after exit from %DT. range is first and last day of FY.
  1. N PRSDT,Y,DIRUT,DIR,X
  1. S DIR("A")=PROMPT
  1. S DIR(0)="D^"_FD_":"_LD_":EX"
  1. D ^DIR
  1. S PRSDT=Y
  1. I $D(DIRUT) S PRSDT=0
  1. Q PRSDT
  1. ;
  1. FYRDATA(RWIEN) ; build a record of data for the Fiscal Year Recess for the viewer
  1. ; INPUT: Recess record IEN
  1. ;
  1. ; OUTPUT: SELFY-selected fiscal year data (11 ^ piece string)
  1. ; 1) 4 digit yr 2) ex.FY06-07 3) external 1st day
  1. ; 4) external last day 5) FM 1st day 6) FM last day
  1. ; 7) first pp 8) last pp 9) 458.8 IEN if exists
  1. ; 10) ext AWS start date 11) FM date AWS start
  1. ; 12) AWS start pay period
  1. ;
  1. N NODE3,FY,RANGE,ST,EN,EXTRANGE,FYE,X,Y,EXTSTDT,SELFY,STDT
  1. S NODE3=$G(^PRST(458.8,RWIEN,3))
  1. S FY=$P(NODE3,U,1)
  1. S RANGE=$$FYDAYS^PRSARC04(FY)
  1. S ST=$P(RANGE,U)
  1. S EN=$P(RANGE,U,2)
  1. S ST=$E(ST,4,5)_"/"_$E(ST,6,7)_"/"_$E(ST,2,3)
  1. S EN=$E(EN,4,5)_"/"_$E(EN,6,7)_"/"_$E(EN,2,3)
  1. S EXTRANGE=ST_U_EN
  1. S FYE=$$GETFSCYR^PRSARC04(FY-1700_"0101")
  1. S SELFY=FY_U_$P(FYE,U,3)_U_EXTRANGE_U_RANGE
  1. S X=$P(NODE3,U,2)
  1. D ^%DT
  1. S STDT=Y
  1. N D1,DAY S D1=STDT D PP^PRSAPPU
  1. S EXTSTDT=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
  1. S SELFY=SELFY_U_RWIEN_U_EXTSTDT_U_STDT_U_PPE
  1. Q SELFY
  1. VWMSG(MSG) ; roll and scroll message from listmanager call.
  1. D FULL^VALM1
  1. I MSG=1 D
  1. . W !!,"This is a view only option. You may not make any changes to the"
  1. . W !,"recess schedule. The Recess Hours Summary action is available.",!
  1. . S OUT=$$ASK^PRSLIB00(1)
  1. E D
  1. . I 'PRSVIEW W !!,"Recess Schedule not saved." S OUT=$$ASK^PRSLIB00(1)
  1. Q
  1. OTHERHRS(CTHW1,CTHW2,PRSNURSE) ; are any tour hours selected different than
  1. ; current tour hours.
  1. N ITEM,D1,TH,MISMATCH,K,PP4Y,PPE,PPI,Y,DAY,W1TMP,W2TMP
  1. S (MISMATCH,ITEM)=0
  1. F S ITEM=$O(^TMP("PRSSW",$J,ITEM)) Q:ITEM'>0!MISMATCH D
  1. . ; Get item out of selectable items index
  1. . S D1=$G(WKSFM(ITEM)) D PP^PRSAPPU
  1. . I $G(PPI)>0 D
  1. .. K TH D TOURHRS^PRSARC07(.TH,PPI,PRSNURSE,"")
  1. .. S W1TMP=$G(TH("W1"))
  1. .. S W2TMP=$G(TH("W2"))
  1. .. I W1TMP>0,W1TMP'=CTHW1 S MISMATCH=1 Q
  1. .. I W2TMP>0,W2TMP'=CTHW2 S MISMATCH=1 Q
  1. Q MISMATCH
  1. ;
  1. GETFLWKS(IEN,PRSDT) ; Get weeks/recess hours from 458.8 and any posted recess
  1. ; by way of the TT8b string. Update the list columns.
  1. ;
  1. ; INPUT: IEN from file 458.8
  1. ;
  1. N RW,RWDATA,REW,RWD1,D1,TMPDT,LSTITEM,RH,PPI,STR8B,PAD,RCPOSTED
  1. N X1,X2,X,%H S X1=PRSDT,X2=-1 D C^%DTC S TMPDT=X
  1. ;
  1. F S TMPDT=$O(^PRST(458.8,IEN,1,"AC",TMPDT)) Q:TMPDT'>0 D
  1. . S RW=$O(^PRST(458.8,IEN,1,"AC",TMPDT,0))
  1. . S RWDATA=^PRST(458.8,IEN,1,RW,0)
  1. . S RH=$P(RWDATA,U,2)
  1. . S RWD1=$P(RWDATA,U,3)
  1. . S REW=$P(RWDATA,U,4)
  1. . ; Get item number for week out of selectable items index
  1. . S LSTITEM=$G(^TMP("PRSLI",$J,+RWDATA))
  1. . D FLDTEXT^VALM10(LSTITEM,"RECESS HOURS",$J($P(RWDATA,U,2),15,2))
  1. . D FLDCTRL^VALM10(LSTITEM,"RECESS HOURS",,,1)
  1. . S ^TMP("PRSRW",$J,+RWDATA)=LSTITEM_U_RH_U_RWD1_U_REW
  1. ;D RPOSTED
  1. Q
  1. RPOSTED ; Get weeks posted
  1. ; get 8b from 5 node unless corrected timecard--then re decomp
  1. ;
  1. N WKDT,RW,STARTDT,STR8B,PAD,RCPOSTED,LSTITEM,RW
  1. S STARTDT=PRSDT
  1. N X1,X2,X,%H S X1=PRSDT,X2=-1 D C^%DTC S WKDT=X
  1. F S WKDT=$O(FMWKS(WKDT)) Q:WKDT'>0 D
  1. . S RW=$G(FMWKS(WKDT))
  1. . S PPI=+$G(^PRST(458,"AD",WKDT))
  1. . Q:PPI'>0
  1. . S STR8B=$$GET8B^PRSPUT3(PPI,+PRSNURSE)
  1. .; pad 8B for function
  1. . S PAD="12345678901234567890123456789012"
  1. . S RCPOSTED=$$CD8B^PRSU1B2(PAD_STR8B,"RS^3^RN^3",1)
  1. . S RCPOSTED=$P(RCPOSTED,U,$S(RW#2:1,1:2))
  1. . Q:RCPOSTED'>0
  1. . S LSTITEM=$G(^TMP("PRSLI",$J,RW))
  1. . D FLDTEXT^VALM10(LSTITEM,"RECESS POSTED",$J(RCPOSTED,7,2))
  1. . I +$G(^TMP("PRSRW",$J,+RW)) D
  1. .. S $P(^TMP("PRSRW",$J,+RW),U,5)=RCPOSTED
  1. . E D
  1. .. S ^TMP("PRSRW",$J,RW)=LSTITEM_U_U_U_U_RCPOSTED
  1. Q
  1. EVEODDWK(ODD,EVEN) ; CHECK SELECTION INDEX FOR ODD AND EVEN PP WEEKS
  1. N ITEM
  1. S (ODD,EVEN)=0
  1. S ITEM=0
  1. F S ITEM=$O(^TMP("PRSSW",$J,ITEM)) Q:ITEM'>0!(ODD&EVEN) D
  1. . I ITEM#2 S ODD=1
  1. . E S EVEN=1
  1. Q
  1. CHANGE(IEN) ; funtion true if file record is different than current data
  1. ;
  1. S VALMBCK="R"
  1. Q:$G(IEN)'>0 0
  1. N RW,RWDATA,REW,RH,RWD1,PRSFILED,ITEM,PRSLIST,WK
  1. S RW=0,PRSFILED="",PRSLIST=""
  1. F S RW=$O(^PRST(458.8,IEN,1,RW)) Q:RW'>0 D
  1. . S RWDATA=^PRST(458.8,IEN,1,RW,0)
  1. . S WK=+RWDATA
  1. . S RH=$P(RWDATA,U,2)
  1. . S RWD1=$P(RWDATA,U,3)
  1. . S REW=$P(RWDATA,U,4)
  1. . S PRSFILED=PRSFILED_WK_U_RH_U
  1. ;
  1. S ITEM=0
  1. F S ITEM=$O(^TMP("PRSRW",$J,ITEM)) Q:ITEM'>0 D
  1. . S RH=$P(^TMP("PRSRW",$J,ITEM),U,2)
  1. . I RH>0 S PRSLIST=PRSLIST_ITEM_U_RH_U
  1. Q PRSFILED'=PRSLIST
  1. ;==================================================================
  1. ;
  1. SETRECES ;SET HOURS FOR A WEEK AT A TIME
  1. ;
  1. S VALMBCK="R"
  1. I $G(PRSVIEW) D VWMSG^PRSARC03(1) Q
  1. ;
  1. N LSTITEM,CTRH1
  1. N ITEM,Y,RH1,RH2,OUT,HRSLEFT,HRDEFALT,CRH,TOURHRS,D1,PPI,PPE
  1. ;
  1. S VALMBCK="R"
  1. D SELRWK^PRSARC01("X",.OUT)
  1. Q:OUT
  1. ;get remaining hours to schedule for FY
  1. ;
  1. S (CRH,ITEM)=0
  1. F S ITEM=$O(^TMP("PRSSW",$J,ITEM)) Q:ITEM'>0!OUT D
  1. . S D1=$G(WKSFM(ITEM)) D PP^PRSAPPU
  1. . N TH D TOURHRS^PRSARC07(.TH,PPI,+PRSNURSE,"")
  1. . S CTRH1=+TH("W1"),CTRH2=+TH("W2")
  1. . S TOURHRS=$S(ITEM#2:CTRH1,1:CTRH2)
  1. . S HRSLEFT=$$HRSLEFT()
  1. . S CRH=+$P($G(^TMP("PRSRW",$J,ITEM)),U,2)
  1. . I HRSLEFT+CRH<TOURHRS D
  1. .. S HRDEFALT=HRSLEFT+CRH
  1. . E D
  1. .. S HRDEFALT=TOURHRS
  1. . I HRDEFALT<0 S HRDEFALT=0
  1. . N DIRUT,DIR,Y,VALID
  1. . S DIR(0)="N^0:72:2"
  1. . S DIR("B")=HRDEFALT
  1. . W !,"Recess hours remaining to schedule: ",HRSLEFT,!
  1. . S DIR("A")="Enter recess hours for week "_ITEM
  1. . S VALID=0
  1. . F D Q:VALID!OUT
  1. .. D ^DIR
  1. .. I (+Y#.25)=0 S VALID=1
  1. .. I +Y=0 S Y=""
  1. .. S RH=Y
  1. .. I $D(DIRUT) S OUT=1,RH=CRH
  1. . ; Get item from selectable index
  1. . S LSTITEM=$G(^TMP("PRSSW",$J,ITEM))
  1. . D FLDTEXT^VALM10(LSTITEM,"RECESS HOURS",$J(RH,15,2))
  1. .;
  1. .; set hrs for selected weeks, remove from array if zero
  1. .;
  1. . I RH'>0 D
  1. .. K ^TMP("PRSRW",$J,ITEM)
  1. . E D
  1. .. S $P(^TMP("PRSRW",$J,ITEM),U,2)=RH
  1. .. S $P(^TMP("PRSRW",$J,ITEM),U,3)=$G(WKSFM(ITEM))
  1. .. S $P(^TMP("PRSRW",$J,ITEM),U,4)=0
  1. ;
  1. D DSELALL^PRSARC01
  1. S VALMBCK="R"
  1. Q
  1. ;====================
  1. HRSLEFT() ; Get remaining hours available for recess for the FY
  1. ;
  1. N TRHA,WK,HRSWK,HRSUSED,PRSRWHRS
  1. S (WK,HRSUSED)=0
  1. F S WK=$O(^TMP("PRSRW",$J,WK)) Q:WK'>0 D
  1. . ; Get item out of recess weeks items index
  1. . S HRSWK=$P(^TMP("PRSRW",$J,WK),U,2)
  1. . S HRSUSED=HRSUSED+HRSWK
  1. S PRSRWHRS=$$GETAVHRS^PRSARC04(.FMWKS,PRSDT)
  1. S TRHA=$P($G(PRSRWHRS),U,2)
  1. Q TRHA-HRSUSED
  1. ;
  1. HRSFILED(IEN) ; funtion returns number of recess hours on file
  1. ;
  1. N RW,RWDATA,RH,HRSFILED
  1. S HRSFILED=0
  1. Q:$G(IEN)'>0 HRSFILED
  1. S RW=0,PRSFILED="",PRSLIST=""
  1. F S RW=$O(^PRST(458.8,IEN,1,RW)) Q:RW'>0 D
  1. . S RWDATA=^PRST(458.8,IEN,1,RW,0)
  1. . S RH=$P(RWDATA,U,2)
  1. . S HRSFILED=HRSFILED+RH
  1. Q HRSFILED
  1. ;==================================================================
  1. ;