source: FOIAVistA/tag/r/PAID-PRS/PRSPTM.m@ 628

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