- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPTM 7993 printed Jan 18, 2025@03:29:28 Page 2
- PRSPTM ;WOIFO/MGD - PTP TERMINATE MEMORANDUM ;06/15/05
- +1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; The following routine will allow HR to terminate a Part Time
- +5 ; Physician's Memorandum of Service Level Expectations. Once
- +6 ; terminated the memorandum will need to be reconciled.
- +7 ; For a memorandum to be eligible for termination it must have already
- +8 ; had had at least one Pay Period processed and it must be prior to
- +9 ; the processing of the last Pay Period covered by the memorandum.
- +10 ;
- +11 QUIT
- MAIN ; Main Driver
- +1 NEW STDAT,ENDAT,AHRS,ICOM,ESOK
- +2 ; Prompt for Part Time Physician
- +3 DO PTP
- +4 IF Y'>0
- DO KILL
- QUIT
- +5 SET PRSIEN=+Y
- +6 ; Find any memorandums that meet the termination qualifications
- +7 DO MEM
- +8 if '$GET(MIEN)
- QUIT
- +9 ; Display employee and memorandum information
- +10 DO DISPLAY
- +11 if $DATA(DIRUT)
- QUIT
- TERM ; Issue Terminate Memorandum prompt
- +1 WRITE !
- +2 SET DIR(0)="YO"
- SET DIR("A")="Terminate Memoranda Y/N: "
- +3 DO ^DIR
- KILL DIR
- +4 if Y'=1
- QUIT
- +5 ; Prompt for Termination Date
- +6 DO TDATE
- +7 if X=""!(X="^")
- QUIT
- +8 ; Prompt for Termination Comments
- +9 DO TCOM
- +10 if TCOM="^"
- QUIT
- +11 ; Prompt for E-sig and update file
- +12 DO ESIG
- +13 QUIT
- +14 ;
- PTP ; Prompt for Part Time Physician
- +1 WRITE !
- +2 SET DIC="^PRSPC("
- SET DIC(0)="AEMQZ"
- SET DIC("A")="Select EMPLOYEE: "
- +3 DO ^DIC
- KILL DIC
- +4 SET PRSIEN=+Y
- +5 QUIT
- +6 ;
- MEM ; Find any memorandums that meet the termination qualifications
- +1 NEW MEM,INDX
- +2 SET MEM=0
- SET INDX=1
- +3 FOR
- SET MEM=$ORDER(^PRST(458.7,"B",PRSIEN,MEM))
- if 'MEM
- QUIT
- Begin DoDot:1
- +4 SET DATA=$GET(^PRST(458.7,MEM,0))
- +5 if DATA=""
- QUIT
- +6 SET STATUS=$PIECE(DATA,U,6)
- +7 ; Memorandum = 3:RECONCILIATION STARTED or 4:RECONCILED
- if STATUS>2
- QUIT
- +8 ; Start Date, End Date
- SET START=$PIECE(DATA,U,2)
- SET END=$PIECE(DATA,U,3)
- +9 ; Don't include future memoradums. The Delete Future Memorandum
- +10 ; option must be used to to remove future memorandums.
- +11 if START>DT
- QUIT
- +12 ; Check for a memorandum that has already been terminated but the
- +13 ; Begin Reconciliation Process option has not been run yet.
- +14 if +$GET(^PRST(458.7,MEM,4))
- QUIT
- +15 SET PPI=$PIECE($GET(^PRST(458,"AD",END)),U,1)
- +16 ; The End Date for future memorandums may not be in #458 yet
- +17 IF PPI=""
- Begin DoDot:2
- +18 SET MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE"
- SET INDX=INDX+1
- End DoDot:2
- QUIT
- +19 ; If the End Date is in #458 check the timecard status for that PP
- +20 ; Quit if Timecard status for the last PP of the mem is not (T)imekeeper
- +21 if $PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T"
- QUIT
- +22 SET MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE"
- SET INDX=INDX+1
- End DoDot:1
- +23 ; If no memos meet the termination qualifications
- +24 IF '$DATA(MEM(1))
- Begin DoDot:1
- +25 WRITE !!,"No memorandums meet the termination qualifications for the "
- +26 WRITE "selected employee."
- +27 SET MIEN=0
- End DoDot:1
- QUIT
- +28 ; If only one memo
- +29 IF '$DATA(MEM(2))
- SET MIEN=$PIECE($GET(MEM(1)),U,1)
- QUIT
- +30 ; Display list if more than one
- +31 IF $DATA(MEM(2))
- Begin DoDot:1
- +32 WRITE !!," # ",?5,"STARTS ENDS"
- +33 FOR MEM=1:1
- if '$DATA(MEM(MEM))
- QUIT
- Begin DoDot:2
- +34 SET DATA=MEM(MEM)
- +35 SET START=$$FMTE^XLFDT($PIECE(DATA,U,2))
- +36 SET END=$$FMTE^XLFDT($PIECE(DATA,U,3))
- +37 WRITE !!,MEM,?5,START," TO ",END
- End DoDot:2
- +38 ;
- ASK ; Ask user to select which memorandum they want
- +1 SET END=""
- SET END=$ORDER(MEM(END),-1)
- +2 WRITE !!,"Enter a number between 1 and ",END,": "
- +3 READ ASK:DTIME
- +4 SET ASK=$$UPPER^PRSRUTL(ASK)
- +5 IF ASK=""!(ASK="^")
- SET MIEN=0
- QUIT
- +6 IF '$DATA(MEM(ASK))
- Begin DoDot:2
- +7 WRITE !!,"Enter a number between 1 and ",END," or ^ to exit"
- End DoDot:2
- GOTO ASK
- +8 SET MIEN=$PIECE(MEM(ASK),U,1)
- End DoDot:1
- +9 QUIT
- +10 ;
- DISPLAY ; Display memorandum info to validate the correct employee was chosen
- +1 SET SCRTTL="Terminate PT Physician Memoranda"
- +2 DO HDR^PRSPUT1(PRSIEN,SCRTTL)
- +3 DO MEM^PRSPUT1(PRSIEN,MIEN)
- +4 DO AL^PRSPUT3(PRSIEN,)
- +5 DO PPSUM^PRSPUT2(PRSIEN,MIEN)
- +6 SET DIR(0)="E"
- SET DIR("A")="Press RETURN to continue"
- DO ^DIR
- +7 QUIT
- +8 ;
- TDATE ; Prompt for Termination Date
- +1 SET DATA0=$GET(^PRST(458.7,MIEN,0))
- +2 SET (STDAT,STDATI)=$PIECE(DATA0,U,2)
- SET (ENDAT,ENDATI)=$PIECE(DATA0,U,3)
- +3 SET Y=STDAT
- +4 DO DD^%DT
- +5 SET STDAT=Y
- +6 SET Y=ENDAT
- +7 DO DD^%DT
- +8 SET ENDAT=Y
- +9 SET TDAT=0
- +10 WRITE !!,"Termination date must be the last day of a pay period."
- +11 WRITE !,"Start Date: ",STDAT," End Date: ",ENDAT,!
- +12 SET %DT="AEX"
- SET %DT("A")="Termination Date: "
- SET QUIT=0
- +13 FOR
- Begin DoDot:1
- +14 NEW DAY14,TPPI
- +15 DO ^%DT
- +16 IF X=""!(X="^")
- SET QUIT=1
- QUIT
- +17 ; Validate that the Termination Date is the last day of a Pay Period.
- +18 SET TDATE=+Y
- +19 if TDATE="^"
- QUIT
- +20 SET D1=TDATE
- +21 ; PPI and Day are set here
- DO PP^PRSAPPU
- +22 ; termination pay period IEN (if open)
- SET TPPI=$GET(PPI)
- +23 IF DAY'=14
- Begin DoDot:2
- +24 WRITE !!,"The Termination Date must be the last day of a Pay Period."
- +25 WRITE !,"Please re-enter.",!
- End DoDot:2
- QUIT
- +26 IF TDATE<STDATI
- Begin DoDot:2
- +27 WRITE !!,"The Termination Date can not be prior to the Start Date: ",STDAT
- +28 WRITE !,"Please re-enter.",!
- End DoDot:2
- QUIT
- +29 IF TDATE'<ENDATI
- Begin DoDot:2
- +30 WRITE !!,"The Termination Date must be prior to the End Date: ",ENDAT
- +31 WRITE !,"Please re-enter.",!
- End DoDot:2
- QUIT
- +32 ;
- +33 ; Check to make sure that no Timecards for PPs after the termination
- +34 ; date have a status of Payroll or Transmitted.
- +35 ; PP containing termination date is not open
- IF 'TPPI
- SET QUIT=1
- QUIT
- +36 ; loop thru PPs after the PP of terminatio and check their status
- +37 ; init # of PPs that have status which prevents termination
- SET FPPESR=0
- +38 SET PPI=TPPI
- FOR
- SET PPI=$ORDER(^PRST(458,PPI))
- if 'PPI
- QUIT
- Begin DoDot:2
- +39 ; last day of PPI
- SET DAY14=$PIECE($GET(^PRST(458,PPI,1)),U,14)
- +40 ; pay period is after end of memo
- if DAY14>ENDATI
- QUIT
- +41 SET STATUS=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
- +42 ; quit if status not P or X
- if "^P^X^"'[(U_STATUS_U)
- QUIT
- +43 ; timecard has a status that prevents termination
- +44 SET FPPESR=FPPESR+1
- +45 SET STATEX=$$EXTERNAL^DILFD(458.01,1,"",STATUS)
- +46 WRITE !,$PIECE($GET(^PRST(458,PPI,0)),U),?10,STATEX
- End DoDot:2
- if DAY14>ENDATI
- QUIT
- +47 ;
- +48 ; All tests passed. Termination date is OK
- IF FPPESR=0
- SET QUIT=1
- QUIT
- +49 ;
- +50 WRITE !!,"You cannot select this Pay Period because there "
- +51 WRITE $SELECT(FPPESR=1:"is ",1:"are "),FPPESR," Pay Period"
- +52 WRITE $SELECT(FPPESR>1:"s ",1:" "),"after this"
- +53 WRITE !,"Pay Period where the timecard",$SELECT(FPPESR=1:" has ",1:"s have ")
- +54 WRITE "a status other than Timekeeper.",!!
- End DoDot:1
- if QUIT
- QUIT
- +55 QUIT
- +56 ;
- TCOM ; Termination Comments
- +1 WRITE !
- +2 SET DIR(0)="FO^1:240^^O"
- SET DIR("A")="Termination Comments"
- DO ^DIR
- +3 SET TCOM=Y
- +4 QUIT
- +5 ;
- ESIG ; Prompt for Electronic Signature and store fields in #458.7
- +1 ;
- +2 NEW ESOK,PPE,PPNUM,RCALFLG
- +3 DO ^PRSAES
- +4 IF ESOK
- Begin DoDot:1
- +5 ; Update #458.7
- +6 SET MIEN=MIEN_","
- +7 ; TERMINATION DATE
- SET PRSFDA(458.7,MIEN,22)=TDATE
- +8 ; TERMINATED BY
- SET PRSFDA(458.7,MIEN,23)=DUZ
- +9 DO NOW^%DTC
- +10 ; TERMINATED DATE/TIME
- SET PRSFDA(458.7,MIEN,24)=%
- +11 ; TERMINATION COMMENTS
- SET PRSFDA(458.7,MIEN,25)=TCOM
- +12 DO UPDATE^DIE("","PRSFDA","MIEN")
- DO MSG^DIALOG()
- +13 ; Remove comma from end
- SET MIEN=+MIEN
- +14 ;
- +15 ; Check for PP that need to have their ESR's deleted
- +16 SET X1=TDATE
- SET X2=1
- +17 DO C^%DTC
- +18 SET PPI=+$GET(^PRST(458,"AD",X))
- +19 ; There aren't any pay periods opened after the termination date
- if 'PPI
- QUIT
- +20 ;
- +21 ; init PPI to include 1st PP in loop
- SET PPI=PPI-.01
- +22 FOR
- SET PPI=$ORDER(^PRST(458,PPI))
- if 'PPI
- QUIT
- Begin DoDot:2
- +23 ; skip PP if no timecard/ESR
- if '$DATA(^PRST(458,PPI,"E",PRSIEN,0))
- QUIT
- +24 ;
- +25 ; Check for previously saved hours for this PP
- +26 SET RCALFLG=0
- +27 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
- +28 SET PPNUM=$ORDER(^PRST(458.7,MIEN,9,"B",PPE,0))
- +29 if PPNUM'>0
- QUIT
- +30 SET RCALFLG=$SELECT($PIECE($GET(^PRST(458.7,MIEN,9,PPNUM,0)),U,1)'="":1,1:0)
- +31 ;
- +32 FOR DAY=1:1:14
- Begin DoDot:3
- +33 SET ESRSTAT=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
- +34 ; Clear Time Card posting information
- IF ESRSTAT=5
- Begin DoDot:4
- +35 KILL ^PRST(458,PPI,"E",PRSIEN,"D",DAY,2),^(3),^(10)
- End DoDot:4
- +36 ;
- +37 ; delete any ESR data
- +38 ; use fileman to delete ESR DAILY STATUS so x-ref will get updated
- +39 SET PRSFDA(458.02,DAY_","_PRSIEN_","_PPI_",",146)="@"
- +40 DO FILE^DIE("","PRSFDA")
- DO MSG^DIALOG()
- +41 ; delete ESR related fields
- +42 KILL ^PRST(458,PPI,"E",PRSIEN,"D",DAY,5),^(6),^(7)
- End DoDot:3
- +43 ;
- +44 ; If the PP had been certified before, re-calculate totals
- +45 IF RCALFLG
- DO PTP^PRSASR1(PRSIEN,PPI)
- End DoDot:2
- End DoDot:1
- +46 QUIT
- +47 ;
- KILL ; Clean up variables
- +1 ;
- +2 KILL ASK,D1,DA,DATA,DATA0,DAY,DIR,DIRUT,END,ENDAT,ENDATI,ESRSTAT
- +3 KILL FPPESR,I,INDX,MEM,MIEN,PPE,PPI,PRSIEN,PRSFDA,QUIT,QUIT1
- +4 KILL SCRTTL,START,STATEX,STATUS,STDAT,STDATI,TCOM
- +5 KILL TDAT,TDATE,TDATI,X,X1,X2,Y,%,%DT
- +6 KILL ^TMP($JOB,"PRSPTM")
- +7 QUIT