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