source: FOIAVistA/tag/r/PAID-PRS/PRSASR.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 8.9 KB
Line 
1PRSASR ;HISC/MGD,WOIFO/JAH - Supervisor Certification ;02/05/2005
2 ;;4.0;PAID;**2,7,8,22,37,43,82,93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;Called by Pay Per Cert Option on T&A Superv menu. Timecard 4 each
6 ;employee in this supervs T&L is displayed. Superv prompted at each
7 ;display as to whether card is ready 4 certification. Cards that r
8 ;ready r saved in ^TMP. After this review--elect sign code is
9 ;required to release approved cards to payroll. Upon ES
10 ; 8b, exceptions, & ot warnings r stored & timecard status
11 ;changed to 'P'--'released to payroll'
12 ;
13 ;=====================================================================
14 ;
15 ;Set up reverse video ON & OFF for tour error highlighting
16 N IORVOFF,IORVON,IOINHI,IOINORM,IOBOFF,IOBON,RESP
17 S X="IORVOFF;IORVON;IOBOFF;IOBON;IOINHI;IOINORM" D ENDR^%ZISS
18 ;
19 N MIDPP,DUMMY
20 S MIDPP="In middle of Pay Period; Cannot Certify & Release."
21 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
22 W !?27,"SUPERVISORY CERTIFICATION"
23 S PRSTLV=3 D ^PRSAUTL G:TLI<1 EX
24 D NOW^%DTC
25 S DT=%\1,APDT=%,Y=$G(^PRST(458,"AD",DT)),PPI=$P(Y,"^",1),DAY=$P(Y,"^",2)
26 I DAY>5,DAY<11 W $C(7),!!,MIDPP G EX
27 I DAY<6 S X1=DT,X2=-7 D C^%DTC S PPI=$P($G(^PRST(458,"AD",X)),"^",1) G:'PPI EX
28 ; -----------------------------------------
29P0 ;PDT = string of pay period dates with format - Sun 29-Sep-96^
30 ;PDTI = string of pay period dates in fileman format.
31 ;PPI = pay period internal entry number in file 458.
32 ;GLOB = global reference for employees pay period record
33 ; returned from $$AVAILREC & passed to UNLOCK.
34 ; -----------------------------------------
35 ;
36 S PDT=$G(^PRST(458,PPI,2)),PDTI=$G(^(1)),QT=0 K ^TMP($J)
37 ;
38 ; -----------------------------------------
39 ;Loop thru this supervisor's T&L unit on x-ref in 450.
40 ;$$availrec() ensures there's data & node with employee's
41 ;pay period record is NOT locked, then locks node.
42 ;Call to CHK checks for needed approvals for current employee
43 ;If supervisor decides record is not ready, during this call,
44 ;then node is unlocked. Records that super accepts for release
45 ;are not unlocked until they are processed thru temp global
46 ;& their status' are updated.
47 ; ---------------------------------------------------
48 ;
49 S NN="",CKS=1
50 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
51 ;
52 ; ---------------------------------------------------
53 ;Loop through T&L unit file x-ref 2 c if this supervisor certifies
54 ;payperiod data for other supervisors of other T&L units. If so
55 ;process after ensuring node to be certified is available.
56 ; ---------------------------------------------------
57 ;
58 S CKS=0
59 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)),"^",8) I Z'="",Z'=TLE,$$AVAILREC^PRSLIB00("SUP",.GLOB) D CHK I QT G EX:'$T,T0
60 ;
61 ; ---------------------------------------------------
62T0 I $D(^TMP($J,"E")) G T1
63 W !!,"No records have been selected for certification."
64 S DUMMY=$$ASK^PRSLIB00(1) G EX
65 ;
66 ; ---------------------------------------------------
67 ;
68T1 ;if supervisor signs off then update all records in tmp
69 ;otherwise remove any auto posting.
70 D ^PRSAES I ESOK D
71 .D NOW^%DTC S APDT=%
72 .F DFN=0:0 S DFN=$O(^TMP($J,"E",DFN)) Q:DFN<1 S VAL=$G(^(DFN)) D PROC
73 I 'ESOK D
74 .F DFN=0:0 S DFN=$O(^TMP($J,"E",DFN)) Q:DFN<1 D
75 ..D AUTOPINI^PRS8(PPI,DFN)
76 D EX
77 Q
78 ;
79 ; ---------------------------------------------------
80CHK ; Check for needed approvals
81 S STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) I "PX"[STAT Q
82 I USR=DFN Q:'$D(^XUSEC("PRSA SIGN",DUZ))
83 E I CKS S SSN=$P($G(^PRSPC(DFN,0)),"^",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)),"^",2)'=TLE
84 S HDR=0 D HDR
85 ;
86 ;Loop to display tour, exceptions(leave, etc..) & errors.
87 ;
88 S (XF,X9)=0
89 F DAY=1:1:14 D TOURERR($P(PDT,"^",DAY),.X9,.XF) D:$Y>(IOSL-6)&(DAY<14) HDR G:QT O1
90 ;
91 ;Display VCS commission sales, if applicable
92 S Z=$G(^PRST(458,PPI,"E",DFN,2))
93 I Z'="" D:$Y>(IOSL-11) HDR Q:QT D VCS^PRSASR1
94 ;
95 ;
96 S Z=$G(^PRST(458,PPI,"E",DFN,4))
97 I Z'="" D:$Y>(IOSL-9) HDR Q:QT D ED^PRSASR1
98 I XF W !,IORVON,"Serious error; cannot release.",IORVOFF S QT=$$ASK^PRSLIB00() Q
99 S QT=$$ASK^PRSLIB00() Q:QT
100 ;
101 ;PRS8 call creates & stores 8B string in employees attendance
102 ;record. Later, under a payroll option, string will be
103 ;transmitted to Austin.
104 ;
105 N NN D ONE^PRS8 S C0=$G(^PRSPC(DFN,0)),PY=PPI D CERT^PRS8VW S QT=0
106 ;
107 ;Show OT (approve-vs-8B) warning & save in TMP.
108 N WK,OTERR,O8,OA
109 F WK=1:1:2 D
110 . D WARNSUP^PRSAOTT(PPE,DFN,VAL,WK,.OTERR,.O8,.OA)
111 . I OTERR S ^TMP($J,"OT",DFN,WK)=O8_"^"_OA
112 ;
113LD ; Check for changes to the Labor Distribution Codes made during the pay
114 ; period.
115 I $D(^PRST(458,PPI,"E",DFN,"LDAUD")) D LD^PRSASR1
116 ; ---------------------------------------------------
117OK ;Prompt Supervisor to release timecard. If yes, store in ^TMP(.
118 ;If supervisor answers no then bypass & unlock record.
119 ; ---------------------------------------------------
120 W !!,IORVON,"Release to Payroll?",IORVOFF," "
121 R X:DTIME S:'$T!(X["^") QT=1 Q:QT S:X="" X="*" S X=$TR(X,"yesno","YESNO")
122 I $P("YES",X,1)'="",$P("NO",X,1)'="" W $C(7)," Answer YES or NO" G OK
123 I X?1"Y".E S ^TMP($J,"E",DFN)=VAL
124 E D
125 . D AUTOPINI^PRS8(PPI,DFN) ; remove any auto posting
126 . D UNLOCK^PRSLIB00(GLOB) ; unlock record
127 . K ^TMP($J,"LOCK",DFN) ;clean out of local lock list.
128O1 Q
129 ;
130PROC ; Set Approval, file any exceptions & update 8B string
131 ;
132 ; get employees entitlement string in variable A1
133 D ^PRSAENT
134 ;
135 ; set approvals
136 S $P(^PRST(458,PPI,"E",DFN,0),"^",3,5)=DUZ_"^"_APDT_"^"_A1
137 ; VCS approval
138 I $D(^PRST(458,PPI,"E",DFN,2)) S $P(^(2),"^",17,18)=DUZ_"^"_APDT
139 ;
140 ; loop thru any exceptions & file in 458.5
141 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,"^",DAY),X2=$G(^(K)) D ^PRSATPF
142 ;
143 ; file overtime warnings
144 F WK=1:1:2 I $G(^TMP($J,"OT",DFN,WK))'="" D
145 . S O8=$P(^TMP($J,"OT",DFN,WK),"^")
146 . S OA=$P(^TMP($J,"OT",DFN,WK),"^",2)
147 . D FILEOTW^PRSAOTTF(PPI,DFN,WK,O8,OA)
148 ;
149 ;set 8b string & change status of timecard to payroll
150 S ^PRST(458,PPI,"E",DFN,5)=VAL S $P(^PRST(458,PPI,"E",DFN,0),"^",2)="P"
151 ;
152 ; If employee is a PT Phys w/ memo update hours credited
153 D PTP^PRSASR1(DFN,PPI)
154 ;
155 ;unlock employees time card record
156 S GLOB="^PRST(458,"_PPI_","_"""E"""_","_DFN_",0)"
157 D UNLOCK^PRSLIB00(GLOB)
158 K ^TMP($J,"LOCK",DFN) ;clean out of local lock list.
159 Q
160 ;
161 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
162 ;
163HDR ; Display Header
164 I HDR S QT=$$ASK^PRSLIB00() Q:QT
165 S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) S HDR=1
166 W !,?6,"Date",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF
167 W !?3 F I=1:1:72 W "-"
168 Q
169 ;====================================================================
170HDR2 ; Display Header don't quit
171 N HOLD
172 S HOLD=$$ASK^PRSLIB00(1)
173 S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)
174 W !,?6,"Date",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF
175 W !?3 F I=1:1:72 W "-"
176 Q
177 ;====================================================================
178 ;
179EX ; clean up variables & unlock any leftover time card nodes
180 N EMPREC
181 S EMPREC=""
182 F S EMPREC=$O(^TMP($J,"LOCK",EMPREC)) Q:EMPREC="" D
183 . S GLOB="^PRST(458,"_PPI_","_"""E"""_","_EMPREC_",0)"
184 . D UNLOCK^PRSLIB00(GLOB)
185 K ^TMP($J) G KILL^XUSCLEAN
186 Q
187 ;
188 ;====================================================================
189 ;These extrinsic functions simply remove lengthy code from long,
190 ;single line, nested loop.
191 ; ---------------------------------------------------
192TLSUP() ;get next supervisor who certifies other supervisors
193 Q $O(^PRST(455.5,"ASX",TLE,VA2))
194 ; ---------------------------------------------------
195SSN() ;get ssn of supervisor to be certified by this supervisor.
196 Q $P($G(^VA(200,VA2,1)),"^",9)
197 ; ---------------------------------------------------
198DFN() ;get internal entry number of supvisor of other T&L 2b approved
199 ;by current supervisor.
200 Q $O(^PRSPC("SSN",SSN,0))
201 ;====================================================================
202TOURERR(DTE,X9,XF) ;DISPLAY TOUR & ERRORS
203 ;
204 N IORVOFF,IORVON,RESP,ERRLEN
205 S X="IORVOFF;IORVON" D ENDR^%ZISS
206 D F1^PRSADP1,^PRSATPE
207 F K=1:1 Q:'$D(Y1(K))&'$D(Y2(K)) D
208 . I $Y>(IOSL-4) D HDR2
209 . W:K>1 !
210 . W:$D(Y1(K)) ?21,Y1(K)
211 . W:$P($G(Y2(K)),"^")'="" ?45,$P(Y2(K),"^",1)
212 . I $P($G(Y2(K)),"^",2)'="" W:$X>44 ! W ?45,$P(Y2(K),"^",2)
213 W:Y3'="" !?10,Y3
214 I $D(ER) S:FATAL XF=1 F K=0:0 S K=$O(ER(K)) Q:K<1 D
215 . I $Y>(IOSL-4) D HDR2
216 .W:X9!($X>55) ! S ERRLEN=23
217 .I $P(ER(K),"^",2)'="" S ERRLEN=$L(ER(K))
218 .W ?(IOM-(ERRLEN+1)),IORVON
219 .W:$P(ER(K),"^",2)'="" $P(ER(K),"^",2)
220 .W " ",$P(ER(K),"^",1),IORVOFF
221 .S X9=0 S:'XF ^TMP($J,"X",DFN,DAY_" "_K)=ER(K)
222 .Q
223 Q
Note: See TracBrowser for help on using the repository browser.