IVMPREC8.m

IVMPREC8 ;ALB/KCL,BRM,PJR,CKN,TDM,PWC,LBD,DPR,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;7/24/24 8:56AM

 ;;2.0;INCOME VERIFICATION MATCH;**5,6,12,58,73,79,102,115,121,148,151,152,168,167,171,164,188,187,210,214,215**;21-OCT-94;Build 14

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 ; This routine will process (event type Z05)

 ;

PID ;-compare PID fields with DHCP

 N COMPPH1,COMPPH2,COUNTRY,IVMCNTRY,IVMEXT,IVMFNUM,IVMFVAL,IVMCNTRY,IVMEXT

 ;

 S IVMFLD=""

 ; - strip off seg name

 S IVMPIECE=$E(IVMXREF,4,9)

 ;Only process if value exist-also handles multiple addr

 I $G(IVMPID(+$E(IVMPIECE,1,2)))'=""!($O(IVMPID(+$E(IVMPIECE,1,2),""))) D

 .; -if PID field is the addr field-parse addr

 .S IVMADFLG=0

 .I IVMXREF["PID11",'$G(DODSEG) D  Q:IVMFLD=""

 ..; IVM*2.0*164-Uncomment Conf and Add Res

 ..I $G(AUPFARY(IVMDEMDA))="CA" S IVMADDR=$G(ADDRESS("CA")) ;Conf Addr

 ..I $G(AUPFARY(IVMDEMDA))'="CA" D

 ...S IVMADDR=$S($D(ADDRESS("P")):ADDRESS("P"),$D(ADDRESS("VAB1")):ADDRESS("VAB1"),$D(ADDRESS("VAB2")):ADDRESS("VAB2"),$D(ADDRESS("VAB3")):ADDRESS("VAB3"),$D(ADDRESS("VAB4")):ADDRESS("VAB4"),1:"")

 ...I $G(AUPFARY(IVMDEMDA))="RA" S IVMADDR=$G(ADDRESS("R"))

 ..I IVMADDR="" Q

 ..S COUNTRY=$P(IVMADDR,$E(HLECH),6)

 ..S FORADDR=$S(COUNTRY="USA":0,1:1)

 ..;-get piece of addr field, and set IVMFLD

 ..S IVMPIECE=$E(IVMPIECE,3,6),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)

 ..;Enable del of Addr2,Addr3-164-Fix End dt

 ..I (IVMPIECE="2C")!(IVMPIECE="8C")!(IVMPIECE="2R")!(IVMPIECE="8R") S:IVMFLD="" IVMFLD="@"

 ..I $E(IVMPIECE,1,3)="13C" D

 ...S IVMFLD=$P(IVMADDR,$E(HLECH),12)

 ...S IVMFLD=$$FMDATE^HLFNC($P(IVMFLD,$E(HLECH,4),2))

 ...S:IVMFLD="" IVMFLD="@"

 ..Q:IVMFLD=""

 ..;convert st abbrev. to pointer

 ..I (IVMPIECE=4)!(IVMPIECE="4C")!(IVMPIECE="4R") D

 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"")

 ...I IVMFLD'="" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))

 ...;IVM*2.0*164-PMA State Pointer

 ...I IVMPIECE=4 S IVMPMAST=$G(IVMSTPTR)

 ...I IVMPIECE="4C" S IVMCMAST=$G(IVMSTPTR)

 ..I (IVMPIECE=5)!(IVMPIECE="5C")!(IVMPIECE="5R") D

 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"")

 ...I IVMFLD'="" S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=X

 ..I (IVMPIECE="4F")!(IVMPIECE="4CF")!(IVMPIECE="4RF") S IVMFLD=$S(FORADDR:IVMFLD,1:"") ;PROVINCE

 ..I (IVMPIECE="5F")!(IVMPIECE="5CF")!(IVMPIECE="5RF") S IVMFLD=$S(FORADDR:IVMFLD,1:"") ;POSTAL CODE

 ..I (IVMPIECE=6)!(IVMPIECE="6C")!(IVMPIECE="6R") S IVMFLD=$$CNTRCONV(COUNTRY) ;COUNTRY

 ..I IVMPIECE=7 S IVMFLD=$$BAICONV(IVMFLD) ;Bad Address Ind

 ..I IVMPIECE="7C" S IVMFLD=CONFADCT  ;CONFADCT set in PID11^IVMPRECA

 ..;County for Conf

 ..I IVMPIECE="9C" D

 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""

 ...I IVMCMAST'="" S IVMFLD=+$O(^DIC(5,IVMCMAST,1,"C",IVMFLD,0))

 ..;County for Res

 ..I IVMPIECE="9R" D

 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""

 ...I IVMSTPTR'="" S IVMFLD=+$O(^DIC(5,IVMSTPTR,1,"C",IVMFLD,0))

 ..I $E(IVMPIECE,1,3)="12C" D

 ...S IVMFLD=$$FMDATE^HLFNC($P(IVMFLD,$E(HLECH,4),1))

 ...;IVM*2.0*164-Allow del of start dt

 ...S:IVMFLD="" IVMFLD="@"

 ..S IVMADFLG=1

 .I IVMXREF["PID12",'$G(DODSEG) D

 ..;IVM*2.0*164-County from PMA St

 ..D PID12^IVMPREC9

 ..I 'FORADDR D

 ...S IVMADFLG=1

 ...I IVMPMAST'="" S IVMFLD=+$O(^DIC(5,IVMPMAST,1,"C",IVMPID(12),0))

 .;line remove so that the ph is compared before saving to 301.5

 .I IVMXREF["PID13",$D(TELECOM),'$G(DODSEG) D

 ..;Conf Ph

 ..I IVMXREF="PID13CA",$D(TELECOM("VACPN")) D

 ...;IVM*2.0*215-Constuct Conf ph

 ...S IVMFLD=$P($G(TELECOM("VACPN")),$E(HLECH),6)_$P($G(TELECOM("VACPN")),$E(HLECH),7),IVMADFLG=1

 ...S IVMFLD=$$CONVPHAN(IVMFLD)

 ...I IVMFLD="" S IVMFLD="@"

 ...S IVMCNTRY=$P($G(TELECOM("VACPN")),$E(HLECH),5)

 ...S IVMCNTRY=$$CONVPHAN(IVMCNTRY)

 ...I ($G(IVMCNTRY))=""!(IVMFLD="@") S IVMCNTRY="@"

 ...D UPLOAD^IVMLDEM6(DFN,.13201,IVMCNTRY)

 ...S IVMEXT=$P($G(TELECOM("VACPN")),$E(HLECH),8)

 ...S IVMEXT=$$CONVPHAN(IVMEXT)

 ...I ($G(IVMEXT)="")!(IVMFLD="@") S IVMEXT="@"

 ...D UPLOAD^IVMLDEM6(DFN,.13214,$G(IVMEXT))

 ..;[Work]

 ..I IVMXREF="PID13W",$D(TELECOM("WPN")) D

 ...; IVM*2.0*215- Work ph

 ...S IVMFLD=$P($G(TELECOM("WPN")),$E(HLECH),6)_$P($G(TELECOM("WPN")),$E(HLECH),7),IVMADFLG=1

 ...S IVMFLD=$$CONVPHAN(IVMFLD)

 ...I IVMFLD="" S IVMFLD="@"

 ...S IVMCNTRY=$P($G(TELECOM("WPN")),$E(HLECH),5)

 ...S IVMCNTRY=$$CONVPHAN(IVMCNTRY)

 ...I ($G(IVMCNTRY)="")!(IVMFLD="@") S IVMCNTRY="@"

 ...D UPLOAD^IVMLDEM6(DFN,.1329,IVMCNTRY)

 ...S IVMEXT=$P($G(TELECOM("WPN")),$E(HLECH),8)

 ...S IVMEXT=$$CONVPHAN(IVMEXT)

 ...I ($G(IVMEXT)="")!(IVMFLD="@") S IVMEXT="@"

 ...D UPLOAD^IVMLDEM6(DFN,.13213,$G(IVMEXT))

 ..;Pager

 ..I IVMXREF="PID13B",$D(TELECOM("BPN")) D

 ...S IVMFLD=$$CONVPH($P($G(TELECOM("BPN")),$E(HLECH))),IVMADFLG=1

 ..;Cell Ph

 ..I IVMXREF="PID13C",$D(TELECOM("ORN")) D

 ...; IVM*2.0*215- Cell ph

 ...S IVMFLD=$P($G(TELECOM("ORN")),$E(HLECH),6)_$P($G(TELECOM("ORN")),$E(HLECH),7),IVMADFLG=1

 ...S IVMFLD=$$CONVPHAN(IVMFLD)

 ...I IVMFLD="" S IVMFLD="@"

 ...S IVMCNTRY=$P($G(TELECOM("ORN")),$E(HLECH),5)

 ...S IVMCNTRY=$$CONVPHAN(IVMCNTRY)

 ...I ($G(IVMCNTRY)="")!(IVMFLD="@") S IVMCNTRY="@"

 ...D UPLOAD^IVMLDEM6(DFN,.1328,IVMCNTRY)

 ...S IVMEXT=$P($G(TELECOM("ORN")),$E(HLECH),8)

 ...S IVMEXT=$$CONVPHAN(IVMEXT)

 ...I ($G(IVMEXT)="")!(IVMFLD="@") S IVMEXT="@"

 ...D UPLOAD^IVMLDEM6(DFN,.13212,$G(IVMEXT))

 ..;Email

 ..I IVMXREF="PID13E",$D(TELECOM("NET")) D

 ...S IVMFLD=$P($G(TELECOM("NET")),$E(HLECH),4)

 ...S IVMFLD=$S($$CHKEMAIL(IVMFLD):IVMFLD,1:""),IVMADFLG=1

 .; - file addr fields and quit

 .I IVMADFLG D STORE^IVMPREC9 Q

 .I $E(IVMXREF,1,5)'="PID13" S IVMFLD=$G(IVMPID(+IVMPIECE))

 .I IVMXREF["PID07" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)

 .I IVMXREF["PID16" D

 ..S IVMFLD=$S(IVMFLD="D":"DIVORCED",IVMFLD="M":"MARRIED",IVMFLD="W":"WIDOWED",IVMFLD="A":"SEPARATED",IVMFLD="S":"NEVER MARRIED",IVMFLD="U":"UNKNOWN")

 ..S IVMFLD=$O(^DIC(11,"B",IVMFLD,0))

 .I IVMXREF["PID17" S IVMFLD=$O(^DIC(13,"C",IVMFLD,0))  ;Religion

 .I IVMXREF["PID22" D  ;Ethnicity

 ..S IVMFLD=$$CODE2PTR^DGUTL4($P($G(IVMPID(22)),$E(HLECH),4),2,2)

 .I IVMXREF="PID10",'$G(DODSEG),$D(IVMRACE) D  Q

 ..N XVAL,IVMLST,DHCPLST

 ..S (XVAL,IVMLST,DHCPLST)=""

 ..F  S XVAL=$O(^DPT(DFN,.02,"B",XVAL)) Q:XVAL=""  S IVMLST=IVMLST_XVAL_U

 ..S XVAL="" F  S XVAL=$O(IVMRACE(2,XVAL)) Q:XVAL=""  S DHCPLST=DHCPLST_XVAL_U

 ..Q:IVMLST=DHCPLST

 ..F XVAL=1:1:($L(DHCPLST,U)-1) S IVMFLD=$P(DHCPLST,U,XVAL) D

 ...D STORE^IVMPREC9

 .;call VADPT to return DHCP demographics

 .D DEM^VADPT,ADD^VADPT,OPD^VADPT

 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y

 .; - special logic for ph,if different store value,quit

 .I IVMXREF="PID13",$D(TELECOM("PRN")),'$G(DODSEG) D  Q

 ..; IVM*2.0*215 - Res ph

 ..S IVMFLD=$P($G(TELECOM("PRN")),$E(HLECH),6)_$P($G(TELECOM("PRN")),$E(HLECH),7)

 ..S IVMFLD=$$CONVPHAN(IVMFLD)

 ..I IVMFLD="" S IVMFLD="@"

 ..S IVMCNTRY=$P($G(TELECOM("PRN")),$E(HLECH),5)

 ..S IVMCNTRY=$$CONVPHAN(IVMCNTRY)

 ..I ($G(IVMCNTRY)="")!(IVMFLD="@") S IVMCNTRY="@"

 ..D UPLOAD^IVMLDEM6(DFN,.1327,IVMCNTRY)

 ..S IVMEXT=$P($G(TELECOM("PRN")),$E(HLECH),8)

 ..S IVMEXT=$$CONVPHAN(IVMEXT)

 ..I ($G(IVMEXT)="")!(IVMFLD="@") S IVMEXT="@"

 ..D UPLOAD^IVMLDEM6(DFN,.13211,$G(IVMEXT))

 ..I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9

 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9

 Q

 ;

ZPD ; -compare ZPD with DHCP

 ;IVM*2.0*215 - Moved ZPD tag to ZPDA^IVMPRECA

 D ZPDPA^IVMPRECA

 Q

 ;

ZTA ; -compare ZTA with DHCP

 N COMPPH1,COMPPH2,COUNTRY,IVMPHONE

 S IVMPIECE=$E(IVMXREF,4,7)

 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D

 .; - set var IVMFLD to incoming HL7 field

 .S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))

 .; - ZTA05 as the ZTA addr field is 5 ~ pieces

 .I IVMXREF["ZTA05" D

 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)) Q:IVMADDR=""

 ..S COUNTRY=$P(IVMADDR,$E(HLECH),6)

 ..S FORADDR=$S(COUNTRY="USA":0,1:1)

 ..; - get piece of address field, and set IVMFLD

 ..S IVMPIECE=$E(IVMPIECE,3,4)

 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)

 ..I (IVMPIECE=2)!(IVMPIECE=8) S:IVMFLD="" IVMFLD="@"

 ..Q:IVMFLD=""

 ..I (IVMPIECE=4)!(IVMPIECE=5)!(IVMPIECE=9) S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""

 ..I IVMPIECE=4 S (IVMTSTPT,IVMFLD)=$O(^DIC(5,"C",IVMFLD,0))

 ..I IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)

 ..I IVMPIECE="4F" S IVMFLD=$S(FORADDR:IVMFLD,1:"")  ;PROVINCE

 ..I IVMPIECE="5F" S IVMFLD=$S(FORADDR:IVMFLD,1:"")  ;POSTAL CODE

 ..I IVMPIECE=6 S IVMFLD=$$CNTRCONV(COUNTRY)         ;COUNTRY

 ..I IVMPIECE=9 S IVMFLD=+$O(^DIC(5,+IVMTSTPT,1,"C",IVMFLD,0))  ;COUNTY

 .Q:IVMFLD=""

 .; - convert to Y/N val

 .I IVMXREF["ZTA02" S IVMFLD=$S(IVMFLD=0:"N",IVMFLD=1:"Y",1:"")

 .; - convert to FM dt

 .I (IVMXREF["ZTA03")!(IVMXREF["ZTA04")!(IVMXREF["ZTA08") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)

 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y

 .; -special logic for ph

 .I IVMXREF["ZTA07" D  Q

 ..;IVM*2.0*215 - Skip phone number from 1st piece

 ..;I COMPPH1'=COMPPH2 D STORE^IVMPREC9

 .; IVM*2.0*215-Add ZTA10 as the Temp phone is 4 ~ pieces in Seq 10

 .I IVMXREF["ZTA10" D  Q

 ..N IVMPH

 ..S IVMPHONE=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)) Q:IVMPHONE=""

 ..S IVMPIECE=$E(IVMPIECE,3)

 ..S IVMFLD=$P(IVMPHONE,$E(HLECH),IVMPIECE)

 ..I IVMPIECE=2 S IVMFLD=IVMFLD_$P(IVMPHONE,$E(HLECH),3)

 ..S IVMFLD=$$CONVPHAN(IVMFLD)

 ..S IVMPH=$P(IVMPHONE,$E(HLECH),2)_$P(IVMPHONE,$E(HLECH),3)

 ..S IVMPH=$$CONVPHAN(IVMPH)

 ..I (IVMFLD="")!(IVMPH="") S IVMFLD="@"

 ..I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9

 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9

 .I IVMXREF["ZTA08" D

 ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("TA")=1

 Q

 ;

ZAV ; compare ZAV with DHCP

 N IVMATYP

 S IVMFLD=""

 S IVMATYP=""

 S IVMATYP=$P(IVMSEG,HLFS,2)

 S IVMFLD=$P(IVMSEG,HLFS,3)

 I IVMXREF=$S(IVMATYP="P":"ZAV03",IVMATYP="CNF":"ZAV02",IVMATYP="R":"ZAV01",IVMATYP="C":"ZAV04",1:"") D 

 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y

 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9

 Q

 ;

ZGD ; - compare ZGD with DHCP

 S IVMADFLG=0

 S IVMPIECE=$E(IVMXREF,4,7)

 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D

 .; - set var IVMFLD to incoming HL7

 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)

 .; - ZGD06 as the ZGD address field is 5 ~ pieces

 .I IVMXREF["ZGD06" D

 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)

 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1

 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))

 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)

 .; - if HL7 dt convert to FM dt

 .I IVMXREF["ZGD08" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)

 .; - execute code on the 1 node and get DHCP

 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y

 .; if field from IVM <> DHCP-store for uploading

 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9

 Q

 ;

ZCT ; - compare ZCT with DHCP

 N ZCTTYP

 S IVMADFLG=0

 S IVMPIECE=$E(IVMXREF,4,8)

 ;IVM*2.0*188-COMMENT BELOW TO ALLOW QUOTES

 ;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)

 S ZCTTYP=$E(IVMPIECE,$L(IVMPIECE)-1,$L(IVMPIECE))

 Q:$P(IVMSEG,HLFS,2)'=$S(ZCTTYP="K1":1,ZCTTYP="K2":2,ZCTTYP="E1":3,ZCTTYP="E2":4,ZCTTYP="D1":5,1:"")

 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D

 .; -set var IVMFLD to incoming HL7 field

 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))

 .;IVM*2.0*188-convert "" to @

 .I IVMFLD="""""" S IVMFLD="@"

 .; - if HL7 name format convert to FM

 .I IVMXREF["ZCT03" S IVMFLD=$$FMNAME^HLFNC(IVMFLD)

 .I IVMFLD="@," S IVMFLD="@" ;IVM*2.0*188

 .; - ZCT05 as the ZCT address field is 5 ~ pieces

 .I IVMXREF["ZCT05" D

 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)

 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1

 ..;IVM*2.0*188-convert "" to @

 ..I IVMFLD="""""" S IVMFLD="@" Q

 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))

 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)

 .I IVMADFLG D STORE^IVMPREC9 Q

 .; - if HL7 dt convert to FM dt

 .I IVMXREF["ZCT10" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)

 .; - execute code on the 1 node and get DHCP field

 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y

 .;IVM*2.0*188-convert "" to @

 .I IVMFLD="""""" S IVMFLD="@"

 .; if field from IVM <> DHCP-store for upload

 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9

 .I IVMXREF["ZCT10" D

 ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG(ZCTTYP)=1

 Q

 ;

ZEM ; - compare ZEM with DHCP

 S IVMADFLG=0

 S IVMPIECE=$E(IVMXREF,4,7)

 S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)

 Q:$P(IVMSEG,HLFS,2)'=$S($E(IVMXREF,$L(IVMXREF))="S":2,1:1)

 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D

 .; - set var IVMFLD to incoming HL7 field

 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))

 .; - ZEM06 as the ZEM addr containing 5 ~ pieces

 .I IVMXREF["ZEM06" D

 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)

 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)    ;,IVMADFLG=1

 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))

 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)

 .; - if HL7 dt convert to FM dt

 .I IVMXREF["ZEM09" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)

 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y

 .I $E(IVMXREF,1,6)="ZEM062",IVMFLD'=IVMDHCP S ZEMADRUP(IVMXREF)=1 D STORE^IVMPREC9 Q

 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9

 Q

 ;

RF1 ; -compare RF1 with DHCP

 S IVMPIECE=$E(IVMXREF,4),IVMADFLG=1,RF1TYPE=$P(IVMSEG,HLFS,3)

 ;Delete the comm data (Email, Cell and Pager) if not in Z05.

 ;Remove from EPCDEL if Data exist in Z05. Comm. fields in EPCDEL deleted after updating all incoming data.

 ;IVM*2.0*164-Don't Kill if PHH

 I RF1TYPE'="PHH" K EPCDEL(RF1TYPE)

 ;if RF1 field is SEQ6, then parse subcomponents

 I RF1TYPE="SAD",((IVMXREF="RF161")!(IVMXREF="RF162")!(IVMXREF="RF171")) D RF1PROC

 ;IVM*2.0*164-Uncomment Conf and Add Res

 I RF1TYPE="CAD",((IVMXREF="RF161CA")!(IVMXREF="RF162CA")!(IVMXREF="RF171CA")) D RF1PROC

 I RF1TYPE="RAD",((IVMXREF="RF161RA")!(IVMXREF="RF162RA")!(IVMXREF="RF171RA")) D RF1PROC

 ;

 I RF1TYPE="CPH",((IVMXREF="RF161C")!(IVMXREF="RF162C")!(IVMXREF="RF171C")) D RF1PROC

 I RF1TYPE="PNO",((IVMXREF="RF161B")!(IVMXREF="RF162B")!(IVMXREF="RF171B")) D RF1PROC

 I RF1TYPE="EAD",((IVMXREF="RF161E")!(IVMXREF="RF162E")!(IVMXREF="RF171E")) D RF1PROC

 I RF1TYPE="PHH",((IVMXREF="RF161P")!(IVMXREF="RF162P")!(IVMXREF="RF171P")) D RF1PROC ;IVM*2*152

 ;IVM*2.0*214 - PHONE NUMBER [WORK] Change Date/Time

 I RF1TYPE="PHW",(IVMXREF="RF171PW") D RF1PROC

 ;IVM*2.0*164-LAST RF1 change

 I '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA),IVMXREF="RF171RA" D  ;Last RF1

 . I $$AUTOEPC^IVMPREC9(DFN,.UPDEPC)

 . N NOUPDT,NOPHUP S (NOUPDT,NOPHUP)=0 ;IVM*2*152

 . I 'UPDEPC("SAD") S NOUPDT=1

 . ;Always keep NOPHUP=0 so Home ph is not handled here

 . K UPPHN

 . I $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT,NOPHUP)

 Q

 ;

RF1PROC ;

 N IVMEPC

 I $P(IVMSEG,HLFS,IVMPIECE)]"" D

 .;if RF1 field is SEQ6, parse subcomponents

 .I IVMXREF["RF16" D  Q

 ..;- get data containing 4 ~ pieces

 ..S IVMRFDAT=$P(IVMSEG,HLFS,6)

 ..S IVMPIECE=$E(IVMXREF,5),IVMFLD=$P(IVMRFDAT,"~",IVMPIECE)

 ..;KUM-164-SET IVMEPC TO NONBLANK 

 ..;S IVMEPC=$E(IVMXREF,6)

 ..S IVMEPC=""

 ..I (IVMXREF="RF162E")!(IVMXREF="RF162C")!(IVMXREF="RF162B")!(IVMXREF="RF162P") S IVMEPC="2"

 ..I IVMPIECE=2 S IVMFLD=$S(IVMEPC'="":$$EPCSRCC(IVMFLD),1:$$ADDRCNV(IVMFLD))

 ..Q:IVMFLD=""

 ..D STORE^IVMPREC9

 .I IVMXREF["RF17" D  Q

 ..;get address/telecomm change date/tm field

 ..S IVMFLD=$$FMDATE^HLFNC($P(IVMSEG,HLFS,7))

 ..Q:IVMFLD=""

 ..;IVM*2*171 - If RF1 type is PHH,home ph is null in PID (IVMPHDFG)

 ..;deletion IF incoming num change dt/tm is > change dt/tm in #2 rec

 ..S:$P($G(TELECOM("PRN")),"~",1)="" IVMPHDFG=1

 ..I RF1TYPE="PHH",+IVMPHDFG,+$$GET1^DIQ(2,DFN_",",.1321,"I") D

 ...S:+$$GET1^DIQ(2,DFN_",",.1321,"I")<IVMFLD EPCDEL("PHH")=".131^.1321^.1322^.1323"

 ..D STORE^IVMPREC9

 ..;164-Uncomment Conf and Add Res

 ..I RF1TYPE="CAD",$P($G(ADDRESS("CA")),HLFS)]"" D  Q

 ...S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y

 ...I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("CA")=1

 ..I RF1TYPE="RAD",$P($G(ADDRESS("R")),HLFS)]"" D  Q

 ...S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y

 ...I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("RA")=1

 ..; check for auto-upload

 ..S IVMDHCP=$S(RF1TYPE="SAD":$P($G(^DPT(DFN,.11)),HLFS,13),RF1TYPE="CPH":$P($G(^DPT(DFN,.13)),HLFS,9),RF1TYPE="PNO":$P($G(^DPT(DFN,.13)),HLFS,12),RF1TYPE="EAD":$P($G(^DPT(DFN,.13)),HLFS,6),1:"")

 ..;IVM*2.0*214 - Get PHONE NUMBER [WORK] from #2

 ..I IVMDHCP="" S IVMDHCP=$S(RF1TYPE="PHH":$P($G(^DPT(DFN,.132)),HLFS,1),RF1TYPE="PHW":$P($G(^DPT(DFN,.132)),HLFS,6),RF1TYPE="RAD":$P($G(^DPT(DFN,.115)),HLFS,11),1:"")

 ..;IVM*2.0*215-If Last update is MPI, Accept

 ..I IVMFLD]"",($$GET1^DIQ(2,DFN_",",.1324,"E")["PSUSER,APPLICATION PROXY"),RF1TYPE="PHH" S UPDEPC(RF1TYPE)=$G(EPCFARY(RF1TYPE))

 ..I IVMFLD]"",(IVMFLD>IVMDHCP) D

 ...S UPDEPC(RF1TYPE)=$G(EPCFARY(RF1TYPE))

 ...I RF1TYPE="SAD" S UPDEPC("SAD")=1

 ...; 167-Make Home ph rec auto-upload to Patient

 ...;I RF1TYPE="PHH" S UPDEPC("PHH")=1 ;IVM*2*152

 Q

ADDRCNV(ADDRSRC) ;convert Addr Source from HL7 to DHCP

 ;

 Q:$G(ADDRSRC)']"" ""

 Q:ADDRSRC="USVAHEC" "HEC"

 Q:ADDRSRC="USVAMC" "VAMC"

 Q:ADDRSRC="USVAHBSC" "HBSC"

 Q:ADDRSRC="USNCOA" "NCOA"

 Q:ADDRSRC="USVABVA" "BVA"

 Q:ADDRSRC="USVAINS" "VAINS"

 Q:ADDRSRC="USPS" "USPS"

 Q:ADDRSRC="LACS" "LACS"

 Q:ADDRSRC="USVOA" "VOA"

 Q:ADDRSRC="VET360" "VET360"

 Q ""

EPCSRCC(EPCSRC) ;Convert Email, Cell, Pager Change Source from HL7 to DHCP

 ;

 Q:$G(EPCSRC)']"" ""

 Q:EPCSRC="USVAHEC" "HEC"

 Q:EPCSRC="USVAMC" "VAMC"

 Q:EPCSRC="USVAHBSC" "HBSC"

 Q:EPCSRC="USVOA" "VOA"

 Q:EPCSRC="VET360" "VET360"

 Q ""

BAICONV(BAISRC) ;Convert Bad addr source from HL7 to DHCP format

 Q:$G(BAISRC)']"" ""

 Q:BAISRC="VAB1" 1

 Q:BAISRC="VAB2" 2

 Q:BAISRC="VAB3" 3

 Q:BAISRC="VAB4" 4

 Q ""

CONVPH(PH) ;remove special chars/spaces from Ph

 ;*168 Check format, quit if OK else strip and return if not 10 num

 ;Format if 10 numeric.

 Q:PH?1"(".3N.1")".3N.1"-".4N PH

 S PH=$TR(PH," )(/#\-","")

 Q:PH'?10N PH

 Q "("_$E(PH,1,3)_")"_$E(PH,4,6)_"-"_$E(PH,7,10)

 ;

CNTRCONV(COUNTRY) ;Check if valid country

 I COUNTRY="" Q 0

 Q $O(^HL(779.004,"B",COUNTRY,""))

CHKEMAIL(EMAIL) ;Check for Valid Email

 I $G(EMAIL)="" Q 0

 I '(EMAIL?1.E1"@"1.E1"."1.E) Q 0

 Q 1

CONVPHAN(PH) ;Convert Alpha Phone number to Numeric

 S PH=$TR(PH," )(/#\-~`!@#$%^&*'|<>?,.+=_abcdefghijklmnopqrstvuwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ","")

 Q PH

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IVMPREC8   18561     printed  Apr 23, 2025@18:16                                                                                                                                                                                                      Page 2

IVMPREC8  ;ALB/KCL,BRM,PJR,CKN,TDM,PWC,LBD,DPR,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;7/24/24 8:56AM

 +1       ;;2.0;INCOME VERIFICATION MATCH;**5,6,12,58,73,79,102,115,121,148,151,152,168,167,171,164,188,187,210,214,215**;21-OCT-94;Build 14

 +2       ;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ; This routine will process (event type Z05)

 +5       ;

PID       ;-compare PID fields with DHCP

 +1        NEW COMPPH1,COMPPH2,COUNTRY,IVMCNTRY,IVMEXT,IVMFNUM,IVMFVAL,IVMCNTRY,IVMEXT

 +2       ;

 +3        SET IVMFLD=""

 +4       ; - strip off seg name

 +5        SET IVMPIECE=$EXTRACT(IVMXREF,4,9)

 +6       ;Only process if value exist-also handles multiple addr

 +7        IF $GET(IVMPID(+$EXTRACT(IVMPIECE,1,2)))'=""!($ORDER(IVMPID(+$EXTRACT(IVMPIECE,1,2),"")))

               Begin DoDot:1

 +8       ; -if PID field is the addr field-parse addr

 +9                SET IVMADFLG=0

 +10               IF IVMXREF["PID11"

                       IF '$GET(DODSEG)

                           Begin DoDot:2

 +11      ; IVM*2.0*164-Uncomment Conf and Add Res

 +12      ;Conf Addr

                               IF $GET(AUPFARY(IVMDEMDA))="CA"

                                   SET IVMADDR=$GET(ADDRESS("CA"))

 +13                           IF $GET(AUPFARY(IVMDEMDA))'="CA"

                                   Begin DoDot:3

 +14                                   SET IVMADDR=$SELECT($DATA(ADDRESS("P")):ADDRESS("P"),$DATA(ADDRESS("VAB1")):ADDRESS("VAB1"),$DATA(ADDRESS("VAB2")):ADDRESS("VAB2"),$DATA(ADDRESS("VAB3")):ADDRESS("VAB3"),$DATA(ADDRESS("VAB4")):ADDRESS("VAB4"),1:"")

 +15                                   IF $GET(AUPFARY(IVMDEMDA))="RA"

                                           SET IVMADDR=$GET(ADDRESS("R"))

                                   End DoDot:3

 +16                           IF IVMADDR=""

                                   QUIT 

 +17                           SET COUNTRY=$PIECE(IVMADDR,$EXTRACT(HLECH),6)

 +18                           SET FORADDR=$SELECT(COUNTRY="USA":0,1:1)

 +19      ;-get piece of addr field, and set IVMFLD

 +20                           SET IVMPIECE=$EXTRACT(IVMPIECE,3,6)

                               SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)

 +21      ;Enable del of Addr2,Addr3-164-Fix End dt

 +22                           IF (IVMPIECE="2C")!(IVMPIECE="8C")!(IVMPIECE="2R")!(IVMPIECE="8R")

                                   if IVMFLD=""

                                       SET IVMFLD="@"

 +23                           IF $EXTRACT(IVMPIECE,1,3)="13C"

                                   Begin DoDot:3

 +24                                   SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),12)

 +25                                   SET IVMFLD=$$FMDATE^HLFNC($PIECE(IVMFLD,$EXTRACT(HLECH,4),2))

 +26                                   if IVMFLD=""

                                           SET IVMFLD="@"

                                   End DoDot:3

 +27                           if IVMFLD=""

                                   QUIT 

 +28      ;convert st abbrev. to pointer

 +29                           IF (IVMPIECE=4)!(IVMPIECE="4C")!(IVMPIECE="4R")

                                   Begin DoDot:3

 +30                                   SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")

 +31                                   IF IVMFLD'=""

                                           SET (IVMSTPTR,IVMFLD)=+$ORDER(^DIC(5,"C",IVMFLD,0))

 +32      ;IVM*2.0*164-PMA State Pointer

 +33                                   IF IVMPIECE=4

                                           SET IVMPMAST=$GET(IVMSTPTR)

 +34                                   IF IVMPIECE="4C"

                                           SET IVMCMAST=$GET(IVMSTPTR)

                                   End DoDot:3

 +35                           IF (IVMPIECE=5)!(IVMPIECE="5C")!(IVMPIECE="5R")

                                   Begin DoDot:3

 +36                                   SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")

 +37                                   IF IVMFLD'=""

                                           SET X=IVMFLD

                                           DO ZIPIN^VAFADDR

                                           SET IVMFLD=X

                                   End DoDot:3

 +38      ;PROVINCE

                               IF (IVMPIECE="4F")!(IVMPIECE="4CF")!(IVMPIECE="4RF")

                                   SET IVMFLD=$SELECT(FORADDR:IVMFLD,1:"")

 +39      ;POSTAL CODE

                               IF (IVMPIECE="5F")!(IVMPIECE="5CF")!(IVMPIECE="5RF")

                                   SET IVMFLD=$SELECT(FORADDR:IVMFLD,1:"")

 +40      ;COUNTRY

                               IF (IVMPIECE=6)!(IVMPIECE="6C")!(IVMPIECE="6R")

                                   SET IVMFLD=$$CNTRCONV(COUNTRY)

 +41      ;Bad Address Ind

                               IF IVMPIECE=7

                                   SET IVMFLD=$$BAICONV(IVMFLD)

 +42      ;CONFADCT set in PID11^IVMPRECA

                               IF IVMPIECE="7C"

                                   SET IVMFLD=CONFADCT

 +43      ;County for Conf

 +44                           IF IVMPIECE="9C"

                                   Begin DoDot:3

 +45                                   SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")

                                       if IVMFLD=""

                                           QUIT 

 +46                                   IF IVMCMAST'=""

                                           SET IVMFLD=+$ORDER(^DIC(5,IVMCMAST,1,"C",IVMFLD,0))

                                   End DoDot:3

 +47      ;County for Res

 +48                           IF IVMPIECE="9R"

                                   Begin DoDot:3

 +49                                   SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")

                                       if IVMFLD=""

                                           QUIT 

 +50                                   IF IVMSTPTR'=""

                                           SET IVMFLD=+$ORDER(^DIC(5,IVMSTPTR,1,"C",IVMFLD,0))

                                   End DoDot:3

 +51                           IF $EXTRACT(IVMPIECE,1,3)="12C"

                                   Begin DoDot:3

 +52                                   SET IVMFLD=$$FMDATE^HLFNC($PIECE(IVMFLD,$EXTRACT(HLECH,4),1))

 +53      ;IVM*2.0*164-Allow del of start dt

 +54                                   if IVMFLD=""

                                           SET IVMFLD="@"

                                   End DoDot:3

 +55                           SET IVMADFLG=1

                           End DoDot:2

                           if IVMFLD=""

                               QUIT 

 +56               IF IVMXREF["PID12"

                       IF '$GET(DODSEG)

                           Begin DoDot:2

 +57      ;IVM*2.0*164-County from PMA St

 +58                           DO PID12^IVMPREC9

 +59                           IF 'FORADDR

                                   Begin DoDot:3

 +60                                   SET IVMADFLG=1

 +61                                   IF IVMPMAST'=""