IVMPREC8 ;ALB/KCL,BRM,PJR,CKN,TDM,PWC,LBD,DPR,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;02 SEPT 2019 8:56 AM
;;2.0;INCOME VERIFICATION MATCH;**5,6,12,58,73,79,102,115,121,148,151,152,168,167,171,164,188,187,210**;21-OCT-94;Build 13
;Per VA Directive 6402, this routine should not be modified.
;
; This routine will process (event type Z05) HL7 messages
;
PID ;-compare PID fields with DHCP fields
N COMPPH1,COMPPH2,COUNTRY
;
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=""
..;
..;-Process Place of Birth City&State
..;I (IVMXREF="PID113N")!(IVMXREF="PID114N") D Q
..;.Q:'$D(ADDRESS("N"))
..;.S IVMADDR=ADDRESS("N")
..;.S IVMPIECE=$E(IVMPIECE,3,4),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
..;.I IVMPIECE="4N" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
..; 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 Indicator
..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
..;I 'FORADDR S IVMADFLG=1,IVMFLD=+$O(^DIC(5,IVMPMAST,1,"C",IVMPID(12),0))
..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
...S IVMFLD=$$CONVPH($P($G(TELECOM("VACPN")),$E(HLECH))),IVMADFLG=1
..;Ph Num [Work]
..I IVMXREF="PID13W",$D(TELECOM("WPN")) D
...S IVMFLD=$$CONVPH($P($G(TELECOM("WPN")),$E(HLECH))),IVMADFLG=1
..;Pager Num
..I IVMXREF="PID13B",$D(TELECOM("BPN")) D
...S IVMFLD=$$CONVPH($P($G(TELECOM("BPN")),$E(HLECH))),IVMADFLG=1
..;Cell Ph Num
..I IVMXREF="PID13C",$D(TELECOM("ORN")) D
...S IVMFLD=$$CONVPH($P($G(TELECOM("ORN")),$E(HLECH))),IVMADFLG=1
..;Email Addr
..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 (IVMXREF'="PID113N")&(IVMXREF'="PID114N")&($E(IVMXREF,1,5)'="PID13") S IVMFLD=$G(IVMPID(+IVMPIECE))
.I $E(IVMXREF,1,5)'="PID13" S IVMFLD=$G(IVMPID(+IVMPIECE))
.;
.; -if HL7 date convert to FM date,set IVMFLD
.I IVMXREF["PID07" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
.;
.; - if HL7 code convert to VistA, set IVMFLD
.I IVMXREF["PID16" D ;Marital Status
..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
.;
.; -execute code on the 1 node and get DHCP field for compare
.S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
.;
.; - special logic for ph,if different store value received,quit
.;
.I IVMXREF="PID13",$D(TELECOM("PRN")),'$G(DODSEG) D Q
..S IVMFLD=$P($G(TELECOM("PRN")),$E(HLECH))
..I IVMFLD]"" D
...K UPPHN
...S COMPPH1=$$CONVPH(IVMFLD),COMPPH2=$$CONVPH(IVMDHCP)
...I COMPPH1'=COMPPH2 D STORE^IVMPREC9 S UPPHN=1
.;
.; -if field from IVM does not equal DHCP-store for uploading
.I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
Q
;
ZPD ; -compare ZPD with DHCP
N STFLG
S STFLG=0
S IVMPIECE=$E(IVMXREF,4,5)
I IVMXREF="ZPD09"!(IVMXREF="ZPD31")!(IVMXREF="ZPD32") Q:$$DODCK(DFN)
; 210-Quit if IVM-Language Date/Time is older
I IVMXREF="ZPD46"!(IVMXREF="ZPD47") Q:'$$LANGCK^IVMPREC9(DFN)
;
I $P(IVMSEG,HLFS,IVMPIECE)]"" D
.;
.; - set var to HL7 field
.S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
.;
.; - if HL7 date convert to FM date
.; 210-ADD ZPD47
.I IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32")!(IVMXREF["ZPD47") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
.;
.; 210-call VADPT for DHCP demographics
.D DEM^VADPT
.; - execute code on the 1 node and get DHCP field
.S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
.;
.; - if field from IVM does not equal DHCP field - store for uploading
.I IVMFLD]"",(IVMFLD'=IVMDHCP) S STFLG=1 D STORE^IVMPREC9 Q
.I $P(IVMSEG,"^",IVMPIECE)'="""""" D
..I IVMXREF["ZPD09" D STORE^IVMPREC9
I IVMXREF["ZPD08",STFLG,$$AUTORINC^IVMPREC9(DFN) Q
I IVMXREF["ZPD32",$$AUTODOD^IVMLDEMD(DFN)
; IVM*2.0*210 - Upload Preferred Language and Language Date/Time
I IVMXREF["ZPD47",$$AUTOLANG^IVMPREC9(DFN)
Q
;
DODCK(DFN) ;this will check if Date of Death information needs to be uploaded or not.
;2 requirements are:
; 1. When the DOD is received from ESR with a Source of Death Notification equal to "Death Certificate on file and the
; VistA DOD is null or empty then VistA will upload the Date of Death from ESR
; 2. When DOD is Received from ESR and VistA DOD is already populated then Vista will ignore the DOD from ESR and VistA
; will not create an entry in the IVM demographic upload option.
;
; Inputs: DFN for ^DPT
; IVMXREF (must be ZPD09, ZPD31 and ZPD32)
; IVMSEG (the ZPD data)
; IVMFLD (the field number in ^DPT(DFN)
; IVMPIECE (the piece number of IVMSEG)
; IVMDHCP (the data from ^DPT(DFN)
;
N DODARRAY,QUIT
;
S (CKDEL,QUIT)=0
;
I $P(IVMSEG,"^",9)="""""" Q 0
D GETS^DIQ(2,DFN,".351:.355","","DODARRAY")
S DOD=DODARRAY(2,DFN_",",.351)
I DOD'="" Q 1
I $P(IVMSEG,"^",31)=3,DOD="" S QUIT=0 ;Death Certificate not on File
I $P(IVMSEG,"^",31)=3,DOD'="" S QUIT=1
;
Q QUIT ;
;
ZTA ; -compare ZTA with DHCP
N COMPPH1,COMPPH2,COUNTRY
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 seperated by HLECH (~)
.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=""
.;
.; - if HL7 data convert to Y/N val
.I IVMXREF["ZTA02" S IVMFLD=$S(IVMFLD=0:"N",IVMFLD=1:"Y",1:"")
.;
.; - if HL7 date convert to FM date
.I (IVMXREF["ZTA03")!(IVMXREF["ZTA04")!(IVMXREF["ZTA08") 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
.;
.; -special logic for phone
.; -if different store value received,quit
.I IVMXREF["ZTA07" D Q
..S COMPPH1=$$CONVPH(IVMFLD),COMPPH2=$$CONVPH(IVMDHCP)
..I COMPPH1'=COMPPH2 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
.; Execute 1 node and get DHCP field
.S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
.; field from IVM is not equal DHCP-store
.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 seperated by HLECH (~)
.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 date convert to FM date
.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 does not equal 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 seperated by HLECH (~)
.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 date convert to FM date
.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 does not equal 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 seperated by HLECH (~)
.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 date convert to FM date
.I IVMXREF["ZEM09" 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
.;
.; if field from IVM does not equal DHCP-store for uploading
.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 it is not received in Z05.
;Hence, remove it from EPCDEL if Data exist in Z05. Comm. fields contained in EPCDEL will be deleted after updating all incoming data.
;IVM*2.0*164-Don't Kill if PHH
I RF1TYPE'="PHH" K EPCDEL(RF1TYPE)
;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 ;Added for IVM*2*152
;IVM*2.0*164-LAST RF1 change
;I '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA),IVMXREF="RF171P" D
I '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA),IVMXREF="RF171RA" D ;Last RF1
. I $$AUTOEPC^IVMPREC9(DFN,.UPDEPC)
. N NOUPDT,NOPHUP S (NOUPDT,NOPHUP)=0 ;Added for IVM*2*152
. I 'UPDEPC("SAD") S NOUPDT=1
. ;Set the NOPHUP flag = 1 if Home Ph Change Dt/Tm not more recent, or
. ;if Home Ph Change Dt/Tm more recent, but ph the same
. ;IVM*2*152
. ;IVM*2.0*167-Make Home ph auto-upload
. ;Always keep NOPHUP = 0 so Home ph data is not handled here
. ;I 'UPDEPC("PHH") S NOPHUP=1
. ;I UPDEPC("PHH"),'$G(UPPHN) S NOPHUP=1
. K UPPHN
. I $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT,NOPHUP)
Q
;
RF1PROC ;
N IVMEPC
I $P(IVMSEG,HLFS,IVMPIECE)]"" D
.;if RF1 field is SEQ6, then parse subcomponents
.I IVMXREF["RF16" D Q
..;- get data containing 4 pieces seperated by HLECH (~)
..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"
..;Convert Change Source for Address, Email, Cell and Pager
..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)
..;and RESIDENCE NUMBER CHANGE DT/TM in Patient rec exists then SET EPCDEL(PHH) for ph num
..;deletion IF incoming num change dt/tm is greater than the change dt/tm in Patient rec
..;Check if PID13 home ph is null
..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
...; - execute code on the 1 node and get DHCP field
...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:"")
..I IVMDHCP="" S IVMDHCP=$S(RF1TYPE="PHH":$P($G(^DPT(DFN,.132)),HLFS,1),RF1TYPE="RAD":$P($G(^DPT(DFN,.115)),HLFS,11),1:"") ;Added for IVM*2*152
..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
...; Keep UPDEPC("PHH") value as Home ph record IENs of #301.92
...;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMPREC8 19996 printed Mar 13, 2024@23:10:24 Page 2
IVMPREC8 ;ALB/KCL,BRM,PJR,CKN,TDM,PWC,LBD,DPR,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;02 SEPT 2019 8:56 AM
+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**;21-OCT-94;Build 13
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine will process (event type Z05) HL7 messages
+5 ;
PID ;-compare PID fields with DHCP fields
+1 NEW COMPPH1,COMPPH2,COUNTRY
+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 ;
+9 ; -if PID field is the addr field-parse addr
+10 SET IVMADFLG=0
+11 IF IVMXREF["PID11"
IF '$GET(DODSEG)
Begin DoDot:2
+12 ;
+13 ;-Process Place of Birth City&State
+14 ;I (IVMXREF="PID113N")!(IVMXREF="PID114N") D Q
+15 ;.Q:'$D(ADDRESS("N"))
+16 ;.S IVMADDR=ADDRESS("N")
+17 ;.S IVMPIECE=$E(IVMPIECE,3,4),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
+18 ;.I IVMPIECE="4N" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
+19 ; IVM*2.0*164-Uncomment Conf and Add Res
+20 ;Conf Addr
IF $GET(AUPFARY(IVMDEMDA))="CA"
SET IVMADDR=$GET(ADDRESS("CA"))
+21 IF $GET(AUPFARY(IVMDEMDA))'="CA"
Begin DoDot:3
+22 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:"")
+23 IF $GET(AUPFARY(IVMDEMDA))="RA"
SET IVMADDR=$GET(ADDRESS("R"))
End DoDot:3
+24 IF IVMADDR=""
QUIT
+25 SET COUNTRY=$PIECE(IVMADDR,$EXTRACT(HLECH),6)
+26 SET FORADDR=$SELECT(COUNTRY="USA":0,1:1)
+27 ;-get piece of addr field, and set IVMFLD
+28 SET IVMPIECE=$EXTRACT(IVMPIECE,3,6)
SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
+29 ;Enable del of Addr2,Addr3-164-Fix End dt
+30 IF (IVMPIECE="2C")!(IVMPIECE="8C")!(IVMPIECE="2R")!(IVMPIECE="8R")
if IVMFLD=""
SET IVMFLD="@"
+31 IF $EXTRACT(IVMPIECE,1,3)="13C"
Begin DoDot:3
+32 SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),12)
+33 SET IVMFLD=$$FMDATE^HLFNC($PIECE(IVMFLD,$EXTRACT(HLECH,4),2))
+34 if IVMFLD=""
SET IVMFLD="@"
End DoDot:3
+35 if IVMFLD=""
QUIT
+36 ;convert st abbrev. to pointer
+37 IF (IVMPIECE=4)!(IVMPIECE="4C")!(IVMPIECE="4R")
Begin DoDot:3
+38 SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")
+39 IF IVMFLD'=""
SET (IVMSTPTR,IVMFLD)=+$ORDER(^DIC(5,"C",IVMFLD,0))
+40 ;IVM*2.0*164-PMA State Pointer
+41 IF IVMPIECE=4
SET IVMPMAST=$GET(IVMSTPTR)
+42 IF IVMPIECE="4C"
SET IVMCMAST=$GET(IVMSTPTR)
End DoDot:3
+43 IF (IVMPIECE=5)!(IVMPIECE="5C")!(IVMPIECE="5R")
Begin DoDot:3
+44 SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")
+45 IF IVMFLD'=""
SET X=IVMFLD
DO ZIPIN^VAFADDR
SET IVMFLD=X
End DoDot:3
+46 ;PROVINCE
IF (IVMPIECE="4F")!(IVMPIECE="4CF")!(IVMPIECE="4RF")
SET IVMFLD=$SELECT(FORADDR:IVMFLD,1:"")
+47 ;POSTAL CODE
IF (IVMPIECE="5F")!(IVMPIECE="5CF")!(IVMPIECE="5RF")
SET IVMFLD=$SELECT(FORADDR:IVMFLD,1:"")
+48 ;COUNTRY
IF (IVMPIECE=6)!(IVMPIECE="6C")!(IVMPIECE="6R")
SET IVMFLD=$$CNTRCONV(COUNTRY)
+49 ;Bad Address Indicator
IF IVMPIECE=7
SET IVMFLD=$$BAICONV(IVMFLD)
+50 ;CONFADCT set in PID11^IVMPRECA
IF IVMPIECE="7C"
SET IVMFLD=CONFADCT
+51 ;County for Conf
+52 IF IVMPIECE="9C"
Begin DoDot:3
+53 SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")
if IVMFLD=""
QUIT
+54 IF IVMCMAST'=""
SET IVMFLD=+$ORDER(^DIC(5,IVMCMAST,1,"C",IVMFLD,0))
End DoDot:3
+55 ;County for Res
+56 IF IVMPIECE="9R"
Begin DoDot:3
+57 SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")
if IVMFLD=""
QUIT
+58 IF IVMSTPTR'=""
SET IVMFLD=+$ORDER(^DIC(5,IVMSTPTR,1,"C",IVMFLD,0))
End DoDot:3
+59 IF $EXTRACT(IVMPIECE,1,3)="12C"
Begin DoDot:3
+60 SET IVMFLD=$$FMDATE^HLFNC($PIECE(IVMFLD,$EXTRACT(HLECH,4),1))
+61 ;IVM*2.0*164-Allow del of start dt
+62 if IVMFLD=""
SET IVMFLD="@"
End DoDot:3
+63 SET IVMADFLG=1
End DoDot:2
if IVMFLD=""
QUIT
+64 ;
+65 IF IVMXREF["PID12"
IF '$GET(DODSEG)
Begin DoDot:2
+66 ;IVM*2.0*164-County from PMA St
+67 ;I 'FORADDR S IVMADFLG=1,IVMFLD=+$O(^DIC(5,IVMPMAST,1,"C",IVMPID(12),0))
+68 DO PID12^IVMPREC9
+69 IF 'FORADDR
Begin DoDot:3
+70 SET IVMADFLG=1
+71 IF IVMPMAST'=""
SET IVMFLD=+$ORDER(^DIC(5,IVMPMAST,1,"C",IVMPID(12),0))
End DoDot:3
End DoDot:2
+72 ;line remove so that the ph is compared before saving to 301.5.
+73 IF IVMXREF["PID13"
IF $DATA(TELECOM)
IF '$GET(DODSEG)
Begin DoDot:2
+74 ;Conf Ph
+75 IF IVMXREF="PID13CA"
IF $DATA(TELECOM("VACPN"))
Begin DoDot:3
+76 SET IVMFLD=$$CONVPH($PIECE($GET(TELECOM("VACPN")),$EXTRACT(HLECH)))
SET IVMADFLG=1
End DoDot:3
+77 ;Ph Num [Work]
+78 IF IVMXREF="PID13W"
IF $DATA(TELECOM("WPN"))
Begin DoDot:3
+79 SET IVMFLD=$$CONVPH($PIECE($GET(TELECOM("WPN")),$EXTRACT(HLECH)))
SET IVMADFLG=1
End DoDot:3
+80 ;Pager Num
+81 IF IVMXREF="PID13B"
IF $DATA(TELECOM("BPN"))
Begin DoDot:3
+82 SET IVMFLD=$$CONVPH($PIECE($GET(TELECOM("BPN")),$EXTRACT(HLECH)))
SET IVMADFLG=1
End DoDot:3
+83 ;Cell Ph Num
+84 IF IVMXREF="PID13C"
IF $DATA(TELECOM("ORN"))
Begin DoDot:3
+85 SET IVMFLD=$$CONVPH($PIECE($GET(TELECOM("ORN")),$EXTRACT(HLECH)))
SET IVMADFLG=1
End DoDot:3
+86 ;Email Addr
+87 IF IVMXREF="PID13E"
IF $DATA(TELECOM("NET"))
Begin DoDot:3
+88 SET IVMFLD=$PIECE($GET(TELECOM("NET")),$EXTRACT(HLECH),4)
+89 SET IVMFLD=$SELECT($$CHKEMAIL(IVMFLD):IVMFLD,1:"")
SET IVMADFLG=1
End DoDot:3
End DoDot:2
+90 ; - file addr fields and quit
+91 IF IVMADFLG
DO STORE^IVMPREC9
QUIT
+92 ;
+93 ;I (IVMXREF'="PID113N")&(IVMXREF'="PID114N")&($E(IVMXREF,1,5)'="PID13") S IVMFLD=$G(IVMPID(+IVMPIECE))
+94 IF $EXTRACT(IVMXREF,1,5)'="PID13"
SET IVMFLD=$GET(IVMPID(+IVMPIECE))
+95 ;
+96 ; -if HL7 date convert to FM date,set IVMFLD
+97 IF IVMXREF["PID07"
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+98 ;
+99 ; - if HL7 code convert to VistA, set IVMFLD
+100 ;Marital Status
IF IVMXREF["PID16"
Begin DoDot:2
+101 SET IVMFLD=$SELECT(IVMFLD="D":"DIVORCED",IVMFLD="M":"MARRIED",IVMFLD="W":"WIDOWED",IVMFLD="A":"SEPARATED",IVMFLD="S":"NEVER MARRIED",IVMFLD="U":"UNKNOWN")
+102 SET IVMFLD=$ORDER(^DIC(11,"B",IVMFLD,0))
End DoDot:2
+103 ;
+104 ;Religion
IF IVMXREF["PID17"
SET IVMFLD=$ORDER(^DIC(13,"C",IVMFLD,0))
+105 ;
+106 ;Ethnicity
IF IVMXREF["PID22"
Begin DoDot:2
+107 SET IVMFLD=$$CODE2PTR^DGUTL4($PIECE($GET(IVMPID(22)),$EXTRACT(HLECH),4),2,2)
End DoDot:2
+108 ;
+109 IF IVMXREF="PID10"
IF '$GET(DODSEG)
IF $DATA(IVMRACE)
Begin DoDot:2
+110 NEW XVAL,IVMLST,DHCPLST
+111 SET (XVAL,IVMLST,DHCPLST)=""
+112 FOR
SET XVAL=$ORDER(^DPT(DFN,.02,"B",XVAL))
if XVAL=""
QUIT
SET IVMLST=IVMLST_XVAL_U
+113 SET XVAL=""
FOR
SET XVAL=$ORDER(IVMRACE(2,XVAL))
if XVAL=""
QUIT
SET DHCPLST=DHCPLST_XVAL_U
+114 if IVMLST=DHCPLST
QUIT
+115 FOR XVAL=1:1:($LENGTH(DHCPLST,U)-1)
SET IVMFLD=$PIECE(DHCPLST,U,XVAL)
Begin DoDot:3
+116 DO STORE^IVMPREC9
End DoDot:3
End DoDot:2
QUIT
+117 ;
+118 ; -call VADPT to return DHCP demographics
+119 DO DEM^VADPT
DO ADD^VADPT
DO OPD^VADPT
+120 ;
+121 ; -execute code on the 1 node and get DHCP field for compare
+122 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+123 ;
+124 ; - special logic for ph,if different store value received,quit
+125 ;
+126 IF IVMXREF="PID13"
IF $DATA(TELECOM("PRN"))
IF '$GET(DODSEG)
Begin DoDot:2
+127 SET IVMFLD=$PIECE($GET(TELECOM("PRN")),$EXTRACT(HLECH))
+128 IF IVMFLD]""
Begin DoDot:3
+129 KILL UPPHN
+130 SET COMPPH1=$$CONVPH(IVMFLD)
SET COMPPH2=$$CONVPH(IVMDHCP)
+131 IF COMPPH1'=COMPPH2
DO STORE^IVMPREC9
SET UPPHN=1
End DoDot:3
End DoDot:2
QUIT
+132 ;
+133 ; -if field from IVM does not equal DHCP-store for uploading
+134 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:1
+135 QUIT
+136 ;
ZPD ; -compare ZPD with DHCP
+1 NEW STFLG
+2 SET STFLG=0
+3 SET IVMPIECE=$EXTRACT(IVMXREF,4,5)
+4 IF IVMXREF="ZPD09"!(IVMXREF="ZPD31")!(IVMXREF="ZPD32")
if $$DODCK(DFN)
QUIT
+5 ; 210-Quit if IVM-Language Date/Time is older
+6 IF IVMXREF="ZPD46"!(IVMXREF="ZPD47")
if '$$LANGCK^IVMPREC9(DFN)
QUIT
+7 ;
+8 IF $PIECE(IVMSEG,HLFS,IVMPIECE)]""
Begin DoDot:1
+9 ;
+10 ; - set var to HL7 field
+11 SET IVMFLD=$PIECE(IVMSEG,HLFS,IVMPIECE)
+12 ;
+13 ; - if HL7 date convert to FM date
+14 ; 210-ADD ZPD47
+15 IF IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32")!(IVMXREF["ZPD47")
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+16 ;
+17 ; 210-call VADPT for DHCP demographics
+18 DO DEM^VADPT
+19 ; - execute code on the 1 node and get DHCP field
+20 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+21 ;
+22 ; - if field from IVM does not equal DHCP field - store for uploading
+23 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
SET STFLG=1
DO STORE^IVMPREC9
QUIT
+24 IF $PIECE(IVMSEG,"^",IVMPIECE)'=""""""
Begin DoDot:2
+25 IF IVMXREF["ZPD09"
DO STORE^IVMPREC9
End DoDot:2
End DoDot:1
+26 IF IVMXREF["ZPD08"
IF STFLG
IF $$AUTORINC^IVMPREC9(DFN)
QUIT
+27 IF IVMXREF["ZPD32"
IF $$AUTODOD^IVMLDEMD(DFN)
+28 ; IVM*2.0*210 - Upload Preferred Language and Language Date/Time
+29 IF IVMXREF["ZPD47"
IF $$AUTOLANG^IVMPREC9(DFN)
+30 QUIT
+31 ;
DODCK(DFN) ;this will check if Date of Death information needs to be uploaded or not.
+1 ;2 requirements are:
+2 ; 1. When the DOD is received from ESR with a Source of Death Notification equal to "Death Certificate on file and the
+3 ; VistA DOD is null or empty then VistA will upload the Date of Death from ESR
+4 ; 2. When DOD is Received from ESR and VistA DOD is already populated then Vista will ignore the DOD from ESR and VistA
+5 ; will not create an entry in the IVM demographic upload option.
+6 ;
+7 ; Inputs: DFN for ^DPT
+8 ; IVMXREF (must be ZPD09, ZPD31 and ZPD32)
+9 ; IVMSEG (the ZPD data)
+10 ; IVMFLD (the field number in ^DPT(DFN)
+11 ; IVMPIECE (the piece number of IVMSEG)
+12 ; IVMDHCP (the data from ^DPT(DFN)
+13 ;
+14 NEW DODARRAY,QUIT
+15 ;
+16 SET (CKDEL,QUIT)=0
+17 ;
+18 IF $PIECE(IVMSEG,"^",9)=""""""
QUIT 0
+19 DO GETS^DIQ(2,DFN,".351:.355","","DODARRAY")
+20 SET DOD=DODARRAY(2,DFN_",",.351)
+21 IF DOD'=""
QUIT 1
+22 ;Death Certificate not on File
IF $PIECE(IVMSEG,"^",31)=3
IF DOD=""
SET QUIT=0
+23 IF $PIECE(IVMSEG,"^",31)=3
IF DOD'=""
SET QUIT=1
+24 ;
+25 ;
QUIT QUIT
+26 ;
ZTA ; -compare ZTA with DHCP
+1 NEW COMPPH1,COMPPH2,COUNTRY
+2 SET IVMPIECE=$EXTRACT(IVMXREF,4,7)
+3 IF $PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))]""
Begin DoDot:1
+4 ;
+5 ; - set var IVMFLD to incoming HL7 field
+6 SET IVMFLD=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
+7 ;
+8 ; - ZTA05 as the ZTA addr field is 5 pieces seperated by HLECH (~)
+9 IF IVMXREF["ZTA05"
Begin DoDot:2
+10 SET IVMADDR=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
if IVMADDR=""
QUIT
+11 SET COUNTRY=$PIECE(IVMADDR,$EXTRACT(HLECH),6)
+12 SET FORADDR=$SELECT(COUNTRY="USA":0,1:1)
+13 ; - get piece of address field, and set IVMFLD
+14 SET IVMPIECE=$EXTRACT(IVMPIECE,3,4)
+15 SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
+16 IF (IVMPIECE=2)!(IVMPIECE=8)
if IVMFLD=""
SET IVMFLD="@"
+17 if IVMFLD=""
QUIT
+18 IF (IVMPIECE=4)!(IVMPIECE=5)!(IVMPIECE=9)
SET IVMFLD=$SELECT('FORADDR:IVMFLD,1:"")
if IVMFLD=""
QUIT
+19 IF IVMPIECE=4
SET (IVMTSTPT,IVMFLD)=$ORDER(^DIC(5,"C",IVMFLD,0))
+20 IF IVMPIECE=5
SET X=IVMFLD
DO ZIPIN^VAFADDR
SET IVMFLD=$GET(X)
+21 ;PROVINCE
IF IVMPIECE="4F"
SET IVMFLD=$SELECT(FORADDR:IVMFLD,1:"")
+22 ;POSTAL CODE
IF IVMPIECE="5F"
SET IVMFLD=$SELECT(FORADDR:IVMFLD,1:"")
+23 ;COUNTRY
IF IVMPIECE=6
SET IVMFLD=$$CNTRCONV(COUNTRY)
+24 ;COUNTY
IF IVMPIECE=9
SET IVMFLD=+$ORDER(^DIC(5,+IVMTSTPT,1,"C",IVMFLD,0))
End DoDot:2
+25 if IVMFLD=""
QUIT
+26 ;
+27 ; - if HL7 data convert to Y/N val
+28 IF IVMXREF["ZTA02"
SET IVMFLD=$SELECT(IVMFLD=0:"N",IVMFLD=1:"Y",1:"")
+29 ;
+30 ; - if HL7 date convert to FM date
+31 IF (IVMXREF["ZTA03")!(IVMXREF["ZTA04")!(IVMXREF["ZTA08")
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+32 ;
+33 ; - execute code on the 1 node and get DHCP field
+34 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+35 ;
+36 ; -special logic for phone
+37 ; -if different store value received,quit
+38 IF IVMXREF["ZTA07"
Begin DoDot:2
+39 SET COMPPH1=$$CONVPH(IVMFLD)
SET COMPPH2=$$CONVPH(IVMDHCP)
+40 IF COMPPH1'=COMPPH2
DO STORE^IVMPREC9
End DoDot:2
QUIT
+41 ;
+42 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
+43 ;
+44 IF IVMXREF["ZTA08"
Begin DoDot:2
+45 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
SET UPDAUPG("TA")=1
End DoDot:2
End DoDot:1
+46 QUIT
+47 ;
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 ; Execute 1 node and get DHCP field
+8 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+9 ; field from IVM is not equal DHCP-store
+10 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:1
+11 ;
+12 QUIT
+13 ;
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 ;
+5 ; - set var IVMFLD to incoming HL7
+6 IF 'IVMADFLG
SET IVMFLD=$PIECE(IVMSEG,HLFS,IVMPIECE)
+7 ;
+8 ; - ZGD06 as the ZGD address field is 5 pieces seperated by HLECH (~)
+9 IF IVMXREF["ZGD06"
Begin DoDot:2
+10 SET IVMADDR=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
SET IVMPIECE=$EXTRACT(IVMPIECE,3)
+11 SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
SET IVMADFLG=1
+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 ;
+15 ; - if HL7 date convert to FM date
+16 IF IVMXREF["ZGD08"
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+17 ;
+18 ; - execute code on the 1 node and get DHCP
+19 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+20 ;
+21 ; if field from IVM does not equal DHCP-store for uploading
+22 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:1
+23 QUIT
+24 ;
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 ;
+10 ; -set var IVMFLD to incoming HL7 field
+11 IF 'IVMADFLG
SET IVMFLD=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
+12 ;IVM*2.0*188-convert "" to @
+13 IF IVMFLD=""""""
SET IVMFLD="@"
+14 ;
+15 ; - if HL7 name format convert to FM
+16 IF IVMXREF["ZCT03"
SET IVMFLD=$$FMNAME^HLFNC(IVMFLD)
+17 ;
+18 ;IVM*2.0*188
IF IVMFLD="@,"
SET IVMFLD="@"
+19 ; - ZCT05 as the ZCT address field is 5 pieces seperated by HLECH (~)
+20 IF IVMXREF["ZCT05"
Begin DoDot:2
+21 SET IVMADDR=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
SET IVMPIECE=$EXTRACT(IVMPIECE,3)
+22 SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
SET IVMADFLG=1
+23 ;IVM*2.0*188-convert "" to @
+24 IF IVMFLD=""""""
SET IVMFLD="@"
QUIT
+25 IF IVMFLD]""
IF IVMPIECE=4
SET IVMFLD=$ORDER(^DIC(5,"C",IVMFLD,0))
+26 IF IVMFLD]""
IF IVMPIECE=5
SET X=IVMFLD
DO ZIPIN^VAFADDR
SET IVMFLD=$GET(X)
End DoDot:2
+27 ;
+28 IF IVMADFLG
DO STORE^IVMPREC9
QUIT
+29 ; - if HL7 date convert to FM date
+30 IF IVMXREF["ZCT10"
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+31 ;
+32 ; - execute code on the 1 node and get DHCP field
+33 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+34 ;
+35 ;IVM*2.0*188-convert "" to @
+36 IF IVMFLD=""""""
SET IVMFLD="@"
+37 ;
+38 ; if field from IVM does not equal DHCP-store for upload
+39 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
+40 ;
+41 IF IVMXREF["ZCT10"
Begin DoDot:2
+42 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
SET UPDAUPG(ZCTTYP)=1
End DoDot:2
End DoDot:1
+43 QUIT
+44 ;
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 ;
+7 ; - set var IVMFLD to incoming HL7 field
+8 IF 'IVMADFLG
SET IVMFLD=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
+9 ;
+10 ; - ZEM06 as the ZEM addr containing 5 pieces seperated by HLECH (~)
+11 IF IVMXREF["ZEM06"
Begin DoDot:2
+12 SET IVMADDR=$PIECE(IVMSEG,HLFS,$EXTRACT(IVMPIECE,1,2))
SET IVMPIECE=$EXTRACT(IVMPIECE,3)
+13 ;,IVMADFLG=1
SET IVMFLD=$PIECE(IVMADDR,$EXTRACT(HLECH),IVMPIECE)
+14 IF IVMFLD]""
IF IVMPIECE=4
SET IVMFLD=$ORDER(^DIC(5,"C",IVMFLD,0))
+15 IF IVMFLD]""
IF IVMPIECE=5
SET X=IVMFLD
DO ZIPIN^VAFADDR
SET IVMFLD=$GET(X)
End DoDot:2
+16 ;
+17 ; - if HL7 date convert to FM date
+18 IF IVMXREF["ZEM09"
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+19 ;
+20 ; - execute code on the 1 node and get DHCP field
+21 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+22 ;
+23 ; if field from IVM does not equal DHCP-store for uploading
+24 IF $EXTRACT(IVMXREF,1,6)="ZEM062"
IF IVMFLD'=IVMDHCP
SET ZEMADRUP(IVMXREF)=1
DO STORE^IVMPREC9
QUIT
+25 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
DO STORE^IVMPREC9
End DoDot:1
+26 QUIT
+27 ;
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 it is not received in Z05.
+3 ;Hence, remove it from EPCDEL if Data exist in Z05. Comm. fields contained in EPCDEL will be deleted after updating all incoming data.
+4 ;IVM*2.0*164-Don't Kill if PHH
+5 IF RF1TYPE'="PHH"
KILL EPCDEL(RF1TYPE)
+6 ;K EPCDEL(RF1TYPE)
+7 ;if RF1 field is SEQ6, then parse subcomponents
+8 IF RF1TYPE="SAD"
IF ((IVMXREF="RF161")!(IVMXREF="RF162")!(IVMXREF="RF171"))
DO RF1PROC
+9 ;IVM*2.0*164-Uncomment Conf and Add Res
+10 IF RF1TYPE="CAD"
IF ((IVMXREF="RF161CA")!(IVMXREF="RF162CA")!(IVMXREF="RF171CA"))
DO RF1PROC
+11 IF RF1TYPE="RAD"
IF ((IVMXREF="RF161RA")!(IVMXREF="RF162RA")!(IVMXREF="RF171RA"))
DO RF1PROC
+12 ;
+13 IF RF1TYPE="CPH"
IF ((IVMXREF="RF161C")!(IVMXREF="RF162C")!(IVMXREF="RF171C"))
DO RF1PROC
+14 IF RF1TYPE="PNO"
IF ((IVMXREF="RF161B")!(IVMXREF="RF162B")!(IVMXREF="RF171B"))
DO RF1PROC
+15 IF RF1TYPE="EAD"
IF ((IVMXREF="RF161E")!(IVMXREF="RF162E")!(IVMXREF="RF171E"))
DO RF1PROC
+16 ;Added for IVM*2*152
IF RF1TYPE="PHH"
IF ((IVMXREF="RF161P")!(IVMXREF="RF162P")!(IVMXREF="RF171P"))
DO RF1PROC
+17 ;IVM*2.0*164-LAST RF1 change
+18 ;I '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA),IVMXREF="RF171P" D
+19 ;Last RF1
IF '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA)
IF IVMXREF="RF171RA"
Begin DoDot:1
+20 IF $$AUTOEPC^IVMPREC9(DFN,.UPDEPC)
+21 ;Added for IVM*2*152
NEW NOUPDT,NOPHUP
SET (NOUPDT,NOPHUP)=0
+22 IF 'UPDEPC("SAD")
SET NOUPDT=1
+23 ;Set the NOPHUP flag = 1 if Home Ph Change Dt/Tm not more recent, or
+24 ;if Home Ph Change Dt/Tm more recent, but ph the same
+25 ;IVM*2*152
+26 ;IVM*2.0*167-Make Home ph auto-upload
+27 ;Always keep NOPHUP = 0 so Home ph data is not handled here
+28 ;I 'UPDEPC("PHH") S NOPHUP=1
+29 ;I UPDEPC("PHH"),'$G(UPPHN) S NOPHUP=1
+30 KILL UPPHN
+31 IF $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT,NOPHUP)
End DoDot:1
+32 QUIT
+33 ;
RF1PROC ;
+1 NEW IVMEPC
+2 IF $PIECE(IVMSEG,HLFS,IVMPIECE)]""
Begin DoDot:1
+3 ;if RF1 field is SEQ6, then parse subcomponents
+4 IF IVMXREF["RF16"
Begin DoDot:2
+5 ;- get data containing 4 pieces seperated by HLECH (~)
+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 ;Convert Change Source for Address, Email, Cell and Pager
+13 IF IVMPIECE=2
SET IVMFLD=$SELECT(IVMEPC'="":$$EPCSRCC(IVMFLD),1:$$ADDRCNV(IVMFLD))
+14 if IVMFLD=""
QUIT
+15 DO STORE^IVMPREC9
End DoDot:2
QUIT
+16 IF IVMXREF["RF17"
Begin DoDot:2
+17 ;get address/telecomm change date/tm field
+18 SET IVMFLD=$$FMDATE^HLFNC($PIECE(IVMSEG,HLFS,7))
+19 if IVMFLD=""
QUIT
+20 ;
+21 ;IVM*2*171 - If RF1 type is PHH,home ph is null in PID (IVMPHDFG)
+22 ;and RESIDENCE NUMBER CHANGE DT/TM in Patient rec exists then SET EPCDEL(PHH) for ph num
+23 ;deletion IF incoming num change dt/tm is greater than the change dt/tm in Patient rec
+24 ;Check if PID13 home ph is null
+25 if $PIECE($GET(TELECOM("PRN")),"~",1)=""
SET IVMPHDFG=1
+26 IF RF1TYPE="PHH"
IF +IVMPHDFG
IF +$$GET1^DIQ(2,DFN_",",.1321,"I")
Begin DoDot:3
+27 if +$$GET1^DIQ(2,DFN_",",.1321,"I")<IVMFLD
SET EPCDEL("PHH")=".131^.1321^.1322^.1323"
End DoDot:3
+28 DO STORE^IVMPREC9
+29 ;
+30 ;164-Uncomment Conf and Add Res
+31 IF RF1TYPE="CAD"
IF $PIECE($GET(ADDRESS("CA")),HLFS)]""
Begin DoDot:3
+32 ; - execute code on the 1 node and get DHCP field
+33 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+34 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
SET UPDAUPG("CA")=1
End DoDot:3
QUIT
+35 ;
+36 IF RF1TYPE="RAD"
IF $PIECE($GET(ADDRESS("R")),HLFS)]""
Begin DoDot:3
+37 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+38 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
SET UPDAUPG("RA")=1
End DoDot:3
QUIT
+39 ;
+40 ; check for auto-upload
+41 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:"")
+42 ;Added for IVM*2*152
IF IVMDHCP=""
SET IVMDHCP=$SELECT(RF1TYPE="PHH":$PIECE($GET(^DPT(DFN,.132)),HLFS,1),RF1TYPE="RAD":$PIECE($GET(^DPT(DFN,.115)),HLFS,11),1:"")
+43 IF IVMFLD]""
IF (IVMFLD>IVMDHCP)
Begin DoDot:3
+44 SET UPDEPC(RF1TYPE)=$GET(EPCFARY(RF1TYPE))
+45 IF RF1TYPE="SAD"
SET UPDEPC("SAD")=1
+46 ; 167-Make Home ph rec auto-upload to Patient
+47 ; Keep UPDEPC("PHH") value as Home ph record IENs of #301.92
+48 ;I RF1TYPE="PHH" S UPDEPC("PHH")=1 ;IVM*2*152
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+49 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