PRSPRM ;WOIFO/MGD - PTP RECONCILE MEMORANDUM ;04/20/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 complete the reconciliation
; process for a memorandum that has expired or been terminated.
;
Q
;
MAIN ; Main Driver
;
K ^TMP($J,"PRSPRM")
; Prompt for Part Time Physician
D PTP
I Y'>0 D KILL^PRSPRM1 Q
S PRSIEN=+Y
; Find any memorandums that meet the reconciliation qualifications
S QUIT=""
D MEM
I 'MIEN D KILL^PRSPRM1 Q
I QUIT D KILL^PRSPRM1 Q
; Display employee and memorandum information
D DISPLAY
I $D(DIRUT) D KILL^PRSPRM1 Q
; Verify that all daily ESRs are completed
D ESRCHK
I QUIT D KILL^PRSPRM1 Q
; Display Summary information
D SUM^PRSPBRP
I $D(DIRUT) D KILL^PRSPRM1 Q
; Display Reconciliation Options
D ROPT^PRSPBRP
; Check for Reconciliation choice entered electronically
D PTPCHK^PRSPRM1
; Prompt HR for Reconciliation Choice
D HRRC^PRSPRM1
I RO="^" D KILL^PRSPRM1 Q
; Prompt for PTP Reconciliation Comments if Paper form was used
D PTPRCOM^PRSPRM1
I X="^" D KILL^PRSPRM1 Q
; Prompt to transfer balance to current memorandum
D TRNS^PRSPRM1
I QUIT D KILL^PRSPRM1 Q
; Prompt HR for any final reconciliation comments
D HRCOM^PRSPRM1
I X="^" D KILL^PRSPRM1 Q
; Prompt HR is they want to print the form for the Chief of Staff
S QUIT=0
D PRT^PRSPRM1
I QUIT D KILL^PRSPRM1 Q
; Prompt for E-sig and update file
D ESIG^PRSPRM1,KILL^PRSPRM1
Q
;
PTP ; Prompt for Part Time Physician
;
W !
S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: "
S DIC("S")="I $D(^PRST(458.7,""B"",+Y))"
D ^DIC K DIC
S PRSIEN=+Y
Q
;
MEM ; Find any memorandums that meet the reconciliation qualifications
;
N ENDAT,MEM,STDAT
S MEM=0,INDX=1
F S MEM=$O(^PRST(458.7,"B",PRSIEN,MEM)) Q:'MEM D
. D MEMDAT(MEM,.STATUS,.STDAT,.ENDAT,.TDAT)
. Q:STATUS'=3 ; Memos that have begun reconciliation have status = 3
. I $G(TDAT)>DT Q ; Termination Date has yet to occur
. Q:TDAT<1&(ENDAT>DT) ; Not Terminated and End Date has yet to occur
. S MEM(INDX)=MEM_"^"_STDAT_"^"_ENDAT_"^"_TDAT_"^"_"Reconciliation Started"
. S INDX=INDX+1
; If no memos meet the reconciliation qualifications
I '$D(MEM(1)) D Q
. W !!,"No memorandums meet the reconciliation 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
. S MIEN=0
. W !!," # ",?5,"STARTS",?20,"ENDS",?35,"TERMINATION DATE"
. 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
. . S Y=$P(DATA,U,4)
. . I Y'="" D
. . . D DD^%DT
. . . S TDAT=Y
. . W !,MEM,?5,START,?20,END,?35,TDAT
. ;
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)
. S DATA0=$G(^PRST(458.7,MIEN,0)) ; Memo info
. S DATA4=$G(^PRST(458.7,MIEN,4)) ; Termination info
Q
;
MEMDAT(MEM,MST,MSD,MED,MTD) ;
;RETURN MST- memo start date
; MSD- memo stop date
; MED- memo termination date
N DATA0,DATA4
S DATA0=$G(^PRST(458.7,MEM,0)) ; Memo info
S DATA4=$G(^PRST(458.7,MEM,4)) ; Termination info
S MST=$P(DATA0,U,6)
S MSD=$P(DATA0,U,2)
S MED=$P(DATA0,U,3)
S MTD=$P(DATA4,U,1)
Q
DISPLAY ; Display memorandum info to validate the correct employee was chosen
W:$E(IOST,1,2)="C-" @IOF
S SCRTTL=" PT Physician Reconcile Memorandum"
S ARRAY="^TMP($J,""PRSPRM"","
D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,1)
D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
D AL^PRSPUT3(PRSIEN,ARRAY)
D PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
Q
;
ESRCHK ; Check for any incomplete ESR within the memoranda.
;
N PPDATA,TPPI
D INDEX^PRSPUT1 ; Get last index
W:$E(IOST,1,2)="C-" @IOF
W $P(^PRSPC(PRSIEN,0),U,1)_" - Memorandum Summary"
S QUIT=0
S TPPI=""
I TDAT'="" D
. S DATA4=$G(^PRST(458.7,MIEN,4))
. Q:'+DATA4
. S TPPI=+$G(^PRST(458,"AD",$P(DATA4,U,1)))
F I=1:1:26 D
. S PPDATA=$G(^PRST(458.7,MIEN,9,I,0))
. S PPE=$P(PPDATA,U,1)
. Q:PPE=""
. S PPI=$O(^PRST(458,"B",PPE,0))
. Q:'PPI
. Q:PPI>TPPI ; Quit if PP is after termination PP
. F DAY=1:1:14 D Q:QUIT
. . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
. . I ESRSTAT<5 S ^TMP($J,"RG",PPE)=""
. ; Check for NP in Pay Period
. I $P(PPDATA,U,3) S ^TMP($J,"NP",PPE)=$P(PPDATA,U,3)
. ; Check for WP in Pay Period
. I $P(PPDATA,U,4) S ^TMP($J,"WP",PPE)=$P(PPDATA,U,4)
I $D(^TMP($J,"RG"))=10 D
. S TEXT="The following Pay Periods have days with incomplete daily ESRs: "
. D A1^PRSPUT1
. S (PPE,PPEX)="",PPCNT=0
. F S PPE=$O(^TMP($J,"RG",PPE)) Q:PPE="" D
. . S PPEX=$S(PPEX="":PPE,1:PPEX_", "_PPE)
. . S PPCNT=PPCNT+1
. . I PPCNT>10 D
. . . S TEXT=PPEX,PPCNT=0,PPEX=""
. . . D A1^PRSPUT1
. I PPCNT>0 D
. . S TEXT=PPEX
. . D A1^PRSPUT1
. S TEXT=""
. D A1^PRSPUT1
. S TEXT="These will have to be completed before the memorandum can be reconciled."
. D A1^PRSPUT1,A1^PRSPUT1
;
NP ; Check for Non-Pay hours
I $D(^TMP($J,"NP"))=10 D
. S TEXT="The following Pay Periods have Non-Pay hours:"
. D A1^PRSPUT1
. S PPE="",PPCNT=0,PPEX=""
. F S PPE=$O(^TMP($J,"NP",PPE)) Q:'PPE D
. . S PPEX1=PPE_" - "_^TMP($J,"NP",PPE),$E(PPEX1,15)=""
. . S PPEX=PPEX_PPEX1
. . S PPCNT=PPCNT+1
. . I PPCNT>4 D
. . . S TEXT=PPEX,PPCNT=0,PPEX=""
. . . D A1^PRSPUT1
. I PPCNT>0 D
. . S TEXT=PPEX
. . D A1^PRSPUT1
;
; Check for Without-Pay hours
WP I $D(^TMP($J,"WP"))=10 D
. S TEXT="The following Pay Periods have Without-Pay hours:"
. D A1^PRSPUT1
. S PPE="",PPCNT=0,PPEX=""
. F S PPE=$O(^TMP($J,"WP",PPE)) Q:'PPE D
. . S PPEX1=PPE_" - "_^TMP($J,"WP",PPE),$E(PPEX1,15)=""
. . S PPEX=PPEX_PPEX1
. . S PPCNT=PPCNT+1
. . I PPCNT>4 D
. . . S TEXT=PPEX,PPCNT=0,PPEX=""
. . . D A1^PRSPUT1
. I PPCNT>0 D
. . S TEXT=PPEX
. . D A1^PRSPUT1
K ^TMP($J,"RG"),^TMP($J,"NP"),^TMP($J,"WP")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPRM 6397 printed Apr 09, 2024@21:30:35 Page 2
PRSPRM ;WOIFO/MGD - PTP RECONCILE MEMORANDUM ;04/20/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 complete the reconciliation
+5 ; process for a memorandum that has expired or been terminated.
+6 ;
+7 QUIT
+8 ;
MAIN ; Main Driver
+1 ;
+2 KILL ^TMP($JOB,"PRSPRM")
+3 ; Prompt for Part Time Physician
+4 DO PTP
+5 IF Y'>0
DO KILL^PRSPRM1
QUIT
+6 SET PRSIEN=+Y
+7 ; Find any memorandums that meet the reconciliation qualifications
+8 SET QUIT=""
+9 DO MEM
+10 IF 'MIEN
DO KILL^PRSPRM1
QUIT
+11 IF QUIT
DO KILL^PRSPRM1
QUIT
+12 ; Display employee and memorandum information
+13 DO DISPLAY
+14 IF $DATA(DIRUT)
DO KILL^PRSPRM1
QUIT
+15 ; Verify that all daily ESRs are completed
+16 DO ESRCHK
+17 IF QUIT
DO KILL^PRSPRM1
QUIT
+18 ; Display Summary information
+19 DO SUM^PRSPBRP
+20 IF $DATA(DIRUT)
DO KILL^PRSPRM1
QUIT
+21 ; Display Reconciliation Options
+22 DO ROPT^PRSPBRP
+23 ; Check for Reconciliation choice entered electronically
+24 DO PTPCHK^PRSPRM1
+25 ; Prompt HR for Reconciliation Choice
+26 DO HRRC^PRSPRM1
+27 IF RO="^"
DO KILL^PRSPRM1
QUIT
+28 ; Prompt for PTP Reconciliation Comments if Paper form was used
+29 DO PTPRCOM^PRSPRM1
+30 IF X="^"
DO KILL^PRSPRM1
QUIT
+31 ; Prompt to transfer balance to current memorandum
+32 DO TRNS^PRSPRM1
+33 IF QUIT
DO KILL^PRSPRM1
QUIT
+34 ; Prompt HR for any final reconciliation comments
+35 DO HRCOM^PRSPRM1
+36 IF X="^"
DO KILL^PRSPRM1
QUIT
+37 ; Prompt HR is they want to print the form for the Chief of Staff
+38 SET QUIT=0
+39 DO PRT^PRSPRM1
+40 IF QUIT
DO KILL^PRSPRM1
QUIT
+41 ; Prompt for E-sig and update file
+42 DO ESIG^PRSPRM1
DO KILL^PRSPRM1
+43 QUIT
+44 ;
PTP ; Prompt for Part Time Physician
+1 ;
+2 WRITE !
+3 SET DIC="^PRSPC("
SET DIC(0)="AEMQZ"
SET DIC("A")="Select EMPLOYEE: "
+4 SET DIC("S")="I $D(^PRST(458.7,""B"",+Y))"
+5 DO ^DIC
KILL DIC
+6 SET PRSIEN=+Y
+7 QUIT
+8 ;
MEM ; Find any memorandums that meet the reconciliation qualifications
+1 ;
+2 NEW ENDAT,MEM,STDAT
+3 SET MEM=0
SET INDX=1
+4 FOR
SET MEM=$ORDER(^PRST(458.7,"B",PRSIEN,MEM))
if 'MEM
QUIT
Begin DoDot:1
+5 DO MEMDAT(MEM,.STATUS,.STDAT,.ENDAT,.TDAT)
+6 ; Memos that have begun reconciliation have status = 3
if STATUS'=3
QUIT
+7 ; Termination Date has yet to occur
IF $GET(TDAT)>DT
QUIT
+8 ; Not Terminated and End Date has yet to occur
if TDAT<1&(ENDAT>DT)
QUIT
+9 SET MEM(INDX)=MEM_"^"_STDAT_"^"_ENDAT_"^"_TDAT_"^"_"Reconciliation Started"
+10 SET INDX=INDX+1
End DoDot:1
+11 ; If no memos meet the reconciliation qualifications
+12 IF '$DATA(MEM(1))
Begin DoDot:1
+13 WRITE !!,"No memorandums meet the reconciliation qualifications for the "
+14 WRITE "selected employee."
+15 SET MIEN=0
End DoDot:1
QUIT
+16 ; If only one memo
+17 IF '$DATA(MEM(2))
SET MIEN=$PIECE(MEM(1),U,1)
QUIT
+18 ; Display list if more than one
+19 IF $DATA(MEM(2))
Begin DoDot:1
+20 SET MIEN=0
+21 WRITE !!," # ",?5,"STARTS",?20,"ENDS",?35,"TERMINATION DATE"
+22 FOR MEM=1:1
if '$DATA(MEM(MEM))
QUIT
Begin DoDot:2
+23 SET DATA=MEM(MEM)
+24 SET Y=$PIECE(DATA,U,2)
+25 DO DD^%DT
+26 SET START=Y
+27 SET Y=$PIECE(DATA,U,3)
+28 DO DD^%DT
+29 SET END=Y
+30 SET Y=$PIECE(DATA,U,4)
+31 IF Y'=""
Begin DoDot:3
+32 DO DD^%DT
+33 SET TDAT=Y
End DoDot:3
+34 WRITE !,MEM,?5,START,?20,END,?35,TDAT
End DoDot:2
+35 ;
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)
+9 ; Memo info
SET DATA0=$GET(^PRST(458.7,MIEN,0))
+10 ; Termination info
SET DATA4=$GET(^PRST(458.7,MIEN,4))
End DoDot:1
+11 QUIT
+12 ;
MEMDAT(MEM,MST,MSD,MED,MTD) ;
+1 ;RETURN MST- memo start date
+2 ; MSD- memo stop date
+3 ; MED- memo termination date
+4 NEW DATA0,DATA4
+5 ; Memo info
SET DATA0=$GET(^PRST(458.7,MEM,0))
+6 ; Termination info
SET DATA4=$GET(^PRST(458.7,MEM,4))
+7 SET MST=$PIECE(DATA0,U,6)
+8 SET MSD=$PIECE(DATA0,U,2)
+9 SET MED=$PIECE(DATA0,U,3)
+10 SET MTD=$PIECE(DATA4,U,1)
+11 QUIT
DISPLAY ; Display memorandum info to validate the correct employee was chosen
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 SET SCRTTL=" PT Physician Reconcile Memorandum"
+3 SET ARRAY="^TMP($J,""PRSPRM"","
+4 DO HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,1)
+5 DO MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
+6 DO AL^PRSPUT3(PRSIEN,ARRAY)
+7 DO PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
+8 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
+9 QUIT
+10 ;
ESRCHK ; Check for any incomplete ESR within the memoranda.
+1 ;
+2 NEW PPDATA,TPPI
+3 ; Get last index
DO INDEX^PRSPUT1
+4 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+5 WRITE $PIECE(^PRSPC(PRSIEN,0),U,1)_" - Memorandum Summary"
+6 SET QUIT=0
+7 SET TPPI=""
+8 IF TDAT'=""
Begin DoDot:1
+9 SET DATA4=$GET(^PRST(458.7,MIEN,4))
+10 if '+DATA4
QUIT
+11 SET TPPI=+$GET(^PRST(458,"AD",$PIECE(DATA4,U,1)))
End DoDot:1
+12 FOR I=1:1:26
Begin DoDot:1
+13 SET PPDATA=$GET(^PRST(458.7,MIEN,9,I,0))
+14 SET PPE=$PIECE(PPDATA,U,1)
+15 if PPE=""
QUIT
+16 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+17 if 'PPI
QUIT
+18 ; Quit if PP is after termination PP
if PPI>TPPI
QUIT
+19 FOR DAY=1:1:14
Begin DoDot:2
+20 SET ESRSTAT=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
+21 IF ESRSTAT<5
SET ^TMP($JOB,"RG",PPE)=""
End DoDot:2
if QUIT
QUIT
+22 ; Check for NP in Pay Period
+23 IF $PIECE(PPDATA,U,3)
SET ^TMP($JOB,"NP",PPE)=$PIECE(PPDATA,U,3)
+24 ; Check for WP in Pay Period
+25 IF $PIECE(PPDATA,U,4)
SET ^TMP($JOB,"WP",PPE)=$PIECE(PPDATA,U,4)
End DoDot:1
+26 IF $DATA(^TMP($JOB,"RG"))=10
Begin DoDot:1
+27 SET TEXT="The following Pay Periods have days with incomplete daily ESRs: "
+28 DO A1^PRSPUT1
+29 SET (PPE,PPEX)=""
SET PPCNT=0
+30 FOR
SET PPE=$ORDER(^TMP($JOB,"RG",PPE))
if PPE=""
QUIT
Begin DoDot:2
+31 SET PPEX=$SELECT(PPEX="":PPE,1:PPEX_", "_PPE)
+32 SET PPCNT=PPCNT+1
+33 IF PPCNT>10
Begin DoDot:3
+34 SET TEXT=PPEX
SET PPCNT=0
SET PPEX=""
+35 DO A1^PRSPUT1
End DoDot:3
End DoDot:2
+36 IF PPCNT>0
Begin DoDot:2
+37 SET TEXT=PPEX
+38 DO A1^PRSPUT1
End DoDot:2
+39 SET TEXT=""
+40 DO A1^PRSPUT1
+41 SET TEXT="These will have to be completed before the memorandum can be reconciled."
+42 DO A1^PRSPUT1
DO A1^PRSPUT1
End DoDot:1
+43 ;
NP ; Check for Non-Pay hours
+1 IF $DATA(^TMP($JOB,"NP"))=10
Begin DoDot:1
+2 SET TEXT="The following Pay Periods have Non-Pay hours:"
+3 DO A1^PRSPUT1
+4 SET PPE=""
SET PPCNT=0
SET PPEX=""
+5 FOR
SET PPE=$ORDER(^TMP($JOB,"NP",PPE))
if 'PPE
QUIT
Begin DoDot:2
+6 SET PPEX1=PPE_" - "_^TMP($JOB,"NP",PPE)
SET $EXTRACT(PPEX1,15)=""
+7 SET PPEX=PPEX_PPEX1
+8 SET PPCNT=PPCNT+1
+9 IF PPCNT>4
Begin DoDot:3
+10 SET TEXT=PPEX
SET PPCNT=0
SET PPEX=""
+11 DO A1^PRSPUT1
End DoDot:3
End DoDot:2
+12 IF PPCNT>0
Begin DoDot:2
+13 SET TEXT=PPEX
+14 DO A1^PRSPUT1
End DoDot:2
End DoDot:1
+15 ;
+16 ; Check for Without-Pay hours
WP IF $DATA(^TMP($JOB,"WP"))=10
Begin DoDot:1
+1 SET TEXT="The following Pay Periods have Without-Pay hours:"
+2 DO A1^PRSPUT1
+3 SET PPE=""
SET PPCNT=0
SET PPEX=""
+4 FOR
SET PPE=$ORDER(^TMP($JOB,"WP",PPE))
if 'PPE
QUIT
Begin DoDot:2
+5 SET PPEX1=PPE_" - "_^TMP($JOB,"WP",PPE)
SET $EXTRACT(PPEX1,15)=""
+6 SET PPEX=PPEX_PPEX1
+7 SET PPCNT=PPCNT+1
+8 IF PPCNT>4
Begin DoDot:3
+9 SET TEXT=PPEX
SET PPCNT=0
SET PPEX=""
+10 DO A1^PRSPUT1
End DoDot:3
End DoDot:2
+11 IF PPCNT>0
Begin DoDot:2
+12 SET TEXT=PPEX
+13 DO A1^PRSPUT1
End DoDot:2
End DoDot:1
+14 KILL ^TMP($JOB,"RG"),^TMP($JOB,"NP"),^TMP($JOB,"WP")
+15 QUIT
