PRSNCGR1 ;WOIFO-JAH - Release POC Records for VANOD Extraction;10/16/09
;;4.0;PAID;**126,146**;Sep 21, 1995;Build 7
;;Per VHA Directive 6402, this routine should not be modified.
Q
;
FILEPP(PC,PRSIEN,PPI,INST,STATN) ; file pay per activity records for Nurse to extraction AND update extraction version number in 451
;
N PRSD,I,PRSFDA,PCDATA,X,X1,OTR,LOC,LOCDIV
S PRSD=0
F S PRSD=$O(PC(PRSD)) Q:PRSD'>0!(PRSD>14) D
.;
.; increment version number for this day's extraction
. D EXTVERS(.VNUM,PPI,PRSIEN,PRSD)
.;
. S I=0
. F S I=$O(PC(PRSD,I)) Q:I'>0 D
.. S PCDATA=PC(PRSD,I)
.. K PRSFDA,IEN
.. S LOC=$P(PCDATA,U,5)
.. S LOCDIV=$S(LOC="":"",1:$P($$ISACTIVE^PRSNUT01("",LOC),U,4))
.. S PRSFDA(451.7,"+1,",.01)=$P($G(^PRSN(451.7,0)),U,3)+1
.. S PRSFDA(451.7,"+1,",1)=$G(INST)
.. S PRSFDA(451.7,"+1,",2)=LOCDIV
.. S PRSFDA(451.7,"+1,",3)=VNUM
.. S PRSFDA(451.7,"+1,",4)=$P($G(^PRSPC(PRSIEN,0)),U,9)
.. S PRSFDA(451.7,"+1,",5)=+PRSIEN
.. S X=$P($G(^PRST(458,PPI,1)),U,PRSD)
.. S X1=$E(X,1,3)+1700_$E(X,4,7)
.. S PRSFDA(451.7,"+1,",6)=X1
.. S PRSFDA(451.7,"+1,",7)=$P(PCDATA,U,9) ; Start time
.. S PRSFDA(451.7,"+1,",8)=$P(PCDATA,U,10) ; Stop time
.. S PRSFDA(451.7,"+1,",9)=$P(PCDATA,U,4) ; POC type of time
.. S PRSFDA(451.7,"+1,",10)=LOC ; Point of care
.. S PRSFDA(451.7,"+1,",11)=$P(PCDATA,U,7) ; mand. ot?
..;
.. S OTR=$P(PCDATA,U,8)
.. I OTR>0 S OTR=$P($G(^PRSN(451.6,OTR,0)),U) ; OT reason
.. S PRSFDA(451.7,"+1,",12)=OTR
..; 451.5 type of wrk
.. S PRSFDA(451.7,"+1,",13)=$P($G(^PRSN(451.5,+$P(PCDATA,U,6),0)),U)
.. S PRSFDA(451.7,"+1,",14)=DT ; release date
.. S PRSFDA(451.7,"+1,",15)=$P(^PRSN(451,PPI,"E",PRSIEN,0),U,7) ; T&L WHEN APPROVED
.. D UPDATE^DIE("","PRSFDA","IEN"),MSG^DIALOG()
Q
;
EXTVERS(VNUM,PPI,PRSIEN,PRSD) ; update extraction version in POC records file
;
; RETURN: VNUM-the version number of the extraction for the
; day (PRSD = 1-14) of the pay period.
;
; increment Extraction Version number. If no data on node then
; we are dealing with the initial extraction for 2nd day of a
; two day tour, so add a node and set version to 1. Subsequent
; releases to day will then have the correct version number.
;
K FDA,IENS
;
I $D(^PRSN(451,PPI,"E",PRSIEN,"D",PRSD,0)) D
. S IENS=PRSD_","_PRSIEN_","_PPI_","
. S VNUM=1+$P($G(^PRSN(451,PPI,"E",PRSIEN,"D",PRSD,0)),U,3)
E D
. S IENS="+1,"_PRSIEN_","_PPI_","
. S IENS(1)=PRSD
. S VNUM=1
. S FDA(451.99,IENS,.01)=PRSD
S FDA(451.99,IENS,2)=VNUM
;
D UPDATE^DIE("","FDA","IENS"),MSG^DIALOG()
Q
;
UPDTPOC(PPI,PRSIEN,STATUS,RETURN) ; update pay period status for nurse POC records
; INPUT:
; PPI, PRSIEN: Standard
; STATUS: POC pay period status (E)ntered, (A)pproved, (R)eleased
; RETURN: (optional) flag set to true to indicate the pay period
; is being returned
N IENS,PRSFDA,PRIMLOC
S IENS=PRSIEN_","_PPI_","
S PRSFDA(451.09,IENS,1)=STATUS
I STATUS="A" D
. S PRIMLOC=+$$PRIMLOC^PRSNUT03(+$G(^PRSPC(PRSIEN,200)))
. S PRSFDA(451.09,IENS,4)=$P($$DIV^PRSNUT03("N",+PRIMLOC),U,3)
. S PRSFDA(451.09,IENS,2)=DUZ
. N %,X,%I,%H D NOW^%DTC
. S PRSFDA(451.09,IENS,3)=%
. S PRSFDA(451.09,IENS,5)=PRIMLOC
. ;PRS*4.0*146 SETS the PRSFDA node below to the internal value of the T&L UNIT code
. N TLE S TLE=$P($G(^PRSPC(PRSIEN,0)),U,8)
. I TLE'="" S PRSFDA(451.09,IENS,6)=$O(^PRST(455.5,"B",TLE,""))
I STATUS="E"&$G(RETURN) D
. S PRSFDA(451.09,IENS,4)="@"
. S PRSFDA(451.09,IENS,2)="@"
. S PRSFDA(451.09,IENS,3)="@"
. S PRSFDA(451.09,IENS,5)="@"
. S PRSFDA(451.09,IENS,6)="@"
D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
Q
UPDTPP(PPI,CI,NRSCNT,RECNT) ; update division release history for pay period
N IENS,PRSFDA
S IENS="+1,"_PPI_","
S PRSFDA(451.06,IENS,.01)=CI
S PRSFDA(451.06,IENS,1)=DUZ
N %,X,%I,%H D NOW^%DTC
S PRSFDA(451.06,IENS,2)=%
S PRSFDA(451.06,IENS,3)=NRSCNT
S PRSFDA(451.06,IENS,4)=RECNT
D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
Q
;
CNTREP(PRSINST,PPI) ; Report on the record status for each division
;
; INPUT: PRSINST- array of instituions
;
N REC,PRECNT,FIELD,PC,DIV,CI,PRSIEN,PRIM,SN
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 PRECNT(CI)="0^0^0"
.;
.; count up entered records
.;
. S PRSIEN=0
. F S PRSIEN=$O(^PRSN(451,"AE",PRSIEN)) Q:PRSIEN'>0 D
.. S PRIM=$$PRIMLOC^PRSNUT03(+$G(^PRSPC(PRSIEN,200)))
.. S DIV=$P($$ISACTIVE^PRSNUT01(DT,+PRIM),U,4)
.. I (DIV=CI),($D(^PRSN(451,"AE",PRSIEN,PPI))) D
... S $P(PRECNT(CI),U)=$P(PRECNT(CI),U)+1
.;
.; count up approved records
.;
. S PRSIEN=0
. F S PRSIEN=$O(^PRSN(451,"AA",CI,PPI,PRSIEN)) Q:PRSIEN'>0 D
.. S $P(PRECNT(CI),U,2)=$P(PRECNT(CI),U,2)+1
.;
.; count up released records
.;
. S PRSIEN=0
. F S PRSIEN=$O(^PRSN(451,"AR",CI,PPI,PRSIEN)) Q:PRSIEN'>0 D
.. S $P(PRECNT(CI),U,3)=$P(PRECNT(CI),U,3)+1
;
; Display counts for the division
;
W @IOF,!!!,?14,"Pay Period ",$P($G(^PRST(458,PPI,0)),U)," Statistics"
N DIVI,DIVE,I,F,X
W !,?14,"==============================="
W !!,?26,"NURSES POINT OF CARE PAY PERIOD RECORD STATUS"
W !,?4,"DIVISION",?41,"UNAPPROVED",?54,"APPROVED",?66,"RELEASED"
W !,?4,"========",?41,"==========",?54,"========",?66,"========"
N I,STNUM,STNAME S I=0
F S I=$O(PRECNT(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 ?42,$J($P(PRECNT(I),U),8)
. W ?54,$J($P(PRECNT(I),U,2),8)
. W ?66,$J($P(PRECNT(I),U,3),8)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSNCGR1 5940 printed Dec 13, 2024@02:27:08 Page 2
PRSNCGR1 ;WOIFO-JAH - Release POC Records for VANOD Extraction;10/16/09
+1 ;;4.0;PAID;**126,146**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
FILEPP(PC,PRSIEN,PPI,INST,STATN) ; file pay per activity records for Nurse to extraction AND update extraction version number in 451
+1 ;
+2 NEW PRSD,I,PRSFDA,PCDATA,X,X1,OTR,LOC,LOCDIV
+3 SET PRSD=0
+4 FOR
SET PRSD=$ORDER(PC(PRSD))
if PRSD'>0!(PRSD>14)
QUIT
Begin DoDot:1
+5 ;
+6 ; increment version number for this day's extraction
+7 DO EXTVERS(.VNUM,PPI,PRSIEN,PRSD)
+8 ;
+9 SET I=0
+10 FOR
SET I=$ORDER(PC(PRSD,I))
if I'>0
QUIT
Begin DoDot:2
+11 SET PCDATA=PC(PRSD,I)
+12 KILL PRSFDA,IEN
+13 SET LOC=$PIECE(PCDATA,U,5)
+14 SET LOCDIV=$SELECT(LOC="":"",1:$PIECE($$ISACTIVE^PRSNUT01("",LOC),U,4))
+15 SET PRSFDA(451.7,"+1,",.01)=$PIECE($GET(^PRSN(451.7,0)),U,3)+1
+16 SET PRSFDA(451.7,"+1,",1)=$GET(INST)
+17 SET PRSFDA(451.7,"+1,",2)=LOCDIV
+18 SET PRSFDA(451.7,"+1,",3)=VNUM
+19 SET PRSFDA(451.7,"+1,",4)=$PIECE($GET(^PRSPC(PRSIEN,0)),U,9)
+20 SET PRSFDA(451.7,"+1,",5)=+PRSIEN
+21 SET X=$PIECE($GET(^PRST(458,PPI,1)),U,PRSD)
+22 SET X1=$EXTRACT(X,1,3)+1700_$EXTRACT(X,4,7)
+23 SET PRSFDA(451.7,"+1,",6)=X1
+24 ; Start time
SET PRSFDA(451.7,"+1,",7)=$PIECE(PCDATA,U,9)
+25 ; Stop time
SET PRSFDA(451.7,"+1,",8)=$PIECE(PCDATA,U,10)
+26 ; POC type of time
SET PRSFDA(451.7,"+1,",9)=$PIECE(PCDATA,U,4)
+27 ; Point of care
SET PRSFDA(451.7,"+1,",10)=LOC
+28 ; mand. ot?
SET PRSFDA(451.7,"+1,",11)=$PIECE(PCDATA,U,7)
+29 ;
+30 SET OTR=$PIECE(PCDATA,U,8)
+31 ; OT reason
IF OTR>0
SET OTR=$PIECE($GET(^PRSN(451.6,OTR,0)),U)
+32 SET PRSFDA(451.7,"+1,",12)=OTR
+33 ; 451.5 type of wrk
+34 SET PRSFDA(451.7,"+1,",13)=$PIECE($GET(^PRSN(451.5,+$PIECE(PCDATA,U,6),0)),U)
+35 ; release date
SET PRSFDA(451.7,"+1,",14)=DT
+36 ; T&L WHEN APPROVED
SET PRSFDA(451.7,"+1,",15)=$PIECE(^PRSN(451,PPI,"E",PRSIEN,0),U,7)
+37 DO UPDATE^DIE("","PRSFDA","IEN")
DO MSG^DIALOG()
End DoDot:2
End DoDot:1
+38 QUIT
+39 ;
EXTVERS(VNUM,PPI,PRSIEN,PRSD) ; update extraction version in POC records file
+1 ;
+2 ; RETURN: VNUM-the version number of the extraction for the
+3 ; day (PRSD = 1-14) of the pay period.
+4 ;
+5 ; increment Extraction Version number. If no data on node then
+6 ; we are dealing with the initial extraction for 2nd day of a
+7 ; two day tour, so add a node and set version to 1. Subsequent
+8 ; releases to day will then have the correct version number.
+9 ;
+10 KILL FDA,IENS
+11 ;
+12 IF $DATA(^PRSN(451,PPI,"E",PRSIEN,"D",PRSD,0))
Begin DoDot:1
+13 SET IENS=PRSD_","_PRSIEN_","_PPI_","
+14 SET VNUM=1+$PIECE($GET(^PRSN(451,PPI,"E",PRSIEN,"D",PRSD,0)),U,3)
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 SET IENS="+1,"_PRSIEN_","_PPI_","
+17 SET IENS(1)=PRSD
+18 SET VNUM=1
+19 SET FDA(451.99,IENS,.01)=PRSD
End DoDot:1
+20 SET FDA(451.99,IENS,2)=VNUM
+21 ;
+22 DO UPDATE^DIE("","FDA","IENS")
DO MSG^DIALOG()
+23 QUIT
+24 ;
UPDTPOC(PPI,PRSIEN,STATUS,RETURN) ; update pay period status for nurse POC records
+1 ; INPUT:
+2 ; PPI, PRSIEN: Standard
+3 ; STATUS: POC pay period status (E)ntered, (A)pproved, (R)eleased
+4 ; RETURN: (optional) flag set to true to indicate the pay period
+5 ; is being returned
+6 NEW IENS,PRSFDA,PRIMLOC
+7 SET IENS=PRSIEN_","_PPI_","
+8 SET PRSFDA(451.09,IENS,1)=STATUS
+9 IF STATUS="A"
Begin DoDot:1
+10 SET PRIMLOC=+$$PRIMLOC^PRSNUT03(+$GET(^PRSPC(PRSIEN,200)))
+11 SET PRSFDA(451.09,IENS,4)=$PIECE($$DIV^PRSNUT03("N",+PRIMLOC),U,3)
+12 SET PRSFDA(451.09,IENS,2)=DUZ
+13 NEW %,X,%I,%H
DO NOW^%DTC
+14 SET PRSFDA(451.09,IENS,3)=%
+15 SET PRSFDA(451.09,IENS,5)=PRIMLOC
+16 ;PRS*4.0*146 SETS the PRSFDA node below to the internal value of the T&L UNIT code
+17 NEW TLE
SET TLE=$PIECE($GET(^PRSPC(PRSIEN,0)),U,8)
+18 IF TLE'=""
SET PRSFDA(451.09,IENS,6)=$ORDER(^PRST(455.5,"B",TLE,""))
End DoDot:1
+19 IF STATUS="E"&$GET(RETURN)
Begin DoDot:1
+20 SET PRSFDA(451.09,IENS,4)="@"
+21 SET PRSFDA(451.09,IENS,2)="@"
+22 SET PRSFDA(451.09,IENS,3)="@"
+23 SET PRSFDA(451.09,IENS,5)="@"
+24 SET PRSFDA(451.09,IENS,6)="@"
End DoDot:1
+25 DO UPDATE^DIE("","PRSFDA","IENS")
DO MSG^DIALOG()
+26 QUIT
UPDTPP(PPI,CI,NRSCNT,RECNT) ; update division release history for pay period
+1 NEW IENS,PRSFDA
+2 SET IENS="+1,"_PPI_","
+3 SET PRSFDA(451.06,IENS,.01)=CI
+4 SET PRSFDA(451.06,IENS,1)=DUZ
+5 NEW %,X,%I,%H
DO NOW^%DTC
+6 SET PRSFDA(451.06,IENS,2)=%
+7 SET PRSFDA(451.06,IENS,3)=NRSCNT
+8 SET PRSFDA(451.06,IENS,4)=RECNT
+9 DO UPDATE^DIE("","PRSFDA","IENS")
DO MSG^DIALOG()
+10 QUIT
+11 ;
CNTREP(PRSINST,PPI) ; Report on the record status for each division
+1 ;
+2 ; INPUT: PRSINST- array of instituions
+3 ;
+4 NEW REC,PRECNT,FIELD,PC,DIV,CI,PRSIEN,PRIM,SN
+5 SET REC=0
+6 FOR
SET REC=$ORDER(PRSINST(REC))
if REC'>0
QUIT
Begin DoDot:1
+7 SET CI=+PRSINST(REC)
+8 DO GETS^DIQ(4,CI_",","99","E","FIELD(",,)
+9 SET SN=FIELD(4,CI_",",99,"E")
+10 SET PRECNT(CI)="0^0^0"
+11 ;
+12 ; count up entered records
+13 ;
+14 SET PRSIEN=0
+15 FOR
SET PRSIEN=$ORDER(^PRSN(451,"AE",PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:2
+16 SET PRIM=$$PRIMLOC^PRSNUT03(+$GET(^PRSPC(PRSIEN,200)))
+17 SET DIV=$PIECE($$ISACTIVE^PRSNUT01(DT,+PRIM),U,4)
+18 IF (DIV=CI)
IF ($DATA(^PRSN(451,"AE",PRSIEN,PPI)))
Begin DoDot:3
+19 SET $PIECE(PRECNT(CI),U)=$PIECE(PRECNT(CI),U)+1
End DoDot:3
End DoDot:2
+20 ;
+21 ; count up approved records
+22 ;
+23 SET PRSIEN=0
+24 FOR
SET PRSIEN=$ORDER(^PRSN(451,"AA",CI,PPI,PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:2
+25 SET $PIECE(PRECNT(CI),U,2)=$PIECE(PRECNT(CI),U,2)+1
End DoDot:2
+26 ;
+27 ; count up released records
+28 ;
+29 SET PRSIEN=0
+30 FOR
SET PRSIEN=$ORDER(^PRSN(451,"AR",CI,PPI,PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:2
+31 SET $PIECE(PRECNT(CI),U,3)=$PIECE(PRECNT(CI),U,3)+1
End DoDot:2
End DoDot:1
+32 ;
+33 ; Display counts for the division
+34 ;
+35 WRITE @IOF,!!!,?14,"Pay Period ",$PIECE($GET(^PRST(458,PPI,0)),U)," Statistics"
+36 NEW DIVI,DIVE,I,F,X
+37 WRITE !,?14,"==============================="
+38 WRITE !!,?26,"NURSES POINT OF CARE PAY PERIOD RECORD STATUS"
+39 WRITE !,?4,"DIVISION",?41,"UNAPPROVED",?54,"APPROVED",?66,"RELEASED"
+40 WRITE !,?4,"========",?41,"==========",?54,"========",?66,"========"
+41 NEW I,STNUM,STNAME
SET I=0
+42 FOR
SET I=$ORDER(PRECNT(I))
if I'>0
QUIT
Begin DoDot:1
+43 DO GETS^DIQ(4,I_",",".01;99","EI","F(",,)
+44 SET STNUM=F(4,I_",",99,"E")
SET STNAME=F(4,I_",",.01,"E")
+45 WRITE !,?4,STNAME," (",STNUM,")"
+46 WRITE ?42,$JUSTIFY($PIECE(PRECNT(I),U),8)
+47 WRITE ?54,$JUSTIFY($PIECE(PRECNT(I),U,2),8)
+48 WRITE ?66,$JUSTIFY($PIECE(PRECNT(I),U,3),8)
End DoDot:1
+49 QUIT
