PRSASR ;HISC/MGD,WOIFO/JAH/PLT - Supervisor Certification ;02/05/2005
;;4.0;PAID;**2,7,8,22,37,43,82,93,112,117,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;Called by Pay Per Cert Option on T&A Superv menu. Timecard 4 each
;employee in this supervs T&L is displayed. Superv prompted at each
;display as to whether card is ready 4 certification. Cards that r
;ready r saved in ^TMP. After this review--elect sign code is
;required to release approved cards to payroll. Upon ES
; 8b, exceptions, & ot warnings r stored & timecard status
;changed to 'P'--'released to payroll'
;
;=====================================================================
;
;Set up reverse video ON & OFF for tour error highlighting
N IORVOFF,IORVON,IOINHI,IOINORM,IOBOFF,IOBON,RESP
S X="IORVOFF;IORVON;IOBOFF;IOBON;IOINHI;IOINORM" D ENDR^%ZISS
;
N MIDPP,DUMMY
S MIDPP="In middle of Pay Period; Cannot Certify & Release."
W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
W !?27,"SUPERVISORY CERTIFICATION"
S PRSTLV=3 D ^PRSAUTL G:TLI<1 EX
D NOW^%DTC
S DT=%\1,APDT=%,Y=$G(^PRST(458,"AD",DT)),PPI=$P(Y,U,1),DAY=$P(Y,U,2)
I DAY>5,DAY<11 W $C(7),!!,MIDPP G EX
I DAY<6 S X1=DT,X2=-7 D C^%DTC S PPI=$P($G(^PRST(458,"AD",X)),U,1) G:'PPI EX
; -----------------------------------------
P0 ;PDT = string of pay period dates with format - Sun 29-Sep-96^
;PDTI = string of pay period dates in fileman format.
;PPI = pay period internal entry number in file 458.
;GLOB = global reference for employees pay period record
; returned from $$AVAILREC & passed to UNLOCK.
; -----------------------------------------
;
S PDT=$G(^PRST(458,PPI,2)),PDTI=$G(^(1)),QT=0 K ^TMP($J)
;
; -----------------------------------------
;Loop thru this supervisor's T&L unit on x-ref in 450.
;$$availrec() ensures there's data & node with employee's
;pay period record is NOT locked, then locks node.
;Call to CHK checks for needed approvals for current employee
;If supervisor decides record is not ready, during this call,
;then node is unlocked. Records that super accepts for release
;are not unlocked until they are processed thru temp global
;& their status' are updated.
; ---------------------------------------------------
;
S NN="",CKS=1
F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" F DFN=0:0 S DFN=$O(^PRSPC("ATL"_TLE,NN,DFN)) Q:DFN<1 I $$AVAILREC^PRSLIB00("SUP",.GLOB) D CHK I QT G T0
;
; ---------------------------------------------------
;Loop through T&L unit file x-ref 2 c if this supervisor certifies
;payperiod data for other supervisors of other T&L units. If so
;process after ensuring node to be certified is available.
; ---------------------------------------------------
;
S CKS=0
F VA2=0:0 S VA2=$$TLSUP Q:VA2<1 S SSN=$$SSN I SSN'="" S DFN=$$DFN S Z=$P($G(^PRSPC(+DFN,0)),U,8) I Z'="",Z'=TLE,$$AVAILREC^PRSLIB00("SUP",.GLOB) D CHK I QT G EX:'$T,T0
;
; ---------------------------------------------------
T0 I $D(^TMP($J,"E")) G T1
W !!,"No records have been selected for certification."
S DUMMY=$$ASK^PRSLIB00(1) G EX
;
; ---------------------------------------------------
;
T1 ;if supervisor signs off then update all records in tmp
;otherwise remove any auto posting.
D ^PRSAES I ESOK D
.D NOW^%DTC S APDT=%
.F DFN=0:0 S DFN=$O(^TMP($J,"E",DFN)) Q:DFN<1 S VAL=$G(^(DFN)) D PROC
I 'ESOK D
.F DFN=0:0 S DFN=$O(^TMP($J,"E",DFN)) Q:DFN<1 D
..D AUTOPINI^PRS8(PPI,DFN)
D EX
Q
;
; ---------------------------------------------------
CHK ; Check for needed approvals
N PRSENT,PRSWOC
S STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),U,2) I "PX"[STAT Q
I USR=DFN Q:'$D(^XUSEC("PRSA SIGN",DUZ))
E I CKS S SSN=$P($G(^PRSPC(DFN,0)),U,9) I SSN S EDUZ=+$O(^VA(200,"SSN",SSN,0)) I $D(^PRST(455.5,"AS",EDUZ,TLI)) Q:$P($G(^PRST(455.5,TLI,"S",EDUZ,0)),U,2)'=TLE
S HDR=0 D HDR,^PRSAENT S PRSENT=ENT
;
;Loop to display tour, exceptions(leave, etc..) & errors.
;
S (XF,X9)=0
F DAY=1:1:14 D TOURERR($P(PDT,U,DAY),.X9,.XF) D:$Y>(IOSL-6)&(DAY<14) HDR G:QT O1
;
;Display VCS commission sales, if applicable
S Z=$G(^PRST(458,PPI,"E",DFN,2))
I Z'="" D:$Y>(IOSL-11) HDR Q:QT D VCS^PRSASR1
;
;
S Z=$G(^PRST(458,PPI,"E",DFN,4))
I Z'="" D:$Y>(IOSL-9) HDR Q:QT D ED^PRSASR1
I XF W !,IORVON,"Serious error; cannot release.",IORVOFF S QT=$$ASK^PRSLIB00() Q
S QT=$$ASK^PRSLIB00() Q:QT
;
;PRS8 call creates & stores 8B string in employees attendance
;record. Later, under a payroll option, string will be
;transmitted to Austin.
;
N NN D ONE^PRS8 S C0=$G(^PRSPC(DFN,0)),PY=PPI D CERT^PRS8VW S QT=0
;
;Show OT (approve-vs-8B) warning & save in TMP.
N WK,OTERR,O8,OA
F WK=1:1:2 D
. D WARNSUP^PRSAOTT(PPE,DFN,VAL,WK,.OTERR,.O8,.OA)
. I OTERR S ^TMP($J,"OT",DFN,WK)=O8_U_OA
;
;warning message for rs/rn and on type of time
I $E(PRSENT,5) D
. I @($TR($$CD8B^PRSU1B2(VAL,"RS^3^RN^3",1),U,"+")_"-("_$TR($$RSHR^PRSU1B2(DFN,PPI),U,"+")_")") W !,?3,"WARNING: The total scheduled recess hours for this pay period does not match the total RS/RN posted."
. I $G(PRSWOC)]"" W !,?3,"Warning: The entire tour for day# ",PRSWOC," is posted RECESS. The On-Call will be paid unless posted UNAVAILABLE."
. QUIT
;
LD ; Check for changes to the Labor Distribution Codes made during the pay
; period.
I $D(^PRST(458,PPI,"E",DFN,"LDAUD")) D LD^PRSASR1
; ---------------------------------------------------
OK ;Prompt Supervisor to release timecard. If yes, store in ^TMP(.
;If supervisor answers no then bypass & unlock record.
; ---------------------------------------------------
W !!,IORVON,"Release to Payroll?",IORVOFF," "
R X:DTIME S:'$T!(X[U) QT=1 Q:QT S:X="" X="*" S X=$TR(X,"yesno","YESNO")
I $P("YES",X,1)'="",$P("NO",X,1)'="" W $C(7)," Answer YES or NO" G OK
I X?1"Y".E S ^TMP($J,"E",DFN)=VAL
E D
. D AUTOPINI^PRS8(PPI,DFN) ; remove any auto posting
. D UNLOCK^PRSLIB00(GLOB) ; unlock record
. K ^TMP($J,"LOCK",DFN) ;clean out of local lock list.
O1 Q
;
PROC ; Set Approval, file any exceptions & update 8B string
;
; get employees entitlement string in variable A1
D ^PRSAENT
;
; set approvals
S $P(^PRST(458,PPI,"E",DFN,0),U,3,5)=DUZ_U_APDT_U_A1
; VCS approval
I $D(^PRST(458,PPI,"E",DFN,2)) S $P(^(2),U,17,18)=DUZ_U_APDT
;
; loop thru any exceptions & file in 458.5
I $D(^TMP($J,"X",DFN)) S K="" F S K=$O(^TMP($J,"X",DFN,K)) Q:K="" S DAY=$P(K," ",1),X1=$P(PDTI,U,DAY),X2=$G(^(K)) D ^PRSATPF
;
; file overtime warnings
F WK=1:1:2 I $G(^TMP($J,"OT",DFN,WK))'="" D
. S O8=$P(^TMP($J,"OT",DFN,WK),U)
. S OA=$P(^TMP($J,"OT",DFN,WK),U,2)
. D FILEOTW^PRSAOTTF(PPI,DFN,WK,O8,OA)
;
;set 8b string & change status of timecard to payroll
S ^PRST(458,PPI,"E",DFN,5)=VAL S $P(^PRST(458,PPI,"E",DFN,0),U,2)="P"
;set the pp telework indicator
S:$P($$TWE^PRSATE0(DFN),U)]"" $P(^PRST(458,PPI,"E",DFN,0),U,8)=$P($$TWE^PRSATE0(DFN),U)
;
; If employee is a PT Phys w/ memo update hours credited
D PTP^PRSASR1(DFN,PPI)
;
;unlock employees time card record
S GLOB="^PRST(458,"_PPI_","_"""E"""_","_DFN_",0)"
D UNLOCK^PRSLIB00(GLOB)
K ^TMP($J,"LOCK",DFN) ;clean out of local lock list.
Q
;
;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
;
HDR ; Display Header
I HDR S QT=$$ASK^PRSLIB00() Q:QT
S X=$G(^PRSPC(DFN,0)) W !,@IOF,?2,$P(X,U,1) S X=$P(X,U,9) I X W ?68,$E(X),"XX-XX-",$E(X,6,9) S HDR=1
W !,?6,"Date",?16,"TW",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF
W !?2 F I=1:1:72 W "-"
Q
;====================================================================
HDR2 ; Display Header don't quit
N HOLD
S HOLD=$$ASK^PRSLIB00(1)
S X=$G(^PRSPC(DFN,0)) W !,@IOF,?2,$P(X,U,1) S X=$P(X,U,9) I X W ?68,$E(X),"XX-XX-",$E(X,6,9)
W !,?6,"Date",?16,"TW",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF
W !?2 F I=1:1:72 W "-"
Q
;====================================================================
;
EX ; clean up variables & unlock any leftover time card nodes
N EMPREC
S EMPREC=""
F S EMPREC=$O(^TMP($J,"LOCK",EMPREC)) Q:EMPREC="" D
. S GLOB="^PRST(458,"_PPI_","_"""E"""_","_EMPREC_",0)"
. D UNLOCK^PRSLIB00(GLOB)
K ^TMP($J) G KILL^XUSCLEAN
Q
;
;
;These extrinsic functions simply remove lengthy code from long,
;single line, nested loop.
; ---------------------------------------------------
TLSUP() ;get next supervisor who certifies other supervisors
Q $O(^PRST(455.5,"ASX",TLE,VA2))
; ---------------------------------------------------
SSN() ;get ssn of supervisor to be certified by this supervisor.
Q $P($G(^VA(200,VA2,1)),U,9)
; ---------------------------------------------------
DFN() ;get internal entry number of supvisor of other T&L 2b approved
;by current supervisor.
Q $O(^PRSPC("SSN",SSN,0))
;====================================================================
TOURERR(DTE,X9,XF) ;DISPLAY TOUR & ERRORS
;
N IORVOFF,IORVON,RESP,ERRLEN
S X="IORVOFF;IORVON" D ENDR^%ZISS
D F1^PRSADP1,^PRSATPE
F K=1:1 Q:'$D(Y1(K))&'$D(Y2(K)) D
. I $Y>(IOSL-4) D HDR2
. W:K>1 !
. W:$D(Y1(K)) ?21,Y1(K)
. W:$P($G(Y2(K)),U)'="" ?45,$P(Y2(K),U,1)
. I $P($G(Y2(K)),U,2)'="" W:$X>44 ! W ?45,$P(Y2(K),U,2)
W:Y3'="" !?10,Y3
I $D(ER) S:FATAL XF=1 F K=0:0 S K=$O(ER(K)) Q:K<1 D
. I $Y>(IOSL-4) D HDR2
. S ERRLEN=$S($P(ER(K),U,2)'="":$L(ER(K)),1:$L($P($G(ER(K)),U))+1)
. W:X9!((ERRLEN+1)>(IOM-$X)) !
. W ?(IOM-(ERRLEN+1)),IORVON
. W:$P(ER(K),U,2)'="" $P(ER(K),U,2)
. W " ",$P(ER(K),U,1),IORVOFF
. S X9=0 S:'XF ^TMP($J,"X",DFN,DAY_" "_K)=ER(K)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSASR 9827 printed Dec 13, 2024@02:24:20 Page 2
PRSASR ;HISC/MGD,WOIFO/JAH/PLT - Supervisor Certification ;02/05/2005
+1 ;;4.0;PAID;**2,7,8,22,37,43,82,93,112,117,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Called by Pay Per Cert Option on T&A Superv menu. Timecard 4 each
+5 ;employee in this supervs T&L is displayed. Superv prompted at each
+6 ;display as to whether card is ready 4 certification. Cards that r
+7 ;ready r saved in ^TMP. After this review--elect sign code is
+8 ;required to release approved cards to payroll. Upon ES
+9 ; 8b, exceptions, & ot warnings r stored & timecard status
+10 ;changed to 'P'--'released to payroll'
+11 ;
+12 ;=====================================================================
+13 ;
+14 ;Set up reverse video ON & OFF for tour error highlighting
+15 NEW IORVOFF,IORVON,IOINHI,IOINORM,IOBOFF,IOBON,RESP
+16 SET X="IORVOFF;IORVON;IOBOFF;IOBON;IOINHI;IOINORM"
DO ENDR^%ZISS
+17 ;
+18 NEW MIDPP,DUMMY
+19 SET MIDPP="In middle of Pay Period; Cannot Certify & Release."
+20 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+21 WRITE !?27,"SUPERVISORY CERTIFICATION"
+22 SET PRSTLV=3
DO ^PRSAUTL
if TLI<1
GOTO EX
+23 DO NOW^%DTC
+24 SET DT=%\1
SET APDT=%
SET Y=$GET(^PRST(458,"AD",DT))
SET PPI=$PIECE(Y,U,1)
SET DAY=$PIECE(Y,U,2)
+25 IF DAY>5
IF DAY<11
WRITE $CHAR(7),!!,MIDPP
GOTO EX
+26 IF DAY<6
SET X1=DT
SET X2=-7
DO C^%DTC
SET PPI=$PIECE($GET(^PRST(458,"AD",X)),U,1)
if 'PPI
GOTO EX
+27 ; -----------------------------------------
P0 ;PDT = string of pay period dates with format - Sun 29-Sep-96^
+1 ;PDTI = string of pay period dates in fileman format.
+2 ;PPI = pay period internal entry number in file 458.
+3 ;GLOB = global reference for employees pay period record
+4 ; returned from $$AVAILREC & passed to UNLOCK.
+5 ; -----------------------------------------
+6 ;
+7 SET PDT=$GET(^PRST(458,PPI,2))
SET PDTI=$GET(^(1))
SET QT=0
KILL ^TMP($JOB)
+8 ;
+9 ; -----------------------------------------
+10 ;Loop thru this supervisor's T&L unit on x-ref in 450.
+11 ;$$availrec() ensures there's data & node with employee's
+12 ;pay period record is NOT locked, then locks node.
+13 ;Call to CHK checks for needed approvals for current employee
+14 ;If supervisor decides record is not ready, during this call,
+15 ;then node is unlocked. Records that super accepts for release
+16 ;are not unlocked until they are processed thru temp global
+17 ;& their status' are updated.
+18 ; ---------------------------------------------------
+19 ;
+20 SET NN=""
SET CKS=1
+21 FOR
SET NN=$ORDER(^PRSPC("ATL"_TLE,NN))
if NN=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^PRSPC("ATL"_TLE,NN,DFN))
if DFN<1
QUIT
IF $$AVAILREC^PRSLIB00("SUP",.GLOB)
DO CHK
IF QT
GOTO T0
+22 ;
+23 ; ---------------------------------------------------
+24 ;Loop through T&L unit file x-ref 2 c if this supervisor certifies
+25 ;payperiod data for other supervisors of other T&L units. If so
+26 ;process after ensuring node to be certified is available.
+27 ; ---------------------------------------------------
+28 ;
+29 SET CKS=0
+30 FOR VA2=0:0
SET VA2=$$TLSUP
if VA2<1
QUIT
SET SSN=$$SSN
IF SSN'=""
SET DFN=$$DFN
SET Z=$PIECE($GET(^PRSPC(+DFN,0)),U,8)
IF Z'=""
IF Z'=TLE
IF $$AVAILREC^PRSLIB00("SUP",.GLOB)
DO CHK
IF QT
if '$TEST
GOTO EX
GOTO T0
+31 ;
+32 ; ---------------------------------------------------
T0 IF $DATA(^TMP($JOB,"E"))
GOTO T1
+1 WRITE !!,"No records have been selected for certification."
+2 SET DUMMY=$$ASK^PRSLIB00(1)
GOTO EX
+3 ;
+4 ; ---------------------------------------------------
+5 ;
T1 ;if supervisor signs off then update all records in tmp
+1 ;otherwise remove any auto posting.
+2 DO ^PRSAES
IF ESOK
Begin DoDot:1
+3 DO NOW^%DTC
SET APDT=%
+4 FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,"E",DFN))
if DFN<1
QUIT
SET VAL=$GET(^(DFN))
DO PROC
End DoDot:1
+5 IF 'ESOK
Begin DoDot:1
+6 FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,"E",DFN))
if DFN<1
QUIT
Begin DoDot:2
+7 DO AUTOPINI^PRS8(PPI,DFN)
End DoDot:2
End DoDot:1
+8 DO EX
+9 QUIT
+10 ;
+11 ; ---------------------------------------------------
CHK ; Check for needed approvals
+1 NEW PRSENT,PRSWOC
+2 SET STAT=$PIECE($GET(^PRST(458,PPI,"E",DFN,0)),U,2)
IF "PX"[STAT
QUIT
+3 IF USR=DFN
if '$DATA(^XUSEC("PRSA SIGN",DUZ))
QUIT
+4 IF '$TEST
IF CKS
SET SSN=$PIECE($GET(^PRSPC(DFN,0)),U,9)
IF SSN
SET EDUZ=+$ORDER(^VA(200,"SSN",SSN,0))
IF $DATA(^PRST(455.5,"AS",EDUZ,TLI))
if $PIECE($GET(^PRST(455.5,TLI,"S",EDUZ,0)),U,2)'=TLE
QUIT
+5 SET HDR=0
DO HDR
DO ^PRSAENT
SET PRSENT=ENT
+6 ;
+7 ;Loop to display tour, exceptions(leave, etc..) & errors.
+8 ;
+9 SET (XF,X9)=0
+10 FOR DAY=1:1:14
DO TOURERR($PIECE(PDT,U,DAY),.X9,.XF)
if $Y>(IOSL-6)&(DAY<14)
DO HDR
if QT
GOTO O1
+11 ;
+12 ;Display VCS commission sales, if applicable
+13 SET Z=$GET(^PRST(458,PPI,"E",DFN,2))
+14 IF Z'=""
if $Y>(IOSL-11)
DO HDR
if QT
QUIT
DO VCS^PRSASR1
+15 ;
+16 ;
+17 SET Z=$GET(^PRST(458,PPI,"E",DFN,4))
+18 IF Z'=""
if $Y>(IOSL-9)
DO HDR
if QT
QUIT
DO ED^PRSASR1
+19 IF XF
WRITE !,IORVON,"Serious error; cannot release.",IORVOFF
SET QT=$$ASK^PRSLIB00()
QUIT
+20 SET QT=$$ASK^PRSLIB00()
if QT
QUIT
+21 ;
+22 ;PRS8 call creates & stores 8B string in employees attendance
+23 ;record. Later, under a payroll option, string will be
+24 ;transmitted to Austin.
+25 ;
+26 NEW NN
DO ONE^PRS8
SET C0=$GET(^PRSPC(DFN,0))
SET PY=PPI
DO CERT^PRS8VW
SET QT=0
+27 ;
+28 ;Show OT (approve-vs-8B) warning & save in TMP.
+29 NEW WK,OTERR,O8,OA
+30 FOR WK=1:1:2
Begin DoDot:1
+31 DO WARNSUP^PRSAOTT(PPE,DFN,VAL,WK,.OTERR,.O8,.OA)
+32 IF OTERR
SET ^TMP($JOB,"OT",DFN,WK)=O8_U_OA
End DoDot:1
+33 ;
+34 ;warning message for rs/rn and on type of time
+35 IF $EXTRACT(PRSENT,5)
Begin DoDot:1
+36 IF @($TRANSLATE($$CD8B^PRSU1B2(VAL,"RS^3^RN^3",1),U,"+")_"-("_$TRANSLATE($$RSHR^PRSU1B2(DFN,PPI),U,"+")_")")
WRITE !,?3,"WARNING: The total scheduled recess hours for this pay period does not match the total RS/RN posted."
+37 IF $GET(PRSWOC)]""
WRITE !,?3,"Warning: The entire tour for day# ",PRSWOC," is posted RECESS. The On-Call will be paid unless posted UNAVAILABLE."
+38 QUIT
End DoDot:1
+39 ;
LD ; Check for changes to the Labor Distribution Codes made during the pay
+1 ; period.
+2 IF $DATA(^PRST(458,PPI,"E",DFN,"LDAUD"))
DO LD^PRSASR1
+3 ; ---------------------------------------------------
OK ;Prompt Supervisor to release timecard. If yes, store in ^TMP(.
+1 ;If supervisor answers no then bypass & unlock record.
+2 ; ---------------------------------------------------
+3 WRITE !!,IORVON,"Release to Payroll?",IORVOFF," "
+4 READ X:DTIME
if '$TEST!(X[U)
SET QT=1
if QT
QUIT
if X=""
SET X="*"
SET X=$TRANSLATE(X,"yesno","YESNO")
+5 IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE $CHAR(7)," Answer YES or NO"
GOTO OK
+6 IF X?1"Y".E
SET ^TMP($JOB,"E",DFN)=VAL
+7 IF '$TEST
Begin DoDot:1
+8 ; remove any auto posting
DO AUTOPINI^PRS8(PPI,DFN)
+9 ; unlock record
DO UNLOCK^PRSLIB00(GLOB)
+10 ;clean out of local lock list.
KILL ^TMP($JOB,"LOCK",DFN)
End DoDot:1
O1 QUIT
+1 ;
PROC ; Set Approval, file any exceptions & update 8B string
+1 ;
+2 ; get employees entitlement string in variable A1
+3 DO ^PRSAENT
+4 ;
+5 ; set approvals
+6 SET $PIECE(^PRST(458,PPI,"E",DFN,0),U,3,5)=DUZ_U_APDT_U_A1
+7 ; VCS approval
+8 IF $DATA(^PRST(458,PPI,"E",DFN,2))
SET $PIECE(^(2),U,17,18)=DUZ_U_APDT
+9 ;
+10 ; loop thru any exceptions & file in 458.5
+11 IF $DATA(^TMP($JOB,"X",DFN))
SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"X",DFN,K))
if K=""
QUIT
SET DAY=$PIECE(K," ",1)
SET X1=$PIECE(PDTI,U,DAY)
SET X2=$GET(^(K))
DO ^PRSATPF
+12 ;
+13 ; file overtime warnings
+14 FOR WK=1:1:2
IF $GET(^TMP($JOB,"OT",DFN,WK))'=""
Begin DoDot:1
+15 SET O8=$PIECE(^TMP($JOB,"OT",DFN,WK),U)
+16 SET OA=$PIECE(^TMP($JOB,"OT",DFN,WK),U,2)
+17 DO FILEOTW^PRSAOTTF(PPI,DFN,WK,O8,OA)
End DoDot:1
+18 ;
+19 ;set 8b string & change status of timecard to payroll
+20 SET ^PRST(458,PPI,"E",DFN,5)=VAL
SET $PIECE(^PRST(458,PPI,"E",DFN,0),U,2)="P"
+21 ;set the pp telework indicator
+22 if $PIECE($$TWE^PRSATE0(DFN),U)]""
SET $PIECE(^PRST(458,PPI,"E",DFN,0),U,8)=$PIECE($$TWE^PRSATE0(DFN),U)
+23 ;
+24 ; If employee is a PT Phys w/ memo update hours credited
+25 DO PTP^PRSASR1(DFN,PPI)
+26 ;
+27 ;unlock employees time card record
+28 SET GLOB="^PRST(458,"_PPI_","_"""E"""_","_DFN_",0)"
+29 DO UNLOCK^PRSLIB00(GLOB)
+30 ;clean out of local lock list.
KILL ^TMP($JOB,"LOCK",DFN)
+31 QUIT
+32 ;
+33 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+34 ;
HDR ; Display Header
+1 IF HDR
SET QT=$$ASK^PRSLIB00()
if QT
QUIT
+2 SET X=$GET(^PRSPC(DFN,0))
WRITE !,@IOF,?2,$PIECE(X,U,1)
SET X=$PIECE(X,U,9)
IF X
WRITE ?68,$EXTRACT(X),"XX-XX-",$EXTRACT(X,6,9)
SET HDR=1
+3 WRITE !,?6,"Date",?16,"TW",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF
+4 WRITE !?2
FOR I=1:1:72
WRITE "-"
+5 QUIT
+6 ;====================================================================
HDR2 ; Display Header don't quit
+1 NEW HOLD
+2 SET HOLD=$$ASK^PRSLIB00(1)
+3 SET X=$GET(^PRSPC(DFN,0))
WRITE !,@IOF,?2,$PIECE(X,U,1)
SET X=$PIECE(X,U,9)
IF X
WRITE ?68,$EXTRACT(X),"XX-XX-",$EXTRACT(X,6,9)
+4 WRITE !,?6,"Date",?16,"TW",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF
+5 WRITE !?2
FOR I=1:1:72
WRITE "-"
+6 QUIT
+7 ;====================================================================
+8 ;
EX ; clean up variables & unlock any leftover time card nodes
+1 NEW EMPREC
+2 SET EMPREC=""
+3 FOR
SET EMPREC=$ORDER(^TMP($JOB,"LOCK",EMPREC))
if EMPREC=""
QUIT
Begin DoDot:1
+4 SET GLOB="^PRST(458,"_PPI_","_"""E"""_","_EMPREC_",0)"
+5 DO UNLOCK^PRSLIB00(GLOB)
End DoDot:1
+6 KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
+7 QUIT
+8 ;
+9 ;
+10 ;These extrinsic functions simply remove lengthy code from long,
+11 ;single line, nested loop.
+12 ; ---------------------------------------------------
TLSUP() ;get next supervisor who certifies other supervisors
+1 QUIT $ORDER(^PRST(455.5,"ASX",TLE,VA2))
+2 ; ---------------------------------------------------
SSN() ;get ssn of supervisor to be certified by this supervisor.
+1 QUIT $PIECE($GET(^VA(200,VA2,1)),U,9)
+2 ; ---------------------------------------------------
DFN() ;get internal entry number of supvisor of other T&L 2b approved
+1 ;by current supervisor.
+2 QUIT $ORDER(^PRSPC("SSN",SSN,0))
+3 ;====================================================================
TOURERR(DTE,X9,XF) ;DISPLAY TOUR & ERRORS
+1 ;
+2 NEW IORVOFF,IORVON,RESP,ERRLEN
+3 SET X="IORVOFF;IORVON"
DO ENDR^%ZISS
+4 DO F1^PRSADP1
DO ^PRSATPE
+5 FOR K=1:1
if '$DATA(Y1(K))&'$DATA(Y2(K))
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-4)
DO HDR2
+7 if K>1
WRITE !
+8 if $DATA(Y1(K))
WRITE ?21,Y1(K)
+9 if $PIECE($GET(Y2(K)),U)'=""
WRITE ?45,$PIECE(Y2(K),U,1)
+10 IF $PIECE($GET(Y2(K)),U,2)'=""
if $X>44
WRITE !
WRITE ?45,$PIECE(Y2(K),U,2)
End DoDot:1
+11 if Y3'=""
WRITE !?10,Y3
+12 IF $DATA(ER)
if FATAL
SET XF=1
FOR K=0:0
SET K=$ORDER(ER(K))
if K<1
QUIT
Begin DoDot:1
+13 IF $Y>(IOSL-4)
DO HDR2
+14 SET ERRLEN=$SELECT($PIECE(ER(K),U,2)'="":$LENGTH(ER(K)),1:$LENGTH($PIECE($GET(ER(K)),U))+1)
+15 if X9!((ERRLEN+1)>(IOM-$X))
WRITE !
+16 WRITE ?(IOM-(ERRLEN+1)),IORVON
+17 if $PIECE(ER(K),U,2)'=""
WRITE $PIECE(ER(K),U,2)
+18 WRITE " ",$PIECE(ER(K),U,1),IORVOFF
+19 SET X9=0
if 'XF
SET ^TMP($JOB,"X",DFN,DAY_" "_K)=ER(K)
+20 QUIT
End DoDot:1
+21 QUIT
