- 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 Jan 18, 2025@03:29 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