PRSPCORE ;WOIFO/JAH - pt phys report on Core Hour Tours ;01/22/05
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Report all tours of duty that currently have a Core Hours
; designation in the TOUR OF DUTY(#457.1)
;
; The Payroll Supervisor will need to remove the
; designation from the indicated tour.
;
Q
COREHRS ; main driver for the core hours report
; Get Station Number
N Y,%,TSTAMP,%ZIS,POP,INCLUDE,PPI,PPE
D NOW^%DTC S Y=% D DD^%DT S TSTAMP=Y
;
; look for core designation in the tours
;
D INTRO
Q:$$ASK^PRSLIB00(1)
S INCLUDE=$$INCLEMP^PRSPCORE()
Q:INCLUDE<0
S PPI=0
I INCLUDE S PPI=$$WHICHPP() Q:PPI<0
I PPI>0 S PPE=$P(^PRST(458,PPI,0),U)
; if the pay period is not open then don't try to print employee list
I PPI=0 S INCLUDE=0
;
S %ZIS="MQ"
D ^%ZIS
Q:POP
I $D(IO("Q")) D
. K IO("Q")
. N ZTDESC,ZTRTN,ZTSAVE
. S ZTDESC="PAID TOURS WITH CORE TIME REPORT",ZTRTN="TOURCHK^PRSPCORE"
. S ZTSAVE("TSTAMP")="",ZTSAVE("INCLUDE")="",ZTSAVE("PPI")="",ZTSAVE("PPE")=""
. D ^%ZTLOAD
.;
E D
. D TOURCHK
Q
;
INTRO ;always show the option description to the user since this is
; standalone secondary option.
N X,Y,DIC,PRSHLP,PRSER,OPTIEN,LN
W @IOF,!
S X="PRSP PS CORE HRS RPT"
S DIC="^DIC(19,"
S DIC(0)="MZ"
D ^DIC
Q:$G(Y)'>0
S OPTIEN=+$G(Y)
S X=$$GET1^DIQ(19,OPTIEN,3.5,,"PRSHLP","PRSER")
S LN=0
F S LN=$O(PRSHLP(LN)) Q:LN'>0 D
. W !,PRSHLP(LN)
S LN=0
F S LN=$O(PRSER(LN)) Q:LN'>0 D
. W !,PRSER(LN)
Q
HDR(TSTAMP) ;
N I,L1
W @IOF,!
I $G(INCLUDE) W ?2,"Employee search in PP ",PPE," included."
W ?(IOM-$L(TSTAMP)-1),TSTAMP
S L1="PAID - TOURS OF DUTY WITH PHYS/DENT CORE HOURS SEGMENTS REPORT"
W !,?(IOM-$L(L1))/2,L1
W !," TOUR #",?10,"TOUR NAME",?50,"SEGMENT"
W !
F I=1:1:IOM-1 W "-"
Q
;
RET(TSTAMP) ;
I ($E(IOST,1,2)'="C-")!($D(ZTQUEUED)) D HDR(TSTAMP) Q 0
;
N OUT
S OUT=$$ASK^PRSLIB00(1)
I 'OUT D HDR(TSTAMP)
Q OUT
;
TOURCHK ; check tour of duty file for tours with special time Phy/Dent core
;
; STIEN-SPECIAL TOUR INDICATOR IEN (457.2)
; STPTR-POINTER FROM TOUR OF DUTY FILE TO THE SPECIAL TOUR IND FILE
;
U IO
N I,ZNODE,NODE1,OUT,STPTR,STIEN,STCNT,SEGCNT,HASCORE,NODEX,TOUR
; Loop through tours
;
S STIEN=$O(^PRST(457.2,"B","Phy/Den Core Hours",0))
I STIEN'>0 D Q
. D HDR(TSTAMP)
. W !!,"REPORT ABORTED!"
. W !,"No Phy/Den Core Hours entry found in file 457.2"
S (STCNT,TOUR,OUT)=0,NODEX=1
D HDR(TSTAMP)
F S TOUR=$O(^PRST(457.1,TOUR)) Q:TOUR'>0!(OUT) D
. S HASCORE=0
. S ZNODE=$G(^PRST(457.1,TOUR,0))
. S NODE1=$G(^PRST(457.1,TOUR,1))
. ;
. ; Loop through 7 Special Codes looking for code
. ; #3 Phy/Den Core Hours
. ;
. S SEGCNT=0
. F I=3:3:21 D
.. S STPTR=$P(NODE1,U,I)
.. I STPTR=STIEN S SEGCNT=SEGCNT+1 D
... S HASCORE=1
... I SEGCNT=1 D
.... S STCNT=STCNT+1
.... W !!,$J(TOUR,7),?10,$P(ZNODE,U)
... E D
.... W !
... W ?50,I/3,": ",$P(NODE1,U,I-2)," - ",$P(NODE1,U,I-1)
.;
. I $Y>(IOSL-3) S OUT=$$RET(TSTAMP) Q:OUT
. I HASCORE S OUT=$$TLLIST^PRSPCORE(TOUR,TSTAMP) Q:OUT
. I INCLUDE,HASCORE S OUT=$$EMPLIST(TSTAMP,TOUR,PPI,TOUR) S HASCORE=0 Q:OUT
;
;
I STCNT=0 W !!,?5,"No Tours were found with Special Tour Indicator of Phy/Den Core Hrs"
D ^%ZISC
I $D(ZTSK) S ZTREQ="@"
Q
WHICHPP() ;
N PPI,SRT,DFN
S PPI=$P($G(^PRST(458,"AD",DT)),U)
I PPI'>0 S PPI=$O(^PRST(458,99999),-1)
Q:PPI'>0
S DFN=0 D NOL^PRSATE2
S PPI=$S(SRT="L":PPI-1,SRT="N":PPI+1,SRT="C":PPI,1:-1)
Q:PPI<0 PPI
I '$G(^PRST(458,PPI,0)) S PPI=0 W !,"No employee tour data available for the unopened pay period."
Q PPI
INCLEMP() ;ASK USER IF THEY WANT TO INCLUDE EMPLOYEES WITH THE TOUR
N DIR,DIRUT,Y,INCLUDE
S DIR(0)="YA0"
S DIR("B")="N"
S DIR("A")="List employees with Phys/Den Core Hours Tours?"
D ^DIR
S INCLUDE=+Y
I $D(DIRUT) S INCLUDE=-1
Q INCLUDE
EMPLIST(TS,TR,PPI,STIEN) ;LOOP THRU PP TO DISPLAY EMPS W/ PHY/DEN CORE TOURS
;
N PRSIEN,PRSD,TRNODE,TR1,TR2,CORECNT,FOUND,OUT
S OUT=0
W !
S (CORECNT,PRSIEN,OUT)=0
; ^PRST(458,236,"E",12717,"D",12,0) = 12^295^0^9^13198^3050114.11 ...
;
F S PRSIEN=$O(^PRST(458,PPI,"E",PRSIEN)) Q:PRSIEN'>0!(OUT) D
. S (PRSD,FOUND)=0
. F PRSD=1:1:14 D
.. S TRNODE=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0))
.. S TR1=$P(TRNODE,U,2)
.. S TR2=$P(TRNODE,U,13)
.. I (TR1=STIEN)!(TR2=STIEN) S FOUND=1,CORECNT=CORECNT+1 Q
. S ZNODE=$G(^PRSPC(PRSIEN,0))
. I FOUND W !,?12,$P(ZNODE,U),?45,"T&L: ",$P(ZNODE,U,8),?67,"nnn-nn-",$E($P(ZNODE,U,9),6,9)
. I $Y>(IOSL-3) S OUT=$$RET(TSTAMP) Q:OUT
I CORECNT=0 W !,?12,"No employees with this core hours tour in pp ",PPE
Q OUT
;
TLLIST(TIE,TSTAMP) ;LOOP THRU TOUR TO DISPLAY ASSOCIATED T&Ls
; INPUT : Tour Internal Entry number
; local vars:
; ATL - Associated T & L unit
; ATLCT - count the assoc tls
N ATL,ATLCT,OUT
W !,?12,"Associated T&Ls: "
I $$GET1^DIQ(457.1,TIE,4,,,)="YES" D Q 0
. W "This tour is available to all T&L units."
;
S (OUT,ATLCT,ATL)=0
F S ATL=$O(^PRST(457.1,TIE,"T","B",ATL)) Q:ATL'>0!(OUT) D
. I $X>(IOM-10) D
.. W ", ",!,?29
. E D
.. I ATLCT>0 W ", "
. I $Y>(IOSL-3) S OUT=$$RET(TSTAMP) Q:OUT W !!,?12,"Associated T&Ls: "
. S ATLCT=ATLCT+1
. W $$GET1^DIQ(455.5,ATL,.01,,,)
I ATLCT=0 W "No T&L units are associated with this tour."
Q OUT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPCORE 5479 printed Sep 23, 2025@20:04:12 Page 2
PRSPCORE ;WOIFO/JAH - pt phys report on Core Hour Tours ;01/22/05
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Report all tours of duty that currently have a Core Hours
+5 ; designation in the TOUR OF DUTY(#457.1)
+6 ;
+7 ; The Payroll Supervisor will need to remove the
+8 ; designation from the indicated tour.
+9 ;
+10 QUIT
COREHRS ; main driver for the core hours report
+1 ; Get Station Number
+2 NEW Y,%,TSTAMP,%ZIS,POP,INCLUDE,PPI,PPE
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TSTAMP=Y
+4 ;
+5 ; look for core designation in the tours
+6 ;
+7 DO INTRO
+8 if $$ASK^PRSLIB00(1)
QUIT
+9 SET INCLUDE=$$INCLEMP^PRSPCORE()
+10 if INCLUDE<0
QUIT
+11 SET PPI=0
+12 IF INCLUDE
SET PPI=$$WHICHPP()
if PPI<0
QUIT
+13 IF PPI>0
SET PPE=$PIECE(^PRST(458,PPI,0),U)
+14 ; if the pay period is not open then don't try to print employee list
+15 IF PPI=0
SET INCLUDE=0
+16 ;
+17 SET %ZIS="MQ"
+18 DO ^%ZIS
+19 if POP
QUIT
+20 IF $DATA(IO("Q"))
Begin DoDot:1
+21 KILL IO("Q")
+22 NEW ZTDESC,ZTRTN,ZTSAVE
+23 SET ZTDESC="PAID TOURS WITH CORE TIME REPORT"
SET ZTRTN="TOURCHK^PRSPCORE"
+24 SET ZTSAVE("TSTAMP")=""
SET ZTSAVE("INCLUDE")=""
SET ZTSAVE("PPI")=""
SET ZTSAVE("PPE")=""
+25 DO ^%ZTLOAD
+26 ;
End DoDot:1
+27 IF '$TEST
Begin DoDot:1
+28 DO TOURCHK
End DoDot:1
+29 QUIT
+30 ;
INTRO ;always show the option description to the user since this is
+1 ; standalone secondary option.
+2 NEW X,Y,DIC,PRSHLP,PRSER,OPTIEN,LN
+3 WRITE @IOF,!
+4 SET X="PRSP PS CORE HRS RPT"
+5 SET DIC="^DIC(19,"
+6 SET DIC(0)="MZ"
+7 DO ^DIC
+8 if $GET(Y)'>0
QUIT
+9 SET OPTIEN=+$GET(Y)
+10 SET X=$$GET1^DIQ(19,OPTIEN,3.5,,"PRSHLP","PRSER")
+11 SET LN=0
+12 FOR
SET LN=$ORDER(PRSHLP(LN))
if LN'>0
QUIT
Begin DoDot:1
+13 WRITE !,PRSHLP(LN)
End DoDot:1
+14 SET LN=0
+15 FOR
SET LN=$ORDER(PRSER(LN))
if LN'>0
QUIT
Begin DoDot:1
+16 WRITE !,PRSER(LN)
End DoDot:1
+17 QUIT
HDR(TSTAMP) ;
+1 NEW I,L1
+2 WRITE @IOF,!
+3 IF $GET(INCLUDE)
WRITE ?2,"Employee search in PP ",PPE," included."
+4 WRITE ?(IOM-$LENGTH(TSTAMP)-1),TSTAMP
+5 SET L1="PAID - TOURS OF DUTY WITH PHYS/DENT CORE HOURS SEGMENTS REPORT"
+6 WRITE !,?(IOM-$LENGTH(L1))/2,L1
+7 WRITE !," TOUR #",?10,"TOUR NAME",?50,"SEGMENT"
+8 WRITE !
+9 FOR I=1:1:IOM-1
WRITE "-"
+10 QUIT
+11 ;
RET(TSTAMP) ;
+1 IF ($EXTRACT(IOST,1,2)'="C-")!($DATA(ZTQUEUED))
DO HDR(TSTAMP)
QUIT 0
+2 ;
+3 NEW OUT
+4 SET OUT=$$ASK^PRSLIB00(1)
+5 IF 'OUT
DO HDR(TSTAMP)
+6 QUIT OUT
+7 ;
TOURCHK ; check tour of duty file for tours with special time Phy/Dent core
+1 ;
+2 ; STIEN-SPECIAL TOUR INDICATOR IEN (457.2)
+3 ; STPTR-POINTER FROM TOUR OF DUTY FILE TO THE SPECIAL TOUR IND FILE
+4 ;
+5 USE IO
+6 NEW I,ZNODE,NODE1,OUT,STPTR,STIEN,STCNT,SEGCNT,HASCORE,NODEX,TOUR
+7 ; Loop through tours
+8 ;
+9 SET STIEN=$ORDER(^PRST(457.2,"B","Phy/Den Core Hours",0))
+10 IF STIEN'>0
Begin DoDot:1
+11 DO HDR(TSTAMP)
+12 WRITE !!,"REPORT ABORTED!"
+13 WRITE !,"No Phy/Den Core Hours entry found in file 457.2"
End DoDot:1
QUIT
+14 SET (STCNT,TOUR,OUT)=0
SET NODEX=1
+15 DO HDR(TSTAMP)
+16 FOR
SET TOUR=$ORDER(^PRST(457.1,TOUR))
if TOUR'>0!(OUT)
QUIT
Begin DoDot:1
+17 SET HASCORE=0
+18 SET ZNODE=$GET(^PRST(457.1,TOUR,0))
+19 SET NODE1=$GET(^PRST(457.1,TOUR,1))
+20 ;
+21 ; Loop through 7 Special Codes looking for code
+22 ; #3 Phy/Den Core Hours
+23 ;
+24 SET SEGCNT=0
+25 FOR I=3:3:21
Begin DoDot:2
+26 SET STPTR=$PIECE(NODE1,U,I)
+27 IF STPTR=STIEN
SET SEGCNT=SEGCNT+1
Begin DoDot:3
+28 SET HASCORE=1
+29 IF SEGCNT=1
Begin DoDot:4
+30 SET STCNT=STCNT+1
+31 WRITE !!,$JUSTIFY(TOUR,7),?10,$PIECE(ZNODE,U)
End DoDot:4
+32 IF '$TEST
Begin DoDot:4
+33 WRITE !
End DoDot:4
+34 WRITE ?50,I/3,": ",$PIECE(NODE1,U,I-2)," - ",$PIECE(NODE1,U,I-1)
End DoDot:3
End DoDot:2
+35 ;
+36 IF $Y>(IOSL-3)
SET OUT=$$RET(TSTAMP)
if OUT
QUIT
+37 IF HASCORE
SET OUT=$$TLLIST^PRSPCORE(TOUR,TSTAMP)
if OUT
QUIT
+38 IF INCLUDE
IF HASCORE
SET OUT=$$EMPLIST(TSTAMP,TOUR,PPI,TOUR)
SET HASCORE=0
if OUT
QUIT
End DoDot:1
+39 ;
+40 ;
+41 IF STCNT=0
WRITE !!,?5,"No Tours were found with Special Tour Indicator of Phy/Den Core Hrs"
+42 DO ^%ZISC
+43 IF $DATA(ZTSK)
SET ZTREQ="@"
+44 QUIT
WHICHPP() ;
+1 NEW PPI,SRT,DFN
+2 SET PPI=$PIECE($GET(^PRST(458,"AD",DT)),U)
+3 IF PPI'>0
SET PPI=$ORDER(^PRST(458,99999),-1)
+4 if PPI'>0
QUIT
+5 SET DFN=0
DO NOL^PRSATE2
+6 SET PPI=$SELECT(SRT="L":PPI-1,SRT="N":PPI+1,SRT="C":PPI,1:-1)
+7 if PPI<0
QUIT PPI
+8 IF '$GET(^PRST(458,PPI,0))
SET PPI=0
WRITE !,"No employee tour data available for the unopened pay period."
+9 QUIT PPI
INCLEMP() ;ASK USER IF THEY WANT TO INCLUDE EMPLOYEES WITH THE TOUR
+1 NEW DIR,DIRUT,Y,INCLUDE
+2 SET DIR(0)="YA0"
+3 SET DIR("B")="N"
+4 SET DIR("A")="List employees with Phys/Den Core Hours Tours?"
+5 DO ^DIR
+6 SET INCLUDE=+Y
+7 IF $DATA(DIRUT)
SET INCLUDE=-1
+8 QUIT INCLUDE
EMPLIST(TS,TR,PPI,STIEN) ;LOOP THRU PP TO DISPLAY EMPS W/ PHY/DEN CORE TOURS
+1 ;
+2 NEW PRSIEN,PRSD,TRNODE,TR1,TR2,CORECNT,FOUND,OUT
+3 SET OUT=0
+4 WRITE !
+5 SET (CORECNT,PRSIEN,OUT)=0
+6 ; ^PRST(458,236,"E",12717,"D",12,0) = 12^295^0^9^13198^3050114.11 ...
+7 ;
+8 FOR
SET PRSIEN=$ORDER(^PRST(458,PPI,"E",PRSIEN))
if PRSIEN'>0!(OUT)
QUIT
Begin DoDot:1
+9 SET (PRSD,FOUND)=0
+10 FOR PRSD=1:1:14
Begin DoDot:2
+11 SET TRNODE=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0))
+12 SET TR1=$PIECE(TRNODE,U,2)
+13 SET TR2=$PIECE(TRNODE,U,13)
+14 IF (TR1=STIEN)!(TR2=STIEN)
SET FOUND=1
SET CORECNT=CORECNT+1
QUIT
End DoDot:2
+15 SET ZNODE=$GET(^PRSPC(PRSIEN,0))
+16 IF FOUND
WRITE !,?12,$PIECE(ZNODE,U),?45,"T&L: ",$PIECE(ZNODE,U,8),?67,"nnn-nn-",$EXTRACT($PIECE(ZNODE,U,9),6,9)
+17 IF $Y>(IOSL-3)
SET OUT=$$RET(TSTAMP)
if OUT
QUIT
End DoDot:1
+18 IF CORECNT=0
WRITE !,?12,"No employees with this core hours tour in pp ",PPE
+19 QUIT OUT
+20 ;
TLLIST(TIE,TSTAMP) ;LOOP THRU TOUR TO DISPLAY ASSOCIATED T&Ls
+1 ; INPUT : Tour Internal Entry number
+2 ; local vars:
+3 ; ATL - Associated T & L unit
+4 ; ATLCT - count the assoc tls
+5 NEW ATL,ATLCT,OUT
+6 WRITE !,?12,"Associated T&Ls: "
+7 IF $$GET1^DIQ(457.1,TIE,4,,,)="YES"
Begin DoDot:1
+8 WRITE "This tour is available to all T&L units."
End DoDot:1
QUIT 0
+9 ;
+10 SET (OUT,ATLCT,ATL)=0
+11 FOR
SET ATL=$ORDER(^PRST(457.1,TIE,"T","B",ATL))
if ATL'>0!(OUT)
QUIT
Begin DoDot:1
+12 IF $X>(IOM-10)
Begin DoDot:2
+13 WRITE ", ",!,?29
End DoDot:2
+14 IF '$TEST
Begin DoDot:2
+15 IF ATLCT>0
WRITE ", "
End DoDot:2
+16 IF $Y>(IOSL-3)
SET OUT=$$RET(TSTAMP)
if OUT
QUIT
WRITE !!,?12,"Associated T&Ls: "
+17 SET ATLCT=ATLCT+1
+18 WRITE $$GET1^DIQ(455.5,ATL,.01,,,)
End DoDot:1
+19 IF ATLCT=0
WRITE "No T&L units are associated with this tour."
+20 QUIT OUT
