PRSPSAP ;WOIFO/JAH - part time physician, supervisory approvals ;10/22/04
;;4.0;PAID;**93,151**;Sep 21, 1995;Build 2
;Per VA Directive 6402, this routine should not be modified
Q
; T&A supervisor of PTP employee is required to review and take
; one of the following actions on each signed day of the PTP's ESR:
; 1. approve, 2. request resubmission or 3. bypass.
; When the T&A Supervisor approves a signed day we attempt to
; update the PTP's timecard for that day. Updates to the
; timecard will be screened based on the status of the timecard
; and the effect of any potential update.
;
; MAIN entry point called from option Approve Signed ESRs.
;
MAIN ;
K ^TMP($J,"PRSPSAP")
N PRSTLV,TLI,TLE,PRSIEN,ANYACT,AVAIL,OUT,DCNT,APRWHO
; Make sure we have a signature code before continuing
I '$$ESIGC^PRSPUT2(1) W !! S OUT=$$ASK^PRSLIB00(1) Q
D HDROPT^PRSPSAP1
; Prompt supervisor to pick one T&L unit for which they are assigned.
S PRSTLV=3
D ^PRSAUTL
Q:TLI<1
;
; Check if they only want to look at one employee
S APRWHO=$$ONEPTP^PRSPSAPU(TLE)
Q:APRWHO<0
; ---------------------------------------------------
I APRWHO>0 D
. S NN=$P($G(^PRSPC(APRWHO,0)),U)
. D BLDLST(.OUT,TLE,NN)
E D
.; Loop thru supervisor's selected T&L
. S NN=""
. F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN=""!($G(OUT)>0) D
.. D BLDLST(.OUT,TLE,NN)
;
; display all the ASA records for action.
S OUT=0
D ASALIST^PRSPSAP1(.OUT)
; check if there are any updates and then prompt for signature
;
D ANYACT^PRSPSAP1(.ANYACT)
I ANYACT>0 D
. D SUMMARY(.ANYACT)
. D SIG^XUSESIG
.; update the timecard and ESR status for all actions when
.; a valid signature is applied
. I X1="" D
.. W @IOF,!!!,?10,"TIMECARD AND ESR WERE NOT UPDATED."
.E D
.. D TRANSACT^PRSPSAP2
; remove any remaining PTP timecard locks held in this option
; D EX^PRSASR
K ^TMP($J,"PRSPSAP")
Q
;
BLDLST(OUT,TLE,NN) ; BUILD LIST OF ALL APPROVAL ACTIONS FOR SINGLE EMPLOYEE
N PRSIEN,PPE,PPI,AVAIL,DCNT,PRSD,GLOB,DFN
S PRSIEN=0
F S PRSIEN=$O(^PRSPC("ATL"_TLE,NN,PRSIEN)) Q:PRSIEN<1!($G(OUT)>0) D ;Loop through IENs for a single name, PRS*4.0*151
. S PPE=""
. F S PPE=$O(^PRST(458,"ASA",PRSIEN,PPE)) Q:PPE=""!($G(OUT)>0) D
.. S PPI=$O(^PRST(458,"B",PPE,0))
..; get lock for PTP's entire PP, then add record (PUSH) that
..; requires supervisor action to the list
.. S DFN=PRSIEN
..;
..; $$availrec() locks PTP ESR node.
..; unlock if supervisor bybasses unlock otherwise they
..; are not unlocked until they are processed thru temp global
..; & their status' are updated.
.. S AVAIL=$$AVAILREC^PRSLIB00("",.GLOB,.OUT)
.. Q:'AVAIL
.. ;
..; add item to list and set up a day cross ref with count of days
.. S (DCNT,PRSD)=0
.. F S PRSD=$O(^PRST(458,"ASA",PRSIEN,PPE,PRSD)) Q:PRSD'>0 D
... S DCNT=DCNT+1
... D PUSH^PRSPSAP1(PPI,PRSIEN,PRSD,DCNT)
;
Q
;
SUMMARY(AA) ;
W @IOF,!!!,"Supervisory Action Summary"
W !!,$J(AA,6)," actions require your electronic signature before being"
W !,?(6-$L(AA))," committed to the database."
I AA("A")>0 W !,$J(AA("A"),6)," ESR record marked for approval. (signature required)"
I AA("R")>0 W !,$J(AA("R"),6)," ESR records marked for resubmission. (signature required)"
I AA("B")>0 W !,$J(AA("B"),6)," ESR records explicitly bypassed."
I AA("N")>0 W !,$J(AA("N"),6)," ESR records with no action."
Q
GETACT(ESRDTS,PRSIEN,PPI) ; return user choice of # (1-ACTCNT) or action
; return 0 for ^ at first action prompt
; return null for no response (user hit return)
; return -1 if ^ at 2nd prompt (action on single day prompt)
N DIR,DIRUT,ACT,CT,NUMS
;
; get total items + marked items CT CT(1)
D MARKCNT^PRSPSAP1(.CT,PRSIEN,PPI)
I CT>1 D
. S NUMS=";"
. F I=1:1:CT D
.. S NUMS=NUMS_I_":"_$P(ESRDTS(I),U,2)_";"
;
; status already marked on all days
I (CT>1)&(CT=CT(1)) D
. S DIR(0)="SAO^"_NUMS
. S DIR("A")="Select an item #: "
. S DIR("?",1)="Enter an item from the left column to change status for that day"
E D
.; if all days don't have a superV action (marked) then prompt for
.; action on remaining days or pick a day (item)
. I CT>1 D
.. S DIR(0)="SAO^A:Approve;B:Bypass;R:Resubmit"_NUMS
.. S DIR("A")="(A)pprove, (B)ypass, (R)esubmit or enter an item #: "
.. S DIR("?",1)="Enter an action for all records without a status or enter an item #"
.. S DIR("?",2)="to then pick an action for that day."
.. S DIR("?",3)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
.. S DIR("?",4)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
.. S DIR("?",5)=" Type A for Approve when the ESR day(s) appears correct."
.E D
..; if only one item to pick, don't ask for item #
.. S DIR(0)="SAO^A:Approve;B:Bypass;R:Resubmit"
.. S DIR("A")="(A)pprove, (B)ypass, (R)esubmit: "
.. S DIR("?",1)="Enter an action for all records without a status"
.. S DIR("?",2)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
.. S DIR("?",3)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
.. S DIR("?",4)=" Type A for Approve when the ESR day(s) appears correct."
;
S DIR("?")=" Press [enter] to move to the next part time physician."
D ^DIR
S PICK=$G(Y)
I $G(Y)="" Q ""
; if there was only one item then set pick to 1 plus action
I CT=1 S PICK=PICK_"^1"
I $G(DIRUT) S PICK=0
;
; item was picked
I PICK>0,(PICK<(CT+1)) D
. N DAYLNS,DIR,DIRUT,ESR,HPL
. D GETESR^PRSPSAP1(.ESR,PPI,PRSIEN,+ESRDTS(PICK))
. N COUNT S COUNT=PICK,COUNT(1)=0
. W ! D DAY^PRSPSAPU(.DAYLNS,ESRDTS(COUNT),.ESR,PRSIEN,PPI)
. S ACT=PICK
. S DIR(0)="SA^A:Approve;B:Bypass;R:Resubmit"
. S DIR("A")="(A)pprove, (B)ypass, (R)esubmit: "
. S DIR("?")="Select an action for the ESR day above."
. S DIR("?",1)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
. S DIR("?",2)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
. S DIR("?",3)=" Type A for Approve when the ESR day(s) appears correct."
. S DIR("?",4)=" Type ^ to redisplay the current part time physician."
. D GETDAY^PRSPSAPU(.DAYLNS,.ESRDTS,.ESR,PICK,PRSIEN,PPI)
. S HPL=0
. F S HPL=$O(DAYLNS(HPL)) Q:HPL'>0 D
.. S DIR("?",HPL+4)=$G(DAYLNS(HPL))
. D ^DIR
. S PICK=$G(Y)_"^"_ACT
. I $G(DIRUT) S PICK=-1
Q PICK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPSAP 6580 printed Dec 13, 2024@02:28:13 Page 2
PRSPSAP ;WOIFO/JAH - part time physician, supervisory approvals ;10/22/04
+1 ;;4.0;PAID;**93,151**;Sep 21, 1995;Build 2
+2 ;Per VA Directive 6402, this routine should not be modified
+3 QUIT
+4 ; T&A supervisor of PTP employee is required to review and take
+5 ; one of the following actions on each signed day of the PTP's ESR:
+6 ; 1. approve, 2. request resubmission or 3. bypass.
+7 ; When the T&A Supervisor approves a signed day we attempt to
+8 ; update the PTP's timecard for that day. Updates to the
+9 ; timecard will be screened based on the status of the timecard
+10 ; and the effect of any potential update.
+11 ;
+12 ; MAIN entry point called from option Approve Signed ESRs.
+13 ;
MAIN ;
+1 KILL ^TMP($JOB,"PRSPSAP")
+2 NEW PRSTLV,TLI,TLE,PRSIEN,ANYACT,AVAIL,OUT,DCNT,APRWHO
+3 ; Make sure we have a signature code before continuing
+4 IF '$$ESIGC^PRSPUT2(1)
WRITE !!
SET OUT=$$ASK^PRSLIB00(1)
QUIT
+5 DO HDROPT^PRSPSAP1
+6 ; Prompt supervisor to pick one T&L unit for which they are assigned.
+7 SET PRSTLV=3
+8 DO ^PRSAUTL
+9 if TLI<1
QUIT
+10 ;
+11 ; Check if they only want to look at one employee
+12 SET APRWHO=$$ONEPTP^PRSPSAPU(TLE)
+13 if APRWHO<0
QUIT
+14 ; ---------------------------------------------------
+15 IF APRWHO>0
Begin DoDot:1
+16 SET NN=$PIECE($GET(^PRSPC(APRWHO,0)),U)
+17 DO BLDLST(.OUT,TLE,NN)
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 ; Loop thru supervisor's selected T&L
+20 SET NN=""
+21 FOR
SET NN=$ORDER(^PRSPC("ATL"_TLE,NN))
if NN=""!($GET(OUT)>0)
QUIT
Begin DoDot:2
+22 DO BLDLST(.OUT,TLE,NN)
End DoDot:2
End DoDot:1
+23 ;
+24 ; display all the ASA records for action.
+25 SET OUT=0
+26 DO ASALIST^PRSPSAP1(.OUT)
+27 ; check if there are any updates and then prompt for signature
+28 ;
+29 DO ANYACT^PRSPSAP1(.ANYACT)
+30 IF ANYACT>0
Begin DoDot:1
+31 DO SUMMARY(.ANYACT)
+32 DO SIG^XUSESIG
+33 ; update the timecard and ESR status for all actions when
+34 ; a valid signature is applied
+35 IF X1=""
Begin DoDot:2
+36 WRITE @IOF,!!!,?10,"TIMECARD AND ESR WERE NOT UPDATED."
End DoDot:2
+37 IF '$TEST
Begin DoDot:2
+38 DO TRANSACT^PRSPSAP2
End DoDot:2
End DoDot:1
+39 ; remove any remaining PTP timecard locks held in this option
+40 ; D EX^PRSASR
+41 KILL ^TMP($JOB,"PRSPSAP")
+42 QUIT
+43 ;
BLDLST(OUT,TLE,NN) ; BUILD LIST OF ALL APPROVAL ACTIONS FOR SINGLE EMPLOYEE
+1 NEW PRSIEN,PPE,PPI,AVAIL,DCNT,PRSD,GLOB,DFN
+2 SET PRSIEN=0
+3 ;Loop through IENs for a single name, PRS*4.0*151
FOR
SET PRSIEN=$ORDER(^PRSPC("ATL"_TLE,NN,PRSIEN))
if PRSIEN<1!($GET(OUT)>0)
QUIT
Begin DoDot:1
+4 SET PPE=""
+5 FOR
SET PPE=$ORDER(^PRST(458,"ASA",PRSIEN,PPE))
if PPE=""!($GET(OUT)>0)
QUIT
Begin DoDot:2
+6 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+7 ; get lock for PTP's entire PP, then add record (PUSH) that
+8 ; requires supervisor action to the list
+9 SET DFN=PRSIEN
+10 ;
+11 ; $$availrec() locks PTP ESR node.
+12 ; unlock if supervisor bybasses unlock otherwise they
+13 ; are not unlocked until they are processed thru temp global
+14 ; & their status' are updated.
+15 SET AVAIL=$$AVAILREC^PRSLIB00("",.GLOB,.OUT)
+16 if 'AVAIL
QUIT
+17 ;
+18 ; add item to list and set up a day cross ref with count of days
+19 SET (DCNT,PRSD)=0
+20 FOR
SET PRSD=$ORDER(^PRST(458,"ASA",PRSIEN,PPE,PRSD))
if PRSD'>0
QUIT
Begin DoDot:3
+21 SET DCNT=DCNT+1
+22 DO PUSH^PRSPSAP1(PPI,PRSIEN,PRSD,DCNT)
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 QUIT
+25 ;
SUMMARY(AA) ;
+1 WRITE @IOF,!!!,"Supervisory Action Summary"
+2 WRITE !!,$JUSTIFY(AA,6)," actions require your electronic signature before being"
+3 WRITE !,?(6-$LENGTH(AA))," committed to the database."
+4 IF AA("A")>0
WRITE !,$JUSTIFY(AA("A"),6)," ESR record marked for approval. (signature required)"
+5 IF AA("R")>0
WRITE !,$JUSTIFY(AA("R"),6)," ESR records marked for resubmission. (signature required)"
+6 IF AA("B")>0
WRITE !,$JUSTIFY(AA("B"),6)," ESR records explicitly bypassed."
+7 IF AA("N")>0
WRITE !,$JUSTIFY(AA("N"),6)," ESR records with no action."
+8 QUIT
GETACT(ESRDTS,PRSIEN,PPI) ; return user choice of # (1-ACTCNT) or action
+1 ; return 0 for ^ at first action prompt
+2 ; return null for no response (user hit return)
+3 ; return -1 if ^ at 2nd prompt (action on single day prompt)
+4 NEW DIR,DIRUT,ACT,CT,NUMS
+5 ;
+6 ; get total items + marked items CT CT(1)
+7 DO MARKCNT^PRSPSAP1(.CT,PRSIEN,PPI)
+8 IF CT>1
Begin DoDot:1
+9 SET NUMS=";"
+10 FOR I=1:1:CT
Begin DoDot:2
+11 SET NUMS=NUMS_I_":"_$PIECE(ESRDTS(I),U,2)_";"
End DoDot:2
End DoDot:1
+12 ;
+13 ; status already marked on all days
+14 IF (CT>1)&(CT=CT(1))
Begin DoDot:1
+15 SET DIR(0)="SAO^"_NUMS
+16 SET DIR("A")="Select an item #: "
+17 SET DIR("?",1)="Enter an item from the left column to change status for that day"
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 ; if all days don't have a superV action (marked) then prompt for
+20 ; action on remaining days or pick a day (item)
+21 IF CT>1
Begin DoDot:2
+22 SET DIR(0)="SAO^A:Approve;B:Bypass;R:Resubmit"_NUMS
+23 SET DIR("A")="(A)pprove, (B)ypass, (R)esubmit or enter an item #: "
+24 SET DIR("?",1)="Enter an action for all records without a status or enter an item #"
+25 SET DIR("?",2)="to then pick an action for that day."
+26 SET DIR("?",3)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
+27 SET DIR("?",4)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
+28 SET DIR("?",5)=" Type A for Approve when the ESR day(s) appears correct."
End DoDot:2
+29 IF '$TEST
Begin DoDot:2
+30 ; if only one item to pick, don't ask for item #
+31 SET DIR(0)="SAO^A:Approve;B:Bypass;R:Resubmit"
+32 SET DIR("A")="(A)pprove, (B)ypass, (R)esubmit: "
+33 SET DIR("?",1)="Enter an action for all records without a status"
+34 SET DIR("?",2)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
+35 SET DIR("?",3)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
+36 SET DIR("?",4)=" Type A for Approve when the ESR day(s) appears correct."
End DoDot:2
End DoDot:1
+37 ;
+38 SET DIR("?")=" Press [enter] to move to the next part time physician."
+39 DO ^DIR
+40 SET PICK=$GET(Y)
+41 IF $GET(Y)=""
QUIT ""
+42 ; if there was only one item then set pick to 1 plus action
+43 IF CT=1
SET PICK=PICK_"^1"
+44 IF $GET(DIRUT)
SET PICK=0
+45 ;
+46 ; item was picked
+47 IF PICK>0
IF (PICK<(CT+1))
Begin DoDot:1
+48 NEW DAYLNS,DIR,DIRUT,ESR,HPL
+49 DO GETESR^PRSPSAP1(.ESR,PPI,PRSIEN,+ESRDTS(PICK))
+50 NEW COUNT
SET COUNT=PICK
SET COUNT(1)=0
+51 WRITE !
DO DAY^PRSPSAPU(.DAYLNS,ESRDTS(COUNT),.ESR,PRSIEN,PPI)
+52 SET ACT=PICK
+53 SET DIR(0)="SA^A:Approve;B:Bypass;R:Resubmit"
+54 SET DIR("A")="(A)pprove, (B)ypass, (R)esubmit: "
+55 SET DIR("?")="Select an action for the ESR day above."
+56 SET DIR("?",1)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
+57 SET DIR("?",2)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
+58 SET DIR("?",3)=" Type A for Approve when the ESR day(s) appears correct."
+59 SET DIR("?",4)=" Type ^ to redisplay the current part time physician."
+60 DO GETDAY^PRSPSAPU(.DAYLNS,.ESRDTS,.ESR,PICK,PRSIEN,PPI)
+61 SET HPL=0
+62 FOR
SET HPL=$ORDER(DAYLNS(HPL))
if HPL'>0
QUIT
Begin DoDot:2
+63 SET DIR("?",HPL+4)=$GET(DAYLNS(HPL))
End DoDot:2
+64 DO ^DIR
+65 SET PICK=$GET(Y)_"^"_ACT
+66 IF $GET(DIRUT)
SET PICK=-1
End DoDot:1
+67 QUIT PICK
+68 ;
