source: WorldVistAEHR/trunk/r/PAID-PRS/PRSDSERV.m@ 1078

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

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