PRSARC02 ;WOIFO/JAH - Recess Tracking Library Functions ;10/16/06
;;4.0;PAID;**112**;Sep 21, 1995;Build 54
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
GETNURSE(NURSE,PRSTLV) ; procedure prompts and screens only 9-month AWS nurses
;
;
; INPUT: PRSTLV - flag to indicate T&L access, 2 for timekeeper
; 3 for
; OUTPUT: NURSE (3 ^ pieces)
; 1) - Nurse IEN from 450 lookup which is screened for
; (DB part-time + NH 80 + pp M) or (recess rec exists)
; 2) Nurse name
; 3) 0 edit only, 1 add and edit
;
; use full screen for initial prompts
D FULL^VALM1
W @IOF,!!!
;
;Ask T&L unit
;
N TLI,TLE,SSN,DUMMY
I $G(PRSTLV)'>0 Q -1
D ^PRSAUTL
I $G(TLE)="" Q -1
;
;Lookup employees screening on t&l, normal hours, duty basis, pay plan
;
N DIC,D
S DIC("A")="Select AWS NURSE: "
S DIC(0)="AEQM"
S DIC="^PRSPC("
S D="ATL"_TLE
S DIC("S")="I $P(^(0),U,8)=TLE,(($P(^(0),U,16)=80)&($P(^(0),U,10)=2)&($P(^(0),U,21)=""M""))!($O(^PRST(458.8,""B"",+Y,0)))"
D IX^DIC
S NURSE=Y
I +NURSE'>0 Q -1
;
; ensure entitlement string returns recess periods set to 1
;
N DFN,ENT,ZENT
S DFN=+NURSE
D ^PRSAENT S ZENT=$S($E(ENT,5):"Recess Periods",1:"")
I ZENT="" D
. W !!?5,"This nurse is not currently entitled to Recess Periods."
. W !?5,"A new FY Recess Record cannot be added, but existing FY"
. W !?5,"Recess records may be edited."
. W ! S DUMMY=$$ASK^PRSLIB00(1)
. S NURSE=NURSE_U_0
E D
. S NURSE=NURSE_U_1
S SSN=$P(^PRSPC(+NURSE,0),U,9),SSN="XXX-XX-"_$E(SSN,6,9)
S NURSE=NURSE_U_TLE_U_SSN
Q
;
CHOOSEFY(SELFY,NURSE) ; Build List of FY choices--Last, Current, Next--include
; whether a record exists for that fiscal year already or not
;
; INPUT: NURSE- IEN^NAME^(0 edit only, 1 add and edit)
; if nurse entitled to recess, new rec can be added, else
; only edit existing records allowed.
; OUTPUT: SELFY-selected fiscal year data (11 ^ piece string)
; 1) 4 digit yr 2) ex.FY06-07 3) external 1st day
; 4) external last day 5) FM 1st day 6) FM last day
; 7) first pp 8) last pp 9) 458.8 IEN if exists
; 10) ext AWS start date 11) FM date AWS start
; 12) AWS start pay period
;
; example:
; 2007^FY06-07^10/01/06^10/13/07^3061001^3071013^06-20^07-20^1
; ^11/12/06^3061112^06-23
;
; entitled to Recess
N RENT,FYA,FYSA
S RENT=$P(NURSE,U,3)
;
; check to see if any Schedules are on file for this Nurse
;
D FIND^DIC(458.8,,".01;1;1.1","Q",+NURSE,"AC",,,,"FYA")
;
; get current next and last
;
D PRMPTARY
;
; if there are no editable records in the range and the Nurse
; isn't entitled then the gig is up.
;
I 'RENT&($P(FYSA(1),U,9)=""&($P(FYSA(2),U,9)="")&($P(FYSA(3),U,9)="")) D Q
. W !,$P(NURSE,U,2)," has no AWS schedules in the current, next or last fiscal years."
;
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,CHOICE,CH,DIRUT
S DIR(0)=$$BLDDIR(.FYSA,.CHOICE,RENT)
S CH=CHOICE
I $L(CHOICE)=3 S CH=$E(CHOICE,1)_", "_$E(CHOICE,2)_" or "_$E(CHOICE,3)
E I $L(CHOICE)=2 S CH=$E(CHOICE,1)_" or "_$E(CHOICE,2)
S DIR("?")=" Enter "_CH_" to "_$S(RENT:"add or edit",1:"edit")_" the recess schedule for that fiscal year."
S DIR("?",1)=" Edit a fiscal year by entering the code on the left."
S DIR("?",2)=" The available choices for editing a 9 month AWS"
S DIR("?",3)=" recess record are limited to the current, next and last"
S DIR("?",4)=" fiscal years. If the nurse has an AWS record on file"
S DIR("?",5)=" for the current, next or last fiscal year then the"
S DIR("?",6)=" record may be edited. To add a new schedule the nurse"
S DIR("?",7)=" must have a pay plan of M, a duty basis of part-time"
S DIR("?",8)=" and normal Hours equal to 80."
S DIR("A")="Select fiscal year"
S DIR("B")=$E(CHOICE,1)
D ^DIR
I $D(DIRUT) S SELFY=0
E S SELFY=FYSA($S(Y="C":1,Y="N":2,1:3))
Q
;
PRMPTARY ; Build array w/fiscal year selections to edit
N FY,CNT,REC,FOUND,ST,EN,RANGE,RWIEN,CUR,CUR4Y,EXTRANGE,PPE,STDT
N X,TMPDT,EXTSTDT,LAS,LAS4Y,NEX,NEX4Y
S CUR=$$GETFSCYR^PRSARC04(DT)
S CUR4Y=+$E(CUR,1,3)
S TMPDT=CUR4Y+1_"0101"
S NEX=$$GETFSCYR^PRSARC04(TMPDT)
S NEX4Y=+$E(NEX,1,3)
S TMPDT=NEX4Y-2_"0101"
S LAS=$$GETFSCYR^PRSARC04(TMPDT)
S LAS4Y=+$E(LAS,1,3)
S CUR4Y=CUR4Y+1700
S NEX4Y=NEX4Y+1700
S LAS4Y=LAS4Y+1700
;
S CNT=0
F FY=CUR4Y,NEX4Y,LAS4Y D
. S CNT=CNT+1
. S (REC,FOUND)=0
. F S REC=$O(FYA("DILIST","ID",REC)) Q:REC'>0!(FOUND) D
.. I FYA("DILIST","ID",REC,1)=FY S FOUND=REC,RWIEN=FYA("DILIST",2,REC)
. S RANGE=$$FYDAYS^PRSARC04(FY)
. S ST=$P(RANGE,U)
. S EN=$P(RANGE,U,2)
. S ST=$E(ST,4,5)_"/"_$E(ST,6,7)_"/"_$E(ST,2,3)
. S EN=$E(EN,4,5)_"/"_$E(EN,6,7)_"/"_$E(EN,2,3)
. S EXTRANGE=ST_U_EN
. S FYSA(CNT)=$S(CNT=2:NEX4Y,CNT=1:CUR4Y,1:LAS4Y)
. S FYSA(CNT)=FYSA(CNT)_U_$P($S(CNT=2:NEX,CNT=1:CUR,1:LAS),U,3)_U_EXTRANGE_U_RANGE
. I FOUND D
.. ;convert start date to mm/dd/yy
.. S X=$G(FYA("DILIST","ID",FOUND,1.1))
.. D ^%DT
.. S STDT=Y
.. N D1 S D1=STDT D PP^PRSAPPU
.. S EXTSTDT=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
.. S FYSA(CNT)=FYSA(CNT)_U_RWIEN_U_EXTSTDT_U_STDT_U_PPE
. E D
.. S FYSA(CNT)=FYSA(CNT)_U_U_U
;
Q
BLDDIR(FYSA,CHOICES,RENT) ; Put Set of Codes for DIR into DIR(0) format
I '$D(FYSA) W !,"Error: no fiscal year data!",!! Q
;
N CNT,CI,SOC,AW,SELI,NR
S CNT=0
S NR="-has no existing record."
S AW="-has AWS start date "
;
; SOC -set of codes
;
N SOC S SOC="",CHOICES=""
F SELI="Current","Next","Last" D
. S CNT=CNT+1
. S CI=$G(FYSA(CNT))
. Q:RENT=0&($P(CI,U,9)="")
. S CHOICES=CHOICES_$S(CNT=1:"C",CNT=2:"N",1:"L")
. I SOC="" D
.. S SOC="S^"_$S(CNT=1:"C:",CNT=2:"N:",1:"L:")
. E D
.. S SOC=SOC_$S(CNT=2:";N:",1:";L:")
. S SOC=SOC_SELI_" FY"_$P(CI,U,1)_" begins "_$P(CI,U,3)_$S($P(CI,U,9)'="":AW_$P(CI,U,10),1:NR)
Q SOC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSARC02 6038 printed Dec 13, 2024@02:24:05 Page 2
PRSARC02 ;WOIFO/JAH - Recess Tracking Library Functions ;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
GETNURSE(NURSE,PRSTLV) ; procedure prompts and screens only 9-month AWS nurses
+1 ;
+2 ;
+3 ; INPUT: PRSTLV - flag to indicate T&L access, 2 for timekeeper
+4 ; 3 for
+5 ; OUTPUT: NURSE (3 ^ pieces)
+6 ; 1) - Nurse IEN from 450 lookup which is screened for
+7 ; (DB part-time + NH 80 + pp M) or (recess rec exists)
+8 ; 2) Nurse name
+9 ; 3) 0 edit only, 1 add and edit
+10 ;
+11 ; use full screen for initial prompts
+12 DO FULL^VALM1
+13 WRITE @IOF,!!!
+14 ;
+15 ;Ask T&L unit
+16 ;
+17 NEW TLI,TLE,SSN,DUMMY
+18 IF $GET(PRSTLV)'>0
QUIT -1
+19 DO ^PRSAUTL
+20 IF $GET(TLE)=""
QUIT -1
+21 ;
+22 ;Lookup employees screening on t&l, normal hours, duty basis, pay plan
+23 ;
+24 NEW DIC,D
+25 SET DIC("A")="Select AWS NURSE: "
+26 SET DIC(0)="AEQM"
+27 SET DIC="^PRSPC("
+28 SET D="ATL"_TLE
+29 SET DIC("S")="I $P(^(0),U,8)=TLE,(($P(^(0),U,16)=80)&($P(^(0),U,10)=2)&($P(^(0),U,21)=""M""))!($O(^PRST(458.8,""B"",+Y,0)))"
+30 DO IX^DIC
+31 SET NURSE=Y
+32 IF +NURSE'>0
QUIT -1
+33 ;
+34 ; ensure entitlement string returns recess periods set to 1
+35 ;
+36 NEW DFN,ENT,ZENT
+37 SET DFN=+NURSE
+38 DO ^PRSAENT
SET ZENT=$SELECT($EXTRACT(ENT,5):"Recess Periods",1:"")
+39 IF ZENT=""
Begin DoDot:1
+40 WRITE !!?5,"This nurse is not currently entitled to Recess Periods."
+41 WRITE !?5,"A new FY Recess Record cannot be added, but existing FY"
+42 WRITE !?5,"Recess records may be edited."
+43 WRITE !
SET DUMMY=$$ASK^PRSLIB00(1)
+44 SET NURSE=NURSE_U_0
End DoDot:1
+45 IF '$TEST
Begin DoDot:1
+46 SET NURSE=NURSE_U_1
End DoDot:1
+47 SET SSN=$PIECE(^PRSPC(+NURSE,0),U,9)
SET SSN="XXX-XX-"_$EXTRACT(SSN,6,9)
+48 SET NURSE=NURSE_U_TLE_U_SSN
+49 QUIT
+50 ;
CHOOSEFY(SELFY,NURSE) ; Build List of FY choices--Last, Current, Next--include
+1 ; whether a record exists for that fiscal year already or not
+2 ;
+3 ; INPUT: NURSE- IEN^NAME^(0 edit only, 1 add and edit)
+4 ; if nurse entitled to recess, new rec can be added, else
+5 ; only edit existing records allowed.
+6 ; OUTPUT: SELFY-selected fiscal year data (11 ^ piece string)
+7 ; 1) 4 digit yr 2) ex.FY06-07 3) external 1st day
+8 ; 4) external last day 5) FM 1st day 6) FM last day
+9 ; 7) first pp 8) last pp 9) 458.8 IEN if exists
+10 ; 10) ext AWS start date 11) FM date AWS start
+11 ; 12) AWS start pay period
+12 ;
+13 ; example:
+14 ; 2007^FY06-07^10/01/06^10/13/07^3061001^3071013^06-20^07-20^1
+15 ; ^11/12/06^3061112^06-23
+16 ;
+17 ; entitled to Recess
+18 NEW RENT,FYA,FYSA
+19 SET RENT=$PIECE(NURSE,U,3)
+20 ;
+21 ; check to see if any Schedules are on file for this Nurse
+22 ;
+23 DO FIND^DIC(458.8,,".01;1;1.1","Q",+NURSE,"AC",,,,"FYA")
+24 ;
+25 ; get current next and last
+26 ;
+27 DO PRMPTARY
+28 ;
+29 ; if there are no editable records in the range and the Nurse
+30 ; isn't entitled then the gig is up.
+31 ;
+32 IF 'RENT&($PIECE(FYSA(1),U,9)=""&($PIECE(FYSA(2),U,9)="")&($PIECE(FYSA(3),U,9)=""))
Begin DoDot:1
+33 WRITE !,$PIECE(NURSE,U,2)," has no AWS schedules in the current, next or last fiscal years."
End DoDot:1
QUIT
+34 ;
+35 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,CHOICE,CH,DIRUT
+36 SET DIR(0)=$$BLDDIR(.FYSA,.CHOICE,RENT)
+37 SET CH=CHOICE
+38 IF $LENGTH(CHOICE)=3
SET CH=$EXTRACT(CHOICE,1)_", "_$EXTRACT(CHOICE,2)_" or "_$EXTRACT(CHOICE,3)
+39 IF '$TEST
IF $LENGTH(CHOICE)=2
SET CH=$EXTRACT(CHOICE,1)_" or "_$EXTRACT(CHOICE,2)
+40 SET DIR("?")=" Enter "_CH_" to "_$SELECT(RENT:"add or edit",1:"edit")_" the recess schedule for that fiscal year."
+41 SET DIR("?",1)=" Edit a fiscal year by entering the code on the left."
+42 SET DIR("?",2)=" The available choices for editing a 9 month AWS"
+43 SET DIR("?",3)=" recess record are limited to the current, next and last"
+44 SET DIR("?",4)=" fiscal years. If the nurse has an AWS record on file"
+45 SET DIR("?",5)=" for the current, next or last fiscal year then the"
+46 SET DIR("?",6)=" record may be edited. To add a new schedule the nurse"
+47 SET DIR("?",7)=" must have a pay plan of M, a duty basis of part-time"
+48 SET DIR("?",8)=" and normal Hours equal to 80."
+49 SET DIR("A")="Select fiscal year"
+50 SET DIR("B")=$EXTRACT(CHOICE,1)
+51 DO ^DIR
+52 IF $DATA(DIRUT)
SET SELFY=0
+53 IF '$TEST
SET SELFY=FYSA($SELECT(Y="C":1,Y="N":2,1:3))
+54 QUIT
+55 ;
PRMPTARY ; Build array w/fiscal year selections to edit
+1 NEW FY,CNT,REC,FOUND,ST,EN,RANGE,RWIEN,CUR,CUR4Y,EXTRANGE,PPE,STDT
+2 NEW X,TMPDT,EXTSTDT,LAS,LAS4Y,NEX,NEX4Y
+3 SET CUR=$$GETFSCYR^PRSARC04(DT)
+4 SET CUR4Y=+$EXTRACT(CUR,1,3)
+5 SET TMPDT=CUR4Y+1_"0101"
+6 SET NEX=$$GETFSCYR^PRSARC04(TMPDT)
+7 SET NEX4Y=+$EXTRACT(NEX,1,3)
+8 SET TMPDT=NEX4Y-2_"0101"
+9 SET LAS=$$GETFSCYR^PRSARC04(TMPDT)
+10 SET LAS4Y=+$EXTRACT(LAS,1,3)
+11 SET CUR4Y=CUR4Y+1700
+12 SET NEX4Y=NEX4Y+1700
+13 SET LAS4Y=LAS4Y+1700
+14 ;
+15 SET CNT=0
+16 FOR FY=CUR4Y,NEX4Y,LAS4Y
Begin DoDot:1
+17 SET CNT=CNT+1
+18 SET (REC,FOUND)=0
+19 FOR
SET REC=$ORDER(FYA("DILIST","ID",REC))
if REC'>0!(FOUND)
QUIT
Begin DoDot:2
+20 IF FYA("DILIST","ID",REC,1)=FY
SET FOUND=REC
SET RWIEN=FYA("DILIST",2,REC)
End DoDot:2
+21 SET RANGE=$$FYDAYS^PRSARC04(FY)
+22 SET ST=$PIECE(RANGE,U)
+23 SET EN=$PIECE(RANGE,U,2)
+24 SET ST=$EXTRACT(ST,4,5)_"/"_$EXTRACT(ST,6,7)_"/"_$EXTRACT(ST,2,3)
+25 SET EN=$EXTRACT(EN,4,5)_"/"_$EXTRACT(EN,6,7)_"/"_$EXTRACT(EN,2,3)
+26 SET EXTRANGE=ST_U_EN
+27 SET FYSA(CNT)=$SELECT(CNT=2:NEX4Y,CNT=1:CUR4Y,1:LAS4Y)
+28 SET FYSA(CNT)=FYSA(CNT)_U_$PIECE($SELECT(CNT=2:NEX,CNT=1:CUR,1:LAS),U,3)_U_EXTRANGE_U_RANGE
+29 IF FOUND
Begin DoDot:2
+30 ;convert start date to mm/dd/yy
+31 SET X=$GET(FYA("DILIST","ID",FOUND,1.1))
+32 DO ^%DT
+33 SET STDT=Y
+34 NEW D1
SET D1=STDT
DO PP^PRSAPPU
+35 SET EXTSTDT=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+36 SET FYSA(CNT)=FYSA(CNT)_U_RWIEN_U_EXTSTDT_U_STDT_U_PPE
End DoDot:2
+37 IF '$TEST
Begin DoDot:2
+38 SET FYSA(CNT)=FYSA(CNT)_U_U_U
End DoDot:2
End DoDot:1
+39 ;
+40 QUIT
BLDDIR(FYSA,CHOICES,RENT) ; Put Set of Codes for DIR into DIR(0) format
+1 IF '$DATA(FYSA)
WRITE !,"Error: no fiscal year data!",!!
QUIT
+2 ;
+3 NEW CNT,CI,SOC,AW,SELI,NR
+4 SET CNT=0
+5 SET NR="-has no existing record."
+6 SET AW="-has AWS start date "
+7 ;
+8 ; SOC -set of codes
+9 ;
+10 NEW SOC
SET SOC=""
SET CHOICES=""
+11 FOR SELI="Current","Next","Last"
Begin DoDot:1
+12 SET CNT=CNT+1
+13 SET CI=$GET(FYSA(CNT))
+14 if RENT=0&($PIECE(CI,U,9)="")
QUIT
+15 SET CHOICES=CHOICES_$SELECT(CNT=1:"C",CNT=2:"N",1:"L")
+16 IF SOC=""
Begin DoDot:2
+17 SET SOC="S^"_$SELECT(CNT=1:"C:",CNT=2:"N:",1:"L:")
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 SET SOC=SOC_$SELECT(CNT=2:";N:",1:";L:")
End DoDot:2
+20 SET SOC=SOC_SELI_" FY"_$PIECE(CI,U,1)_" begins "_$PIECE(CI,U,3)_$SELECT($PIECE(CI,U,9)'="":AW_$PIECE(CI,U,10),1:NR)
End DoDot:1
+21 QUIT SOC
