source: FOIAVistA/trunk/r/PAID-PRS/PRSPEM.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 7.3 KB
Line 
1PRSPEM ;WOIFO/MGD - PTP ENTER MEMORANDUM ;06/01/05
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;The following routine will allow HR to enter a Part Time Physician's
6 ;Memorandum of Service Level Expectations. Memorandums will cover 364
7 ;days (26 full Pay Periods) and the Agreed Hours must be equally
8 ;divisible by 26.
9 ;
10 Q
11MAIN ; Main Driver
12 N DFN,STDAT,ENDAT,AHRS,ICOM,ESOK
13 ; Prompt for Part Time Physician
14 D PTP
15 I PRSIEN'>0 D KILL Q
16 ; Display Header info to validate the correct employee was chosen
17 D HDR
18 ; Prompt and validate Start Date. Calculate and display End Date
19 S QUIT=0
20 F D Q:QUIT!('OVERLAP)
21 . S OVERLAP=0
22 . D START
23 . Q:QUIT
24 . D END
25 I QUIT D KILL Q
26 ;
27 ; Prompt and validate Agreed Hours
28 D AHRS
29 I Y'>0 D KILL Q
30 ; Prompt for Initial Comments
31 D ICOM
32 I Y="^" D KILL Q
33 ; Prompt for E-Sig and save if confirmed
34 D ESIG
35 Q
36 ;
37PTP ; Prompt for Part Time Physician
38 N SSN
39 W !
40 S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: "
41 D ^DIC K DIC
42 S PRSIEN=+Y
43 Q:PRSIEN<1
44 ;
45 ; determine associated NEW PERSON entry
46 S SSN=$$GET1^DIQ(450,PRSIEN_",",8,"I")
47 S IEN200=$S(SSN="":"",1:$O(^VA(200,"SSN",SSN,0)))
48 I 'IEN200 D
49 . W $C(7),!!,"Can't find an entry in the NEW PERSON file for this employee."
50 . W !,"They must be added as a user before the memorandum is created."
51 . S PRSIEN=-1
52 Q
53 ;
54HDR ; Display PTP info
55 S SCRTTL="Enter PT Physician Memoranda"
56 D HDR^PRSPUT1(PRSIEN,SCRTTL)
57 W !
58 Q
59 ;
60START ; Prompt for Start Date
61 ; This subroutine prompts for the date then goes through several
62 ; checks if any check fails we give an explanation message and
63 ; reprompt for the date. If no checks fail we set valid to
64 ; quit. The user must ^ or timeout to quit.
65 ;
66 N VALID S VALID=0
67 F D Q:QUIT!(VALID)
68 . N Y,DIR,DIRUT S DIR(0)="458.7,1A0",DIR("A")="Start Date: " D ^DIR
69 .; Validate that the Start Date is the first day of a Pay Period.
70 . I $D(DIRUT) S QUIT=1 Q
71 . S D1=+Y
72 . D PP^PRSAPPU
73 . I DAY'=1 D Q
74 . . D SILMO^PRSLIB01(D1)
75 . . W !,"You entered ",$$EXTERNAL^DILFD(458.7,1,,D1)
76 . . W !!,"The Start Date must be the first day of a Pay Period."
77 . . W !,"Please re-enter.",!
78 . S STDAT=D1
79 .; Check to see if this employee's timecard for this PP is
80 .; in a status other than Timekeeper
81 . S PPI=$P($G(^PRST(458,"AD",D1)),U)
82 . I (D1<DT),($G(PPI)'>0) D Q
83 . . W !!,?3,"There is no pay period on file for that past date."
84 .;
85 .; for all past dates the employee must have a timecard in a
86 .; a status of 'T"
87 .;
88 . I (D1<DT),($P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T") D Q
89 .. W !!,?3,"To enter memos for past dates, the employee must have a"
90 .. W !,?3,"timecard in Timekeeper status."
91 .;
92 .; for future dates when there is a timecard we must also be in
93 .; timekeeper status
94 .;
95 . I (D1'<DT),($G(PPI)>0),$D(^PRST(458,PPI,"E",PRSIEN,0)),($P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T") D Q
96 . . W !!,?3,"This employee's timecard has a status other than "
97 . . W !,?3,"Timekeeper. It will have to be returned to the Timekeeper "
98 . . W !,?3,"before a memo covering this pay period can be entered."
99 .;
100 .; If we make it through all the checks set valid and QUIT only gets
101 .; set when we abort or timeout
102 . S VALID=1
103 Q
104 ;
105END ; Calculate and display End Date
106 N X1,X2,X,Y
107 S X1=D1,X2=363
108 D C^%DTC
109 S ENDDAT=X,Y=X
110 D DD^%DT
111 W !," End Date: ",Y
112 K D1
113 ; Verify that there are no other Memorandums covering this same time
114 S IEN=""
115 F S IEN=$O(^PRST(458.7,"B",PRSIEN,IEN)) Q:IEN="" D Q:QUIT
116 . S DATA=$G(^PRST(458.7,IEN,0))
117 . Q:DATA=""
118 . S START=$P(DATA,U,2),END=$P(DATA,U,3),STATUS=$P(DATA,U,6)
119 . S TDAT=$P($G(^PRST(458.7,IEN,4)),U,1) ; Termination Date
120 . S END=$S(TDAT:TDAT,1:END)
121 . I STDAT'>START,ENDDAT'<START D OVRLAP
122 . I STDAT'>END,ENDDAT'<END D OVRLAP
123 ; If all checks have passed, calculate the PPs covered by the Memo
124 I $G(PPE)?2N1"-"2N D CALPP
125 Q
126 ;
127OVRLAP ; Display warning when dates cover an existing memo
128 ;
129 S Y=START ; START DATE
130 D DD^%DT
131 S START=Y
132 S Y=END ; END DATE
133 D DD^%DT
134 S END=Y
135 W !!,"These dates overlap the following memorandum:"
136 W !,"Start Date: ",START," - "
137 W $S(TDAT:"Termination Date: ",1:"End Date: "),END
138 S OVERLAP=1
139 Q
140 ;
141AHRS ; Display list of Agreed Hours
142 W !!,"Agreed Hours must be equally divisible by 26 Pay Periods."
143 W !!,"1/8 = 260, 1/4 = 520, 3/8 = 780, 1/2 = 1040, 5/8 = 1300, "
144 W "3/4 = 1560, 7/8 = 1820",!
145 S DIR(0)="NO",DIR("A")="Agreed Hours"
146 D ^DIR
147 ; Verify that Agreed Hours is divisible by 26.
148 I Y#26 G AHRS
149 S AHRS=Y
150 Q
151 ;
152ICOM ; Prompt for Initial Comments
153 W !
154 S DIR(0)="FO^1:240^^O",DIR("A")="Initial Comments" D ^DIR
155 S ICOM=Y
156 Q
157 ;
158ESIG ; Prompt for Electronic Signature and store fields in #458.7
159 ;
160 N ESOK,HOL
161 K PRSFDA,IEN4587
162 D ^PRSAES
163 I ESOK D
164 . ; Create entry in #458.7
165 . S PRSFDA(458.7,"+1,",.01)=PRSIEN ; EMPLOYEE
166 . D UPDATE^DIE("","PRSFDA","IEN4587"),MSG^DIALOG()
167 . S IEN4587=IEN4587(1)_","
168 . S PRSFDA(458.7,IEN4587,1)=STDAT ; START DATE
169 . S PRSFDA(458.7,IEN4587,2)=ENDDAT ; END DATE
170 . S PRSFDA(458.7,IEN4587,3)=AHRS ; AGREED HOURS
171 . S PRSFDA(458.7,IEN4587,4)=ICOM ; INITIAL COMMENTS
172 . ;
173 . ; Check to see if 1st pay period covered by memo is opened
174 . ; 1 = NOT STARTED 2 = ACTIVE
175 . S PRSFDA(458.7,IEN4587,5)=$S($D(^PRST(458,"AD",STDAT)):2,1:1)
176 . S PRSFDA(458.7,IEN4587,6)=DUZ ; ENTERED BY
177 . D NOW^%DTC
178 . S PRSFDA(458.7,IEN4587,7)=% ; DATE/TIME ENTERED
179 . D FILE^DIE("","PRSFDA",),MSG^DIALOG() ; Set fields into 0 node
180 . ;
181 . ; Initialize the PPs within the Memo (#458.701 multiple)
182 . F I=1:1:26 D
183 . . S PRSFDA(458.701,"+"_I_","_IEN4587,.01)=$P(PPESTR,U,I)
184 . D UPDATE^DIE("","PRSFDA"),MSG^DIALOG()
185 . ;
186 . ; Allocate the security key to the PTP if they don't already hold it
187 . I '$D(^XUSEC("PRSP EMP",IEN200)) D
188 . . N KEYIEN
189 . . S KEYIEN=$$FIND1^DIC(19.1,,"X","PRSP EMP")
190 . . I 'KEYIEN D Q
191 . . . W !!,"PRSP EMP key was not found in the 19.1 file."
192 . . S PRSFDA(200.051,"?+1,"_IEN200_",",.01)=KEYIEN
193 . . S PRSIENS(1)=KEYIEN
194 . . D UPDATE^DIE("","PRSFDA","PRSIENS"),MSG^DIALOG()
195 ;
196 ; Check to see if PPs covered by the memo are already opened
197 Q:'$$MIEN^PRSPUT1(PRSIEN,STDAT)
198 S PPI=+$G(^PRST(458,"AD",STDAT))
199 Q:'PPI
200 ; Loop thru pay periods in file 458
201 S PPI=PPI-.001 ; init PPI so loop will include 1st PP covered by memo
202 F S PPI=$O(^PRST(458,PPI)) Q:'PPI D
203 . N PRSD
204 . ; Quit if the employee doesn't have a timecard for this PP yet.
205 . ; When the Timekeeper creates the timecard it will update the ESR as
206 . ; needed
207 . Q:'$D(^PRST(458,PPI,"E",PRSIEN,0))
208 . ; Quit if timecard does not have status = Timekeeper
209 . Q:$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T"
210 . ;
211 . ; clear any Timecard exceptions, remarks, and posting status
212 . F PRSD=1:1:14 K ^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2),^(3),^(10)
213 . ; Call to initialize ESR
214 . D ^PRSAPPH ; Set up HOL and PDT
215 . D ESRUPDT^PRSPUT3(PPI,PRSIEN)
216 . ; Call to Autopost PT Phy Leave
217 . D PLPP^PRSPLVA(PRSIEN,PPI)
218 . ; Call to Autopost PT Phy Extended Absence
219 . D PEAPP^PRSPEAA(PRSIEN,PPI)
220 ;
221 Q
222 ;
223CALPP ; Calculate the PPs covered by the memorandum
224 S PPESTR=""
225 S (STDATX,D1)=STDAT
226 D PP^PRSAPPU
227 S PPESTR=PPESTR_PPE_U
228 F I=1:1:25 D
229 . S X1=STDATX,X2=14
230 . D C^%DTC
231 . S (D1,STDATX)=X
232 . D PP^PRSAPPU
233 . S PPESTR=PPESTR_PPE_$S(I=25:"",1:"^")
234 Q
235 ;
236KILL ; Clean up variables
237 ;
238 K AHRS,DATA,DAY,DIR,END,ENDDAT,I,ICOM,IEN,IEN200,IEN4587,OVERLAP
239 K PPE,PPI,PPESTR,PRSFDA,PRSIEN,PRSIENS,QUIT,SCRTTL,START,STATUS
240 K STDAT,STDATX,TDAT,X,Y,%,%DT
241 Q
Note: See TracBrowser for help on using the repository browser.