- 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 Feb 18, 2025@23:54:24 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