PRSPDESR ; HISC/MGD - Display PT Phy ESR ;05/01/05
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
PAY ; Payroll Entry
S PRSTLV=7
D TOP ; print header
P1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
W ! D ^DIC S PRSIEN=+Y K DIC G:PRSIEN<1 EX
S TLE=$P($G(^PRSPC(PRSIEN,0)),"^",8)
S DIC="^PRST(458,",DIC(0)="AEQM",DIC("A")="Select PAY PERIOD: "
W ! D ^DIC K DIC G:Y<1 EX
S PPI=+Y
S PPE=$P(Y,U,2)
D L1 ;ask device
G P1 ;ask for employee again
;
TK ; TimeKeeper Entry
S PRSTLV=2 G T0
;
SUP ; Supervisor Entry
S PRSTLV=3
T0 D TOP ; print header
D ^PRSAUTL G:TLI<1 EX
T1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
S DIC("S")="I $P(^(0),""^"",8)=TLE" S D="ATL"_TLE W ! D IX^DIC
S PRSIEN=+Y K DIC G:PRSIEN<1 EX
S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=3041001 W ! D ^%DT
G:Y<1 EX
S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
G EX:PPI<1
S PPE=$P($G(^PRST(458,PPI,0)),U,1)
D L1 ;ask device
G T1 ;ask for employee again
;
EMP ; Employee Entry
S PRSTLV=1 D TOP S PRSIEN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9)
I SSN'="" S PRSIEN=$O(^PRSPC("SSN",SSN,0))
I 'PRSIEN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
S PRSIEN=PRSIEN
S TLE=$P($G(^PRSPC(PRSIEN,0)),"^",8)
S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=3040101 W ! D ^%DT
G:Y<1 EX
S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
S MIEN=+$$MIEN^PRSPUT1(PRSIEN,D1)
G EX:PPI<1
S PPE=$P($G(^PRST(458,PPI,0)),U,1)
D L1 G EX
;
TOP W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
W !?27,"DISPLAY PT PHYSICIAN ESR" Q
L1 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ"
D ^%ZIS K %ZIS,IOP
Q:POP
I $D(IO("Q")) D Q
. S PRSAPGM="DIS^PRSPDESR",PRSALST="PRSIEN^TLE^PPI^PPE^DATA7"
. D QUE^PRSAUTL
U IO D DIS
I $E(IOST,1,2)="C-",'QT D H1
D ^%ZISC K %ZIS,IOP Q
;
DIS ; Display 14 days
;
S PDT=$G(^PRST(458,PPI,2)),STAT=$P($G(^PRST(458,PPI,"E",PRSIEN,0)),"^",2)
S QT=0,DASH="",$P(DASH,"_",80)="_"
S IDAYS=0
F DAY=1:1:14 D Q:QT
. S DATA7=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7))
. S STAT=$P(DATA7,U,1) ; ESR Daily Status
. I STAT<4 S IDAYS=IDAYS+1
D HDR1
; Check to see if the PTP had a memorandum during this PP.
S DAY1=$P($G(^PRST(458,PPI,1)),U,1)
I +$$MIEN^PRSPUT1(PRSIEN,DAY1)=0 D Q:QT
. W !!,"This employee did not have an active Memorandum during this Pay Period."
. S QT=1
F DAY=1:1:14 D Q:QT
. S DATA0=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0))
. S DATA5=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,5))
. S DATA6=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,6))
. S DATA7=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7))
. S T1=$P(DATA0,U,2) ; Tour #1
. S T1EX=$S(T1:$P($G(^PRST(457.1,T1,0)),U,1),1:"") ; Tour #1 External
. S STAT=$P(DATA7,U,1) ; ESR Daily Status
. S STATEX=$$EXTERNAL^DILFD(458.02,146,"",STAT)
. W !,$P(PDT,U,DAY),?14,$J(T1,4)," ",T1EX,?68," ",STATEX
. S T2=$P(DATA0,U,13) ; Tour #2
. I T2 D
. . S T2EX=$S(T2:$P($G(^PRST(457.1,T2,0)),U,1),1:"") ; Tour #2 External
. . W !?14,$J(T2,4)," ",T2EX
. S EDLSM=$P(DATA7,U,3) ; ESR DAY LAST SIGN METHOD
. I EDLSM=2 S STATEX=STATEX_" - EA" ; Posted by Extended Absence
. S QUIT=0
. F SEG=1:5:31 D:$Y>(IOSL-3) HDR Q:QT!(QUIT) D Q:QT!(QUIT)
. . S START=$P(DATA5,U,SEG)
. . I START="",SEG>1 S QUIT=1
. . Q:START=""
. . S STOP=$P(DATA5,U,SEG+1),TOT=$P(DATA5,U,SEG+2)
. . S TOTEX=""
. . I TOT'="" D
. . . S TOTEX=$O(^PRST(457.3,"B",TOT,0))
. . . S TOTEX=$E($P($G(^PRST(457.3,TOTEX,0)),U,2),1,14)
. . . S TOTEX=TOT_" "_TOTEX
. . S RC=$P(DATA5,U,SEG+3),MT=$P(DATA5,U,SEG+4)
. . S HRS=$$ELAPSE^PRSPESR2(MT,START,STOP)
. . W !?21,START,"-",STOP,?36,TOTEX,?56,$J(MT,2)," ",$J(HRS,5)
. . D:$Y>(IOSL-3) HDR
. . Q:QT!(QUIT)
. . I RC'="" D Q:QT!(QUIT)
. . . S RCEX=$P($G(^PRST(457.4,RC,0)),U,4)
. . . W !?38,RCEX
. . . D:$Y>(IOSL-3) HDR
. . Q:QT!(QUIT)
. Q:QT
. ;
. ; Display any PTP or Supervisor Remarks
. S PTPRMKS=$P(DATA6,U,1) ; PTP Remarks
. I PTPRMKS'="" D Q:QT!(QUIT)
. . W !," PTP Remarks: ",PTPRMKS
. . D:$Y>(IOSL-3) HDR
. S SUPRMKS=$P(DATA6,U,2) ; Supervisor Remarks
. I SUPRMKS'="" D Q:QT!(QUIT)
. . W !," Sup Remarks: ",SUPRMKS
. . D:$Y>(IOSL-3) HDR
Q
;====================================================================
HDR ; Display Header
D H1 Q:QT W @IOF
HDR1 S SCRTTL="PT PHYSICIAN ESR FOR PP "_PPE
D HDR^PRSPUT1(PRSIEN,SCRTTL,,,PPI)
W !?30,"Incomplete Days: "_$J(IDAYS,2)
W !,"Day",?14,"Tour Description",?69,"Status"
W !?21,"Postings",?36,"Time Code",?55,"Meal Hours"
W !?38,"Remarks Code"
W !,DASH
Q
;
H1 I $E(IOST,1,2)="C-" D
. W !
. S DIR(0)="E",DIR("A")="Press RETURN to continue"
. D ^DIR K DIR
. I $D(DIRUT) S QT=1
Q
EX ; Clean up variables
K D,D1,DASH,DATA0,DATA5,DATA6,DATA7,DAY,DAY1,DIRUT,EDLSM,HRS,IDAYS
K MIEN,MT,PDT,POP,PPE,PPI,PRSALST,PRSAPGM,PRSIEN,PRSTLV,PTPRMKS,QUIT
K QT,RC,RCEX,SCRTTL,SEG,SSN,START,STAT,STATEX,SUPRMKS,STOP,T1,T1EX
K T2,T2EX,TLE,TLI,TLSCREEN,TOT,TOTEX,X,Y,%DT,%ZIS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPDESR 5139 printed Sep 23, 2025@20:04:15 Page 2
PRSPDESR ; HISC/MGD - Display PT Phy ESR ;05/01/05
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
PAY ; Payroll Entry
+1 SET PRSTLV=7
+2 ; print header
DO TOP
P1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
+1 WRITE !
DO ^DIC
SET PRSIEN=+Y
KILL DIC
if PRSIEN<1
GOTO EX
+2 SET TLE=$PIECE($GET(^PRSPC(PRSIEN,0)),"^",8)
+3 SET DIC="^PRST(458,"
SET DIC(0)="AEQM"
SET DIC("A")="Select PAY PERIOD: "
+4 WRITE !
DO ^DIC
KILL DIC
if Y<1
GOTO EX
+5 SET PPI=+Y
+6 SET PPE=$PIECE(Y,U,2)
+7 ;ask device
DO L1
+8 ;ask for employee again
GOTO P1
+9 ;
TK ; TimeKeeper Entry
+1 SET PRSTLV=2
GOTO T0
+2 ;
SUP ; Supervisor Entry
+1 SET PRSTLV=3
T0 ; print header
DO TOP
+1 DO ^PRSAUTL
if TLI<1
GOTO EX
T1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
+1 SET DIC("S")="I $P(^(0),""^"",8)=TLE"
SET D="ATL"_TLE
WRITE !
DO IX^DIC
+2 SET PRSIEN=+Y
KILL DIC
if PRSIEN<1
GOTO EX
+3 SET %DT="AEPX"
SET %DT("A")="Posting Date: "
SET %DT(0)=3041001
WRITE !
DO ^%DT
+4 if Y<1
GOTO EX
+5 SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
+6 if PPI<1
GOTO EX
+7 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
+8 ;ask device
DO L1
+9 ;ask for employee again
GOTO T1
+10 ;
EMP ; Employee Entry
+1 SET PRSTLV=1
DO TOP
SET PRSIEN=""
SET SSN=$PIECE($GET(^VA(200,DUZ,1)),"^",9)
+2 IF SSN'=""
SET PRSIEN=$ORDER(^PRSPC("SSN",SSN,0))
+3 IF 'PRSIEN
WRITE !!,*7,"Your SSN was not found in both the New Person & Employee File!"
GOTO EX
+4 SET PRSIEN=PRSIEN
+5 SET TLE=$PIECE($GET(^PRSPC(PRSIEN,0)),"^",8)
+6 SET %DT="AEPX"
SET %DT("A")="Posting Date: "
SET %DT(0)=3040101
WRITE !
DO ^%DT
+7 if Y<1
GOTO EX
+8 SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
+9 SET MIEN=+$$MIEN^PRSPUT1(PRSIEN,D1)
+10 if PPI<1
GOTO EX
+11 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
+12 DO L1
GOTO EX
+13 ;
TOP if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+1 WRITE !?27,"DISPLAY PT PHYSICIAN ESR"
QUIT
L1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
+1 DO ^%ZIS
KILL %ZIS,IOP
+2 if POP
QUIT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET PRSAPGM="DIS^PRSPDESR"
SET PRSALST="PRSIEN^TLE^PPI^PPE^DATA7"
+5 DO QUE^PRSAUTL
End DoDot:1
QUIT
+6 USE IO
DO DIS
+7 IF $EXTRACT(IOST,1,2)="C-"
IF 'QT
DO H1
+8 DO ^%ZISC
KILL %ZIS,IOP
QUIT
+9 ;
DIS ; Display 14 days
+1 ;
+2 SET PDT=$GET(^PRST(458,PPI,2))
SET STAT=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),"^",2)
+3 SET QT=0
SET DASH=""
SET $PIECE(DASH,"_",80)="_"
+4 SET IDAYS=0
+5 FOR DAY=1:1:14
Begin DoDot:1
+6 SET DATA7=$GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7))
+7 ; ESR Daily Status
SET STAT=$PIECE(DATA7,U,1)
+8 IF STAT<4
SET IDAYS=IDAYS+1
End DoDot:1
if QT
QUIT
+9 DO HDR1
+10 ; Check to see if the PTP had a memorandum during this PP.
+11 SET DAY1=$PIECE($GET(^PRST(458,PPI,1)),U,1)
+12 IF +$$MIEN^PRSPUT1(PRSIEN,DAY1)=0
Begin DoDot:1
+13 WRITE !!,"This employee did not have an active Memorandum during this Pay Period."
+14 SET QT=1
End DoDot:1
if QT
QUIT
+15 FOR DAY=1:1:14
Begin DoDot:1
+16 SET DATA0=$GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0))
+17 SET DATA5=$GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,5))
+18 SET DATA6=$GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,6))
+19 SET DATA7=$GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7))
+20 ; Tour #1
SET T1=$PIECE(DATA0,U,2)
+21 ; Tour #1 External
SET T1EX=$SELECT(T1:$PIECE($GET(^PRST(457.1,T1,0)),U,1),1:"")
+22 ; ESR Daily Status
SET STAT=$PIECE(DATA7,U,1)
+23 SET STATEX=$$EXTERNAL^DILFD(458.02,146,"",STAT)
+24 WRITE !,$PIECE(PDT,U,DAY),?14,$JUSTIFY(T1,4)," ",T1EX,?68," ",STATEX
+25 ; Tour #2
SET T2=$PIECE(DATA0,U,13)
+26 IF T2
Begin DoDot:2
+27 ; Tour #2 External
SET T2EX=$SELECT(T2:$PIECE($GET(^PRST(457.1,T2,0)),U,1),1:"")
+28 WRITE !?14,$JUSTIFY(T2,4)," ",T2EX
End DoDot:2
+29 ; ESR DAY LAST SIGN METHOD
SET EDLSM=$PIECE(DATA7,U,3)
+30 ; Posted by Extended Absence
IF EDLSM=2
SET STATEX=STATEX_" - EA"
+31 SET QUIT=0
+32 FOR SEG=1:5:31
if $Y>(IOSL-3)
DO HDR
if QT!(QUIT)
QUIT
Begin DoDot:2
+33 SET START=$PIECE(DATA5,U,SEG)
+34 IF START=""
IF SEG>1
SET QUIT=1
+35 if START=""
QUIT
+36 SET STOP=$PIECE(DATA5,U,SEG+1)
SET TOT=$PIECE(DATA5,U,SEG+2)
+37 SET TOTEX=""
+38 IF TOT'=""
Begin DoDot:3
+39 SET TOTEX=$ORDER(^PRST(457.3,"B",TOT,0))
+40 SET TOTEX=$EXTRACT($PIECE($GET(^PRST(457.3,TOTEX,0)),U,2),1,14)
+41 SET TOTEX=TOT_" "_TOTEX
End DoDot:3
+42 SET RC=$PIECE(DATA5,U,SEG+3)
SET MT=$PIECE(DATA5,U,SEG+4)
+43 SET HRS=$$ELAPSE^PRSPESR2(MT,START,STOP)
+44 WRITE !?21,START,"-",STOP,?36,TOTEX,?56,$JUSTIFY(MT,2)," ",$JUSTIFY(HRS,5)
+45 if $Y>(IOSL-3)
DO HDR
+46 if QT!(QUIT)
QUIT
+47 IF RC'=""
Begin DoDot:3
+48 SET RCEX=$PIECE($GET(^PRST(457.4,RC,0)),U,4)
+49 WRITE !?38,RCEX
+50 if $Y>(IOSL-3)
DO HDR
End DoDot:3
if QT!(QUIT)
QUIT
+51 if QT!(QUIT)
QUIT
End DoDot:2
if QT!(QUIT)
QUIT
+52 if QT
QUIT
+53 ;
+54 ; Display any PTP or Supervisor Remarks
+55 ; PTP Remarks
SET PTPRMKS=$PIECE(DATA6,U,1)
+56 IF PTPRMKS'=""
Begin DoDot:2
+57 WRITE !," PTP Remarks: ",PTPRMKS
+58 if $Y>(IOSL-3)
DO HDR
End DoDot:2
if QT!(QUIT)
QUIT
+59 ; Supervisor Remarks
SET SUPRMKS=$PIECE(DATA6,U,2)
+60 IF SUPRMKS'=""
Begin DoDot:2
+61 WRITE !," Sup Remarks: ",SUPRMKS
+62 if $Y>(IOSL-3)
DO HDR
End DoDot:2
if QT!(QUIT)
QUIT
End DoDot:1
if QT
QUIT
+63 QUIT
+64 ;====================================================================
HDR ; Display Header
+1 DO H1
if QT
QUIT
WRITE @IOF
HDR1 SET SCRTTL="PT PHYSICIAN ESR FOR PP "_PPE
+1 DO HDR^PRSPUT1(PRSIEN,SCRTTL,,,PPI)
+2 WRITE !?30,"Incomplete Days: "_$JUSTIFY(IDAYS,2)
+3 WRITE !,"Day",?14,"Tour Description",?69,"Status"
+4 WRITE !?21,"Postings",?36,"Time Code",?55,"Meal Hours"
+5 WRITE !?38,"Remarks Code"
+6 WRITE !,DASH
+7 QUIT
+8 ;
H1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+1 WRITE !
+2 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
SET QT=1
End DoDot:1
+5 QUIT
EX ; Clean up variables
+1 KILL D,D1,DASH,DATA0,DATA5,DATA6,DATA7,DAY,DAY1,DIRUT,EDLSM,HRS,IDAYS
+2 KILL MIEN,MT,PDT,POP,PPE,PPI,PRSALST,PRSAPGM,PRSIEN,PRSTLV,PTPRMKS,QUIT
+3 KILL QT,RC,RCEX,SCRTTL,SEG,SSN,START,STAT,STATEX,SUPRMKS,STOP,T1,T1EX
+4 KILL T2,T2EX,TLE,TLI,TLSCREEN,TOT,TOTEX,X,Y,%DT,%ZIS
+5 QUIT
