PRSDV450 ;HISC/MGD-VIEW PAID EMPLOYEE DATA ;09/05/2003
;;4.0;PAID;**2,82,114,100**;Sep 21, 1995;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
EN1 ;HRM entry
S LIMIT=10,PRSTLV=7 D PTBL^PRSDVTBL G EMP
EN2 ;Fiscal entry
S LIMIT=12,PRSTLV=7 D FTBL^PRSDVTBL
EMP K DASHES S $P(DASHES,"-",80)="-",FIRST=""
K DIC,^UTILITY("DIQ1",$J)
S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: " D ^DIC
K DIC I Y'>0 D KILL1,KILL2 Q
S DA=+Y,ZERO=^PRSPC(DA,0),NAME=$P(ZERO,U,1),SSN=$P(ZERO,U,9)
S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9),TLU=$P(ZERO,U,8)
S STATION=$P(ZERO,U,7),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)
CAT S CLNGTH=$L(CCORG),TAB=(80-CLNGTH)\2,TAB=TAB-1
W @IOF,!,NAME,?TAB,CCORG,?61,"DUTY STATION: ",STATION_DS
W !,SSN,?71,"T&L: ",TLU,!,DASHES
W ! F L=1:1:LIMIT W !,?20,$P(CHOICE(L),";",3),?23,$P(CHOICE(L),";",4)
SAN W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)="NAO^1:"_LIMIT_":0",DIR("A")="Select a number: "
S DIR("?")="Type a number between 1 and "_LIMIT S:$D(FIRST) DIR("B")=3
D ^DIR I ($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) D KILL1 G EMP
I X="@" W !!,*7,DIR("?")_"." G SAN
G:X="" EMP
I CHOICE(+Y)["NURSING" S PP=$P(^PRSPC(DA,0),U,21) I (PP'="K")&(PP'="M")&(PP'="X") W !!,*7,"This employee is not a nurse. Pay Plan code not K, M or X.",! K PP G SAN
I CHOICE(+Y)["SEPARATED" I $P($G(^PRSPC(DA,1)),U,33)'="Y" W !!,*7,"This is not a separated employee. Separation Ind not equal Y.",! G SAN
S PAGE=0,CATEGORY=$P(CHOICE(+Y),";",4),LAB=$P(CHOICE(+Y),";",5)
S NOL=$P(CHOICE(+Y),";",6)
F L=1:1:NOL S (VAL(L),PRNTORDR(L))=$P($T(@LAB+L^PRSDVTBL),";",3) D
.F Q:VAL(L)'["," S VAL(L)=$P(VAL(L),",")_";"_$P(VAL(L),",",2,999)
.F Q:VAL(L)'[":1:" S VAL(L)=$P(VAL(L),":1:")_":"_$P(VAL(L),":1:",2,999)
.F Q:VAL(L)'[":.01:" S VAL(L)=$P(VAL(L),":.01:")_":"_$P(VAL(L),":.01:",2,999)
S IOFSAV=IOF
K %ZIS,IOP S %ZIS="MQ",%ZIS("B")="" D ^%ZIS I POP D KILL1,KILL2 Q
S IOF=IOFSAV
F L="CATEGORY","CCORG","CLNGTH","DA","DASHES","DATETIME","VAL(","DS","LPP","NAME","PAGE","PRNTORDR(","SSN","STATION","TAB","TLU","PRSTLV" S ZTSAVE(L)=""
I $D(IO("Q")) S ZTIO=ION,ZTDESC="DISPLAY EMPLOYEE DATA",ZTRTN="DISPLAY^PRSDV450",ZTREQ="@",ZTSAVE("ZTREQ")="" D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued!" D KILL1 K FIRST G CAT
D:$E(IOST,1)="C" WAIT^DICD
U IO D DISPLAY K FIRST G:PRTC=0 CAT
I $E(IOST,1)="C" D:PRTC="" PRTC G:PRTC=0 CAT
D:$E(IOST,1)'="C" ^%ZISC
W @IOF K FIRST G CAT
DISPLAY S DRIEN=0 F S DRIEN=$O(VAL(DRIEN)) Q:DRIEN="" S DIQ(0)="EI",DIC="^PRSPC(",DR=VAL(DRIEN) D EN^DIQ1
W:$E(IOST,1)="C" @IOF D HDR^PRSDSRS
D ^PRSDYTD
I CATEGORY="LABOR DISTRIBUTION" D
. S PRTC=0
. D LD
. I $E(IOST,1)="C" D CHECK
. I $E(IOST,1)'="C" D ^%ZISC
I CATEGORY'="LABOR DISTRIBUTION" D
. S PRIEN=0,PRTC="" F S PRIEN=$O(PRNTORDR(PRIEN)) Q:PRIEN="" S PRNTVALS="F FIELDN="_PRNTORDR(PRIEN)_" D WRITE^PRSDW450 Q:PRTC=0" X PRNTVALS
KILL1 K D0,DIC,DIQ,DIQ2,DIR,DIRUT,DIROUT,DR,DRIEN,VAL,DTOUT,DUOUT,FIELDN
K IOFSAV,IOP,L,POP,PRIEN,PRNTORDR,PRNTVALS,X,Y,ZERO,ZTDESC,ZTIO,ZTRTN
K ZTSAVE,ZTSK,%ZIS,^UTILITY("DIQ1",$J)
D YTDEX^PRSDYTD
Q
KILL2 K CATEGORY,CCORG,CHOICE,CLNGTH,DA,DASHES,DATETIME,DS,FIRST,LAB,LIMIT,LPP
K NAME,NOL,PAGE,PRSTLV,PRTC,SSN,STATION,TAB,TLU,LOOP,ZTREQ,%,%I
Q
CHECK I $E(IOST,1)="C",$Y>(IOSL-4) D PRTC
Q
PRTC W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR S PRTC=Y
S:$D(DIRUT) PRTC=0
Q
LD ; Display Labor Distribution codes
Q:'$G(DA)
N DESC,INTERNAL,LDCNT,LDDATA,NODEDD,PRSLD,Y
S DIC=450,DIQ(0)="IE",DIQ="LDDATA"
F PRSLD=756,755,755.1 D
. S DR=PRSLD
. D EN^DIQ1
. S NODEDD=^DD(450,PRSLD,0)
. S INTERNAL=$G(LDDATA(450,DA,PRSLD,"I"))
. S DESC=$G(LDDATA(450,DA,PRSLD,"E"))
. W !,$P(NODEDD,U,1)
. W ?30,$S($P(NODEDD,U,5)["""$""":$J($FN(INTERNAL,",",2),14),$P(NODEDD,U,2)["NJ":$J(INTERNAL,14,2),$P(NODEDD,U,2)["D":$J(DESC,14),1:$J(INTERNAL,14))
. I $P(NODEDD,U,2)'["D",INTERNAL'=DESC D DESC^PRSDW450
;
F PRSLD=1:1:4 D
. S DIC=450,DR=757 ; Specify LD multiple
. S DR(450.0757)="1;2;3;4",DA(450.0757)=PRSLD ; Specify fields w/in mult
. S DIQ(0)="IE",DIQ="LDDATA"
. D EN^DIQ1
. F LDCNT=1:1:4 D
. . S NODEDD=^DD(450.0757,LDCNT,0)
. . S INTERNAL=$G(LDDATA(450.0757,PRSLD,LDCNT,"I"))
. . I LDCNT'=3 S DESC=$G(LDDATA(450.0757,PRSLD,LDCNT,"E"))
. . I LDCNT=3 D
. . . S Y=INTERNAL,SUB454="CC"
. . . D OT^PRSDUTIL K SUB454
. . . S DESC=Y
. . W !,"LABOR DIST CODE-",PRSLD," ",$P(NODEDD,U,1)
. . W ?30,$S($P(NODEDD,U,5)["""$""":$J($FN(INTERNAL,",",2),14),$P(NODEDD,U,2)["NJ":$J(INTERNAL,14,2),$P(NODEDD,U,2)["D":$J(DESC,14),1:$J(INTERNAL,14))
. . I $P(NODEDD,U,2)'["D",INTERNAL'=DESC D DESC^PRSDW450
. . D CHECK
. . I PRTC W @IOF D HDR^PRSDSRS S PRTC=0
I $E(IOST,1)="C" D PRTC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDV450 4877 printed Apr 09, 2024@21:25:53 Page 2
PRSDV450 ;HISC/MGD-VIEW PAID EMPLOYEE DATA ;09/05/2003
+1 ;;4.0;PAID;**2,82,114,100**;Sep 21, 1995;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
EN1 ;HRM entry
+1 SET LIMIT=10
SET PRSTLV=7
DO PTBL^PRSDVTBL
GOTO EMP
EN2 ;Fiscal entry
+1 SET LIMIT=12
SET PRSTLV=7
DO FTBL^PRSDVTBL
EMP KILL DASHES
SET $PIECE(DASHES,"-",80)="-"
SET FIRST=""
+1 KILL DIC,^UTILITY("DIQ1",$JOB)
+2 SET DIC="^PRSPC("
SET DIC(0)="AEMQZ"
SET DIC("A")="Select EMPLOYEE: "
DO ^DIC
+3 KILL DIC
IF Y'>0
DO KILL1
DO KILL2
QUIT
+4 SET DA=+Y
SET ZERO=^PRSPC(DA,0)
SET NAME=$PIECE(ZERO,U,1)
SET SSN=$PIECE(ZERO,U,9)
+5 SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)
SET TLU=$PIECE(ZERO,U,8)
+6 SET STATION=$PIECE(ZERO,U,7)
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)
CAT SET CLNGTH=$LENGTH(CCORG)
SET TAB=(80-CLNGTH)\2
SET TAB=TAB-1
+1 WRITE @IOF,!,NAME,?TAB,CCORG,?61,"DUTY STATION: ",STATION_DS
+2 WRITE !,SSN,?71,"T&L: ",TLU,!,DASHES
+3 WRITE !
FOR L=1:1:LIMIT
WRITE !,?20,$PIECE(CHOICE(L),";",3),?23,$PIECE(CHOICE(L),";",4)
SAN WRITE !
KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+1 SET DIR(0)="NAO^1:"_LIMIT_":0"
SET DIR("A")="Select a number: "
+2 SET DIR("?")="Type a number between 1 and "_LIMIT
if $DATA(FIRST)
SET DIR("B")=3
+3 DO ^DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
DO KILL1
GOTO EMP
+4 IF X="@"
WRITE !!,*7,DIR("?")_"."
GOTO SAN
+5 if X=""
GOTO EMP
+6 IF CHOICE(+Y)["NURSING"
SET PP=$PIECE(^PRSPC(DA,0),U,21)
IF (PP'="K")&(PP'="M")&(PP'="X")
WRITE !!,*7,"This employee is not a nurse. Pay Plan code not K, M or X.",!
KILL PP
GOTO SAN
+7 IF CHOICE(+Y)["SEPARATED"
IF $PIECE($GET(^PRSPC(DA,1)),U,33)'="Y"
WRITE !!,*7,"This is not a separated employee. Separation Ind not equal Y.",!
GOTO SAN
+8 SET PAGE=0
SET CATEGORY=$PIECE(CHOICE(+Y),";",4)
SET LAB=$PIECE(CHOICE(+Y),";",5)
+9 SET NOL=$PIECE(CHOICE(+Y),";",6)
+10 FOR L=1:1:NOL
SET (VAL(L),PRNTORDR(L))=$PIECE($TEXT(@LAB+L^PRSDVTBL),";",3)
Begin DoDot:1
+11 FOR
if VAL(L)'[","
QUIT
SET VAL(L)=$PIECE(VAL(L),",")_";"_$PIECE(VAL(L),",",2,999)
+12 FOR
if VAL(L)'["
QUIT
SET VAL(L)=$PIECE(VAL(L),":1:")_":"_$PIECE(VAL(L),":1:",2,999)
+13 FOR
if VAL(L)'["
QUIT
SET VAL(L)=$PIECE(VAL(L),":.01:")_":"_$PIECE(VAL(L),":.01:",2,999)
End DoDot:1
+14 SET IOFSAV=IOF
+15 KILL %ZIS,IOP
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
IF POP
DO KILL1
DO KILL2
QUIT
+16 SET IOF=IOFSAV
+17 FOR L="CATEGORY","CCORG","CLNGTH","DA","DASHES","DATETIME","VAL(","DS","LPP","NAME","PAGE","PRNTORDR(","SSN","STATION","TAB","TLU","PRSTLV"
SET ZTSAVE(L)=""
+18 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTDESC="DISPLAY EMPLOYEE DATA"
SET ZTRTN="DISPLAY^PRSDV450"
SET ZTREQ="@"
SET ZTSAVE("ZTREQ")=""
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Request Queued!"
DO KILL1
KILL FIRST
GOTO CAT
+19 if $EXTRACT(IOST,1)="C"
DO WAIT^DICD
+20 USE IO
DO DISPLAY
KILL FIRST
if PRTC=0
GOTO CAT
+21 IF $EXTRACT(IOST,1)="C"
if PRTC=""
DO PRTC
if PRTC=0
GOTO CAT
+22 if $EXTRACT(IOST,1)'="C"
DO ^%ZISC
+23 WRITE @IOF
KILL FIRST
GOTO CAT
DISPLAY SET DRIEN=0
FOR
SET DRIEN=$ORDER(VAL(DRIEN))
if DRIEN=""
QUIT
SET DIQ(0)="EI"
SET DIC="^PRSPC("
SET DR=VAL(DRIEN)
DO EN^DIQ1
+1 if $EXTRACT(IOST,1)="C"
WRITE @IOF
DO HDR^PRSDSRS
+2 DO ^PRSDYTD
+3 IF CATEGORY="LABOR DISTRIBUTION"
Begin DoDot:1
+4 SET PRTC=0
+5 DO LD
+6 IF $EXTRACT(IOST,1)="C"
DO CHECK
+7 IF $EXTRACT(IOST,1)'="C"
DO ^%ZISC
End DoDot:1
+8 IF CATEGORY'="LABOR DISTRIBUTION"
Begin DoDot:1
+9 SET PRIEN=0
SET PRTC=""
FOR
SET PRIEN=$ORDER(PRNTORDR(PRIEN))
if PRIEN=""
QUIT
SET PRNTVALS="F FIELDN="_PRNTORDR(PRIEN)_" D WRITE^PRSDW450 Q:PRTC=0"
XECUTE PRNTVALS
End DoDot:1
KILL1 KILL D0,DIC,DIQ,DIQ2,DIR,DIRUT,DIROUT,DR,DRIEN,VAL,DTOUT,DUOUT,FIELDN
+1 KILL IOFSAV,IOP,L,POP,PRIEN,PRNTORDR,PRNTVALS,X,Y,ZERO,ZTDESC,ZTIO,ZTRTN
+2 KILL ZTSAVE,ZTSK,%ZIS,^UTILITY("DIQ1",$JOB)
+3 DO YTDEX^PRSDYTD
+4 QUIT
KILL2 KILL CATEGORY,CCORG,CHOICE,CLNGTH,DA,DASHES,DATETIME,DS,FIRST,LAB,LIMIT,LPP
+1 KILL NAME,NOL,PAGE,PRSTLV,PRTC,SSN,STATION,TAB,TLU,LOOP,ZTREQ,%,%I
+2 QUIT
CHECK IF $EXTRACT(IOST,1)="C"
IF $Y>(IOSL-4)
DO PRTC
+1 QUIT
PRTC WRITE !
KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+1 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
SET PRTC=Y
+2 if $DATA(DIRUT)
SET PRTC=0
+3 QUIT
LD ; Display Labor Distribution codes
+1 if '$GET(DA)
QUIT
+2 NEW DESC,INTERNAL,LDCNT,LDDATA,NODEDD,PRSLD,Y
+3 SET DIC=450
SET DIQ(0)="IE"
SET DIQ="LDDATA"
+4 FOR PRSLD=756,755,755.1
Begin DoDot:1
+5 SET DR=PRSLD
+6 DO EN^DIQ1
+7 SET NODEDD=^DD(450,PRSLD,0)
+8 SET INTERNAL=$GET(LDDATA(450,DA,PRSLD,"I"))
+9 SET DESC=$GET(LDDATA(450,DA,PRSLD,"E"))
+10 WRITE !,$PIECE(NODEDD,U,1)
+11 WRITE ?30,$SELECT($PIECE(NODEDD,U,5)["""$""":$JUSTIFY($FNUMBER(INTERNAL,",",2),14),$PIECE(NODEDD,U,2)["NJ":$JUSTIFY(INTERNAL,14,2),$PIECE(NODEDD,U,2)["D":$JUSTIFY(DESC,14),1:$JUSTIFY(INTERNAL,14))
+12 IF $PIECE(NODEDD,U,2)'["D"
IF INTERNAL'=DESC
DO DESC^PRSDW450
End DoDot:1
+13 ;
+14 FOR PRSLD=1:1:4
Begin DoDot:1
+15 ; Specify LD multiple
SET DIC=450
SET DR=757
+16 ; Specify fields w/in mult
SET DR(450.0757)="1;2;3;4"
SET DA(450.0757)=PRSLD
+17 SET DIQ(0)="IE"
SET DIQ="LDDATA"
+18 DO EN^DIQ1
+19 FOR LDCNT=1:1:4
Begin DoDot:2
+20 SET NODEDD=^DD(450.0757,LDCNT,0)
+21 SET INTERNAL=$GET(LDDATA(450.0757,PRSLD,LDCNT,"I"))
+22 IF LDCNT'=3
SET DESC=$GET(LDDATA(450.0757,PRSLD,LDCNT,"E"))
+23 IF LDCNT=3
Begin DoDot:3
+24 SET Y=INTERNAL
SET SUB454="CC"
+25 DO OT^PRSDUTIL
KILL SUB454
+26 SET DESC=Y
End DoDot:3
+27 WRITE !,"LABOR DIST CODE-",PRSLD," ",$PIECE(NODEDD,U,1)
+28 WRITE ?30,$SELECT($PIECE(NODEDD,U,5)["""$""":$JUSTIFY($FNUMBER(INTERNAL,",",2),14),$PIECE(NODEDD,U,2)["NJ":$JUSTIFY(INTERNAL,14,2),$PIECE(NODEDD,U,2)["D":$JUSTIFY(DESC,14),1:$JUSTIFY(INTERNAL,14))
+29 IF $PIECE(NODEDD,U,2)'["D"
IF INTERNAL'=DESC
DO DESC^PRSDW450
+30 DO CHECK
+31 IF PRTC
WRITE @IOF
DO HDR^PRSDSRS
SET PRTC=0
End DoDot:2
End DoDot:1
+32 IF $EXTRACT(IOST,1)="C"
DO PRTC
+33 QUIT
