Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSPDFM

PRSPDFM.m

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