PRSPSAP.m

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 ---PRSPSAP   6580     printed  Feb 18, 2025@23:54:44                                                                                                                                                                                                     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      ;