PRSNCGP ;WOIFO-JAH - Release POC Record corrections for VANOD;11/03/09
;;4.0;PAID;**126**;Sep 21, 1995;Build 59
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
CRELEASE ; Routine provides functionality to release corrected records for
; VANOD extraction. These are daily records with a CORRECTION STATUS
; of Approved for a Day
;
; Prompt Coordinator for Divisions to release (one, many, all)
;
N PRSINST,PPI,PPS,MMR,INSTCC
;
D GETDIV^PRSNCGR(.PRSINST) Q:PRSINST<0
;
; Check all pay periods with approved corrections to released records.
;
D PRECHK(.INSTCC,.PRSINST)
;
; do prelimary report of record status
;
D CNTREP(.INSTCC)
Q:$G(INSTCC)=0
;
S X=$$ASK^PRSLIB00() Q:X
;
; prompt for mismatch report
;
S MMR=$$ASKMM^PRSNCGR() Q:MMR<0
;
I MMR D
. N %ZIS,POP,IOP
. S %ZIS="MQ"
. D ^%ZIS
. Q:POP
. I $D(IO("Q")) D
.. K IO("Q")
.. N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
.. S ZTDESC="PRSN POC/ETA MISMATCH REPORT FOR POC CORRECTIONS"
.. S ZTRTN="MMREP^PRSNCGP"
.. S ZTSAVE("PRSINST(")=""
.. D ^%ZTLOAD
.. I $D(ZTSK) S ZTREQ="@" W !,"Request "_ZTSK_" Queued."
. E D
.. D MMREP
;
I $$SUREQ^PRSNCGR() D
. N %ZIS,POP,IOP
. S %ZIS="MQ"
. D ^%ZIS
. Q:POP
. I $D(IO("Q")) D
.. K IO("Q")
.. N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
.. N ZTDESC,ZTRTN,ZTSAVE
.. S ZTDESC="PRSN POC/ETA MISMATCH REPORT"
.. S ZTRTN="DRIVER^PRSNCGP"
.. S ZTSAVE("PRSINST(")=""
.. D ^%ZTLOAD
.. I $D(ZTSK) S ZTREQ="@" W !,"Request "_ZTSK_" Queued."
.E D
.. D DRIVER
Q
DRIVER ;
N REC,CNT,FIELD,SEGCNT,PC,CI,SN
U IO
S REC=0
F S REC=$O(PRSINST(REC)) Q:REC'>0 D
. S CI=+PRSINST(REC)
. D GETS^DIQ(4,CI_",","99","E","FIELD(",,)
. S SN=FIELD(4,CI_",",99,"E")
. S CNT(CI)="0^0"
.;
.; loop thru Approved Daily Corrections index (sorted by Division,
.; pay period, nurse, day number)
.;
. S (SEGCNT,PPI,RECCNT)=0
. F S PPI=$O(^PRSN(451,"ACA",CI,PPI)) Q:PPI'>0 S PRSIEN=0 F S PRSIEN=$O(^PRSN(451,"ACA",CI,PPI,PRSIEN)) Q:PRSIEN'>0 D
.. S $P(CNT(CI),U)=$P(CNT(CI),U)+1
..;
..; build node with days corrected
..;
.. K CDS
.. S I=0
.. F S I=$O(^PRSN(451,"ACA",CI,PPI,PRSIEN,I)) Q:I'>0 D
... S CDS(I)=""
..;
..; get all records for the pay period
..;
.. K PC D EXTRECS^PRSNCGR(.PC,.RECCNT,PPI,PRSIEN)
..;
..; trim days from PC that aren't impacted by corrections
..;
.. D TRIMPC(.PC,.CDS,PRSIEN)
..;
..; note that day 15 has data and we need to determine whether
..; to file that days correction after filing for this pp
.. S PCNX=0 I $D(PC(15)) S PCNX=1 K PC(15)
..;
..; file all corrections in PC array
..;
.. D FILEPP^PRSNCGR1(.PC,PRSIEN,PPI,CI,SN)
..;
..; increment counter
..;
.. S $P(CNT(CI),U,2)=$P(CNT(CI),U,2)+$$PCCOUNT(.PC)
..;
..; update daily POC record status from approved to released
..;
.. D UPDTPOC(.PC,PPI,PRSIEN,"R")
..;
..; File and update for day one of next pp, if necessary.
..; If there is correction data from a two day tour of current pay
..; period that impacts day 1 of next pay period and that pay
..; period has been released then we need to include any data
..; that is explicitly recorded on that day. If there is also
..; a correction on that day or that pay period is not released
..; then we need do nothing as the release of that correction or pp
..; will pick up the two day tour spillover.
..;
.. S NXTPPSTA=$P($G(^PRSN(451,PPI+1,"E",PRSIEN,0)),U,2)
.. S NXTPPDAT=$D(^PRSN(451,PPI+1,"E",PRSIEN,"D",1,0))
.. S NXTPPCOR=$D(^PRSN(451,"ACA",CI,PPI+1,PRSIEN,1))
.. I PCNX,'NXTPPCOR,NXTPPSTA="R",NXTPPDAT D
... K PC D EXTRECS^PRSNCGR(.PC,.SEGCNT,PPI+1,PRSIEN)
...;only need day one, so kill the rest
... N I F I=0,2:1:15 K PC(I)
... D FILEPP^PRSNCGR1(.PC,PRSIEN,PPI+1,CI,SN)
... S $P(CNT(CI),U,2)=$P(CNT(CI),U,2)+$$PCCOUNT(.PC)
... D UPDTPOC(.PC,PPI+1,PRSIEN,"R")
D RESULTS(.CNT)
;
D ^%ZISC
Q
;
MMREP ;
N REC,CNT,FIELD,SEGCNT,PC,PPI,CI,PG,OUT,SN
U IO
S (PG,REC,OUT)=0
F S REC=$O(PRSINST(REC)) Q:REC'>0!OUT D
. S CI=+PRSINST(REC)
. D GETS^DIQ(4,CI_",","99","E","FIELD(",,)
. S SN=FIELD(4,CI_",",99,"E")
. S PRSIEN=0
. S PPI=0
. F S PPI=$O(^PRSN(451,"ACA",CI,PPI)) Q:PPI'>0!OUT D
.. S PRSIEN=0
.. F S PRSIEN=$O(^PRSN(451,"ACA",CI,PPI,PRSIEN)) Q:PRSIEN'>0!OUT D
... D PPMM^PRSNRMM(PRSIEN,PPI,.PG,.OUT)
;
D ^%ZISC
Q
;
TRIMPC(PC,CDS,PRSIEN) ;Trim days from pay per array that are not either
; a corrected day or a day impacted by the correction
; i.e., we must resend days that have time from a corrected day
; that cross midnight into them.
;
N PRSD,CORSPIL
S PRSD=0
F S PRSD=$O(PC(PRSD)) Q:PRSD'>0 D
. S CORSPIL=0
.;
.; if prior day is a correction with spillover we must include today
.;
. I $D(CDS(PRSD-1)),$$SPILLOVR($G(PC(PRSD-1)),PRSD-1) S CORSPIL=1
.;
.; kill days that aren't part of the correction set
.;
. I '$D(CDS(PRSD))&('CORSPIL) K PC(PRSD)
;
Q
SPILLOVR(SEGS,I) ; return true if a segment on this day crosses midnight
N SPILL,J
S (SPILL,J)=0
F S J=$O(SEGS(I,J)) Q:J'>0!SPILL D
. I $P(SEGS(I,J),U,10)>2400 S SPILL=1
Q SPILL
;
PCCOUNT(ARRAY2D) ; COUNT records in 2D array with integer subscripts
N I,J,CNT
S (CNT,I)=0
F S I=$O(ARRAY2D(I)) Q:I'>0 D
. S J=0 F S J=$O(ARRAY2D(I,J)) Q:J'>0 D
.. S CNT=CNT+1
Q CNT
RESULTS(CNT) ; Print results of the Release
N DIVI,DIVE,I,F,X,STNAME,STNUM
W @IOF,!!,?14,"POC CORRECTED RECORDS RELEASED RESULTS"
W !,?14,"======================================"
W !!,?30,"TOTAL",?42,"TOTAL"
W !,?4,"DIVISION",?30,"NURSES",?42,"RECORDS"
W !,?4,"========",?30,"======",?42,"======="
N I S I=0
F S I=$O(CNT(I)) Q:I'>0 D
. D GETS^DIQ(4,I_",",".01;99","EI","F(",,)
. S STNUM=F(4,I_",",99,"E"),STNAME=F(4,I_",",.01,"E")
. W !,?4,STNAME," (",STNUM,")",?30,$P(CNT(I),U),?44,$P(CNT(I),U,2)
W !!! S X=$$ASK^PRSLIB00(1)
Q
PRECHK(INSTCC,PRSINST) ; Count up corrections by division
;
; INPUT:
; PRSINST (required) array of institutions to check
; OUTPUT:
; INSTCC (returned by reference) Institution correction counts
; e.g., INSTCC(500)=32
; INSTCC(16473)=10
; Where the node is the institution # and it is set equal
; to the total number of corrections across all released
; pay periods.
;
N REC,CNT,FIELD,STOP
;
S (INSTCC,I)=0
F S I=$O(PRSINST(I)) Q:I'>0 D
. S INSTCC(+PRSINST(I))=0
;
S I=0
F S I=$O(INSTCC(I)) Q:I'>0 D
. S PPI=0
. F S PPI=$O(^PRSN(451,"ACA",I,PPI)) Q:PPI'>0 D
.. S PRSIEN=0
.. F S PRSIEN=$O(^PRSN(451,"ACA",I,PPI,PRSIEN)) Q:PRSIEN'>0 D
... S INSTCC=INSTCC+1
... S INSTCC(I)=INSTCC(I)+1
Q
CNTREP(INSTCC) ;
N I,STNUM,STNAME,X
W @IOF,!!!,?20,"CORRECTION TOTALS BY DIVISION"
W !,?20,"============================="
;
W !!,"DIVISION",?30,"# OF DAILY"
W !,?30,"DAILY CORRECTIONS"
S I=0
F S I=$O(INSTCC(I)) Q:I'>0 D
. D GETS^DIQ(4,I_",",".01;99","EI","F(",,)
. S STNUM=F(4,I_",",99,"E"),STNAME=F(4,I_",",.01,"E")
. W !,?4,STNAME," (",STNUM,")"
. W ?30,$J(INSTCC(I),10,0)
I $G(INSTCC)=0 D
. W !!," No approved corrections are ready for release."
. W !!! S X=$$ASK^PRSLIB00(1)
Q
UPDTPOCD(PPI,PRSIEN,PRSD,PRSV,STATUS) ; update DAILY RECORD status for POC records
; INPUT :
; PPI,PRSIEN,PRSD : Standard
; PRSV : (optional) if STATUS is (A)pproved PRSV must be defined
; to the version number of the POC record
; STATUS: (optional) : set to (A)pproved
; (R)eleased
; (E)ntered
; Null (remove status)
;
N IENS,PRSFDA
S IENS=PRSD_","_PRSIEN_","_PPI_","
I STATUS="" S STATUS="@"
S PRSFDA(451.99,IENS,1)=STATUS
D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
I STATUS="A"&(PRSV>0) D
.; update approver and date time of approval
. K IENS,PRSFDA N %
. S IENS=PRSV_","_PRSD_","_PRSIEN_","_PPI_","
. S PRSFDA(451.999,IENS,1)=DUZ
. D NOW^%DTC
. S PRSFDA(451.999,IENS,2)=%
. D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
Q
UPDTPOC(PC,PPI,PRSIEN,STATUS) ; update POC daily record status
N IENS,FDA
S I=0
F S I=$O(PC(I)) Q:I'>0 D
. S IENS=I_","_PRSIEN_","_PPI_","
. S FDA(451.99,IENS,1)=STATUS
D UPDATE^DIE("","FDA","IENS"),MSG^DIALOG()
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSNCGP 8618 printed Apr 09, 2024@21:27:14 Page 2
PRSNCGP ;WOIFO-JAH - Release POC Record corrections for VANOD;11/03/09
+1 ;;4.0;PAID;**126**;Sep 21, 1995;Build 59
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
CRELEASE ; Routine provides functionality to release corrected records for
+1 ; VANOD extraction. These are daily records with a CORRECTION STATUS
+2 ; of Approved for a Day
+3 ;
+4 ; Prompt Coordinator for Divisions to release (one, many, all)
+5 ;
+6 NEW PRSINST,PPI,PPS,MMR,INSTCC
+7 ;
+8 DO GETDIV^PRSNCGR(.PRSINST)
if PRSINST<0
QUIT
+9 ;
+10 ; Check all pay periods with approved corrections to released records.
+11 ;
+12 DO PRECHK(.INSTCC,.PRSINST)
+13 ;
+14 ; do prelimary report of record status
+15 ;
+16 DO CNTREP(.INSTCC)
+17 if $GET(INSTCC)=0
QUIT
+18 ;
+19 SET X=$$ASK^PRSLIB00()
if X
QUIT
+20 ;
+21 ; prompt for mismatch report
+22 ;
+23 SET MMR=$$ASKMM^PRSNCGR()
if MMR<0
QUIT
+24 ;
+25 IF MMR
Begin DoDot:1
+26 NEW %ZIS,POP,IOP
+27 SET %ZIS="MQ"
+28 DO ^%ZIS
+29 if POP
QUIT
+30 IF $DATA(IO("Q"))
Begin DoDot:2
+31 KILL IO("Q")
+32 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
+33 SET ZTDESC="PRSN POC/ETA MISMATCH REPORT FOR POC CORRECTIONS"
+34 SET ZTRTN="MMREP^PRSNCGP"
+35 SET ZTSAVE("PRSINST(")=""
+36 DO ^%ZTLOAD
+37 IF $DATA(ZTSK)
SET ZTREQ="@"
WRITE !,"Request "_ZTSK_" Queued."
End DoDot:2
+38 IF '$TEST
Begin DoDot:2
+39 DO MMREP
End DoDot:2
End DoDot:1
+40 ;
+41 IF $$SUREQ^PRSNCGR()
Begin DoDot:1
+42 NEW %ZIS,POP,IOP
+43 SET %ZIS="MQ"
+44 DO ^%ZIS
+45 if POP
QUIT
+46 IF $DATA(IO("Q"))
Begin DoDot:2
+47 KILL IO("Q")
+48 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
+49 NEW ZTDESC,ZTRTN,ZTSAVE
+50 SET ZTDESC="PRSN POC/ETA MISMATCH REPORT"
+51 SET ZTRTN="DRIVER^PRSNCGP"
+52 SET ZTSAVE("PRSINST(")=""
+53 DO ^%ZTLOAD
+54 IF $DATA(ZTSK)
SET ZTREQ="@"
WRITE !,"Request "_ZTSK_" Queued."
End DoDot:2
+55 IF '$TEST
Begin DoDot:2
+56 DO DRIVER
End DoDot:2
End DoDot:1
+57 QUIT
DRIVER ;
+1 NEW REC,CNT,FIELD,SEGCNT,PC,CI,SN
+2 USE IO
+3 SET REC=0
+4 FOR
SET REC=$ORDER(PRSINST(REC))
if REC'>0
QUIT
Begin DoDot:1
+5 SET CI=+PRSINST(REC)
+6 DO GETS^DIQ(4,CI_",","99","E","FIELD(",,)
+7 SET SN=FIELD(4,CI_",",99,"E")
+8 SET CNT(CI)="0^0"
+9 ;
+10 ; loop thru Approved Daily Corrections index (sorted by Division,
+11 ; pay period, nurse, day number)
+12 ;
+13 SET (SEGCNT,PPI,RECCNT)=0
+14 FOR
SET PPI=$ORDER(^PRSN(451,"ACA",CI,PPI))
if PPI'>0
QUIT
SET PRSIEN=0
FOR
SET PRSIEN=$ORDER(^PRSN(451,"ACA",CI,PPI,PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:2
+15 SET $PIECE(CNT(CI),U)=$PIECE(CNT(CI),U)+1
+16 ;
+17 ; build node with days corrected
+18 ;
+19 KILL CDS
+20 SET I=0
+21 FOR
SET I=$ORDER(^PRSN(451,"ACA",CI,PPI,PRSIEN,I))
if I'>0
QUIT
Begin DoDot:3
+22 SET CDS(I)=""
End DoDot:3
+23 ;
+24 ; get all records for the pay period
+25 ;
+26 KILL PC
DO EXTRECS^PRSNCGR(.PC,.RECCNT,PPI,PRSIEN)
+27 ;
+28 ; trim days from PC that aren't impacted by corrections
+29 ;
+30 DO TRIMPC(.PC,.CDS,PRSIEN)
+31 ;
+32 ; note that day 15 has data and we need to determine whether
+33 ; to file that days correction after filing for this pp
+34 SET PCNX=0
IF $DATA(PC(15))
SET PCNX=1
KILL PC(15)
+35 ;
+36 ; file all corrections in PC array
+37 ;
+38 DO FILEPP^PRSNCGR1(.PC,PRSIEN,PPI,CI,SN)
+39 ;
+40 ; increment counter
+41 ;
+42 SET $PIECE(CNT(CI),U,2)=$PIECE(CNT(CI),U,2)+$$PCCOUNT(.PC)
+43 ;
+44 ; update daily POC record status from approved to released
+45 ;
+46 DO UPDTPOC(.PC,PPI,PRSIEN,"R")
+47 ;
+48 ; File and update for day one of next pp, if necessary.
+49 ; If there is correction data from a two day tour of current pay
+50 ; period that impacts day 1 of next pay period and that pay
+51 ; period has been released then we need to include any data
+52 ; that is explicitly recorded on that day. If there is also
+53 ; a correction on that day or that pay period is not released
+54 ; then we need do nothing as the release of that correction or pp
+55 ; will pick up the two day tour spillover.
+56 ;
+57 SET NXTPPSTA=$PIECE($GET(^PRSN(451,PPI+1,"E",PRSIEN,0)),U,2)
+58 SET NXTPPDAT=$DATA(^PRSN(451,PPI+1,"E",PRSIEN,"D",1,0))
+59 SET NXTPPCOR=$DATA(^PRSN(451,"ACA",CI,PPI+1,PRSIEN,1))
+60 IF PCNX
IF 'NXTPPCOR
IF NXTPPSTA="R"
IF NXTPPDAT
Begin DoDot:3
+61 KILL PC
DO EXTRECS^PRSNCGR(.PC,.SEGCNT,PPI+1,PRSIEN)
+62 ;only need day one, so kill the rest
+63 NEW I
FOR I=0,2:1:15
KILL PC(I)
+64 DO FILEPP^PRSNCGR1(.PC,PRSIEN,PPI+1,CI,SN)
+65 SET $PIECE(CNT(CI),U,2)=$PIECE(CNT(CI),U,2)+$$PCCOUNT(.PC)
+66 DO UPDTPOC(.PC,PPI+1,PRSIEN,"R")
End DoDot:3
End DoDot:2
End DoDot:1
+67 DO RESULTS(.CNT)
+68 ;
+69 DO ^%ZISC
+70 QUIT
+71 ;
MMREP ;
+1 NEW REC,CNT,FIELD,SEGCNT,PC,PPI,CI,PG,OUT,SN
+2 USE IO
+3 SET (PG,REC,OUT)=0
+4 FOR
SET REC=$ORDER(PRSINST(REC))
if REC'>0!OUT
QUIT
Begin DoDot:1
+5 SET CI=+PRSINST(REC)
+6 DO GETS^DIQ(4,CI_",","99","E","FIELD(",,)
+7 SET SN=FIELD(4,CI_",",99,"E")
+8 SET PRSIEN=0
+9 SET PPI=0
+10 FOR
SET PPI=$ORDER(^PRSN(451,"ACA",CI,PPI))
if PPI'>0!OUT
QUIT
Begin DoDot:2
+11 SET PRSIEN=0
+12 FOR
SET PRSIEN=$ORDER(^PRSN(451,"ACA",CI,PPI,PRSIEN))
if PRSIEN'>0!OUT
QUIT
Begin DoDot:3
+13 DO PPMM^PRSNRMM(PRSIEN,PPI,.PG,.OUT)
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;
+15 DO ^%ZISC
+16 QUIT
+17 ;
TRIMPC(PC,CDS,PRSIEN) ;Trim days from pay per array that are not either
+1 ; a corrected day or a day impacted by the correction
+2 ; i.e., we must resend days that have time from a corrected day
+3 ; that cross midnight into them.
+4 ;
+5 NEW PRSD,CORSPIL
+6 SET PRSD=0
+7 FOR
SET PRSD=$ORDER(PC(PRSD))
if PRSD'>0
QUIT
Begin DoDot:1
+8 SET CORSPIL=0
+9 ;
+10 ; if prior day is a correction with spillover we must include today
+11 ;
+12 IF $DATA(CDS(PRSD-1))
IF $$SPILLOVR($GET(PC(PRSD-1)),PRSD-1)
SET CORSPIL=1
+13 ;
+14 ; kill days that aren't part of the correction set
+15 ;
+16 IF '$DATA(CDS(PRSD))&('CORSPIL)
KILL PC(PRSD)
End DoDot:1
+17 ;
+18 QUIT
SPILLOVR(SEGS,I) ; return true if a segment on this day crosses midnight
+1 NEW SPILL,J
+2 SET (SPILL,J)=0
+3 FOR
SET J=$ORDER(SEGS(I,J))
if J'>0!SPILL
QUIT
Begin DoDot:1
+4 IF $PIECE(SEGS(I,J),U,10)>2400
SET SPILL=1
End DoDot:1
+5 QUIT SPILL
+6 ;
PCCOUNT(ARRAY2D) ; COUNT records in 2D array with integer subscripts
+1 NEW I,J,CNT
+2 SET (CNT,I)=0
+3 FOR
SET I=$ORDER(ARRAY2D(I))
if I'>0
QUIT
Begin DoDot:1
+4 SET J=0
FOR
SET J=$ORDER(ARRAY2D(I,J))
if J'>0
QUIT
Begin DoDot:2
+5 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+6 QUIT CNT
RESULTS(CNT) ; Print results of the Release
+1 NEW DIVI,DIVE,I,F,X,STNAME,STNUM
+2 WRITE @IOF,!!,?14,"POC CORRECTED RECORDS RELEASED RESULTS"
+3 WRITE !,?14,"======================================"
+4 WRITE !!,?30,"TOTAL",?42,"TOTAL"
+5 WRITE !,?4,"DIVISION",?30,"NURSES",?42,"RECORDS"
+6 WRITE !,?4,"========",?30,"======",?42,"======="
+7 NEW I
SET I=0
+8 FOR
SET I=$ORDER(CNT(I))
if I'>0
QUIT
Begin DoDot:1
+9 DO GETS^DIQ(4,I_",",".01;99","EI","F(",,)
+10 SET STNUM=F(4,I_",",99,"E")
SET STNAME=F(4,I_",",.01,"E")
+11 WRITE !,?4,STNAME," (",STNUM,")",?30,$PIECE(CNT(I),U),?44,$PIECE(CNT(I),U,2)
End DoDot:1
+12 WRITE !!!
SET X=$$ASK^PRSLIB00(1)
+13 QUIT
PRECHK(INSTCC,PRSINST) ; Count up corrections by division
+1 ;
+2 ; INPUT:
+3 ; PRSINST (required) array of institutions to check
+4 ; OUTPUT:
+5 ; INSTCC (returned by reference) Institution correction counts
+6 ; e.g., INSTCC(500)=32
+7 ; INSTCC(16473)=10
+8 ; Where the node is the institution # and it is set equal
+9 ; to the total number of corrections across all released
+10 ; pay periods.
+11 ;
+12 NEW REC,CNT,FIELD,STOP
+13 ;
+14 SET (INSTCC,I)=0
+15 FOR
SET I=$ORDER(PRSINST(I))
if I'>0
QUIT
Begin DoDot:1
+16 SET INSTCC(+PRSINST(I))=0
End DoDot:1
+17 ;
+18 SET I=0
+19 FOR
SET I=$ORDER(INSTCC(I))
if I'>0
QUIT
Begin DoDot:1
+20 SET PPI=0
+21 FOR
SET PPI=$ORDER(^PRSN(451,"ACA",I,PPI))
if PPI'>0
QUIT
Begin DoDot:2
+22 SET PRSIEN=0
+23 FOR
SET PRSIEN=$ORDER(^PRSN(451,"ACA",I,PPI,PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:3
+24 SET INSTCC=INSTCC+1
+25 SET INSTCC(I)=INSTCC(I)+1
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
CNTREP(INSTCC) ;
+1 NEW I,STNUM,STNAME,X
+2 WRITE @IOF,!!!,?20,"CORRECTION TOTALS BY DIVISION"
+3 WRITE !,?20,"============================="
+4 ;
+5 WRITE !!,"DIVISION",?30,"# OF DAILY"
+6 WRITE !,?30,"DAILY CORRECTIONS"
+7 SET I=0
+8 FOR
SET I=$ORDER(INSTCC(I))
if I'>0
QUIT
Begin DoDot:1
+9 DO GETS^DIQ(4,I_",",".01;99","EI","F(",,)
+10 SET STNUM=F(4,I_",",99,"E")
SET STNAME=F(4,I_",",.01,"E")
+11 WRITE !,?4,STNAME," (",STNUM,")"
+12 WRITE ?30,$JUSTIFY(INSTCC(I),10,0)
End DoDot:1
+13 IF $GET(INSTCC)=0
Begin DoDot:1
+14 WRITE !!," No approved corrections are ready for release."
+15 WRITE !!!
SET X=$$ASK^PRSLIB00(1)
End DoDot:1
+16 QUIT
UPDTPOCD(PPI,PRSIEN,PRSD,PRSV,STATUS) ; update DAILY RECORD status for POC records
+1 ; INPUT :
+2 ; PPI,PRSIEN,PRSD : Standard
+3 ; PRSV : (optional) if STATUS is (A)pproved PRSV must be defined
+4 ; to the version number of the POC record
+5 ; STATUS: (optional) : set to (A)pproved
+6 ; (R)eleased
+7 ; (E)ntered
+8 ; Null (remove status)
+9 ;
+10 NEW IENS,PRSFDA
+11 SET IENS=PRSD_","_PRSIEN_","_PPI_","
+12 IF STATUS=""
SET STATUS="@"
+13 SET PRSFDA(451.99,IENS,1)=STATUS
+14 DO UPDATE^DIE("","PRSFDA","IENS")
DO MSG^DIALOG()
+15 IF STATUS="A"&(PRSV>0)
Begin DoDot:1
+16 ; update approver and date time of approval
+17 KILL IENS,PRSFDA
NEW %
+18 SET IENS=PRSV_","_PRSD_","_PRSIEN_","_PPI_","
+19 SET PRSFDA(451.999,IENS,1)=DUZ
+20 DO NOW^%DTC
+21 SET PRSFDA(451.999,IENS,2)=%
+22 DO UPDATE^DIE("","PRSFDA","IENS")
DO MSG^DIALOG()
End DoDot:1
+23 QUIT
UPDTPOC(PC,PPI,PRSIEN,STATUS) ; update POC daily record status
+1 NEW IENS,FDA
+2 SET I=0
+3 FOR
SET I=$ORDER(PC(I))
if I'>0
QUIT
Begin DoDot:1
+4 SET IENS=I_","_PRSIEN_","_PPI_","
+5 SET FDA(451.99,IENS,1)=STATUS
End DoDot:1
+6 DO UPDATE^DIE("","FDA","IENS")
DO MSG^DIALOG()
+7 QUIT
