180 lines
6.0 KiB
Mathematica
180 lines
6.0 KiB
Mathematica
PRSPDFM ;WOIFO/MGD - PTP DELETE FUTURE MEMORANDUM ;04/07/05
|
|
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
|
|
;;Per VHA Directive 2004-038, this routine should not be modified.
|
|
;The following routine will allow HR to delete a Part Time
|
|
; Physician's Memorandum of Service Level Expectations.
|
|
; For a memorandum to be eligible for deletion it must not have had
|
|
; any Pay Period processed.
|
|
;
|
|
Q
|
|
MAIN ; Main Driver
|
|
N STDAT,ENDAT,AHRS,ICOM,ESOK
|
|
; Prompt for Part Time Physician
|
|
D PTP
|
|
I Y'>0 D KILL Q
|
|
S PRSIEN=+Y
|
|
; Find any memorandums that meet the deletion qualifications
|
|
D MEM
|
|
Q:'MIEN
|
|
; Display employee and memorandum information
|
|
D DISPLAY
|
|
; Issue Delete Memorandum prompt
|
|
W !!,"Delete this Memoranda: "
|
|
S %=0 D YN^DICN
|
|
I %'=1 D KILL Q
|
|
; Prompt for E-sig and update file
|
|
D ESIG
|
|
;
|
|
Q
|
|
;
|
|
PTP ; Prompt for Part Time Physician
|
|
W !
|
|
S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: "
|
|
D ^DIC K DIC
|
|
S PRSIEN=+Y
|
|
Q
|
|
;
|
|
MEM ; Find any memorandums that meet the deletion qualifications
|
|
N INDX,MEM,PPE,PPI459
|
|
S (MEM,MIEN)=0,INDX=1
|
|
F S MEM=$O(^PRST(458.7,"B",PRSIEN,MEM)) Q:'MEM D
|
|
. S DATA=$G(^PRST(458.7,MEM,0))
|
|
. Q:DATA=""
|
|
. S START=$P(DATA,U,2),END=$P(DATA,U,3) ; Start Date, End Date
|
|
. ; If the PP covering the Start Date is not opened no additional checks
|
|
. ; are needed
|
|
. S PPI=$P($G(^PRST(458,"AD",START)),U,1)
|
|
. I PPI="" D Q
|
|
. . S MIEN=MEM,MEM(1)=MIEN_"^"_START_"^"_END_"^ACTIVE"
|
|
. ; If the 1st PP covered by the memorandum is opened, check to see
|
|
. ; what status it is in.
|
|
. S PPE=$P($G(^PRST(458,PPI,0)),U,1)
|
|
. Q:PPE=""
|
|
. S PPI459=$O(^PRST(459,"B",PPE,0))
|
|
. ; Check to see if Payroll for the first PP of the memorandum has
|
|
. ; already been processed.
|
|
. I PPI459 D Q
|
|
. . W !!,"The payroll for the first Pay Period covered by this Memorandum"
|
|
. . W !,"has already been processed. This memorandum will have to be"
|
|
. . W !,"terminated and reconciled."
|
|
. . S MIEN=-1
|
|
. ; Checks for Payroll not yet processed.
|
|
. S STATUS=$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
|
|
. I STATUS="X" D Q
|
|
. . W !!,"This PT Physician's timecard has already been transmitted."
|
|
. . W !,"If you think there is enough time to retransmit their 8B, you may:"
|
|
. . W !,"1. Have the Payroll Supervisor return the timecard"
|
|
. . W !,"2. Delete the memorandum"
|
|
. . W !,"3. Have the PTP complete a paper Subsidiary Record"
|
|
. . W !,"4. Have the Supervisor review and approve the Subsidiary Record"
|
|
. . W !,"5. Have the Timekeeper post each day in the Pay Period"
|
|
. . W !,"6. Re-certify and re-transmit the timecard"
|
|
. . W !!,"If there isn't enough time, the memorandum will have to be"
|
|
. . W !,"terminated and reconciled."
|
|
. . S MIEN=-1
|
|
. ;
|
|
. I STATUS="P" D Q
|
|
. . W !!,"This PT Physician's timecard has already been certified."
|
|
. . W !,"If you think there is enough time, you may:"
|
|
. . W !,"1. Have the Payroll Supervisor return the timecard"
|
|
. . W !,"2. Delete the memorandum"
|
|
. . W !,"3. Have the PTP complete a paper Subsidiary Record"
|
|
. . W !,"4. Have the Supervisor review and approve the Subsidiary Record"
|
|
. . W !,"5. Have the Timekeeper post each day in the Pay Period"
|
|
. . W !,"6. Re-certify the timecard."
|
|
. . W !!,"If there isn't enough time, the memorandum will have to be"
|
|
. . W !,"terminated and reconciled."
|
|
. . S MIEN=-1
|
|
. ; The End Date for future memorandums may not be in #458 yet
|
|
. I PPI="" D Q
|
|
. . S MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE",INDX=INDX+1
|
|
. ; If the End Date is in #458 check the timecard status for that PP
|
|
. ; Quit if Timecard status for the last PP of the mem is not (T)imekeeper
|
|
. Q:$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T"
|
|
. S MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE",INDX=INDX+1
|
|
; If no memos meet the deletion qualifications
|
|
I '$D(MEM(1)) D Q
|
|
. W !!,"No memorandums meet the deletion qualifications for the "
|
|
. W "selected employee,"
|
|
. S MIEN=0
|
|
; If only one memo
|
|
I '$D(MEM(2)) S MIEN=$P(MEM(1),U,1) Q
|
|
; Display list if more than one
|
|
I $D(MEM(2)) D
|
|
. W !!," # ",?5,"STARTS ENDS"
|
|
. F MEM=1:1 Q:'$D(MEM(MEM)) D
|
|
. . S DATA=MEM(MEM)
|
|
. . S Y=$P(DATA,U,2)
|
|
. . D DD^%DT
|
|
. . S START=Y
|
|
. . S Y=$P(DATA,U,3)
|
|
. . D DD^%DT
|
|
. . S END=Y
|
|
. . W !!,MEM,?5,START," TO ",END
|
|
. ;
|
|
ASK . ; Ask user to select which memorandum they want
|
|
. S END="",END=$O(MEM(END),-1)
|
|
. W !!,"Enter a number between 1 and ",END," :"
|
|
. R ASK:DTIME
|
|
. S ASK=$$UPPER^PRSRUTL(ASK)
|
|
. Q:ASK=""!(ASK="^")
|
|
. I '$D(MEM(ASK)) D G ASK
|
|
. . W !!,"Enter a number between 1 and ",END," or ^ to exit"
|
|
. S MIEN=$P(MEM(ASK),U,1)
|
|
Q
|
|
;
|
|
DISPLAY ; Display memorandum info to validate the correct employee was chosen
|
|
S SCRTTL="Delete PT Physician Memoranda"
|
|
D HDR^PRSPUT1(PRSIEN,SCRTTL)
|
|
S DATA=$G(^PRST(458.7,MIEN,0))
|
|
S X=$P(DATA,U,2)
|
|
S START=$P(DATA,U,2),END=$P(DATA,U,3),AHRS=$P(DATA,U,4)
|
|
S Y=START
|
|
D DD^%DT
|
|
S START=Y
|
|
S Y=END
|
|
D DD^%DT
|
|
S END=Y
|
|
W !!," Start Date: ",START
|
|
W !," End Date: ",END
|
|
W !,"Agreed Hours: ",AHRS,!!
|
|
Q
|
|
;
|
|
ESIG ; Prompt for Electronic Signature and store fields in #458.7
|
|
;
|
|
N ESOK,PPE
|
|
D ^PRSAES
|
|
I ESOK D
|
|
. ; obtain first PP covered by the this memo
|
|
. S PPE=$P($G(^PRST(458.7,MIEN,9,1,0)),U)
|
|
. ;
|
|
. ; Update #458.7 to delete the memo
|
|
. S DA=MIEN,DIK="^PRST(458.7,"
|
|
. D ^DIK
|
|
. W !!,"Memorandum Deleted."
|
|
. ;
|
|
. ; loop thru PP to clear ESR and (if necesary) time card
|
|
. Q:PPE=""
|
|
. S PPI=$O(^PRST(458,"B",PPE,0))
|
|
. Q:'PPI
|
|
. S PPI=PPI-.01 ; init PPI to include 1st PP in loop
|
|
. F S PPI=$O(^PRST(458,PPI)) Q:'PPI D
|
|
. . F DAY=1:1:14 D
|
|
. . . ; Check if Daily ESR with a status of APPROVED
|
|
. . . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
|
|
. . . I ESRSTAT=5 D ; Clear Time Card posting information
|
|
. . . . K ^PRST(458,PPI,"E",PRSIEN,"D",DAY,2),^(3),^(10)
|
|
. . . ;
|
|
. . . ; delete any ESR data
|
|
. . . ; use fileman to delete ESR DAILY STATUS so x-ref will get updated
|
|
. . . S PRSFDA(458.02,DAY_","_PRSIEN_","_PPI_",",146)="@"
|
|
. . . D FILE^DIE("","PRSFDA"),MSG^DIALOG()
|
|
. . . ; delete ESR related fields
|
|
. . . K ^PRST(458,PPI,"E",PRSIEN,"D",DAY,5),^(6),^(7)
|
|
;
|
|
KILL ; Clean up variables
|
|
;
|
|
K ASK,D1,DA,DATA,DAY,DIK,DIR,DIRUT,END,ESRSTAT,INDX,MEM,MIEN
|
|
K PPI,PRSIEN,PRSFDA,TDATE,TCOM,SCRTTL,START,STATUS,STOP,X,Y,%,%DT
|
|
Q
|