source: FOIAVistA/trunk/r/PAID-PRS/PRSPTM.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.6 KB
Line 
1PRSPTM ;WOIFO/MGD - PTP TERMINATE MEMORANDUM ;06/15/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 terminate a Part Time
6 ; Physician's Memorandum of Service Level Expectations. Once
7 ; terminated the memorandum will need to be reconciled.
8 ; For a memorandum to be eligible for termination it must have already
9 ; had had at least one Pay Period processed and it must be prior to
10 ; the processing of the last Pay Period covered by the memorandum.
11 ;
12 Q
13MAIN ; Main Driver
14 N STDAT,ENDAT,AHRS,ICOM,ESOK
15 ; Prompt for Part Time Physician
16 D PTP
17 I Y'>0 D KILL Q
18 S PRSIEN=+Y
19 ; Find any memorandums that meet the termination qualifications
20 D MEM
21 Q:'$G(MIEN)
22 ; Display employee and memorandum information
23 D DISPLAY
24 Q:$D(DIRUT)
25TERM ; Issue Terminate Memorandum prompt
26 W !
27 S DIR(0)="YO",DIR("A")="Terminate Memoranda Y/N: "
28 D ^DIR K DIR
29 Q:Y'=1
30 ; Prompt for Termination Date
31 D TDATE
32 Q:X=""!(X="^")
33 ; Prompt for Termination Comments
34 D TCOM
35 Q:TCOM="^"
36 ; Prompt for E-sig and update file
37 D ESIG
38 Q
39 ;
40PTP ; Prompt for Part Time Physician
41 W !
42 S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: "
43 D ^DIC K DIC
44 S PRSIEN=+Y
45 Q
46 ;
47MEM ; Find any memorandums that meet the termination qualifications
48 N MEM,INDX
49 S MEM=0,INDX=1
50 F S MEM=$O(^PRST(458.7,"B",PRSIEN,MEM)) Q:'MEM D
51 . S DATA=$G(^PRST(458.7,MEM,0))
52 . Q:DATA=""
53 . S STATUS=$P(DATA,U,6)
54 . Q:STATUS>2 ; Memorandum = 3:RECONCILIATION STARTED or 4:RECONCILED
55 . S START=$P(DATA,U,2),END=$P(DATA,U,3) ; Start Date, End Date
56 . ; Don't include future memoradums. The Delete Future Memorandum
57 . ; option must be used to to remove future memorandums.
58 . Q:START>DT
59 . ; Check for a memorandum that has already been terminated but the
60 . ; Begin Reconciliation Process option has not been run yet.
61 . Q:+$G(^PRST(458.7,MEM,4))
62 . S PPI=$P($G(^PRST(458,"AD",END)),U,1)
63 . ; The End Date for future memorandums may not be in #458 yet
64 . I PPI="" D Q
65 . . S MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE",INDX=INDX+1
66 . ; If the End Date is in #458 check the timecard status for that PP
67 . ; Quit if Timecard status for the last PP of the mem is not (T)imekeeper
68 . Q:$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T"
69 . S MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE",INDX=INDX+1
70 ; If no memos meet the termination qualifications
71 I '$D(MEM(1)) D Q
72 . W !!,"No memorandums meet the termination qualifications for the "
73 . W "selected employee."
74 . S MIEN=0
75 ; If only one memo
76 I '$D(MEM(2)) S MIEN=$P($G(MEM(1)),U,1) Q
77 ; Display list if more than one
78 I $D(MEM(2)) D
79 . W !!," # ",?5,"STARTS ENDS"
80 . F MEM=1:1 Q:'$D(MEM(MEM)) D
81 . . S DATA=MEM(MEM)
82 . . S START=$$FMTE^XLFDT($P(DATA,U,2))
83 . . S END=$$FMTE^XLFDT($P(DATA,U,3))
84 . . W !!,MEM,?5,START," TO ",END
85 . ;
86ASK . ; Ask user to select which memorandum they want
87 . S END="",END=$O(MEM(END),-1)
88 . W !!,"Enter a number between 1 and ",END,": "
89 . R ASK:DTIME
90 . S ASK=$$UPPER^PRSRUTL(ASK)
91 . I ASK=""!(ASK="^") S MIEN=0 Q
92 . I '$D(MEM(ASK)) D G ASK
93 . . W !!,"Enter a number between 1 and ",END," or ^ to exit"
94 . S MIEN=$P(MEM(ASK),U,1)
95 Q
96 ;
97DISPLAY ; Display memorandum info to validate the correct employee was chosen
98 S SCRTTL="Terminate PT Physician Memoranda"
99 D HDR^PRSPUT1(PRSIEN,SCRTTL)
100 D MEM^PRSPUT1(PRSIEN,MIEN)
101 D AL^PRSPUT3(PRSIEN,)
102 D PPSUM^PRSPUT2(PRSIEN,MIEN)
103 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
104 Q
105 ;
106TDATE ; Prompt for Termination Date
107 S DATA0=$G(^PRST(458.7,MIEN,0))
108 S (STDAT,STDATI)=$P(DATA0,U,2),(ENDAT,ENDATI)=$P(DATA0,U,3)
109 S Y=STDAT
110 D DD^%DT
111 S STDAT=Y
112 S Y=ENDAT
113 D DD^%DT
114 S ENDAT=Y
115 S TDAT=0
116 W !!,"Termination date must be the last day of a pay period."
117 W !,"Start Date: ",STDAT," End Date: ",ENDAT,!
118 S %DT="AEX",%DT("A")="Termination Date: ",QUIT=0
119 F D Q:QUIT
120 . N DAY14,TPPI
121 . D ^%DT
122 . I X=""!(X="^") S QUIT=1 Q
123 . ; Validate that the Termination Date is the last day of a Pay Period.
124 . S TDATE=+Y
125 . Q:TDATE="^"
126 . S D1=TDATE
127 . D PP^PRSAPPU ; PPI and Day are set here
128 . S TPPI=$G(PPI) ; termination pay period IEN (if open)
129 . I DAY'=14 D Q
130 . . W !!,"The Termination Date must be the last day of a Pay Period."
131 . . W !,"Please re-enter.",!
132 . I TDATE<STDATI D Q
133 . . W !!,"The Termination Date can not be prior to the Start Date: ",STDAT
134 . . W !,"Please re-enter.",!
135 . I TDATE'<ENDATI D Q
136 . . W !!,"The Termination Date must be prior to the End Date: ",ENDAT
137 . . W !,"Please re-enter.",!
138 . ;
139 . ; Check to make sure that no Timecards for PPs after the termination
140 . ; date have a status of Payroll or Transmitted.
141 . I 'TPPI S QUIT=1 Q ; PP containing termination date is not open
142 . ; loop thru PPs after the PP of terminatio and check their status
143 . S FPPESR=0 ; init # of PPs that have status which prevents termination
144 . S PPI=TPPI F S PPI=$O(^PRST(458,PPI)) Q:'PPI D Q:DAY14>ENDATI
145 . . S DAY14=$P($G(^PRST(458,PPI,1)),U,14) ; last day of PPI
146 . . Q:DAY14>ENDATI ; pay period is after end of memo
147 . . S STATUS=$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
148 . . Q:"^P^X^"'[(U_STATUS_U) ; quit if status not P or X
149 . . ; timecard has a status that prevents termination
150 . . S FPPESR=FPPESR+1
151 . . S STATEX=$$EXTERNAL^DILFD(458.01,1,"",STATUS)
152 . . W !,$P($G(^PRST(458,PPI,0)),U),?10,STATEX
153 . ;
154 . I FPPESR=0 S QUIT=1 Q ; All tests passed. Termination date is OK
155 . ;
156 . W !!,"You cannot select this Pay Period because there "
157 . W $S(FPPESR=1:"is ",1:"are "),FPPESR," Pay Period"
158 . W $S(FPPESR>1:"s ",1:" "),"after this"
159 . W !,"Pay Period where the timecard",$S(FPPESR=1:" has ",1:"s have ")
160 . W "a status other than Timekeeper.",!!
161 Q
162 ;
163TCOM ; Termination Comments
164 W !
165 S DIR(0)="FO^1:240^^O",DIR("A")="Termination Comments" D ^DIR
166 S TCOM=Y
167 Q
168 ;
169ESIG ; Prompt for Electronic Signature and store fields in #458.7
170 ;
171 N ESOK,PPE,PPNUM,RCALFLG
172 D ^PRSAES
173 I ESOK D
174 . ; Update #458.7
175 . S MIEN=MIEN_","
176 . S PRSFDA(458.7,MIEN,22)=TDATE ; TERMINATION DATE
177 . S PRSFDA(458.7,MIEN,23)=DUZ ; TERMINATED BY
178 . D NOW^%DTC
179 . S PRSFDA(458.7,MIEN,24)=% ; TERMINATED DATE/TIME
180 . S PRSFDA(458.7,MIEN,25)=TCOM ; TERMINATION COMMENTS
181 . D UPDATE^DIE("","PRSFDA","MIEN"),MSG^DIALOG()
182 . S MIEN=+MIEN ; Remove comma from end
183 . ;
184 . ; Check for PP that need to have their ESR's deleted
185 . S X1=TDATE,X2=1
186 . D C^%DTC
187 . S PPI=+$G(^PRST(458,"AD",X))
188 . Q:'PPI ; There aren't any pay periods opened after the termination date
189 . ;
190 . S PPI=PPI-.01 ; init PPI to include 1st PP in loop
191 . F S PPI=$O(^PRST(458,PPI)) Q:'PPI D
192 . . Q:'$D(^PRST(458,PPI,"E",PRSIEN,0)) ; skip PP if no timecard/ESR
193 . . ;
194 . . ; Check for previously saved hours for this PP
195 . . S RCALFLG=0
196 . . S PPE=$P($G(^PRST(458,PPI,0)),U,1)
197 . . S PPNUM=$O(^PRST(458.7,MIEN,9,"B",PPE,0))
198 . . Q:PPNUM'>0
199 . . S RCALFLG=$S($P($G(^PRST(458.7,MIEN,9,PPNUM,0)),U,1)'="":1,1:0)
200 . . ;
201 . . F DAY=1:1:14 D
202 . . . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
203 . . . I ESRSTAT=5 D ; Clear Time Card posting information
204 . . . . K ^PRST(458,PPI,"E",PRSIEN,"D",DAY,2),^(3),^(10)
205 . . . ;
206 . . . ; delete any ESR data
207 . . . ; use fileman to delete ESR DAILY STATUS so x-ref will get updated
208 . . . S PRSFDA(458.02,DAY_","_PRSIEN_","_PPI_",",146)="@"
209 . . . D FILE^DIE("","PRSFDA"),MSG^DIALOG()
210 . . . ; delete ESR related fields
211 . . . K ^PRST(458,PPI,"E",PRSIEN,"D",DAY,5),^(6),^(7)
212 . . ;
213 . . ; If the PP had been certified before, re-calculate totals
214 . . I RCALFLG D PTP^PRSASR1(PRSIEN,PPI)
215 Q
216 ;
217KILL ; Clean up variables
218 ;
219 K ASK,D1,DA,DATA,DATA0,DAY,DIR,DIRUT,END,ENDAT,ENDATI,ESRSTAT
220 K FPPESR,I,INDX,MEM,MIEN,PPE,PPI,PRSIEN,PRSFDA,QUIT,QUIT1
221 K SCRTTL,START,STATEX,STATUS,STDAT,STDATI,TCOM
222 K TDAT,TDATE,TDATI,X,X1,X2,Y,%,%DT
223 K ^TMP($J,"PRSPTM")
224 Q
Note: See TracBrowser for help on using the repository browser.