IVMPRECA.m

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 ---IVMPRECA   14486     printed  Mar 13, 2025@21:06:25                                                                                                                                                                                                   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