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

PRSPTM.m

Go to the documentation of this file.
  1. PRSPTM ;WOIFO/MGD - PTP TERMINATE MEMORANDUM ;06/15/05
  1. ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; The following routine will allow HR to terminate a Part Time
  1. ; Physician's Memorandum of Service Level Expectations. Once
  1. ; terminated the memorandum will need to be reconciled.
  1. ; For a memorandum to be eligible for termination it must have already
  1. ; had had at least one Pay Period processed and it must be prior to
  1. ; the processing of the last Pay Period covered by the memorandum.
  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 termination qualifications
  1. D MEM
  1. Q:'$G(MIEN)
  1. ; Display employee and memorandum information
  1. D DISPLAY
  1. Q:$D(DIRUT)
  1. TERM ; Issue Terminate Memorandum prompt
  1. W !
  1. S DIR(0)="YO",DIR("A")="Terminate Memoranda Y/N: "
  1. D ^DIR K DIR
  1. Q:Y'=1
  1. ; Prompt for Termination Date
  1. D TDATE
  1. Q:X=""!(X="^")
  1. ; Prompt for Termination Comments
  1. D TCOM
  1. Q:TCOM="^"
  1. ; Prompt for E-sig and update file
  1. D ESIG
  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 termination qualifications
  1. N MEM,INDX
  1. S MEM=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 STATUS=$P(DATA,U,6)
  1. . Q:STATUS>2 ; Memorandum = 3:RECONCILIATION STARTED or 4:RECONCILED
  1. . S START=$P(DATA,U,2),END=$P(DATA,U,3) ; Start Date, End Date
  1. . ; Don't include future memoradums. The Delete Future Memorandum
  1. . ; option must be used to to remove future memorandums.
  1. . Q:START>DT
  1. . ; Check for a memorandum that has already been terminated but the
  1. . ; Begin Reconciliation Process option has not been run yet.
  1. . Q:+$G(^PRST(458.7,MEM,4))
  1. . S PPI=$P($G(^PRST(458,"AD",END)),U,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 termination qualifications
  1. I '$D(MEM(1)) D Q
  1. . W !!,"No memorandums meet the termination qualifications for the "
  1. . W "selected employee."
  1. . S MIEN=0
  1. ; If only one memo
  1. I '$D(MEM(2)) S MIEN=$P($G(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 START=$$FMTE^XLFDT($P(DATA,U,2))
  1. . . S END=$$FMTE^XLFDT($P(DATA,U,3))
  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. . I ASK=""!(ASK="^") S MIEN=0 Q
  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="Terminate PT Physician Memoranda"
  1. D HDR^PRSPUT1(PRSIEN,SCRTTL)
  1. D MEM^PRSPUT1(PRSIEN,MIEN)
  1. D AL^PRSPUT3(PRSIEN,)
  1. D PPSUM^PRSPUT2(PRSIEN,MIEN)
  1. S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
  1. Q
  1. ;
  1. TDATE ; Prompt for Termination Date
  1. S DATA0=$G(^PRST(458.7,MIEN,0))
  1. S (STDAT,STDATI)=$P(DATA0,U,2),(ENDAT,ENDATI)=$P(DATA0,U,3)
  1. S Y=STDAT
  1. D DD^%DT
  1. S STDAT=Y
  1. S Y=ENDAT
  1. D DD^%DT
  1. S ENDAT=Y
  1. S TDAT=0
  1. W !!,"Termination date must be the last day of a pay period."
  1. W !,"Start Date: ",STDAT," End Date: ",ENDAT,!
  1. S %DT="AEX",%DT("A")="Termination Date: ",QUIT=0
  1. F D Q:QUIT
  1. . N DAY14,TPPI
  1. . D ^%DT
  1. . I X=""!(X="^") S QUIT=1 Q
  1. . ; Validate that the Termination Date is the last day of a Pay Period.
  1. . S TDATE=+Y
  1. . Q:TDATE="^"
  1. . S D1=TDATE
  1. . D PP^PRSAPPU ; PPI and Day are set here
  1. . S TPPI=$G(PPI) ; termination pay period IEN (if open)
  1. . I DAY'=14 D Q
  1. . . W !!,"The Termination Date must be the last day of a Pay Period."
  1. . . W !,"Please re-enter.",!
  1. . I TDATE<STDATI D Q
  1. . . W !!,"The Termination Date can not be prior to the Start Date: ",STDAT
  1. . . W !,"Please re-enter.",!
  1. . I TDATE'<ENDATI D Q
  1. . . W !!,"The Termination Date must be prior to the End Date: ",ENDAT
  1. . . W !,"Please re-enter.",!
  1. . ;
  1. . ; Check to make sure that no Timecards for PPs after the termination
  1. . ; date have a status of Payroll or Transmitted.
  1. . I 'TPPI S QUIT=1 Q ; PP containing termination date is not open
  1. . ; loop thru PPs after the PP of terminatio and check their status
  1. . S FPPESR=0 ; init # of PPs that have status which prevents termination
  1. . S PPI=TPPI F S PPI=$O(^PRST(458,PPI)) Q:'PPI D Q:DAY14>ENDATI
  1. . . S DAY14=$P($G(^PRST(458,PPI,1)),U,14) ; last day of PPI
  1. . . Q:DAY14>ENDATI ; pay period is after end of memo
  1. . . S STATUS=$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
  1. . . Q:"^P^X^"'[(U_STATUS_U) ; quit if status not P or X
  1. . . ; timecard has a status that prevents termination
  1. . . S FPPESR=FPPESR+1
  1. . . S STATEX=$$EXTERNAL^DILFD(458.01,1,"",STATUS)
  1. . . W !,$P($G(^PRST(458,PPI,0)),U),?10,STATEX
  1. . ;
  1. . I FPPESR=0 S QUIT=1 Q ; All tests passed. Termination date is OK
  1. . ;
  1. . W !!,"You cannot select this Pay Period because there "
  1. . W $S(FPPESR=1:"is ",1:"are "),FPPESR," Pay Period"
  1. . W $S(FPPESR>1:"s ",1:" "),"after this"
  1. . W !,"Pay Period where the timecard",$S(FPPESR=1:" has ",1:"s have ")
  1. . W "a status other than Timekeeper.",!!
  1. Q
  1. ;
  1. TCOM ; Termination Comments
  1. W !
  1. S DIR(0)="FO^1:240^^O",DIR("A")="Termination Comments" D ^DIR
  1. S TCOM=Y
  1. Q
  1. ;
  1. ESIG ; Prompt for Electronic Signature and store fields in #458.7
  1. ;
  1. N ESOK,PPE,PPNUM,RCALFLG
  1. D ^PRSAES
  1. I ESOK D
  1. . ; Update #458.7
  1. . S MIEN=MIEN_","
  1. . S PRSFDA(458.7,MIEN,22)=TDATE ; TERMINATION DATE
  1. . S PRSFDA(458.7,MIEN,23)=DUZ ; TERMINATED BY
  1. . D NOW^%DTC
  1. . S PRSFDA(458.7,MIEN,24)=% ; TERMINATED DATE/TIME
  1. . S PRSFDA(458.7,MIEN,25)=TCOM ; TERMINATION COMMENTS
  1. . D UPDATE^DIE("","PRSFDA","MIEN"),MSG^DIALOG()
  1. . S MIEN=+MIEN ; Remove comma from end
  1. . ;
  1. . ; Check for PP that need to have their ESR's deleted
  1. . S X1=TDATE,X2=1
  1. . D C^%DTC
  1. . S PPI=+$G(^PRST(458,"AD",X))
  1. . Q:'PPI ; There aren't any pay periods opened after the termination date
  1. . ;
  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. . . Q:'$D(^PRST(458,PPI,"E",PRSIEN,0)) ; skip PP if no timecard/ESR
  1. . . ;
  1. . . ; Check for previously saved hours for this PP
  1. . . S RCALFLG=0
  1. . . S PPE=$P($G(^PRST(458,PPI,0)),U,1)
  1. . . S PPNUM=$O(^PRST(458.7,MIEN,9,"B",PPE,0))
  1. . . Q:PPNUM'>0
  1. . . S RCALFLG=$S($P($G(^PRST(458.7,MIEN,9,PPNUM,0)),U,1)'="":1,1:0)
  1. . . ;
  1. . . F DAY=1:1:14 D
  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. . . ; If the PP had been certified before, re-calculate totals
  1. . . I RCALFLG D PTP^PRSASR1(PRSIEN,PPI)
  1. Q
  1. ;
  1. KILL ; Clean up variables
  1. ;
  1. K ASK,D1,DA,DATA,DATA0,DAY,DIR,DIRUT,END,ENDAT,ENDATI,ESRSTAT
  1. K FPPESR,I,INDX,MEM,MIEN,PPE,PPI,PRSIEN,PRSFDA,QUIT,QUIT1
  1. K SCRTTL,START,STATEX,STATUS,STDAT,STDATI,TCOM
  1. K TDAT,TDATE,TDATI,X,X1,X2,Y,%,%DT
  1. K ^TMP($J,"PRSPTM")
  1. Q