PRSPDM ; HISC/MGD - DISPLAY PT PHYSICIAN MEMORANDUM ;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
S PRSTLV=7
D TOP ; print header
P1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
W ! D ^DIC S (DFN,PRSIEN)=+Y K DIC G:DFN<1 EX
S TLE=$P($G(^PRSPC(DFN,0)),"^",8)
S DIC="^PRST(458,",DIC(0)="AEQM",DIC("A")="Select PAY PERIOD: "
W ! D ^DIC K DIC G:Y<1 EX
S PPI=+Y
S PPE=$P(Y,U,2)
D L1 ;ask device
G P1 ;ask for employee again
;====================================================================
TK ; TimeKeeper Entry
S PRSTLV=2 G T0
;====================================================================
SUP ; Supervisor Entry
S PRSTLV=3
T0 D TOP ; print header
D ^PRSAUTL G:TLI<1 EX
T1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
S DIC("S")="I $P(^(0),""^"",8)=TLE" S D="ATL"_TLE W ! D IX^DIC
S (DFN,PRSIEN)=+Y K DIC G:DFN<1 EX
S %DT="AEPX",%DT("A")="Posting Date: " W ! D ^%DT
G:Y<1 EX
S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
G EX:PPI<1
S PPE=$P($G(^PRST(458,PPI,0)),U,1)
D L1 ;ask device
;
G T1 ;ask for employee again
;====================================================================
EMP ; Employee Entry
S PRSTLV=1 D TOP S DFN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9)
I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0)),PRSIEN=DFN
I 'DFN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
S TLE=$P($G(^PRSPC(DFN,0)),"^",8)
S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=3040101 W ! D ^%DT
G:Y<1 EX
S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
G EX:PPI<1
S PPE=$P($G(^PRST(458,PPI,0)),U,1)
D L1 G EX
;====================================================================
TOP W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
W !?25,"DISPLAY PT PHYSICIAN MEMORANDA" Q
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^PRSPDM",PRSALST="PRSIEN^TLE^PPE^PPI"
. 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,'$D(DIRUT) S PG=PG+1 D H1
D ^%ZISC K %ZIS,IOP Q
;====================================================================
DIS ; Display Memorandum
;
S PDT=$G(^PRST(458,PPI,2)),DAY1=$P($G(^PRST(458,PPI,1)),U,1)
S STAT=$P($G(^PRST(458,PPI,"E",PRSIEN,0)),"^",2)
S MIEN=+$$MIEN^PRSPUT1(PRSIEN,DAY1),(PG,QT)=0
I 'MIEN D Q
. W !!,"The employee did not have a memorandum during the date specified."
;
DISPLAY ; Display memorandum information
W:$E(IOST,1,2)="C-" @IOF
S SCRTTL="DISPLAY PT PHYSICIAN MEMORANDA"
S ARRAY="^TMP($J,""PRSPDM"",",INDEX=1
D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,INDEX,PPI)
D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
D AL^PRSPUT3(PRSIEN,ARRAY)
D PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
Q:$D(DIRUT)
I $E(IOST,1,2)="C-" D
. S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
. I '$D(DIRUT) W @IOF
Q:$D(DIRUT)
;
ESRCHK ; Check for any incomplete ESR within the memoranda.
;
S QUIT=0
S PPIT=+$G(^PRST(458.7,MIEN,4)),PPIT=+$G(^PRST(458,"AD",PPIT))
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")="" S QUIT=1 Q
. S PPI=$O(^PRST(458,"B",PPE,0))
. Q:'PPI
. I PPIT,PPIT<PPI Q ; Don't display PP ESR beyond termination of memo
. 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
;
; List any PP exceptions
I $D(^TMP($J,"INCESR")) D
. 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)=""
. S TEXT="" D A1^PRSPUT1 ; Blank Line
. F S PPE=$O(^TMP($J,"INCESR",PPE)) Q:PPE="" D
. . S PPEX=$S(PPEX="":PPE,1:PPEX_", "_PPE)
. S TEXT=PPEX
I '$D(^TMP($J,"INCESR")) D
. S TEXT=" There are no pay periods with incomplete daily ESRs."
D A1^PRSPUT1
K ^TMP($J,"INCESR")
;
; Load and display any HR Initial comments
I PRSTLV'=1 D
. S MESSAGE=$G(^PRST(458.7,MIEN,1))
. Q:MESSAGE=""
. S TEXT=""
. D A1^PRSPUT1 ; Blank Line
. F J=1:1:3 D
. . S HEADER=$S(J=1:"HR Initial Comments: ",1:"")
. . D TEXT(HEADER,.MESSAGE)
. . D A1^PRSPUT1
. I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
;
; Load and display Termination information if any
I PRSTLV'=1 D
. 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))
. Q:MESSAGE=""
. 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(HEADER,.MESSAGE)
. . D A1^PRSPUT1
. I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
;
; Load and display PTP's reconciliation choice and comments
S DATA2=$G(^PRST(458.7,MIEN,2))
S PTPRC=$P(DATA2,U,1),MESSAGE=$P(DATA2,U,2)
I PTPRC'="" D
. S TEXT=""
. D A1^PRSPUT1 ; Blank Line
. S TEXT=$$EXTERNAL^DILFD(458.7,17,"",PTPRC)
. S TEXT=" PTP's Reconciliation Choice: "_TEXT
. D A1^PRSPUT1
I MESSAGE'="" D
. F J=1:1:3 D
. . S HEADER=$S(J=1:"PTP's Reconciliation Comments: ",1:"")
. . D TEXT(HEADER,.MESSAGE)
. . D A1^PRSPUT1
;
; Load and display HR's reconciliation info and comments
I PRSTLV'=1 D
. I $Y>(IOSL-7) D PSE Q:$D(DIRUT)
. S DATA3=$G(^PRST(458.7,MIEN,3))
. S RECONBY=$P(DATA3,U,1),RECONDAT=$P(DATA3,U,2)
. I RECONBY'="" D
. . S TEXT=""
. . D A1^PRSPUT1 ; Blank Line
. . S RECONBY=$P($G(^VA(200,RECONBY,0)),U,1)
. . S TEXT="Reconciled by: "_RECONBY
. . D A1^PRSPUT1
. I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
. I RECONDAT'="" D
. . S Y=RECONDAT
. . D DD^%DT
. . S RECONDAT=Y
. . I RECONDAT'="" D
. . . S TEXT="Reconciled on: "_RECONDAT
. . . D A1^PRSPUT1
. I $Y>(IOSL-7) D PSE Q:$D(DIRUT)
;
; HR Reconciliation Comments
I PRSTLV'=1 D
. S MESSAGE=$G(^PRST(458.7,MIEN,3.1))
. Q:MESSAGE=""
. S TEXT=""
. D A1^PRSPUT1 ; Blank Line
. F J=1:1:3 D
. . S HEADER=$S(J=1:"HR's Reconciliation Comments: ",1:"")
. . D TEXT(HEADER,.MESSAGE)
. . D A1^PRSPUT1
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 K DIR
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
;
TEXT(HEADER,MESSAGE) ;
N BREAK
S BREAK=0
I $L(HEADER)+$L(MESSAGE)<80 D Q
. S TEXT=HEADER_MESSAGE
. S MESSAGE=""
F I=(80-$L(HEADER)):-1:0 D Q:BREAK
. Q:$E(MESSAGE,I)'=" "
. S TEXT=HEADER_$E(MESSAGE,1,I)
. S MESSAGE=$E(MESSAGE,I+1,999)
. S BREAK=1
Q
;
EX ; Clean up variables
K ARRAY,D,D1,DASH,DATA0,DATA2,DATA3,DATA4,DAY
K DAY1,DFN,DIRUT,ESRSTAT,HRS,I,ICOM,IDAYS,INDEX,J,HEADER,MESSAGE
K MIEN,MT,PDT,PG,POP,PPE,PPEX,PPI,PPIT,PRSALST,PRSAPGM,PRSIEN,PRSTLV
K PTPRC,PTPRCOM,PTPRMKS,QUIT,QT,RC,RCEX,RECONBY,RECONDAT,SCRTTL,SEG
K SSN,START,STAT,STATEX,STOP,T1,T1EX,TDAT,TERMBY,TERMDT,TEXT,TLI,TLE
K TLSCREEN,TOT,TOTEX,X,Y,%DT,%ZIS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPDM 7704 printed Nov 22, 2024@17:37:56 Page 2
PRSPDM ; HISC/MGD - DISPLAY PT PHYSICIAN MEMORANDUM ;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 SET PRSTLV=7
+2 ; print header
DO TOP
P1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
+1 WRITE !
DO ^DIC
SET (DFN,PRSIEN)=+Y
KILL DIC
if DFN<1
GOTO EX
+2 SET TLE=$PIECE($GET(^PRSPC(DFN,0)),"^",8)
+3 SET DIC="^PRST(458,"
SET DIC(0)="AEQM"
SET DIC("A")="Select PAY PERIOD: "
+4 WRITE !
DO ^DIC
KILL DIC
if Y<1
GOTO EX
+5 SET PPI=+Y
+6 SET PPE=$PIECE(Y,U,2)
+7 ;ask device
DO L1
+8 ;ask for employee again
GOTO P1
+9 ;====================================================================
TK ; TimeKeeper Entry
+1 SET PRSTLV=2
GOTO T0
+2 ;====================================================================
SUP ; Supervisor Entry
+1 SET PRSTLV=3
T0 ; print header
DO TOP
+1 DO ^PRSAUTL
if TLI<1
GOTO EX
T1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
+1 SET DIC("S")="I $P(^(0),""^"",8)=TLE"
SET D="ATL"_TLE
WRITE !
DO IX^DIC
+2 SET (DFN,PRSIEN)=+Y
KILL DIC
if DFN<1
GOTO EX
+3 SET %DT="AEPX"
SET %DT("A")="Posting Date: "
WRITE !
DO ^%DT
+4 if Y<1
GOTO EX
+5 SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
+6 if PPI<1
GOTO EX
+7 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
+8 ;ask device
DO L1
+9 ;
+10 ;ask for employee again
GOTO T1
+11 ;====================================================================
EMP ; Employee Entry
+1 SET PRSTLV=1
DO TOP
SET DFN=""
SET SSN=$PIECE($GET(^VA(200,DUZ,1)),"^",9)
+2 IF SSN'=""
SET DFN=$ORDER(^PRSPC("SSN",SSN,0))
SET PRSIEN=DFN
+3 IF 'DFN
WRITE !!,*7,"Your SSN was not found in both the New Person & Employee File!"
GOTO EX
+4 SET TLE=$PIECE($GET(^PRSPC(DFN,0)),"^",8)
+5 SET %DT="AEPX"
SET %DT("A")="Posting Date: "
SET %DT(0)=3040101
WRITE !
DO ^%DT
+6 if Y<1
GOTO EX
+7 SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
+8 if PPI<1
GOTO EX
+9 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
+10 DO L1
GOTO EX
+11 ;====================================================================
TOP if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+1 WRITE !?25,"DISPLAY PT PHYSICIAN MEMORANDA"
QUIT
L1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
+1 DO ^%ZIS
KILL %ZIS,IOP
+2 if POP
QUIT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET PRSAPGM="DIS^PRSPDM"
SET PRSALST="PRSIEN^TLE^PPE^PPI"
+5 DO QUE^PRSAUTL
End DoDot:1
QUIT
+6 USE IO
DO DIS
+7 ; pause screen when employee to prevent scroll (other users prompted)
+8 IF $EXTRACT(IOST,1,2)="C-"
IF 'QT
IF PRSTLV=1
IF '$DATA(DIRUT)
SET PG=PG+1
DO H1
+9 DO ^%ZISC
KILL %ZIS,IOP
QUIT
+10 ;====================================================================
DIS ; Display Memorandum
+1 ;
+2 SET PDT=$GET(^PRST(458,PPI,2))
SET DAY1=$PIECE($GET(^PRST(458,PPI,1)),U,1)
+3 SET STAT=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),"^",2)
+4 SET MIEN=+$$MIEN^PRSPUT1(PRSIEN,DAY1)
SET (PG,QT)=0
+5 IF 'MIEN
Begin DoDot:1
+6 WRITE !!,"The employee did not have a memorandum during the date specified."
End DoDot:1
QUIT
+7 ;
DISPLAY ; Display memorandum information
+1 if $EXTRACT(IOST,1,2)="C-"
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,PPI)
+5 DO MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
+6 DO AL^PRSPUT3(PRSIEN,ARRAY)
+7 DO PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
+8 if $DATA(DIRUT)
QUIT
+9 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+10 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
+11 IF '$DATA(DIRUT)
WRITE @IOF
End DoDot:1
+12 if $DATA(DIRUT)
QUIT
+13 ;
ESRCHK ; Check for any incomplete ESR within the memoranda.
+1 ;
+2 SET QUIT=0
+3 SET PPIT=+$GET(^PRST(458.7,MIEN,4))
SET PPIT=+$GET(^PRST(458,"AD",PPIT))
+4 FOR I=1:1:26
Begin DoDot:1
+5 SET PPE=$PIECE($GET(^PRST(458.7,MIEN,9,I,0)),U)
+6 IF PPE=""
SET ^TMP($JOB,"INCESR","NO DATA")=""
SET QUIT=1
QUIT
+7 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+8 if 'PPI
QUIT
+9 ; Don't display PP ESR beyond termination of memo
IF PPIT
IF PPIT<PPI
QUIT
+10 FOR DAY=1:1:14
Begin DoDot:2
+11 SET ESRSTAT=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
+12 IF ESRSTAT<5
SET ^TMP($JOB,"INCESR",PPE)=""
SET QUIT=1
End DoDot:2
if QUIT
QUIT
End DoDot:1
+13 ;
+14 ; List any PP exceptions
+15 IF $DATA(^TMP($JOB,"INCESR"))
Begin DoDot:1
+16 SET INDEX=INDEX+1
+17 SET TEXT=""
+18 ; Blank Lines
DO A1^PRSPUT1
DO A1^PRSPUT1
+19 SET TEXT="The following Pay Periods have days with incomplete daily ESRs: "
+20 DO A1^PRSPUT1
+21 SET (PPE,PPEX)=""
+22 ; Blank Line
SET TEXT=""
DO A1^PRSPUT1
+23 FOR
SET PPE=$ORDER(^TMP($JOB,"INCESR",PPE))
if PPE=""
QUIT
Begin DoDot:2
+24 SET PPEX=$SELECT(PPEX="":PPE,1:PPEX_", "_PPE)
End DoDot:2
+25 SET TEXT=PPEX
End DoDot:1
+26 IF '$DATA(^TMP($JOB,"INCESR"))
Begin DoDot:1
+27 SET TEXT=" There are no pay periods with incomplete daily ESRs."
End DoDot:1
+28 DO A1^PRSPUT1
+29 KILL ^TMP($JOB,"INCESR")
+30 ;
+31 ; Load and display any HR Initial comments
+32 IF PRSTLV'=1
Begin DoDot:1
+33 SET MESSAGE=$GET(^PRST(458.7,MIEN,1))
+34 if MESSAGE=""
QUIT
+35 SET TEXT=""
+36 ; Blank Line
DO A1^PRSPUT1
+37 FOR J=1:1:3
Begin DoDot:2
+38 SET HEADER=$SELECT(J=1:"HR Initial Comments: ",1:"")
+39 DO TEXT(HEADER,.MESSAGE)
+40 DO A1^PRSPUT1
End DoDot:2
+41 IF $Y>(IOSL-5)
DO PSE
if $DATA(DIRUT)
QUIT
End DoDot:1
+42 ;
+43 ; Load and display Termination information if any
+44 IF PRSTLV'=1
Begin DoDot:1
+45 SET DATA4=$GET(^PRST(458.7,MIEN,4))
+46 SET TDAT=$PIECE(DATA4,U,1)
SET TERMBY=$PIECE(DATA4,U,2)
SET TERMDT=$PIECE(DATA4,U,3)
+47 IF TDAT'=""
Begin DoDot:2
+48 SET Y=TDAT
+49 DO DD^%DT
+50 SET TDAT=Y
+51 IF TDAT'=""
Begin DoDot:3
+52 SET TEXT=""
+53 ; Blank Line
DO A1^PRSPUT1
+54 SET TEXT=" Termination date: "_TDAT
+55 DO A1^PRSPUT1
End DoDot:3
End DoDot:2
+56 ;
+57 IF TERMBY'=""
Begin DoDot:2
+58 SET TERMBY=$PIECE($GET(^VA(200,TERMBY,0)),U,1)
+59 SET TEXT=" Terminated by: "_TERMBY
+60 DO A1^PRSPUT1
End DoDot:2
+61 ;
+62 IF TERMDT'=""
Begin DoDot:2
+63 SET Y=TERMDT
+64 DO DD^%DT
+65 SET TERMDT=Y
+66 IF TERMDT'=""
Begin DoDot:3
+67 SET TEXT="Date/Time Terminated: "_TERMDT
+68 DO A1^PRSPUT1
End DoDot:3
End DoDot:2
+69 IF $Y>(IOSL-5)
DO PSE
if $DATA(DIRUT)
QUIT
+70 ;
+71 SET MESSAGE=$GET(^PRST(458.7,MIEN,4.1))
+72 if MESSAGE=""
QUIT
+73 SET TEXT=""
+74 ; Blank Line
DO A1^PRSPUT1
+75 FOR J=1:1:3
Begin DoDot:2
+76 SET HEADER=$SELECT(J=1:"HR's Termination Comments: ",1:"")
+77 DO TEXT(HEADER,.MESSAGE)
+78 DO A1^PRSPUT1
End DoDot:2
+79 IF $Y>(IOSL-5)
DO PSE
if $DATA(DIRUT)
QUIT
End DoDot:1
+80 ;
+81 ; Load and display PTP's reconciliation choice and comments
+82 SET DATA2=$GET(^PRST(458.7,MIEN,2))
+83 SET PTPRC=$PIECE(DATA2,U,1)
SET MESSAGE=$PIECE(DATA2,U,2)
+84 IF PTPRC'=""
Begin DoDot:1
+85 SET TEXT=""
+86 ; Blank Line
DO A1^PRSPUT1
+87 SET TEXT=$$EXTERNAL^DILFD(458.7,17,"",PTPRC)
+88 SET TEXT=" PTP's Reconciliation Choice: "_TEXT
+89 DO A1^PRSPUT1
End DoDot:1
+90 IF MESSAGE'=""
Begin DoDot:1
+91 FOR J=1:1:3
Begin DoDot:2
+92 SET HEADER=$SELECT(J=1:"PTP's Reconciliation Comments: ",1:"")
+93 DO TEXT(HEADER,.MESSAGE)
+94 DO A1^PRSPUT1
End DoDot:2
End DoDot:1
+95 ;
+96 ; Load and display HR's reconciliation info and comments
+97 IF PRSTLV'=1
Begin DoDot:1
+98 IF $Y>(IOSL-7)
DO PSE
if $DATA(DIRUT)
QUIT
+99 SET DATA3=$GET(^PRST(458.7,MIEN,3))
+100 SET RECONBY=$PIECE(DATA3,U,1)
SET RECONDAT=$PIECE(DATA3,U,2)
+101 IF RECONBY'=""
Begin DoDot:2
+102 SET TEXT=""
+103 ; Blank Line
DO A1^PRSPUT1
+104 SET RECONBY=$PIECE($GET(^VA(200,RECONBY,0)),U,1)
+105 SET TEXT="Reconciled by: "_RECONBY
+106 DO A1^PRSPUT1
End DoDot:2
+107 IF $Y>(IOSL-5)
DO PSE
if $DATA(DIRUT)
QUIT
+108 IF RECONDAT'=""
Begin DoDot:2
+109 SET Y=RECONDAT
+110 DO DD^%DT
+111 SET RECONDAT=Y
+112 IF RECONDAT'=""
Begin DoDot:3
+113 SET TEXT="Reconciled on: "_RECONDAT
+114 DO A1^PRSPUT1
End DoDot:3
End DoDot:2
+115 IF $Y>(IOSL-7)
DO PSE
if $DATA(DIRUT)
QUIT
End DoDot:1
+116 ;
+117 ; HR Reconciliation Comments
+118 IF PRSTLV'=1
Begin DoDot:1
+119 SET MESSAGE=$GET(^PRST(458.7,MIEN,3.1))
+120 if MESSAGE=""
QUIT
+121 SET TEXT=""
+122 ; Blank Line
DO A1^PRSPUT1
+123 FOR J=1:1:3
Begin DoDot:2
+124 SET HEADER=$SELECT(J=1:"HR's Reconciliation Comments: ",1:"")
+125 DO TEXT(HEADER,.MESSAGE)
+126 DO A1^PRSPUT1
End DoDot:2
End DoDot:1
+127 QUIT
+128 ;
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
KILL DIR
+4 WRITE @IOF
+5 QUIT
+6 ;
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
+3 ;
TEXT(HEADER,MESSAGE) ;
+1 NEW BREAK
+2 SET BREAK=0
+3 IF $LENGTH(HEADER)+$LENGTH(MESSAGE)<80
Begin DoDot:1
+4 SET TEXT=HEADER_MESSAGE
+5 SET MESSAGE=""
End DoDot:1
QUIT
+6 FOR I=(80-$LENGTH(HEADER)):-1:0
Begin DoDot:1
+7 if $EXTRACT(MESSAGE,I)'=" "
QUIT
+8 SET TEXT=HEADER_$EXTRACT(MESSAGE,1,I)
+9 SET MESSAGE=$EXTRACT(MESSAGE,I+1,999)
+10 SET BREAK=1
End DoDot:1
if BREAK
QUIT
+11 QUIT
+12 ;
EX ; Clean up variables
+1 KILL ARRAY,D,D1,DASH,DATA0,DATA2,DATA3,DATA4,DAY
+2 KILL DAY1,DFN,DIRUT,ESRSTAT,HRS,I,ICOM,IDAYS,INDEX,J,HEADER,MESSAGE
+3 KILL MIEN,MT,PDT,PG,POP,PPE,PPEX,PPI,PPIT,PRSALST,PRSAPGM,PRSIEN,PRSTLV
+4 KILL PTPRC,PTPRCOM,PTPRMKS,QUIT,QT,RC,RCEX,RECONBY,RECONDAT,SCRTTL,SEG
+5 KILL SSN,START,STAT,STATEX,STOP,T1,T1EX,TDAT,TERMBY,TERMDT,TEXT,TLI,TLE
+6 KILL TLSCREEN,TOT,TOTEX,X,Y,%DT,%ZIS
+7 QUIT
