PRSPSAP1 ;WOIFO/JAH - part time physician, supervisory approvals ;10/22/04
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
HDRESR(PRSIEN,PPI,LINES) ; Display a Supervisor Header
; PRSIEN - users 450 number
; PPI - what pay period
N CO,NM,SSN,TL,PPE,PPTXT,INCD
Q:(PRSIEN'>0)
S C0=^PRSPC(PRSIEN,0)
S NM=$P(C0,U,1)
S SSN=$P(C0,U,9),SSN="XXX-XX-"_$E(SSN,6,9)
S TL=$P(C0,"^",8),TL="T&L: "_TL
I $G(PPI)>0 S PPE=$P($G(^PRST(458,PPI,0)),U)
I $G(PPE)="" S PPE="?????"
S PPTXT="Pay Per: "_PPE
S INCD=$$INCESRS^PRSPESR3(PRSIEN,PPI)
S INCD="Incomplete Days: "_INCD
W @IOF," VA TIME & ATTENDANCE SYSTEM"
W !,PPTXT,?20,"Supervisory Review for Part Time Physicians in "_TL
W !,$E(NM,1,30),?32,SSN,?56,INCD
W ! D COLHDRS
W ! F I=1:1:(IOM-1) W "-"
S LINES=7
Q
COLHDRS ; JUST THE COLUMN HEADERS
W !,"Item",?8,"Date",?17,"Scheduled Tour",?36,"Work/Leave Posted"
W ?61,"Hours",?67,"Meal",?73,"Status"
Q
PUSH(PPI,PRSIEN,PRSD,CNT) ; ADD record to approval list
; set up a xref on the day. This enables quick access to the
; day number when the pick list has 4 items spread over the
; pay period. (e.g. the first item is day 4, the 2nd item
; is day 12, etc.)
;
N NM
; Set up name x-ref for alphabetical review
S NM=$P($G(^PRSPC(PRSIEN,0)),U)
S ^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,0)=""
S ^TMP($J,"PRSPSAP","B",NM,PRSIEN)=""
S ^TMP($J,"PRSPSAP",PRSIEN,PPI,"B",CNT)=PRSD
Q
GETESR(ESR,PPI,PRSIEN,PRSD) ; GET ESR RELATED DATA
; RETURN DATA IN ESR ARRAY BY REFERENCE
;
N PRSN1,TOD,LSGN,METHOD,PRSN4
S PRSN1=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,1)) ; tour segmts node
S PRSN4=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,4)) ; 2ND tour segmts node
S TOD=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,2)
S ESR("TOD")=TOD
S ESR("TODEXT")=$$GETTOUR^PRSPESR3(PRSIEN,PRSD,TOD,PRSN1,PRSN4)
S ESR("TOD2")=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,13)
S ESR("WORK")=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,5))
I $P(ESR("WORK"),U)="" D
.; get ESR DAY LAST SIGN METHOD
. S LSGN=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,7)),U,3)
. I LSGN'>0 S LSGN=1
. S METHOD=$$EXTERNAL^DILFD(458.02,149,"",LSGN,)
. S ESR("WORK")="No work:signed-"_METHOD
S ESR("RMK")=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,6)),U)
S ESR("ML")=$P($G(^PRST(457.1,TOD,0)),U,3)
; esr status must be SIGNED initially to appear in this option
S ESR("STAT")=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,7)),"^",1)
Q
;
ASALIST(OUT) ; ADD record to approval list
;
N PRSIEN,PPI,PRSD,MOVEON,OUT,ACT,ESRDTS,NM
;
; MOVEON : flag to indicate superV is done with this PTP's pp ESR.
;
S OUT=0
S (ACT,NM)=""
F S NM=$O(^TMP($J,"PRSPSAP","B",NM)) Q:NM=""!OUT D
. S PRSIEN=$O(^TMP($J,"PRSPSAP","B",NM,0))
. I PRSIEN'>0 S OUT=1 Q
. S PPI=0
. F S PPI=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI)) Q:PPI'>0!OUT D
..;
..; REWORK THIS EMPLOYEE UNTIL WE'RE DONE
..;
.. S MOVEON=0
.. F D Q:MOVEON
... D DISPLAY^PRSPSAPU(PRSIEN,PPI)
... D ESRDTS^PRSPSAPU(.ESRDTS,PRSIEN,PPI)
... S ACT=$$GETACT^PRSPSAP(.ESRDTS,PRSIEN,PPI)
...; if user hit return and all days are marked w/status then moveon
... I ACT="" S MOVEON=$$MOVEON(PRSIEN,PPI) Q
...; did user type a caret to abort?
... I ACT=0 S (OUT,MOVEON)=1 Q
...; either mark a single day or mark remaining unmarked
...; days depending on ACT
... ; ^ at second prompt should redisplay esr period
... Q:ACT<0
...; mark the action on the day
... D MARK^PRSPSAP3(ACT,PRSIEN,PPI)
Q
HDROPT ; MAIN OPTION HEADING
W:$E(IOST,1,2)="C-" @IOF
N TAB,TITLE
S TITLE="SUPERVISOR'S APPROVAL FOR PT PHYSICIAN'S ELECTRONIC SUBSIDIARY RECORDS"
S TAB=IOM-$L(TITLE)/2
W !?26,"VA TIME & ATTENDANCE SYSTEM",!?TAB,TITLE
Q
ANYACT(ACTCNT) ; RETURN NUMBER OF ESR DAILY ACTIONS TO UPDATE
; THIS IS A COUNT OF ALL THE RESUBMITS AND APPROVES
;
N PRSIEN,PPI,PRSD,ACT
S (ACTCNT,ACTCNT("R"),ACTCNT("A"),ACTCNT("B"),ACTCNT("N"))=0
S PRSIEN=0
F S PRSIEN=$O(^TMP($J,"PRSPSAP",PRSIEN)) Q:PRSIEN'>0 D
. S PPI=0
. F S PPI=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI)) Q:PPI'>0 D
.. S PRSD=0
.. F S PRSD=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD)) Q:PRSD'>0 D
... S ACT=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,1))
... I ACT="A" S ACTCNT=ACTCNT+1,ACTCNT("A")=ACTCNT("A")+1 Q
... I ACT="R" S ACTCNT=ACTCNT+1,ACTCNT("R")=ACTCNT("R")+1 Q
... I ACT="B" S ACTCNT("B")=ACTCNT("B")+1 Q
... S ACTCNT("N")=ACTCNT("N")+1
Q
MARKCNT(MC,PRSIEN,PPI) ; return items marked AND total items in MC array
; MC = items marked with any status
; MC(1) = available items to mark count
;
N ACT,PRSD
S (MC,MC(1))=0
Q:(PRSIEN'>0)!(PPI'>0)
S PRSD=0
F S PRSD=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD)) Q:PRSD'>0 D
. S ACT=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,1))
. ; increment the counter for days marked by the supervisor already
. I "^A^B^R^"[(U_ACT_U) S MC(1)=MC(1)+1
. S MC=MC+1
Q
;
MOVEON(PRSIEN,PPI) ; return users choice (MOVE ON OR REDISPLAY CURR PTP)
; return 0 for abort
; if the number of days available for approval matches the number
; of days that have some status marked then we will not ask the
; user whether they want to move on or not.
;
N CT,MOVEON
S MOVEON=1
D MARKCNT^PRSPSAP1(.CT,PRSIEN,PPI)
Q:$G(CT)=$G(CT(1)) MOVEON
N DIR,DIRUT
S MOVEON=0
S DIR(0)="Y"
S DIR("?")="Enter NO to continue editing this part-time physician."
S DIR("?",1)="Not all days are marked with a status. Answer YES to"
S DIR("?",2)="ignore these days and move past this part-time physician."
S DIR("A")="Are you done with this employee"
D ^DIR
S MOVEON=$G(Y)
I $G(DIRUT) S MOVEON=1
Q MOVEON
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPSAP1 5792 printed Dec 13, 2024@02:28:13 Page 2
PRSPSAP1 ;WOIFO/JAH - part time physician, supervisory approvals ;10/22/04
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
HDRESR(PRSIEN,PPI,LINES) ; Display a Supervisor Header
+1 ; PRSIEN - users 450 number
+2 ; PPI - what pay period
+3 NEW CO,NM,SSN,TL,PPE,PPTXT,INCD
+4 if (PRSIEN'>0)
QUIT
+5 SET C0=^PRSPC(PRSIEN,0)
+6 SET NM=$PIECE(C0,U,1)
+7 SET SSN=$PIECE(C0,U,9)
SET SSN="XXX-XX-"_$EXTRACT(SSN,6,9)
+8 SET TL=$PIECE(C0,"^",8)
SET TL="T&L: "_TL
+9 IF $GET(PPI)>0
SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U)
+10 IF $GET(PPE)=""
SET PPE="?????"
+11 SET PPTXT="Pay Per: "_PPE
+12 SET INCD=$$INCESRS^PRSPESR3(PRSIEN,PPI)
+13 SET INCD="Incomplete Days: "_INCD
+14 WRITE @IOF," VA TIME & ATTENDANCE SYSTEM"
+15 WRITE !,PPTXT,?20,"Supervisory Review for Part Time Physicians in "_TL
+16 WRITE !,$EXTRACT(NM,1,30),?32,SSN,?56,INCD
+17 WRITE !
DO COLHDRS
+18 WRITE !
FOR I=1:1:(IOM-1)
WRITE "-"
+19 SET LINES=7
+20 QUIT
COLHDRS ; JUST THE COLUMN HEADERS
+1 WRITE !,"Item",?8,"Date",?17,"Scheduled Tour",?36,"Work/Leave Posted"
+2 WRITE ?61,"Hours",?67,"Meal",?73,"Status"
+3 QUIT
PUSH(PPI,PRSIEN,PRSD,CNT) ; ADD record to approval list
+1 ; set up a xref on the day. This enables quick access to the
+2 ; day number when the pick list has 4 items spread over the
+3 ; pay period. (e.g. the first item is day 4, the 2nd item
+4 ; is day 12, etc.)
+5 ;
+6 NEW NM
+7 ; Set up name x-ref for alphabetical review
+8 SET NM=$PIECE($GET(^PRSPC(PRSIEN,0)),U)
+9 SET ^TMP($JOB,"PRSPSAP",PRSIEN,PPI,PRSD,0)=""
+10 SET ^TMP($JOB,"PRSPSAP","B",NM,PRSIEN)=""
+11 SET ^TMP($JOB,"PRSPSAP",PRSIEN,PPI,"B",CNT)=PRSD
+12 QUIT
GETESR(ESR,PPI,PRSIEN,PRSD) ; GET ESR RELATED DATA
+1 ; RETURN DATA IN ESR ARRAY BY REFERENCE
+2 ;
+3 NEW PRSN1,TOD,LSGN,METHOD,PRSN4
+4 ; tour segmts node
SET PRSN1=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,1))
+5 ; 2ND tour segmts node
SET PRSN4=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,4))
+6 SET TOD=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,2)
+7 SET ESR("TOD")=TOD
+8 SET ESR("TODEXT")=$$GETTOUR^PRSPESR3(PRSIEN,PRSD,TOD,PRSN1,PRSN4)
+9 SET ESR("TOD2")=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,13)
+10 SET ESR("WORK")=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,5))
+11 IF $PIECE(ESR("WORK"),U)=""
Begin DoDot:1
+12 ; get ESR DAY LAST SIGN METHOD
+13 SET LSGN=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,7)),U,3)
+14 IF LSGN'>0
SET LSGN=1
+15 SET METHOD=$$EXTERNAL^DILFD(458.02,149,"",LSGN,)
+16 SET ESR("WORK")="No work:signed-"_METHOD
End DoDot:1
+17 SET ESR("RMK")=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,6)),U)
+18 SET ESR("ML")=$PIECE($GET(^PRST(457.1,TOD,0)),U,3)
+19 ; esr status must be SIGNED initially to appear in this option
+20 SET ESR("STAT")=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,7)),"^",1)
+21 QUIT
+22 ;
ASALIST(OUT) ; ADD record to approval list
+1 ;
+2 NEW PRSIEN,PPI,PRSD,MOVEON,OUT,ACT,ESRDTS,NM
+3 ;
+4 ; MOVEON : flag to indicate superV is done with this PTP's pp ESR.
+5 ;
+6 SET OUT=0
+7 SET (ACT,NM)=""
+8 FOR
SET NM=$ORDER(^TMP($JOB,"PRSPSAP","B",NM))
if NM=""!OUT
QUIT
Begin DoDot:1
+9 SET PRSIEN=$ORDER(^TMP($JOB,"PRSPSAP","B",NM,0))
+10 IF PRSIEN'>0
SET OUT=1
QUIT
+11 SET PPI=0
+12 FOR
SET PPI=$ORDER(^TMP($JOB,"PRSPSAP",PRSIEN,PPI))
if PPI'>0!OUT
QUIT
Begin DoDot:2
+13 ;
+14 ; REWORK THIS EMPLOYEE UNTIL WE'RE DONE
+15 ;
+16 SET MOVEON=0
+17 FOR
Begin DoDot:3
+18 DO DISPLAY^PRSPSAPU(PRSIEN,PPI)
+19 DO ESRDTS^PRSPSAPU(.ESRDTS,PRSIEN,PPI)
+20 SET ACT=$$GETACT^PRSPSAP(.ESRDTS,PRSIEN,PPI)
+21 ; if user hit return and all days are marked w/status then moveon
+22 IF ACT=""
SET MOVEON=$$MOVEON(PRSIEN,PPI)
QUIT
+23 ; did user type a caret to abort?
+24 IF ACT=0
SET (OUT,MOVEON)=1
QUIT
+25 ; either mark a single day or mark remaining unmarked
+26 ; days depending on ACT
+27 ; ^ at second prompt should redisplay esr period
+28 if ACT<0
QUIT
+29 ; mark the action on the day
+30 DO MARK^PRSPSAP3(ACT,PRSIEN,PPI)
End DoDot:3
if MOVEON
QUIT
End DoDot:2
End DoDot:1
+31 QUIT
HDROPT ; MAIN OPTION HEADING
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 NEW TAB,TITLE
+3 SET TITLE="SUPERVISOR'S APPROVAL FOR PT PHYSICIAN'S ELECTRONIC SUBSIDIARY RECORDS"
+4 SET TAB=IOM-$LENGTH(TITLE)/2
+5 WRITE !?26,"VA TIME & ATTENDANCE SYSTEM",!?TAB,TITLE
+6 QUIT
ANYACT(ACTCNT) ; RETURN NUMBER OF ESR DAILY ACTIONS TO UPDATE
+1 ; THIS IS A COUNT OF ALL THE RESUBMITS AND APPROVES
+2 ;
+3 NEW PRSIEN,PPI,PRSD,ACT
+4 SET (ACTCNT,ACTCNT("R"),ACTCNT("A"),ACTCNT("B"),ACTCNT("N"))=0
+5 SET PRSIEN=0
+6 FOR
SET PRSIEN=$ORDER(^TMP($JOB,"PRSPSAP",PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:1
+7 SET PPI=0
+8 FOR
SET PPI=$ORDER(^TMP($JOB,"PRSPSAP",PRSIEN,PPI))
if PPI'>0
QUIT
Begin DoDot:2
+9 SET PRSD=0
+10 FOR
SET PRSD=$ORDER(^TMP($JOB,"PRSPSAP",PRSIEN,PPI,PRSD))
if PRSD'>0
QUIT
Begin DoDot:3
+11 SET ACT=$GET(^TMP($JOB,"PRSPSAP",PRSIEN,PPI,PRSD,1))
+12 IF ACT="A"
SET ACTCNT=ACTCNT+1
SET ACTCNT("A")=ACTCNT("A")+1
QUIT
+13 IF ACT="R"
SET ACTCNT=ACTCNT+1
SET ACTCNT("R")=ACTCNT("R")+1
QUIT
+14 IF ACT="B"
SET ACTCNT("B")=ACTCNT("B")+1
QUIT
+15 SET ACTCNT("N")=ACTCNT("N")+1
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
MARKCNT(MC,PRSIEN,PPI) ; return items marked AND total items in MC array
+1 ; MC = items marked with any status
+2 ; MC(1) = available items to mark count
+3 ;
+4 NEW ACT,PRSD
+5 SET (MC,MC(1))=0
+6 if (PRSIEN'>0)!(PPI'>0)
QUIT
+7 SET PRSD=0
+8 FOR
SET PRSD=$ORDER(^TMP($JOB,"PRSPSAP",PRSIEN,PPI,PRSD))
if PRSD'>0
QUIT
Begin DoDot:1
+9 SET ACT=$GET(^TMP($JOB,"PRSPSAP",PRSIEN,PPI,PRSD,1))
+10 ; increment the counter for days marked by the supervisor already
+11 IF "^A^B^R^"[(U_ACT_U)
SET MC(1)=MC(1)+1
+12 SET MC=MC+1
End DoDot:1
+13 QUIT
+14 ;
MOVEON(PRSIEN,PPI) ; return users choice (MOVE ON OR REDISPLAY CURR PTP)
+1 ; return 0 for abort
+2 ; if the number of days available for approval matches the number
+3 ; of days that have some status marked then we will not ask the
+4 ; user whether they want to move on or not.
+5 ;
+6 NEW CT,MOVEON
+7 SET MOVEON=1
+8 DO MARKCNT^PRSPSAP1(.CT,PRSIEN,PPI)
+9 if $GET(CT)=$GET(CT(1))
QUIT MOVEON
+10 NEW DIR,DIRUT
+11 SET MOVEON=0
+12 SET DIR(0)="Y"
+13 SET DIR("?")="Enter NO to continue editing this part-time physician."
+14 SET DIR("?",1)="Not all days are marked with a status. Answer YES to"
+15 SET DIR("?",2)="ignore these days and move past this part-time physician."
+16 SET DIR("A")="Are you done with this employee"
+17 DO ^DIR
+18 SET MOVEON=$GET(Y)
+19 IF $GET(DIRUT)
SET MOVEON=1
+20 QUIT MOVEON
