Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSNCGP

PRSNCGP.m

Go to the documentation of this file. 
  1. PRSNCGP ;WOIFO-JAH - Release POC Record corrections for VANOD;11/03/09
  1.  ;;4.0;PAID;**126**;Sep 21, 1995;Build 59
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  Q
  1.  ;
  1. CRELEASE ; Routine provides functionality to release corrected records for
  1.  ; VANOD extraction. These are daily records with a CORRECTION STATUS
  1.  ; of Approved for a Day
  1.  ;
  1.  ;    Prompt Coordinator for Divisions to release (one, many, all) 
  1.  ;
  1.  N PRSINST,PPI,PPS,MMR,INSTCC
  1.  ;
  1.  D GETDIV^PRSNCGR(.PRSINST) Q:PRSINST<0
  1.  ;
  1.  ; Check all pay periods with approved corrections to released records.
  1.  ;
  1.  D PRECHK(.INSTCC,.PRSINST)
  1.  ;
  1.  ; do prelimary report of record status
  1.  ;
  1.  D CNTREP(.INSTCC)
  1.  Q:$G(INSTCC)=0
  1.  ;
  1.  S X=$$ASK^PRSLIB00() Q:X
  1.  ;
  1.  ;    prompt for mismatch report 
  1.  ;
  1.  S MMR=$$ASKMM^PRSNCGR() Q:MMR<0
  1.  ;
  1.  I MMR D
  1.  . N %ZIS,POP,IOP
  1.  . S %ZIS="MQ"
  1.  . D ^%ZIS
  1.  . Q:POP
  1.  . I $D(IO("Q")) D
  1.  .. K IO("Q")
  1.  .. N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
  1.  .. S ZTDESC="PRSN POC/ETA MISMATCH REPORT FOR POC CORRECTIONS"
  1.  .. S ZTRTN="MMREP^PRSNCGP"
  1.  .. S ZTSAVE("PRSINST(")=""
  1.  .. D ^%ZTLOAD
  1.  .. I $D(ZTSK) S ZTREQ="@" W !,"Request "_ZTSK_" Queued."
  1.  . E  D
  1.  .. D MMREP
  1.  ;
  1.  I $$SUREQ^PRSNCGR() D
  1.  . N %ZIS,POP,IOP
  1.  . S %ZIS="MQ"
  1.  . D ^%ZIS
  1.  . Q:POP
  1.  . I $D(IO("Q")) D
  1.  .. K IO("Q")
  1.  .. N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
  1.  .. N ZTDESC,ZTRTN,ZTSAVE
  1.  .. S ZTDESC="PRSN POC/ETA MISMATCH REPORT"
  1.  .. S ZTRTN="DRIVER^PRSNCGP"
  1.  .. S ZTSAVE("PRSINST(")=""
  1.  .. D ^%ZTLOAD
  1.  .. I $D(ZTSK) S ZTREQ="@" W !,"Request "_ZTSK_" Queued."
  1.  .E  D
  1.  .. D DRIVER
  1.  Q
  1. DRIVER ;
  1.  N REC,CNT,FIELD,SEGCNT,PC,CI,SN
  1.  U IO
  1.  S REC=0
  1.  F  S REC=$O(PRSINST(REC)) Q:REC'>0  D
  1.  .  S CI=+PRSINST(REC)
  1.  .  D GETS^DIQ(4,CI_",","99","E","FIELD(",,)
  1.  .  S SN=FIELD(4,CI_",",99,"E")
  1.  .  S CNT(CI)="0^0"
  1.  .;
  1.  .;  loop thru Approved Daily Corrections index (sorted by Division,
  1.  .;  pay period, nurse, day number)
  1.  .;
  1.  .  S (SEGCNT,PPI,RECCNT)=0
  1.  .  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
  1.  ..    S $P(CNT(CI),U)=$P(CNT(CI),U)+1
  1.  ..;
  1.  ..; build node with days corrected
  1.  ..;
  1.  ..    K CDS
  1.  ..    S I=0
  1.  ..    F  S I=$O(^PRSN(451,"ACA",CI,PPI,PRSIEN,I)) Q:I'>0  D
  1.  ...     S CDS(I)=""
  1.  ..;
  1.  ..;  get all records for the pay period
  1.  ..;
  1.  ..    K PC D EXTRECS^PRSNCGR(.PC,.RECCNT,PPI,PRSIEN)
  1.  ..;
  1.  ..;  trim days from PC that aren't impacted by corrections
  1.  ..;
  1.  ..   D TRIMPC(.PC,.CDS,PRSIEN)
  1.  ..;
  1.  ..; note that day 15 has data and we need to determine whether
  1.  ..; to file that days correction after filing for this pp
  1.  ..    S PCNX=0 I $D(PC(15)) S PCNX=1 K PC(15)
  1.  ..;
  1.  ..;   file all corrections in PC array 
  1.  ..;
  1.  ..    D FILEPP^PRSNCGR1(.PC,PRSIEN,PPI,CI,SN)
  1.  ..;
  1.  ..;   increment counter
  1.  ..;
  1.  ..    S $P(CNT(CI),U,2)=$P(CNT(CI),U,2)+$$PCCOUNT(.PC)
  1.  ..;
  1.  ..;  update daily POC record status from approved to released
  1.  ..;
  1.  ..    D UPDTPOC(.PC,PPI,PRSIEN,"R")
  1.  ..;
  1.  ..; File and update for day one of next pp, if necessary.
  1.  ..; If there is correction data from a two day tour of current pay
  1.  ..; period that impacts day 1 of next pay period and that pay
  1.  ..; period has been released then we need to include any data
  1.  ..; that is explicitly recorded on that day.  If there is also
  1.  ..; a correction on that day or that pay period is not released
  1.  ..; then we need do nothing as the release of that correction or pp
  1.  ..; will pick up the two day tour spillover.
  1.  ..;
  1.  ..  S NXTPPSTA=$P($G(^PRSN(451,PPI+1,"E",PRSIEN,0)),U,2)
  1.  ..  S NXTPPDAT=$D(^PRSN(451,PPI+1,"E",PRSIEN,"D",1,0))
  1.  ..  S NXTPPCOR=$D(^PRSN(451,"ACA",CI,PPI+1,PRSIEN,1))
  1.  ..    I PCNX,'NXTPPCOR,NXTPPSTA="R",NXTPPDAT D
  1.  ...      K PC D EXTRECS^PRSNCGR(.PC,.SEGCNT,PPI+1,PRSIEN)
  1.  ...;only need day one, so kill the rest
  1.  ...      N I F I=0,2:1:15 K PC(I)
  1.  ...      D FILEPP^PRSNCGR1(.PC,PRSIEN,PPI+1,CI,SN)
  1.  ...      S $P(CNT(CI),U,2)=$P(CNT(CI),U,2)+$$PCCOUNT(.PC)
  1.  ...      D UPDTPOC(.PC,PPI+1,PRSIEN,"R")
  1.  D RESULTS(.CNT)
  1.  ;
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. MMREP ;
  1.  N REC,CNT,FIELD,SEGCNT,PC,PPI,CI,PG,OUT,SN
  1.  U IO
  1.  S (PG,REC,OUT)=0
  1.  F  S REC=$O(PRSINST(REC)) Q:REC'>0!OUT  D
  1.  .  S CI=+PRSINST(REC)
  1.  .  D GETS^DIQ(4,CI_",","99","E","FIELD(",,)
  1.  .  S SN=FIELD(4,CI_",",99,"E")
  1.  .  S PRSIEN=0
  1.  .  S PPI=0
  1.  .  F  S PPI=$O(^PRSN(451,"ACA",CI,PPI)) Q:PPI'>0!OUT  D
  1.  ..    S PRSIEN=0
  1.  ..    F  S PRSIEN=$O(^PRSN(451,"ACA",CI,PPI,PRSIEN)) Q:PRSIEN'>0!OUT  D
  1.  ...      D PPMM^PRSNRMM(PRSIEN,PPI,.PG,.OUT)
  1.  ;
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. 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
  1.  ; i.e., we must resend days that have time from a corrected day
  1.  ; that cross midnight into them.
  1.  ;
  1.  N PRSD,CORSPIL
  1.  S PRSD=0
  1.  F  S PRSD=$O(PC(PRSD)) Q:PRSD'>0  D
  1.  .  S CORSPIL=0
  1.  .;
  1.  .; if prior day is a correction with spillover we must include today
  1.  .;
  1.  .  I $D(CDS(PRSD-1)),$$SPILLOVR($G(PC(PRSD-1)),PRSD-1) S CORSPIL=1
  1.  .;
  1.  .; kill days that aren't part of the correction set
  1.  .;
  1.  .  I '$D(CDS(PRSD))&('CORSPIL) K PC(PRSD)
  1.  ; 
  1.  Q
  1. SPILLOVR(SEGS,I) ; return true if a segment on this day crosses midnight
  1.  N SPILL,J
  1.  S (SPILL,J)=0
  1.  F  S J=$O(SEGS(I,J)) Q:J'>0!SPILL  D
  1.  .  I $P(SEGS(I,J),U,10)>2400 S SPILL=1
  1.  Q SPILL
  1.  ;
  1. PCCOUNT(ARRAY2D) ; COUNT records in 2D array with integer subscripts
  1.  N I,J,CNT
  1.  S (CNT,I)=0
  1.  F  S I=$O(ARRAY2D(I)) Q:I'>0  D
  1.  .  S J=0 F  S J=$O(ARRAY2D(I,J)) Q:J'>0  D
  1.  ..   S CNT=CNT+1
  1.  Q CNT
  1. RESULTS(CNT) ; Print results of the Release
  1.  N DIVI,DIVE,I,F,X,STNAME,STNUM
  1.  W @IOF,!!,?14,"POC CORRECTED RECORDS RELEASED RESULTS"
  1.  W !,?14,"======================================"
  1.  W !!,?30,"TOTAL",?42,"TOTAL"
  1.  W !,?4,"DIVISION",?30,"NURSES",?42,"RECORDS"
  1.  W !,?4,"========",?30,"======",?42,"======="
  1.  N I S I=0
  1.  F  S I=$O(CNT(I)) Q:I'>0  D
  1.  .  D GETS^DIQ(4,I_",",".01;99","EI","F(",,)
  1.  .  S STNUM=F(4,I_",",99,"E"),STNAME=F(4,I_",",.01,"E")
  1.  .  W !,?4,STNAME," (",STNUM,")",?30,$P(CNT(I),U),?44,$P(CNT(I),U,2)
  1.  W !!! S X=$$ASK^PRSLIB00(1)
  1.  Q
  1. PRECHK(INSTCC,PRSINST) ; Count up corrections by division
  1.  ;
  1.  ;  INPUT:
  1.  ;    PRSINST (required) array of institutions to check
  1.  ;  OUTPUT:
  1.  ;    INSTCC (returned by reference) Institution correction counts
  1.  ;         e.g.,  INSTCC(500)=32 
  1.  ;                INSTCC(16473)=10 
  1.  ;         Where the node is the institution # and it is set equal
  1.  ;         to the total number of corrections across all released
  1.  ;         pay periods.
  1.  ;
  1.  N REC,CNT,FIELD,STOP
  1.  ;
  1.  S (INSTCC,I)=0
  1.  F  S I=$O(PRSINST(I)) Q:I'>0  D
  1.  .  S INSTCC(+PRSINST(I))=0
  1.  ;
  1.  S I=0
  1.  F  S I=$O(INSTCC(I)) Q:I'>0  D
  1.  .  S PPI=0
  1.  .  F  S PPI=$O(^PRSN(451,"ACA",I,PPI)) Q:PPI'>0  D
  1.  ..  S PRSIEN=0
  1.  ..  F  S PRSIEN=$O(^PRSN(451,"ACA",I,PPI,PRSIEN)) Q:PRSIEN'>0  D
  1.  ...    S INSTCC=INSTCC+1
  1.  ...    S INSTCC(I)=INSTCC(I)+1
  1.  Q
  1. CNTREP(INSTCC) ;
  1.  N I,STNUM,STNAME,X
  1.  W @IOF,!!!,?20,"CORRECTION TOTALS BY DIVISION"
  1.  W !,?20,"============================="
  1.  ;
  1.  W !!,"DIVISION",?30,"# OF DAILY"
  1.  W !,?30,"DAILY CORRECTIONS"
  1.  S I=0
  1.  F  S I=$O(INSTCC(I)) Q:I'>0  D
  1.  .  D GETS^DIQ(4,I_",",".01;99","EI","F(",,)
  1.  .  S STNUM=F(4,I_",",99,"E"),STNAME=F(4,I_",",.01,"E")
  1.  .  W !,?4,STNAME," (",STNUM,")"
  1.  .  W ?30,$J(INSTCC(I),10,0)
  1.  I $G(INSTCC)=0 D
  1.  .  W !!,"  No approved corrections are ready for release."
  1.  .  W !!! S X=$$ASK^PRSLIB00(1)
  1.  Q
  1. UPDTPOCD(PPI,PRSIEN,PRSD,PRSV,STATUS) ; update DAILY RECORD status for POC records
  1.  ; INPUT :
  1.  ;    PPI,PRSIEN,PRSD : Standard
  1.  ;    PRSV : (optional) if STATUS is (A)pproved PRSV must be defined
  1.  ;                      to the version number of the POC record
  1.  ;    STATUS: (optional) : set to (A)pproved
  1.  ;                                (R)eleased
  1.  ;                                (E)ntered
  1.  ;                                Null (remove status)
  1.  ;
  1.  N IENS,PRSFDA
  1.  S IENS=PRSD_","_PRSIEN_","_PPI_","
  1.  I STATUS="" S STATUS="@"
  1.  S PRSFDA(451.99,IENS,1)=STATUS
  1.  D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
  1.  I STATUS="A"&(PRSV>0) D
  1.  .;  update approver and date time of approval
  1.  .  K IENS,PRSFDA N %
  1.  .  S IENS=PRSV_","_PRSD_","_PRSIEN_","_PPI_","
  1.  .  S PRSFDA(451.999,IENS,1)=DUZ
  1.  .  D NOW^%DTC
  1.  .  S PRSFDA(451.999,IENS,2)=%
  1.  .  D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
  1.  Q
  1. UPDTPOC(PC,PPI,PRSIEN,STATUS) ; update POC daily record status
  1.  N IENS,FDA
  1.  S I=0
  1.  F  S I=$O(PC(I)) Q:I'>0  D
  1.  . S IENS=I_","_PRSIEN_","_PPI_","
  1.  . S FDA(451.99,IENS,1)=STATUS
  1.  D UPDATE^DIE("","FDA","IENS"),MSG^DIALOG()
  1.  Q