PRSNCGR ;WOIFO-JAH - Release POC Records for VANOD Extraction;10/16/09
;;4.0;PAID;**126**;Sep 21, 1995;Build 59
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
RELEASE ; Routine provides functionality to release records for
; VANOD extraction. I.e., search for POC records who's pay period
; status is approved and move those records to the extraction
; file. Records in the POC file may cross midnight, but we will
; split those records at midnight and report the activity on the
; day on which it occured.
;
; Prompt Coordinator for Divisions to release (one, many, all)
;
N PRSINST,PPI,PPS,MMR
;
D GETDIV(.PRSINST) Q:PRSINST<0
;
; Check all pay periods with approved records which are
; ready to be released.
;
D PPRELCHK(.PPS,.PRSINST)
;
; prompt for pay period
;
S PPI=$$GETPP(.PPS) Q:PPI'>0
;
;
; do prelimary report of record status
;
D CNTREP^PRSNCGR1(.PRSINST,PPI)
;
I '$D(PPS("P",PPI)) D Q
. W !!,"There are no records in pay period ",$P($G(^PRST(458,PPI,0)),U)," approved for release."
. W !! S X=$$ASK^PRSLIB00(1)
;
; prompt for mismatch report
;
S MMR=$$ASKMM() 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"
.. S ZTRTN="MMREP^PRSNCGR"
.. S ZTSAVE("PPI")=""
.. S ZTSAVE("PRSINST(")=""
.. D ^%ZTLOAD
.. I $D(ZTSK) S ZTREQ="@" W !,"Request "_ZTSK_" Queued."
. E D
.. D MMREP
;
I $$SUREQ() 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 RELEASE REPORT"
.. S ZTRTN="DRIVER^PRSNCGR"
.. S ZTSAVE("PPI")=""
.. S ZTSAVE("PRSINST(")=""
.. D ^%ZTLOAD
.. I $D(ZTSK) S ZTREQ="@" W !,"Request "_ZTSK_" Queued."
. E D
.. D DRIVER
Q
MMREP ;
N REC,CNT,FIELD,SEGCNT,PC,OUT,PG,CI,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
. F S PRSIEN=$O(^PRSN(451,"AA",CI,PPI,PRSIEN)) Q:PRSIEN'>0!OUT D
.. D PPMM^PRSNRMM(PRSIEN,PPI,.PG,.OUT)
D ^%ZISC
Q
;
DRIVER ;
N REC,CI,SN,CNT,PRSIEN,SEGCNT,PC
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"
. S PRSIEN=0
. F S PRSIEN=$O(^PRSN(451,"AA",CI,PPI,PRSIEN)) Q:PRSIEN'>0 D
.. S SEGCNT=0
.. S $P(CNT(CI),U)=$P(CNT(CI),U)+1
.. K PC D EXTRECS(.PC,.SEGCNT,PPI,PRSIEN)
.. D FILEPP^PRSNCGR1(.PC,PRSIEN,PPI,CI,SN)
.. S $P(CNT(CI),U,2)=$P(CNT(CI),U,2)+SEGCNT
.. D UPDTPOC^PRSNCGR1(PPI,PRSIEN,"R")
.; if any records were released then update the release history for
.; for this division
. I $P(CNT(CI),U,2)>0 D
.. D UPDTPP^PRSNCGR1(PPI,CI,$P(CNT(CI),U),$P(CNT(CI),U,2))
D RESULTS(.CNT,PPI)
;
D ^%ZISC
Q
;
GETPP(PPS) ;prompt for and return pay period
; Use the following criteria:
; 1) pp must exist in 451
; 2) Default value is most recently ended pay period
; 3) selection of a pay period that has not ended is not allowed
; 4) Screen out pay periods with no approved data
N DIC,DUOUT,DTOUT,X,Y,PPI,DEFPP,PPTEMP
;
; set default as most recent pay period with data but must be
; earlier than current
;
S PPTEMP=$G(^PRST(458,"AD",DT))
S DEFPP=$O(PPS("P",PPTEMP),-1)
S DIC("B")=DEFPP
S DIC="^PRSN(451,",DIC(0)="AEQMZ"
S DIC("A")="Select a Pay Period: "
S DIC("S")="I +Y'>DEFPP&($D(PPS(""P"",+Y)))"
D ^DIC
I $D(DUOUT)!$D(DTOUT)!+$G(Y)'>0 Q 0
Q +Y
;
GETDIV(PRSINST) ;
N DIC,VAUTSTR,VAUTNI,VAUTVB,Y,CNT
S DIC="^PRST(456,"
S VAUTSTR="PAID Parameter Institution"
S VAUTNI=2,VAUTVB="PRSINST"
D FIRST^VAUTOMA
I $G(Y)<0 S PRSINST=Y Q
S (CNT,Y)=0
;
; all institutions selected, so loop through file to get them.
I PRSINST D
. F S Y=$O(^PRST(456,Y)) Q:Y'>0 D
.. S PRSINST(Y)=$G(^PRST(456,Y,0))
;
; Since the one, many or all call (VAUTOMA) doesn't explicitly return
; whether the user aborted the prompt, we need to check to see
; if there is anything in the selection array at this point
; and return -1 if nothing was selected.
;
S Y=0
F S Y=$O(PRSINST(Y)) Q:Y'>0 D
. S CNT=CNT+1
I CNT'>0 S PRSINST=-1
Q
;
ASKMM() ;
W !!," Would you like to view the mismatch report"
W !," for records to be released?"
N DIR,DIRUT,X,Y S DIR(0)="Y",DIR("B")="N" D ^DIR
I $D(DIRUT) S Y=-1
Q Y
SUREQ() ;
W !!," Are you sure you want to Release POC records?"
N DIR,DIRUT,X,Y S DIR(0)="Y",DIR("B")="N" D ^DIR
I $D(DIRUT) S Y=-1
Q Y
;
EXTRECS(PC,SEGCNT,PPI,PRSIEN) ; get all POC activity for nurses pay period
;
; INPUT:
; PRSIEN - (required) nurse 450 IEN
; PPI (required) pay period IEN
; OUTPUT:
; PC - Array of POC activity records formatted for
; the extraction file.
;
; Note: any work from the 2nd Saturday night of the prior pay period is
; returned in the zero node of PC, if that pp is either approved or
; released.
;
; In general. Work from a two day tour is included on the node
; for that day. I.e., two day tours are split at midnight.
;
N PRSD,POCD,T1,T2,SEG,SI,MT,T1N,T2N
;
S SI=0
K POCD
; If prior pp approved or released get any spillover from 2nd Sat.
I "^A^R^"[(U_$P($G(^PRSN(451,PPI-1,"E",PRSIEN,0)),U,2)_U) D
. D L1^PRSNRUT1(.POCD,PPI-1,PRSIEN,14)
. S PRSD=0
. D SEGS
;
F PRSD=1:1:14 D
. K POCD
. D L1^PRSNRUT1(.POCD,PPI,PRSIEN,PRSD)
. D SEGS
;
; Don't extract day 14 from prior pay period
K PC(0)
; we may end up with data in PC(15)--2 day tour on day 14 of current
; pp. That should only be extracted for corrections and is handled
; by the release corrections logic
Q
SEGS ;
S SEG=0
F S SEG=$O(POCD(SEG)) Q:SEG'>0 D
.; T1 and T2 are start and stop times for each segment.
.; 1st IF handles segments occuring entirely on 2nd day of a tour.
.; 2nd if splits segments that cross midnight into segments on the day
.; they occur and the ELSE DO handles segments entirely on 1st day.
.;
. S (T1,T1N)=$P(POCD(SEG),U,9)
. S (T2,T2N)=$P(POCD(SEG),U,10)
. S MT=$P(POCD(SEG),U,3)
. I T1'<2400 D
.. S SI=SI+1
.. S PC(PRSD+1,SI)=POCD(SEG)
.. S T1N=T1-2400
.. S $P(PC(PRSD+1,SI),U,9)=T1N
.. S T2N=T2-2400
.. I MT S T2N=$$SUBMEAL(T1N,T2N,.MT)
.. S $P(PC(PRSD+1,SI),U,2)=$$EXTIME(T2N)
.. S $P(PC(PRSD+1,SI),U,3)=0
.. S $P(PC(PRSD+1,SI),U,10)=T2N
. E D
.. I T2>2400 D
... S SI=SI+1
... S PC(PRSD,SI)=POCD(SEG)
... S T2N=2400
... I MT S T2N=$$SUBMEAL(T1N,T2N,.MT)
... S $P(PC(PRSD,SI),U,2)=$$EXTIME(T2N)
... S $P(PC(PRSD,SI),U,3)=0
... S $P(PC(PRSD,SI),U,10)=T2N
... S SI=SI+1
... S PC(PRSD+1,SI)=POCD(SEG)
... S T1N=0,T2N=T2-2400
... S $P(PC(PRSD+1,SI),U)="MID"
... S $P(PC(PRSD+1,SI),U,9)=T1N
... I MT S T2N=$$SUBMEAL(T1N,T2N,.MT)
... S $P(PC(PRSD+1,SI),U,2)=$$EXTIME(T2N)
... S $P(PC(PRSD+1,SI),U,3)=0
... S $P(PC(PRSD+1,SI),U,10)=T2N
.. E D
... S SI=SI+1
... S PC(PRSD,SI)=POCD(SEG)
... I MT S T2N=$$SUBMEAL(T1N,T2N,.MT)
... S $P(PC(PRSD,SI),U,2)=$$EXTIME(T2N)
... S $P(PC(PRSD,SI),U,3)=0
... S $P(PC(PRSD,SI),U,10)=T2N
S SEGCNT=SI
Q
;
SUBMEAL(TIME1,TIME2,MEAL) ;
;
;MEAL should be passed with a . so that any partial meal application can be returned
;for processing on next segment on 2 day tours
N TIME2N,MIN,MINDIF,MEALN
S MINDIF=$$MINDIF(TIME1,TIME2)
S MEALN=$S(MINDIF<MEAL:MINDIF,1:MEAL)
S MEAL=MEAL-MEALN
S MIN=TIME2#100
I MIN'<MEALN S TIME2N=TIME2-MEALN Q TIME2N
S TIME2N=TIME2-100+(60-MEALN)
Q TIME2N
;
MINDIF(TIME1,TIME2) ;
;FIND THE NUMBER OF MINUTES BETWEEN TWO TIMES
N MIN1,MIN2,MINDIF
S MIN1=(TIME1\100*60)+(TIME1#100)
S MIN2=(TIME2\100*60)+(TIME2#100)
S MINDIF=MIN2-MIN1
Q MINDIF
;
EXTIME(TIME) ;
;TIME IS IN MILTARY TIME
;outputs HH:MMA/P
N EXTIME
I 'TIME!(TIME=1200)!(TIME=2400) S EXTIME=$S(TIME=1200:"NOON",1:"MID") G EXTQ
S EXTIME=$S(TIME>1259:TIME-1200,1:TIME),EXTIME=$E("000",1,4-$L(EXTIME))_EXTIME
S EXTIME=$E(EXTIME,1,2)_":"_$E(EXTIME,3,4)_$S(TIME=2400:"A",TIME>1159:"P",1:"A")
;
EXTQ ;
;
Q EXTIME
;
RESULTS(CNT,PPI) ; Print results of the Release
N DIVI,DIVE,I,F,X,STNUM,STNAME
W @IOF,!!,?14,"POC RECORDS RELEASED RESULTS FOR PAY PERIOD ",$P($G(^PRST(458,PPI,0)),U)
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
;
PPRELCHK(PPS,PRSINST,PPI) ; BUILD ARRAY OF PAY PERIODS WITH APPROVED DATA
; BY DIVISION
;
; INPUT:
; PRSINST (required) array of institutions to check
; PPI (optional) if passed only that pay period will be checked
; otherwise all pps will be checked
; OUTPUT:
; PPS (returned by reference) two part array. Portion w/subscript
; "P" contains pay periods w/approved recs. for any of the
; divisions in PRSINST. Subscipt "D" is division specific
; w/total approved records for each pay period.
;
N REC,CNT,FIELD,STOP
I $G(PPI)>0 D
. S STOP=PPI
E D
. S STOP=99999999
S REC=0
F S REC=$O(PRSINST(REC)) Q:REC'>0 D
. S CI=+PRSINST(REC)
. S PPI=+$G(PPI)
. F S PPI=$O(^PRSN(451,"AA",CI,PPI)) Q:PPI'>0!(PPI>STOP) D
.. S PPS("D",CI,PPI)=0
.. S PPS("P",PPI)=""
.. S PRSIEN=0
.. F S PRSIEN=$O(^PRSN(451,"AA",CI,PPI,PRSIEN)) Q:PRSIEN'>0 D
... S PPS("D",CI,PPI)=PPS("D",CI,PPI)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSNCGR 10334 printed Apr 09, 2024@21:29:27 Page 2
PRSNCGR ;WOIFO-JAH - Release POC Records for VANOD Extraction;10/16/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 ;
RELEASE ; Routine provides functionality to release records for
+1 ; VANOD extraction. I.e., search for POC records who's pay period
+2 ; status is approved and move those records to the extraction
+3 ; file. Records in the POC file may cross midnight, but we will
+4 ; split those records at midnight and report the activity on the
+5 ; day on which it occured.
+6 ;
+7 ; Prompt Coordinator for Divisions to release (one, many, all)
+8 ;
+9 NEW PRSINST,PPI,PPS,MMR
+10 ;
+11 DO GETDIV(.PRSINST)
if PRSINST<0
QUIT
+12 ;
+13 ; Check all pay periods with approved records which are
+14 ; ready to be released.
+15 ;
+16 DO PPRELCHK(.PPS,.PRSINST)
+17 ;
+18 ; prompt for pay period
+19 ;
+20 SET PPI=$$GETPP(.PPS)
if PPI'>0
QUIT
+21 ;
+22 ;
+23 ; do prelimary report of record status
+24 ;
+25 DO CNTREP^PRSNCGR1(.PRSINST,PPI)
+26 ;
+27 IF '$DATA(PPS("P",PPI))
Begin DoDot:1
+28 WRITE !!,"There are no records in pay period ",$PIECE($GET(^PRST(458,PPI,0)),U)," approved for release."
+29 WRITE !!
SET X=$$ASK^PRSLIB00(1)
End DoDot:1
QUIT
+30 ;
+31 ; prompt for mismatch report
+32 ;
+33 SET MMR=$$ASKMM()
if MMR<0
QUIT
+34 ;
+35 IF MMR
Begin DoDot:1
+36 NEW %ZIS,POP,IOP
+37 SET %ZIS="MQ"
+38 DO ^%ZIS
+39 if POP
QUIT
+40 IF $DATA(IO("Q"))
Begin DoDot:2
+41 KILL IO("Q")
+42 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
+43 SET ZTDESC="PRSN POC/ETA MISMATCH REPORT"
+44 SET ZTRTN="MMREP^PRSNCGR"
+45 SET ZTSAVE("PPI")=""
+46 SET ZTSAVE("PRSINST(")=""
+47 DO ^%ZTLOAD
+48 IF $DATA(ZTSK)
SET ZTREQ="@"
WRITE !,"Request "_ZTSK_" Queued."
End DoDot:2
+49 IF '$TEST
Begin DoDot:2
+50 DO MMREP
End DoDot:2
End DoDot:1
+51 ;
+52 IF $$SUREQ()
Begin DoDot:1
+53 NEW %ZIS,POP,IOP
+54 SET %ZIS="MQ"
+55 DO ^%ZIS
+56 if POP
QUIT
+57 IF $DATA(IO("Q"))
Begin DoDot:2
+58 KILL IO("Q")
+59 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
+60 SET ZTDESC="PRSN POC/ETA RELEASE REPORT"
+61 SET ZTRTN="DRIVER^PRSNCGR"
+62 SET ZTSAVE("PPI")=""
+63 SET ZTSAVE("PRSINST(")=""
+64 DO ^%ZTLOAD
+65 IF $DATA(ZTSK)
SET ZTREQ="@"
WRITE !,"Request "_ZTSK_" Queued."
End DoDot:2
+66 IF '$TEST
Begin DoDot:2
+67 DO DRIVER
End DoDot:2
End DoDot:1
+68 QUIT
MMREP ;
+1 NEW REC,CNT,FIELD,SEGCNT,PC,OUT,PG,CI,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 FOR
SET PRSIEN=$ORDER(^PRSN(451,"AA",CI,PPI,PRSIEN))
if PRSIEN'>0!OUT
QUIT
Begin DoDot:2
+10 DO PPMM^PRSNRMM(PRSIEN,PPI,.PG,.OUT)
End DoDot:2
End DoDot:1
+11 DO ^%ZISC
+12 QUIT
+13 ;
DRIVER ;
+1 NEW REC,CI,SN,CNT,PRSIEN,SEGCNT,PC
+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 SET PRSIEN=0
+10 FOR
SET PRSIEN=$ORDER(^PRSN(451,"AA",CI,PPI,PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:2
+11 SET SEGCNT=0
+12 SET $PIECE(CNT(CI),U)=$PIECE(CNT(CI),U)+1
+13 KILL PC
DO EXTRECS(.PC,.SEGCNT,PPI,PRSIEN)
+14 DO FILEPP^PRSNCGR1(.PC,PRSIEN,PPI,CI,SN)
+15 SET $PIECE(CNT(CI),U,2)=$PIECE(CNT(CI),U,2)+SEGCNT
+16 DO UPDTPOC^PRSNCGR1(PPI,PRSIEN,"R")
End DoDot:2
+17 ; if any records were released then update the release history for
+18 ; for this division
+19 IF $PIECE(CNT(CI),U,2)>0
Begin DoDot:2
+20 DO UPDTPP^PRSNCGR1(PPI,CI,$PIECE(CNT(CI),U),$PIECE(CNT(CI),U,2))
End DoDot:2
End DoDot:1
+21 DO RESULTS(.CNT,PPI)
+22 ;
+23 DO ^%ZISC
+24 QUIT
+25 ;
GETPP(PPS) ;prompt for and return pay period
+1 ; Use the following criteria:
+2 ; 1) pp must exist in 451
+3 ; 2) Default value is most recently ended pay period
+4 ; 3) selection of a pay period that has not ended is not allowed
+5 ; 4) Screen out pay periods with no approved data
+6 NEW DIC,DUOUT,DTOUT,X,Y,PPI,DEFPP,PPTEMP
+7 ;
+8 ; set default as most recent pay period with data but must be
+9 ; earlier than current
+10 ;
+11 SET PPTEMP=$GET(^PRST(458,"AD",DT))
+12 SET DEFPP=$ORDER(PPS("P",PPTEMP),-1)
+13 SET DIC("B")=DEFPP
+14 SET DIC="^PRSN(451,"
SET DIC(0)="AEQMZ"
+15 SET DIC("A")="Select a Pay Period: "
+16 SET DIC("S")="I +Y'>DEFPP&($D(PPS(""P"",+Y)))"
+17 DO ^DIC
+18 IF $DATA(DUOUT)!$DATA(DTOUT)!+$GET(Y)'>0
QUIT 0
+19 QUIT +Y
+20 ;
GETDIV(PRSINST) ;
+1 NEW DIC,VAUTSTR,VAUTNI,VAUTVB,Y,CNT
+2 SET DIC="^PRST(456,"
+3 SET VAUTSTR="PAID Parameter Institution"
+4 SET VAUTNI=2
SET VAUTVB="PRSINST"
+5 DO FIRST^VAUTOMA
+6 IF $GET(Y)<0
SET PRSINST=Y
QUIT
+7 SET (CNT,Y)=0
+8 ;
+9 ; all institutions selected, so loop through file to get them.
+10 IF PRSINST
Begin DoDot:1
+11 FOR
SET Y=$ORDER(^PRST(456,Y))
if Y'>0
QUIT
Begin DoDot:2
+12 SET PRSINST(Y)=$GET(^PRST(456,Y,0))
End DoDot:2
End DoDot:1
+13 ;
+14 ; Since the one, many or all call (VAUTOMA) doesn't explicitly return
+15 ; whether the user aborted the prompt, we need to check to see
+16 ; if there is anything in the selection array at this point
+17 ; and return -1 if nothing was selected.
+18 ;
+19 SET Y=0
+20 FOR
SET Y=$ORDER(PRSINST(Y))
if Y'>0
QUIT
Begin DoDot:1
+21 SET CNT=CNT+1
End DoDot:1
+22 IF CNT'>0
SET PRSINST=-1
+23 QUIT
+24 ;
ASKMM() ;
+1 WRITE !!," Would you like to view the mismatch report"
+2 WRITE !," for records to be released?"
+3 NEW DIR,DIRUT,X,Y
SET DIR(0)="Y"
SET DIR("B")="N"
DO ^DIR
+4 IF $DATA(DIRUT)
SET Y=-1
+5 QUIT Y
SUREQ() ;
+1 WRITE !!," Are you sure you want to Release POC records?"
+2 NEW DIR,DIRUT,X,Y
SET DIR(0)="Y"
SET DIR("B")="N"
DO ^DIR
+3 IF $DATA(DIRUT)
SET Y=-1
+4 QUIT Y
+5 ;
EXTRECS(PC,SEGCNT,PPI,PRSIEN) ; get all POC activity for nurses pay period
+1 ;
+2 ; INPUT:
+3 ; PRSIEN - (required) nurse 450 IEN
+4 ; PPI (required) pay period IEN
+5 ; OUTPUT:
+6 ; PC - Array of POC activity records formatted for
+7 ; the extraction file.
+8 ;
+9 ; Note: any work from the 2nd Saturday night of the prior pay period is
+10 ; returned in the zero node of PC, if that pp is either approved or
+11 ; released.
+12 ;
+13 ; In general. Work from a two day tour is included on the node
+14 ; for that day. I.e., two day tours are split at midnight.
+15 ;
+16 NEW PRSD,POCD,T1,T2,SEG,SI,MT,T1N,T2N
+17 ;
+18 SET SI=0
+19 KILL POCD
+20 ; If prior pp approved or released get any spillover from 2nd Sat.
+21 IF "^A^R^"[(U_$PIECE($GET(^PRSN(451,PPI-1,"E",PRSIEN,0)),U,2)_U)
Begin DoDot:1
+22 DO L1^PRSNRUT1(.POCD,PPI-1,PRSIEN,14)
+23 SET PRSD=0
+24 DO SEGS
End DoDot:1
+25 ;
+26 FOR PRSD=1:1:14
Begin DoDot:1
+27 KILL POCD
+28 DO L1^PRSNRUT1(.POCD,PPI,PRSIEN,PRSD)
+29 DO SEGS
End DoDot:1
+30 ;
+31 ; Don't extract day 14 from prior pay period
+32 KILL PC(0)
+33 ; we may end up with data in PC(15)--2 day tour on day 14 of current
+34 ; pp. That should only be extracted for corrections and is handled
+35 ; by the release corrections logic
+36 QUIT
SEGS ;
+1 SET SEG=0
+2 FOR
SET SEG=$ORDER(POCD(SEG))
if SEG'>0
QUIT
Begin DoDot:1
+3 ; T1 and T2 are start and stop times for each segment.
+4 ; 1st IF handles segments occuring entirely on 2nd day of a tour.
+5 ; 2nd if splits segments that cross midnight into segments on the day
+6 ; they occur and the ELSE DO handles segments entirely on 1st day.
+7 ;
+8 SET (T1,T1N)=$PIECE(POCD(SEG),U,9)
+9 SET (T2,T2N)=$PIECE(POCD(SEG),U,10)
+10 SET MT=$PIECE(POCD(SEG),U,3)
+11 IF T1'<2400
Begin DoDot:2
+12 SET SI=SI+1
+13 SET PC(PRSD+1,SI)=POCD(SEG)
+14 SET T1N=T1-2400
+15 SET $PIECE(PC(PRSD+1,SI),U,9)=T1N
+16 SET T2N=T2-2400
+17 IF MT
SET T2N=$$SUBMEAL(T1N,T2N,.MT)
+18 SET $PIECE(PC(PRSD+1,SI),U,2)=$$EXTIME(T2N)
+19 SET $PIECE(PC(PRSD+1,SI),U,3)=0
+20 SET $PIECE(PC(PRSD+1,SI),U,10)=T2N
End DoDot:2
+21 IF '$TEST
Begin DoDot:2
+22 IF T2>2400
Begin DoDot:3
+23 SET SI=SI+1
+24 SET PC(PRSD,SI)=POCD(SEG)
+25 SET T2N=2400
+26 IF MT
SET T2N=$$SUBMEAL(T1N,T2N,.MT)
+27 SET $PIECE(PC(PRSD,SI),U,2)=$$EXTIME(T2N)
+28 SET $PIECE(PC(PRSD,SI),U,3)=0
+29 SET $PIECE(PC(PRSD,SI),U,10)=T2N
+30 SET SI=SI+1
+31 SET PC(PRSD+1,SI)=POCD(SEG)
+32 SET T1N=0
SET T2N=T2-2400
+33 SET $PIECE(PC(PRSD+1,SI),U)="MID"
+34 SET $PIECE(PC(PRSD+1,SI),U,9)=T1N
+35 IF MT
SET T2N=$$SUBMEAL(T1N,T2N,.MT)
+36 SET $PIECE(PC(PRSD+1,SI),U,2)=$$EXTIME(T2N)
+37 SET $PIECE(PC(PRSD+1,SI),U,3)=0
+38 SET $PIECE(PC(PRSD+1,SI),U,10)=T2N
End DoDot:3
+39 IF '$TEST
Begin DoDot:3
+40 SET SI=SI+1
+41 SET PC(PRSD,SI)=POCD(SEG)
+42 IF MT
SET T2N=$$SUBMEAL(T1N,T2N,.MT)
+43 SET $PIECE(PC(PRSD,SI),U,2)=$$EXTIME(T2N)
+44 SET $PIECE(PC(PRSD,SI),U,3)=0
+45 SET $PIECE(PC(PRSD,SI),U,10)=T2N
End DoDot:3
End DoDot:2
End DoDot:1
+46 SET SEGCNT=SI
+47 QUIT
+48 ;
SUBMEAL(TIME1,TIME2,MEAL) ;
+1 ;
+2 ;MEAL should be passed with a . so that any partial meal application can be returned
+3 ;for processing on next segment on 2 day tours
+4 NEW TIME2N,MIN,MINDIF,MEALN
+5 SET MINDIF=$$MINDIF(TIME1,TIME2)
+6 SET MEALN=$SELECT(MINDIF<MEAL:MINDIF,1:MEAL)
+7 SET MEAL=MEAL-MEALN
+8 SET MIN=TIME2#100
+9 IF MIN'<MEALN
SET TIME2N=TIME2-MEALN
QUIT TIME2N
+10 SET TIME2N=TIME2-100+(60-MEALN)
+11 QUIT TIME2N
+12 ;
MINDIF(TIME1,TIME2) ;
+1 ;FIND THE NUMBER OF MINUTES BETWEEN TWO TIMES
+2 NEW MIN1,MIN2,MINDIF
+3 SET MIN1=(TIME1\100*60)+(TIME1#100)
+4 SET MIN2=(TIME2\100*60)+(TIME2#100)
+5 SET MINDIF=MIN2-MIN1
+6 QUIT MINDIF
+7 ;
EXTIME(TIME) ;
+1 ;TIME IS IN MILTARY TIME
+2 ;outputs HH:MMA/P
+3 NEW EXTIME
+4 IF 'TIME!(TIME=1200)!(TIME=2400)
SET EXTIME=$SELECT(TIME=1200:"NOON",1:"MID")
GOTO EXTQ
+5 SET EXTIME=$SELECT(TIME>1259:TIME-1200,1:TIME)
SET EXTIME=$EXTRACT("000",1,4-$LENGTH(EXTIME))_EXTIME
+6 SET EXTIME=$EXTRACT(EXTIME,1,2)_":"_$EXTRACT(EXTIME,3,4)_$SELECT(TIME=2400:"A",TIME>1159:"P",1:"A")
+7 ;
EXTQ ;
+1 ;
+2 QUIT EXTIME
+3 ;
RESULTS(CNT,PPI) ; Print results of the Release
+1 NEW DIVI,DIVE,I,F,X,STNUM,STNAME
+2 WRITE @IOF,!!,?14,"POC RECORDS RELEASED RESULTS FOR PAY PERIOD ",$PIECE($GET(^PRST(458,PPI,0)),U)
+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
+14 ;
PPRELCHK(PPS,PRSINST,PPI) ; BUILD ARRAY OF PAY PERIODS WITH APPROVED DATA
+1 ; BY DIVISION
+2 ;
+3 ; INPUT:
+4 ; PRSINST (required) array of institutions to check
+5 ; PPI (optional) if passed only that pay period will be checked
+6 ; otherwise all pps will be checked
+7 ; OUTPUT:
+8 ; PPS (returned by reference) two part array. Portion w/subscript
+9 ; "P" contains pay periods w/approved recs. for any of the
+10 ; divisions in PRSINST. Subscipt "D" is division specific
+11 ; w/total approved records for each pay period.
+12 ;
+13 NEW REC,CNT,FIELD,STOP
+14 IF $GET(PPI)>0
Begin DoDot:1
+15 SET STOP=PPI
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 SET STOP=99999999
End DoDot:1
+18 SET REC=0
+19 FOR
SET REC=$ORDER(PRSINST(REC))
if REC'>0
QUIT
Begin DoDot:1
+20 SET CI=+PRSINST(REC)
+21 SET PPI=+$GET(PPI)
+22 FOR
SET PPI=$ORDER(^PRSN(451,"AA",CI,PPI))
if PPI'>0!(PPI>STOP)
QUIT
Begin DoDot:2
+23 SET PPS("D",CI,PPI)=0
+24 SET PPS("P",PPI)=""
+25 SET PRSIEN=0
+26 FOR
SET PRSIEN=$ORDER(^PRSN(451,"AA",CI,PPI,PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:3
+27 SET PPS("D",CI,PPI)=PPS("D",CI,PPI)+1
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
