311 lines
9.3 KiB
Mathematica
311 lines
9.3 KiB
Mathematica
PRSPBRP ;WOIFO/MGD - PTP BEGIN RECONCILIATION OF MEMORANDUM ;01/29/07
|
|
;;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 begin the reconciliation
|
|
; process for a memorandum that has expired or been terminated.
|
|
; After the PT Physician is selected a summary screen will be
|
|
; displayed to verify that the correct memo is selected.
|
|
; Then a list of the reconciliation choices will be displayed and HR
|
|
; will either print the reconciliation process or they will e-mail it
|
|
; to the PT Physician.
|
|
;
|
|
Q
|
|
;
|
|
MAIN ; Prompt for Part Time Physician
|
|
S QUIT=0
|
|
F D I QUIT D KILL Q
|
|
. S PRSIEN=""
|
|
. D PTP^PRSPRM
|
|
. I PRSIEN<1 S QUIT=1 Q
|
|
. D DRIVER
|
|
. K ^TMP($J,"PRSPBRP")
|
|
Q
|
|
;
|
|
DRIVER ; Main Driver
|
|
;
|
|
; Find any memorandums that meet the begin reconciliation qualifications
|
|
D MEM
|
|
Q:'MIEN
|
|
; Display employee and memorandum information
|
|
D DISPLAY
|
|
Q:$D(DIRUT)
|
|
; Display any outstanding PP ESRs
|
|
D ESRCHK^PRSPRM
|
|
; Display Summary information
|
|
D SUM
|
|
Q:$D(DIRUT)
|
|
; Reconciliation Options
|
|
D ROPT
|
|
; Prompt for Print or E-mail
|
|
D ASK2
|
|
Q:ASK2="^"!($G(POP))
|
|
; Prompt for E-sig and update file
|
|
D ESIG
|
|
Q
|
|
;
|
|
MEM ; Find any memorandums that meet the begin reconciliation qualifications
|
|
;
|
|
N ENDAT,INDX,MEM,STDAT
|
|
S MEM=0,INDX=1
|
|
F S MEM=$O(^PRST(458.7,"B",PRSIEN,MEM)) Q:'MEM D
|
|
. S DATA0=$G(^PRST(458.7,MEM,0)) ; Memo info
|
|
. S DATA4=$G(^PRST(458.7,MEM,4)) ; Termination info
|
|
. Q:DATA0=""
|
|
. S STATUS=$P(DATA0,U,6)
|
|
. Q:STATUS'=2 ; Recently ended memos would still be in status of 2
|
|
. S STDAT=$P(DATA0,U,2)
|
|
. S ENDAT=$P(DATA0,U,3)
|
|
. S TDAT=$P(DATA4,U,1)
|
|
. I TDAT,TDAT>DT Q ; Termination Date has yet to occur
|
|
. I TDAT S ENDAT=TDAT ; Set ENDAT to Termination Date
|
|
. Q:TDAT=""&(ENDAT>DT) ; Not Terminated and End Date has yet to occur
|
|
. S MEM(INDX)=MEM_"^"_STDAT_"^"_ENDAT_"^ACTIVE"
|
|
. 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
|
|
. 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," ",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)
|
|
. S DATA0=$G(^PRST(458.7,MIEN,0)) ; Memo info
|
|
. S DATA4=$G(^PRST(458.7,MIEN,4)) ; Termination info
|
|
Q
|
|
;
|
|
DISPLAY ; Display memorandum info to validate the correct employee was chosen
|
|
W:$E(IOST,1,2)="C-" @IOF
|
|
S SCRTTL=" PT Physician Begin Reconciliation Process",INDX=1
|
|
S ARRAY="^TMP($J,""PRSPBRP"","
|
|
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
|
|
;
|
|
SUM ; Display Summary information - Screen #2
|
|
D INDEX^PRSPUT1 ; Get last index
|
|
S TEXT=""
|
|
D A1^PRSPUT1
|
|
N AHRS,AMT,COHRS,DATA0,ENDSTA,POMC,PPREM,RATE,SALARY,SPAA
|
|
N THW,TOTNP,TOTWP
|
|
S PPREM=$P($$MEMCPP^PRSPUT3(MIEN),U,2) ; Determine # PP already worked
|
|
S PPREM=26-PPREM ; Pay Periods REMaining
|
|
S DATA0=$G(^PRST(458.7,MIEN,0))
|
|
S AHRS=$P(DATA0,U,4) ; Agreed Hours
|
|
S COHRS=$P(DATA0,U,9) ; Carryover Hours
|
|
S COHRS=$G(COHRS,"0.00")
|
|
S THW=$P(DATA0,U,10) ; Total Hours Worked
|
|
S TOTNP=$P(DATA0,U,12) ; Total NonPay Hours
|
|
I TOTNP="" S TOTNP="0.00"
|
|
S TOTWP=$P(DATA0,U,13) ; Total Without Pay Hours
|
|
I TOTWP="" S TOTWP="0.00"
|
|
S POMC=+$P(DATA0,U,14) ; % of Memo Completed
|
|
S POT=+$P(DATA0,U,17) ; % Off Target
|
|
S TEXT=" Percent Completed: "_$J(POMC,6,2)
|
|
D A1^PRSPUT1 ; Screen 2, Line 3
|
|
S OTHRS=AHRS/26*(26-PPREM)-TOTNP-TOTWP ; Hrs that should've been worked
|
|
S OTHRS=THW+COHRS-OTHRS ; Off Target HouRS
|
|
S TEXT=" Off Target Hours: "_$J(OTHRS,6,2)
|
|
D A1^PRSPUT1 ; Screen 2, Line 4
|
|
S TEXT="Off Target Percentage: "_$J(POT,6,2)
|
|
D A1^PRSPUT1 ; Screen 2, Line 5
|
|
D A1^PRSPUT1 ; Screen 2, Line 6
|
|
S TEXT=" Non Pay Hours: "_$J(TOTNP,6,2)
|
|
D A1^PRSPUT1 ; Screen 2, Line 7
|
|
S TEXT=" Without Pay Hours: "_$J(TOTWP,6,2)
|
|
D A1^PRSPUT1 ; Screen 2, Line 8
|
|
S TEXT=" Carryover Hours: "_$J(COHRS,6,2)
|
|
D A1^PRSPUT1,A1^PRSPUT1 ; Screen 2, Line 9
|
|
; Calculate amount owed
|
|
S SALARY=$P($G(^PRSPC(PRSIEN,0)),U,29) ; Salary
|
|
S SPAA=$P($G(^PRSPC(PRSIEN,"T38")),U,24) ; Special Pay Annual Amount
|
|
S RATE=SALARY+SPAA/2080
|
|
S RATE=$J(RATE,0,2)
|
|
S AMT=$J(OTHRS*RATE,6,2)
|
|
S TEXT="Estimated Gross Amount Owed "
|
|
S ENDSTA=$S(OTHRS>0:"Over",OTHRS<0:"Under",1:"Even")
|
|
S TEXT=TEXT_$S(ENDSTA="Over":"PTP",1:"VA")_": "_AMT
|
|
D A1^PRSPUT1 ; Screen 2, Line 10
|
|
S TEXT=" Ending Status: "_$J(ENDSTA,6)
|
|
D A1^PRSPUT1 ; Screen 2,
|
|
W !
|
|
S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
|
|
Q
|
|
;
|
|
ROPT ; Reconciliation Options
|
|
;
|
|
I $E(IOST,1,2)="C-" W @IOF
|
|
W $P(^PRSPC(PRSIEN,0),U,1)_" - Memorandum Summary"
|
|
D A1^PRSPUT1 ; Screen 2, Line 8 - Blank line
|
|
S TEXT="Reconciliation Options:"
|
|
D A1^PRSPUT1 ; Screen 2, Line 9
|
|
; PTP worked less than Agreed Hours
|
|
;I POT<-5.00 D Q
|
|
I POT<0 D Q
|
|
. S TEXT="Pay VA for negative balance"
|
|
. S MEM(1)=TEXT_U_3
|
|
. S TEXT="1. "_TEXT
|
|
. D A1^PRSPUT1 ; Screen 2, Line 10
|
|
;
|
|
; PTP worked more than Agreed Hours
|
|
; CO policy removed I POT>5.00 D Q
|
|
I POT>0 D Q
|
|
. S TEXT="Pay Phy for positive balance"
|
|
. S MEM(1)=TEXT_U_5
|
|
. S TEXT="1. "_TEXT
|
|
. D A1^PRSPUT1 ; Screen 2, Line 10
|
|
;
|
|
; PTP worked Agreed Hours exactly
|
|
I POT=0 D Q
|
|
. S TEXT="No reconciliation needed"
|
|
. S MEM(1)=TEXT_U_1
|
|
. S TEXT="1. "_TEXT
|
|
. D A1^PRSPUT1 ; Screen 2, Line 10
|
|
;
|
|
;***************************************************************
|
|
;PRS*4*93: BEGIN comment out carry over options--during testing
|
|
;policy was changed to not allow ptp to carry over hours within
|
|
;5% of agreement.
|
|
;***************************************************************
|
|
;; Within 5% of Agreed Hours
|
|
;; Check for next memorandum
|
|
;S OLDMIEN=MIEN
|
|
;S NMIEN=+$$MIEN^PRSPUT1(PRSIEN)
|
|
;S MIEN=OLDMIEN
|
|
;I 'NMIEN D
|
|
;. S TEXT="No current Memorandum on file. Transfer not possible."
|
|
;. D A1^PRSPUT1
|
|
;. S TEXT="If applicable, exit and enter a new memorandum first."
|
|
;. D A1^PRSPUT1
|
|
;;
|
|
;; Negative Balance Options
|
|
;I POT<0 D
|
|
;. S TEXT="Pay VA for negative balance"
|
|
;. S MEM(1)=TEXT_U_3
|
|
;. S TEXT="1. "_TEXT
|
|
;. D A1^PRSPUT1 ; Screen 2, Line 12
|
|
;I NMIEN,POT<0 D
|
|
;. S TEXT="Transfer negative balance"
|
|
;. S MEM(2)=TEXT_U_2
|
|
;. S TEXT="2. "_TEXT
|
|
;. D A1^PRSPUT1 ; Screen 2, Line 11
|
|
;;
|
|
;; Postive Balance Options
|
|
;I POT>0 D
|
|
;. S TEXT="Pay PT Phy for positive balance"
|
|
;. S MEM(1)=TEXT_U_5
|
|
;. S TEXT="1. "_TEXT
|
|
;. D A1^PRSPUT1 ; Screen 2, Line 12
|
|
;I NMIEN,POT>0 D
|
|
;. S TEXT="Transfer positive balance"
|
|
;. S MEM(2)=TEXT_U_4
|
|
;. S TEXT="2. "_TEXT
|
|
;. D A1^PRSPUT1 ; Screen 2, Line 11
|
|
;;finish the remainder of the form
|
|
;D A1^PRSPUT1 ; Blank Line
|
|
;S TEXT="Enter Reconciliation Option: _____"
|
|
;D A1^PRSPUT1
|
|
;D A1^PRSPUT1 ; Blank Line
|
|
;S $P(DASH,"_",55)="_"
|
|
;S TEXT="Reconciliation Comments: "_DASH
|
|
;D A1^PRSPUT1 ; Reconciliation Comments Line #1
|
|
;D A1^PRSPUT1 ; Blank Line
|
|
;S DASH="",$P(DASH,"_",80)="_"
|
|
;S TEXT=DASH
|
|
;D A1^PRSPUT1 ; Reconciliation Comments Line #2
|
|
;D A1^PRSPUT1 ; Blank Line
|
|
;S TEXT=DASH
|
|
;D A1^PRSPUT1 ; Reconciliation Comments Line #3
|
|
;D A1^PRSPUT1 ; Blank Line
|
|
;D A1^PRSPUT1 ; Reconciliation Comments Line #4
|
|
;S DASH="",$P(DASH,"_",41)="_"
|
|
;S TEXT="Signature: "_DASH
|
|
;S DASH="",$P(DASH,"_",20)="_"
|
|
;S TEXT=TEXT_" Date: "_DASH
|
|
;D A1^PRSPUT1
|
|
;**********************************
|
|
;END of comment out carry over options
|
|
;**********************************
|
|
Q
|
|
;
|
|
ASK2 ; Prompt to e-mail or print.
|
|
;
|
|
W !!,"Would you like to use a (H)ard copy or (E)lectronic reconciliation form: "
|
|
R ASK2:DTIME
|
|
S ASK2=$$UPPER^PRSRUTL(ASK2)
|
|
Q:ASK2="^"
|
|
I "^H^E^"'[("^"_ASK2_"^") D G ASK2
|
|
. W !!,"Enter H or E or ^ to Quit."
|
|
Q
|
|
;
|
|
ESIG ; Prompt for Electronic Signature and store fields in #458.7
|
|
;
|
|
N ESOK
|
|
D ^PRSAES
|
|
I 'ESOK K ^TMP($J,"PRSPBRP") Q
|
|
;
|
|
DEV I ASK2="H" D Q:POP
|
|
. K IOP,%ZIS
|
|
. S %ZIS("A")="Select Device: ",%ZIS="MQ"
|
|
. W !
|
|
. D ^%ZIS
|
|
. K %ZIS,IOP
|
|
. I $D(IO("Q")) D Q ; Queued
|
|
.. S ZTDESC="PRS PTP BEGIN RECONCILE PROC"
|
|
.. S ZTRTN="PRINT^PRSPBRP"
|
|
.. S ZTSAVE("^TMP($J,""PRSPBRP"",")=""
|
|
.. D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
|
|
.. K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
|
|
.. D HOME^%ZIS
|
|
. U IO
|
|
. D PRINT,^%ZISC
|
|
. K %ZIS,IOP
|
|
; Update STATUS or memorandum
|
|
S MIEN=MIEN_",",PRSFDA(458.7,MIEN,5)=3
|
|
D UPDATE^DIE("","PRSFDA","MIEN"),MSG^DIALOG()
|
|
W !!,"Memorandum Status updated to: RECONCILIATION STARTED",!
|
|
K ^TMP($J,"PRSPBRP")
|
|
Q
|
|
;
|
|
PRINT ; Print the paper version of the Reconciliation form
|
|
;
|
|
S INDEX=""
|
|
F S INDEX=$O(^TMP($J,"PRSPBRP",INDEX)) Q:'INDEX D
|
|
. S TEXT=^TMP($J,"PRSPBRP",INDEX)
|
|
. W !,TEXT
|
|
K ^TMP($J),TEXT
|
|
Q
|
|
;
|
|
KILL ; Clean up variables
|
|
;
|
|
K AMT,ARRAY,ASK,ASK2,COHRS,D1,DASH,DATA,DATA0,DATA4,DAY,DIR,DIRUT
|
|
K END,ENDSTA,INDEX,INDX,MEM,MIEN,NMIEN,NPHRS,OLDMIEN,OTHRS
|
|
K POP,POT,PPI,PPCNT,PPREM,PRSAPGM,PRSIEN,PRSFDA,QUIT,RATE,SALARY
|
|
K SCRTTL,SPAA,START,STATUS,TDAT,TDATE,WPHRS,ZTSAVE,X,Y
|
|
K ^TMP($J,"PRSPBRP")
|
|
Q
|