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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPBRP 9844 printed Dec 13, 2024@02:27:47 Page 2
PRSPBRP ;WOIFO/MGD - PTP BEGIN RECONCILIATION OF MEMORANDUM ;01/29/07
+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 begin the reconciliation
+5 ; process for a memorandum that has expired or been terminated.
+6 ; After the PT Physician is selected a summary screen will be
+7 ; displayed to verify that the correct memo is selected.
+8 ; Then a list of the reconciliation choices will be displayed and HR
+9 ; will either print the reconciliation process or they will e-mail it
+10 ; to the PT Physician.
+11 ;
+12 QUIT
+13 ;
MAIN ; Prompt for Part Time Physician
+1 SET QUIT=0
+2 FOR
Begin DoDot:1
+3 SET PRSIEN=""
+4 DO PTP^PRSPRM
+5 IF PRSIEN<1
SET QUIT=1
QUIT
+6 DO DRIVER
+7 KILL ^TMP($JOB,"PRSPBRP")
End DoDot:1
IF QUIT
DO KILL
QUIT
+8 QUIT
+9 ;
DRIVER ; Main Driver
+1 ;
+2 ; Find any memorandums that meet the begin reconciliation qualifications
+3 DO MEM
+4 if 'MIEN
QUIT
+5 ; Display employee and memorandum information
+6 DO DISPLAY
+7 if $DATA(DIRUT)
QUIT
+8 ; Display any outstanding PP ESRs
+9 DO ESRCHK^PRSPRM
+10 ; Display Summary information
+11 DO SUM
+12 if $DATA(DIRUT)
QUIT
+13 ; Reconciliation Options
+14 DO ROPT
+15 ; Prompt for Print or E-mail
+16 DO ASK2
+17 if ASK2="^"!($GET(POP))
QUIT
+18 ; Prompt for E-sig and update file
+19 DO ESIG
+20 QUIT
+21 ;
MEM ; Find any memorandums that meet the begin reconciliation qualifications
+1 ;
+2 NEW ENDAT,INDX,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 ; Memo info
SET DATA0=$GET(^PRST(458.7,MEM,0))
+6 ; Termination info
SET DATA4=$GET(^PRST(458.7,MEM,4))
+7 if DATA0=""
QUIT
+8 SET STATUS=$PIECE(DATA0,U,6)
+9 ; Recently ended memos would still be in status of 2
if STATUS'=2
QUIT
+10 SET STDAT=$PIECE(DATA0,U,2)
+11 SET ENDAT=$PIECE(DATA0,U,3)
+12 SET TDAT=$PIECE(DATA4,U,1)
+13 ; Termination Date has yet to occur
IF TDAT
IF TDAT>DT
QUIT
+14 ; Set ENDAT to Termination Date
IF TDAT
SET ENDAT=TDAT
+15 ; Not Terminated and End Date has yet to occur
if TDAT=""&(ENDAT>DT)
QUIT
+16 SET MEM(INDX)=MEM_"^"_STDAT_"^"_ENDAT_"^ACTIVE"
+17 SET INDX=INDX+1
End DoDot:1
+18 ; If no memos meet the reconciliation qualifications
+19 IF '$DATA(MEM(1))
Begin DoDot:1
+20 WRITE !!,"No memorandums meet the reconciliation qualifications for the "
+21 WRITE "selected employee."
+22 SET MIEN=0
End DoDot:1
QUIT
+23 ; If only one memo
+24 IF '$DATA(MEM(2))
SET MIEN=$PIECE(MEM(1),U,1)
QUIT
+25 ; Display list if more than one
+26 IF $DATA(MEM(2))
Begin DoDot:1
+27 WRITE !!,"# ",?5,"STARTS ENDS"
+28 FOR MEM=1:1
if '$DATA(MEM(MEM))
QUIT
Begin DoDot:2
+29 SET DATA=MEM(MEM)
+30 SET Y=$PIECE(DATA,U,2)
+31 DO DD^%DT
+32 SET START=Y
+33 SET Y=$PIECE(DATA,U,3)
+34 DO DD^%DT
+35 SET END=Y
+36 WRITE !,MEM,?5,START," ",END
End DoDot:2
+37 ;
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)
+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 ;
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 Begin Reconciliation Process"
SET INDX=1
+3 SET ARRAY="^TMP($J,""PRSPBRP"","
+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 ;
SUM ; Display Summary information - Screen #2
+1 ; Get last index
DO INDEX^PRSPUT1
+2 SET TEXT=""
+3 DO A1^PRSPUT1
+4 NEW AHRS,AMT,COHRS,DATA0,ENDSTA,POMC,PPREM,RATE,SALARY,SPAA
+5 NEW THW,TOTNP,TOTWP
+6 ; Determine # PP already worked
SET PPREM=$PIECE($$MEMCPP^PRSPUT3(MIEN),U,2)
+7 ; Pay Periods REMaining
SET PPREM=26-PPREM
+8 SET DATA0=$GET(^PRST(458.7,MIEN,0))
+9 ; Agreed Hours
SET AHRS=$PIECE(DATA0,U,4)
+10 ; Carryover Hours
SET COHRS=$PIECE(DATA0,U,9)
+11 SET COHRS=$GET(COHRS,"0.00")
+12 ; Total Hours Worked
SET THW=$PIECE(DATA0,U,10)
+13 ; Total NonPay Hours
SET TOTNP=$PIECE(DATA0,U,12)
+14 IF TOTNP=""
SET TOTNP="0.00"
+15 ; Total Without Pay Hours
SET TOTWP=$PIECE(DATA0,U,13)
+16 IF TOTWP=""
SET TOTWP="0.00"
+17 ; % of Memo Completed
SET POMC=+$PIECE(DATA0,U,14)
+18 ; % Off Target
SET POT=+$PIECE(DATA0,U,17)
+19 SET TEXT=" Percent Completed: "_$JUSTIFY(POMC,6,2)
+20 ; Screen 2, Line 3
DO A1^PRSPUT1
+21 ; Hrs that should've been worked
SET OTHRS=AHRS/26*(26-PPREM)-TOTNP-TOTWP
+22 ; Off Target HouRS
SET OTHRS=THW+COHRS-OTHRS
+23 SET TEXT=" Off Target Hours: "_$JUSTIFY(OTHRS,6,2)
+24 ; Screen 2, Line 4
DO A1^PRSPUT1
+25 SET TEXT="Off Target Percentage: "_$JUSTIFY(POT,6,2)
+26 ; Screen 2, Line 5
DO A1^PRSPUT1
+27 ; Screen 2, Line 6
DO A1^PRSPUT1
+28 SET TEXT=" Non Pay Hours: "_$JUSTIFY(TOTNP,6,2)
+29 ; Screen 2, Line 7
DO A1^PRSPUT1
+30 SET TEXT=" Without Pay Hours: "_$JUSTIFY(TOTWP,6,2)
+31 ; Screen 2, Line 8
DO A1^PRSPUT1
+32 SET TEXT=" Carryover Hours: "_$JUSTIFY(COHRS,6,2)
+33 ; Screen 2, Line 9
DO A1^PRSPUT1
DO A1^PRSPUT1
+34 ; Calculate amount owed
+35 ; Salary
SET SALARY=$PIECE($GET(^PRSPC(PRSIEN,0)),U,29)
+36 ; Special Pay Annual Amount
SET SPAA=$PIECE($GET(^PRSPC(PRSIEN,"T38")),U,24)
+37 SET RATE=SALARY+SPAA/2080
+38 SET RATE=$JUSTIFY(RATE,0,2)
+39 SET AMT=$JUSTIFY(OTHRS*RATE,6,2)
+40 SET TEXT="Estimated Gross Amount Owed "
+41 SET ENDSTA=$SELECT(OTHRS>0:"Over",OTHRS<0:"Under",1:"Even")
+42 SET TEXT=TEXT_$SELECT(ENDSTA="Over":"PTP",1:"VA")_": "_AMT
+43 ; Screen 2, Line 10
DO A1^PRSPUT1
+44 SET TEXT=" Ending Status: "_$JUSTIFY(ENDSTA,6)
+45 ; Screen 2,
DO A1^PRSPUT1
+46 WRITE !
+47 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
+48 QUIT
+49 ;
ROPT ; Reconciliation Options
+1 ;
+2 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+3 WRITE $PIECE(^PRSPC(PRSIEN,0),U,1)_" - Memorandum Summary"
+4 ; Screen 2, Line 8 - Blank line
DO A1^PRSPUT1
+5 SET TEXT="Reconciliation Options:"
+6 ; Screen 2, Line 9
DO A1^PRSPUT1
+7 ; PTP worked less than Agreed Hours
+8 ;I POT<-5.00 D Q
+9 IF POT<0
Begin DoDot:1
+10 SET TEXT="Pay VA for negative balance"
+11 SET MEM(1)=TEXT_U_3
+12 SET TEXT="1. "_TEXT
+13 ; Screen 2, Line 10
DO A1^PRSPUT1
End DoDot:1
QUIT
+14 ;
+15 ; PTP worked more than Agreed Hours
+16 ; CO policy removed I POT>5.00 D Q
+17 IF POT>0
Begin DoDot:1
+18 SET TEXT="Pay Phy for positive balance"
+19 SET MEM(1)=TEXT_U_5
+20 SET TEXT="1. "_TEXT
+21 ; Screen 2, Line 10
DO A1^PRSPUT1
End DoDot:1
QUIT
+22 ;
+23 ; PTP worked Agreed Hours exactly
+24 IF POT=0
Begin DoDot:1
+25 SET TEXT="No reconciliation needed"
+26 SET MEM(1)=TEXT_U_1
+27 SET TEXT="1. "_TEXT
+28 ; Screen 2, Line 10
DO A1^PRSPUT1
End DoDot:1
QUIT
+29 ;
+30 ;***************************************************************
+31 ;PRS*4*93: BEGIN comment out carry over options--during testing
+32 ;policy was changed to not allow ptp to carry over hours within
+33 ;5% of agreement.
+34 ;***************************************************************
+35 ;; Within 5% of Agreed Hours
+36 ;; Check for next memorandum
+37 ;S OLDMIEN=MIEN
+38 ;S NMIEN=+$$MIEN^PRSPUT1(PRSIEN)
+39 ;S MIEN=OLDMIEN
+40 ;I 'NMIEN D
+41 ;. S TEXT="No current Memorandum on file. Transfer not possible."
+42 ;. D A1^PRSPUT1
+43 ;. S TEXT="If applicable, exit and enter a new memorandum first."
+44 ;. D A1^PRSPUT1
+45 ;;
+46 ;; Negative Balance Options
+47 ;I POT<0 D
+48 ;. S TEXT="Pay VA for negative balance"
+49 ;. S MEM(1)=TEXT_U_3
+50 ;. S TEXT="1. "_TEXT
+51 ;. D A1^PRSPUT1 ; Screen 2, Line 12
+52 ;I NMIEN,POT<0 D
+53 ;. S TEXT="Transfer negative balance"
+54 ;. S MEM(2)=TEXT_U_2
+55 ;. S TEXT="2. "_TEXT
+56 ;. D A1^PRSPUT1 ; Screen 2, Line 11
+57 ;;
+58 ;; Postive Balance Options
+59 ;I POT>0 D
+60 ;. S TEXT="Pay PT Phy for positive balance"
+61 ;. S MEM(1)=TEXT_U_5
+62 ;. S TEXT="1. "_TEXT
+63 ;. D A1^PRSPUT1 ; Screen 2, Line 12
+64 ;I NMIEN,POT>0 D
+65 ;. S TEXT="Transfer positive balance"
+66 ;. S MEM(2)=TEXT_U_4
+67 ;. S TEXT="2. "_TEXT
+68 ;. D A1^PRSPUT1 ; Screen 2, Line 11
+69 ;;finish the remainder of the form
+70 ;D A1^PRSPUT1 ; Blank Line
+71 ;S TEXT="Enter Reconciliation Option: _____"
+72 ;D A1^PRSPUT1
+73 ;D A1^PRSPUT1 ; Blank Line
+74 ;S $P(DASH,"_",55)="_"
+75 ;S TEXT="Reconciliation Comments: "_DASH
+76 ;D A1^PRSPUT1 ; Reconciliation Comments Line #1
+77 ;D A1^PRSPUT1 ; Blank Line
+78 ;S DASH="",$P(DASH,"_",80)="_"
+79 ;S TEXT=DASH
+80 ;D A1^PRSPUT1 ; Reconciliation Comments Line #2
+81 ;D A1^PRSPUT1 ; Blank Line
+82 ;S TEXT=DASH
+83 ;D A1^PRSPUT1 ; Reconciliation Comments Line #3
+84 ;D A1^PRSPUT1 ; Blank Line
+85 ;D A1^PRSPUT1 ; Reconciliation Comments Line #4
+86 ;S DASH="",$P(DASH,"_",41)="_"
+87 ;S TEXT="Signature: "_DASH
+88 ;S DASH="",$P(DASH,"_",20)="_"
+89 ;S TEXT=TEXT_" Date: "_DASH
+90 ;D A1^PRSPUT1
+91 ;**********************************
+92 ;END of comment out carry over options
+93 ;**********************************
+94 QUIT
+95 ;
ASK2 ; Prompt to e-mail or print.
+1 ;
+2 WRITE !!,"Would you like to use a (H)ard copy or (E)lectronic reconciliation form: "
+3 READ ASK2:DTIME
+4 SET ASK2=$$UPPER^PRSRUTL(ASK2)
+5 if ASK2="^"
QUIT
+6 IF "^H^E^"'[("^"_ASK2_"^")
Begin DoDot:1
+7 WRITE !!,"Enter H or E or ^ to Quit."
End DoDot:1
GOTO ASK2
+8 QUIT
+9 ;
ESIG ; Prompt for Electronic Signature and store fields in #458.7
+1 ;
+2 NEW ESOK
+3 DO ^PRSAES
+4 IF 'ESOK
KILL ^TMP($JOB,"PRSPBRP")
QUIT
+5 ;
DEV IF ASK2="H"
Begin DoDot:1
+1 KILL IOP,%ZIS
+2 SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
+3 WRITE !
+4 DO ^%ZIS
+5 KILL %ZIS,IOP
+6 ; Queued
IF $DATA(IO("Q"))
Begin DoDot:2
+7 SET ZTDESC="PRS PTP BEGIN RECONCILE PROC"
+8 SET ZTRTN="PRINT^PRSPBRP"
+9 SET ZTSAVE("^TMP($J,""PRSPBRP"",")=""
+10 DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Canceled!")
+11 KILL ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+12 DO HOME^%ZIS
End DoDot:2
QUIT
+13 USE IO
+14 DO PRINT
DO ^%ZISC
+15 KILL %ZIS,IOP
End DoDot:1
if POP
QUIT
+16 ; Update STATUS or memorandum
+17 SET MIEN=MIEN_","
SET PRSFDA(458.7,MIEN,5)=3
+18 DO UPDATE^DIE("","PRSFDA","MIEN")
DO MSG^DIALOG()
+19 WRITE !!,"Memorandum Status updated to: RECONCILIATION STARTED",!
+20 KILL ^TMP($JOB,"PRSPBRP")
+21 QUIT
+22 ;
PRINT ; Print the paper version of the Reconciliation form
+1 ;
+2 SET INDEX=""
+3 FOR
SET INDEX=$ORDER(^TMP($JOB,"PRSPBRP",INDEX))
if 'INDEX
QUIT
Begin DoDot:1
+4 SET TEXT=^TMP($JOB,"PRSPBRP",INDEX)
+5 WRITE !,TEXT
End DoDot:1
+6 KILL ^TMP($JOB),TEXT
+7 QUIT
+8 ;
KILL ; Clean up variables
+1 ;
+2 KILL AMT,ARRAY,ASK,ASK2,COHRS,D1,DASH,DATA,DATA0,DATA4,DAY,DIR,DIRUT
+3 KILL END,ENDSTA,INDEX,INDX,MEM,MIEN,NMIEN,NPHRS,OLDMIEN,OTHRS
+4 KILL POP,POT,PPI,PPCNT,PPREM,PRSAPGM,PRSIEN,PRSFDA,QUIT,RATE,SALARY
+5 KILL SCRTTL,SPAA,START,STATUS,TDAT,TDATE,WPHRS,ZTSAVE,X,Y
+6 KILL ^TMP($JOB,"PRSPBRP")
+7 QUIT
