Index: WorldVistAEHR/trunk/r/PAID-PRS/PRSDSERV.m
===================================================================
--- WorldVistAEHR/trunk/r/PAID-PRS/PRSDSERV.m	(revision 613)
+++ WorldVistAEHR/trunk/r/PAID-PRS/PRSDSERV.m	(revision 623)
@@ -1,175 +1,173 @@
-PRSDSERV	;WOIFO/MGD,PLT - PAID DOWNLOAD MESSAGE SERVER ;12/3/07
-	;;4.0;PAID;**6,78,82,116**;Sep 21, 1995;Build 23
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	D NOW^%DTC S TIME=% S XMPOS=1 D REC^XMS3 G:XMER'=0 EXIT
-	S LPE=$E(XMRG,1,7) I LPE'?1"**"2N1"PDH",LPE'="****PDH" G EXIT
-	; EMPCNT = # emp in this mail message
-	; SEQNUM = Mail message sequence number if more than one message
-	S EMPCNT=+$E(XMRG,9,12),SEQNUM=$E(XMRG,13,16),TYPE=$E(XMRG,23)
-	S DATE=$E(XMRG,24,31),STA="",SUB="TMP"
-	I "IEPTD"'[TYPE G EXIT
-	; Check to see if the message was previously loaded
-	I $D(^PRSD(450.12,"B",XMZ)) G EXIT
-	S MTYPE=$S(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"")
-	; Set Lines Per Employee (LPE) for the correct interface
-	S LPE=$E(LPE,3,4),LPE=$S(LPE?2N:+LPE,TYPE="I":20,(TYPE="E")!(TYPE="T"):15,TYPE="P":9,1:0)
-	D REC^XMS3 G:XMER'=0 EXIT S STA=$E(XMRG,1,3) I STA'?3N G EXIT
-	I TYPE="D" D ^PRSDDL G EXIT  ; Process Separation download
-	; Mark message as received.  This info is for the reports sent to the
-	; PAD mail group.
-	I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) D  G EXIT
-	.S ^TMP($J,"PRSD",999)=MTYPE_" message "_SEQNUM_" received."
-	.D SETPRS S MNR="" D PROC^PRSDPROC
-	I $D(^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM)) G EXIT
-	K DD,DO S DIC="^PRSD(450.12,",DIC(0)="L",X=XMZ D FILE^DICN
-	S PRSDIEN=+Y,$P(^PRSD(450.12,+Y,0),U,2)=TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM
-	S $P(^PRSD(450.12,+Y,0),U,3)="R",$P(^PRSD(450.12,+Y,0),U,4)=TIME
-	S ^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM,+Y)=""
-SETPRS	;start employee record
-	S XMPOS=2 F A=1:1:EMPCNT D SSNLOOP Q:SSN=999999999
-	I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) K ^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM) Q
-	S:SSN'=999999999 $P(^PRSD(450.12,PRSDIEN,0),U,3)="S"
-EXIT	K %,%H,%I,A,AA,AAA,ADDFLG,B,BB,CC,DA,DATA,DATE,DBNAME,DIC,DIK,DINUM
-	K DLAYGO,DLID,E1,E2,EE,ECNT,ECOUNT,EMPCNT,ERRCNT,ERRFLG,ERRID,ERRIEN,SUB
-	K ERRMSG,FLD,FLDNUM,GNUM,GRP,GRPVAL,IEN,II,LPE,LTH,MO,MFLD,MTYPE,MULT
-	K NAME,NODE,NODE459,PIC,PIECE,PIECE459,PP,PP455,PPIEN,PRSD,PRSDIEN,RCD
-	K RTN,RTNNUM,RTYPE,SEQNUM,SSN,SSNLINE,STA,STA450,SUM,TMPIEN,TMPLINE
-	K TIME,TYPE,X,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,Y,YR,XMPOS,XMRG,XMER,XMLOC
-	K XMMG,MNR,PDATE,CDATE,X1,X2
-REMSB	I $D(XMZ) S XMSER="S.PRSD" D REMSBMSG^XMA1C K XMSER
-	Q
-SSNLOOP	D REC^XMS3
-	S SSN=$S(TYPE="I":$P(XMRG,":",2),1:$E(XMRG,4,12))
-	S SSN=$E("000000000",$L(SSN)+1,9)_SSN
-	; The last employee in the last MailMan message has a SSN=999999999
-	; This triggers the software to begin processing the download.
-	I SSN=999999999 D  Q
-	.I TYPE="I" K ^XTMP("PRS","ERR")
-	.S ^XTMP("PRS","LSN",TYPE,DATE,STA)=SEQNUM
-	.S:$D(PRSDIEN) $P(^PRSD(450.12,PRSDIEN,0),U,3)="S" H 600
-	.D REMSB S ECNT=0 D START,START,^PRSDERR,^PRSDSTAT S SSN=999999999
-	S (PDATE,CDATE)=$P(TIME,".",1),X1=PDATE,X2=90 D C^%DTC S PDATE=X
-	S ^XTMP("PRS",0)=PDATE_"^"_CDATE
-	K KFLG S XMPOS=XMPOS-1
-	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
-	I $D(KFLG) K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN),KFLG
-	Q
-START	; Process download
-	; RTYPE is used to determine which series of routines to call to
-	; process the download
-	S SSN="",RTYPE=$S(TYPE="I":"LD",(TYPE="E")!(TYPE="T"):"EU",TYPE="P":"PR",1:"")
-	F  S SSN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN)) Q:SSN=""  D
-	. L +^XTMP("PRS",SUB,DATE,TYPE,STA,SSN):0
-	. I $T D
-	. . S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,""))
-	. . I TMPIEN'="" D
-	. . . S RCD=^(TMPIEN),ERRFLG=""
-	. . . D SSN
-	. . . D:ERRFLG'="Y" LDINIT,PROC,PROC2,LDFNL,LDCMP
-	. . . D:ERRFLG="Y" TMPERR D UNL
-	Q
-	; Piece together the routine name and call the routine
-PROC	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
-	Q
-PROC2	I TYPE="P",PP'="" D ^PRSDCOMP  ;Compute calculated fields
-	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)
-	K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
-TMPERR	I TYPE="P",PP="" G TMPERR1
-	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
-TMPERR1	K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
-UNL	L -^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
-SSN	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
-	I TYPE="I" S NAME=$P(RCD,":",4)
-	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)=""
-	I '$D(^PRSPC("SSN",SSN)) D ^PRSDADD K DA,DIE,DR,OLDSSN,VAIEN,VANAME Q:ERRFLG="Y"  G SSNOUT
-	S IEN=0,IEN=$O(^PRSPC("SSN",SSN,IEN))
-SSNOUT	I TYPE="P" D ^PRSDPTYP I PP="" S ERRFLG="Y" Q
-	S ECNT=ECNT+1
-	Q
-ERR	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
-	S ERRFLG="Y"
-	Q
-LDINIT	; Load Initial Labor Distribution Values
-	S LDINIT=$$LDLOAD()
-	Q
-LDFNL	; Load Final Labor Distribution Values
-	S LDFNL=$$LDLOAD()
-	Q
-LDLOAD()	; Retrieve current Labor Distribution Values from #450
-	;
-	N LD,LDCC,LDCODE,LDFCP,LDPCT,PRSLD
-	S LD=""
-	F PRSLD=1:1:4 D
-	. S LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_IEN,1)
-	. S LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_IEN,2)
-	. S LDCC=$$GET1^DIQ(450.0757,PRSLD_","_IEN,3)
-	. S LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_IEN,4)
-	. S LD=LD_LDCODE_U_LDPCT_U_LDCC_U_LDFCP_U
-	Q LD
-	;
-LDCMP	; Compare Initial and Final Labor Distribution for changes
-	; and update audit trail in #458 if necessary.
-	Q:LDINIT=LDFNL
-	N PPA,I,IENS,IENS1,INDX,J,LDA,PRSFDA,TLDPER
-	; Get IEN for current Pay Period
-	S PPA=$P($G(^PRST(458,"AD",$P(TIME,".",1))),U,1)
-	Q:PPA=""
-	;
-	; Get next multiple number
-	S LDA="A",LDA=$O(^PRST(458,PPA,"E",IEN,"LDAUD",LDA),-1)
-	S LDA=$S(LDA>0:LDA+1,1:1)
-	;
-	; Set Audit information into #450
-	S DA=IEN,DIE="^PRSPC("
-	S DR="755///^S X=$O(^VA(200,""B"",""CENTRAL,PAID"",0))"
-	D ^DIE
-	S DR="755.1///^S X=TYPE"
-	D ^DIE
-	S DR="756///^S X=TIME"
-	D ^DIE
-	;
-	; If there is no entry for this employee in the Pay Period, create
-	; a record for them
-	I '$D(^PRSPC(458,PPA,"E",IEN)) D
-	. S IENS=","_PPA_","
-	. S PRSFDA(458.01,"?+1"_IENS,.01)=IEN
-	. D UPDATE^DIE("","PRSFDA")
-	;
-	; Set LD AUDIT record into #458.1105
-	S IENS=","_IEN_IENS
-	K PRSFDA
-	S PRSFDA(458.1105,"?+1"_IENS,.01)=LDA
-	S PRSFDA(458.1105,"?+1"_IENS,1)=TIME
-	S PRSFDA(458.1105,"?+1"_IENS,2)=$O(^VA(200,"B","CENTRAL PAID",0))
-	S PRSFDA(458.1105,"?+1"_IENS,3)=TYPE
-	D UPDATE^DIE("","PRSFDA")
-	;
-	; Central PAID only sends LD fields that have changed.  Run check on 
-	; percentages and delete all LD fields in #450 after 99% has been reached
-	S TLDPER=0
-	F I=0:1:3 S TLDPER=TLDPER+$P(LDFNL,U,I*4+2) Q:TLDPER'<.99
-	S J=(I+1)*4+1 ; Set counter for LDINIT
-	F J=J:1:16 S $P(LDINIT,U,J)=""
-	S I=I+2 ; Adjust counter for deletion of multiples
-	K PRSFDA
-	S DA(1)=IEN
-	F I=I:1:4 D
-	. S DA=I,DIK="^PRSPC("_DA(1)_",""LD"","
-	. D ^DIK
-	;
-	; Set LABOR DISTRIBUTION (Multiple-458.11054)
-	S LD=$O(^PRST(458,PPA,"E",IEN,"LDAUD",0))
-	F PRSLD=0:1:3 D
-	. S J=PRSLD+1
-	. S IENS1="+"_J_","_LD_IENS
-	. ; Don't record empty multiples
-	. Q:$P(LDINIT,U,PRSLD*4+2)=""  ; PERCENT
-	. K PRSFDA
-	. S PRSFDA(458.11054,IENS1,.01)=PRSLD+1
-	. S PRSFDA(458.11054,IENS1,1)=$P(LDINIT,U,PRSLD*4+1) ; CODE
-	. S PRSFDA(458.11054,IENS1,2)=$P(LDINIT,U,PRSLD*4+2) ; PERCENT
-	. S PRSFDA(458.11054,IENS1,3)=$P(LDINIT,U,PRSLD*4+3) ; COST CENTER
-	. S PRSFDA(458.11054,IENS1,4)=$P(LDINIT,U,PRSLD*4+4) ; FUND CTRL PT
-	. D UPDATE^DIE("","PRSFDA")
-	K LDINIT,LDFNL
-	Q
+PRSDSERV ;HISC/MGD-PAID DOWNLOAD MESSAGE SERVER ;09/13/2003
+ ;;4.0;PAID;**6,78,82**;Sep 21, 1995
+ D NOW^%DTC S TIME=% S XMPOS=1 D REC^XMS3 G:XMER'=0 EXIT
+ G:$E(XMRG,1,7)'="****PDH" EXIT
+ ; EMPCNT = # emp in this mail message
+ ; SEQNUM = Mail message sequence number if more than one message
+ S EMPCNT=+$E(XMRG,9,12),SEQNUM=$E(XMRG,13,16),TYPE=$E(XMRG,23)
+ S DATE=$E(XMRG,24,31),STA="",SUB="TMP"
+ I "IEPTD"'[TYPE G EXIT
+ ; Check to see if the message was previously loaded
+ I $D(^PRSD(450.12,"B",XMZ)) G EXIT
+ S MTYPE=$S(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"")
+ D REC^XMS3 G:XMER'=0 EXIT S STA=$E(XMRG,1,3) I STA'?3N G EXIT
+ I TYPE="D" D ^PRSDDL G EXIT  ; Process Separation download
+ ; Mark message as received.  This info is for the reports sent to the
+ ; PAD mail group.
+ I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) D  G EXIT
+ .S ^TMP($J,"PRSD",999)=MTYPE_" message "_SEQNUM_" received."
+ .D SETPRS S MNR="" D PROC^PRSDPROC
+ I $D(^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM)) G EXIT
+ K DD,DO S DIC="^PRSD(450.12,",DIC(0)="L",X=XMZ D FILE^DICN
+ S PRSDIEN=+Y,$P(^PRSD(450.12,+Y,0),U,2)=TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM
+ S $P(^PRSD(450.12,+Y,0),U,3)="R",$P(^PRSD(450.12,+Y,0),U,4)=TIME
+ S ^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM,+Y)=""
+ ; Set Lines Per Employee (LPE) for the correct interface
+SETPRS S LPE=$S(TYPE="I":20,(TYPE="E")!(TYPE="T"):15,TYPE="P":9,1:0)
+ S XMPOS=2 F A=1:1:EMPCNT D SSNLOOP Q:SSN=999999999
+ I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) K ^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM) Q
+ S:SSN'=999999999 $P(^PRSD(450.12,PRSDIEN,0),U,3)="S"
+EXIT K %,%H,%I,A,AA,AAA,ADDFLG,B,BB,CC,DA,DATA,DATE,DBNAME,DIC,DIK,DINUM
+ K DLAYGO,DLID,E1,E2,EE,ECNT,ECOUNT,EMPCNT,ERRCNT,ERRFLG,ERRID,ERRIEN,SUB
+ K ERRMSG,FLD,FLDNUM,GNUM,GRP,GRPVAL,IEN,II,LPE,LTH,MO,MFLD,MTYPE,MULT
+ K NAME,NODE,NODE459,PIC,PIECE,PIECE459,PP,PP455,PPIEN,PRSD,PRSDIEN,RCD
+ K RTN,RTNNUM,RTYPE,SEQNUM,SSN,SSNLINE,STA,STA450,SUM,TMPIEN,TMPLINE
+ K TIME,TYPE,X,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,Y,YR,XMPOS,XMRG,XMER,XMLOC
+ K XMMG,MNR,PDATE,CDATE,X1,X2
+REMSB I $D(XMZ) S XMSER="S.PRSD" D REMSBMSG^XMA1C K XMSER
+ Q
+SSNLOOP D REC^XMS3
+ S SSN=$S(TYPE="I":$P(XMRG,":",2),1:$E(XMRG,4,12))
+ S SSN=$E("000000000",$L(SSN)+1,9)_SSN
+ ; The last employee in the last MailMan message has a SSN=999999999
+ ; This triggers the software to begin processing the download.
+ I SSN=999999999 D  Q
+ .I TYPE="I" K ^XTMP("PRS","ERR")
+ .S ^XTMP("PRS","LSN",TYPE,DATE,STA)=SEQNUM
+ .S:$D(PRSDIEN) $P(^PRSD(450.12,PRSDIEN,0),U,3)="S" H 600
+ .D REMSB S ECNT=0 D START,START,^PRSDERR,^PRSDSTAT S SSN=999999999
+ S (PDATE,CDATE)=$P(TIME,".",1),X1=PDATE,X2=90 D C^%DTC S PDATE=X
+ S ^XTMP("PRS",0)=PDATE_"^"_CDATE
+ K KFLG S XMPOS=XMPOS-1
+ 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
+ I $D(KFLG) K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN),KFLG
+ Q
+START ; Process download
+ ; RTYPE is used to determine which series of routines to call to
+ ; process the download
+ S SSN="",RTYPE=$S(TYPE="I":"LD",(TYPE="E")!(TYPE="T"):"EU",TYPE="P":"PR",1:"")
+ F  S SSN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN)) Q:SSN=""  D
+ . L +^XTMP("PRS",SUB,DATE,TYPE,STA,SSN):0
+ . I $T D
+ . . S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,""))
+ . . I TMPIEN'="" D
+ . . . S RCD=^(TMPIEN),ERRFLG=""
+ . . . D SSN
+ . . . D:ERRFLG'="Y" LDINIT,PROC,PROC2,LDFNL,LDCMP
+ . . . D:ERRFLG="Y" TMPERR D UNL
+ Q
+ ; Piece together the routine name and call the routine
+PROC 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
+ Q
+PROC2 I TYPE="P",PP'="" D ^PRSDCOMP  ;Compute calculated fields
+ 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)
+ K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
+TMPERR I TYPE="P",PP="" G TMPERR1
+ 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
+TMPERR1 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
+UNL L -^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q
+SSN 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
+ I TYPE="I" S NAME=$P(RCD,":",4)
+ 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)=""
+ I '$D(^PRSPC("SSN",SSN)) D ^PRSDADD K DA,DIE,DR,OLDSSN,VAIEN,VANAME Q:ERRFLG="Y"  G SSNOUT
+ S IEN=0,IEN=$O(^PRSPC("SSN",SSN,IEN))
+SSNOUT I TYPE="P" D ^PRSDPTYP I PP="" S ERRFLG="Y" Q
+ S ECNT=ECNT+1
+ Q
+ERR 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
+ S ERRFLG="Y"
+ Q
+LDINIT ; Load Initial Labor Distribution Values
+ S LDINIT=$$LDLOAD()
+ Q
+LDFNL ; Load Final Labor Distribution Values
+ S LDFNL=$$LDLOAD()
+ Q
+LDLOAD() ; Retrieve current Labor Distribution Values from #450
+ ;
+ N LD,LDCC,LDCODE,LDFCP,LDPCT,PRSLD
+ S LD=""
+ F PRSLD=1:1:4 D
+ . S LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_IEN,1)
+ . S LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_IEN,2)
+ . S LDCC=$$GET1^DIQ(450.0757,PRSLD_","_IEN,3)
+ . S LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_IEN,4)
+ . S LD=LD_LDCODE_U_LDPCT_U_LDCC_U_LDFCP_U
+ Q LD
+ ;
+LDCMP ; Compare Initial and Final Labor Distribution for changes
+ ; and update audit trail in #458 if necessary.
+ Q:LDINIT=LDFNL
+ N PPA,I,IENS,IENS1,INDX,J,LDA,PRSFDA,TLDPER
+ ; Get IEN for current Pay Period
+ S PPA=$P($G(^PRST(458,"AD",$P(TIME,".",1))),U,1)
+ Q:PPA=""
+ ;
+ ; Get next multiple number
+ S LDA="A",LDA=$O(^PRST(458,PPA,"E",IEN,"LDAUD",LDA),-1)
+ S LDA=$S(LDA>0:LDA+1,1:1)
+ ;
+ ; Set Audit information into #450
+ S DA=IEN,DIE="^PRSPC("
+ S DR="755///^S X=$O(^VA(200,""B"",""CENTRAL,PAID"",0))"
+ D ^DIE
+ S DR="755.1///^S X=TYPE"
+ D ^DIE
+ S DR="756///^S X=TIME"
+ D ^DIE
+ ;
+ ; If there is no entry for this employee in the Pay Period, create
+ ; a record for them
+ I '$D(^PRSPC(458,PPA,"E",IEN)) D
+ . S IENS=","_PPA_","
+ . S PRSFDA(458.01,"?+1"_IENS,.01)=IEN
+ . D UPDATE^DIE("","PRSFDA")
+ ;
+ ; Set LD AUDIT record into #458.1105
+ S IENS=","_IEN_IENS
+ K PRSFDA
+ S PRSFDA(458.1105,"?+1"_IENS,.01)=LDA
+ S PRSFDA(458.1105,"?+1"_IENS,1)=TIME
+ S PRSFDA(458.1105,"?+1"_IENS,2)=$O(^VA(200,"B","CENTRAL PAID",0))
+ S PRSFDA(458.1105,"?+1"_IENS,3)=TYPE
+ D UPDATE^DIE("","PRSFDA")
+ ;
+ ; Central PAID only sends LD fields that have changed.  Run check on 
+ ; percentages and delete all LD fields in #450 after 99% has been reached
+ S TLDPER=0
+ F I=0:1:3 S TLDPER=TLDPER+$P(LDFNL,U,I*4+2) Q:TLDPER'<.99
+ S J=(I+1)*4+1 ; Set counter for LDINIT
+ F J=J:1:16 S $P(LDINIT,U,J)=""
+ S I=I+2 ; Adjust counter for deletion of multiples
+ K PRSFDA
+ S DA(1)=IEN
+ F I=I:1:4 D
+ . S DA=I,DIK="^PRSPC("_DA(1)_",""LD"","
+ . D ^DIK
+ ;
+ ; Set LABOR DISTRIBUTION (Multiple-458.11054)
+ S LD=$O(^PRST(458,PPA,"E",IEN,"LDAUD",0))
+ F PRSLD=0:1:3 D
+ . S J=PRSLD+1
+ . S IENS1="+"_J_","_LD_IENS
+ . ; Don't record empty multiples
+ . Q:$P(LDINIT,U,PRSLD*4+2)=""  ; PERCENT
+ . K PRSFDA
+ . S PRSFDA(458.11054,IENS1,.01)=PRSLD+1
+ . S PRSFDA(458.11054,IENS1,1)=$P(LDINIT,U,PRSLD*4+1) ; CODE
+ . S PRSFDA(458.11054,IENS1,2)=$P(LDINIT,U,PRSLD*4+2) ; PERCENT
+ . S PRSFDA(458.11054,IENS1,3)=$P(LDINIT,U,PRSLD*4+3) ; COST CENTER
+ . S PRSFDA(458.11054,IENS1,4)=$P(LDINIT,U,PRSLD*4+4) ; FUND CTRL PT
+ . D UPDATE^DIE("","PRSFDA")
+ K LDINIT,LDFNL
+ Q
