XUPSPAID ;CS/GRR/RAM/DW - New Person file Update & Report ; 1 Jan 2004
;;8.0;KERNEL;**309,343**; Jul 10, 1995;
;
Q
;
EN ; - entry point
;
N DIRUT,X,Y
;
I $E(XUPSACT,1)="U" D
. W !!," *********************************************"
. W !," *This option will UPDATE eligible New Person*"
. W !," *file (#200) entries with missing DOB or SEX*"
. W !," *********************************************"
;
W !!,"The reports will be sent to you via MailMan",!
;
S DIR(0)="YA",DIR("B")="Yes",DIR("A")="Do you wish to continue? "
S DIR("?")="Enter 'Yes' to continue or 'No' to quit"
D ^DIR K DIR ;ask user if they want to continue with option
Q:'Y!($D(DIRUT)) ;user responded No or with '^' to exit
;
D QUE
;
K XUPSACT
Q
;
QUE ;Que the task
N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR,IOP
W !
S ZTIO=""
S ZTRTN="EN1^XUPSPAID"
S ZTSAVE("XUPSACT")=""
I $E(XUPSACT,1)="U" S ZTDESC="XUPS NPF UPDATE"
I $E(XUPSACT,1)="P" S ZTDESC="XUPS NPF PREUPDATE REPORT"
D ^%ZTLOAD
D ^%ZISC,HOME^%ZIS
W !,$S($D(ZTSK):"REQUEST QUEUED AS TASK#"_ZTSK,1:"REQUEST CANCELLED!")
;
Q
;
EN1 ;
N IEN,XUPSDIFF,XUPSUPD,XUT,XUNPFT,XUUPDT
S (XUNPFT,XUUPDT)=0
;
K ^TMP("XUPS PAID",$J)
K ^TMP("XUPS DIFF",$J)
K ^TMP("XUPS UPD",$J)
;
S XUPSDIFF("SSN")=0
S XUPSDIFF("NAME")=0
S XUPSDIFF("SEX")=0
S XUPSDIFF("DOB")=0
;
S XUPSUPD("SEX")=0
S XUPSUPD("DOB")=0
;
S IEN=0
F S IEN=$O(^PRSPC(IEN)) Q:'IEN D RECORD
;
S XUT(1)=$G(XUNPFT)
S XUT(2)=$G(XUUPDT)
I $E(XUPSACT,1)="U" D NOTICE^XUPSPD1(.XUT)
;
D REPORT
;
Q
;
REPORT ;Pre-update reports
;
N CNTG,DATA,DATA1,IEN,CNT,CNTU,CNTD
S (CNTG,CNT,CNTU,CNTD)=0
;
;The difference report
D HD("XUPS DIFF")
S IEN=0
F S IEN=$O(^TMP("XUPS PAID",$J,"DIFF",IEN)) Q:'IEN D
.S DATA=^TMP("XUPS PAID",$J,"DIFF",IEN)
.D FL("XUPS DIFF",DATA)
.S CNTD=$G(CNTD)+1
S CNT=$G(CNT)+1
S ^TMP("XUPS DIFF",$J,CNT)=""
S CNT=$G(CNT)+1
S ^TMP("XUPS DIFF",$J,CNT)=" Totals"
S CNT=$G(CNT)+1
S ^TMP("XUPS DIFF",$J,CNT)=" Different LastName,FirstName: "_$G(XUPSDIFF("NAME"))
S CNT=$G(CNT)+1
S ^TMP("XUPS DIFF",$J,CNT)=" Same LastName,FirstName, different Sex: "_$G(XUPSDIFF("SEX"))
S CNT=$G(CNT)+1
S ^TMP("XUPS DIFF",$J,CNT)=" Same LastName,FirstName, different DOB: "_$G(XUPSDIFF("DOB"))
S CNT=$G(CNT)+1
S ^TMP("XUPS DIFF",$J,CNT)=" New Person file entries: "_$G(CNTD)
;
;The update report
S CNT=0
D HD1("XUPS UPD")
S IEN=0
F S IEN=$O(^TMP("XUPS PAID",$J,"UPD",IEN)) Q:'IEN D
.S DATA=^TMP("XUPS PAID",$J,"UPD",IEN)
.D FL1("XUPS UPD",DATA)
.S CNTU=$G(CNTU)+1
S CNT=$G(CNT)+1
S ^TMP("XUPS UPD",$J,CNT)=""
S CNT=$G(CNT)+1
S ^TMP("XUPS UPD",$J,CNT)=" Totals"
S CNT=$G(CNT)+1
S ^TMP("XUPS UPD",$J,CNT)=" Sex fields: "_XUPSUPD("SEX")
S CNT=$G(CNT)+1
S ^TMP("XUPS UPD",$J,CNT)=" DOB fields: "_XUPSUPD("DOB")
S CNT=$G(CNT)+1
S ^TMP("XUPS UPD",$J,CNT)=" New Person entries: "_$G(CNTU)
;
D XM("Update NPF with PAID data - Sex and DOB","XUPS UPD")
D XM("Differences between NPF and PAID files","XUPS DIFF")
;
K ^TMP("XUPS PAID",$J)
K ^TMP("XUPS DIFF",$J)
K ^TMP("XUPS UPD",$J)
;
Q
;
RECORD ;Process the record
;
N IEN200,DATA,DATA1
N PAIDNM,PAIDOB,PAIDSSN,PAIDSEX
N NPFNM,NPFSEX,NPFDOB,NPFSSN
;
; NPF IEN
S IEN200=$P($G(^PRSPC(IEN,200)),"^",1)
;
Q:'IEN200
S XUNPFT=$G(XUNPFT)+1
;
; PAID file
S DATA=$G(^PRSPC(IEN,0))
S PAIDNM=$P(DATA,"^",1)
S PAIDDOB=$P(DATA,"^",33)
S PAIDSSN=$P(DATA,"^",9)
S PAIDSEX=$P(DATA,"^",32)
; transform SEX code PAID to NPF
S PAIDSEX=$S(PAIDSEX="":"",PAIDSEX=1:"M",PAIDSEX=2:"F",1:"")
;
; New Person File
S DATA=$G(^VA(200,IEN200,1))
S NPFNM=$P($G(^VA(200,IEN200,0)),U)
S NPFSEX=$P(DATA,"^",2)
S NPFDOB=$P(DATA,"^",3)
S NPFSSN=$P(DATA,"^",9)
;
Q:NPFSSN'=PAIDSSN
;
S DATA=NPFNM_U_NPFSEX_U_NPFDOB_U_NPFSSN
S DATA=DATA_U_PAIDNM_U_PAIDSEX_U_PAIDDOB_U_PAIDSSN_U_IEN200
;
S DATA1=NPFSSN_U_NPFNM_U_U_U_IEN200
;
I $$NAME(NPFNM)'=$$NAME(PAIDNM) D Q
.S XUPSDIFF("NAME")=XUPSDIFF("NAME")+1
.S ^TMP("XUPS PAID",$J,"DIFF",IEN200)=DATA
;
I PAIDSEX'="" D
.I NPFSEX="" D Q
..S $P(DATA1,U,3)=PAIDSEX
..S XUPSUPD("SEX")=XUPSUPD("SEX")+1
..S ^TMP("XUPS PAID",$J,"UPD",IEN200)=DATA1
..I $E(XUPSACT,1)="U" D
... D UPDSEX
... S XUUPDT=$G(XUUPDT)+1
.I NPFSEX'=PAIDSEX D Q
..S XUPSDIFF("SEX")=XUPSDIFF("SEX")+1
..S ^TMP("XUPS PAID",$J,"DIFF",IEN200)=DATA
;
I PAIDDOB'="" D
.I NPFDOB="" D Q
..S $P(DATA1,U,4)=PAIDDOB
..S XUPSUPD("DOB")=XUPSUPD("DOB")+1
..S ^TMP("XUPS PAID",$J,"UPD",IEN200)=DATA1
..I $E(XUPSACT,1)="U" D
... D UPDDOB
... S XUUPDT=$G(XUUPDT)+1
.I NPFDOB'=PAIDDOB D Q
..S XUPSDIFF("DOB")=XUPSDIFF("DOB")+1
..S ^TMP("XUPS PAID",$J,"DIFF",IEN200)=DATA
;
Q
;
HD(NODE) ; -- Report header
N C1,C2,C3,C4,C5
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=""
;
I NODE="XUPS DIFF" D
. S CNT=$G(CNT)+1
. S ^TMP(NODE,$J,CNT)="The following New Person File entries have different LastName,FirstName,"
. S CNT=$G(CNT)+1
. S ^TMP(NODE,$J,CNT)="or same LastName,FirstName but different Sex or DOB with their linked PAID"
. S CNT=$G(CNT)+1
. S ^TMP(NODE,$J,CNT)="Employee entries."
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=""
;
S C1=$$LJ^XLFSTR("NPF - Name",30," ")
S C2=$$CJ^XLFSTR("SEX",3," ")
S C3=$$LJ^XLFSTR("DOB",11," ")
S C4=$$LJ^XLFSTR("SSN",9," ")
S C5=$$RJ^XLFSTR("IEN",14," ")
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
;
S C1=$$LJ^XLFSTR("PAID -",30," ")
S C2=$$CJ^XLFSTR("",3," ")
S C3=$$LJ^XLFSTR("",11," ")
S C4=$$LJ^XLFSTR("",9," ")
S C5=$$RJ^XLFSTR("",14," ")
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
;
S C1=$$LJ^XLFSTR("=================",30," ")
S C2=$$CJ^XLFSTR("===",3," ")
S C3=$$LJ^XLFSTR("==========",11," ")
S C4=$$LJ^XLFSTR("=========",9," ")
S C5=$$RJ^XLFSTR("===",14," ")
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=""
;
Q
;
FL(NODE,DATA) ; -- format line
;
N NPFNM,NPFSEX,NPFDOB,NPFSSN,NPFIEN
N PAIDNM,PAIDSEX,PAIDDOB,PAIDSSN
;
S NPFNM=$P(DATA,U,1)
S NPFSEX=$P(DATA,U,2)
S NPFDOB=$P(DATA,U,3)
S NPFSSN=$P(DATA,U,4)
S NPFIEN=$P(DATA,U,9)
S PAIDNM=$P(DATA,U,5)
S PAIDSEX=$P(DATA,U,6)
S PAIDDOB=$P(DATA,U,7)
S PAIDSSN=$P(DATA,U,8)
;
N C1,C2,C3,C4,C5
;
;NPF values
S C1=$$LJ^XLFSTR(NPFNM,30," ")
S C2=$$CJ^XLFSTR(NPFSEX,3," ")
S C3=$$LJ^XLFSTR($$DOB(NPFDOB),11," ")
S C4=$$LJ^XLFSTR(NPFSSN,9," ")
S C5=$$RJ^XLFSTR(NPFIEN,14," ")
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
;
;PAID values
S C1=$$LJ^XLFSTR(PAIDNM,30," ")
S C2=$$CJ^XLFSTR(PAIDSEX,3," ")
S C3=$$LJ^XLFSTR($$DOB(PAIDDOB),11," ")
S C4=$$LJ^XLFSTR(PAIDSSN,9," ")
S C5=$$RJ^XLFSTR(" ",14," ")
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=""
;
Q
;
HD1(NODE) ; -- Report header
;
N C1,C2,C3,C4,C5
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=""
;
I NODE="XUPS UPD" D
. S CNT=$G(CNT)+1
. S ^TMP(NODE,$J,CNT)="The following New Person File entries will be updated."
. S CNT=$G(CNT)+1
. S ^TMP(NODE,$J,CNT)="The DOB or Sex fields to be updated are shown with the PAID values;"
. S CNT=$G(CNT)+1
. S ^TMP(NODE,$J,CNT)="The DOB or Sex fields not to be updated are shown with ""-""."
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=""
;
S C1=$$LJ^XLFSTR("SSN",9," ")
S C2=$$LJ^XLFSTR("NPF Name",30," ")
S C3=$$LJ^XLFSTR("SEX",3," ")
S C4=$$LJ^XLFSTR("DOB",11," ")
S C5=$$RJ^XLFSTR("IEN",14," ")
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
;
S C1=$$LJ^XLFSTR("=========",9," ")
S C2=$$LJ^XLFSTR("=================",30," ")
S C3=$$CJ^XLFSTR("===",3," ")
S C4=$$LJ^XLFSTR("==========",11," ")
S C5=$$RJ^XLFSTR("===",14," ")
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=""
;
Q
;
FL1(NODE,DATA) ; -- format line
;
N NPFSSN,NPFNM,NPFSEX,NPFDOB,NPFIEN
;
S NPFSSN=$P(DATA,U,1)
S NPFNM=$P(DATA,U,2)
S NPFSEX=$P(DATA,U,3)
I NPFSEX="" S NPFSEX="-"
S NPFDOB=$P(DATA,U,4)
S NPFIEN=$P(DATA,U,5)
;
N C1,C2,C3,C4,C5
;
;NPF values
S C1=$$LJ^XLFSTR(NPFSSN,9," ")
S C2=$$LJ^XLFSTR(NPFNM,30," ")
S C3=$$CJ^XLFSTR(NPFSEX,3," ")
I NPFDOB="" S C4="---------- "
I NPFDOB'="" S C4=$$LJ^XLFSTR($$DOB(NPFDOB),11," ")
S C5=$$RJ^XLFSTR(NPFIEN,14," ")
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
;
S CNT=$G(CNT)+1
S ^TMP(NODE,$J,CNT)=""
;
Q
;
UPDSEX ;Update SEX if NPF SEX is null
I $E(XUPSACT,1)'="U" Q
;
N DIE,DA,DR
S DIE=200,DA=IEN200
I NPFSEX="" D
. S DR="4///^S X=PAIDSEX"
. D ^DIE
Q
;
UPDDOB ;Update DOB if NPF DOB is null
I $E(XUPSACT,1)'="U" Q
;
N DIE,DA,DR
S DIE=200,DA=IEN200
I NPFDOB="" D
. S DR="5///^S X=PAIDDOB"
. D ^DIE
Q
;
NAME(NAME) ; Return "LastName,FirstName".
;
N RESULT,STDNM
;
S RESULT=""
;
; CALL FORMAT^XLFNAME7
S STDNM=$$FORMAT^XLFNAME7(.NAME,3,35)
;
; Return LastName,FirstName
S RESULT=$P($G(STDNM)," ",1)
;
Q RESULT
;
DOB(DOB) ; format DOB
;
Q:DOB="" ""
;
Q $E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_(1700+$E(DOB,1,3))
;
PSDT() ; format date
;
N %
;
D NOW^%DTC S Y=% D DD^%DT
;
Q Y
;
XM(XMSUB,X) ;Email the report
;If called within a task, protect variables
I $D(ZTQUEUED) N %,DIFROM
;
N XMY,XMTEXT,XMDUZ
S XMY(DUZ)="",XMDUZ=.5
S XMTEXT="^TMP("""_X_""",$J,"
D ^XMD
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUPSPAID 9782 printed Sep 23, 2025@19:47:58 Page 2
XUPSPAID ;CS/GRR/RAM/DW - New Person file Update & Report ; 1 Jan 2004
+1 ;;8.0;KERNEL;**309,343**; Jul 10, 1995;
+2 ;
+3 QUIT
+4 ;
EN ; - entry point
+1 ;
+2 NEW DIRUT,X,Y
+3 ;
+4 IF $EXTRACT(XUPSACT,1)="U"
Begin DoDot:1
+5 WRITE !!," *********************************************"
+6 WRITE !," *This option will UPDATE eligible New Person*"
+7 WRITE !," *file (#200) entries with missing DOB or SEX*"
+8 WRITE !," *********************************************"
End DoDot:1
+9 ;
+10 WRITE !!,"The reports will be sent to you via MailMan",!
+11 ;
+12 SET DIR(0)="YA"
SET DIR("B")="Yes"
SET DIR("A")="Do you wish to continue? "
+13 SET DIR("?")="Enter 'Yes' to continue or 'No' to quit"
+14 ;ask user if they want to continue with option
DO ^DIR
KILL DIR
+15 ;user responded No or with '^' to exit
if 'Y!($DATA(DIRUT))
QUIT
+16 ;
+17 DO QUE
+18 ;
+19 KILL XUPSACT
+20 QUIT
+21 ;
QUE ;Que the task
+1 NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR,IOP
+2 WRITE !
+3 SET ZTIO=""
+4 SET ZTRTN="EN1^XUPSPAID"
+5 SET ZTSAVE("XUPSACT")=""
+6 IF $EXTRACT(XUPSACT,1)="U"
SET ZTDESC="XUPS NPF UPDATE"
+7 IF $EXTRACT(XUPSACT,1)="P"
SET ZTDESC="XUPS NPF PREUPDATE REPORT"
+8 DO ^%ZTLOAD
+9 DO ^%ZISC
DO HOME^%ZIS
+10 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED AS TASK#"_ZTSK,1:"REQUEST CANCELLED!")
+11 ;
+12 QUIT
+13 ;
EN1 ;
+1 NEW IEN,XUPSDIFF,XUPSUPD,XUT,XUNPFT,XUUPDT
+2 SET (XUNPFT,XUUPDT)=0
+3 ;
+4 KILL ^TMP("XUPS PAID",$JOB)
+5 KILL ^TMP("XUPS DIFF",$JOB)
+6 KILL ^TMP("XUPS UPD",$JOB)
+7 ;
+8 SET XUPSDIFF("SSN")=0
+9 SET XUPSDIFF("NAME")=0
+10 SET XUPSDIFF("SEX")=0
+11 SET XUPSDIFF("DOB")=0
+12 ;
+13 SET XUPSUPD("SEX")=0
+14 SET XUPSUPD("DOB")=0
+15 ;
+16 SET IEN=0
+17 FOR
SET IEN=$ORDER(^PRSPC(IEN))
if 'IEN
QUIT
DO RECORD
+18 ;
+19 SET XUT(1)=$GET(XUNPFT)
+20 SET XUT(2)=$GET(XUUPDT)
+21 IF $EXTRACT(XUPSACT,1)="U"
DO NOTICE^XUPSPD1(.XUT)
+22 ;
+23 DO REPORT
+24 ;
+25 QUIT
+26 ;
REPORT ;Pre-update reports
+1 ;
+2 NEW CNTG,DATA,DATA1,IEN,CNT,CNTU,CNTD
+3 SET (CNTG,CNT,CNTU,CNTD)=0
+4 ;
+5 ;The difference report
+6 DO HD("XUPS DIFF")
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^TMP("XUPS PAID",$JOB,"DIFF",IEN))
if 'IEN
QUIT
Begin DoDot:1
+9 SET DATA=^TMP("XUPS PAID",$JOB,"DIFF",IEN)
+10 DO FL("XUPS DIFF",DATA)
+11 SET CNTD=$GET(CNTD)+1
End DoDot:1
+12 SET CNT=$GET(CNT)+1
+13 SET ^TMP("XUPS DIFF",$JOB,CNT)=""
+14 SET CNT=$GET(CNT)+1
+15 SET ^TMP("XUPS DIFF",$JOB,CNT)=" Totals"
+16 SET CNT=$GET(CNT)+1
+17 SET ^TMP("XUPS DIFF",$JOB,CNT)=" Different LastName,FirstName: "_$GET(XUPSDIFF("NAME"))
+18 SET CNT=$GET(CNT)+1
+19 SET ^TMP("XUPS DIFF",$JOB,CNT)=" Same LastName,FirstName, different Sex: "_$GET(XUPSDIFF("SEX"))
+20 SET CNT=$GET(CNT)+1
+21 SET ^TMP("XUPS DIFF",$JOB,CNT)=" Same LastName,FirstName, different DOB: "_$GET(XUPSDIFF("DOB"))
+22 SET CNT=$GET(CNT)+1
+23 SET ^TMP("XUPS DIFF",$JOB,CNT)=" New Person file entries: "_$GET(CNTD)
+24 ;
+25 ;The update report
+26 SET CNT=0
+27 DO HD1("XUPS UPD")
+28 SET IEN=0
+29 FOR
SET IEN=$ORDER(^TMP("XUPS PAID",$JOB,"UPD",IEN))
if 'IEN
QUIT
Begin DoDot:1
+30 SET DATA=^TMP("XUPS PAID",$JOB,"UPD",IEN)
+31 DO FL1("XUPS UPD",DATA)
+32 SET CNTU=$GET(CNTU)+1
End DoDot:1
+33 SET CNT=$GET(CNT)+1
+34 SET ^TMP("XUPS UPD",$JOB,CNT)=""
+35 SET CNT=$GET(CNT)+1
+36 SET ^TMP("XUPS UPD",$JOB,CNT)=" Totals"
+37 SET CNT=$GET(CNT)+1
+38 SET ^TMP("XUPS UPD",$JOB,CNT)=" Sex fields: "_XUPSUPD("SEX")
+39 SET CNT=$GET(CNT)+1
+40 SET ^TMP("XUPS UPD",$JOB,CNT)=" DOB fields: "_XUPSUPD("DOB")
+41 SET CNT=$GET(CNT)+1
+42 SET ^TMP("XUPS UPD",$JOB,CNT)=" New Person entries: "_$GET(CNTU)
+43 ;
+44 DO XM("Update NPF with PAID data - Sex and DOB","XUPS UPD")
+45 DO XM("Differences between NPF and PAID files","XUPS DIFF")
+46 ;
+47 KILL ^TMP("XUPS PAID",$JOB)
+48 KILL ^TMP("XUPS DIFF",$JOB)
+49 KILL ^TMP("XUPS UPD",$JOB)
+50 ;
+51 QUIT
+52 ;
RECORD ;Process the record
+1 ;
+2 NEW IEN200,DATA,DATA1
+3 NEW PAIDNM,PAIDOB,PAIDSSN,PAIDSEX
+4 NEW NPFNM,NPFSEX,NPFDOB,NPFSSN
+5 ;
+6 ; NPF IEN
+7 SET IEN200=$PIECE($GET(^PRSPC(IEN,200)),"^",1)
+8 ;
+9 if 'IEN200
QUIT
+10 SET XUNPFT=$GET(XUNPFT)+1
+11 ;
+12 ; PAID file
+13 SET DATA=$GET(^PRSPC(IEN,0))
+14 SET PAIDNM=$PIECE(DATA,"^",1)
+15 SET PAIDDOB=$PIECE(DATA,"^",33)
+16 SET PAIDSSN=$PIECE(DATA,"^",9)
+17 SET PAIDSEX=$PIECE(DATA,"^",32)
+18 ; transform SEX code PAID to NPF
+19 SET PAIDSEX=$SELECT(PAIDSEX="":"",PAIDSEX=1:"M",PAIDSEX=2:"F",1:"")
+20 ;
+21 ; New Person File
+22 SET DATA=$GET(^VA(200,IEN200,1))
+23 SET NPFNM=$PIECE($GET(^VA(200,IEN200,0)),U)
+24 SET NPFSEX=$PIECE(DATA,"^",2)
+25 SET NPFDOB=$PIECE(DATA,"^",3)
+26 SET NPFSSN=$PIECE(DATA,"^",9)
+27 ;
+28 if NPFSSN'=PAIDSSN
QUIT
+29 ;
+30 SET DATA=NPFNM_U_NPFSEX_U_NPFDOB_U_NPFSSN
+31 SET DATA=DATA_U_PAIDNM_U_PAIDSEX_U_PAIDDOB_U_PAIDSSN_U_IEN200
+32 ;
+33 SET DATA1=NPFSSN_U_NPFNM_U_U_U_IEN200
+34 ;
+35 IF $$NAME(NPFNM)'=$$NAME(PAIDNM)
Begin DoDot:1
+36 SET XUPSDIFF("NAME")=XUPSDIFF("NAME")+1
+37 SET ^TMP("XUPS PAID",$JOB,"DIFF",IEN200)=DATA
End DoDot:1
QUIT
+38 ;
+39 IF PAIDSEX'=""
Begin DoDot:1
+40 IF NPFSEX=""
Begin DoDot:2
+41 SET $PIECE(DATA1,U,3)=PAIDSEX
+42 SET XUPSUPD("SEX")=XUPSUPD("SEX")+1
+43 SET ^TMP("XUPS PAID",$JOB,"UPD",IEN200)=DATA1
+44 IF $EXTRACT(XUPSACT,1)="U"
Begin DoDot:3
+45 DO UPDSEX
+46 SET XUUPDT=$GET(XUUPDT)+1
End DoDot:3
End DoDot:2
QUIT
+47 IF NPFSEX'=PAIDSEX
Begin DoDot:2
+48 SET XUPSDIFF("SEX")=XUPSDIFF("SEX")+1
+49 SET ^TMP("XUPS PAID",$JOB,"DIFF",IEN200)=DATA
End DoDot:2
QUIT
End DoDot:1
+50 ;
+51 IF PAIDDOB'=""
Begin DoDot:1
+52 IF NPFDOB=""
Begin DoDot:2
+53 SET $PIECE(DATA1,U,4)=PAIDDOB
+54 SET XUPSUPD("DOB")=XUPSUPD("DOB")+1
+55 SET ^TMP("XUPS PAID",$JOB,"UPD",IEN200)=DATA1
+56 IF $EXTRACT(XUPSACT,1)="U"
Begin DoDot:3
+57 DO UPDDOB
+58 SET XUUPDT=$GET(XUUPDT)+1
End DoDot:3
End DoDot:2
QUIT
+59 IF NPFDOB'=PAIDDOB
Begin DoDot:2
+60 SET XUPSDIFF("DOB")=XUPSDIFF("DOB")+1
+61 SET ^TMP("XUPS PAID",$JOB,"DIFF",IEN200)=DATA
End DoDot:2
QUIT
End DoDot:1
+62 ;
+63 QUIT
+64 ;
HD(NODE) ; -- Report header
+1 NEW C1,C2,C3,C4,C5
+2 ;
+3 SET CNT=$GET(CNT)+1
+4 SET ^TMP(NODE,$JOB,CNT)=""
+5 ;
+6 IF NODE="XUPS DIFF"
Begin DoDot:1
+7 SET CNT=$GET(CNT)+1
+8 SET ^TMP(NODE,$JOB,CNT)="The following New Person File entries have different LastName,FirstName,"
+9 SET CNT=$GET(CNT)+1
+10 SET ^TMP(NODE,$JOB,CNT)="or same LastName,FirstName but different Sex or DOB with their linked PAID"
+11 SET CNT=$GET(CNT)+1
+12 SET ^TMP(NODE,$JOB,CNT)="Employee entries."
End DoDot:1
+13 ;
+14 SET CNT=$GET(CNT)+1
+15 SET ^TMP(NODE,$JOB,CNT)=""
+16 ;
+17 SET C1=$$LJ^XLFSTR("NPF - Name",30," ")
+18 SET C2=$$CJ^XLFSTR("SEX",3," ")
+19 SET C3=$$LJ^XLFSTR("DOB",11," ")
+20 SET C4=$$LJ^XLFSTR("SSN",9," ")
+21 SET C5=$$RJ^XLFSTR("IEN",14," ")
+22 ;
+23 SET CNT=$GET(CNT)+1
+24 SET ^TMP(NODE,$JOB,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
+25 ;
+26 SET C1=$$LJ^XLFSTR("PAID -",30," ")
+27 SET C2=$$CJ^XLFSTR("",3," ")
+28 SET C3=$$LJ^XLFSTR("",11," ")
+29 SET C4=$$LJ^XLFSTR("",9," ")
+30 SET C5=$$RJ^XLFSTR("",14," ")
+31 ;
+32 SET CNT=$GET(CNT)+1
+33 SET ^TMP(NODE,$JOB,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
+34 ;
+35 SET C1=$$LJ^XLFSTR("=================",30," ")
+36 SET C2=$$CJ^XLFSTR("===",3," ")
+37 SET C3=$$LJ^XLFSTR("==========",11," ")
+38 SET C4=$$LJ^XLFSTR("=========",9," ")
+39 SET C5=$$RJ^XLFSTR("===",14," ")
+40 ;
+41 SET CNT=$GET(CNT)+1
+42 SET ^TMP(NODE,$JOB,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
+43 ;
+44 SET CNT=$GET(CNT)+1
+45 SET ^TMP(NODE,$JOB,CNT)=""
+46 ;
+47 QUIT
+48 ;
FL(NODE,DATA) ; -- format line
+1 ;
+2 NEW NPFNM,NPFSEX,NPFDOB,NPFSSN,NPFIEN
+3 NEW PAIDNM,PAIDSEX,PAIDDOB,PAIDSSN
+4 ;
+5 SET NPFNM=$PIECE(DATA,U,1)
+6 SET NPFSEX=$PIECE(DATA,U,2)
+7 SET NPFDOB=$PIECE(DATA,U,3)
+8 SET NPFSSN=$PIECE(DATA,U,4)
+9 SET NPFIEN=$PIECE(DATA,U,9)
+10 SET PAIDNM=$PIECE(DATA,U,5)
+11 SET PAIDSEX=$PIECE(DATA,U,6)
+12 SET PAIDDOB=$PIECE(DATA,U,7)
+13 SET PAIDSSN=$PIECE(DATA,U,8)
+14 ;
+15 NEW C1,C2,C3,C4,C5
+16 ;
+17 ;NPF values
+18 SET C1=$$LJ^XLFSTR(NPFNM,30," ")
+19 SET C2=$$CJ^XLFSTR(NPFSEX,3," ")
+20 SET C3=$$LJ^XLFSTR($$DOB(NPFDOB),11," ")
+21 SET C4=$$LJ^XLFSTR(NPFSSN,9," ")
+22 SET C5=$$RJ^XLFSTR(NPFIEN,14," ")
+23 ;
+24 SET CNT=$GET(CNT)+1
+25 SET ^TMP(NODE,$JOB,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
+26 ;
+27 ;PAID values
+28 SET C1=$$LJ^XLFSTR(PAIDNM,30," ")
+29 SET C2=$$CJ^XLFSTR(PAIDSEX,3," ")
+30 SET C3=$$LJ^XLFSTR($$DOB(PAIDDOB),11," ")
+31 SET C4=$$LJ^XLFSTR(PAIDSSN,9," ")
+32 SET C5=$$RJ^XLFSTR(" ",14," ")
+33 ;
+34 SET CNT=$GET(CNT)+1
+35 SET ^TMP(NODE,$JOB,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
+36 ;
+37 SET CNT=$GET(CNT)+1
+38 SET ^TMP(NODE,$JOB,CNT)=""
+39 ;
+40 QUIT
+41 ;
HD1(NODE) ; -- Report header
+1 ;
+2 NEW C1,C2,C3,C4,C5
+3 ;
+4 SET CNT=$GET(CNT)+1
+5 SET ^TMP(NODE,$JOB,CNT)=""
+6 ;
+7 IF NODE="XUPS UPD"
Begin DoDot:1
+8 SET CNT=$GET(CNT)+1
+9 SET ^TMP(NODE,$JOB,CNT)="The following New Person File entries will be updated."
+10 SET CNT=$GET(CNT)+1
+11 SET ^TMP(NODE,$JOB,CNT)="The DOB or Sex fields to be updated are shown with the PAID values;"
+12 SET CNT=$GET(CNT)+1
+13 SET ^TMP(NODE,$JOB,CNT)="The DOB or Sex fields not to be updated are shown with ""-""."
End DoDot:1
+14 ;
+15 SET CNT=$GET(CNT)+1
+16 SET ^TMP(NODE,$JOB,CNT)=""
+17 ;
+18 SET C1=$$LJ^XLFSTR("SSN",9," ")
+19 SET C2=$$LJ^XLFSTR("NPF Name",30," ")
+20 SET C3=$$LJ^XLFSTR("SEX",3," ")
+21 SET C4=$$LJ^XLFSTR("DOB",11," ")
+22 SET C5=$$RJ^XLFSTR("IEN",14," ")
+23 ;
+24 SET CNT=$GET(CNT)+1
+25 SET ^TMP(NODE,$JOB,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
+26 ;
+27 SET C1=$$LJ^XLFSTR("=========",9," ")
+28 SET C2=$$LJ^XLFSTR("=================",30," ")
+29 SET C3=$$CJ^XLFSTR("===",3," ")
+30 SET C4=$$LJ^XLFSTR("==========",11," ")
+31 SET C5=$$RJ^XLFSTR("===",14," ")
+32 ;
+33 SET CNT=$GET(CNT)+1
+34 SET ^TMP(NODE,$JOB,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
+35 ;
+36 SET CNT=$GET(CNT)+1
+37 SET ^TMP(NODE,$JOB,CNT)=""
+38 ;
+39 QUIT
+40 ;
FL1(NODE,DATA) ; -- format line
+1 ;
+2 NEW NPFSSN,NPFNM,NPFSEX,NPFDOB,NPFIEN
+3 ;
+4 SET NPFSSN=$PIECE(DATA,U,1)
+5 SET NPFNM=$PIECE(DATA,U,2)
+6 SET NPFSEX=$PIECE(DATA,U,3)
+7 IF NPFSEX=""
SET NPFSEX="-"
+8 SET NPFDOB=$PIECE(DATA,U,4)
+9 SET NPFIEN=$PIECE(DATA,U,5)
+10 ;
+11 NEW C1,C2,C3,C4,C5
+12 ;
+13 ;NPF values
+14 SET C1=$$LJ^XLFSTR(NPFSSN,9," ")
+15 SET C2=$$LJ^XLFSTR(NPFNM,30," ")
+16 SET C3=$$CJ^XLFSTR(NPFSEX,3," ")
+17 IF NPFDOB=""
SET C4="---------- "
+18 IF NPFDOB'=""
SET C4=$$LJ^XLFSTR($$DOB(NPFDOB),11," ")
+19 SET C5=$$RJ^XLFSTR(NPFIEN,14," ")
+20 ;
+21 SET CNT=$GET(CNT)+1
+22 SET ^TMP(NODE,$JOB,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
+23 ;
+24 SET CNT=$GET(CNT)+1
+25 SET ^TMP(NODE,$JOB,CNT)=""
+26 ;
+27 QUIT
+28 ;
UPDSEX ;Update SEX if NPF SEX is null
+1 IF $EXTRACT(XUPSACT,1)'="U"
QUIT
+2 ;
+3 NEW DIE,DA,DR
+4 SET DIE=200
SET DA=IEN200
+5 IF NPFSEX=""
Begin DoDot:1
+6 SET DR="4///^S X=PAIDSEX"
+7 DO ^DIE
End DoDot:1
+8 QUIT
+9 ;
UPDDOB ;Update DOB if NPF DOB is null
+1 IF $EXTRACT(XUPSACT,1)'="U"
QUIT
+2 ;
+3 NEW DIE,DA,DR
+4 SET DIE=200
SET DA=IEN200
+5 IF NPFDOB=""
Begin DoDot:1
+6 SET DR="5///^S X=PAIDDOB"
+7 DO ^DIE
End DoDot:1
+8 QUIT
+9 ;
NAME(NAME) ; Return "LastName,FirstName".
+1 ;
+2 NEW RESULT,STDNM
+3 ;
+4 SET RESULT=""
+5 ;
+6 ; CALL FORMAT^XLFNAME7
+7 SET STDNM=$$FORMAT^XLFNAME7(.NAME,3,35)
+8 ;
+9 ; Return LastName,FirstName
+10 SET RESULT=$PIECE($GET(STDNM)," ",1)
+11 ;
+12 QUIT RESULT
+13 ;
DOB(DOB) ; format DOB
+1 ;
+2 if DOB=""
QUIT ""
+3 ;
+4 QUIT $EXTRACT(DOB,4,5)_"/"_$EXTRACT(DOB,6,7)_"/"_(1700+$EXTRACT(DOB,1,3))
+5 ;
PSDT() ; format date
+1 ;
+2 NEW %
+3 ;
+4 DO NOW^%DTC
SET Y=%
DO DD^%DT
+5 ;
+6 QUIT Y
+7 ;
XM(XMSUB,X) ;Email the report
+1 ;If called within a task, protect variables
+2 IF $DATA(ZTQUEUED)
NEW %,DIFROM
+3 ;
+4 NEW XMY,XMTEXT,XMDUZ
+5 SET XMY(DUZ)=""
SET XMDUZ=.5
+6 SET XMTEXT="^TMP("""_X_""",$J,"
+7 DO ^XMD
+8 ;
+9 QUIT
+10 ;
