Changeset 623 for WorldVistAEHR/trunk/r/PAID-PRS/PRSDSERV.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/PAID-PRS/PRSDSERV.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PAID-PRS/PRSDSERV.m
r613 r623 1 PRSDSERV ;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)="" 28 SETPRS ;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" 32 EXIT 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 39 REMSB I $D(XMZ) S XMSER="S.PRSD" D REMSBMSG^XMA1C K XMSER 40 Q 41 SSNLOOP 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 57 START ; 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 72 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 73 Q 74 PROC2 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 77 TMPERR 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 79 TMPERR1 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 80 UNL L -^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 81 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 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)) 86 SSNOUT I TYPE="P" D ^PRSDPTYP I PP="" S ERRFLG="Y" Q 87 S ECNT=ECNT+1 88 Q 89 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 90 S ERRFLG="Y" 91 Q 92 LDINIT ; Load Initial Labor Distribution Values 93 S LDINIT=$$LDLOAD() 94 Q 95 LDFNL ; Load Final Labor Distribution Values 96 S LDFNL=$$LDLOAD() 97 Q 98 LDLOAD() ; 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 ; 110 LDCMP ; 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 1 PRSDSERV ;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 26 SETPRS 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" 30 EXIT 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 37 REMSB I $D(XMZ) S XMSER="S.PRSD" D REMSBMSG^XMA1C K XMSER 38 Q 39 SSNLOOP 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 55 START ; 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 70 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 71 Q 72 PROC2 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 75 TMPERR 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 77 TMPERR1 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 78 UNL L -^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 79 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 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)) 84 SSNOUT I TYPE="P" D ^PRSDPTYP I PP="" S ERRFLG="Y" Q 85 S ECNT=ECNT+1 86 Q 87 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 88 S ERRFLG="Y" 89 Q 90 LDINIT ; Load Initial Labor Distribution Values 91 S LDINIT=$$LDLOAD() 92 Q 93 LDFNL ; Load Final Labor Distribution Values 94 S LDFNL=$$LDLOAD() 95 Q 96 LDLOAD() ; 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 ; 108 LDCMP ; 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 TracChangeset
for help on using the changeset viewer.
