PRSPCPPE ; HISC/MGD - DISPLAY PP ESR EXCEPTIONS ;05/18/05
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
TK ; TimeKeeper Entry
S PRSTLV=2 D T0 Q
SUP ; Supervisor Entry
S PRSTLV=3
T0 D TOP ; print header
S USR="",SSN=$P($G(^VA(200,DUZ,1)),"^",9)
I SSN="" D D EXIT Q
. W !!,*7,"Your SSN was not found in the New Person File!"
. S TLI=""
S USR=$O(^PRSPC("SSN",SSN,0))
D TLL ; Loop to prompt for T&Ls
K DIC
I '$D(PRSTL) D EXIT Q
; Prompt for Pay Period Date
S PPI=""
D DATE
I Y<1!(PPI<1) D EXIT Q
D DEVICE I POP D EXIT Q
I $D(IO("Q")) D D EXIT Q
. S PRSAPGM="QEN^PRSPCPPE"
. S PRSALST="MDAT^PPE^PPI^PRSIEN^PRSTL("
. D QUE^PRSAUTL
;
QEN ; queued entry point
;
; Loop through T&Ls identifying PTP's w/ exceptions
D LOOP
; Display Exceptions
D DISPLAY
D EXIT
Q
;
TLL ; Loop to allow enting more than one T&L unit
; Select T&L from among those allowed
K DIC,PRSTL
S Z1=$S(PRSTLV="2":"T",PRSTLV="3":"S",1:"*")
S TLI=$O(^PRST(455.5,"A"_Z1,DUZ,0))
I TLI<1 D Q
. W !!,*7,"No T&L Units have been assigned to you!"
. S TLI="^"
I $O(^PRST(455.5,"A"_Z1,DUZ,TLI))<1 D Q
. S TLE=$P($G(^PRST(455.5,TLI,0)),"^",1)
. S PRSTL(TLE)="",TLI=""
S DIC("S")="I $D(^PRST(455.5,+Y,Z1,DUZ))"
TL S DIC="^PRST(455.5,",DIC(0)="AEQM",DIC("A")="Select T&L Unit: "
F D Q:TLI=""!(TLI="^")
. W !
. I $D(PRSTL) S DIC("A")="Select Another T&L Unit: "
. D ^DIC
. I "^"[X!$D(DTOUT) S TLI="^" Q
. S TLI=+Y
. Q:'TLI
. S TLE=$P($G(^PRST(455.5,TLI,0)),"^",1)
. S PRSTL(TLE)=""
Q
;
DATE S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=-DT W ! D ^%DT
Q:Y<1
S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
Q:PPI<1
S PPE=$P($G(^PRST(458,PPI,0)),U,1)
S MDAT=$P($G(^PRST(458,PPI,1)),U,1)
Q
;
DEVICE W !
S %ZIS("A")="Select DEVICE: ",%ZIS="MQ"
D ^%ZIS Q:POP
;
LOOP ; Loop through T&Ls identifying PTP's w/ exceptions
K ^TMP($J,"PRSPCPPE DATA")
S TLE="",QT=0
F S TLE=$O(PRSTL(TLE)) Q:TLE="" D Q:QT
. S TL="ATL"_TLE
. S NAME="",DATA1=$G(^PRST(458,PPI,1))
. F S NAME=$O(^PRSPC(TL,NAME)) Q:NAME="" D Q:QT
. . S PRSIEN=$O(^PRSPC(TL,NAME,0))
. . Q:'PRSIEN
. . Q:'+$$MIEN^PRSPUT1(PRSIEN,MDAT) ; Employee is not a PTP w/ Memo
DAYCHK . . ; Loop through the days in the PP checking the ESR status
. . S (DAYCHK,IDAYS)=0
. . F DAY=1:1:14 Q:$P(DATA1,U,DAY)>DT D
. . . S DAYCHK=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
. . . Q:DAYCHK>3 ; Not an exception
. . . S IDAYS=IDAYS+1
. . Q:IDAYS=0
. . ; Found at least 1 incomplete ESR
. . S ^TMP($J,"PRSPCPPE DATA",$P(^PRSPC(PRSIEN,0),U,1))=PRSIEN_"^"_IDAYS
Q
;
DISPLAY ; Display ESR for entire Pay Period. Sorted alphabetically
U IO
S QT=0,(NAME,PRSIEN)="",$P(DASH,"_",80)="_"
D LOOP^PRSPCPP1
D ^%ZISC K %ZIS,IOP
Q
;
;====================================================================
TOP W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
W !?27,"DISPLAY PP ESR EXCEPTIONS"
Q
;
;====================================================================
;
EXIT ; Clean up variables
K %DT,%ZIS,D1,DASH,DATA,DATA0,DATA1,DATA5,DATA6,DATA7,DAY,DAY1,DAYCHK
K DFN,DIR,DIRUT,DTOUT,EDLSM,HRS,IDAYS,MDAT,MIEN,MT,NAME,PDT,PG,POP
K PPE,PPI,PRSALST,PRSAPGM,PRSIEN,PRSTL,PRSTLV,PTPRMKS,QT,QUIT,RC,RCEX
K SCRTTL,SEG,SSN,START,STAT,STATEX,STOP,SUPRMKS,T1,T1EX,T2,T2EX
K TL,TLE,TLI,TLSCREEN,TOT,TOTEX,USR,X,Y,Z1
K ^TMP($J,"PRSPCPPE DATA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPCPPE 3515 printed Apr 09, 2024@21:28:20 Page 2
PRSPCPPE ; HISC/MGD - DISPLAY PP ESR EXCEPTIONS ;05/18/05
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
TK ; TimeKeeper Entry
+1 SET PRSTLV=2
DO T0
QUIT
SUP ; Supervisor Entry
+1 SET PRSTLV=3
T0 ; print header
DO TOP
+1 SET USR=""
SET SSN=$PIECE($GET(^VA(200,DUZ,1)),"^",9)
+2 IF SSN=""
Begin DoDot:1
+3 WRITE !!,*7,"Your SSN was not found in the New Person File!"
+4 SET TLI=""
End DoDot:1
DO EXIT
QUIT
+5 SET USR=$ORDER(^PRSPC("SSN",SSN,0))
+6 ; Loop to prompt for T&Ls
DO TLL
+7 KILL DIC
+8 IF '$DATA(PRSTL)
DO EXIT
QUIT
+9 ; Prompt for Pay Period Date
+10 SET PPI=""
+11 DO DATE
+12 IF Y<1!(PPI<1)
DO EXIT
QUIT
+13 DO DEVICE
IF POP
DO EXIT
QUIT
+14 IF $DATA(IO("Q"))
Begin DoDot:1
+15 SET PRSAPGM="QEN^PRSPCPPE"
+16 SET PRSALST="MDAT^PPE^PPI^PRSIEN^PRSTL("
+17 DO QUE^PRSAUTL
End DoDot:1
DO EXIT
QUIT
+18 ;
QEN ; queued entry point
+1 ;
+2 ; Loop through T&Ls identifying PTP's w/ exceptions
+3 DO LOOP
+4 ; Display Exceptions
+5 DO DISPLAY
+6 DO EXIT
+7 QUIT
+8 ;
TLL ; Loop to allow enting more than one T&L unit
+1 ; Select T&L from among those allowed
+2 KILL DIC,PRSTL
+3 SET Z1=$SELECT(PRSTLV="2":"T",PRSTLV="3":"S",1:"*")
+4 SET TLI=$ORDER(^PRST(455.5,"A"_Z1,DUZ,0))
+5 IF TLI<1
Begin DoDot:1
+6 WRITE !!,*7,"No T&L Units have been assigned to you!"
+7 SET TLI="^"
End DoDot:1
QUIT
+8 IF $ORDER(^PRST(455.5,"A"_Z1,DUZ,TLI))<1
Begin DoDot:1
+9 SET TLE=$PIECE($GET(^PRST(455.5,TLI,0)),"^",1)
+10 SET PRSTL(TLE)=""
SET TLI=""
End DoDot:1
QUIT
+11 SET DIC("S")="I $D(^PRST(455.5,+Y,Z1,DUZ))"
TL SET DIC="^PRST(455.5,"
SET DIC(0)="AEQM"
SET DIC("A")="Select T&L Unit: "
+1 FOR
Begin DoDot:1
+2 WRITE !
+3 IF $DATA(PRSTL)
SET DIC("A")="Select Another T&L Unit: "
+4 DO ^DIC
+5 IF "^"[X!$DATA(DTOUT)
SET TLI="^"
QUIT
+6 SET TLI=+Y
+7 if 'TLI
QUIT
+8 SET TLE=$PIECE($GET(^PRST(455.5,TLI,0)),"^",1)
+9 SET PRSTL(TLE)=""
End DoDot:1
if TLI=""!(TLI="^")
QUIT
+10 QUIT
+11 ;
DATE SET %DT="AEPX"
SET %DT("A")="Posting Date: "
SET %DT(0)=-DT
WRITE !
DO ^%DT
+1 if Y<1
QUIT
+2 SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
+3 if PPI<1
QUIT
+4 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
+5 SET MDAT=$PIECE($GET(^PRST(458,PPI,1)),U,1)
+6 QUIT
+7 ;
DEVICE WRITE !
+1 SET %ZIS("A")="Select DEVICE: "
SET %ZIS="MQ"
+2 DO ^%ZIS
if POP
QUIT
+3 ;
LOOP ; Loop through T&Ls identifying PTP's w/ exceptions
+1 KILL ^TMP($JOB,"PRSPCPPE DATA")
+2 SET TLE=""
SET QT=0
+3 FOR
SET TLE=$ORDER(PRSTL(TLE))
if TLE=""
QUIT
Begin DoDot:1
+4 SET TL="ATL"_TLE
+5 SET NAME=""
SET DATA1=$GET(^PRST(458,PPI,1))
+6 FOR
SET NAME=$ORDER(^PRSPC(TL,NAME))
if NAME=""
QUIT
Begin DoDot:2
+7 SET PRSIEN=$ORDER(^PRSPC(TL,NAME,0))
+8 if 'PRSIEN
QUIT
+9 ; Employee is not a PTP w/ Memo
if '+$$MIEN^PRSPUT1(PRSIEN,MDAT)
QUIT
DAYCHK ; Loop through the days in the PP checking the ESR status
+1 SET (DAYCHK,IDAYS)=0
+2 FOR DAY=1:1:14
if $PIECE(DATA1,U,DAY)>DT
QUIT
Begin DoDot:3
+3 SET DAYCHK=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
+4 ; Not an exception
if DAYCHK>3
QUIT
+5 SET IDAYS=IDAYS+1
End DoDot:3
+6 if IDAYS=0
QUIT
+7 ; Found at least 1 incomplete ESR
+8 SET ^TMP($JOB,"PRSPCPPE DATA",$PIECE(^PRSPC(PRSIEN,0),U,1))=PRSIEN_"^"_IDAYS
End DoDot:2
if QT
QUIT
End DoDot:1
if QT
QUIT
+9 QUIT
+10 ;
DISPLAY ; Display ESR for entire Pay Period. Sorted alphabetically
+1 USE IO
+2 SET QT=0
SET (NAME,PRSIEN)=""
SET $PIECE(DASH,"_",80)="_"
+3 DO LOOP^PRSPCPP1
+4 DO ^%ZISC
KILL %ZIS,IOP
+5 QUIT
+6 ;
+7 ;====================================================================
TOP if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+1 WRITE !?27,"DISPLAY PP ESR EXCEPTIONS"
+2 QUIT
+3 ;
+4 ;====================================================================
+5 ;
EXIT ; Clean up variables
+1 KILL %DT,%ZIS,D1,DASH,DATA,DATA0,DATA1,DATA5,DATA6,DATA7,DAY,DAY1,DAYCHK
+2 KILL DFN,DIR,DIRUT,DTOUT,EDLSM,HRS,IDAYS,MDAT,MIEN,MT,NAME,PDT,PG,POP
+3 KILL PPE,PPI,PRSALST,PRSAPGM,PRSIEN,PRSTL,PRSTLV,PTPRMKS,QT,QUIT,RC,RCEX
+4 KILL SCRTTL,SEG,SSN,START,STAT,STATEX,STOP,SUPRMKS,T1,T1EX,T2,T2EX
+5 KILL TL,TLE,TLI,TLSCREEN,TOT,TOTEX,USR,X,Y,Z1
+6 KILL ^TMP($JOB,"PRSPCPPE DATA")
+7 QUIT
