PRSPEM ;WOIFO/MGD - PTP ENTER MEMORANDUM ;06/01/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 enter a Part Time Physician's
;Memorandum of Service Level Expectations. Memorandums will cover 364
;days (26 full Pay Periods) and the Agreed Hours must be equally
;divisible by 26.
;
Q
MAIN ; Main Driver
N DFN,STDAT,ENDAT,AHRS,ICOM,ESOK
; Prompt for Part Time Physician
D PTP
I PRSIEN'>0 D KILL Q
; Display Header info to validate the correct employee was chosen
D HDR
; Prompt and validate Start Date. Calculate and display End Date
S QUIT=0
F D Q:QUIT!('OVERLAP)
. S OVERLAP=0
. D START
. Q:QUIT
. D END
I QUIT D KILL Q
;
; Prompt and validate Agreed Hours
D AHRS
I Y'>0 D KILL Q
; Prompt for Initial Comments
D ICOM
I Y="^" D KILL Q
; Prompt for E-Sig and save if confirmed
D ESIG
Q
;
PTP ; Prompt for Part Time Physician
N SSN
W !
S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: "
D ^DIC K DIC
S PRSIEN=+Y
Q:PRSIEN<1
;
; determine associated NEW PERSON entry
S SSN=$$GET1^DIQ(450,PRSIEN_",",8,"I")
S IEN200=$S(SSN="":"",1:$O(^VA(200,"SSN",SSN,0)))
I 'IEN200 D
. W $C(7),!!,"Can't find an entry in the NEW PERSON file for this employee."
. W !,"They must be added as a user before the memorandum is created."
. S PRSIEN=-1
Q
;
HDR ; Display PTP info
S SCRTTL="Enter PT Physician Memoranda"
D HDR^PRSPUT1(PRSIEN,SCRTTL)
W !
Q
;
START ; Prompt for Start Date
; This subroutine prompts for the date then goes through several
; checks if any check fails we give an explanation message and
; reprompt for the date. If no checks fail we set valid to
; quit. The user must ^ or timeout to quit.
;
N VALID S VALID=0
F D Q:QUIT!(VALID)
. N Y,DIR,DIRUT S DIR(0)="458.7,1A0",DIR("A")="Start Date: " D ^DIR
.; Validate that the Start Date is the first day of a Pay Period.
. I $D(DIRUT) S QUIT=1 Q
. S D1=+Y
. D PP^PRSAPPU
. I DAY'=1 D Q
. . D SILMO^PRSLIB01(D1)
. . W !,"You entered ",$$EXTERNAL^DILFD(458.7,1,,D1)
. . W !!,"The Start Date must be the first day of a Pay Period."
. . W !,"Please re-enter.",!
. S STDAT=D1
.; Check to see if this employee's timecard for this PP is
.; in a status other than Timekeeper
. S PPI=$P($G(^PRST(458,"AD",D1)),U)
. I (D1<DT),($G(PPI)'>0) D Q
. . W !!,?3,"There is no pay period on file for that past date."
.;
.; for all past dates the employee must have a timecard in a
.; a status of 'T"
.;
. I (D1<DT),($P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T") D Q
.. W !!,?3,"To enter memos for past dates, the employee must have a"
.. W !,?3,"timecard in Timekeeper status."
.;
.; for future dates when there is a timecard we must also be in
.; timekeeper status
.;
. I (D1'<DT),($G(PPI)>0),$D(^PRST(458,PPI,"E",PRSIEN,0)),($P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T") D Q
. . W !!,?3,"This employee's timecard has a status other than "
. . W !,?3,"Timekeeper. It will have to be returned to the Timekeeper "
. . W !,?3,"before a memo covering this pay period can be entered."
.;
.; If we make it through all the checks set valid and QUIT only gets
.; set when we abort or timeout
. S VALID=1
Q
;
END ; Calculate and display End Date
N X1,X2,X,Y
S X1=D1,X2=363
D C^%DTC
S ENDDAT=X,Y=X
D DD^%DT
W !," End Date: ",Y
K D1
; Verify that there are no other Memorandums covering this same time
S IEN=""
F S IEN=$O(^PRST(458.7,"B",PRSIEN,IEN)) Q:IEN="" D Q:QUIT
. S DATA=$G(^PRST(458.7,IEN,0))
. Q:DATA=""
. S START=$P(DATA,U,2),END=$P(DATA,U,3),STATUS=$P(DATA,U,6)
. S TDAT=$P($G(^PRST(458.7,IEN,4)),U,1) ; Termination Date
. S END=$S(TDAT:TDAT,1:END)
. I STDAT'>START,ENDDAT'<START D OVRLAP
. I STDAT'>END,ENDDAT'<END D OVRLAP
; If all checks have passed, calculate the PPs covered by the Memo
I $G(PPE)?2N1"-"2N D CALPP
Q
;
OVRLAP ; Display warning when dates cover an existing memo
;
S Y=START ; START DATE
D DD^%DT
S START=Y
S Y=END ; END DATE
D DD^%DT
S END=Y
W !!,"These dates overlap the following memorandum:"
W !,"Start Date: ",START," - "
W $S(TDAT:"Termination Date: ",1:"End Date: "),END
S OVERLAP=1
Q
;
AHRS ; Display list of Agreed Hours
W !!,"Agreed Hours must be equally divisible by 26 Pay Periods."
W !!,"1/8 = 260, 1/4 = 520, 3/8 = 780, 1/2 = 1040, 5/8 = 1300, "
W "3/4 = 1560, 7/8 = 1820",!
S DIR(0)="NO",DIR("A")="Agreed Hours"
D ^DIR
; Verify that Agreed Hours is divisible by 26.
I Y#26 G AHRS
S AHRS=Y
Q
;
ICOM ; Prompt for Initial Comments
W !
S DIR(0)="FO^1:240^^O",DIR("A")="Initial Comments" D ^DIR
S ICOM=Y
Q
;
ESIG ; Prompt for Electronic Signature and store fields in #458.7
;
N ESOK,HOL
K PRSFDA,IEN4587
D ^PRSAES
I ESOK D
. ; Create entry in #458.7
. S PRSFDA(458.7,"+1,",.01)=PRSIEN ; EMPLOYEE
. D UPDATE^DIE("","PRSFDA","IEN4587"),MSG^DIALOG()
. S IEN4587=IEN4587(1)_","
. S PRSFDA(458.7,IEN4587,1)=STDAT ; START DATE
. S PRSFDA(458.7,IEN4587,2)=ENDDAT ; END DATE
. S PRSFDA(458.7,IEN4587,3)=AHRS ; AGREED HOURS
. S PRSFDA(458.7,IEN4587,4)=ICOM ; INITIAL COMMENTS
. ;
. ; Check to see if 1st pay period covered by memo is opened
. ; 1 = NOT STARTED 2 = ACTIVE
. S PRSFDA(458.7,IEN4587,5)=$S($D(^PRST(458,"AD",STDAT)):2,1:1)
. S PRSFDA(458.7,IEN4587,6)=DUZ ; ENTERED BY
. D NOW^%DTC
. S PRSFDA(458.7,IEN4587,7)=% ; DATE/TIME ENTERED
. D FILE^DIE("","PRSFDA",),MSG^DIALOG() ; Set fields into 0 node
. ;
. ; Initialize the PPs within the Memo (#458.701 multiple)
. F I=1:1:26 D
. . S PRSFDA(458.701,"+"_I_","_IEN4587,.01)=$P(PPESTR,U,I)
. D UPDATE^DIE("","PRSFDA"),MSG^DIALOG()
. ;
. ; Allocate the security key to the PTP if they don't already hold it
. I '$D(^XUSEC("PRSP EMP",IEN200)) D
. . N KEYIEN
. . S KEYIEN=$$FIND1^DIC(19.1,,"X","PRSP EMP")
. . I 'KEYIEN D Q
. . . W !!,"PRSP EMP key was not found in the 19.1 file."
. . S PRSFDA(200.051,"?+1,"_IEN200_",",.01)=KEYIEN
. . S PRSIENS(1)=KEYIEN
. . D UPDATE^DIE("","PRSFDA","PRSIENS"),MSG^DIALOG()
;
; Check to see if PPs covered by the memo are already opened
Q:'$$MIEN^PRSPUT1(PRSIEN,STDAT)
S PPI=+$G(^PRST(458,"AD",STDAT))
Q:'PPI
; Loop thru pay periods in file 458
S PPI=PPI-.001 ; init PPI so loop will include 1st PP covered by memo
F S PPI=$O(^PRST(458,PPI)) Q:'PPI D
. N PRSD
. ; Quit if the employee doesn't have a timecard for this PP yet.
. ; When the Timekeeper creates the timecard it will update the ESR as
. ; needed
. Q:'$D(^PRST(458,PPI,"E",PRSIEN,0))
. ; Quit if timecard does not have status = Timekeeper
. Q:$P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T"
. ;
. ; clear any Timecard exceptions, remarks, and posting status
. F PRSD=1:1:14 K ^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2),^(3),^(10)
. ; Call to initialize ESR
. D ^PRSAPPH ; Set up HOL and PDT
. D ESRUPDT^PRSPUT3(PPI,PRSIEN)
. ; Call to Autopost PT Phy Leave
. D PLPP^PRSPLVA(PRSIEN,PPI)
. ; Call to Autopost PT Phy Extended Absence
. D PEAPP^PRSPEAA(PRSIEN,PPI)
;
Q
;
CALPP ; Calculate the PPs covered by the memorandum
S PPESTR=""
S (STDATX,D1)=STDAT
D PP^PRSAPPU
S PPESTR=PPESTR_PPE_U
F I=1:1:25 D
. S X1=STDATX,X2=14
. D C^%DTC
. S (D1,STDATX)=X
. D PP^PRSAPPU
. S PPESTR=PPESTR_PPE_$S(I=25:"",1:"^")
Q
;
KILL ; Clean up variables
;
K AHRS,DATA,DAY,DIR,END,ENDDAT,I,ICOM,IEN,IEN200,IEN4587,OVERLAP
K PPE,PPI,PPESTR,PRSFDA,PRSIEN,PRSIENS,QUIT,SCRTTL,START,STATUS
K STDAT,STDATX,TDAT,X,Y,%,%DT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPEM 7715 printed Apr 09, 2024@21:28:29 Page 2
PRSPEM ;WOIFO/MGD - PTP ENTER MEMORANDUM ;06/01/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 enter a Part Time Physician's
+5 ;Memorandum of Service Level Expectations. Memorandums will cover 364
+6 ;days (26 full Pay Periods) and the Agreed Hours must be equally
+7 ;divisible by 26.
+8 ;
+9 QUIT
MAIN ; Main Driver
+1 NEW DFN,STDAT,ENDAT,AHRS,ICOM,ESOK
+2 ; Prompt for Part Time Physician
+3 DO PTP
+4 IF PRSIEN'>0
DO KILL
QUIT
+5 ; Display Header info to validate the correct employee was chosen
+6 DO HDR
+7 ; Prompt and validate Start Date. Calculate and display End Date
+8 SET QUIT=0
+9 FOR
Begin DoDot:1
+10 SET OVERLAP=0
+11 DO START
+12 if QUIT
QUIT
+13 DO END
End DoDot:1
if QUIT!('OVERLAP)
QUIT
+14 IF QUIT
DO KILL
QUIT
+15 ;
+16 ; Prompt and validate Agreed Hours
+17 DO AHRS
+18 IF Y'>0
DO KILL
QUIT
+19 ; Prompt for Initial Comments
+20 DO ICOM
+21 IF Y="^"
DO KILL
QUIT
+22 ; Prompt for E-Sig and save if confirmed
+23 DO ESIG
+24 QUIT
+25 ;
PTP ; Prompt for Part Time Physician
+1 NEW SSN
+2 WRITE !
+3 SET DIC="^PRSPC("
SET DIC(0)="AEMQZ"
SET DIC("A")="Select EMPLOYEE: "
+4 DO ^DIC
KILL DIC
+5 SET PRSIEN=+Y
+6 if PRSIEN<1
QUIT
+7 ;
+8 ; determine associated NEW PERSON entry
+9 SET SSN=$$GET1^DIQ(450,PRSIEN_",",8,"I")
+10 SET IEN200=$SELECT(SSN="":"",1:$ORDER(^VA(200,"SSN",SSN,0)))
+11 IF 'IEN200
Begin DoDot:1
+12 WRITE $CHAR(7),!!,"Can't find an entry in the NEW PERSON file for this employee."
+13 WRITE !,"They must be added as a user before the memorandum is created."
+14 SET PRSIEN=-1
End DoDot:1
+15 QUIT
+16 ;
HDR ; Display PTP info
+1 SET SCRTTL="Enter PT Physician Memoranda"
+2 DO HDR^PRSPUT1(PRSIEN,SCRTTL)
+3 WRITE !
+4 QUIT
+5 ;
START ; Prompt for Start Date
+1 ; This subroutine prompts for the date then goes through several
+2 ; checks if any check fails we give an explanation message and
+3 ; reprompt for the date. If no checks fail we set valid to
+4 ; quit. The user must ^ or timeout to quit.
+5 ;
+6 NEW VALID
SET VALID=0
+7 FOR
Begin DoDot:1
+8 NEW Y,DIR,DIRUT
SET DIR(0)="458.7,1A0"
SET DIR("A")="Start Date: "
DO ^DIR
+9 ; Validate that the Start Date is the first day of a Pay Period.
+10 IF $DATA(DIRUT)
SET QUIT=1
QUIT
+11 SET D1=+Y
+12 DO PP^PRSAPPU
+13 IF DAY'=1
Begin DoDot:2
+14 DO SILMO^PRSLIB01(D1)
+15 WRITE !,"You entered ",$$EXTERNAL^DILFD(458.7,1,,D1)
+16 WRITE !!,"The Start Date must be the first day of a Pay Period."
+17 WRITE !,"Please re-enter.",!
End DoDot:2
QUIT
+18 SET STDAT=D1
+19 ; Check to see if this employee's timecard for this PP is
+20 ; in a status other than Timekeeper
+21 SET PPI=$PIECE($GET(^PRST(458,"AD",D1)),U)
+22 IF (D1<DT)
IF ($GET(PPI)'>0)
Begin DoDot:2
+23 WRITE !!,?3,"There is no pay period on file for that past date."
End DoDot:2
QUIT
+24 ;
+25 ; for all past dates the employee must have a timecard in a
+26 ; a status of 'T"
+27 ;
+28 IF (D1<DT)
IF ($PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T")
Begin DoDot:2
+29 WRITE !!,?3,"To enter memos for past dates, the employee must have a"
+30 WRITE !,?3,"timecard in Timekeeper status."
End DoDot:2
QUIT
+31 ;
+32 ; for future dates when there is a timecard we must also be in
+33 ; timekeeper status
+34 ;
+35 IF (D1'<DT)
IF ($GET(PPI)>0)
IF $DATA(^PRST(458,PPI,"E",PRSIEN,0))
IF ($PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T")
Begin DoDot:2
+36 WRITE !!,?3,"This employee's timecard has a status other than "
+37 WRITE !,?3,"Timekeeper. It will have to be returned to the Timekeeper "
+38 WRITE !,?3,"before a memo covering this pay period can be entered."
End DoDot:2
QUIT
+39 ;
+40 ; If we make it through all the checks set valid and QUIT only gets
+41 ; set when we abort or timeout
+42 SET VALID=1
End DoDot:1
if QUIT!(VALID)
QUIT
+43 QUIT
+44 ;
END ; Calculate and display End Date
+1 NEW X1,X2,X,Y
+2 SET X1=D1
SET X2=363
+3 DO C^%DTC
+4 SET ENDDAT=X
SET Y=X
+5 DO DD^%DT
+6 WRITE !," End Date: ",Y
+7 KILL D1
+8 ; Verify that there are no other Memorandums covering this same time
+9 SET IEN=""
+10 FOR
SET IEN=$ORDER(^PRST(458.7,"B",PRSIEN,IEN))
if IEN=""
QUIT
Begin DoDot:1
+11 SET DATA=$GET(^PRST(458.7,IEN,0))
+12 if DATA=""
QUIT
+13 SET START=$PIECE(DATA,U,2)
SET END=$PIECE(DATA,U,3)
SET STATUS=$PIECE(DATA,U,6)
+14 ; Termination Date
SET TDAT=$PIECE($GET(^PRST(458.7,IEN,4)),U,1)
+15 SET END=$SELECT(TDAT:TDAT,1:END)
+16 IF STDAT'>START
IF ENDDAT'<START
DO OVRLAP
+17 IF STDAT'>END
IF ENDDAT'<END
DO OVRLAP
End DoDot:1
if QUIT
QUIT
+18 ; If all checks have passed, calculate the PPs covered by the Memo
+19 IF $GET(PPE)?2N1"-"2N
DO CALPP
+20 QUIT
+21 ;
OVRLAP ; Display warning when dates cover an existing memo
+1 ;
+2 ; START DATE
SET Y=START
+3 DO DD^%DT
+4 SET START=Y
+5 ; END DATE
SET Y=END
+6 DO DD^%DT
+7 SET END=Y
+8 WRITE !!,"These dates overlap the following memorandum:"
+9 WRITE !,"Start Date: ",START," - "
+10 WRITE $SELECT(TDAT:"Termination Date: ",1:"End Date: "),END
+11 SET OVERLAP=1
+12 QUIT
+13 ;
AHRS ; Display list of Agreed Hours
+1 WRITE !!,"Agreed Hours must be equally divisible by 26 Pay Periods."
+2 WRITE !!,"1/8 = 260, 1/4 = 520, 3/8 = 780, 1/2 = 1040, 5/8 = 1300, "
+3 WRITE "3/4 = 1560, 7/8 = 1820",!
+4 SET DIR(0)="NO"
SET DIR("A")="Agreed Hours"
+5 DO ^DIR
+6 ; Verify that Agreed Hours is divisible by 26.
+7 IF Y#26
GOTO AHRS
+8 SET AHRS=Y
+9 QUIT
+10 ;
ICOM ; Prompt for Initial Comments
+1 WRITE !
+2 SET DIR(0)="FO^1:240^^O"
SET DIR("A")="Initial Comments"
DO ^DIR
+3 SET ICOM=Y
+4 QUIT
+5 ;
ESIG ; Prompt for Electronic Signature and store fields in #458.7
+1 ;
+2 NEW ESOK,HOL
+3 KILL PRSFDA,IEN4587
+4 DO ^PRSAES
+5 IF ESOK
Begin DoDot:1
+6 ; Create entry in #458.7
+7 ; EMPLOYEE
SET PRSFDA(458.7,"+1,",.01)=PRSIEN
+8 DO UPDATE^DIE("","PRSFDA","IEN4587")
DO MSG^DIALOG()
+9 SET IEN4587=IEN4587(1)_","
+10 ; START DATE
SET PRSFDA(458.7,IEN4587,1)=STDAT
+11 ; END DATE
SET PRSFDA(458.7,IEN4587,2)=ENDDAT
+12 ; AGREED HOURS
SET PRSFDA(458.7,IEN4587,3)=AHRS
+13 ; INITIAL COMMENTS
SET PRSFDA(458.7,IEN4587,4)=ICOM
+14 ;
+15 ; Check to see if 1st pay period covered by memo is opened
+16 ; 1 = NOT STARTED 2 = ACTIVE
+17 SET PRSFDA(458.7,IEN4587,5)=$SELECT($DATA(^PRST(458,"AD",STDAT)):2,1:1)
+18 ; ENTERED BY
SET PRSFDA(458.7,IEN4587,6)=DUZ
+19 DO NOW^%DTC
+20 ; DATE/TIME ENTERED
SET PRSFDA(458.7,IEN4587,7)=%
+21 ; Set fields into 0 node
DO FILE^DIE("","PRSFDA",)
DO MSG^DIALOG()
+22 ;
+23 ; Initialize the PPs within the Memo (#458.701 multiple)
+24 FOR I=1:1:26
Begin DoDot:2
+25 SET PRSFDA(458.701,"+"_I_","_IEN4587,.01)=$PIECE(PPESTR,U,I)
End DoDot:2
+26 DO UPDATE^DIE("","PRSFDA")
DO MSG^DIALOG()
+27 ;
+28 ; Allocate the security key to the PTP if they don't already hold it
+29 IF '$DATA(^XUSEC("PRSP EMP",IEN200))
Begin DoDot:2
+30 NEW KEYIEN
+31 SET KEYIEN=$$FIND1^DIC(19.1,,"X","PRSP EMP")
+32 IF 'KEYIEN
Begin DoDot:3
+33 WRITE !!,"PRSP EMP key was not found in the 19.1 file."
End DoDot:3
QUIT
+34 SET PRSFDA(200.051,"?+1,"_IEN200_",",.01)=KEYIEN
+35 SET PRSIENS(1)=KEYIEN
+36 DO UPDATE^DIE("","PRSFDA","PRSIENS")
DO MSG^DIALOG()
End DoDot:2
End DoDot:1
+37 ;
+38 ; Check to see if PPs covered by the memo are already opened
+39 if '$$MIEN^PRSPUT1(PRSIEN,STDAT)
QUIT
+40 SET PPI=+$GET(^PRST(458,"AD",STDAT))
+41 if 'PPI
QUIT
+42 ; Loop thru pay periods in file 458
+43 ; init PPI so loop will include 1st PP covered by memo
SET PPI=PPI-.001
+44 FOR
SET PPI=$ORDER(^PRST(458,PPI))
if 'PPI
QUIT
Begin DoDot:1
+45 NEW PRSD
+46 ; Quit if the employee doesn't have a timecard for this PP yet.
+47 ; When the Timekeeper creates the timecard it will update the ESR as
+48 ; needed
+49 if '$DATA(^PRST(458,PPI,"E",PRSIEN,0))
QUIT
+50 ; Quit if timecard does not have status = Timekeeper
+51 if $PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),U,2)'="T"
QUIT
+52 ;
+53 ; clear any Timecard exceptions, remarks, and posting status
+54 FOR PRSD=1:1:14
KILL ^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2),^(3),^(10)
+55 ; Call to initialize ESR
+56 ; Set up HOL and PDT
DO ^PRSAPPH
+57 DO ESRUPDT^PRSPUT3(PPI,PRSIEN)
+58 ; Call to Autopost PT Phy Leave
+59 DO PLPP^PRSPLVA(PRSIEN,PPI)
+60 ; Call to Autopost PT Phy Extended Absence
+61 DO PEAPP^PRSPEAA(PRSIEN,PPI)
End DoDot:1
+62 ;
+63 QUIT
+64 ;
CALPP ; Calculate the PPs covered by the memorandum
+1 SET PPESTR=""
+2 SET (STDATX,D1)=STDAT
+3 DO PP^PRSAPPU
+4 SET PPESTR=PPESTR_PPE_U
+5 FOR I=1:1:25
Begin DoDot:1
+6 SET X1=STDATX
SET X2=14
+7 DO C^%DTC
+8 SET (D1,STDATX)=X
+9 DO PP^PRSAPPU
+10 SET PPESTR=PPESTR_PPE_$SELECT(I=25:"",1:"^")
End DoDot:1
+11 QUIT
+12 ;
KILL ; Clean up variables
+1 ;
+2 KILL AHRS,DATA,DAY,DIR,END,ENDDAT,I,ICOM,IEN,IEN200,IEN4587,OVERLAP
+3 KILL PPE,PPI,PPESTR,PRSFDA,PRSIEN,PRSIENS,QUIT,SCRTTL,START,STATUS
+4 KILL STDAT,STDATX,TDAT,X,Y,%,%DT
+5 QUIT
