IVMPRECA ;ALB/KCL,BRM,PJR,RGL,CKN,TDM,KUM - DEMOGRAPHICS MESSAGE CONSISTENCY CHECK ;7/06/24 11:16AM
;;2.0;INCOME VERIFICATION MATCH;**5,6,12,34,58,56,115,144,121,151,145,164,210,215**;21-OCT-94;Build 14
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; This routine will perform data validation checks on uploadable
; demographic fields received from the IVM Center to ensure they
; are accurate prior to their upload into DHCP.
;
;
; Called from routine IVMPREC6 before uploadable demographic fields
; are stored in DHCP.
;
;ICRs
; Reference to NAME,^DI(.85 in ICR #6062
;
EN ; - Entry point to create temp array and perform msg consistency checks
;
N DFN,IVMCNTY,IVMCR,IVMEG,IVMFLAG,IVMFLD,IVMNUM,IVMSTR,IVMSTPTR,X,IVMSEG
N COMP,CNTR,NOPID,ADDRTYPE,ADDSEQ,TELESEQ,COMMTYPE,TCFLG,TMPARRY,PID3ARRY,CNTR2
N MULTDONE
K IVMRACE
S IVMNUM=IVMDA ; 'current' line in ^HL(772,"IN",...
S DODSEG=0 ;Initialize flag for DOD information
S GUARSEG=0 ;Initialize flag for Guardian information
;
; - check the format of the HL7 demographic message
D NEXT I $E(IVMSTR,1,3)'="PID" S HLERR="Missing PID segment" G ENQ
S CNTR=1,NOPID=0,PIDSTR(CNTR)=$P(IVMSTR,HLFS,2,999)
;Handle wrapped PID segment
F I=1:1 D Q:NOPID
. D NEXT I $E(IVMSTR,1,4)="ZPD^" S NOPID=1 Q
. S CNTR=CNTR+1,PIDSTR(CNTR)=IVMSTR
D BLDPID^IVMPREC6(.PIDSTR,.IVMPID) ;Create IVMPID subscript by seq #
;convert "" to null for PID segment
S CNTR="" F S CNTR=$O(IVMPID(CNTR)) Q:CNTR="" D
. I $O(IVMPID(CNTR,"")) D Q
. . S CNTR2="" F S CNTR2=$O(IVMPID(CNTR,CNTR2)) Q:CNTR2="" D
. . . S IVMPID(CNTR,CNTR2)=$$CLEARF(IVMPID(CNTR,CNTR2),$E(HLECH))
. I CNTR=11 S IVMPID(CNTR)=$$CLEARF(IVMPID(CNTR),$E(HLECH)) Q
. I IVMPID(CNTR)=HLQ S IVMPID(CNTR)=""
I $E(IVMSTR,1,3)'="ZPD" S HLERR="Missing ZPD segment" G ENQ
S IVMSTR("ZPD")=$P(IVMSTR,HLFS,2,999)
I $P(IVMSTR("ZPD"),HLFS,8)'="" S GUARSEG=1
I $P(IVMSTR("ZPD"),HLFS,9)'="" S DODSEG=1
D NEXT I $E(IVMSTR,1,3)="ZEL" S HLERR="ZEL segment should not be sent in Z05 message" G ENQ
;I $E(IVMSTR,1,3)="ZTA" D NEXT ;Skip ZTA -coming later
I $E(IVMSTR,1,3)'="ZTA" S HLERR="Missing ZTA segment" G ENQ
S IVMSTR("ZTA")=$P(IVMSTR,HLFS,2,999)
; IVM*2.0*164 - ADD LOGIC FOR ZAV SEGMENTS
D NEXT
S IVMSEG="" F S IVMSEG=$E(IVMSTR,1,3) Q:IVMSEG="ZGD" D
. D NEXT
;
; D NEXT
I $E(IVMSTR,1,3)'="ZGD" S HLERR="Missing ZGD segment" G ENQ
S IVMSTR("ZGD")=$P(IVMSTR,HLFS,2,999)
;
; - perform field validation checks for PID segment
M TMPARRY(3)=IVMPID(3) D PARSPID3^IVMUFNC(.TMPARRY,.PID3ARY)
S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
K TMPARRY,PID3ARY
I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) S HLERR=ERRMSG G ENQ
S IVMDFN=DFN ;Store DFN in temp variable to use later
;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVM SSN with DHCP SSN" G ENQ
;
S X=IVMPID(7) I X]"",($$FMDATE^HLFNC(X)>DT) S HLERR="Date of Birth greater than current date" G ENQ
;
S X=IVMPID(8) I X]"",X'="M",X'="F" S HLERR="Invalid code sent for Patient sex" G ENQ
;
; Marital Status
S X=$G(IVMPID(16)) I (X'="")&(X'="D")&(X'="M")&(X'="W")&(X'="U")&(X'="A")&(X'="S") D G ENQ
. S HLERR="Invalid code sent for Patient Marital Status" G ENQ
; Religion
S X=$G(IVMPID(17)) I X'="" S X=$O(^DIC(13,"C",+X,"")) I X="" D G ENQ
. S HLERR="Invalid code sent for Patient Religion"
; Ethnicity
S X=$P($G(IVMPID(22)),$E(HLECH),4) I X]"" S X=$O(^DIC(10.2,"AHL7",X,"")) I X="" D G ENQ
. S HLERR="Invalid code sent for Patient Ethnicity" G ENQ
;
; - if address - perform validation checks on addr fields
;Get all address from seq. 11 of PID segment
I 'DODSEG,'GUARSEG D
. D PID11 Q:$D(HLERR)
. D PID10 Q:$D(HLERR)
. D PID13
G ENQ:$D(HLERR)
;
; - perform field validation check for ZPD and ZGD segment
; - I X]"" was changed to I X below for IVM*2*56
S X=$P(IVMSTR("ZPD"),HLFS,9) I X,($$FMDATE^HLFNC(X)<$P($G(^DPT(+DFN,0)),"^",3))!($$FMDATE^HLFNC(X)>$$NOW^XLFDT) S HLERR="Invalid date of death" G ENQ
; IVM*2.0*210 - Validate Preferred Language
S X=$P(IVMSTR("ZPD"),HLFS,46) I X="""""" S X=""
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I X]"",+X'=888,+X'=999,'$$FIND1^DIC(.85,,"MX",X) S HLERR="Invalid Preferred Language" G ENQ
; IVM*2*121 - Added new check for ZGD
N ZGD3
S ZGD3=$P(IVMSTR("ZGD"),HLFS,3)
S X=$P(IVMSTR("ZGD"),HLFS,2)
I X=HLQ S HLERR="Invalid Guardian Type" G ENQ
I X,X'=1 S HLERR="Invalid Guardian Type" G ENQ
I X=1,((ZGD3=HLQ)!(ZGD3="")) S HLERR="Invalid Guardian Type" G ENQ
;
;
ENQ ; - send acknowledgement (ACK) 'AE' msg to the IVM Center
I $D(HLERR) D ACK^IVMPREC
Q
;
;
ADDRCHK ; - validate address fields sent by IVM Center
N HLERRDEF
;I ADDRTYPE="N" D Q ;Birth City & State
;. I $P(X,$E(HLECH),3)']"" S HLERR="Invalid address - Missing birth city" Q
;. I $P(X,$E(HLECH),4)']"" S HLERR="Invalid address - Missing birth state abbreviation" Q
;. S IVMSTPTR=+$O(^DIC(5,"C",$P(X,$E(HLECH),4),0))
;. I 'IVMSTPTR S HLERR="Invalid birth state abbreviation" Q
;
S HLERRDEF="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"address - "
S CNTRY=$P(X,$E(HLECH),6) I CNTRY']"" S HLERR=HLERRDEF_"Missing Country" Q
I '$$CNTRCONV^IVMPREC8(CNTRY) S HLERR=HLERRDEF_"Invalid Country" Q
S FORFLG=$S(CNTRY="USA":0,1:1)
I $P(X,$E(HLECH),1)']"" S HLERR=HLERRDEF_"Missing street address [line 1]" Q
I $P(X,$E(HLECH),3)']"" S HLERR=HLERRDEF_"Missing city" Q
;I $P(X,$E(HLECH),4)']"" S HLERR=HLERRDEF_"Missing "_$S('FORFLG:"state abbreviation",1:"province") Q
;I $P(X,$E(HLECH),5)']"" S HLERR=HLERRDEF_"Missing "_$S('FORFLG:"zip code",1:"postal code") Q
I $P(X,$E(HLECH),4)']"",'FORFLG S HLERR=HLERRDEF_"Missing State abbreviation" Q
I $P(X,$E(HLECH),5)']"",'FORFLG S HLERR=HLERRDEF_"Missing Zip Code" Q
I 'FORFLG D Q:$D(HLERR)
. S IVMCNTY=$P(X,$E(HLECH),9)
. I IVMCNTY']"" S HLERR=HLERRDEF_"Missing county code" Q
I $L($P(X,$E(HLECH),1))>35!($L($P(X,$E(HLECH),1))<3) S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"street address [line 1]" Q
I $P(X,$E(HLECH),2)]"",(($L($P(X,$E(HLECH),2))>30)!($L($P(X,$E(HLECH),2))<3)) S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"street address [line 2]" Q
I ADDRTYPE'="CA" I $L($P(X,$E(HLECH),3))>15!($L($P(X,$E(HLECH),3))<2) S HLERR="Invalid city" Q
; IVM*2.0*164 - Uncomment below
I ADDRTYPE="CA" I $L($P(X,$E(HLECH),3))>30!($L($P(X,$E(HLECH),3))<2) S HLERR="Invalid Confidential city" Q
;
; - save state pointer for county code validation only if not foreign address
I 'FORFLG D Q:$D(HLERR)
.S IVMSTPTR=+$O(^DIC(5,"C",$P(X,$E(HLECH),4),0))
.I 'IVMSTPTR S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"state abbreviation" Q
.I '$O(^DIC(5,IVMSTPTR,1,"C",IVMCNTY,0)) D Q:$G(HLERR)]""
..N STFIPS
..S STFIPS=IVMSTPTR
..S:$L(STFIPS)<2 STFIPS="0"_STFIPS
..Q:$$FIPSCHK^XIPUTIL(STFIPS_IVMCNTY) ;county code is valid
..S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"county code"
.S X=$P(X,$E(HLECH),5) D ZIPIN^VAFADDR I $D(X)[0 S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"zip code" Q
Q
;
;
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
S IVMNUM=$O(^TMP($J,IVMRTN,IVMNUM)),IVMSTR=$G(^(+IVMNUM,0))
Q
;
PID10 ; Perform consistency checks for seq. 10
; Get all Race data from seq. 10 of PID segment
N RACEVAL,RACEDA,RACEFLG,RACESQ
S RACEFLG=1 ;Flag to check if Race data exist.
I $D(IVMPID(10)) D
. I $O(IVMPID(10,"")) D Q
. . S RACESQ=0 F S RACESQ=$O(IVMPID(10,RACESQ)) Q:((RACESQ="")!($D(HLERR))!('RACEFLG)) D
. . . I $G(IVMPID(10,RACESQ))="" S RACEFLG=0 Q
. . . S RACEVAL=$P($P(IVMPID(10,RACESQ),$E(HLECH),1),"-",1,2)
. . . I RACEVAL="" S HLERR="Missing Race Value - PID Seq 10" Q
. . . S IVMRACE(1,RACEVAL)=IVMPID(10,RACESQ)
. I $G(IVMPID(10))="" S RACEFLG=0 Q
. I $P($P(IVMPID(10),$E(HLECH),1),"-",1,2)="" S HLERR="Missing Race Value - PID Seq 10" Q
. S RACEVAL=$P($P(IVMPID(10),$E(HLECH),1),"-",1,2)
. I RACEVAL="" S HLERR="Missing Race Value - PID Seq 10" Q
. S IVMRACE(1,RACEVAL)=IVMPID(10)
Q:$D(HLERR)
;perform consistency checks on Race
I RACEFLG D
. S RACEVAL="" F S RACEVAL=$O(IVMRACE(1,RACEVAL)) Q:RACEVAL=""!$D(HLERR) D
. . S RACEDA=$$CODE2PTR^DGUTL4(RACEVAL,1,2)
. . I RACEVAL="UNK-SLF" S RACEDA=$$CODE2PTR^DGUTL4("9999-4",1,2)
. . I RACEDA<1 S HLERR="Invalid Race Value - PID Seq 10" Q
. . S IVMRACE(2,RACEDA)=IVMRACE(1,RACEVAL)
Q
;
PID11 ; Perform consistency check for seq. 11
S CONFADCT=""
I $D(IVMPID(11)) D
. I $O(IVMPID(11,"")) D Q
. . S ADDSEQ=0 F S ADDSEQ=$O(IVMPID(11,ADDSEQ)) Q:ADDSEQ=""!($D(HLERR)) D
. . . I $G(IVMPID(11,ADDSEQ))="" S HLERR="Invalid Address - Missing Address information" Q
. . . S ADDRTYPE=$P($G(IVMPID(11,ADDSEQ)),$E(HLECH),7)
. . . I ADDRTYPE="" S HLERR="Invalid Address - Missing Address Type" Q
. . . ; I ADDRTYPE="P"!(ADDRTYPE="VAB1")!(ADDRTYPE="VAB2")!(ADDRTYPE="VAB3")!(ADDRTYPE="VAB4") S ADDRESS(ADDRTYPE)=IVMPID(11,ADDSEQ)
. . . Q:'$D(IVMALADT(ADDRTYPE))
. . . I IVMALADT(ADDRTYPE)="" S ADDRESS(ADDRTYPE)=IVMPID(11,ADDSEQ)
. . . ;IVM*2.0*164 - Uncomment below to enable confidentail address processing
. . . I $P(IVMALADT(ADDRTYPE),"^")="CA" D
. . . . S ADDRESS("CA")=IVMPID(11,ADDSEQ)
. . . . S CONFADCT=$P(IVMALADT(ADDRTYPE),"^",2)
. . . . S CONFADCT(CONFADCT)=""
. I $G(IVMPID(11))="" S HLERR="Invalid Address - Missing Address information" Q
. S ADDRTYPE=$P($G(IVMPID(11)),$E(HLECH),7)
. I ADDRTYPE="" S HLERR="Invalid Address - Missing Address Type" Q
. ; I ADDRTYPE="P"!(ADDRTYPE="VAB1")!(ADDRTYPE="VAB2")!(ADDRTYPE="VAB3")!(ADDRTYPE="VAB4") S ADDRESS(ADDRTYPE)=IVMPID(11)
. Q:'$D(IVMALADT(ADDRTYPE))
. I IVMALADT(ADDRTYPE)="" S ADDRESS(ADDRTYPE)=IVMPID(11)
. I $P(IVMALADT(ADDRTYPE),"^")="CA" D
. . S ADDRESS("CA")=IVMPID(11)
. . S CONFADCT=$P(IVMALADT(ADDRTYPE),"^",2)
. . S CONFADCT(CONFADCT)=""
Q:$D(HLERR)
;perform consistency checks on Permanent and all bad address
I '$D(ADDRESS) S HLERR="Invalid Address - Invalid Address Type" Q
S ADDRTYPE="" F S ADDRTYPE=$O(ADDRESS(ADDRTYPE)) Q:((ADDRTYPE="")!($G(HLERR)'="")) S X=$G(ADDRESS(ADDRTYPE)) D ADDRCHK
Q
;
PID13 ; Perform consistency checks for seq. 13
;Get communication data for all types from seq. 13 or PID segment
S TCFLG=1 ;Flag to check if Telecom data exist.
I $D(IVMPID(13)) D
. I $O(IVMPID(13,"")) D Q
. . S TELESEQ=0 F S TELESEQ=$O(IVMPID(13,TELESEQ)) Q:((TELESEQ="")!($D(HLERR))!('TCFLG)) D
. . . I $G(IVMPID(13,TELESEQ))="" S TCFLG=0 Q
. . . I $P(IVMPID(13,TELESEQ),$E(HLECH),2)="" S HLERR="Invalid Communication Data - Missing Communication Type - PID Seq 13" Q
. . . S TELECOM($P(IVMPID(13,TELESEQ),$E(HLECH),2))=IVMPID(13,TELESEQ)
. I $G(IVMPID(13))="" S TCFLG=0 Q
. I $P(IVMPID(13),$E(HLECH),2)="" S HLERR="Invalid Communication Data - Missing Communication Type - PID Seq 13" Q
. S TELECOM($P(IVMPID(13),$E(HLECH),2))=IVMPID(13)
Q:$D(HLERR)
;perform consistency checks on all types of communication data.
I TCFLG D
. S COMMTYPE="" F S COMMTYPE=$O(TELECOM(COMMTYPE)) Q:COMMTYPE=""!$D(HLERR) D
. . I COMMTYPE="NET" D Q
. . . S X=$P(TELECOM(COMMTYPE),$E(HLECH),4)
. . . I X]"",'$$CHKEMAIL^IVMPREC8(X) S HLERR="Invalid Email address"
. .;IVM*2.0*215 - Remove validation for phone numbers
. .;S X=$P(TELECOM(COMMTYPE),$E(HLECH)) I X]"",(($L(X)>20)!($L(X)<4)) S HLERR="Invalid phone number"
Q
;
CLEARF(NODE,DEL,IGNORE) ;
; Input: NODE - SEGMENT/SEQ.
; DEL - Delimiter (optional - default is ^)
; IGNORE - String of seq # to avoid (optional)
N I
I $G(DEL)="" S DEL=HLFS
F I=1:1:$L(NODE,DEL) D
. I $G(IGNORE)[(","_I_",") Q ;Ignore this seq. to convert
. I $P(NODE,DEL,I)=HLQ S $P(NODE,DEL,I)=""
Q NODE
;
ZPDPA ; compare ZPD with DHCP
; IVM*2.0*215 - Moved ZPD tag from IVMPREC8 and renamed it to ZPDPA tag to fix size error
; ZPD tag in IVMPREC8 now calls ZPDPA
N STFLG
S STFLG=0
S IVMPIECE=$E(IVMXREF,4,5)
I IVMXREF="ZPD09"!(IVMXREF="ZPD31")!(IVMXREF="ZPD32") Q:$$DODCK(DFN)
; IVM*2.0*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
.; IVM*2.0*210-ADD ZPD47
.I IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32")!(IVMXREF["ZPD47") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
.; IVM*2.0*214 - Restore lines mistakenly removed by patch 210 and extract only 4 ~ pieces
.; - if HL7 name format convert to FM
.I IVMXREF["ZPD06"!(IVMXREF["ZPD07") S IVMFLD=$$FMNAME^HLFNC($S($L(IVMFLD,HLECH)>4:$P(IVMFLD,HLECH,1,4),1:IVMFLD))
.;
.; IVM*2.0*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
.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 - Preferred Language and Date/Time
I IVMXREF["ZPD47",$$AUTOLANG^IVMPREC9(DFN)
Q
;
DODCK(DFN) ;this will check if Date of Death needs to be uploaded or not.
; IVM*2.0*215 - Moved DODCK tag from IVMPREC8 to fix size error
;2 reqs 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 ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMPRECA 14486 printed Nov 22, 2024@17:12:30 Page 2
IVMPRECA ;ALB/KCL,BRM,PJR,RGL,CKN,TDM,KUM - DEMOGRAPHICS MESSAGE CONSISTENCY CHECK ;7/06/24 11:16AM
+1 ;;2.0;INCOME VERIFICATION MATCH;**5,6,12,34,58,56,115,144,121,151,145,164,210,215**;21-OCT-94;Build 14
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This routine will perform data validation checks on uploadable
+5 ; demographic fields received from the IVM Center to ensure they
+6 ; are accurate prior to their upload into DHCP.
+7 ;
+8 ;
+9 ; Called from routine IVMPREC6 before uploadable demographic fields
+10 ; are stored in DHCP.
+11 ;
+12 ;ICRs
+13 ; Reference to NAME,^DI(.85 in ICR #6062
+14 ;
EN ; - Entry point to create temp array and perform msg consistency checks
+1 ;
+2 NEW DFN,IVMCNTY,IVMCR,IVMEG,IVMFLAG,IVMFLD,IVMNUM,IVMSTR,IVMSTPTR,X,IVMSEG
+3 NEW COMP,CNTR,NOPID,ADDRTYPE,ADDSEQ,TELESEQ,COMMTYPE,TCFLG,TMPARRY,PID3ARRY,CNTR2
+4 NEW MULTDONE
+5 KILL IVMRACE
+6 ; 'current' line in ^HL(772,"IN",...
SET IVMNUM=IVMDA
+7 ;Initialize flag for DOD information
SET DODSEG=0
+8 ;Initialize flag for Guardian information
SET GUARSEG=0
+9 ;
+10 ; - check the format of the HL7 demographic message
+11 DO NEXT
IF $EXTRACT(IVMSTR,1,3)'="PID"
SET HLERR="Missing PID segment"
GOTO ENQ
+12 SET CNTR=1
SET NOPID=0
SET PIDSTR(CNTR)=$PIECE(IVMSTR,HLFS,2,999)
+13 ;Handle wrapped PID segment
+14 FOR I=1:1
Begin DoDot:1
+15 DO NEXT
IF $EXTRACT(IVMSTR,1,4)="ZPD^"
SET NOPID=1
QUIT
+16 SET CNTR=CNTR+1
SET PIDSTR(CNTR)=IVMSTR
End DoDot:1
if NOPID
QUIT
+17 ;Create IVMPID subscript by seq #
DO BLDPID^IVMPREC6(.PIDSTR,.IVMPID)
+18 ;convert "" to null for PID segment
+19 SET CNTR=""
FOR
SET CNTR=$ORDER(IVMPID(CNTR))
if CNTR=""
QUIT
Begin DoDot:1
+20 IF $ORDER(IVMPID(CNTR,""))
Begin DoDot:2
+21 SET CNTR2=""
FOR
SET CNTR2=$ORDER(IVMPID(CNTR,CNTR2))
if CNTR2=""
QUIT
Begin DoDot:3
+22 SET IVMPID(CNTR,CNTR2)=$$CLEARF(IVMPID(CNTR,CNTR2),$EXTRACT(HLECH))
End DoDot:3
End DoDot:2
QUIT
+23 IF CNTR=11
SET IVMPID(CNTR)=$$CLEARF(IVMPID(CNTR),$EXTRACT(HLECH))
QUIT
+24 IF IVMPID(CNTR)=HLQ
SET IVMPID(CNTR)=""
End DoDot:1
+25 IF $EXTRACT(IVMSTR,1,3)'="ZPD"
SET HLERR="Missing ZPD segment"
GOTO ENQ
+26 SET IVMSTR("ZPD")=$PIECE(IVMSTR,HLFS,2,999)
+27 IF $PIECE(IVMSTR("ZPD"),HLFS,8)'=""
SET GUARSEG=1
+28 IF $PIECE(IVMSTR("ZPD"),HLFS,9)'=""
SET DODSEG=1
+29 DO NEXT
IF $EXTRACT(IVMSTR,1,3)="ZEL"
SET HLERR="ZEL segment should not be sent in Z05 message"
GOTO ENQ
+30 ;I $E(IVMSTR,1,3)="ZTA" D NEXT ;Skip ZTA -coming later
+31 IF $EXTRACT(IVMSTR,1,3)'="ZTA"
SET HLERR="Missing ZTA segment"
GOTO ENQ
+32 SET IVMSTR("ZTA")=$PIECE(IVMSTR,HLFS,2,999)
+33 ; IVM*2.0*164 - ADD LOGIC FOR ZAV SEGMENTS
+34 DO NEXT
+35 SET IVMSEG=""
FOR
SET IVMSEG=$EXTRACT(IVMSTR,1,3)
if IVMSEG="ZGD"
QUIT
Begin DoDot:1
+36 DO NEXT
End DoDot:1
+37 ;
+38 ; D NEXT
+39 IF $EXTRACT(IVMSTR,1,3)'="ZGD"
SET HLERR="Missing ZGD segment"
GOTO ENQ
+40 SET IVMSTR("ZGD")=$PIECE(IVMSTR,HLFS,2,999)
+41 ;
+42 ; - perform field validation checks for PID segment
+43 MERGE TMPARRY(3)=IVMPID(3)
DO PARSPID3^IVMUFNC(.TMPARRY,.PID3ARY)
+44 SET DFN=$GET(PID3ARY("PI"))
SET ICN=$GET(PID3ARY("NI"))
+45 KILL TMPARRY,PID3ARY
+46 IF '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG)
SET HLERR=ERRMSG
GOTO ENQ
+47 ;Store DFN in temp variable to use later
SET IVMDFN=DFN
+48 ;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVM SSN with DHCP SSN" G ENQ
+49 ;
+50 SET X=IVMPID(7)
IF X]""
IF ($$FMDATE^HLFNC(X)>DT)
SET HLERR="Date of Birth greater than current date"
GOTO ENQ
+51 ;
+52 SET X=IVMPID(8)
IF X]""
IF X'="M"
IF X'="F"
SET HLERR="Invalid code sent for Patient sex"
GOTO ENQ
+53 ;
+54 ; Marital Status
+55 SET X=$GET(IVMPID(16))
IF (X'="")&(X'="D")&(X'="M")&(X'="W")&(X'="U")&(X'="A")&(X'="S")
Begin DoDot:1
+56 SET HLERR="Invalid code sent for Patient Marital Status"
GOTO ENQ
End DoDot:1
GOTO ENQ
+57 ; Religion
+58 SET X=$GET(IVMPID(17))
IF X'=""
SET X=$ORDER(^DIC(13,"C",+X,""))
IF X=""
Begin DoDot:1
+59 SET HLERR="Invalid code sent for Patient Religion"
End DoDot:1
GOTO ENQ
+60 ; Ethnicity
+61 SET X=$PIECE($GET(IVMPID(22)),$EXTRACT(HLECH),4)
IF X]""
SET X=$ORDER(^DIC(10.2,"AHL7",X,""))
IF X=""
Begin DoDot:1
+62 SET HLERR="Invalid code sent for Patient Ethnicity"
GOTO ENQ
End DoDot:1
GOTO ENQ
+63 ;
+64 ; - if address - perform validation checks on addr fields
+65 ;Get all address from seq. 11 of PID segment
+66 IF 'DODSEG
IF 'GUARSEG
Begin DoDot:1
+67 DO PID11
if $DATA(HLERR)
QUIT
+68 DO PID10
if $DATA(HLERR)
QUIT
+69 DO PID13
End DoDot:1
+70 if $DATA(HLERR)
GOTO ENQ
+71 ;
+72 ; - perform field validation check for ZPD and ZGD segment
+73 ; - I X]"" was changed to I X below for IVM*2*56
+74 SET X=$PIECE(IVMSTR("ZPD"),HLFS,9)
IF X
IF ($$FMDATE^HLFNC(X)<$PIECE($GET(^DPT(+DFN,0)),"^",3))!($$FMDATE^HLFNC(X)>$$NOW^XLFDT)
SET HLERR="Invalid date of death"
GOTO ENQ
+75 ; IVM*2.0*210 - Validate Preferred Language
+76 SET X=$PIECE(IVMSTR("ZPD"),HLFS,46)
IF X=""""""
SET X=""
+77 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+78 IF X]""
IF +X'=888
IF +X'=999
IF '$$FIND1^DIC(.85,,"MX",X)
SET HLERR="Invalid Preferred Language"
GOTO ENQ
+79 ; IVM*2*121 - Added new check for ZGD
+80 NEW ZGD3
+81 SET ZGD3=$PIECE(IVMSTR("ZGD"),HLFS,3)
+82 SET X=$PIECE(IVMSTR("ZGD"),HLFS,2)
+83 IF X=HLQ
SET HLERR="Invalid Guardian Type"
GOTO ENQ
+84 IF X
IF X'=1
SET HLERR="Invalid Guardian Type"
GOTO ENQ
+85 IF X=1
IF ((ZGD3=HLQ)!(ZGD3=""))
SET HLERR="Invalid Guardian Type"
GOTO ENQ
+86 ;
+87 ;
ENQ ; - send acknowledgement (ACK) 'AE' msg to the IVM Center
+1 IF $DATA(HLERR)
DO ACK^IVMPREC
+2 QUIT
+3 ;
+4 ;
ADDRCHK ; - validate address fields sent by IVM Center
+1 NEW HLERRDEF
+2 ;I ADDRTYPE="N" D Q ;Birth City & State
+3 ;. I $P(X,$E(HLECH),3)']"" S HLERR="Invalid address - Missing birth city" Q
+4 ;. I $P(X,$E(HLECH),4)']"" S HLERR="Invalid address - Missing birth state abbreviation" Q
+5 ;. S IVMSTPTR=+$O(^DIC(5,"C",$P(X,$E(HLECH),4),0))
+6 ;. I 'IVMSTPTR S HLERR="Invalid birth state abbreviation" Q
+7 ;
+8 SET HLERRDEF="Invalid "_$SELECT(ADDRTYPE="CA":"Confidential ",1:"")_"address - "
+9 SET CNTRY=$PIECE(X,$EXTRACT(HLECH),6)
IF CNTRY']""
SET HLERR=HLERRDEF_"Missing Country"
QUIT
+10 IF '$$CNTRCONV^IVMPREC8(CNTRY)
SET HLERR=HLERRDEF_"Invalid Country"
QUIT
+11 SET FORFLG=$SELECT(CNTRY="USA":0,1:1)
+12 IF $PIECE(X,$EXTRACT(HLECH),1)']""
SET HLERR=HLERRDEF_"Missing street address [line 1]"
QUIT
+13 IF $PIECE(X,$EXTRACT(HLECH),3)']""
SET HLERR=HLERRDEF_"Missing city"
QUIT
+14 ;I $P(X,$E(HLECH),4)']"" S HLERR=HLERRDEF_"Missing "_$S('FORFLG:"state abbreviation",1:"province") Q
+15 ;I $P(X,$E(HLECH),5)']"" S HLERR=HLERRDEF_"Missing "_$S('FORFLG:"zip code",1:"postal code") Q
+16 IF $PIECE(X,$EXTRACT(HLECH),4)']""
IF 'FORFLG
SET HLERR=HLERRDEF_"Missing State abbreviation"
QUIT
+17 IF $PIECE(X,$EXTRACT(HLECH),5)']""
IF 'FORFLG
SET HLERR=HLERRDEF_"Missing Zip Code"
QUIT
+18 IF 'FORFLG
Begin DoDot:1
+19 SET IVMCNTY=$PIECE(X,$EXTRACT(HLECH),9)
+20 IF IVMCNTY']""
SET HLERR=HLERRDEF_"Missing county code"
QUIT
End DoDot:1
if $DATA(HLERR)
QUIT
+21 IF $LENGTH($PIECE(X,$EXTRACT(HLECH),1))>35!($LENGTH($PIECE(X,$EXTRACT(HLECH),1))<3)
SET HLERR="Invalid "_$SELECT(ADDRTYPE="CA":"Confidential ",1:"")_"street address [line 1]"
QUIT
+22 IF $PIECE(X,$EXTRACT(HLECH),2)]""
IF (($LENGTH($PIECE(X,$EXTRACT(HLECH),2))>30)!($LENGTH($PIECE(X,$EXTRACT(HLECH),2))<3))
SET HLERR="Invalid "_$SELECT(ADDRTYPE="CA":"Confidential ",1:"")_"street address [line 2]"
QUIT
+23 IF ADDRTYPE'="CA"
IF $LENGTH($PIECE(X,$EXTRACT(HLECH),3))>15!($LENGTH($PIECE(X,$EXTRACT(HLECH),3))<2)
SET HLERR="Invalid city"
QUIT
+24 ; IVM*2.0*164 - Uncomment below
+25 IF ADDRTYPE="CA"
IF $LENGTH($PIECE(X,$EXTRACT(HLECH),3))>30!($LENGTH($PIECE(X,$EXTRACT(HLECH),3))<2)
SET HLERR="Invalid Confidential city"
QUIT
+26 ;
+27 ; - save state pointer for county code validation only if not foreign address
+28 IF 'FORFLG
Begin DoDot:1
+29 SET IVMSTPTR=+$ORDER(^DIC(5,"C",$PIECE(X,$EXTRACT(HLECH),4),0))
+30 IF 'IVMSTPTR
SET HLERR="Invalid "_$SELECT(ADDRTYPE="CA":"Confidential ",1:"")_"state abbreviation"
QUIT
+31 IF '$ORDER(^DIC(5,IVMSTPTR,1,"C",IVMCNTY,0))
Begin DoDot:2
+32 NEW STFIPS
+33 SET STFIPS=IVMSTPTR
+34 if $LENGTH(STFIPS)<2
SET STFIPS="0"_STFIPS
+35 ;county code is valid
if $$FIPSCHK^XIPUTIL(STFIPS_IVMCNTY)
QUIT
+36 SET HLERR="Invalid "_$SELECT(ADDRTYPE="CA":"Confidential ",1:"")_"county code"
End DoDot:2
if $GET(HLERR)]""
QUIT
+37 SET X=$PIECE(X,$EXTRACT(HLECH),5)
DO ZIPIN^VAFADDR
IF $DATA(X)[0
SET HLERR="Invalid "_$SELECT(ADDRTYPE="CA":"Confidential ",1:"")_"zip code"
QUIT
End DoDot:1
if $DATA(HLERR)
QUIT
+38 QUIT
+39 ;
+40 ;
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
+1 SET IVMNUM=$ORDER(^TMP($JOB,IVMRTN,IVMNUM))
SET IVMSTR=$GET(^(+IVMNUM,0))
+2 QUIT
+3 ;
PID10 ; Perform consistency checks for seq. 10
+1 ; Get all Race data from seq. 10 of PID segment
+2 NEW RACEVAL,RACEDA,RACEFLG,RACESQ
+3 ;Flag to check if Race data exist.
SET RACEFLG=1
+4 IF $DATA(IVMPID(10))
Begin DoDot:1
+5 IF $ORDER(IVMPID(10,""))
Begin DoDot:2
+6 SET RACESQ=0
FOR
SET RACESQ=$ORDER(IVMPID(10,RACESQ))
if ((RACESQ="")!($DATA(HLERR))!('RACEFLG))
QUIT
Begin DoDot:3
+7 IF $GET(IVMPID(10,RACESQ))=""
SET RACEFLG=0
QUIT
+8 SET RACEVAL=$PIECE($PIECE(IVMPID(10,RACESQ),$EXTRACT(HLECH),1),"-",1,2)
+9 IF RACEVAL=""
SET HLERR="Missing Race Value - PID Seq 10"
QUIT
+10 SET IVMRACE(1,RACEVAL)=IVMPID(10,RACESQ)
End DoDot:3
End DoDot:2
QUIT
+11 IF $GET(IVMPID(10))=""
SET RACEFLG=0
QUIT
+12 IF $PIECE($PIECE(IVMPID(10),$EXTRACT(HLECH),1),"-",1,2)=""
SET HLERR="Missing Race Value - PID Seq 10"
QUIT
+13 SET RACEVAL=$PIECE($PIECE(IVMPID(10),$EXTRACT(HLECH),1),"-",1,2)
+14 IF RACEVAL=""
SET HLERR="Missing Race Value - PID Seq 10"
QUIT
+15 SET IVMRACE(1,RACEVAL)=IVMPID(10)
End DoDot:1
+16 if $DATA(HLERR)
QUIT
+17 ;perform consistency checks on Race
+18 IF RACEFLG
Begin DoDot:1
+19 SET RACEVAL=""
FOR
SET RACEVAL=$ORDER(IVMRACE(1,RACEVAL))
if RACEVAL=""!$DATA(HLERR)
QUIT
Begin DoDot:2
+20 SET RACEDA=$$CODE2PTR^DGUTL4(RACEVAL,1,2)
+21 IF RACEVAL="UNK-SLF"
SET RACEDA=$$CODE2PTR^DGUTL4("9999-4",1,2)
+22 IF RACEDA<1
SET HLERR="Invalid Race Value - PID Seq 10"
QUIT
+23 SET IVMRACE(2,RACEDA)=IVMRACE(1,RACEVAL)
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
PID11 ; Perform consistency check for seq. 11
+1 SET CONFADCT=""
+2 IF $DATA(IVMPID(11))
Begin DoDot:1
+3 IF $ORDER(IVMPID(11,""))
Begin DoDot:2
+4 SET ADDSEQ=0
FOR
SET ADDSEQ=$ORDER(IVMPID(11,ADDSEQ))
if ADDSEQ=""!($DATA(HLERR))
QUIT
Begin DoDot:3
+5 IF $GET(IVMPID(11,ADDSEQ))=""
SET HLERR="Invalid Address - Missing Address information"
QUIT
+6 SET ADDRTYPE=$PIECE($GET(IVMPID(11,ADDSEQ)),$EXTRACT(HLECH),7)
+7 IF ADDRTYPE=""
SET HLERR="Invalid Address - Missing Address Type"
QUIT
+8 ; I ADDRTYPE="P"!(ADDRTYPE="VAB1")!(ADDRTYPE="VAB2")!(ADDRTYPE="VAB3")!(ADDRTYPE="VAB4") S ADDRESS(ADDRTYPE)=IVMPID(11,ADDSEQ)
+9 if '$DATA(IVMALADT(ADDRTYPE))
QUIT
+10 IF IVMALADT(ADDRTYPE)=""
SET ADDRESS(ADDRTYPE)=IVMPID(11,ADDSEQ)
+11 ;IVM*2.0*164 - Uncomment below to enable confidentail address processing
+12 IF $PIECE(IVMALADT(ADDRTYPE),"^")="CA"
Begin DoDot:4
+13 SET ADDRESS("CA")=IVMPID(11,ADDSEQ)
+14 SET CONFADCT=$PIECE(IVMALADT(ADDRTYPE),"^",2)
+15 SET CONFADCT(CONFADCT)=""
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+16 IF $GET(IVMPID(11))=""
SET HLERR="Invalid Address - Missing Address information"
QUIT
+17 SET ADDRTYPE=$PIECE($GET(IVMPID(11)),$EXTRACT(HLECH),7)
+18 IF ADDRTYPE=""
SET HLERR="Invalid Address - Missing Address Type"
QUIT
+19 ; I ADDRTYPE="P"!(ADDRTYPE="VAB1")!(ADDRTYPE="VAB2")!(ADDRTYPE="VAB3")!(ADDRTYPE="VAB4") S ADDRESS(ADDRTYPE)=IVMPID(11)
+20 if '$DATA(IVMALADT(ADDRTYPE))
QUIT
+21 IF IVMALADT(ADDRTYPE)=""
SET ADDRESS(ADDRTYPE)=IVMPID(11)
+22 IF $PIECE(IVMALADT(ADDRTYPE),"^")="CA"
Begin DoDot:2
+23 SET ADDRESS("CA")=IVMPID(11)
+24 SET CONFADCT=$PIECE(IVMALADT(ADDRTYPE),"^",2)
+25 SET CONFADCT(CONFADCT)=""
End DoDot:2
End DoDot:1
+26 if $DATA(HLERR)
QUIT
+27 ;perform consistency checks on Permanent and all bad address
+28 IF '$DATA(ADDRESS)
SET HLERR="Invalid Address - Invalid Address Type"
QUIT
+29 SET ADDRTYPE=""
FOR
SET ADDRTYPE=$ORDER(ADDRESS(ADDRTYPE))
if ((ADDRTYPE="")!($GET(HLERR)'=""))
QUIT
SET X=$GET(ADDRESS(ADDRTYPE))
DO ADDRCHK
+30 QUIT
+31 ;
PID13 ; Perform consistency checks for seq. 13
+1 ;Get communication data for all types from seq. 13 or PID segment
+2 ;Flag to check if Telecom data exist.
SET TCFLG=1
+3 IF $DATA(IVMPID(13))
Begin DoDot:1
+4 IF $ORDER(IVMPID(13,""))
Begin DoDot:2
+5 SET TELESEQ=0
FOR
SET TELESEQ=$ORDER(IVMPID(13,TELESEQ))
if ((TELESEQ="")!($DATA(HLERR))!('TCFLG))
QUIT
Begin DoDot:3
+6 IF $GET(IVMPID(13,TELESEQ))=""
SET TCFLG=0
QUIT
+7 IF $PIECE(IVMPID(13,TELESEQ),$EXTRACT(HLECH),2)=""
SET HLERR="Invalid Communication Data - Missing Communication Type - PID Seq 13"
QUIT
+8 SET TELECOM($PIECE(IVMPID(13,TELESEQ),$EXTRACT(HLECH),2))=IVMPID(13,TELESEQ)
End DoDot:3
End DoDot:2
QUIT
+9 IF $GET(IVMPID(13))=""
SET TCFLG=0
QUIT
+10 IF $PIECE(IVMPID(13),$EXTRACT(HLECH),2)=""
SET HLERR="Invalid Communication Data - Missing Communication Type - PID Seq 13"
QUIT
+11 SET TELECOM($PIECE(IVMPID(13),$EXTRACT(HLECH),2))=IVMPID(13)
End DoDot:1
+12 if $DATA(HLERR)
QUIT
+13 ;perform consistency checks on all types of communication data.
+14 IF TCFLG
Begin DoDot:1
+15 SET COMMTYPE=""
FOR
SET COMMTYPE=$ORDER(TELECOM(COMMTYPE))
if COMMTYPE=""!$DATA(HLERR)
QUIT
Begin DoDot:2
+16 IF COMMTYPE="NET"
Begin DoDot:3
+17 SET X=$PIECE(TELECOM(COMMTYPE),$EXTRACT(HLECH),4)
+18 IF X]""
IF '$$CHKEMAIL^IVMPREC8(X)
SET HLERR="Invalid Email address"
End DoDot:3
QUIT
+19 ;IVM*2.0*215 - Remove validation for phone numbers
+20 ;S X=$P(TELECOM(COMMTYPE),$E(HLECH)) I X]"",(($L(X)>20)!($L(X)<4)) S HLERR="Invalid phone number"
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
CLEARF(NODE,DEL,IGNORE) ;
+1 ; Input: NODE - SEGMENT/SEQ.
+2 ; DEL - Delimiter (optional - default is ^)
+3 ; IGNORE - String of seq # to avoid (optional)
+4 NEW I
+5 IF $GET(DEL)=""
SET DEL=HLFS
+6 FOR I=1:1:$LENGTH(NODE,DEL)
Begin DoDot:1
+7 ;Ignore this seq. to convert
IF $GET(IGNORE)[(","_I_",")
QUIT
+8 IF $PIECE(NODE,DEL,I)=HLQ
SET $PIECE(NODE,DEL,I)=""
End DoDot:1
+9 QUIT NODE
+10 ;
ZPDPA ; compare ZPD with DHCP
+1 ; IVM*2.0*215 - Moved ZPD tag from IVMPREC8 and renamed it to ZPDPA tag to fix size error
+2 ; ZPD tag in IVMPREC8 now calls ZPDPA
+3 NEW STFLG
+4 SET STFLG=0
+5 SET IVMPIECE=$EXTRACT(IVMXREF,4,5)
+6 IF IVMXREF="ZPD09"!(IVMXREF="ZPD31")!(IVMXREF="ZPD32")
if $$DODCK(DFN)
QUIT
+7 ; IVM*2.0*210-Quit if IVM-Language Date/Time is older
+8 IF IVMXREF="ZPD46"!(IVMXREF="ZPD47")
if '$$LANGCK^IVMPREC9(DFN)
QUIT
+9 ;
+10 IF $PIECE(IVMSEG,HLFS,IVMPIECE)]""
Begin DoDot:1
+11 ; - set var to HL7 field
+12 SET IVMFLD=$PIECE(IVMSEG,HLFS,IVMPIECE)
+13 ; - if HL7 date convert to FM date
+14 ; IVM*2.0*210-ADD ZPD47
+15 IF IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32")!(IVMXREF["ZPD47")
SET IVMFLD=$$FMDATE^HLFNC(IVMFLD)
+16 ; IVM*2.0*214 - Restore lines mistakenly removed by patch 210 and extract only 4 ~ pieces
+17 ; - if HL7 name format convert to FM
+18 IF IVMXREF["ZPD06"!(IVMXREF["ZPD07")
SET IVMFLD=$$FMNAME^HLFNC($SELECT($LENGTH(IVMFLD,HLECH)>4:$PIECE(IVMFLD,HLECH,1,4),1:IVMFLD))
+19 ;
+20 ; IVM*2.0*210-call VADPT for DHCP demographics
+21 DO DEM^VADPT
+22 ; - execute code on the 1 node and get DHCP field
+23 SET IVMDHCP=""
if $DATA(^IVM(301.92,+IVMDEMDA,1))
XECUTE ^(1)
SET IVMDHCP=Y
+24 IF IVMFLD]""
IF (IVMFLD'=IVMDHCP)
SET STFLG=1
DO STORE^IVMPREC9
QUIT
+25 IF $PIECE(IVMSEG,"^",IVMPIECE)'=""""""
Begin DoDot:2
+26 IF IVMXREF["ZPD09"
DO STORE^IVMPREC9
End DoDot:2
End DoDot:1
+27 IF IVMXREF["ZPD08"
IF STFLG
IF $$AUTORINC^IVMPREC9(DFN)
QUIT
+28 IF IVMXREF["ZPD32"
IF $$AUTODOD^IVMLDEMD(DFN)
+29 ; IVM*2.0*210 - Preferred Language and Date/Time
+30 IF IVMXREF["ZPD47"
IF $$AUTOLANG^IVMPREC9(DFN)
+31 QUIT
+32 ;
DODCK(DFN) ;this will check if Date of Death needs to be uploaded or not.
+1 ; IVM*2.0*215 - Moved DODCK tag from IVMPREC8 to fix size error
+2 ;2 reqs are:
+3 ; 1. When the DOD is received from ESR with a Source of Death Notification equal to "Death Certificate on file and the
+4 ; VistA DOD is null or empty then VistA will upload the Date of Death from ESR
+5 ; 2. When DOD is Received from ESR and VistA DOD is already populated then Vista will ignore the DOD from ESR and VistA
+6 ; will not create an entry in the IVM demographic upload option.
+7 ;
+8 ; Inputs: DFN for ^DPT
+9 ; IVMXREF (must be ZPD09, ZPD31 and ZPD32)
+10 ; IVMSEG (the ZPD data)
+11 ; IVMFLD (the field number in ^DPT(DFN)
+12 ; IVMPIECE (the piece number of IVMSEG)
+13 ; IVMDHCP (the data from ^DPT(DFN)
+14 ;
+15 NEW DODARRAY,QUIT
+16 ;
+17 SET (CKDEL,QUIT)=0
+18 ;
+19 IF $PIECE(IVMSEG,"^",9)=""""""
QUIT 0
+20 DO GETS^DIQ(2,DFN,".351:.355","","DODARRAY")
+21 SET DOD=DODARRAY(2,DFN_",",.351)
+22 IF DOD'=""
QUIT 1
+23 ;Death Certificate not on File
IF $PIECE(IVMSEG,"^",31)=3
IF DOD=""
SET QUIT=0
+24 IF $PIECE(IVMSEG,"^",31)=3
IF DOD'=""
SET QUIT=1
+25 ;
+26 ;
QUIT QUIT
+27 ;
