- 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 Feb 18, 2025@23:52:31 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