PRSPDEM ; HISC/MGD - DISPLAY PT PHYSICIAN EXPIRING MEMORANDUMS ;06/28/05
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
PAY ; Payroll Entry
N PPERIOD
S PRSTLV=7
TOP W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
S TEXT="MEMORANDA EXPIRING WITHIN THE NEXT 30 DAYS"
S SCRTTL=TEXT
W !?19,TEXT
; Prompt for Expiration date
W !!,"This report identifies PT Physician memorandums that will expire"
W !,"within the next 30 days. You may specify a date range other "
W "than 30."
W !
EDAT ;
S %DT="AEFX",%DT("A")="Expiration Date: ",%DT("B")="T+30",%DT(0)=DT
D ^%DT
S EDAT=Y
;
PRCNT ; Prompt for optional off by percentage
W !!,"You have the option to enter an Off By Percentage that will only"
W !,"list memorandums that are expiring within the specified date and"
W !,"that are only off by more than the percentage you specify."
W !!
S DIR("A")="Would you like to specify an Off By Percentage "
S DIR(0)="YO"
S PRCNT=""
D ^DIR K DIR
I X="Y" D
. W !
. S DIR(0)="NO^1:100:0"
. S DIR("A")="Select Off By Percentage "
. D ^DIR
. I X S PRCNT=X
;====================================================================
L1 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 PRSAPGM="DIS^PRSPDEM",PRSALST="DT^EDAT^PRCNT^POT"
. D QUE^PRSAUTL
U IO D DIS
; pause screen when employee to prevent scroll (other users prompted)
I $E(IOST,1,2)="C-",'QT,PRSTLV=1 S PG=PG+1 D H1
D ^%ZISC K %ZIS,IOP Q
;
DIS ; Display Memorandum
;
S (CNT,MIEN,PG,QT)=0
F S MIEN=$O(^PRST(458.7,MIEN)) Q:'MIEN D Q:QT
. S DATA0=$G(^PRST(458.7,MIEN,0)),DATA4=$G(^PRST(458.7,MIEN,4))
. S DATA3=$G(^PRST(458.7,MIEN,3))
. Q:$P(DATA3,U,1) ; Memo has been reconciled
. ;
. ; Check for Termination date beyond user selected expiration date
. S PRSIEN=$P(DATA0,U,1),POT=$P(DATA0,U,17)
. S TDAT=$P(DATA4,U,1),ENDAT=$P(DATA0,U,3)
. Q:TDAT&(TDAT>EDAT)
. ;
. ; Check for end date beyond user selected expiration date
. Q:TDAT=""&(ENDAT>EDAT)
. ;
. ; Quit if less that Percent Off Target
. Q:PRCNT&(+$FN(POT,"T")<PRCNT)
. ;
. ; Update counter and display memo
. S CNT=CNT+1
. D DISPLAY
. I $D(DIRUT) S QT=1 Q
. D PSE
;
Q:$D(DIRUT)
W !!,"There were "_CNT_" PT Physician Memorandums expiring in the"
W " date range specified"
I PRCNT D
. W !,"who were more than "_PRCNT_"% off target"
W "."
Q
;
DISPLAY ; Display memorandum information
W @IOF
S SCRTTL="DISPLAY PT PHYSICIAN MEMORANDA"
S ARRAY="^TMP($J,""PRSPDM"",",INDEX=1
D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,INDEX)
D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
D AL^PRSPUT3(PRSIEN,ARRAY)
D PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
I $E(IOST,1,2)="C-" D
. S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
. I '$D(DIRUT) W @IOF
Q:$D(DIRUT)
;
ESRCHK ; Check for any incomplete ESR within the memoranda.
;
F I=1:1:26 D
. S PPE=$P($G(^PRST(458.7,MIEN,9,I,0)),U)
. I PPE="" S ^TMP($J,"INCESR","NO DATA")="" Q
. S PPI=$O(^PRST(458,"B",PPE,0))
. Q:'PPI ; Pay Period is not opened yet.
. S QUIT=0
. F DAY=1:1:14 D Q:QUIT
. . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
. . I ESRSTAT<5 S ^TMP($J,"INCESR",PPE)="",QUIT=1
S INDEX=INDEX+1
S TEXT=""
D A1^PRSPUT1,A1^PRSPUT1 ; Blank Lines
S TEXT="The following Pay Periods have days with incomplete daily ESRs: "
D A1^PRSPUT1
S (PPE,PPEX)=""
F S PPE=$O(^TMP($J,"INCESR",PPE)) Q:PPE="" D
. S PPEX=$S(PPEX="":PPE,1:PPEX_", "_PPE)
S TEXT="" D A1^PRSPUT1 ; Blank Line
S TEXT=PPEX
D A1^PRSPUT1
K ^TMP($J,"INCESR")
;
; Load and display any HR Initial comments
S MESSAGE=$G(^PRST(458.7,MIEN,1))
I MESSAGE'="" D
. S TEXT=""
. D A1^PRSPUT1 ; Blank Line
. F J=1:1:3 D
. . S HEADER=$S(J=1:"HR Initial Comments: ",1:"")
. . D TEXT^PRSPDM(HEADER,.MESSAGE)
. . D A1^PRSPUT1
. I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
;
; Load and display Termination information if any
S DATA4=$G(^PRST(458.7,MIEN,4))
S TDAT=$P(DATA4,U,1),TERMBY=$P(DATA4,U,2),TERMDT=$P(DATA4,U,3)
I TDAT'="" D
. S Y=TDAT
. D DD^%DT
. S TDAT=Y
. I TDAT'="" D
. . S TEXT=""
. . D A1^PRSPUT1 ; Blank Line
. . S TEXT=" Termination date: "_TDAT
. . D A1^PRSPUT1
;
I TERMBY'="" D
. S TERMBY=$P($G(^VA(200,TERMBY,0)),U,1)
. S TEXT=" Terminated by: "_TERMBY
. D A1^PRSPUT1
;
I TERMDT'="" D
. S Y=TERMDT
. D DD^%DT
. S TERMDT=Y
. I TERMDT'="" D
. . S TEXT="Date/Time Terminated: "_TERMDT
. . D A1^PRSPUT1
I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
;
S MESSAGE=$G(^PRST(458.7,MIEN,4.1))
I MESSAGE'="" D
. S TEXT=""
. D A1^PRSPUT1 ; Blank Line
. F J=1:1:3 D
. . S HEADER=$S(J=1:"HR's Termination Comments: ",1:"")
. . D TEXT^PRSPDM(HEADER,.MESSAGE)
. . D A1^PRSPUT1
. I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
Q
PSE ; Pause for screen breaks
Q:$E(IOST,1,2)'="C-"
W !
S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
I $D(DIRUT) S QT=1
W @IOF
Q
;
;====================================================================
;
H1 I PG,$E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1
S PG=PG+1
Q
EX ; Clean up variables
K ARRAY,CNT,D,D1,DASH,DATA0,DATA2,DATA3,DATA31,DATA4,DATA41,DATA4580
K DAY,DAY1,DFN,DIRUT,EDAT,ENDAT,ESRSTAT,HEADER,HRS,I,ICOM
K IDAYS,IEN,INDEX,J,MESSAGE,MIEN,MT,PDT,PG,POP,POT,PPEX,PRCNT,PRSIEN
K PTPRC,PTPRCOM,RECONBY,RECONDAT,SDAT,TDAT,TERMBY,TERMDT,TEXT,TL
K PPE,PPI,PRSALST,PRSAPGM,PRSTLV,PTPRMKS,QUIT,QT,RC,RCEX,SCRTTL
K SEG,SSN,START,STAT,STATEX,STOP,T1,T1EX,TLI,TLSCREEN,TOT,TOTEX
K X,Y,%DT,%ZIS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPDEM 5688 printed Apr 09, 2024@21:28:39 Page 2
PRSPDEM ; HISC/MGD - DISPLAY PT PHYSICIAN EXPIRING MEMORANDUMS ;06/28/05
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
PAY ; Payroll Entry
+1 NEW PPERIOD
+2 SET PRSTLV=7
TOP if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+1 SET TEXT="MEMORANDA EXPIRING WITHIN THE NEXT 30 DAYS"
+2 SET SCRTTL=TEXT
+3 WRITE !?19,TEXT
+4 ; Prompt for Expiration date
+5 WRITE !!,"This report identifies PT Physician memorandums that will expire"
+6 WRITE !,"within the next 30 days. You may specify a date range other "
+7 WRITE "than 30."
+8 WRITE !
EDAT ;
+1 SET %DT="AEFX"
SET %DT("A")="Expiration Date: "
SET %DT("B")="T+30"
SET %DT(0)=DT
+2 DO ^%DT
+3 SET EDAT=Y
+4 ;
PRCNT ; Prompt for optional off by percentage
+1 WRITE !!,"You have the option to enter an Off By Percentage that will only"
+2 WRITE !,"list memorandums that are expiring within the specified date and"
+3 WRITE !,"that are only off by more than the percentage you specify."
+4 WRITE !!
+5 SET DIR("A")="Would you like to specify an Off By Percentage "
+6 SET DIR(0)="YO"
+7 SET PRCNT=""
+8 DO ^DIR
KILL DIR
+9 IF X="Y"
Begin DoDot:1
+10 WRITE !
+11 SET DIR(0)="NO^1:100:0"
+12 SET DIR("A")="Select Off By Percentage "
+13 DO ^DIR
+14 IF X
SET PRCNT=X
End DoDot:1
+15 ;====================================================================
L1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
QUIT
+1 IF $DATA(IO("Q"))
Begin DoDot:1
+2 SET PRSAPGM="DIS^PRSPDEM"
SET PRSALST="DT^EDAT^PRCNT^POT"
+3 DO QUE^PRSAUTL
End DoDot:1
QUIT
+4 USE IO
DO DIS
+5 ; pause screen when employee to prevent scroll (other users prompted)
+6 IF $EXTRACT(IOST,1,2)="C-"
IF 'QT
IF PRSTLV=1
SET PG=PG+1
DO H1
+7 DO ^%ZISC
KILL %ZIS,IOP
QUIT
+8 ;
DIS ; Display Memorandum
+1 ;
+2 SET (CNT,MIEN,PG,QT)=0
+3 FOR
SET MIEN=$ORDER(^PRST(458.7,MIEN))
if 'MIEN
QUIT
Begin DoDot:1
+4 SET DATA0=$GET(^PRST(458.7,MIEN,0))
SET DATA4=$GET(^PRST(458.7,MIEN,4))
+5 SET DATA3=$GET(^PRST(458.7,MIEN,3))
+6 ; Memo has been reconciled
if $PIECE(DATA3,U,1)
QUIT
+7 ;
+8 ; Check for Termination date beyond user selected expiration date
+9 SET PRSIEN=$PIECE(DATA0,U,1)
SET POT=$PIECE(DATA0,U,17)
+10 SET TDAT=$PIECE(DATA4,U,1)
SET ENDAT=$PIECE(DATA0,U,3)
+11 if TDAT&(TDAT>EDAT)
QUIT
+12 ;
+13 ; Check for end date beyond user selected expiration date
+14 if TDAT=""&(ENDAT>EDAT)
QUIT
+15 ;
+16 ; Quit if less that Percent Off Target
+17 if PRCNT&(+$FNUMBER(POT,"T")<PRCNT)
QUIT
+18 ;
+19 ; Update counter and display memo
+20 SET CNT=CNT+1
+21 DO DISPLAY
+22 IF $DATA(DIRUT)
SET QT=1
QUIT
+23 DO PSE
End DoDot:1
if QT
QUIT
+24 ;
+25 if $DATA(DIRUT)
QUIT
+26 WRITE !!,"There were "_CNT_" PT Physician Memorandums expiring in the"
+27 WRITE " date range specified"
+28 IF PRCNT
Begin DoDot:1
+29 WRITE !,"who were more than "_PRCNT_"% off target"
End DoDot:1
+30 WRITE "."
+31 QUIT
+32 ;
DISPLAY ; Display memorandum information
+1 WRITE @IOF
+2 SET SCRTTL="DISPLAY PT PHYSICIAN MEMORANDA"
+3 SET ARRAY="^TMP($J,""PRSPDM"","
SET INDEX=1
+4 DO HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,INDEX)
+5 DO MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
+6 DO AL^PRSPUT3(PRSIEN,ARRAY)
+7 DO PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
+8 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+9 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
+10 IF '$DATA(DIRUT)
WRITE @IOF
End DoDot:1
+11 if $DATA(DIRUT)
QUIT
+12 ;
ESRCHK ; Check for any incomplete ESR within the memoranda.
+1 ;
+2 FOR I=1:1:26
Begin DoDot:1
+3 SET PPE=$PIECE($GET(^PRST(458.7,MIEN,9,I,0)),U)
+4 IF PPE=""
SET ^TMP($JOB,"INCESR","NO DATA")=""
QUIT
+5 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+6 ; Pay Period is not opened yet.
if 'PPI
QUIT
+7 SET QUIT=0
+8 FOR DAY=1:1:14
Begin DoDot:2
+9 SET ESRSTAT=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
+10 IF ESRSTAT<5
SET ^TMP($JOB,"INCESR",PPE)=""
SET QUIT=1
End DoDot:2
if QUIT
QUIT
End DoDot:1
+11 SET INDEX=INDEX+1
+12 SET TEXT=""
+13 ; Blank Lines
DO A1^PRSPUT1
DO A1^PRSPUT1
+14 SET TEXT="The following Pay Periods have days with incomplete daily ESRs: "
+15 DO A1^PRSPUT1
+16 SET (PPE,PPEX)=""
+17 FOR
SET PPE=$ORDER(^TMP($JOB,"INCESR",PPE))
if PPE=""
QUIT
Begin DoDot:1
+18 SET PPEX=$SELECT(PPEX="":PPE,1:PPEX_", "_PPE)
End DoDot:1
+19 ; Blank Line
SET TEXT=""
DO A1^PRSPUT1
+20 SET TEXT=PPEX
+21 DO A1^PRSPUT1
+22 KILL ^TMP($JOB,"INCESR")
+23 ;
+24 ; Load and display any HR Initial comments
+25 SET MESSAGE=$GET(^PRST(458.7,MIEN,1))
+26 IF MESSAGE'=""
Begin DoDot:1
+27 SET TEXT=""
+28 ; Blank Line
DO A1^PRSPUT1
+29 FOR J=1:1:3
Begin DoDot:2
+30 SET HEADER=$SELECT(J=1:"HR Initial Comments: ",1:"")
+31 DO TEXT^PRSPDM(HEADER,.MESSAGE)
+32 DO A1^PRSPUT1
End DoDot:2
+33 IF $Y>(IOSL-5)
DO PSE
if $DATA(DIRUT)
QUIT
End DoDot:1
+34 ;
+35 ; Load and display Termination information if any
+36 SET DATA4=$GET(^PRST(458.7,MIEN,4))
+37 SET TDAT=$PIECE(DATA4,U,1)
SET TERMBY=$PIECE(DATA4,U,2)
SET TERMDT=$PIECE(DATA4,U,3)
+38 IF TDAT'=""
Begin DoDot:1
+39 SET Y=TDAT
+40 DO DD^%DT
+41 SET TDAT=Y
+42 IF TDAT'=""
Begin DoDot:2
+43 SET TEXT=""
+44 ; Blank Line
DO A1^PRSPUT1
+45 SET TEXT=" Termination date: "_TDAT
+46 DO A1^PRSPUT1
End DoDot:2
End DoDot:1
+47 ;
+48 IF TERMBY'=""
Begin DoDot:1
+49 SET TERMBY=$PIECE($GET(^VA(200,TERMBY,0)),U,1)
+50 SET TEXT=" Terminated by: "_TERMBY
+51 DO A1^PRSPUT1
End DoDot:1
+52 ;
+53 IF TERMDT'=""
Begin DoDot:1
+54 SET Y=TERMDT
+55 DO DD^%DT
+56 SET TERMDT=Y
+57 IF TERMDT'=""
Begin DoDot:2
+58 SET TEXT="Date/Time Terminated: "_TERMDT
+59 DO A1^PRSPUT1
End DoDot:2
End DoDot:1
+60 IF $Y>(IOSL-5)
DO PSE
if $DATA(DIRUT)
QUIT
+61 ;
+62 SET MESSAGE=$GET(^PRST(458.7,MIEN,4.1))
+63 IF MESSAGE'=""
Begin DoDot:1
+64 SET TEXT=""
+65 ; Blank Line
DO A1^PRSPUT1
+66 FOR J=1:1:3
Begin DoDot:2
+67 SET HEADER=$SELECT(J=1:"HR's Termination Comments: ",1:"")
+68 DO TEXT^PRSPDM(HEADER,.MESSAGE)
+69 DO A1^PRSPUT1
End DoDot:2
+70 IF $Y>(IOSL-5)
DO PSE
if $DATA(DIRUT)
QUIT
End DoDot:1
+71 QUIT
PSE ; Pause for screen breaks
+1 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 WRITE !
+3 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
+4 IF $DATA(DIRUT)
SET QT=1
+5 WRITE @IOF
+6 QUIT
+7 ;
+8 ;====================================================================
+9 ;
H1 IF PG
IF $EXTRACT(IOST,1,2)="C-"
READ !!,"Press RETURN to Continue.",X:DTIME
if '$TEST!(X["^")
SET QT=1
+1 SET PG=PG+1
+2 QUIT
EX ; Clean up variables
+1 KILL ARRAY,CNT,D,D1,DASH,DATA0,DATA2,DATA3,DATA31,DATA4,DATA41,DATA4580
+2 KILL DAY,DAY1,DFN,DIRUT,EDAT,ENDAT,ESRSTAT,HEADER,HRS,I,ICOM
+3 KILL IDAYS,IEN,INDEX,J,MESSAGE,MIEN,MT,PDT,PG,POP,POT,PPEX,PRCNT,PRSIEN
+4 KILL PTPRC,PTPRCOM,RECONBY,RECONDAT,SDAT,TDAT,TERMBY,TERMDT,TEXT,TL
+5 KILL PPE,PPI,PRSALST,PRSAPGM,PRSTLV,PTPRMKS,QUIT,QT,RC,RCEX,SCRTTL
+6 KILL SEG,SSN,START,STAT,STATEX,STOP,T1,T1EX,TLI,TLSCREEN,TOT,TOTEX
+7 KILL X,Y,%DT,%ZIS
+8 QUIT
