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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPDFM 6339 printed Nov 22, 2024@17:37:56 Page 2
PRSPDFM ;WOIFO/MGD - PTP DELETE FUTURE MEMORANDUM ;04/07/05
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;The following routine will allow HR to delete a Part Time
+4 ; Physician's Memorandum of Service Level Expectations.
+5 ; For a memorandum to be eligible for deletion it must not have had
+6 ; any Pay Period processed.
+7 ;
+8 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 deletion qualifications
+7 DO MEM
+8 if 'MIEN
QUIT
+9 ; Display employee and memorandum information
+10 DO DISPLAY
+11 ; Issue Delete Memorandum prompt
+12 WRITE !!,"Delete this Memoranda: "
+13 SET %=0
DO YN^DICN
+14 IF %'=1
DO KILL
QUIT
+15 ; Prompt for E-sig and update file
+16 DO ESIG
+17 ;
+18 QUIT
+19 ;
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 deletion qualifications
+1 NEW INDX,MEM,PPE,PPI459
+2 SET (MEM,MIEN)=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 ; Start Date, End Date
SET START=$PIECE(DATA,U,2)
SET END=$PIECE(DATA,U,3)
+7 ; If the PP covering the Start Date is not opened no additional checks
+8 ; are needed
+9 SET PPI=$PIECE($GET(^PRST(458,"AD",START)),U,1)
+10 IF PPI=""
Begin DoDot:2
+11 SET MIEN=MEM
SET MEM(1)=MIEN_"^"_START_"^"_END_"^ACTIVE"
End DoDot:2
QUIT
+12 ; If the 1st PP covered by the memorandum is opened, check to see
+13 ; what status it is in.
+14 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
+15 if PPE=""
QUIT
+16 SET PPI459=$ORDER(^PRST(459,"B",PPE,0))
+17 ; Check to see if Payroll for the first PP of the memorandum has
+18 ; already been processed.
+19 IF PPI459
Begin DoDot:2
+20 WRITE !!,"The payroll for the first Pay Period covered by this Memorandum"
+21 WRITE !,"has already been processed. This memorandum will have to be"
+22 WRITE !,"terminated and reconciled."
+23 SET MIEN=-1
End DoDot:2
QUIT
+24 ; Checks for Payroll not yet processed.
+25 SET STATUS=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
+26 IF STATUS="X"
Begin DoDot:2
+27 WRITE !!,"This PT Physician's timecard has already been transmitted."
+28 WRITE !,"If you think there is enough time to retransmit their 8B, you may:"
+29 WRITE !,"1. Have the Payroll Supervisor return the timecard"
+30 WRITE !,"2. Delete the memorandum"
+31 WRITE !,"3. Have the PTP complete a paper Subsidiary Record"
+32 WRITE !,"4. Have the Supervisor review and approve the Subsidiary Record"
+33 WRITE !,"5. Have the Timekeeper post each day in the Pay Period"
+34 WRITE !,"6. Re-certify and re-transmit the timecard"
+35 WRITE !!,"If there isn't enough time, the memorandum will have to be"
+36 WRITE !,"terminated and reconciled."
+37 SET MIEN=-1
End DoDot:2
QUIT
+38 ;
+39 IF STATUS="P"
Begin DoDot:2
+40 WRITE !!,"This PT Physician's timecard has already been certified."
+41 WRITE !,"If you think there is enough time, you may:"
+42 WRITE !,"1. Have the Payroll Supervisor return the timecard"
+43 WRITE !,"2. Delete the memorandum"
+44 WRITE !,"3. Have the PTP complete a paper Subsidiary Record"
+45 WRITE !,"4. Have the Supervisor review and approve the Subsidiary Record"
+46 WRITE !,"5. Have the Timekeeper post each day in the Pay Period"
+47 WRITE !,"6. Re-certify the timecard."
+48 WRITE !!,"If there isn't enough time, the memorandum will have to be"
+49 WRITE !,"terminated and reconciled."
+50 SET MIEN=-1
End DoDot:2
QUIT
+51 ; The End Date for future memorandums may not be in #458 yet
+52 IF PPI=""
Begin DoDot:2
+53 SET MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE"
SET INDX=INDX+1
End DoDot:2
QUIT
+54 ; If the End Date is in #458 check the timecard status for that PP
+55 ; Quit if Timecard status for the last PP of the mem is not (T)imekeeper
+56 if $PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T"
QUIT
+57 SET MEM(INDX)=MEM_"^"_START_"^"_END_"^ACTIVE"
SET INDX=INDX+1
End DoDot:1
+58 ; If no memos meet the deletion qualifications
+59 IF '$DATA(MEM(1))
Begin DoDot:1
+60 WRITE !!,"No memorandums meet the deletion qualifications for the "
+61 WRITE "selected employee,"
+62 SET MIEN=0
End DoDot:1
QUIT
+63 ; If only one memo
+64 IF '$DATA(MEM(2))
SET MIEN=$PIECE(MEM(1),U,1)
QUIT
+65 ; Display list if more than one
+66 IF $DATA(MEM(2))
Begin DoDot:1
+67 WRITE !!," # ",?5,"STARTS ENDS"
+68 FOR MEM=1:1
if '$DATA(MEM(MEM))
QUIT
Begin DoDot:2
+69 SET DATA=MEM(MEM)
+70 SET Y=$PIECE(DATA,U,2)
+71 DO DD^%DT
+72 SET START=Y
+73 SET Y=$PIECE(DATA,U,3)
+74 DO DD^%DT
+75 SET END=Y
+76 WRITE !!,MEM,?5,START," TO ",END
End DoDot:2
+77 ;
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="^")
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="Delete PT Physician Memoranda"
+2 DO HDR^PRSPUT1(PRSIEN,SCRTTL)
+3 SET DATA=$GET(^PRST(458.7,MIEN,0))
+4 SET X=$PIECE(DATA,U,2)
+5 SET START=$PIECE(DATA,U,2)
SET END=$PIECE(DATA,U,3)
SET AHRS=$PIECE(DATA,U,4)
+6 SET Y=START
+7 DO DD^%DT
+8 SET START=Y
+9 SET Y=END
+10 DO DD^%DT
+11 SET END=Y
+12 WRITE !!," Start Date: ",START
+13 WRITE !," End Date: ",END
+14 WRITE !,"Agreed Hours: ",AHRS,!!
+15 QUIT
+16 ;
ESIG ; Prompt for Electronic Signature and store fields in #458.7
+1 ;
+2 NEW ESOK,PPE
+3 DO ^PRSAES
+4 IF ESOK
Begin DoDot:1
+5 ; obtain first PP covered by the this memo
+6 SET PPE=$PIECE($GET(^PRST(458.7,MIEN,9,1,0)),U)
+7 ;
+8 ; Update #458.7 to delete the memo
+9 SET DA=MIEN
SET DIK="^PRST(458.7,"
+10 DO ^DIK
+11 WRITE !!,"Memorandum Deleted."
+12 ;
+13 ; loop thru PP to clear ESR and (if necesary) time card
+14 if PPE=""
QUIT
+15 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+16 if 'PPI
QUIT
+17 ; init PPI to include 1st PP in loop
SET PPI=PPI-.01
+18 FOR
SET PPI=$ORDER(^PRST(458,PPI))
if 'PPI
QUIT
Begin DoDot:2
+19 FOR DAY=1:1:14
Begin DoDot:3
+20 ; Check if Daily ESR with a status of APPROVED
+21 SET ESRSTAT=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
+22 ; Clear Time Card posting information
IF ESRSTAT=5
Begin DoDot:4
+23 KILL ^PRST(458,PPI,"E",PRSIEN,"D",DAY,2),^(3),^(10)
End DoDot:4
+24 ;
+25 ; delete any ESR data
+26 ; use fileman to delete ESR DAILY STATUS so x-ref will get updated
+27 SET PRSFDA(458.02,DAY_","_PRSIEN_","_PPI_",",146)="@"
+28 DO FILE^DIE("","PRSFDA")
DO MSG^DIALOG()
+29 ; delete ESR related fields
+30 KILL ^PRST(458,PPI,"E",PRSIEN,"D",DAY,5),^(6),^(7)
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
KILL ; Clean up variables
+1 ;
+2 KILL ASK,D1,DA,DATA,DAY,DIK,DIR,DIRUT,END,ESRSTAT,INDX,MEM,MIEN
+3 KILL PPI,PRSIEN,PRSFDA,TDATE,TCOM,SCRTTL,START,STATUS,STOP,X,Y,%,%DT
+4 QUIT
