PRSDSERV ;WOIFO/MGD,PLT - PAID DOWNLOAD MESSAGE SERVER ;12/3/07
;;4.0;PAID;**6,78,82,116,107**;Sep 21, 1995;Build 2
;;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,E458IEN
; 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(^PRST(458,PPA,"E",IEN)) D
. S IENS=","_PPA_","
. S E458IEN(1)=IEN
. S PRSFDA(458.01,"?+1"_IENS,.01)=IEN
. S PRSFDA(458.01,"?+1"_IENS,1)="T"
. D UPDATE^DIE("","PRSFDA","E458IEN")
;
; PRS*107 - undefined PPA caused errors
; PRS*107 - undefined LDA caused errors
; PRS*107 - IENS not set properly
S PPA=$P($G(^PRST(458,"AD",$P(TIME,".",1))),U,1)
Q:PPA=""
S LDA="A",LDA=$O(^PRST(458,PPA,"E",IEN,"LDAUD",LDA),-1)
S LDA=$S(LDA>0:LDA+1,1:1)
S IENS=","_IEN_","_PPA_","
;
; Set LD AUDIT record into #458.1105
; S IENS=","_IEN_IENS - PRS*107 REPLACED WITH IENS SET 3 LINES ABOVE
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDSERV 8387 printed Apr 09, 2024@21:27:29 Page 2
PRSDSERV ;WOIFO/MGD,PLT - PAID DOWNLOAD MESSAGE SERVER ;12/3/07
+1 ;;4.0;PAID;**6,78,82,116,107**;Sep 21, 1995;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 DO NOW^%DTC
SET TIME=%
SET XMPOS=1
DO REC^XMS3
if XMER'=0
GOTO EXIT
+4 SET LPE=$EXTRACT(XMRG,1,7)
IF LPE'?1"**"2N1"PDH"
IF LPE'="****PDH"
GOTO EXIT
+5 ; EMPCNT = # emp in this mail message
+6 ; SEQNUM = Mail message sequence number if more than one message
+7 SET EMPCNT=+$EXTRACT(XMRG,9,12)
SET SEQNUM=$EXTRACT(XMRG,13,16)
SET TYPE=$EXTRACT(XMRG,23)
+8 SET DATE=$EXTRACT(XMRG,24,31)
SET STA=""
SET SUB="TMP"
+9 IF "IEPTD"'[TYPE
GOTO EXIT
+10 ; Check to see if the message was previously loaded
+11 IF $DATA(^PRSD(450.12,"B",XMZ))
GOTO EXIT
+12 SET MTYPE=$SELECT(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"")
+13 ; Set Lines Per Employee (LPE) for the correct interface
+14 SET LPE=$EXTRACT(LPE,3,4)
SET LPE=$SELECT(LPE?2N:+LPE,TYPE="I":20,(TYPE="E")!(TYPE="T"):15,TYPE="P":9,1:0)
+15 DO REC^XMS3
if XMER'=0
GOTO EXIT
SET STA=$EXTRACT(XMRG,1,3)
IF STA'?3N
GOTO EXIT
+16 ; Process Separation download
IF TYPE="D"
DO ^PRSDDL
GOTO EXIT
+17 ; Mark message as received. This info is for the reports sent to the
+18 ; PAD mail group.
+19 IF $DATA(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM))
Begin DoDot:1
+20 SET ^TMP($JOB,"PRSD",999)=MTYPE_" message "_SEQNUM_" received."
+21 DO SETPRS
SET MNR=""
DO PROC^PRSDPROC
End DoDot:1
GOTO EXIT
+22 IF $DATA(^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM))
GOTO EXIT
+23 KILL DD,DO
SET DIC="^PRSD(450.12,"
SET DIC(0)="L"
SET X=XMZ
DO FILE^DICN
+24 SET PRSDIEN=+Y
SET $PIECE(^PRSD(450.12,+Y,0),U,2)=TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM
+25 SET $PIECE(^PRSD(450.12,+Y,0),U,3)="R"
SET $PIECE(^PRSD(450.12,+Y,0),U,4)=TIME
+26 SET ^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM,+Y)=""
SETPRS ;start employee record
+1 SET XMPOS=2
FOR A=1:1:EMPCNT
DO SSNLOOP
if SSN=999999999
QUIT
+2 IF $DATA(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM))
KILL ^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)
QUIT
+3 if SSN'=999999999
SET $PIECE(^PRSD(450.12,PRSDIEN,0),U,3)="S"
EXIT KILL %,%H,%I,A,AA,AAA,ADDFLG,B,BB,CC,DA,DATA,DATE,DBNAME,DIC,DIK,DINUM
+1 KILL DLAYGO,DLID,E1,E2,EE,ECNT,ECOUNT,EMPCNT,ERRCNT,ERRFLG,ERRID,ERRIEN,SUB
+2 KILL ERRMSG,FLD,FLDNUM,GNUM,GRP,GRPVAL,IEN,II,LPE,LTH,MO,MFLD,MTYPE,MULT
+3 KILL NAME,NODE,NODE459,PIC,PIECE,PIECE459,PP,PP455,PPIEN,PRSD,PRSDIEN,RCD
+4 KILL RTN,RTNNUM,RTYPE,SEQNUM,SSN,SSNLINE,STA,STA450,SUM,TMPIEN,TMPLINE
+5 KILL TIME,TYPE,X,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,Y,YR,XMPOS,XMRG,XMER,XMLOC
+6 KILL XMMG,MNR,PDATE,CDATE,X1,X2
REMSB IF $DATA(XMZ)
SET XMSER="S.PRSD"
DO REMSBMSG^XMA1C
KILL XMSER
+1 QUIT
SSNLOOP DO REC^XMS3
+1 SET SSN=$SELECT(TYPE="I":$PIECE(XMRG,":",2),1:$EXTRACT(XMRG,4,12))
+2 SET SSN=$EXTRACT("000000000",$LENGTH(SSN)+1,9)_SSN
+3 ; The last employee in the last MailMan message has a SSN=999999999
+4 ; This triggers the software to begin processing the download.
+5 IF SSN=999999999
Begin DoDot:1
+6 IF TYPE="I"
KILL ^XTMP("PRS","ERR")
+7 SET ^XTMP("PRS","LSN",TYPE,DATE,STA)=SEQNUM
+8 if $DATA(PRSDIEN)
SET $PIECE(^PRSD(450.12,PRSDIEN,0),U,3)="S"
HANG 600
+9 DO REMSB
SET ECNT=0
DO START
DO START
DO ^PRSDERR
DO ^PRSDSTAT
SET SSN=999999999
End DoDot:1
QUIT
+10 SET (PDATE,CDATE)=$PIECE(TIME,".",1)
SET X1=PDATE
SET X2=90
DO C^%DTC
SET PDATE=X
+11 SET ^XTMP("PRS",0)=PDATE_"^"_CDATE
+12 KILL KFLG
SET XMPOS=XMPOS-1
+13 FOR B=1:1:LPE
DO REC^XMS3
IF (($LENGTH(XMRG,":")-1)'=$LENGTH(XMRG))!(TYPE="I")
SET TMPLINE=$EXTRACT("000",$LENGTH(XMPOS)+1,3)_XMPOS
SET ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,XMZ_"-"_TMPLINE_"-"_B)=XMRG
IF TYPE="T"
IF B=6
DO TRANSCK^PRSDERR
+14 IF $DATA(KFLG)
KILL ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN),KFLG
+15 QUIT
START ; Process download
+1 ; RTYPE is used to determine which series of routines to call to
+2 ; process the download
+3 SET SSN=""
SET RTYPE=$SELECT(TYPE="I":"LD",(TYPE="E")!(TYPE="T"):"EU",TYPE="P":"PR",1:"")
+4 FOR
SET SSN=$ORDER(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN))
if SSN=""
QUIT
Begin DoDot:1
+5 LOCK +^XTMP("PRS",SUB,DATE,TYPE,STA,SSN):0
+6 IF $TEST
Begin DoDot:2
+7 SET TMPIEN=$ORDER(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,""))
+8 IF TMPIEN'=""
Begin DoDot:3
+9 SET RCD=^(TMPIEN)
SET ERRFLG=""
+10 DO SSN
+11 if ERRFLG'="Y"
DO LDINIT
DO PROC
DO PROC2
DO LDFNL
DO LDCMP
+12 if ERRFLG="Y"
DO TMPERR
DO UNL
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ; Piece together the routine name and call the routine
PROC SET TMPIEN=""
FOR
SET TMPIEN=$ORDER(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN))
if TMPIEN=""
QUIT
SET RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)
SET RTNNUM=$PIECE(TMPIEN,"-",3)
if $LENGTH(RTNNUM)=1
SET RTNNUM=0_RTNNUM
SET RTN="^PRSD"_RTYPE_RTNNUM
if $TEXT(@RTN)]""
DO @RTN
+1 QUIT
PROC2 ;Compute calculated fields
IF TYPE="P"
IF PP'=""
DO ^PRSDCOMP
+1 SET NODE=0
FOR EE=1:1
SET NODE=$ORDER(^PRSPC(IEN,NODE))
if NODE=""
QUIT
IF $DATA(^PRSPC(IEN,NODE))#2
SET DATA=^PRSPC(IEN,NODE)
IF $LENGTH(DATA,U)-1=$LENGTH(DATA)
KILL ^PRSPC(IEN,NODE)
+2 KILL ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN)
QUIT
TMPERR IF TYPE="P"
IF PP=""
GOTO TMPERR1
+1 SET TMPIEN=""
FOR
SET TMPIEN=$ORDER(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN))
if TMPIEN=""
QUIT
SET RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)
SET ^XTMP("PRS","ERR",DATE,TYPE,STA,SSN,TMPIEN)=RCD
TMPERR1 KILL ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN)
QUIT
UNL LOCK -^XTMP("PRS",SUB,DATE,TYPE,STA,SSN)
QUIT
SSN IF TYPE="P"
IF '$DATA(^PRSPC("SSN",SSN))
SET ERRMSG="SSN "_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_" not found"
DO ERR
QUIT
+1 IF TYPE="I"
SET NAME=$PIECE(RCD,":",4)
+2 IF (TYPE="E")!(TYPE="T")
SET NAME=$PIECE(RCD,":",2)
SET DATA=$EXTRACT(NAME,1,27)
IF DATA'=""
DO RTS^PRSDUTIL
SET NAME=DATA
if TYPE="T"
SET ^TMP($JOB,"PRS",NAME,SSN)=""
+3 IF '$DATA(^PRSPC("SSN",SSN))
DO ^PRSDADD
KILL DA,DIE,DR,OLDSSN,VAIEN,VANAME
if ERRFLG="Y"
QUIT
GOTO SSNOUT
+4 SET IEN=0
SET IEN=$ORDER(^PRSPC("SSN",SSN,IEN))
SSNOUT IF TYPE="P"
DO ^PRSDPTYP
IF PP=""
SET ERRFLG="Y"
QUIT
+1 SET ECNT=ECNT+1
+2 QUIT
ERR KILL DD,DO
SET DIC="^PRSD(450.11,"
SET DIC(0)="L"
SET X=TYPE_"-"_DATE_"-"_STA
DO FILE^DICN
IF Y>0
SET $PIECE(^PRSD(450.11,+Y,0),U,3)=ERRMSG
+1 SET ERRFLG="Y"
+2 QUIT
LDINIT ; Load Initial Labor Distribution Values
+1 SET LDINIT=$$LDLOAD()
+2 QUIT
LDFNL ; Load Final Labor Distribution Values
+1 SET LDFNL=$$LDLOAD()
+2 QUIT
LDLOAD() ; Retrieve current Labor Distribution Values from #450
+1 ;
+2 NEW LD,LDCC,LDCODE,LDFCP,LDPCT,PRSLD
+3 SET LD=""
+4 FOR PRSLD=1:1:4
Begin DoDot:1
+5 SET LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_IEN,1)
+6 SET LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_IEN,2)
+7 SET LDCC=$$GET1^DIQ(450.0757,PRSLD_","_IEN,3)
+8 SET LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_IEN,4)
+9 SET LD=LD_LDCODE_U_LDPCT_U_LDCC_U_LDFCP_U
End DoDot:1
+10 QUIT LD
+11 ;
LDCMP ; Compare Initial and Final Labor Distribution for changes
+1 ; and update audit trail in #458 if necessary.
+2 if LDINIT=LDFNL
QUIT
+3 NEW PPA,I,IENS,IENS1,INDX,J,LDA,PRSFDA,TLDPER,E458IEN
+4 ; Get IEN for current Pay Period
+5 SET PPA=$PIECE($GET(^PRST(458,"AD",$PIECE(TIME,".",1))),U,1)
+6 if PPA=""
QUIT
+7 ;
+8 ; Get next multiple number
+9 SET LDA="A"
SET LDA=$ORDER(^PRST(458,PPA,"E",IEN,"LDAUD",LDA),-1)
+10 SET LDA=$SELECT(LDA>0:LDA+1,1:1)
+11 ;
+12 ; Set Audit information into #450
+13 SET DA=IEN
SET DIE="^PRSPC("
+14 SET DR="755///^S X=$O(^VA(200,""B"",""CENTRAL,PAID"",0))"
+15 DO ^DIE
+16 SET DR="755.1///^S X=TYPE"
+17 DO ^DIE
+18 SET DR="756///^S X=TIME"
+19 DO ^DIE
+20 ;
+21 ; If there is no entry for this employee in the Pay Period, create
+22 ; a record for them
+23 IF '$DATA(^PRST(458,PPA,"E",IEN))
Begin DoDot:1
+24 SET IENS=","_PPA_","
+25 SET E458IEN(1)=IEN
+26 SET PRSFDA(458.01,"?+1"_IENS,.01)=IEN
+27 SET PRSFDA(458.01,"?+1"_IENS,1)="T"
+28 DO UPDATE^DIE("","PRSFDA","E458IEN")
End DoDot:1
+29 ;
+30 ; PRS*107 - undefined PPA caused errors
+31 ; PRS*107 - undefined LDA caused errors
+32 ; PRS*107 - IENS not set properly
+33 SET PPA=$PIECE($GET(^PRST(458,"AD",$PIECE(TIME,".",1))),U,1)
+34 if PPA=""
QUIT
+35 SET LDA="A"
SET LDA=$ORDER(^PRST(458,PPA,"E",IEN,"LDAUD",LDA),-1)
+36 SET LDA=$SELECT(LDA>0:LDA+1,1:1)
+37 SET IENS=","_IEN_","_PPA_","
+38 ;
+39 ; Set LD AUDIT record into #458.1105
+40 ; S IENS=","_IEN_IENS - PRS*107 REPLACED WITH IENS SET 3 LINES ABOVE
+41 KILL PRSFDA
+42 SET PRSFDA(458.1105,"?+1"_IENS,.01)=LDA
+43 SET PRSFDA(458.1105,"?+1"_IENS,1)=TIME
+44 SET PRSFDA(458.1105,"?+1"_IENS,2)=$ORDER(^VA(200,"B","CENTRAL PAID",0))
+45 SET PRSFDA(458.1105,"?+1"_IENS,3)=TYPE
+46 DO UPDATE^DIE("","PRSFDA")
+47 ;
+48 ; Central PAID only sends LD fields that have changed. Run check on
+49 ; percentages and delete all LD fields in #450 after 99% has been reached
+50 SET TLDPER=0
+51 FOR I=0:1:3
SET TLDPER=TLDPER+$PIECE(LDFNL,U,I*4+2)
if TLDPER'<.99
QUIT
+52 ; Set counter for LDINIT
SET J=(I+1)*4+1
+53 FOR J=J:1:16
SET $PIECE(LDINIT,U,J)=""
+54 ; Adjust counter for deletion of multiples
SET I=I+2
+55 KILL PRSFDA
+56 SET DA(1)=IEN
+57 FOR I=I:1:4
Begin DoDot:1
+58 SET DA=I
SET DIK="^PRSPC("_DA(1)_",""LD"","
+59 DO ^DIK
End DoDot:1
+60 ;
+61 ; Set LABOR DISTRIBUTION (Multiple-458.11054)
+62 SET LD=$ORDER(^PRST(458,PPA,"E",IEN,"LDAUD",0))
+63 FOR PRSLD=0:1:3
Begin DoDot:1
+64 SET J=PRSLD+1
+65 SET IENS1="+"_J_","_LD_IENS
+66 ; Don't record empty multiples
+67 ; PERCENT
if $PIECE(LDINIT,U,PRSLD*4+2)=""
QUIT
+68 KILL PRSFDA
+69 SET PRSFDA(458.11054,IENS1,.01)=PRSLD+1
+70 ; CODE
SET PRSFDA(458.11054,IENS1,1)=$PIECE(LDINIT,U,PRSLD*4+1)
+71 ; PERCENT
SET PRSFDA(458.11054,IENS1,2)=$PIECE(LDINIT,U,PRSLD*4+2)
+72 ; COST CENTER
SET PRSFDA(458.11054,IENS1,3)=$PIECE(LDINIT,U,PRSLD*4+3)
+73 ; FUND CTRL PT
SET PRSFDA(458.11054,IENS1,4)=$PIECE(LDINIT,U,PRSLD*4+4)
+74 DO UPDATE^DIE("","PRSFDA")
End DoDot:1
+75 KILL LDINIT,LDFNL
+76 QUIT
