PRSPEEM ;HISC/MGD - ESR EXCEPTIONS FOR ENTIRE MEMORANDA ;06/15/05
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
PAY ; Payroll Entry
S PRSTLV=7,QUITX=0
D T0
Q
;
SUP ; Supervisor Entry
;
S PRSTLV=3,QUITX=0
T0 K DIR,^TMP($J,"PRSPEEM"),^TMP($J,"PRSPEEM EMP")
D TOP ; print header
D OMIT ; Prompt to omit current Pay Period
I X="^" D EX Q
D TLCHK ; Check for Supervisor of just 1 or mult T&L
I MULT>1 D TL
I MULT=1 D
. S TL="ATL"_TLE
. D EMP
I '$D(^TMP($J,"PRSPEEM")) W !,"No exceptions found for input criteria." Q
D SCRN1
D EX
;
Q
OMIT ; Prompt for Omit current pay period
S DIR(0)="Y"
S DIR("A")="Would you like to omit the current pay period from this report"
D ^DIR K DIR
S OMIT=Y
Q
;
TLCHK ; Check for Supervisor of just 1 or mult T&L
S MULT=0,I=""
F S I=$O(^PRST(455.5,"AS",DUZ,I)) Q:'I D
. S MULT=MULT+1,TLI=I,TLE=$P(^PRST(455.5,I,0),U,1)
Q
;
TL ; Loop to enter T&Ls and employees
N SEL ; local array to hold selected t&ls and employees
S QUIT1=0
F D Q:QUIT1
. D ^PRSAUTL
. I 'TLI S QUIT1=1 Q
. I $D(SEL(TLI,"A")) D Q
.. W !!,?5,"You have already selected all the employees in T&L unit ",$G(TLE),"."
.. W !,?5,"Select another T&L OR enter <return> to begin report."
. D EMP
Q
;
; Loop for individual employees in a T&L
EMP S QUIT2=0
S DIR(0)="SM^A:All PT Physicians in the T&L;I:Individual PT Physicians"
S DIR("A")="Enter Choice"
D ^DIR K DIR
; Loop for All employee in a T&L
I Y="A" D Q
. K SEL(TLI) S SEL(TLI,"A")=""
. K ^TMP($J,"PRSPEEM",TLI)
. S EMP="",TL="ATL"_TLE
. F S EMP=$O(^PRSPC(TL,EMP)) Q:EMP="" D
. . S PRSIEN=$O(^PRSPC(TL,EMP,0))
. . Q:'PRSIEN
. . D MEM ; Check for memos w/ status = ACTIVE or RECONCILIATION STARTED
. . S QUIT2=1
Q:QUIT2
;
S PPI=+$G(^PRST(458,"AD",DT)),PRSDT=DT,PTPF=1
F D Q:QUIT2
. K DIC
. S DIC("A")=$S('$D(SEL(TLI)):"Select EMPLOYEE: ",1:"Select Another EMPLOYEE: ")
. S DIC(0)="AEQM",DIC="^PRSPC(",D="ATL"_TLE
. S DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458.7,""B"",+Y)),'$D(SEL(TLI,+Y))"
. W !
. D IX^DIC S PRSIEN=+Y
. I X=""!(X="^") S QUIT2=1 Q
. S SEL(TLI,PRSIEN)=""
. D MEM
Q
;
MEM ; Check for memos w/ status of ACTIVE (2) or RECONCILIATION STARTED (3)
N PPI
S MIEN=""
F S MIEN=$O(^PRST(458.7,"B",PRSIEN,MIEN)) Q:'MIEN D
. S DATA0=$G(^PRST(458.7,MIEN,0))
. S STATUS=$P(DATA0,U,6)
. Q:STATUS'=2&(STATUS'=3)
. S TDAT=$P($G(^PRST(458.7,MIEN,4)),U,1)
. I TDAT S TDAT=+$G(^PRST(458,"AD",TDAT)) ; IEN of termination PP
. ; Loop to check for any incomplete days in any PP of the memo
. S PP=0
. F I=1:1:26 S PPE=$P($G(^PRST(458.7,MIEN,9,I,0)),U) Q:PPE="" D
. . S PPI=$O(^PRST(458,"B",PPE,0))
. . Q:'PPI
. . ; If the memo was terminated, only check ESRs up to and
. . ; including the Termination Date
. . Q:TDAT&(PPI>TDAT) ; Don't look past termination PP
. . S PP=PP+1
. . S DATA1=$G(^PRST(458,PPI,1)) ; FileMan Dates
. . Q:'+$$MIEN^PRSPUT1(PRSIEN,$P(DATA1,U,I))
. . F DAY=1:1:14 D
. . . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
. . . Q:ESRSTAT>3
. . . S ESRSTATX=$$EXTERNAL^DILFD(458.02,146,"",ESRSTAT)
. . . I ESRSTATX="" S ESRSTATX="UNKNOWN"
. . . S Y=$P(DATA1,U,DAY)
. . . D DD^%DT
. . . S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY)=Y_U_ESRSTATX
. . I $D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)) D
. . . S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)=PPI_U_PPE
. ; if no exceptions found set up first pay pereiod with no data message
. I '$D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN)) D
.. S PPE=$P($G(^PRST(458.7,MIEN,9,1,0)),U)
.. S PPI=$O(^PRST(458,"B",PPE,0))
.. S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,1)=PPI_U_PPE_U_"*"
.. S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,1,0)="no exceptions found fo r entire memo"
Q
;
TOP W:$E(IOST,1,2)="C-" @IOF
W !?26,"VA TIME & ATTENDANCE SYSTEM"
W !?22,"ESR EXCEPTIONS FOR ENTIRE MEMORANDA",!!
Q
;
TOP1 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
S SCRTTLX="ESR EXCEPTIONS FOR ENTIRE MEMORANDA"
I OMIT S SCRTTLX=SCRTTLX_" - CURRENT PP OMITTED"
S $E(SCRTTL,$S(OMIT:12,1:22))=""
S SCRTTL=SCRTTL_SCRTTLX
W !,SCRTTL
Q
;
SCRN1 ; Loop through employees and display data
W:$E(IOST,1,2)="C-" @IOF
S TLI="",QUITX=0
F S TLI=$O(^TMP($J,"PRSPEEM",TLI)) Q:'TLI D Q:QUITX
. S PRSIEN="",INDEX=1
. F S PRSIEN=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN)) Q:'PRSIEN D Q:QUITX
. . K ^TMP($J,"PRSPEEM EMP") ; Kill temporary employee array
. . S MIEN="",(EMPQT,LIST)=0
. . F S MIEN=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN)) Q:'MIEN D Q:QUITX
. . . S PP="",DAYCNT=0
. . . F S PP=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)) Q:'PP D Q:QUITX
. . . . S DATA=^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP),LIST=LIST+1
. . . . S PPI=$P(DATA,U,1),PPE=$P(DATA,U,2)
. . . . S ITEM(LIST)=DATA
. . . . I DAYCNT=0 D ; Display header prior to 1st PP in a memo
. . . . . S ARRAY="^TMP($J,""PRSPEEM EMP"","
. . . . . S SCRTTL="ESR EXCEPTIONS FOR ENTIRE MEMORANDA"
. . . . . D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,INDEX,PPI)
. . . . . D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
. . . . . D AL^PRSPUT3(PRSIEN,ARRAY)
. . . . . S INDEX="",INDEX=$O(^TMP($J,"PRSPEEM EMP",INDEX),-1)
. . . . . S TEXT="",INDEX=INDEX+1
. . . . . D A1^PRSPUT1 ; Blank Line
. . . . . S TEXT=" # Pay Period Date Status"
. . . . . D A1^PRSPUT1
. . . . . S TEXT="------------------------------------"
. . . . . D A1^PRSPUT1
. . . . I $P(DATA,U,3)="*" S TEXT="No exceptions found for entire memo" D A1^PRSPUT1 Q
. . . . S TEXT=$J(PP,2),$E(TEXT,5)="",TEXT=TEXT_PPE
. . . . F DAY=1:1:14 D Q:QUITX
. . . . . Q:'$D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY))
. . . . . S DATA=^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY)
. . . . . S $E(TEXT,17)="",TEXT=TEXT_$P(DATA,U,1) ; External Date
. . . . . S $E(TEXT,31)="",TEXT=TEXT_$P(DATA,U,2) ; External Status
. . . . . S DAYCNT=DAYCNT+1
. . . . . D A1^PRSPUT1
. . . . . I $Y>(IOSL-3) D PSE
. . . Q:QUITX
. . . S $E(TEXT,31,36)="------",INDEX=INDEX+1
. . . D A1^PRSPUT1
. . . S $E(TEXT,20)="",TEXT=TEXT_"Total Days: "_DAYCNT
. . . D A1^PRSPUT1
. . . I $P(DATA,U,3)="*" D
. . . . S QUITX=$$ASK^PRSLIB00(1)
. . . E D
. . . . D ACTION
. . . I $E(IOST,1,2)="C-" W @IOF
Q
;
ACTION ; Prompt for action
S EMPQT=0
F D Q:QUITX!(EMPQT)
. S TEXT="(P)rint list, (S)elect Item or press Enter to "
. S TEXT=TEXT_"continue to next employee"
. W !!,TEXT
. W !!,"Enter Choice: "
. R CHOICE:DT
. S CHOICE=$$UPPER^PRSRUTL(CHOICE)
. I CHOICE="" S EMPQT=1 Q ; Go to next employee
. I CHOICE="^" S QUITX=1 Q ; Terminate report
. I CHOICE'="P"&(CHOICE'="S") D Q
. . W !!,"Enter P, S or ^ to Quit or press Enter to continue to next employee."
. I CHOICE="P" D Q:EMPQT
. . D DVC1
. . I POP S EMPQT=1
. I CHOICE="S" D
. . F D Q:EMPQT!(QUITX)
. . . I $E(IOST,1,2)="C-" W @IOF
. . . F I=1:1 Q:'$D(ITEM(I)) W !,I,?5,$P(ITEM(I),U,2)
. . . W !!,"Select a number between 1 and ",LIST_" : "
. . . R ITEM:DT
. . . S ITEM=$$UPPER^PRSRUTL(ITEM)
. . . I ITEM="" S EMPQT=1 Q ; Go to next employee
. . . I ITEM="^" S QUITX=1 Q ; Terminate report
. . . Q:'$D(ITEM(ITEM))
. . . S PPI=+ITEM(ITEM)
. . . D DVC2
;
Q
;
LOOP1 ; Loop to display Summary Screen with list of outstanding ESRs
I '$D(^TMP($J,"PRSPEEM EMP")) W !,"No part-time physician ESR Exceptions found for selected criteria." Q
S INDX=""
F S INDX=$O(^TMP($J,"PRSPEEM EMP",INDX)) Q:'INDX D
. S TEXT=^TMP($J,"PRSPEEM EMP",INDX)
. W !,TEXT
Q
;
DVC1 ; Display Summary Screen with list of outstanding ESRs
W !
K IOP,%ZIS
S %ZIS("A")="Select Device: ",%ZIS="MQ"
D ^%ZIS K %ZIS,IOP
Q:POP
I $D(IO("Q")) D Q
. S ZTRTN="LOOP1^PRSPEEM"
. S ZTSAVE("^TMP($J,""PRSPEEM EMP"",")=""
. S ZTDESC="PRS PTP EXCEPTS"
. D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
. K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
. D HOME^%ZIS
U IO D LOOP1
D ^%ZISC K %ZIS,IOP
D H1 ; pause screen
Q
;
DVC2 ; Display PP ESR
W !
K IOP,%ZIS
S %ZIS("A")="Select Device: ",%ZIS="MQ"
D ^%ZIS K %ZIS,IOP
Q:POP
I $D(IO("Q")) D Q
. S ZTRTN="DIS^PRSPDESR"
. S ZTSAVE("PRSIEN")="",ZTSAVE("PPI")="",ZTSAVE("PPE")=""
. S ZTDESC="PRS PTP DISPLAY ESR"
. D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
. K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
. D HOME^%ZIS
. N HOLD S HOLD=$$ASK^PRSLIB00(1)
U IO D DIS^PRSPDESR
D ^%ZISC K %ZIS,IOP
D H1 ; pause screen
Q
;
;====================================================================
;
PSE ; Pause for screen breaks
W !
S DIR(0)="E",DIR("A")="Press RETURN to continue"
D ^DIR
I X="^" S QUITX=1 Q
W @IOF
Q
;
H1 I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1
Q
EX ; Clean up variables
K ARRAY,CHOICE,D,DASH,DATA,DATA0,DATA1,DAY,DAYCNT,DFN
K EMP,EMPQT,ESRSTAT,ESRSTATX,I,IDAYS,INDEX,INDX,ITEM,LIST,MIEN
K MULT,OMIT,POP,PP,PPE,PPI,PRSAPGM,PRSDT,PRSIEN,PRSTLV,PTPF
K QT,QUIT1,QUIT2,QUITX,SCRTTL,SCRTTLX,STATUS,TDAT,TEXT,TL,TLE,TLI,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPEEM 9213 printed Sep 23, 2025@20:04:25 Page 2
PRSPEEM ;HISC/MGD - ESR EXCEPTIONS FOR ENTIRE MEMORANDA ;06/15/05
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
PAY ; Payroll Entry
+1 SET PRSTLV=7
SET QUITX=0
+2 DO T0
+3 QUIT
+4 ;
SUP ; Supervisor Entry
+1 ;
+2 SET PRSTLV=3
SET QUITX=0
T0 KILL DIR,^TMP($JOB,"PRSPEEM"),^TMP($JOB,"PRSPEEM EMP")
+1 ; print header
DO TOP
+2 ; Prompt to omit current Pay Period
DO OMIT
+3 IF X="^"
DO EX
QUIT
+4 ; Check for Supervisor of just 1 or mult T&L
DO TLCHK
+5 IF MULT>1
DO TL
+6 IF MULT=1
Begin DoDot:1
+7 SET TL="ATL"_TLE
+8 DO EMP
End DoDot:1
+9 IF '$DATA(^TMP($JOB,"PRSPEEM"))
WRITE !,"No exceptions found for input criteria."
QUIT
+10 DO SCRN1
+11 DO EX
+12 ;
+13 QUIT
OMIT ; Prompt for Omit current pay period
+1 SET DIR(0)="Y"
+2 SET DIR("A")="Would you like to omit the current pay period from this report"
+3 DO ^DIR
KILL DIR
+4 SET OMIT=Y
+5 QUIT
+6 ;
TLCHK ; Check for Supervisor of just 1 or mult T&L
+1 SET MULT=0
SET I=""
+2 FOR
SET I=$ORDER(^PRST(455.5,"AS",DUZ,I))
if 'I
QUIT
Begin DoDot:1
+3 SET MULT=MULT+1
SET TLI=I
SET TLE=$PIECE(^PRST(455.5,I,0),U,1)
End DoDot:1
+4 QUIT
+5 ;
TL ; Loop to enter T&Ls and employees
+1 ; local array to hold selected t&ls and employees
NEW SEL
+2 SET QUIT1=0
+3 FOR
Begin DoDot:1
+4 DO ^PRSAUTL
+5 IF 'TLI
SET QUIT1=1
QUIT
+6 IF $DATA(SEL(TLI,"A"))
Begin DoDot:2
+7 WRITE !!,?5,"You have already selected all the employees in T&L unit ",$GET(TLE),"."
+8 WRITE !,?5,"Select another T&L OR enter <return> to begin report."
End DoDot:2
QUIT
+9 DO EMP
End DoDot:1
if QUIT1
QUIT
+10 QUIT
+11 ;
+12 ; Loop for individual employees in a T&L
EMP SET QUIT2=0
+1 SET DIR(0)="SM^A:All PT Physicians in the T&L;I:Individual PT Physicians"
+2 SET DIR("A")="Enter Choice"
+3 DO ^DIR
KILL DIR
+4 ; Loop for All employee in a T&L
+5 IF Y="A"
Begin DoDot:1
+6 KILL SEL(TLI)
SET SEL(TLI,"A")=""
+7 KILL ^TMP($JOB,"PRSPEEM",TLI)
+8 SET EMP=""
SET TL="ATL"_TLE
+9 FOR
SET EMP=$ORDER(^PRSPC(TL,EMP))
if EMP=""
QUIT
Begin DoDot:2
+10 SET PRSIEN=$ORDER(^PRSPC(TL,EMP,0))
+11 if 'PRSIEN
QUIT
+12 ; Check for memos w/ status = ACTIVE or RECONCILIATION STARTED
DO MEM
+13 SET QUIT2=1
End DoDot:2
End DoDot:1
QUIT
+14 if QUIT2
QUIT
+15 ;
+16 SET PPI=+$GET(^PRST(458,"AD",DT))
SET PRSDT=DT
SET PTPF=1
+17 FOR
Begin DoDot:1
+18 KILL DIC
+19 SET DIC("A")=$SELECT('$DATA(SEL(TLI)):"Select EMPLOYEE: ",1:"Select Another EMPLOYEE: ")
+20 SET DIC(0)="AEQM"
SET DIC="^PRSPC("
SET D="ATL"_TLE
+21 SET DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458.7,""B"",+Y)),'$D(SEL(TLI,+Y))"
+22 WRITE !
+23 DO IX^DIC
SET PRSIEN=+Y
+24 IF X=""!(X="^")
SET QUIT2=1
QUIT
+25 SET SEL(TLI,PRSIEN)=""
+26 DO MEM
End DoDot:1
if QUIT2
QUIT
+27 QUIT
+28 ;
MEM ; Check for memos w/ status of ACTIVE (2) or RECONCILIATION STARTED (3)
+1 NEW PPI
+2 SET MIEN=""
+3 FOR
SET MIEN=$ORDER(^PRST(458.7,"B",PRSIEN,MIEN))
if 'MIEN
QUIT
Begin DoDot:1
+4 SET DATA0=$GET(^PRST(458.7,MIEN,0))
+5 SET STATUS=$PIECE(DATA0,U,6)
+6 if STATUS'=2&(STATUS'=3)
QUIT
+7 SET TDAT=$PIECE($GET(^PRST(458.7,MIEN,4)),U,1)
+8 ; IEN of termination PP
IF TDAT
SET TDAT=+$GET(^PRST(458,"AD",TDAT))
+9 ; Loop to check for any incomplete days in any PP of the memo
+10 SET PP=0
+11 FOR I=1:1:26
SET PPE=$PIECE($GET(^PRST(458.7,MIEN,9,I,0)),U)
if PPE=""
QUIT
Begin DoDot:2
+12 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+13 if 'PPI
QUIT
+14 ; If the memo was terminated, only check ESRs up to and
+15 ; including the Termination Date
+16 ; Don't look past termination PP
if TDAT&(PPI>TDAT)
QUIT
+17 SET PP=PP+1
+18 ; FileMan Dates
SET DATA1=$GET(^PRST(458,PPI,1))
+19 if '+$$MIEN^PRSPUT1(PRSIEN,$PIECE(DATA1,U,I))
QUIT
+20 FOR DAY=1:1:14
Begin DoDot:3
+21 SET ESRSTAT=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
+22 if ESRSTAT>3
QUIT
+23 SET ESRSTATX=$$EXTERNAL^DILFD(458.02,146,"",ESRSTAT)
+24 IF ESRSTATX=""
SET ESRSTATX="UNKNOWN"
+25 SET Y=$PIECE(DATA1,U,DAY)
+26 DO DD^%DT
+27 SET ^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY)=Y_U_ESRSTATX
End DoDot:3
+28 IF $DATA(^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,PP))
Begin DoDot:3
+29 SET ^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,PP)=PPI_U_PPE
End DoDot:3
End DoDot:2
+30 ; if no exceptions found set up first pay pereiod with no data message
+31 IF '$DATA(^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN))
Begin DoDot:2
+32 SET PPE=$PIECE($GET(^PRST(458.7,MIEN,9,1,0)),U)
+33 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+34 SET ^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,1)=PPI_U_PPE_U_"*"
+35 SET ^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,1,0)="no exceptions found fo r entire memo"
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
TOP if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+1 WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+2 WRITE !?22,"ESR EXCEPTIONS FOR ENTIRE MEMORANDA",!!
+3 QUIT
+4 ;
TOP1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+1 SET SCRTTLX="ESR EXCEPTIONS FOR ENTIRE MEMORANDA"
+2 IF OMIT
SET SCRTTLX=SCRTTLX_" - CURRENT PP OMITTED"
+3 SET $EXTRACT(SCRTTL,$SELECT(OMIT:12,1:22))=""
+4 SET SCRTTL=SCRTTL_SCRTTLX
+5 WRITE !,SCRTTL
+6 QUIT
+7 ;
SCRN1 ; Loop through employees and display data
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 SET TLI=""
SET QUITX=0
+3 FOR
SET TLI=$ORDER(^TMP($JOB,"PRSPEEM",TLI))
if 'TLI
QUIT
Begin DoDot:1
+4 SET PRSIEN=""
SET INDEX=1
+5 FOR
SET PRSIEN=$ORDER(^TMP($JOB,"PRSPEEM",TLI,PRSIEN))
if 'PRSIEN
QUIT
Begin DoDot:2
+6 ; Kill temporary employee array
KILL ^TMP($JOB,"PRSPEEM EMP")
+7 SET MIEN=""
SET (EMPQT,LIST)=0
+8 FOR
SET MIEN=$ORDER(^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN))
if 'MIEN
QUIT
Begin DoDot:3
+9 SET PP=""
SET DAYCNT=0
+10 FOR
SET PP=$ORDER(^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,PP))
if 'PP
QUIT
Begin DoDot:4
+11 SET DATA=^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,PP)
SET LIST=LIST+1
+12 SET PPI=$PIECE(DATA,U,1)
SET PPE=$PIECE(DATA,U,2)
+13 SET ITEM(LIST)=DATA
+14 ; Display header prior to 1st PP in a memo
IF DAYCNT=0
Begin DoDot:5
+15 SET ARRAY="^TMP($J,""PRSPEEM EMP"","
+16 SET SCRTTL="ESR EXCEPTIONS FOR ENTIRE MEMORANDA"
+17 DO HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,INDEX,PPI)
+18 DO MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
+19 DO AL^PRSPUT3(PRSIEN,ARRAY)
+20 SET INDEX=""
SET INDEX=$ORDER(^TMP($JOB,"PRSPEEM EMP",INDEX),-1)
+21 SET TEXT=""
SET INDEX=INDEX+1
+22 ; Blank Line
DO A1^PRSPUT1
+23 SET TEXT=" # Pay Period Date Status"
+24 DO A1^PRSPUT1
+25 SET TEXT="------------------------------------"
+26 DO A1^PRSPUT1
End DoDot:5
+27 IF $PIECE(DATA,U,3)="*"
SET TEXT="No exceptions found for entire memo"
DO A1^PRSPUT1
QUIT
+28 SET TEXT=$JUSTIFY(PP,2)
SET $EXTRACT(TEXT,5)=""
SET TEXT=TEXT_PPE
+29 FOR DAY=1:1:14
Begin DoDot:5
+30 if '$DATA(^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY))
QUIT
+31 SET DATA=^TMP($JOB,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY)
+32 ; External Date
SET $EXTRACT(TEXT,17)=""
SET TEXT=TEXT_$PIECE(DATA,U,1)
+33 ; External Status
SET $EXTRACT(TEXT,31)=""
SET TEXT=TEXT_$PIECE(DATA,U,2)
+34 SET DAYCNT=DAYCNT+1
+35 DO A1^PRSPUT1
+36 IF $Y>(IOSL-3)
DO PSE
End DoDot:5
if QUITX
QUIT
End DoDot:4
if QUITX
QUIT
+37 if QUITX
QUIT
+38 SET $EXTRACT(TEXT,31,36)="------"
SET INDEX=INDEX+1
+39 DO A1^PRSPUT1
+40 SET $EXTRACT(TEXT,20)=""
SET TEXT=TEXT_"Total Days: "_DAYCNT
+41 DO A1^PRSPUT1
+42 IF $PIECE(DATA,U,3)="*"
Begin DoDot:4
+43 SET QUITX=$$ASK^PRSLIB00(1)
End DoDot:4
+44 IF '$TEST
Begin DoDot:4
+45 DO ACTION
End DoDot:4
+46 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
End DoDot:3
if QUITX
QUIT
End DoDot:2
if QUITX
QUIT
End DoDot:1
if QUITX
QUIT
+47 QUIT
+48 ;
ACTION ; Prompt for action
+1 SET EMPQT=0
+2 FOR
Begin DoDot:1
+3 SET TEXT="(P)rint list, (S)elect Item or press Enter to "
+4 SET TEXT=TEXT_"continue to next employee"
+5 WRITE !!,TEXT
+6 WRITE !!,"Enter Choice: "
+7 READ CHOICE:DT
+8 SET CHOICE=$$UPPER^PRSRUTL(CHOICE)
+9 ; Go to next employee
IF CHOICE=""
SET EMPQT=1
QUIT
+10 ; Terminate report
IF CHOICE="^"
SET QUITX=1
QUIT
+11 IF CHOICE'="P"&(CHOICE'="S")
Begin DoDot:2
+12 WRITE !!,"Enter P, S or ^ to Quit or press Enter to continue to next employee."
End DoDot:2
QUIT
+13 IF CHOICE="P"
Begin DoDot:2
+14 DO DVC1
+15 IF POP
SET EMPQT=1
End DoDot:2
if EMPQT
QUIT
+16 IF CHOICE="S"
Begin DoDot:2
+17 FOR
Begin DoDot:3
+18 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+19 FOR I=1:1
if '$DATA(ITEM(I))
QUIT
WRITE !,I,?5,$PIECE(ITEM(I),U,2)
+20 WRITE !!,"Select a number between 1 and ",LIST_" : "
+21 READ ITEM:DT
+22 SET ITEM=$$UPPER^PRSRUTL(ITEM)
+23 ; Go to next employee
IF ITEM=""
SET EMPQT=1
QUIT
+24 ; Terminate report
IF ITEM="^"
SET QUITX=1
QUIT
+25 if '$DATA(ITEM(ITEM))
QUIT
+26 SET PPI=+ITEM(ITEM)
+27 DO DVC2
End DoDot:3
if EMPQT!(QUITX)
QUIT
End DoDot:2
End DoDot:1
if QUITX!(EMPQT)
QUIT
+28 ;
+29 QUIT
+30 ;
LOOP1 ; Loop to display Summary Screen with list of outstanding ESRs
+1 IF '$DATA(^TMP($JOB,"PRSPEEM EMP"))
WRITE !,"No part-time physician ESR Exceptions found for selected criteria."
QUIT
+2 SET INDX=""
+3 FOR
SET INDX=$ORDER(^TMP($JOB,"PRSPEEM EMP",INDX))
if 'INDX
QUIT
Begin DoDot:1
+4 SET TEXT=^TMP($JOB,"PRSPEEM EMP",INDX)
+5 WRITE !,TEXT
End DoDot:1
+6 QUIT
+7 ;
DVC1 ; Display Summary Screen with list of outstanding ESRs
+1 WRITE !
+2 KILL IOP,%ZIS
+3 SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
+4 DO ^%ZIS
KILL %ZIS,IOP
+5 if POP
QUIT
+6 IF $DATA(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="LOOP1^PRSPEEM"
+8 SET ZTSAVE("^TMP($J,""PRSPEEM EMP"",")=""
+9 SET ZTDESC="PRS PTP EXCEPTS"
+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:1
QUIT
+13 USE IO
DO LOOP1
+14 DO ^%ZISC
KILL %ZIS,IOP
+15 ; pause screen
DO H1
+16 QUIT
+17 ;
DVC2 ; Display PP ESR
+1 WRITE !
+2 KILL IOP,%ZIS
+3 SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
+4 DO ^%ZIS
KILL %ZIS,IOP
+5 if POP
QUIT
+6 IF $DATA(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="DIS^PRSPDESR"
+8 SET ZTSAVE("PRSIEN")=""
SET ZTSAVE("PPI")=""
SET ZTSAVE("PPE")=""
+9 SET ZTDESC="PRS PTP DISPLAY ESR"
+10 DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Canceled!")
+11 KILL ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+12 DO HOME^%ZIS
+13 NEW HOLD
SET HOLD=$$ASK^PRSLIB00(1)
End DoDot:1
QUIT
+14 USE IO
DO DIS^PRSPDESR
+15 DO ^%ZISC
KILL %ZIS,IOP
+16 ; pause screen
DO H1
+17 QUIT
+18 ;
+19 ;====================================================================
+20 ;
PSE ; Pause for screen breaks
+1 WRITE !
+2 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
+3 DO ^DIR
+4 IF X="^"
SET QUITX=1
QUIT
+5 WRITE @IOF
+6 QUIT
+7 ;
H1 IF $EXTRACT(IOST,1,2)="C-"
READ !!,"Press RETURN to Continue.",X:DTIME
if '$TEST!(X["^")
SET QT=1
+1 QUIT
EX ; Clean up variables
+1 KILL ARRAY,CHOICE,D,DASH,DATA,DATA0,DATA1,DAY,DAYCNT,DFN
+2 KILL EMP,EMPQT,ESRSTAT,ESRSTATX,I,IDAYS,INDEX,INDX,ITEM,LIST,MIEN
+3 KILL MULT,OMIT,POP,PP,PPE,PPI,PRSAPGM,PRSDT,PRSIEN,PRSTLV,PTPF
+4 KILL QT,QUIT1,QUIT2,QUITX,SCRTTL,SCRTTLX,STATUS,TDAT,TEXT,TL,TLE,TLI,X,Y
+5 QUIT
