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 ---[H[J[2J[HIVMPREC8 18561 printed Sep 23, 2025@19:37:41 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'=""
SET IVMFLD=+$ORDER(^DIC(5,IVMPMAST,1,"C",IVMPID(12),0))
End DoDot:3
End DoDot:2
+62 ;line remove so that the ph is compared before saving to 301.5
+63 IF IVMXREF["PID13"
IF $DATA(TELECOM)
IF '$GET(DODSEG)
Begin DoDot:2
+64 ;Conf Ph
+65 IF IVMXREF="PID13CA"
IF $DATA(TELECOM("VACPN"))
Begin DoDot:3
+66 ;IVM*2.0*215-Constuct Conf ph
+67 SET IVMFLD=$PIECE($GET(TELECOM("VACPN")),$EXTRACT(HLECH),6)_$PIECE($GET(TELECOM("VACPN")),$EXTRACT(HLECH),7)
SET IVMADFLG=1
+68 SET IVMFLD=$$CONVPHAN(IVMFLD)
+69 IF IVMFLD=""
SET IVMFLD="@"
+70 SET IVMCNTRY=$PIECE($GET(TELECOM("VACPN")),$EXTRACT(HLECH),5)
+71 SET IVMCNTRY=$$CONVPHAN(IVMCNTRY)
+72 IF ($GET(IVMCNTRY))=""!(IVMFLD="@")
SET IVMCNTRY="@"
+73 DO UPLOAD^IVMLDEM6(DFN,.13201,IVMCNTRY)
+74 SET IVMEXT=$PIECE($GET(TELECOM("VACPN")),$EXTRACT(HLECH),8)
+75 SET IVMEXT=$$CONVPHAN(IVMEXT)
+76 IF ($GET(IVMEXT)="")!(IVMFLD="@")
SET IVMEXT="@"
+77 DO UPLOAD^IVMLDEM6(DFN,.13214,$GET(IVMEXT))
End DoDot:3
+78 ;[Work]
+79 IF IVMXREF="PID13W"
IF $DATA(TELECOM("WPN"))
Begin DoDot:3
+80 ; IVM*2.0*215- Work ph
+81 SET IVMFLD=$PIECE($GET(TELECOM("WPN")),$EXTRACT(HLECH),6)_$PIECE($GET(TELECOM("WPN")),$EXTRACT(HLECH),7)
SET IVMADFLG=1
+82 SET IVMFLD=$$CONVPHAN(IVMFLD)
+83 IF IVMFLD=""
SET IVMFLD="@"
+84 SET IVMCNTRY=$PIECE($GET(TELECOM("WPN")),$EXTRACT(HLECH),5)
+85 SET IVMCNTRY=$$CONVPHAN(IVMCNTRY)
+86 IF ($GET(IVMCNTRY)="")!(IVMFLD="@")
SET IVMCNTRY="@"
+87 DO UPLOAD^IVMLDEM6(DFN,.1329,IVMCNTRY)
+88 SET IVMEXT=$PIECE($GET(TELECOM("WPN")),$EXTRACT(HLECH),8)
+89 SET IVMEXT=$$CONVPHAN(IVMEXT)
+90 IF ($GET(IVMEXT)="")!(IVMFLD="@")
SET IVMEXT="@"
+91 DO UPLOAD^IVMLDEM6(DFN,.13213,$GET(IVMEXT))
End DoDot:3
+92 ;Pager
+93 IF IVMXREF="PID13B"
IF $DATA(TELECOM("BPN"))
Begin DoDot:3
+94 SET IVMFLD=$$CONVPH($PIECE($GET(TELECOM("BPN")),$EXTRACT(HLECH)))
SET IVMADFLG=1
End DoDot:3
+95 ;Cell Ph
+96 IF IVMXREF="PID13C"
IF $DATA(TELECOM("ORN"))
Begin DoDot:3
+97 ; IVM*2.0*215- Cell ph
+98 SET IVMFLD=$PIECE($GET(TELECOM("ORN")),$EXTRACT(HLECH),6)_$PIECE($GET(TELECOM("ORN")),$EXTRACT(HLECH),7)
SET IVMADFLG=1
+99 SET IVMFLD=$$CONVPHAN(IVMFLD)
+100 IF IVMFLD=""
SET IVMFLD="@"
+101 SET IVMCNTRY=$PIECE($GET(TELECOM("ORN")),$EXTRACT(HLECH),5)
+102 SET IVMCNTRY=$$CONVPHAN(IVMCNTRY)
+103 IF ($GET(IVMCNTRY)="")!(IVMFLD="@")
SET IVMCNTRY="@"
+104 DO UPLOAD^IVMLDEM6(DFN,.1328,IVMCNTRY)
+105 SET IVMEXT=$PIECE($GET(TELECOM("ORN")),$EXTRACT(HLECH),8)
+106 SET IVMEXT=$$CONVPHAN(IVMEXT)
+107 IF ($GET(IVMEXT)="")!(IVMFLD="@")
SET IVMEXT="@"
+108 DO UPLOAD^IVMLDEM6(DFN,.13212,$GET(IVMEXT))
End DoDot:3
+109 ;Email
+110 IF IVMXREF="PID13E"
IF $DATA(TELECOM("NET"))
Begin DoDot:3
+111 SET IVMFLD=$PIECE($GET(TELECOM("NET")),$EXTRACT(HLECH),4)
+112 SET IVMFLD=$SELECT($$CHKEMAIL(IVMFLD):IVMFLD,1:"")
SET IVMADFLG=1
End DoDot:3
End DoDot:2
+113 ; - file addr fields and quit
+114 IF IVMADFLG
DO STORE^IVMPREC9
QUIT
+115 IF $EXTRACT(IVMXREF,1,5)'="PID13"
SET IVMFLD=$GET(IVMPID(+IVMPIECE))
+116 IF IVMXREF["PID07"
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+117 IF IVMXREF["PID16"
Begin DoDot:2
+118 SET IVMFLD=$SELECT(IVMFLD="D":"DIVORCED",IVMFLD="M":"MARRIED",IVMFLD="W":"WIDOWED",IVMFLD="A":"SEPARATED",IVMFLD="S":"NEVER MARRIED",IVMFLD="U":"UNKNOWN")
+119 SET IVMFLD=$ORDER(^DIC(11,"B",IVMFLD,0))
End DoDot:2
+120 ;Religion
IF IVMXREF["PID17"
SET IVMFLD=$ORDER(^DIC(13,"C",IVMFLD,0))
+121 ;Ethnicity
IF IVMXREF["PID22"
Begin DoDot:2
+122 SET IVMFLD=$$CODE2PTR^DGUTL4($PIECE($GET(IVMPID(22)),$EXTRACT(HLECH),4),2,2)
End DoDot:2
+123 IF IVMXREF="PID10"
IF '$GET(DODSEG)
IF $DATA(IVMRACE)
Begin DoDot:2
+124 NEW XVAL,IVMLST,DHCPLST
+125 SET (XVAL,IVMLST,DHCPLST)=""
+126 FOR
SET XVAL=$ORDER(^DPT(DFN,.02,"B",XVAL))
if XVAL=""
QUIT
SET IVMLST=IVMLST_XVAL_U
+127 SET XVAL=""
FOR
SET XVAL=$ORDER(IVMRACE(2,XVAL))
if XVAL=""
QUIT
SET DHCPLST=DHCPLST_XVAL_U
+128 if IVMLST=DHCPLST
QUIT
+129 FOR XVAL=1:1:($LENGTH(DHCPLST,U)-1)
SET IVMFLD=$PIECE(DHCPLST,U,XVAL)
Begin DoDot:3
+130 DO STORE^IVMPREC9
End DoDot:3
End DoDot:2
QUIT
+131 ;call VADPT to return DHCP demographics
+132 DO DEM^VADPT
DO ADD^VADPT
DO OPD^VADPT
+133 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+134 ; - special logic for ph,if different store value,quit
+135 IF IVMXREF="PID13"
IF $DATA(TELECOM("PRN"))
IF '$GET(DODSEG)
Begin DoDot:2
+136 ; IVM*2.0*215 - Res ph
+137 SET IVMFLD=$PIECE($GET(TELECOM("PRN")),$EXTRACT(HLECH),6)_$PIECE($GET(TELECOM("PRN")),$EXTRACT(HLECH),7)
+138 SET IVMFLD=$$CONVPHAN(IVMFLD)
+139 IF IVMFLD=""
SET IVMFLD="@"
+140 SET IVMCNTRY=$PIECE($GET(TELECOM("PRN")),$EXTRACT(HLECH),5)
+141 SET IVMCNTRY=$$CONVPHAN(IVMCNTRY)
+142 IF ($GET(IVMCNTRY)="")!(IVMFLD="@")
SET IVMCNTRY="@"
+143 DO UPLOAD^IVMLDEM6(DFN,.1327,IVMCNTRY)
+144 SET IVMEXT=$PIECE($GET(TELECOM("PRN")),$EXTRACT(HLECH),8)
+145 SET IVMEXT=$$CONVPHAN(IVMEXT)
+146 IF ($GET(IVMEXT)="")!(IVMFLD="@")
SET IVMEXT="@"
+147 DO UPLOAD^IVMLDEM6(DFN,.13211,$GET(IVMEXT))
+148 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:2
QUIT
+149 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:1
+150 QUIT
+151 ;
ZPD ; -compare ZPD with DHCP
+1 ;IVM*2.0*215 - Moved ZPD tag to ZPDA^IVMPRECA
+2 DO ZPDPA^IVMPRECA
+3 QUIT
+4 ;
ZTA ; -compare ZTA with DHCP
+1 NEW COMPPH1,COMPPH2,COUNTRY,IVMPHONE
+2 SET IVMPIECE=$EXTRACT(IVMXREF,4,7)
+3 IF $PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))]""
Begin DoDot:1
+4 ; - set var IVMFLD to incoming HL7 field
+5 SET IVMFLD=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
+6 ; - ZTA05 as the ZTA addr field is 5 ~ pieces
+7 IF IVMXREF["ZTA05"
Begin DoDot:2
+8 SET IVMADDR=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
if IVMADDR=""
QUIT
+9 SET COUNTRY=$PIECE(IVMADDR,$EXTRACT(HLECH),6)
+10 SET FORADDR=$SELECT(COUNTRY="USA":0,1:1)
+11 ; - get piece of address field, and set IVMFLD
+12 SET IVMPIECE=$EXTRACT(IVMPIECE,3,4)
+13 SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
+14 IF (IVMPIECE=2)!(IVMPIECE=8)
if IVMFLD=""
SET IVMFLD="@"
+15 if IVMFLD=""
QUIT
+16 IF (IVMPIECE=4)!(IVMPIECE=5)!(IVMPIECE=9)
SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")
if IVMFLD=""
QUIT
+17 IF IVMPIECE=4
SET (IVMTSTPT,IVMFLD)=$ORDER(^DIC(5,"C",IVMFLD,0))
+18 IF IVMPIECE=5
SET X=IVMFLD
DO ZIPIN^VAFADDR
SET IVMFLD=$GET(X)
+19 ;PROVINCE
IF IVMPIECE="4F"
SET IVMFLD=$SELECT(FORADDR:IVMFLD,1:"")
+20 ;POSTAL CODE
IF IVMPIECE="5F"
SET IVMFLD=$SELECT(FORADDR:IVMFLD,1:"")
+21 ;COUNTRY
IF IVMPIECE=6
SET IVMFLD=$$CNTRCONV(COUNTRY)
+22 ;COUNTY
IF IVMPIECE=9
SET IVMFLD=+$ORDER(^DIC(5,+IVMTSTPT,1,"C",IVMFLD,0))
End DoDot:2
+23 if IVMFLD=""
QUIT
+24 ; - convert to Y/N val
+25 IF IVMXREF["ZTA02"
SET IVMFLD=$SELECT(IVMFLD=0:"N",IVMFLD=1:"Y",1:"")
+26 ; - convert to FM dt
+27 IF (IVMXREF["ZTA03")!(IVMXREF["ZTA04")!(IVMXREF["ZTA08")
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+28 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+29 ; -special logic for ph
+30 IF IVMXREF["ZTA07"
Begin DoDot:2
+31 ;IVM*2.0*215 - Skip phone number from 1st piece
+32 ;I COMPPH1'=COMPPH2 D STORE^IVMPREC9
End DoDot:2
QUIT
+33 ; IVM*2.0*215-Add ZTA10 as the Temp phone is 4 ~ pieces in Seq 10
+34 IF IVMXREF["ZTA10"
Begin DoDot:2
+35 NEW IVMPH
+36 SET IVMPHONE=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
if IVMPHONE=""
QUIT
+37 SET IVMPIECE=$EXTRACT(IVMPIECE,3)
+38 SET IVMFLD=$PIECE(IVMPHONE,$EXTRACT(HLECH),IVMPIECE)
+39 IF IVMPIECE=2
SET IVMFLD=IVMFLD_$PIECE(IVMPHONE,$EXTRACT(HLECH),3)
+40 SET IVMFLD=$$CONVPHAN(IVMFLD)
+41 SET IVMPH=$PIECE(IVMPHONE,$EXTRACT(HLECH),2)_$PIECE(IVMPHONE,$EXTRACT(HLECH),3)
+42 SET IVMPH=$$CONVPHAN(IVMPH)
+43 IF (IVMFLD="")!(IVMPH="")
SET IVMFLD="@"
+44 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:2
QUIT
+45 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
+46 IF IVMXREF["ZTA08"
Begin DoDot:2
+47 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
SET UPDAUPG("TA")=1
End DoDot:2
End DoDot:1
+48 QUIT
+49 ;
ZAV ; compare ZAV with DHCP
+1 NEW IVMATYP
+2 SET IVMFLD=""
+3 SET IVMATYP=""
+4 SET IVMATYP=$PIECE(IVMSEG,HLFS,2)
+5 SET IVMFLD=$PIECE(IVMSEG,HLFS,3)
+6 IF IVMXREF=$SELECT(IVMATYP="P":"ZAV03",IVMATYP="CNF":"ZAV02",IVMATYP="R":"ZAV01",IVMATYP="C":"ZAV04",1:"")
Begin DoDot:1
+7 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+8 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:1
+9 QUIT
+10 ;
ZGD ; - compare ZGD with DHCP
+1 SET IVMADFLG=0
+2 SET IVMPIECE=$EXTRACT(IVMXREF,4,7)
+3 IF $PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))]""
Begin DoDot:1
+4 ; - set var IVMFLD to incoming HL7
+5 IF 'IVMADFLG
SET IVMFLD=$PIECE(IVMSEG,HLFS,IVMPIECE)
+6 ; - ZGD06 as the ZGD address field is 5 ~ pieces
+7 IF IVMXREF["ZGD06"
Begin DoDot:2
+8 SET IVMADDR=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
SET IVMPIECE=$EXTRACT(IVMPIECE,3)
+9 SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
SET IVMADFLG=1
+10 IF IVMFLD]""
IF IVMPIECE=4
SET IVMFLD=$ORDER(^DIC(5,"C",IVMFLD,0))
+11 IF IVMFLD]""
IF IVMPIECE=5
SET X=IVMFLD
DO ZIPIN^VAFADDR
SET IVMFLD=$GET(X)
End DoDot:2
+12 ; - if HL7 dt convert to FM dt
+13 IF IVMXREF["ZGD08"
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+14 ; - execute code on the 1 node and get DHCP
+15 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+16 ; if field from IVM <> DHCP-store for uploading
+17 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:1
+18 QUIT
+19 ;
ZCT ; - compare ZCT with DHCP
+1 NEW ZCTTYP
+2 SET IVMADFLG=0
+3 SET IVMPIECE=$EXTRACT(IVMXREF,4,8)
+4 ;IVM*2.0*188-COMMENT BELOW TO ALLOW QUOTES
+5 ;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
+6 SET ZCTTYP=$EXTRACT(IVMPIECE,$LENGTH(IVMPIECE)-1,$LENGTH(IVMPIECE))
+7 if $PIECE(IVMSEG,HLFS,2)'=$SELECT(ZCTTYP="K1"
QUIT
+8 IF $PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))]""
Begin DoDot:1
+9 ; -set var IVMFLD to incoming HL7 field
+10 IF 'IVMADFLG
SET IVMFLD=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
+11 ;IVM*2.0*188-convert "" to @
+12 IF IVMFLD=""""""
SET IVMFLD="@"
+13 ; - if HL7 name format convert to FM
+14 IF IVMXREF["ZCT03"
SET IVMFLD=$$FMNAME^HLFNC(IVMFLD)
+15 ;IVM*2.0*188
IF IVMFLD="@,"
SET IVMFLD="@"
+16 ; - ZCT05 as the ZCT address field is 5 ~ pieces
+17 IF IVMXREF["ZCT05"
Begin DoDot:2
+18 SET IVMADDR=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
SET IVMPIECE=$EXTRACT(IVMPIECE,3)
+19 SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
SET IVMADFLG=1
+20 ;IVM*2.0*188-convert "" to @
+21 IF IVMFLD=""""""
SET IVMFLD="@"
QUIT
+22 IF IVMFLD]""
IF IVMPIECE=4
SET IVMFLD=$ORDER(^DIC(5,"C",IVMFLD,0))
+23 IF IVMFLD]""
IF IVMPIECE=5
SET X=IVMFLD
DO ZIPIN^VAFADDR
SET IVMFLD=$GET(X)
End DoDot:2
+24 IF IVMADFLG
DO STORE^IVMPREC9
QUIT
+25 ; - if HL7 dt convert to FM dt
+26 IF IVMXREF["ZCT10"
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+27 ; - execute code on the 1 node and get DHCP field
+28 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+29 ;IVM*2.0*188-convert "" to @
+30 IF IVMFLD=""""""
SET IVMFLD="@"
+31 ; if field from IVM <> DHCP-store for upload
+32 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
+33 IF IVMXREF["ZCT10"
Begin DoDot:2
+34 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
SET UPDAUPG(ZCTTYP)=1
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
ZEM ; - compare ZEM with DHCP
+1 SET IVMADFLG=0
+2 SET IVMPIECE=$EXTRACT(IVMXREF,4,7)
+3 SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
+4 if $PIECE(IVMSEG,HLFS,2)'=$SELECT($EXTRACT(IVMXREF,$LENGTH(IVMXREF))="S"
QUIT
+5 IF $PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))]""
Begin DoDot:1
+6 ; - set var IVMFLD to incoming HL7 field
+7 IF 'IVMADFLG
SET IVMFLD=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
+8 ; - ZEM06 as the ZEM addr containing 5 ~ pieces
+9 IF IVMXREF["ZEM06"
Begin DoDot:2
+10 SET IVMADDR=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
SET IVMPIECE=$EXTRACT(IVMPIECE,3)
+11 ;,IVMADFLG=1
SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
+12 IF IVMFLD]""
IF IVMPIECE=4
SET IVMFLD=$ORDER(^DIC(5,"C",IVMFLD,0))
+13 IF IVMFLD]""
IF IVMPIECE=5
SET X=IVMFLD
DO ZIPIN^VAFADDR
SET IVMFLD=$GET(X)
End DoDot:2
+14 ; - if HL7 dt convert to FM dt
+15 IF IVMXREF["ZEM09"
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+16 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+17 IF $EXTRACT(IVMXREF,1,6)="ZEM062"
IF IVMFLD'=IVMDHCP
SET ZEMADRUP(IVMXREF)=1
DO STORE^IVMPREC9
QUIT
+18 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:1
+19 QUIT
+20 ;
RF1 ; -compare RF1 with DHCP
+1 SET IVMPIECE=$EXTRACT(IVMXREF,4)
SET IVMADFLG=1
SET RF1TYPE=$PIECE(IVMSEG,HLFS,3)
+2 ;Delete the comm data (Email, Cell and Pager) if not in Z05.
+3 ;Remove from EPCDEL if Data exist in Z05. Comm. fields in EPCDEL deleted after updating all incoming data.
+4 ;IVM*2.0*164-Don't Kill if PHH
+5 IF RF1TYPE'="PHH"
KILL EPCDEL(RF1TYPE)
+6 ;if RF1 field is SEQ6, then parse subcomponents
+7 IF RF1TYPE="SAD"
IF ((IVMXREF="RF161")!(IVMXREF="RF162")!(IVMXREF="RF171"))
DO RF1PROC
+8 ;IVM*2.0*164-Uncomment Conf and Add Res
+9 IF RF1TYPE="CAD"
IF ((IVMXREF="RF161CA")!(IVMXREF="RF162CA")!(IVMXREF="RF171CA"))
DO RF1PROC
+10 IF RF1TYPE="RAD"
IF ((IVMXREF="RF161RA")!(IVMXREF="RF162RA")!(IVMXREF="RF171RA"))
DO RF1PROC
+11 ;
+12 IF RF1TYPE="CPH"
IF ((IVMXREF="RF161C")!(IVMXREF="RF162C")!(IVMXREF="RF171C"))
DO RF1PROC
+13 IF RF1TYPE="PNO"
IF ((IVMXREF="RF161B")!(IVMXREF="RF162B")!(IVMXREF="RF171B"))
DO RF1PROC
+14 IF RF1TYPE="EAD"
IF ((IVMXREF="RF161E")!(IVMXREF="RF162E")!(IVMXREF="RF171E"))
DO RF1PROC
+15 ;IVM*2*152
IF RF1TYPE="PHH"
IF ((IVMXREF="RF161P")!(IVMXREF="RF162P")!(IVMXREF="RF171P"))
DO RF1PROC
+16 ;IVM*2.0*214 - PHONE NUMBER [WORK] Change Date/Time
+17 IF RF1TYPE="PHW"
IF (IVMXREF="RF171PW")
DO RF1PROC
+18 ;IVM*2.0*164-LAST RF1 change
+19 ;Last RF1
IF '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA)
IF IVMXREF="RF171RA"
Begin DoDot:1
+20 IF $$AUTOEPC^IVMPREC9(DFN,.UPDEPC)
+21 ;IVM*2*152
NEW NOUPDT,NOPHUP
SET (NOUPDT,NOPHUP)=0
+22 IF 'UPDEPC("SAD")
SET NOUPDT=1
+23 ;Always keep NOPHUP=0 so Home ph is not handled here
+24 KILL UPPHN
+25 IF $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT,NOPHUP)
End DoDot:1
+26 QUIT
+27 ;
RF1PROC ;
+1 NEW IVMEPC
+2 IF $PIECE(IVMSEG,HLFS,IVMPIECE)]""
Begin DoDot:1
+3 ;if RF1 field is SEQ6, parse subcomponents
+4 IF IVMXREF["RF16"
Begin DoDot:2
+5 ;- get data containing 4 ~ pieces
+6 SET IVMRFDAT=$PIECE(IVMSEG,HLFS,6)
+7 SET IVMPIECE=$EXTRACT(IVMXREF,5)
SET IVMFLD=$PIECE(IVMRFDAT,"~",IVMPIECE)
+8 ;KUM-164-SET IVMEPC TO NONBLANK
+9 ;S IVMEPC=$E(IVMXREF,6)
+10 SET IVMEPC=""
+11 IF (IVMXREF="RF162E")!(IVMXREF="RF162C")!(IVMXREF="RF162B")!(IVMXREF="RF162P")
SET IVMEPC="2"
+12 IF IVMPIECE=2
SET IVMFLD=$SELECT(IVMEPC'="":$$EPCSRCC(IVMFLD),1:$$ADDRCNV(IVMFLD))
+13 if IVMFLD=""
QUIT
+14 DO STORE^IVMPREC9
End DoDot:2
QUIT
+15 IF IVMXREF["RF17"
Begin DoDot:2
+16 ;get address/telecomm change date/tm field
+17 SET IVMFLD=$$FMDATE^HLFNC($PIECE(IVMSEG,HLFS,7))
+18 if IVMFLD=""
QUIT
+19 ;IVM*2*171 - If RF1 type is PHH,home ph is null in PID (IVMPHDFG)
+20 ;deletion IF incoming num change dt/tm is > change dt/tm in #2 rec
+21 if $PIECE($GET(TELECOM("PRN")),"~",1)=""
SET IVMPHDFG=1
+22 IF RF1TYPE="PHH"
IF +IVMPHDFG
IF +$$GET1^DIQ(2,DFN_",",.1321,"I")
Begin DoDot:3
+23 if +$$GET1^DIQ(2,DFN_",",.1321,"I")<IVMFLD
SET EPCDEL("PHH")=".131^.1321^.1322^.1323"
End DoDot:3
+24 DO STORE^IVMPREC9
+25 ;164-Uncomment Conf and Add Res
+26 IF RF1TYPE="CAD"
IF $PIECE($GET(ADDRESS("CA")),HLFS)]""
Begin DoDot:3
+27 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+28 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
SET UPDAUPG("CA")=1
End DoDot:3
QUIT
+29 IF RF1TYPE="RAD"
IF $PIECE($GET(ADDRESS("R")),HLFS)]""
Begin DoDot:3
+30 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+31 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
SET UPDAUPG("RA")=1
End DoDot:3
QUIT
+32 ; check for auto-upload
+33 SET IVMDHCP=$SELECT(RF1TYPE="SAD":$PIECE($GET(^DPT(DFN,.11)),HLFS,13),RF1TYPE="CPH":$PIECE($GET(^DPT(DFN,.13)),HLFS,9),RF1TYPE="PNO":$PIECE($GET(^DPT(DFN,.13)),HLFS,12),RF1TYPE="EAD":$PIECE($GET(^DPT(DFN,.13)),HLFS,6),1:"")
+34 ;IVM*2.0*214 - Get PHONE NUMBER [WORK] from #2
+35 IF IVMDHCP=""
SET IVMDHCP=$SELECT(RF1TYPE="PHH":$PIECE($GET(^DPT(DFN,.132)),HLFS,1),RF1TYPE="PHW":$PIECE($GET(^DPT(DFN,.132)),HLFS,6),RF1TYPE="RAD":$PIECE($GET(^DPT(DFN,.115)),HLFS,11),1:"")
+36 ;IVM*2.0*215-If Last update is MPI, Accept
+37 IF IVMFLD]""
IF ($$GET1^DIQ(2,DFN_",",.1324,"E")["PSUSER,APPLICATION PROXY")
IF RF1TYPE="PHH"
SET UPDEPC(RF1TYPE)=$GET(EPCFARY(RF1TYPE))
+38 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
Begin DoDot:3
+39 SET UPDEPC(RF1TYPE)=$GET(EPCFARY(RF1TYPE))
+40 IF RF1TYPE="SAD"
SET UPDEPC("SAD")=1
+41 ; 167-Make Home ph rec auto-upload to Patient
+42 ;I RF1TYPE="PHH" S UPDEPC("PHH")=1 ;IVM*2*152
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+43 QUIT
ADDRCNV(ADDRSRC) ;convert Addr Source from HL7 to DHCP
+1 ;
+2 if $GET(ADDRSRC)']""
QUIT ""
+3 if ADDRSRC="USVAHEC"
QUIT "HEC"
+4 if ADDRSRC="USVAMC"
QUIT "VAMC"
+5 if ADDRSRC="USVAHBSC"
QUIT "HBSC"
+6 if ADDRSRC="USNCOA"
QUIT "NCOA"
+7 if ADDRSRC="USVABVA"
QUIT "BVA"
+8 if ADDRSRC="USVAINS"
QUIT "VAINS"
+9 if ADDRSRC="USPS"
QUIT "USPS"
+10 if ADDRSRC="LACS"
QUIT "LACS"
+11 if ADDRSRC="USVOA"
QUIT "VOA"
+12 if ADDRSRC="VET360"
QUIT "VET360"
+13 QUIT ""
EPCSRCC(EPCSRC) ;Convert Email, Cell, Pager Change Source from HL7 to DHCP
+1 ;
+2 if $GET(EPCSRC)']""
QUIT ""
+3 if EPCSRC="USVAHEC"
QUIT "HEC"
+4 if EPCSRC="USVAMC"
QUIT "VAMC"
+5 if EPCSRC="USVAHBSC"
QUIT "HBSC"
+6 if EPCSRC="USVOA"
QUIT "VOA"
+7 if EPCSRC="VET360"
QUIT "VET360"
+8 QUIT ""
BAICONV(BAISRC) ;Convert Bad addr source from HL7 to DHCP format
+1 if $GET(BAISRC)']""
QUIT ""
+2 if BAISRC="VAB1"
QUIT 1
+3 if BAISRC="VAB2"
QUIT 2
+4 if BAISRC="VAB3"
QUIT 3
+5 if BAISRC="VAB4"
QUIT 4
+6 QUIT ""
CONVPH(PH) ;remove special chars/spaces from Ph
+1 ;*168 Check format, quit if OK else strip and return if not 10 num
+2 ;Format if 10 numeric.
+3 if PH?1"(".3N.1")".3N.1"-".4N
QUIT PH
+4 SET PH=$TRANSLATE(PH," )(/#\-","")
+5 if PH'?10N
QUIT PH
+6 QUIT "("_$EXTRACT(PH,1,3)_")"_$EXTRACT(PH,4,6)_"-"_$EXTRACT(PH,7,10)
+7 ;
CNTRCONV(COUNTRY) ;Check if valid country
+1 IF COUNTRY=""
QUIT 0
+2 QUIT $ORDER(^HL(779.004,"B",COUNTRY,""))
CHKEMAIL(EMAIL) ;Check for Valid Email
+1 IF $GET(EMAIL)=""
QUIT 0
+2 IF '(EMAIL?1.E1"@"1.E1"."1.E)
QUIT 0
+3 QUIT 1
CONVPHAN(PH) ;Convert Alpha Phone number to Numeric
+1 SET PH=$TRANSLATE(PH," )(/#\-~`!@#$%^&*'|<>?,.+=_abcdefghijklmnopqrstvuwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ","")
+2 QUIT PH
