source: FOIAVistA/trunk/r/PAID-PRS/PRSDSERV.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1PRSDSERV ;WOIFO/MGD,PLT - PAID DOWNLOAD MESSAGE SERVER ;12/3/07
2 ;;4.0;PAID;**6,78,82,116**;Sep 21, 1995;Build 23
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 D NOW^%DTC S TIME=% S XMPOS=1 D REC^XMS3 G:XMER'=0 EXIT
5 S LPE=$E(XMRG,1,7) I LPE'?1"**"2N1"PDH",LPE'="****PDH" G EXIT
6 ; EMPCNT = # emp in this mail message
7 ; SEQNUM = Mail message sequence number if more than one message
8 S EMPCNT=+$E(XMRG,9,12),SEQNUM=$E(XMRG,13,16),TYPE=$E(XMRG,23)
9 S DATE=$E(XMRG,24,31),STA="",SUB="TMP"
10 I "IEPTD"'[TYPE G EXIT
11 ; Check to see if the message was previously loaded
12 I $D(^PRSD(450.12,"B",XMZ)) G EXIT
13 S MTYPE=$S(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"")
14 ; Set Lines Per Employee (LPE) for the correct interface
15 S LPE=$E(LPE,3,4),LPE=$S(LPE?2N:+LPE,TYPE="I":20,(TYPE="E")!(TYPE="T"):15,TYPE="P":9,1:0)
16 D REC^XMS3 G:XMER'=0 EXIT S STA=$E(XMRG,1,3) I STA'?3N G EXIT
17 I TYPE="D" D ^PRSDDL G EXIT ; Process Separation download
18 ; Mark message as received. This info is for the reports sent to the
19 ; PAD mail group.
20 I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) D G EXIT
21 .S ^TMP($J,"PRSD",999)=MTYPE_" message "_SEQNUM_" received."
22 .D SETPRS S MNR="" D PROC^PRSDPROC
23 I $D(^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM)) G EXIT
24 K DD,DO S DIC="^PRSD(450.12,",DIC(0)="L",X=XMZ D FILE^DICN
25 S PRSDIEN=+Y,$P(^PRSD(450.12,+Y,0),U,2)=TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM
26 S $P(^PRSD(450.12,+Y,0),U,3)="R",$P(^PRSD(450.12,+Y,0),U,4)=TIME
27 S ^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM,+Y)=""
28SETPRS ;start employee record
29 S XMPOS=2 F A=1:1:EMPCNT D SSNLOOP Q:SSN=999999999
30 I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) K ^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM) Q
31 S:SSN'=999999999 $P(^PRSD(450.12,PRSDIEN,0),U,3)="S"
32EXIT K %,%H,%I,A,AA,AAA,ADDFLG,B,BB,CC,DA,DATA,DATE,DBNAME,DIC,DIK,DINUM
33 K DLAYGO,DLID,E1,E2,EE,ECNT,ECOUNT,EMPCNT,ERRCNT,ERRFLG,ERRID,ERRIEN,SUB
34 K ERRMSG,FLD,FLDNUM,GNUM,GRP,GRPVAL,IEN,II,LPE,LTH,MO,MFLD,MTYPE,MULT
35 K NAME,NODE,NODE459,PIC,PIECE,PIECE459,PP,PP455,PPIEN,PRSD,PRSDIEN,RCD
36 K RTN,RTNNUM,RTYPE,SEQNUM,SSN,SSNLINE,STA,STA450,SUM,TMPIEN,TMPLINE
37 K TIME,TYPE,X,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,Y,YR,XMPOS,XMRG,XMER,XMLOC
38 K XMMG,MNR,PDATE,CDATE,X1,X2
39REMSB I $D(XMZ) S XMSER="S.PRSD" D REMSBMSG^XMA1C K XMSER
40 Q
41SSNLOOP D REC^XMS3
42 S SSN=$S(TYPE="I":$P(XMRG,":",2),1:$E(XMRG,4,12))
43 S SSN=$E("000000000",$L(SSN)+1,9)_SSN
44 ; The last employee in the last MailMan message has a SSN=999999999
45 ; This triggers the software to begin processing the download.
46 I SSN=999999999 D Q
47 .I TYPE="I" K ^XTMP("PRS","ERR")
48 .S ^XTMP("PRS","LSN",TYPE,DATE,STA)=SEQNUM
49 .S:$D(PRSDIEN) $P(^PRSD(450.12,PRSDIEN,0),U,3)="S" H 600
50 .D REMSB S ECNT=0 D START,START,^PRSDERR,^PRSDSTAT S SSN=999999999
51 S (PDATE,CDATE)=$P(TIME,".",1),X1=PDATE,X2=90 D C^%DTC S PDATE=X
52 S ^XTMP("PRS",0)=PDATE_"^"_CDATE
53 K KFLG S XMPOS=XMPOS-1
54 F B=1:1:LPE D REC^XMS3 I (($L(XMRG,":")-1)'=$L(XMRG))!(TYPE="I") S TMPLINE=$E("000",$L(XMPOS)+1,3)_XMPOS,^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,XMZ_"-"_TMPLINE_"-"_B)=XMRG I TYPE="T",B=6 D TRANSCK^PRSDERR
55 I $D(KFLG) K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN),KFLG
56 Q
57START ; Process download
58 ; RTYPE is used to determine which series of routines to call to
59 ; process the download
60 S SSN="",RTYPE=$S(TYPE="I":"LD",(TYPE="E")!(TYPE="T"):"EU",TYPE="P":"PR",1:"")
61 F S SSN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN)) Q:SSN="" D
62 . L +^XTMP("PRS",SUB,DATE,TYPE,STA,SSN):0
63 . I $T D
64 . . S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,""))
65 . . I TMPIEN'="" D
66 . . . S RCD=^(TMPIEN),ERRFLG=""
67 . . . D SSN
68 . . . D:ERRFLG'="Y" LDINIT,PROC,PROC2,LDFNL,LDCMP
69 . . . D:ERRFLG="Y" TMPERR D UNL
70 Q
71 ; Piece together the routine name and call the routine
72PROC S TMPIEN="" F S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)) Q:TMPIEN="" S RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN),RTNNUM=$P(TMPIEN,"-",3) S:$L(RTNNUM)=1 RTNNUM=0_RTNNUM S RTN="^PRSD"_RTYPE_RTNNUM D:$T(@RTN)]"" @RTN
73 Q
74PROC2 I TYPE="P",PP'="" D ^PRSDCOMP ;Compute calculated fields
75 S NODE=0 F EE=1:1 S NODE=$O(^PRSPC(IEN,NODE)) Q:NODE="" I $D(^PRSPC(IEN,NODE))#2 S DATA=^PRSPC(IEN,NODE) I $L(DATA,U)-1=$L(DATA) K ^PRSPC(IEN,NODE)
76 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
77TMPERR I TYPE="P",PP="" G TMPERR1
78 S TMPIEN="" F S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)) Q:TMPIEN="" S RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN),^XTMP("PRS","ERR",DATE,TYPE,STA,SSN,TMPIEN)=RCD
79TMPERR1 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
80UNL L -^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
81SSN I TYPE="P",'$D(^PRSPC("SSN",SSN)) S ERRMSG="SSN "_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_" not found" D ERR Q
82 I TYPE="I" S NAME=$P(RCD,":",4)
83 I (TYPE="E")!(TYPE="T") S NAME=$P(RCD,":",2),DATA=$E(NAME,1,27) I DATA'="" D RTS^PRSDUTIL S NAME=DATA S:TYPE="T" ^TMP($J,"PRS",NAME,SSN)=""
84 I '$D(^PRSPC("SSN",SSN)) D ^PRSDADD K DA,DIE,DR,OLDSSN,VAIEN,VANAME Q:ERRFLG="Y" G SSNOUT
85 S IEN=0,IEN=$O(^PRSPC("SSN",SSN,IEN))
86SSNOUT I TYPE="P" D ^PRSDPTYP I PP="" S ERRFLG="Y" Q
87 S ECNT=ECNT+1
88 Q
89ERR K DD,DO S DIC="^PRSD(450.11,",DIC(0)="L",X=TYPE_"-"_DATE_"-"_STA D FILE^DICN I Y>0 S $P(^PRSD(450.11,+Y,0),U,3)=ERRMSG
90 S ERRFLG="Y"
91 Q
92LDINIT ; Load Initial Labor Distribution Values
93 S LDINIT=$$LDLOAD()
94 Q
95LDFNL ; Load Final Labor Distribution Values
96 S LDFNL=$$LDLOAD()
97 Q
98LDLOAD() ; Retrieve current Labor Distribution Values from #450
99 ;
100 N LD,LDCC,LDCODE,LDFCP,LDPCT,PRSLD
101 S LD=""
102 F PRSLD=1:1:4 D
103 . S LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_IEN,1)
104 . S LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_IEN,2)
105 . S LDCC=$$GET1^DIQ(450.0757,PRSLD_","_IEN,3)
106 . S LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_IEN,4)
107 . S LD=LD_LDCODE_U_LDPCT_U_LDCC_U_LDFCP_U
108 Q LD
109 ;
110LDCMP ; Compare Initial and Final Labor Distribution for changes
111 ; and update audit trail in #458 if necessary.
112 Q:LDINIT=LDFNL
113 N PPA,I,IENS,IENS1,INDX,J,LDA,PRSFDA,TLDPER
114 ; Get IEN for current Pay Period
115 S PPA=$P($G(^PRST(458,"AD",$P(TIME,".",1))),U,1)
116 Q:PPA=""
117 ;
118 ; Get next multiple number
119 S LDA="A",LDA=$O(^PRST(458,PPA,"E",IEN,"LDAUD",LDA),-1)
120 S LDA=$S(LDA>0:LDA+1,1:1)
121 ;
122 ; Set Audit information into #450
123 S DA=IEN,DIE="^PRSPC("
124 S DR="755///^S X=$O(^VA(200,""B"",""CENTRAL,PAID"",0))"
125 D ^DIE
126 S DR="755.1///^S X=TYPE"
127 D ^DIE
128 S DR="756///^S X=TIME"
129 D ^DIE
130 ;
131 ; If there is no entry for this employee in the Pay Period, create
132 ; a record for them
133 I '$D(^PRSPC(458,PPA,"E",IEN)) D
134 . S IENS=","_PPA_","
135 . S PRSFDA(458.01,"?+1"_IENS,.01)=IEN
136 . D UPDATE^DIE("","PRSFDA")
137 ;
138 ; Set LD AUDIT record into #458.1105
139 S IENS=","_IEN_IENS
140 K PRSFDA
141 S PRSFDA(458.1105,"?+1"_IENS,.01)=LDA
142 S PRSFDA(458.1105,"?+1"_IENS,1)=TIME
143 S PRSFDA(458.1105,"?+1"_IENS,2)=$O(^VA(200,"B","CENTRAL PAID",0))
144 S PRSFDA(458.1105,"?+1"_IENS,3)=TYPE
145 D UPDATE^DIE("","PRSFDA")
146 ;
147 ; Central PAID only sends LD fields that have changed. Run check on
148 ; percentages and delete all LD fields in #450 after 99% has been reached
149 S TLDPER=0
150 F I=0:1:3 S TLDPER=TLDPER+$P(LDFNL,U,I*4+2) Q:TLDPER'<.99
151 S J=(I+1)*4+1 ; Set counter for LDINIT
152 F J=J:1:16 S $P(LDINIT,U,J)=""
153 S I=I+2 ; Adjust counter for deletion of multiples
154 K PRSFDA
155 S DA(1)=IEN
156 F I=I:1:4 D
157 . S DA=I,DIK="^PRSPC("_DA(1)_",""LD"","
158 . D ^DIK
159 ;
160 ; Set LABOR DISTRIBUTION (Multiple-458.11054)
161 S LD=$O(^PRST(458,PPA,"E",IEN,"LDAUD",0))
162 F PRSLD=0:1:3 D
163 . S J=PRSLD+1
164 . S IENS1="+"_J_","_LD_IENS
165 . ; Don't record empty multiples
166 . Q:$P(LDINIT,U,PRSLD*4+2)="" ; PERCENT
167 . K PRSFDA
168 . S PRSFDA(458.11054,IENS1,.01)=PRSLD+1
169 . S PRSFDA(458.11054,IENS1,1)=$P(LDINIT,U,PRSLD*4+1) ; CODE
170 . S PRSFDA(458.11054,IENS1,2)=$P(LDINIT,U,PRSLD*4+2) ; PERCENT
171 . S PRSFDA(458.11054,IENS1,3)=$P(LDINIT,U,PRSLD*4+3) ; COST CENTER
172 . S PRSFDA(458.11054,IENS1,4)=$P(LDINIT,U,PRSLD*4+4) ; FUND CTRL PT
173 . D UPDATE^DIE("","PRSFDA")
174 K LDINIT,LDFNL
175 Q
Note: See TracBrowser for help on using the repository browser.