PRSD1150 ;HISC/GWB-RECORD OF LEAVE DATA ;2/5/1998
;;4.0;PAID;**35,100**;Sep 21, 1995;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
EMP K DIC S DIC="^PRSPC(",DIC(0)="AEMQZ"
S DIC("A")="Select SEPARATED EMPLOYEE: " D ^DIC K DIC
I Y'>0 G EX
S DA=+Y
I $P($G(^PRSPC(DA,1)),U,33)'="Y" D G EMP
.W !!,*7,"This is not a separated employee. "
.W "The SEPARATION IND does not equal Y.",!
START ;
K DASHES S $P(DASHES,"-",80)="-"
S ZERO=^PRSPC(DA,0)
S NAME=$P(ZERO,U,1),STATION=$P(ZERO,U,7),TLU=$P(ZERO,U,8)
S SSN=$P(ZERO,U,9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
S SAL=$P(ZERO,U,29),HR=$S(SAL>99:SAL/2087,1:SAL),HR=$J(HR,0,2)
S Y=$P(ZERO,U,49) X ^DD(450,458,2.1) S CCORG=Y
S DS=$P($G(^PRSPC(DA,1)),U,42),LPP=$P($G(^PRSPC(DA,"MISC4")),U,16)
S SCD=$P(ZERO,U,31)
S SCDYR=$E(SCD,1,3),SCDMO=+$E(SCD,4,5),SCDDY=+$E(SCD,6,7)
S DOS=$P($G(^PRSPC(DA,1)),U,2)
S DOS1=$$FMADD^XLFDT(DOS,1) ; add 1 day so empl. credited for DOS
S DOS1YR=$E(DOS1,1,3),DOS1MO=+$E(DOS1,4,5),DOS1DY=+$E(DOS1,6,7)
;
; calculate difference between DOS1 and SCD
S TOTDY=DOS1DY-SCDDY
S TOTMO=DOS1MO-SCDMO
S TOTYR=DOS1YR-SCDYR
; if negative days then recalc. Subtract 1 from month and get days by
; adding the days from first and last month together.
I TOTDY<0 D
. S SCDDIM=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,SCDMO)
. I SCDDIM=28 S SCDDIM=SCDDIM+$$LEAPYR^PRSLIB00(SCDYR+1700)
. S TOTDY=SCDDIM-SCDDY+DOS1DY
. S TOTMO=TOTMO-1
I TOTMO<0 S TOTMO=TOTMO+12,TOTYR=TOTYR-1
;
ROLD S CATEGORY="RECORD OF LEAVE DATA",PAGE=0
K ^UTILITY("DIQ1",$J) S DIC="^PRSPC("
S DR="30;49;50",DIQ(0)="IE" D EN^DIQ1 W @IOF D HDR S PRTC=1
F F=30,49,50 D WR G:'PRTC EX
W !,"TOTAL SERVICE FOR LEAVE.........",TOTYR," YEARS"
W !," ",TOTMO," MONTHS"
W !," ",TOTDY," DAYS"
K ^UTILITY("DIQ1",$J) S DIC="^PRSPC("
S DR="462;510",DIQ(0)="IE" D EN^DIQ1
F F=462,510 D WR G:'PRTC EX
W !,"HOURLY RATE.....................",HR
S END="" D PRTC
EX K ^UTILITY("DIQ1",$J)
N PRSTLV D KILL^XUSCLEAN W @IOF
Q
WR S NODEDD=^DD(450,F,0),NODEUTIL=$G(^UTILITY("DIQ1",$J,450,DA,F,"E"))
I (NODEUTIL="")!(NODEUTIL="NA") K NODEDD,NODEUTIL Q
S FLDNAM=$P(NODEDD,U,1)
S INT=^UTILITY("DIQ1",$J,450,DA,F,"I")
EXT S EXT=^UTILITY("DIQ1",$J,450,DA,F,"E")
S IL=$L(INT)
I $P(NODEDD,U,2)["NJ",+INT=0 K NODEDD,NODEUTIL Q
I $P(NODEDD,U,5)["""$""" S VAL=$FN(INT,",",2) G IOSL
I $P(NODEDD,U,2)["D" S VAL=EXT G IOSL
I $P(NODEDD,U,2)["NJ" S VAL=$J(INT,IL,2) G IOSL
S VAL=EXT
IOSL K DOTS S NOD=32-$L(FLDNAM),$P(DOTS,".",NOD)="."
I $Y>(IOSL-4) D PRTC Q:'PRTC
W !,FLDNAM,DOTS
D VAL Q
VAL I $L(VAL)<48 W ?32,VAL Q
S COLUMN=32,LGTH=0
F LOOP=1:1 Q:LGTH=$L(VAL)!(LGTH>($L(VAL))) W:$L($P(VAL," ",LOOP))>(80-COLUMN) ! S:$L($P(VAL," ",LOOP))>(80-COLUMN) COLUMN=32 W ?COLUMN,$P(VAL," ",LOOP) S COLUMN=COLUMN+$L($P(VAL," ",LOOP))+1,LGTH=LGTH+$L($P(VAL," ",LOOP))+1
Q
HDR W:$Y>0 @IOF S PAGE=PAGE+1
S CLNGTH=$L(CCORG),TAB=(80-CLNGTH)\2,TAB=TAB-1
W !,NAME,?TAB,CCORG,?61,"DUTY STATION: ",STATION_DS
W !,SSN,?71,"T&L: ",TLU,!,DASHES
S CLNGTH=$L(CATEGORY),TAB=(80-CLNGTH)\2,TAB=TAB-1
W !,"LAST PP: ",LPP,?TAB,CATEGORY,?73,"PAGE ",PAGE
W !,DASHES
K CLNGTH,TAB Q
PRTC W:$Y<22 ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
I $D(DIRUT) S PRTC=0 Q
D:'$D(END) HDR Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSD1150 3434 printed Dec 13, 2024@02:25 Page 2
PRSD1150 ;HISC/GWB-RECORD OF LEAVE DATA ;2/5/1998
+1 ;;4.0;PAID;**35,100**;Sep 21, 1995;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
EMP KILL DIC
SET DIC="^PRSPC("
SET DIC(0)="AEMQZ"
+1 SET DIC("A")="Select SEPARATED EMPLOYEE: "
DO ^DIC
KILL DIC
+2 IF Y'>0
GOTO EX
+3 SET DA=+Y
+4 IF $PIECE($GET(^PRSPC(DA,1)),U,33)'="Y"
Begin DoDot:1
+5 WRITE !!,*7,"This is not a separated employee. "
+6 WRITE "The SEPARATION IND does not equal Y.",!
End DoDot:1
GOTO EMP
START ;
+1 KILL DASHES
SET $PIECE(DASHES,"-",80)="-"
+2 SET ZERO=^PRSPC(DA,0)
+3 SET NAME=$PIECE(ZERO,U,1)
SET STATION=$PIECE(ZERO,U,7)
SET TLU=$PIECE(ZERO,U,8)
+4 SET SSN=$PIECE(ZERO,U,9)
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)
+5 SET SAL=$PIECE(ZERO,U,29)
SET HR=$SELECT(SAL>99:SAL/2087,1:SAL)
SET HR=$JUSTIFY(HR,0,2)
+6 SET Y=$PIECE(ZERO,U,49)
XECUTE ^DD(450,458,2.1)
SET CCORG=Y
+7 SET DS=$PIECE($GET(^PRSPC(DA,1)),U,42)
SET LPP=$PIECE($GET(^PRSPC(DA,"MISC4")),U,16)
+8 SET SCD=$PIECE(ZERO,U,31)
+9 SET SCDYR=$EXTRACT(SCD,1,3)
SET SCDMO=+$EXTRACT(SCD,4,5)
SET SCDDY=+$EXTRACT(SCD,6,7)
+10 SET DOS=$PIECE($GET(^PRSPC(DA,1)),U,2)
+11 ; add 1 day so empl. credited for DOS
SET DOS1=$$FMADD^XLFDT(DOS,1)
+12 SET DOS1YR=$EXTRACT(DOS1,1,3)
SET DOS1MO=+$EXTRACT(DOS1,4,5)
SET DOS1DY=+$EXTRACT(DOS1,6,7)
+13 ;
+14 ; calculate difference between DOS1 and SCD
+15 SET TOTDY=DOS1DY-SCDDY
+16 SET TOTMO=DOS1MO-SCDMO
+17 SET TOTYR=DOS1YR-SCDYR
+18 ; if negative days then recalc. Subtract 1 from month and get days by
+19 ; adding the days from first and last month together.
+20 IF TOTDY<0
Begin DoDot:1
+21 SET SCDDIM=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31",U,SCDMO)
+22 IF SCDDIM=28
SET SCDDIM=SCDDIM+$$LEAPYR^PRSLIB00(SCDYR+1700)
+23 SET TOTDY=SCDDIM-SCDDY+DOS1DY
+24 SET TOTMO=TOTMO-1
End DoDot:1
+25 IF TOTMO<0
SET TOTMO=TOTMO+12
SET TOTYR=TOTYR-1
+26 ;
ROLD SET CATEGORY="RECORD OF LEAVE DATA"
SET PAGE=0
+1 KILL ^UTILITY("DIQ1",$JOB)
SET DIC="^PRSPC("
+2 SET DR="30;49;50"
SET DIQ(0)="IE"
DO EN^DIQ1
WRITE @IOF
DO HDR
SET PRTC=1
+3 FOR F=30,49,50
DO WR
if 'PRTC
GOTO EX
+4 WRITE !,"TOTAL SERVICE FOR LEAVE.........",TOTYR," YEARS"
+5 WRITE !," ",TOTMO," MONTHS"
+6 WRITE !," ",TOTDY," DAYS"
+7 KILL ^UTILITY("DIQ1",$JOB)
SET DIC="^PRSPC("
+8 SET DR="462;510"
SET DIQ(0)="IE"
DO EN^DIQ1
+9 FOR F=462,510
DO WR
if 'PRTC
GOTO EX
+10 WRITE !,"HOURLY RATE.....................",HR
+11 SET END=""
DO PRTC
EX KILL ^UTILITY("DIQ1",$JOB)
+1 NEW PRSTLV
DO KILL^XUSCLEAN
WRITE @IOF
+2 QUIT
WR SET NODEDD=^DD(450,F,0)
SET NODEUTIL=$GET(^UTILITY("DIQ1",$JOB,450,DA,F,"E"))
+1 IF (NODEUTIL="")!(NODEUTIL="NA")
KILL NODEDD,NODEUTIL
QUIT
+2 SET FLDNAM=$PIECE(NODEDD,U,1)
+3 SET INT=^UTILITY("DIQ1",$JOB,450,DA,F,"I")
EXT SET EXT=^UTILITY("DIQ1",$JOB,450,DA,F,"E")
+1 SET IL=$LENGTH(INT)
+2 IF $PIECE(NODEDD,U,2)["NJ"
IF +INT=0
KILL NODEDD,NODEUTIL
QUIT
+3 IF $PIECE(NODEDD,U,5)["""$"""
SET VAL=$FNUMBER(INT,",",2)
GOTO IOSL
+4 IF $PIECE(NODEDD,U,2)["D"
SET VAL=EXT
GOTO IOSL
+5 IF $PIECE(NODEDD,U,2)["NJ"
SET VAL=$JUSTIFY(INT,IL,2)
GOTO IOSL
+6 SET VAL=EXT
IOSL KILL DOTS
SET NOD=32-$LENGTH(FLDNAM)
SET $PIECE(DOTS,".",NOD)="."
+1 IF $Y>(IOSL-4)
DO PRTC
if 'PRTC
QUIT
+2 WRITE !,FLDNAM,DOTS
+3 DO VAL
QUIT
VAL IF $LENGTH(VAL)<48
WRITE ?32,VAL
QUIT
+1 SET COLUMN=32
SET LGTH=0
+2 FOR LOOP=1:1
if LGTH=$LENGTH(VAL)!(LGTH>($LENGTH(VAL)))
QUIT
if $LENGTH($PIECE(VAL," ",LOOP))>(80-COLUMN)
WRITE !
if $LENGTH($PIECE(VAL," ",LOOP))>(80-COLUMN)
SET COLUMN=32
WRITE ?COLUMN,$PIECE(VAL," ",LOOP)
SET COLUMN=COLUMN+$LENGTH($PIECE(VAL," ",LOOP))+1
SET LGTH=LGTH+$LENGTH($PIECE(VAL," ",LOOP))+1
+3 QUIT
HDR if $Y>0
WRITE @IOF
SET PAGE=PAGE+1
+1 SET CLNGTH=$LENGTH(CCORG)
SET TAB=(80-CLNGTH)\2
SET TAB=TAB-1
+2 WRITE !,NAME,?TAB,CCORG,?61,"DUTY STATION: ",STATION_DS
+3 WRITE !,SSN,?71,"T&L: ",TLU,!,DASHES
+4 SET CLNGTH=$LENGTH(CATEGORY)
SET TAB=(80-CLNGTH)\2
SET TAB=TAB-1
+5 WRITE !,"LAST PP: ",LPP,?TAB,CATEGORY,?73,"PAGE ",PAGE
+6 WRITE !,DASHES
+7 KILL CLNGTH,TAB
QUIT
PRTC if $Y<22
WRITE !
KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+1 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
+2 IF $DATA(DIRUT)
SET PRTC=0
QUIT
+3 if '$DATA(END)
DO HDR
QUIT
+4 QUIT
