IVM2174F ;ALB/JAM - IVM*2.0*174 - FIX BLANK SSN IN PERSON INCOME FILE ;9/26/2018 3:21pm
;;2.0;INCOME VERIFICATION MATCH;**174**;21-OCT-94;Build 15
;
Q
EP ; Entry Point
Q
IVMFSSN(DFN,IVMJOB) ; Process only ZDP segments to store SSNs into 408.13 file if IEN is in ^XTMP("DG53970P")
; Called by: ^IVMCM if DFN is defined in ^XTMP("DG53970P") when processing ORU-Z10 message
;
; Input: DFN - Patient DFN from the ORU-Z10 PID
; IVMJOB - job number in ^XTMP("DG53970P",JOB)
;
N IVMCTR,IVMSEG,IVMVAL,IEN,IVMIEN,IVMFOUND,IVMIENCNT
; spouse segment
S IVMSEG=$G(^TMP($J,"IVMCM","ZDPS"))
I IVMSEG'="" D FILESSN(DFN,IVMJOB,IVMSEG)
; inactive spouse segments
S IVMCTR=0
F S IVMCTR=$O(^TMP($J,"IVMCM","ZDPIS",IVMCTR)) Q:(IVMCTR="") D
. S IVMSEG=$G(^TMP($J,"IVMCM","ZDPIS",IVMCTR)) Q:IVMSEG=""
. D FILESSN(DFN,IVMJOB,IVMSEG)
; dependent segments
S IVMCTR=0
F S IVMCTR=$O(^TMP($J,"IVMCM","ZDPC",IVMCTR)) Q:(IVMCTR="") D
. S IVMSEG=$G(^TMP($J,"IVMCM","ZDPC",IVMCTR)) Q:IVMSEG=""
. D FILESSN(DFN,IVMJOB,IVMSEG)
; inactive dependent segments
S IVMCTR=0
F S IVMCTR=$O(^TMP($J,"IVMCM","ZDPIC",IVMCTR)) Q:(IVMCTR="") D
. S IVMSEG=$G(^TMP($J,"IVMCM","ZDPIC",IVMCTR)) Q:IVMSEG=""
. D FILESSN(DFN,IVMJOB,IVMSEG)
; All ZDP segments processed
; If all IENs related to the DFN are gone from ^XTMP, remove the DFN from ^XTMP
S IVMFOUND=0
; For the DFN, loop over ALL the dependent IENs in the 408.12 file "B" index
S IEN="" F S IEN=$O(^DGPR(408.12,"B",DFN,IEN)) Q:'IEN D Q:IVMFOUND
. ; get the related 408.13 IEN
. S IVMVAL=$P(^DGPR(408.12,IEN,0),"^",3)
. I $P(IVMVAL,";",2)'="DGPR(408.13," Q
. S IVMIEN=$P(IVMVAL,";",1)
. S IVMIENCNT=0
. ; If IVMIEN is in ^XTMP("DG53970P",IVMJOB,"SSN",count)=IVMIEN set flag
. F S IVMIENCNT=$O(^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT)) Q:'IVMIENCNT I ^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT)=IVMIEN S IVMFOUND=1 Q
; If no IENs found, clear the DFN out of the ^XTMP global
I 'IVMFOUND K ^XTMP("DG53970P",IVMJOB,"DFN",DFN)
Q
FILESSN(DFN,IVMJOB,IVMSEG) ; Check segment and store SSN in 408.13 if criteria met
; Input: DFN - DFN from PID segment
; IVMJOB - job number in ^XTMP("DG53970P",JOB)
; IVMSEG - the ZDPS or ZDPC segment
N IVMPRI,IVMVAL,IVMIEN,IVMFOUND,IVMIENCNT,IVMSSN,IVMPSSNR,IVMFLG1,IVMERR
N IVMSEX,IVMSEX13,IVMDOB,IVMDOB13,IVMRELN,IVMRELO
N FDA,IVMERRORS,DIERR
S IVMRELN=$P(IVMSEG,"^",6)
; skip segment if RELATIONSHIP is SELF
Q:IVMRELN=1
S IVMPRI=$P(IVMSEG,"^",7) ; ien of patient relation file 408.12
; if IEN not supplied, derive it by looping over dependents in 408.12 file
I IVMPRI="" D
. ; get Sex and DOB from segment
. S IVMSEX=$P(IVMSEG,"^",3),IVMDOB=$$FMDATE^HLFNC($P(IVMSEG,"^",4))
. S IVMFLG1=0
. ; loop over dependents for this DFN in the 408.12 file
. S IVMPRI=0 F S IVMPRI=$O(^DGPR(408.12,"B",DFN,IVMPRI)) Q:'IVMPRI D Q:IVMFLG1
. . ; Get Relationship, DOB, and Sex from income person file 408.13
. . D GETIP(IVMPRI,.IVMRELO,.IVMDOB13,.IVMSEX13)
. . Q:(IVMRELO=1) ; quit if RELATIONSHIP is SELF
. . ; match sex, dob and relationship from segment with values from 408.13 file
. . I (IVMSEX=IVMSEX13)&(IVMDOB=IVMDOB13)&(IVMRELN=IVMRELO) S IVMFLG1=1 ; Match - found dependent in 408.13.
; If dependent IEN from 408.12 file not defined - Quit
Q:IVMPRI=""
; get the related 408.13 IEN
S IVMVAL=$P(^DGPR(408.12,IVMPRI,0),"^",3)
I $P(IVMVAL,";",2)'="DGPR(408.13," Q
S IVMIEN=$P(IVMVAL,";",1) ; ien of income person file 408.13
S IVMFOUND=0,IVMIENCNT=0
; loop over IENs in ^XTMP to see if IVMIEN is there
F S IVMIENCNT=$O(^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT)) Q:'IVMIENCNT I ^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT)=IVMIEN S IVMFOUND=1 Q
Q:'IVMFOUND
; IVMIEN is the IEN that needs the SSN updated in 408.13 - ^DGPR(408.13,IEN,0) piece 9
S IVMSSN=$P(IVMSEG,"^",5) ;SSN
; Validate the SSN and if not valid, place the error in the ^XTMP global and quit
S IVMERR=""
I '$$VALSSN(IVMSSN,.IVMERR) S ^XTMP("DG53970P",IVMJOB,"SSNERR",IVMIEN)=$G(IVMERR) Q
; strip dashes
S IVMSSN=$TR(IVMSSN,"-")
; check for Pseudo SSN
S IVMPSSNR=$P(IVMSEG,"^",10) ;Pseudo SSN Reason
; If not valid value, set it to null
I IVMPSSNR]"",IVMPSSNR'="R",IVMPSSNR'="S",IVMPSSNR'="N" S IVMPSSNR=""
; If there is a valid Pseudo SSN Reason, then append a "P" to the end
; of the SSN so that it can be recognized on VistA as a pseudo
I IVMPSSNR'="" S IVMSSN=$G(IVMSSN)_"P"
; Recheck the SSN field in 408.13 file and if corrupted, clean it up
D CHKSSN(IVMIEN)
; Update the SSN - if not successful, place the error in the ^XTMP global and quit
S FDA(408.13,IVMIEN_",",.09)=IVMSSN
S FDA(408.13,IVMIEN_",",.1)=IVMPSSNR
D FILE^DIE("K","FDA","IVMERRORS(1)")
I +$G(DIERR) D Q
. S IVMERR=$G(IVMERRORS(1,"DIERR",1,"TEXT",1))
. S ^XTMP("DG53970P",IVMJOB,"SSNERR",IVMIEN)=IVMERR
; update was successful, clean the IEN out of the ^XTMP global
K ^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT),^XTMP("DG53970P",IVMJOB,"SSNERR",IVMIEN)
Q
VALSSN(X,ERROR) ; Validate the SSN format
; Input: X - SSN to validate
; ERROR - pass by reference, returns error text if validation fails
; Output: 1 if valid, 0 if invalid
N CNT
I X'?9N&(X'?3N1"-"2N1"-"4N) S ERROR="SSN must be either nine numbers, or be in the format nnn-nn-nnnn." Q 0
; strip dashes
I X'?.AN F CNT=1:1:$L(X) I $E(X,CNT)?1P S X=$E(X,0,CNT-1)_$E(X,CNT+1,999),CNT=CNT-1
I X'?9N S ERROR="Invalid format for SSN." Q 0
I $E(X,1)=9 S ERROR="The SSN must not begin with 9." Q 0
I $E(X,1,3)="000" S ERROR="First three digits of SSN cannot be zeros." Q 0
Q 1
GETIP(IVMPRI,IVMRELO,IVMDOB13,IVMSEX13) ; Return 408.13 Sex,DOB,Relationship via 408.12 record
; Input: IVMPRI - IEN of 408.12 entry
; IVMRELO - Relationship from 408.12 piece 2 (pass by ref)
; IVMDOB13 - Date of Birth from 408.13 piece 3 (pass by ref)
; IVMSEX13 - Sex from 408.13 piece 2 (pass by ref)
N IVMPRN
S IVMPRN=$G(^DGPR(408.12,+IVMPRI,0))
S IVMRELO=$P(IVMPRN,"^",2)
I IVMPRN']"" Q
; Quit if RELATIONSHIP is SELF
Q:IVMRELO=1
N IVMSEG13
; ivmseg13 is 0 node of income person file 408.13
S IVMSEG13=$$DEM^DGMTU1(IVMPRI)
I IVMSEG13']"" Q ; Can't find 408.13 record
; get Sex and DOB from 408.13 file
S IVMSEX13=$P(IVMSEG13,"^",2),IVMDOB13=$P(IVMSEG13,"^",3)
Q
CHKSSN(IEN) ; Check to see if SSN IN 408.13 is corrupted and clean up if it is
; Input: IEN - 408.13 ien
N IVMSSN
S IVMSSN=$P(^DGPR(408.13,IEN,0),"^",9)
I IVMSSN=" "!(IVMSSN=" P") D
. S $P(^DGPR(408.13,IEN,0),"^",9)=""
. ; we have to assume the xrefs are bad and need to be cleaned up
. D XREF(IEN)
Q
XREF(IEN) ; clean "SSN", "BS" and "BS5" xrefs for this INCOME PERSON file (#408.13) record
N VAL,XREF
F XREF="SSN","BS","BS5" D
. S VAL=""
. F S VAL=$O(^DGPR(408.13,XREF,VAL)) Q:VAL="" D
. . I $D(^DGPR(408.13,XREF,VAL,IEN)) K ^DGPR(408.13,XREF,VAL,IEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVM2174F 6981 printed Sep 23, 2025@19:36:12 Page 2
IVM2174F ;ALB/JAM - IVM*2.0*174 - FIX BLANK SSN IN PERSON INCOME FILE ;9/26/2018 3:21pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**174**;21-OCT-94;Build 15
+2 ;
+3 QUIT
EP ; Entry Point
+1 QUIT
IVMFSSN(DFN,IVMJOB) ; Process only ZDP segments to store SSNs into 408.13 file if IEN is in ^XTMP("DG53970P")
+1 ; Called by: ^IVMCM if DFN is defined in ^XTMP("DG53970P") when processing ORU-Z10 message
+2 ;
+3 ; Input: DFN - Patient DFN from the ORU-Z10 PID
+4 ; IVMJOB - job number in ^XTMP("DG53970P",JOB)
+5 ;
+6 NEW IVMCTR,IVMSEG,IVMVAL,IEN,IVMIEN,IVMFOUND,IVMIENCNT
+7 ; spouse segment
+8 SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZDPS"))
+9 IF IVMSEG'=""
DO FILESSN(DFN,IVMJOB,IVMSEG)
+10 ; inactive spouse segments
+11 SET IVMCTR=0
+12 FOR
SET IVMCTR=$ORDER(^TMP($JOB,"IVMCM","ZDPIS",IVMCTR))
if (IVMCTR="")
QUIT
Begin DoDot:1
+13 SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZDPIS",IVMCTR))
if IVMSEG=""
QUIT
+14 DO FILESSN(DFN,IVMJOB,IVMSEG)
End DoDot:1
+15 ; dependent segments
+16 SET IVMCTR=0
+17 FOR
SET IVMCTR=$ORDER(^TMP($JOB,"IVMCM","ZDPC",IVMCTR))
if (IVMCTR="")
QUIT
Begin DoDot:1
+18 SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZDPC",IVMCTR))
if IVMSEG=""
QUIT
+19 DO FILESSN(DFN,IVMJOB,IVMSEG)
End DoDot:1
+20 ; inactive dependent segments
+21 SET IVMCTR=0
+22 FOR
SET IVMCTR=$ORDER(^TMP($JOB,"IVMCM","ZDPIC",IVMCTR))
if (IVMCTR="")
QUIT
Begin DoDot:1
+23 SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZDPIC",IVMCTR))
if IVMSEG=""
QUIT
+24 DO FILESSN(DFN,IVMJOB,IVMSEG)
End DoDot:1
+25 ; All ZDP segments processed
+26 ; If all IENs related to the DFN are gone from ^XTMP, remove the DFN from ^XTMP
+27 SET IVMFOUND=0
+28 ; For the DFN, loop over ALL the dependent IENs in the 408.12 file "B" index
+29 SET IEN=""
FOR
SET IEN=$ORDER(^DGPR(408.12,"B",DFN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+30 ; get the related 408.13 IEN
+31 SET IVMVAL=$PIECE(^DGPR(408.12,IEN,0),"^",3)
+32 IF $PIECE(IVMVAL,";",2)'="DGPR(408.13,"
QUIT
+33 SET IVMIEN=$PIECE(IVMVAL,";",1)
+34 SET IVMIENCNT=0
+35 ; If IVMIEN is in ^XTMP("DG53970P",IVMJOB,"SSN",count)=IVMIEN set flag
+36 FOR
SET IVMIENCNT=$ORDER(^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT))
if 'IVMIENCNT
QUIT
IF ^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT)=IVMIEN
SET IVMFOUND=1
QUIT
End DoDot:1
if IVMFOUND
QUIT
+37 ; If no IENs found, clear the DFN out of the ^XTMP global
+38 IF 'IVMFOUND
KILL ^XTMP("DG53970P",IVMJOB,"DFN",DFN)
+39 QUIT
FILESSN(DFN,IVMJOB,IVMSEG) ; Check segment and store SSN in 408.13 if criteria met
+1 ; Input: DFN - DFN from PID segment
+2 ; IVMJOB - job number in ^XTMP("DG53970P",JOB)
+3 ; IVMSEG - the ZDPS or ZDPC segment
+4 NEW IVMPRI,IVMVAL,IVMIEN,IVMFOUND,IVMIENCNT,IVMSSN,IVMPSSNR,IVMFLG1,IVMERR
+5 NEW IVMSEX,IVMSEX13,IVMDOB,IVMDOB13,IVMRELN,IVMRELO
+6 NEW FDA,IVMERRORS,DIERR
+7 SET IVMRELN=$PIECE(IVMSEG,"^",6)
+8 ; skip segment if RELATIONSHIP is SELF
+9 if IVMRELN=1
QUIT
+10 ; ien of patient relation file 408.12
SET IVMPRI=$PIECE(IVMSEG,"^",7)
+11 ; if IEN not supplied, derive it by looping over dependents in 408.12 file
+12 IF IVMPRI=""
Begin DoDot:1
+13 ; get Sex and DOB from segment
+14 SET IVMSEX=$PIECE(IVMSEG,"^",3)
SET IVMDOB=$$FMDATE^HLFNC($PIECE(IVMSEG,"^",4))
+15 SET IVMFLG1=0
+16 ; loop over dependents for this DFN in the 408.12 file
+17 SET IVMPRI=0
FOR
SET IVMPRI=$ORDER(^DGPR(408.12,"B",DFN,IVMPRI))
if 'IVMPRI
QUIT
Begin DoDot:2
+18 ; Get Relationship, DOB, and Sex from income person file 408.13
+19 DO GETIP(IVMPRI,.IVMRELO,.IVMDOB13,.IVMSEX13)
+20 ; quit if RELATIONSHIP is SELF
if (IVMRELO=1)
QUIT
+21 ; match sex, dob and relationship from segment with values from 408.13 file
+22 ; Match - found dependent in 408.13.
IF (IVMSEX=IVMSEX13)&(IVMDOB=IVMDOB13)&(IVMRELN=IVMRELO)
SET IVMFLG1=1
End DoDot:2
if IVMFLG1
QUIT
End DoDot:1
+23 ; If dependent IEN from 408.12 file not defined - Quit
+24 if IVMPRI=""
QUIT
+25 ; get the related 408.13 IEN
+26 SET IVMVAL=$PIECE(^DGPR(408.12,IVMPRI,0),"^",3)
+27 IF $PIECE(IVMVAL,";",2)'="DGPR(408.13,"
QUIT
+28 ; ien of income person file 408.13
SET IVMIEN=$PIECE(IVMVAL,";",1)
+29 SET IVMFOUND=0
SET IVMIENCNT=0
+30 ; loop over IENs in ^XTMP to see if IVMIEN is there
+31 FOR
SET IVMIENCNT=$ORDER(^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT))
if 'IVMIENCNT
QUIT
IF ^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT)=IVMIEN
SET IVMFOUND=1
QUIT
+32 if 'IVMFOUND
QUIT
+33 ; IVMIEN is the IEN that needs the SSN updated in 408.13 - ^DGPR(408.13,IEN,0) piece 9
+34 ;SSN
SET IVMSSN=$PIECE(IVMSEG,"^",5)
+35 ; Validate the SSN and if not valid, place the error in the ^XTMP global and quit
+36 SET IVMERR=""
+37 IF '$$VALSSN(IVMSSN,.IVMERR)
SET ^XTMP("DG53970P",IVMJOB,"SSNERR",IVMIEN)=$GET(IVMERR)
QUIT
+38 ; strip dashes
+39 SET IVMSSN=$TRANSLATE(IVMSSN,"-")
+40 ; check for Pseudo SSN
+41 ;Pseudo SSN Reason
SET IVMPSSNR=$PIECE(IVMSEG,"^",10)
+42 ; If not valid value, set it to null
+43 IF IVMPSSNR]""
IF IVMPSSNR'="R"
IF IVMPSSNR'="S"
IF IVMPSSNR'="N"
SET IVMPSSNR=""
+44 ; If there is a valid Pseudo SSN Reason, then append a "P" to the end
+45 ; of the SSN so that it can be recognized on VistA as a pseudo
+46 IF IVMPSSNR'=""
SET IVMSSN=$GET(IVMSSN)_"P"
+47 ; Recheck the SSN field in 408.13 file and if corrupted, clean it up
+48 DO CHKSSN(IVMIEN)
+49 ; Update the SSN - if not successful, place the error in the ^XTMP global and quit
+50 SET FDA(408.13,IVMIEN_",",.09)=IVMSSN
+51 SET FDA(408.13,IVMIEN_",",.1)=IVMPSSNR
+52 DO FILE^DIE("K","FDA","IVMERRORS(1)")
+53 IF +$GET(DIERR)
Begin DoDot:1
+54 SET IVMERR=$GET(IVMERRORS(1,"DIERR",1,"TEXT",1))
+55 SET ^XTMP("DG53970P",IVMJOB,"SSNERR",IVMIEN)=IVMERR
End DoDot:1
QUIT
+56 ; update was successful, clean the IEN out of the ^XTMP global
+57 KILL ^XTMP("DG53970P",IVMJOB,"SSN",IVMIENCNT),^XTMP("DG53970P",IVMJOB,"SSNERR",IVMIEN)
+58 QUIT
VALSSN(X,ERROR) ; Validate the SSN format
+1 ; Input: X - SSN to validate
+2 ; ERROR - pass by reference, returns error text if validation fails
+3 ; Output: 1 if valid, 0 if invalid
+4 NEW CNT
+5 IF X'?9N&(X'?3N1"-"2N1"-"4N)
SET ERROR="SSN must be either nine numbers, or be in the format nnn-nn-nnnn."
QUIT 0
+6 ; strip dashes
+7 IF X'?.AN
FOR CNT=1:1:$LENGTH(X)
IF $EXTRACT(X,CNT)?1P
SET X=$EXTRACT(X,0,CNT-1)_$EXTRACT(X,CNT+1,999)
SET CNT=CNT-1
+8 IF X'?9N
SET ERROR="Invalid format for SSN."
QUIT 0
+9 IF $EXTRACT(X,1)=9
SET ERROR="The SSN must not begin with 9."
QUIT 0
+10 IF $EXTRACT(X,1,3)="000"
SET ERROR="First three digits of SSN cannot be zeros."
QUIT 0
+11 QUIT 1
GETIP(IVMPRI,IVMRELO,IVMDOB13,IVMSEX13) ; Return 408.13 Sex,DOB,Relationship via 408.12 record
+1 ; Input: IVMPRI - IEN of 408.12 entry
+2 ; IVMRELO - Relationship from 408.12 piece 2 (pass by ref)
+3 ; IVMDOB13 - Date of Birth from 408.13 piece 3 (pass by ref)
+4 ; IVMSEX13 - Sex from 408.13 piece 2 (pass by ref)
+5 NEW IVMPRN
+6 SET IVMPRN=$GET(^DGPR(408.12,+IVMPRI,0))
+7 SET IVMRELO=$PIECE(IVMPRN,"^",2)
+8 IF IVMPRN']""
QUIT
+9 ; Quit if RELATIONSHIP is SELF
+10 if IVMRELO=1
QUIT
+11 NEW IVMSEG13
+12 ; ivmseg13 is 0 node of income person file 408.13
+13 SET IVMSEG13=$$DEM^DGMTU1(IVMPRI)
+14 ; Can't find 408.13 record
IF IVMSEG13']""
QUIT
+15 ; get Sex and DOB from 408.13 file
+16 SET IVMSEX13=$PIECE(IVMSEG13,"^",2)
SET IVMDOB13=$PIECE(IVMSEG13,"^",3)
+17 QUIT
CHKSSN(IEN) ; Check to see if SSN IN 408.13 is corrupted and clean up if it is
+1 ; Input: IEN - 408.13 ien
+2 NEW IVMSSN
+3 SET IVMSSN=$PIECE(^DGPR(408.13,IEN,0),"^",9)
+4 IF IVMSSN=" "!(IVMSSN=" P")
Begin DoDot:1
+5 SET $PIECE(^DGPR(408.13,IEN,0),"^",9)=""
+6 ; we have to assume the xrefs are bad and need to be cleaned up
+7 DO XREF(IEN)
End DoDot:1
+8 QUIT
XREF(IEN) ; clean "SSN", "BS" and "BS5" xrefs for this INCOME PERSON file (#408.13) record
+1 NEW VAL,XREF
+2 FOR XREF="SSN","BS","BS5"
Begin DoDot:1
+3 SET VAL=""
+4 FOR
SET VAL=$ORDER(^DGPR(408.13,XREF,VAL))
if VAL=""
QUIT
Begin DoDot:2
+5 IF $DATA(^DGPR(408.13,XREF,VAL,IEN))
KILL ^DGPR(408.13,XREF,VAL,IEN)
End DoDot:2
End DoDot:1
+6 QUIT
