PRSNAA01 ;WOIFO/DWA - Pay period approval for Nurse POC records;10/5/2009
;;4.0;PAID;**126**;Sep 21, 1995;Build 59
;;Per VHA Directive 2004-038,this routine should not be modified.
Q
EN ; Entry point for approval of POC records for a pay period.
N A,B,DAY,DAYREC,DIC,DIR,DIRUT,DSPFLG,GROUP,GRPIEN,GRPSC,I,IEN200
N IEN450,NURSNM,PAYPD,PREVPD,PRSD,PRSFLG,PRSIEN,PRSPD,PRSPDE
N PRSPDI,PRSPRM,PRSSTAT,STOP,REC,SEG
K ^TMP($J,"PRSNAA")
D ACCESS^PRSNUT02(.GROUP,"A",DT)
I $P($G(GROUP(0)),U,2)="E" D Q
. W !!,"There are no groups assigned or selected."
;
S PRSPRM=$P(GROUP(0),U,2)
S STOP=0
S GRPIEN=0,GRPIEN=$O(GROUP(GRPIEN))
I PRSPRM="N" S GRPSC=$P(GROUP(GRPIEN),U,4)
S PRSPDI=$G(^PRST(458,"AD",DT)) S:PRSPDI="" PRSPDI=$G(^PRST(458,"AD",$O(^PRST(458,"AD",":"),-1)))
I $P(PRSPDI,U,2)<12 S PRSPDI=+PRSPDI-1
E S PRSPDI=+PRSPDI
;
D PREV
I PRSFLG D SETPPD
I 'PRSFLG W "There are no POC records to approve for this "_$S(PRSPRM="N":"Nurse Location.",1:"T&L Unit.")
;
D CLEANUP
;
Q
;
SETPPD ; back up default of current pay period if it doesn't have any data
S PRSPDI=$O(^TMP($J,"PRSNAA",PRSPDI+1),-1)
;
N DIC,X,Y,DUOUT,DTOUT
S DIC("B")=PRSPDI
S DIC="^PRSN(451,",DIC(0)="AEQMZ"
S DIC("A")="Select a Pay Period: "
S DIC("S")="I +Y'>PRSPDI&($D(^TMP($J,""PRSNAA"",+Y)))"
D ^DIC
Q:$D(DUOUT)!$D(DTOUT)!(+$G(Y)'>0)
S PRSPDE=$P(^PRST(458,+Y,0),U)
;
;no need to have separate approval subroutines because
;they have already been filtered by PREV subroutine
;just set date to selected date and process
I +Y<PRSPDI S PRSPDI=+Y
D APPREV
;
Q
PREV ;
N PREVPD,PRSNAM
S (PRSFLG,PRSIEN,PRSSTAT)=0
F S PRSIEN=$O(^PRSN(451,"AE",PRSIEN)) Q:'PRSIEN D
.; if the access parameter matches the current nurses location or T&L unit, then display
.;
. S PREVPD=0
. S PRSNAM=$P($G(^PRSPC(PRSIEN,0)),U)
. I PRSNAM="" S PRSNAM=" "
. N PML,TLI,TLE
. S PML=+$$PRIMLOC^PRSNUT03($P($G(^PRSPC(PRSIEN,200)),U))
. I PRSPRM="N"&(PML=+GROUP(GRPIEN)) D
.. F S PREVPD=$O(^PRSN(451,"AE",PRSIEN,PREVPD)) Q:'PREVPD!(PREVPD>PRSPDI) D
... S ^TMP($J,"PRSNAA",PREVPD,PRSNAM,PRSIEN)="",PRSFLG=1
. I PRSPRM="T" D
.. S TLE=$P($G(^PRSPC(PRSIEN,0)),U,8)
.. S TLI=$S(TLE="":"",1:$O(^PRST(455.5,"B",TLE,"")))
.. F S PREVPD=$O(^PRSN(451,"AE",PRSIEN,PREVPD)) Q:'PREVPD!(PREVPD>PRSPDI) D
... ;separated employee, get T&L from archived time record
... I TLE="" D
.... N PAYPRD
.... S PAYPRD=$P($G(^PRST(458,PREVPD,0)),U)
.... D CHECKTLE^PRSADP2(PAYPRD,PRSIEN,.TLE)
.... S TLI=$S(TLE="":"",1:$O(^PRST(455.5,"B",TLE,"")))
... I TLI=+GROUP(GRPIEN) D
.... S ^TMP($J,"PRSNAA",PREVPD,PRSNAM,PRSIEN)="",PRSFLG=1
I PRSFLG D DSPREV
W !!
;
Q
;
DSPREV ; Display previous pay period records
;
W !!,"The following previous pay periods have unapproved POC records"
W !,"in this "_$S(PRSPRM="N":"Nurse Location",1:"T&L Unit")_":",!!
S PREVPD=0
F S PREVPD=$O(^TMP($J,"PRSNAA",PREVPD)) Q:'PREVPD D
. W "Pay period ",$P(^PRST(458,PREVPD,0),U),!
;
Q
;
APPROV(PRSPD,PRSIEN) ; Complete approval process
N DAY,DAYREC,REC,SEG,DSPFLG,Y
S DSPFLG=0
F DAY=1:1:14 D
. K DAYREC
. D L1^PRSNRUT1(.DAYREC,PRSPD,PRSIEN,DAY)
. Q:'$O(DAYREC(0))
. S SEG=0,DSPFLG=1
. F S SEG=$O(DAYREC(SEG)) Q:'SEG D
. . S REC(DAY,SEG)=DAYREC(SEG)
. D SETREC(.REC,PRSPD)
Q:'DSPFLG
D DSPMM(PRSIEN,PRSPD)
Q:STOP
D HDR(PRSPD,PRSIEN)
D DSPREC(.REC)
Q:STOP
D ACTION(PRSPD,PRSIEN)
Q
;
APPREV ; Process previous pay periods
N A,B,C
;
S A=PRSPDI,B=""
F S B=$O(^TMP($J,"PRSNAA",A,B)) Q:(B="")!STOP D
. S C=""
. F S C=$O(^TMP($J,"PRSNAA",A,B,C)) Q:(C="")!STOP D
.. D APPROV(A,C)
Q
;
SETREC(REC,PAYPD) ; Set up record for display
;
N A,B
S (A,B)=0
F S A=$O(REC(A)) Q:'A D
. F S B=$O(REC(A,B)) Q:'B D
. . S:$P(REC(A,B),U,5)]""&($P(REC(A,B),U,5)?1.N) $P(REC(A,B),U,5)=$P($$ISACTIVE^PRSNUT01(DT,$P(REC(A,B),U,5)),U,2)
. . S:$P(REC(A,B),U,6)]""&($P(REC(A,B),U,6)?1.N) $P(REC(A,B),U,6)=$P(^PRSN(451.5,$P(REC(A,B),U,6),0),U,2)
. . S:$P(REC(A,B),U,8)]""&($P(REC(A,B),U,8)?1.N) $P(REC(A,B),U,8)=$P(^PRSN(451.6,$P(REC(A,B),U,8),0),U,2)
. . QUIT
. I $O(REC(A,0)) S $P(REC(A,$O(REC(A,0))),U,12)=$P(^PRST(458,PAYPD,2),U,A)
. QUIT
;
QUIT
;
DSPREC(REC) ; Display the record
N A,B
S (A,B)=0
F S A=$O(REC(A)) Q:'A D Q:STOP
. F S B=$O(REC(A,B)) Q:'B D Q:STOP
. . W $P($P(REC(A,B),U,12)," "),?12,$P(REC(A,B),U),?21,$P(REC(A,B),U,3)
. . W ?28,$P(REC(A,B),U,4),?38,$P($P(REC(A,B),U,5)," ")
. . W ?51,$P($P(REC(A,B),U,6)," "),?64,$P($P(REC(A,B),U,8)," ")
. . W ?77,$P(REC(A,B),U,7),!
. . W $P($P(REC(A,B),U,12)," ",2,999),?12,$P(REC(A,B),U,2),?38
. . W $P($P(REC(A,B),U,5)," ",2),?51,$P($P(REC(A,B),U,6)," ",2),?64
. . W $P($P(REC(A,B),U,8)," ",2),!
. . ;
. . I (IOSL-6)<$Y S STOP=$$ASK^PRSLIB00() I 'STOP D HDR(PRSPD,PRSIEN) W !
. W !
;
Q
;
DSPMM(PRSIEN,PRSPD) ; Display mismatch report
D PPMM^PRSNRMM(PRSIEN,PRSPD,,.STOP)
Q:STOP
W !!,?5,"Return to Approvals.",!
S STOP=$$ASK^PRSLIB00(1)
Q
;
ACTION(A,B) ; Approve or bypass current record
N DIR,X,Y
S PAYPD=A,PRSIEN=B
S DIR("A")="Enter an 'A' to Approve or Return to Bypass: "
S DIR(0)="SAO^A:Approve" D ^DIR ;K DIR
I Y="" Q
I $D(DIRUT) S STOP=1 Q
I Y="A" D UPDTPOC^PRSNCGR1(PAYPD,PRSIEN,Y)
;
Q
;
HDR(PAYPD,IEN450) ;
;
S PRSPDE=$$GET1^DIQ(458,PAYPD,.01),PRSIEN=IEN450
W:$E(IOST,1,2)="C-" @IOF
W $$GET1^DIQ(450,PRSIEN,.01),?26,"Approve Pay Period POC Records"
W ?66,"Pay Pd: ",PRSPDE,!!
W "Date",?12,"Start/",?20,"Meal",?26,"Type of",?38,"Location",?51
W "Type of",?66,"OT",?76,"OT",!
W ?12,"Stop",?27,"Time",?52,"Work",?64,"Reason",?75,"Mand",!
F I=1:1:80 W "-"
;
Q
;
CLEANUP ;
K PRSIEN,PRSPDI,PRSPDE,GROUP,GRPIEN,GRPSC,REC,NURSNM,IEN200
K PRSFLG,DSPFLG,PREVPD,PRSPRM,PRSSTAT,PRSD,A,B,Y,X,DIC
K ^TMP($J,"PRSNAA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSNAA01 5897 printed Sep 23, 2025@20:03:27 Page 2
PRSNAA01 ;WOIFO/DWA - Pay period approval for Nurse POC records;10/5/2009
+1 ;;4.0;PAID;**126**;Sep 21, 1995;Build 59
+2 ;;Per VHA Directive 2004-038,this routine should not be modified.
+3 QUIT
EN ; Entry point for approval of POC records for a pay period.
+1 NEW A,B,DAY,DAYREC,DIC,DIR,DIRUT,DSPFLG,GROUP,GRPIEN,GRPSC,I,IEN200
+2 NEW IEN450,NURSNM,PAYPD,PREVPD,PRSD,PRSFLG,PRSIEN,PRSPD,PRSPDE
+3 NEW PRSPDI,PRSPRM,PRSSTAT,STOP,REC,SEG
+4 KILL ^TMP($JOB,"PRSNAA")
+5 DO ACCESS^PRSNUT02(.GROUP,"A",DT)
+6 IF $PIECE($GET(GROUP(0)),U,2)="E"
Begin DoDot:1
+7 WRITE !!,"There are no groups assigned or selected."
End DoDot:1
QUIT
+8 ;
+9 SET PRSPRM=$PIECE(GROUP(0),U,2)
+10 SET STOP=0
+11 SET GRPIEN=0
SET GRPIEN=$ORDER(GROUP(GRPIEN))
+12 IF PRSPRM="N"
SET GRPSC=$PIECE(GROUP(GRPIEN),U,4)
+13 SET PRSPDI=$GET(^PRST(458,"AD",DT))
if PRSPDI=""
SET PRSPDI=$GET(^PRST(458,"AD",$ORDER(^PRST(458,"AD",":"),-1)))
+14 IF $PIECE(PRSPDI,U,2)<12
SET PRSPDI=+PRSPDI-1
+15 IF '$TEST
SET PRSPDI=+PRSPDI
+16 ;
+17 DO PREV
+18 IF PRSFLG
DO SETPPD
+19 IF 'PRSFLG
WRITE "There are no POC records to approve for this "_$SELECT(PRSPRM="N":"Nurse Location.",1:"T&L Unit.")
+20 ;
+21 DO CLEANUP
+22 ;
+23 QUIT
+24 ;
SETPPD ; back up default of current pay period if it doesn't have any data
+1 SET PRSPDI=$ORDER(^TMP($JOB,"PRSNAA",PRSPDI+1),-1)
+2 ;
+3 NEW DIC,X,Y,DUOUT,DTOUT
+4 SET DIC("B")=PRSPDI
+5 SET DIC="^PRSN(451,"
SET DIC(0)="AEQMZ"
+6 SET DIC("A")="Select a Pay Period: "
+7 SET DIC("S")="I +Y'>PRSPDI&($D(^TMP($J,""PRSNAA"",+Y)))"
+8 DO ^DIC
+9 if $DATA(DUOUT)!$DATA(DTOUT)!(+$GET(Y)'>0)
QUIT
+10 SET PRSPDE=$PIECE(^PRST(458,+Y,0),U)
+11 ;
+12 ;no need to have separate approval subroutines because
+13 ;they have already been filtered by PREV subroutine
+14 ;just set date to selected date and process
+15 IF +Y<PRSPDI
SET PRSPDI=+Y
+16 DO APPREV
+17 ;
+18 QUIT
PREV ;
+1 NEW PREVPD,PRSNAM
+2 SET (PRSFLG,PRSIEN,PRSSTAT)=0
+3 FOR
SET PRSIEN=$ORDER(^PRSN(451,"AE",PRSIEN))
if 'PRSIEN
QUIT
Begin DoDot:1
+4 ; if the access parameter matches the current nurses location or T&L unit, then display
+5 ;
+6 SET PREVPD=0
+7 SET PRSNAM=$PIECE($GET(^PRSPC(PRSIEN,0)),U)
+8 IF PRSNAM=""
SET PRSNAM=" "
+9 NEW PML,TLI,TLE
+10 SET PML=+$$PRIMLOC^PRSNUT03($PIECE($GET(^PRSPC(PRSIEN,200)),U))
+11 IF PRSPRM="N"&(PML=+GROUP(GRPIEN))
Begin DoDot:2
+12 FOR
SET PREVPD=$ORDER(^PRSN(451,"AE",PRSIEN,PREVPD))
if 'PREVPD!(PREVPD>PRSPDI)
QUIT
Begin DoDot:3
+13 SET ^TMP($JOB,"PRSNAA",PREVPD,PRSNAM,PRSIEN)=""
SET PRSFLG=1
End DoDot:3
End DoDot:2
+14 IF PRSPRM="T"
Begin DoDot:2
+15 SET TLE=$PIECE($GET(^PRSPC(PRSIEN,0)),U,8)
+16 SET TLI=$SELECT(TLE="":"",1:$ORDER(^PRST(455.5,"B",TLE,"")))
+17 FOR
SET PREVPD=$ORDER(^PRSN(451,"AE",PRSIEN,PREVPD))
if 'PREVPD!(PREVPD>PRSPDI)
QUIT
Begin DoDot:3
+18 ;separated employee, get T&L from archived time record
+19 IF TLE=""
Begin DoDot:4
+20 NEW PAYPRD
+21 SET PAYPRD=$PIECE($GET(^PRST(458,PREVPD,0)),U)
+22 DO CHECKTLE^PRSADP2(PAYPRD,PRSIEN,.TLE)
+23 SET TLI=$SELECT(TLE="":"",1:$ORDER(^PRST(455.5,"B",TLE,"")))
End DoDot:4
+24 IF TLI=+GROUP(GRPIEN)
Begin DoDot:4
+25 SET ^TMP($JOB,"PRSNAA",PREVPD,PRSNAM,PRSIEN)=""
SET PRSFLG=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 IF PRSFLG
DO DSPREV
+27 WRITE !!
+28 ;
+29 QUIT
+30 ;
DSPREV ; Display previous pay period records
+1 ;
+2 WRITE !!,"The following previous pay periods have unapproved POC records"
+3 WRITE !,"in this "_$SELECT(PRSPRM="N":"Nurse Location",1:"T&L Unit")_":",!!
+4 SET PREVPD=0
+5 FOR
SET PREVPD=$ORDER(^TMP($JOB,"PRSNAA",PREVPD))
if 'PREVPD
QUIT
Begin DoDot:1
+6 WRITE "Pay period ",$PIECE(^PRST(458,PREVPD,0),U),!
End DoDot:1
+7 ;
+8 QUIT
+9 ;
APPROV(PRSPD,PRSIEN) ; Complete approval process
+1 NEW DAY,DAYREC,REC,SEG,DSPFLG,Y
+2 SET DSPFLG=0
+3 FOR DAY=1:1:14
Begin DoDot:1
+4 KILL DAYREC
+5 DO L1^PRSNRUT1(.DAYREC,PRSPD,PRSIEN,DAY)
+6 if '$ORDER(DAYREC(0))
QUIT
+7 SET SEG=0
SET DSPFLG=1
+8 FOR
SET SEG=$ORDER(DAYREC(SEG))
if 'SEG
QUIT
Begin DoDot:2
+9 SET REC(DAY,SEG)=DAYREC(SEG)
End DoDot:2
+10 DO SETREC(.REC,PRSPD)
End DoDot:1
+11 if 'DSPFLG
QUIT
+12 DO DSPMM(PRSIEN,PRSPD)
+13 if STOP
QUIT
+14 DO HDR(PRSPD,PRSIEN)
+15 DO DSPREC(.REC)
+16 if STOP
QUIT
+17 DO ACTION(PRSPD,PRSIEN)
+18 QUIT
+19 ;
APPREV ; Process previous pay periods
+1 NEW A,B,C
+2 ;
+3 SET A=PRSPDI
SET B=""
+4 FOR
SET B=$ORDER(^TMP($JOB,"PRSNAA",A,B))
if (B="")!STOP
QUIT
Begin DoDot:1
+5 SET C=""
+6 FOR
SET C=$ORDER(^TMP($JOB,"PRSNAA",A,B,C))
if (C="")!STOP
QUIT
Begin DoDot:2
+7 DO APPROV(A,C)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
SETREC(REC,PAYPD) ; Set up record for display
+1 ;
+2 NEW A,B
+3 SET (A,B)=0
+4 FOR
SET A=$ORDER(REC(A))
if 'A
QUIT
Begin DoDot:1
+5 FOR
SET B=$ORDER(REC(A,B))
if 'B
QUIT
Begin DoDot:2
+6 if $PIECE(REC(A,B),U,5)]""&($PIECE(REC(A,B),U,5)?1.N)
SET $PIECE(REC(A,B),U,5)=$PIECE($$ISACTIVE^PRSNUT01(DT,$PIECE(REC(A,B),U,5)),U,2)
+7 if $PIECE(REC(A,B),U,6)]""&($PIECE(REC(A,B),U,6)?1.N)
SET $PIECE(REC(A,B),U,6)=$PIECE(^PRSN(451.5,$PIECE(REC(A,B),U,6),0),U,2)
+8 if $PIECE(REC(A,B),U,8)]""&($PIECE(REC(A,B),U,8)?1.N)
SET $PIECE(REC(A,B),U,8)=$PIECE(^PRSN(451.6,$PIECE(REC(A,B),U,8),0),U,2)
+9 QUIT
End DoDot:2
+10 IF $ORDER(REC(A,0))
SET $PIECE(REC(A,$ORDER(REC(A,0))),U,12)=$PIECE(^PRST(458,PAYPD,2),U,A)
+11 QUIT
End DoDot:1
+12 ;
+13 QUIT
+14 ;
DSPREC(REC) ; Display the record
+1 NEW A,B
+2 SET (A,B)=0
+3 FOR
SET A=$ORDER(REC(A))
if 'A
QUIT
Begin DoDot:1
+4 FOR
SET B=$ORDER(REC(A,B))
if 'B
QUIT
Begin DoDot:2
+5 WRITE $PIECE($PIECE(REC(A,B),U,12)," "),?12,$PIECE(REC(A,B),U),?21,$PIECE(REC(A,B),U,3)
+6 WRITE ?28,$PIECE(REC(A,B),U,4),?38,$PIECE($PIECE(REC(A,B),U,5)," ")
+7 WRITE ?51,$PIECE($PIECE(REC(A,B),U,6)," "),?64,$PIECE($PIECE(REC(A,B),U,8)," ")
+8 WRITE ?77,$PIECE(REC(A,B),U,7),!
+9 WRITE $PIECE($PIECE(REC(A,B),U,12)," ",2,999),?12,$PIECE(REC(A,B),U,2),?38
+10 WRITE $PIECE($PIECE(REC(A,B),U,5)," ",2),?51,$PIECE($PIECE(REC(A,B),U,6)," ",2),?64
+11 WRITE $PIECE($PIECE(REC(A,B),U,8)," ",2),!
+12 ;
+13 IF (IOSL-6)<$Y
SET STOP=$$ASK^PRSLIB00()
IF 'STOP
DO HDR(PRSPD,PRSIEN)
WRITE !
End DoDot:2
if STOP
QUIT
+14 WRITE !
End DoDot:1
if STOP
QUIT
+15 ;
+16 QUIT
+17 ;
DSPMM(PRSIEN,PRSPD) ; Display mismatch report
+1 DO PPMM^PRSNRMM(PRSIEN,PRSPD,,.STOP)
+2 if STOP
QUIT
+3 WRITE !!,?5,"Return to Approvals.",!
+4 SET STOP=$$ASK^PRSLIB00(1)
+5 QUIT
+6 ;
ACTION(A,B) ; Approve or bypass current record
+1 NEW DIR,X,Y
+2 SET PAYPD=A
SET PRSIEN=B
+3 SET DIR("A")="Enter an 'A' to Approve or Return to Bypass: "
+4 ;K DIR
SET DIR(0)="SAO^A:Approve"
DO ^DIR
+5 IF Y=""
QUIT
+6 IF $DATA(DIRUT)
SET STOP=1
QUIT
+7 IF Y="A"
DO UPDTPOC^PRSNCGR1(PAYPD,PRSIEN,Y)
+8 ;
+9 QUIT
+10 ;
HDR(PAYPD,IEN450) ;
+1 ;
+2 SET PRSPDE=$$GET1^DIQ(458,PAYPD,.01)
SET PRSIEN=IEN450
+3 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+4 WRITE $$GET1^DIQ(450,PRSIEN,.01),?26,"Approve Pay Period POC Records"
+5 WRITE ?66,"Pay Pd: ",PRSPDE,!!
+6 WRITE "Date",?12,"Start/",?20,"Meal",?26,"Type of",?38,"Location",?51
+7 WRITE "Type of",?66,"OT",?76,"OT",!
+8 WRITE ?12,"Stop",?27,"Time",?52,"Work",?64,"Reason",?75,"Mand",!
+9 FOR I=1:1:80
WRITE "-"
+10 ;
+11 QUIT
+12 ;
CLEANUP ;
+1 KILL PRSIEN,PRSPDI,PRSPDE,GROUP,GRPIEN,GRPSC,REC,NURSNM,IEN200
+2 KILL PRSFLG,DSPFLG,PREVPD,PRSPRM,PRSSTAT,PRSD,A,B,Y,X,DIC
+3 KILL ^TMP($JOB,"PRSNAA")
+4 QUIT
