source: WorldVistAEHR/trunk/r/PAID-PRS/PRSDV450.m@ 1789

Last change on this file since 1789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1PRSDV450 ;HISC/MGD-VIEW PAID EMPLOYEE DATA ;09/05/2003
2 ;;4.0;PAID;**2,82,114**;Sep 21, 1995;Build 6
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4EN1 ;HRM entry
5 S LIMIT=10,PRSTLV=7 D PTBL^PRSDVTBL G EMP
6EN2 ;Fiscal entry
7 S LIMIT=12,PRSTLV=7 D FTBL^PRSDVTBL
8EMP K DASHES S $P(DASHES,"-",80)="-",FIRST=""
9 K DIC,^UTILITY("DIQ1",$J)
10 S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: " D ^DIC
11 K DIC I Y'>0 D KILL1,KILL2 Q
12 S DA=+Y,ZERO=^PRSPC(DA,0),NAME=$P(ZERO,U,1),SSN=$P(ZERO,U,9)
13 S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9),TLU=$P(ZERO,U,8)
14 S STATION=$P(ZERO,U,7),Y=$P(ZERO,U,49) X ^DD(450,458,2.1) S CCORG=Y
15 S DS=$P($G(^PRSPC(DA,1)),U,42),LPP=$P($G(^PRSPC(DA,"MISC4")),U,16)
16CAT S CLNGTH=$L(CCORG),TAB=(80-CLNGTH)\2,TAB=TAB-1
17 W @IOF,!,NAME,?TAB,CCORG,?62,"DUTY STATION: ",STATION_DS
18 W !,SSN,?71,"T&L: ",TLU,!,DASHES
19 W ! F L=1:1:LIMIT W !,?20,$P(CHOICE(L),";",3),?23,$P(CHOICE(L),";",4)
20SAN W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT
21 S DIR(0)="NAO^1:"_LIMIT_":0",DIR("A")="Select a number: "
22 S DIR("?")="Type a number between 1 and "_LIMIT S:$D(FIRST) DIR("B")=3
23 D ^DIR I ($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) D KILL1 G EMP
24 I X="@" W !!,*7,DIR("?")_"." G SAN
25 G:X="" EMP
26 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
27 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
28 S PAGE=0,CATEGORY=$P(CHOICE(+Y),";",4),LAB=$P(CHOICE(+Y),";",5)
29 S NOL=$P(CHOICE(+Y),";",6)
30 F L=1:1:NOL S (VAL(L),PRNTORDR(L))=$P($T(@LAB+L^PRSDVTBL),";",3) D
31 .F Q:VAL(L)'["," S VAL(L)=$P(VAL(L),",")_";"_$P(VAL(L),",",2,999)
32 .F Q:VAL(L)'[":1:" S VAL(L)=$P(VAL(L),":1:")_":"_$P(VAL(L),":1:",2,999)
33 .F Q:VAL(L)'[":.01:" S VAL(L)=$P(VAL(L),":.01:")_":"_$P(VAL(L),":.01:",2,999)
34 S IOFSAV=IOF
35 K %ZIS,IOP S %ZIS="MQ",%ZIS("B")="" D ^%ZIS I POP D KILL1,KILL2 Q
36 S IOF=IOFSAV
37 F L="CATEGORY","CCORG","CLNGTH","DA","DASHES","DATETIME","VAL(","DS","LPP","NAME","PAGE","PRNTORDR(","SSN","STATION","TAB","TLU","PRSTLV" S ZTSAVE(L)=""
38 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
39 D:$E(IOST,1)="C" WAIT^DICD
40 U IO D DISPLAY K FIRST G:PRTC=0 CAT
41 I $E(IOST,1)="C" D:PRTC="" PRTC G:PRTC=0 CAT
42 D:$E(IOST,1)'="C" ^%ZISC
43 W @IOF K FIRST G CAT
44DISPLAY S DRIEN=0 F S DRIEN=$O(VAL(DRIEN)) Q:DRIEN="" S DIQ(0)="EI",DIC="^PRSPC(",DR=VAL(DRIEN) D EN^DIQ1
45 W:$E(IOST,1)="C" @IOF D HDR^PRSDSRS
46 D ^PRSDYTD
47 I CATEGORY="LABOR DISTRIBUTION" D
48 . S PRTC=0
49 . D LD
50 . I $E(IOST,1)="C" D CHECK
51 . I $E(IOST,1)'="C" D ^%ZISC
52 I CATEGORY'="LABOR DISTRIBUTION" D
53 . 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
54KILL1 K D0,DIC,DIQ,DIQ2,DIR,DIRUT,DIROUT,DR,DRIEN,VAL,DTOUT,DUOUT,FIELDN
55 K IOFSAV,IOP,L,POP,PRIEN,PRNTORDR,PRNTVALS,X,Y,ZERO,ZTDESC,ZTIO,ZTRTN
56 K ZTSAVE,ZTSK,%ZIS,^UTILITY("DIQ1",$J)
57 D YTDEX^PRSDYTD
58 Q
59KILL2 K CATEGORY,CCORG,CHOICE,CLNGTH,DA,DASHES,DATETIME,DS,FIRST,LAB,LIMIT,LPP
60 K NAME,NOL,PAGE,PRSTLV,PRTC,SSN,STATION,TAB,TLU,LOOP,ZTREQ,%,%I
61 Q
62CHECK I $E(IOST,1)="C",$Y>(IOSL-4) D PRTC
63 Q
64PRTC W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT
65 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR S PRTC=Y
66 S:$D(DIRUT) PRTC=0
67 Q
68LD ; Display Labor Distribution codes
69 Q:'$G(DA)
70 N DESC,INTERNAL,LDCNT,LDDATA,NODEDD,PRSLD,Y
71 S DIC=450,DIQ(0)="IE",DIQ="LDDATA"
72 F PRSLD=756,755,755.1 D
73 . S DR=PRSLD
74 . D EN^DIQ1
75 . S NODEDD=^DD(450,PRSLD,0)
76 . S INTERNAL=$G(LDDATA(450,DA,PRSLD,"I"))
77 . S DESC=$G(LDDATA(450,DA,PRSLD,"E"))
78 . W !,$P(NODEDD,U,1)
79 . 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))
80 . I $P(NODEDD,U,2)'["D",INTERNAL'=DESC D DESC^PRSDW450
81 ;
82 F PRSLD=1:1:4 D
83 . S DIC=450,DR=757 ; Specify LD multiple
84 . S DR(450.0757)="1;2;3;4",DA(450.0757)=PRSLD ; Specify fields w/in mult
85 . S DIQ(0)="IE",DIQ="LDDATA"
86 . D EN^DIQ1
87 . F LDCNT=1:1:4 D
88 . . S NODEDD=^DD(450.0757,LDCNT,0)
89 . . S INTERNAL=$G(LDDATA(450.0757,PRSLD,LDCNT,"I"))
90 . . I LDCNT'=3 S DESC=$G(LDDATA(450.0757,PRSLD,LDCNT,"E"))
91 . . I LDCNT=3 D
92 . . . S Y=INTERNAL,SUB454="CC"
93 . . . D OT^PRSDUTIL K SUB454
94 . . . S DESC=Y
95 . . W !,"LABOR DIST CODE-",PRSLD," ",$P(NODEDD,U,1)
96 . . 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))
97 . . I $P(NODEDD,U,2)'["D",INTERNAL'=DESC D DESC^PRSDW450
98 . . D CHECK
99 . . I PRTC W @IOF D HDR^PRSDSRS S PRTC=0
100 I $E(IOST,1)="C" D PRTC
101 Q
Note: See TracBrowser for help on using the repository browser.