source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPDFM.m@ 623

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

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1PRSPDFM ;WOIFO/MGD - PTP DELETE FUTURE MEMORANDUM ;04/07/05
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;The following routine will allow HR to delete a Part Time
5 ; Physician's Memorandum of Service Level Expectations.
6 ; For a memorandum to be eligible for deletion it must not have had
7 ; any Pay Period processed.
8 ;
9 Q
10MAIN ; Main Driver
11 N STDAT,ENDAT,AHRS,ICOM,ESOK
12 ; Prompt for Part Time Physician
13 D PTP
14 I Y'>0 D KILL Q
15 S PRSIEN=+Y
16 ; Find any memorandums that meet the deletion qualifications
17 D MEM
18 Q:'MIEN
19 ; Display employee and memorandum information
20 D DISPLAY
21 ; Issue Delete Memorandum prompt
22 W !!,"Delete this Memoranda: "
23 S %=0 D YN^DICN
24 I %'=1 D KILL Q
25 ; Prompt for E-sig and update file
26 D ESIG
27 ;
28 Q
29 ;
30PTP ; Prompt for Part Time Physician
31 W !
32 S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: "
33 D ^DIC K DIC
34 S PRSIEN=+Y
35 Q
36 ;
37MEM ; Find any memorandums that meet the deletion qualifications
38 N INDX,MEM,PPE,PPI459
39 S (MEM,MIEN)=0,INDX=1
40 F S MEM=$O(^PRST(458.7,"B",PRSIEN,MEM)) Q:'MEM D
41 . S DATA=$G(^PRST(458.7,MEM,0))
42 . Q:DATA=""
43 . S START=$P(DATA,U,2),END=$P(DATA,U,3) ; Start Date, End Date
44 . ; If the PP covering the Start Date is not opened no additional checks
45 . ; are needed
46 . S PPI=$P($G(^PRST(458,"AD",START)),U,1)
47 . I PPI="" D Q
48 . . S MIEN=MEM,MEM(1)=MIEN_"^"_START_"^"_END_"^ACTIVE"
49 . ; If the 1st PP covered by the memorandum is opened, check to see
50 . ; what status it is in.
51 . S PPE=$P($G(^PRST(458,PPI,0)),U,1)
52 . Q:PPE=""
53 . S PPI459=$O(^PRST(459,"B",PPE,0))
54 . ; Check to see if Payroll for the first PP of the memorandum has
55 . ; already been processed.
56 . I PPI459 D Q
57 . . W !!,"The payroll for the first Pay Period covered by this Memorandum"
58 . . W !,"has already been processed. This memorandum will have to be"
59 . . W !,"terminated and reconciled."
60 . . S MIEN=-1
61 . ; Checks for Payroll not yet processed.
62 . S STATUS=$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
63 . I STATUS="X" D Q
64 . . W !!,"This PT Physician's timecard has already been transmitted."
65 . . W !,"If you think there is enough time to retransmit their 8B, you may:"
66 . . W !,"1. Have the Payroll Supervisor return the timecard"
67 . . W !,"2. Delete the memorandum"
68 . . W !,"3. Have the PTP complete a paper Subsidiary Record"
69 . . W !,"4. Have the Supervisor review and approve the Subsidiary Record"
70 . . W !,"5. Have the Timekeeper post each day in the Pay Period"
71 . . W !,"6. Re-certify and re-transmit the timecard"
72 . . W !!,"If there isn't enough time, the memorandum will have to be"
73 . . W !,"terminated and reconciled."
74 . . S MIEN=-1
75 . ;
76 . I STATUS="P" D Q
77 . . W !!,"This PT Physician's timecard has already been certified."
78 . . W !,"If you think there is enough time, you may:"
79 . . W !,"1. Have the Payroll Supervisor return the timecard"
80 . . W !,"2. Delete the memorandum"
81 . . W !,"3. Have the PTP complete a paper Subsidiary Record"
82 . . W !,"4. Have the Supervisor review and approve the Subsidiary Record"
83 . . W !,"5. Have the Timekeeper post each day in the Pay Period"
84 . . W !,"6. Re-certify the timecard."
85 . . W !!,"If there isn't enough time, the memorandum will have to be"
86 . . W !,"terminated and reconciled."
87 . . S MIEN=-1
88 . ; The End Date for future memorandums may not be in #458 yet
89 . I PPI="" D Q
90 . . S MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE",INDX=INDX+1
91 . ; If the End Date is in #458 check the timecard status for that PP
92 . ; Quit if Timecard status for the last PP of the mem is not (T)imekeeper
93 . Q:$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T"
94 . S MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE",INDX=INDX+1
95 ; If no memos meet the deletion qualifications
96 I '$D(MEM(1)) D Q
97 . W !!,"No memorandums meet the deletion qualifications for the "
98 . W "selected employee,"
99 . S MIEN=0
100 ; If only one memo
101 I '$D(MEM(2)) S MIEN=$P(MEM(1),U,1) Q
102 ; Display list if more than one
103 I $D(MEM(2)) D
104 . W !!," # ",?5,"STARTS ENDS"
105 . F MEM=1:1 Q:'$D(MEM(MEM)) D
106 . . S DATA=MEM(MEM)
107 . . S Y=$P(DATA,U,2)
108 . . D DD^%DT
109 . . S START=Y
110 . . S Y=$P(DATA,U,3)
111 . . D DD^%DT
112 . . S END=Y
113 . . W !!,MEM,?5,START," TO ",END
114 . ;
115ASK . ; Ask user to select which memorandum they want
116 . S END="",END=$O(MEM(END),-1)
117 . W !!,"Enter a number between 1 and ",END," :"
118 . R ASK:DTIME
119 . S ASK=$$UPPER^PRSRUTL(ASK)
120 . Q:ASK=""!(ASK="^")
121 . I '$D(MEM(ASK)) D G ASK
122 . . W !!,"Enter a number between 1 and ",END," or ^ to exit"
123 . S MIEN=$P(MEM(ASK),U,1)
124 Q
125 ;
126DISPLAY ; Display memorandum info to validate the correct employee was chosen
127 S SCRTTL="Delete PT Physician Memoranda"
128 D HDR^PRSPUT1(PRSIEN,SCRTTL)
129 S DATA=$G(^PRST(458.7,MIEN,0))
130 S X=$P(DATA,U,2)
131 S START=$P(DATA,U,2),END=$P(DATA,U,3),AHRS=$P(DATA,U,4)
132 S Y=START
133 D DD^%DT
134 S START=Y
135 S Y=END
136 D DD^%DT
137 S END=Y
138 W !!," Start Date: ",START
139 W !," End Date: ",END
140 W !,"Agreed Hours: ",AHRS,!!
141 Q
142 ;
143ESIG ; Prompt for Electronic Signature and store fields in #458.7
144 ;
145 N ESOK,PPE
146 D ^PRSAES
147 I ESOK D
148 . ; obtain first PP covered by the this memo
149 . S PPE=$P($G(^PRST(458.7,MIEN,9,1,0)),U)
150 . ;
151 . ; Update #458.7 to delete the memo
152 . S DA=MIEN,DIK="^PRST(458.7,"
153 . D ^DIK
154 . W !!,"Memorandum Deleted."
155 . ;
156 . ; loop thru PP to clear ESR and (if necesary) time card
157 . Q:PPE=""
158 . S PPI=$O(^PRST(458,"B",PPE,0))
159 . Q:'PPI
160 . S PPI=PPI-.01 ; init PPI to include 1st PP in loop
161 . F S PPI=$O(^PRST(458,PPI)) Q:'PPI D
162 . . F DAY=1:1:14 D
163 . . . ; Check if Daily ESR with a status of APPROVED
164 . . . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
165 . . . I ESRSTAT=5 D ; Clear Time Card posting information
166 . . . . K ^PRST(458,PPI,"E",PRSIEN,"D",DAY,2),^(3),^(10)
167 . . . ;
168 . . . ; delete any ESR data
169 . . . ; use fileman to delete ESR DAILY STATUS so x-ref will get updated
170 . . . S PRSFDA(458.02,DAY_","_PRSIEN_","_PPI_",",146)="@"
171 . . . D FILE^DIE("","PRSFDA"),MSG^DIALOG()
172 . . . ; delete ESR related fields
173 . . . K ^PRST(458,PPI,"E",PRSIEN,"D",DAY,5),^(6),^(7)
174 ;
175KILL ; Clean up variables
176 ;
177 K ASK,D1,DA,DATA,DAY,DIK,DIR,DIRUT,END,ESRSTAT,INDX,MEM,MIEN
178 K PPI,PRSIEN,PRSFDA,TDATE,TCOM,SCRTTL,START,STATUS,STOP,X,Y,%,%DT
179 Q
Note: See TracBrowser for help on using the repository browser.