IVMPREC3 ;ALB/KCL/CKN,TDM,HM - PROCESS INCOMING (Z04 EVENT TYPE) HL7 MESSAGES ;8/15/08 10:21am
;;2.0;INCOME VERIFICATION MATCH;**3,17,34,111,115,172**;21-OCT-94;Build 27
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
; This routine will process batch ORU insurance(event type Z04) HL7
; messages received from the IVM center. Format of batch:
; BHS
; {MSH
; PID
; IN1 could be a continuation of IN1
; ZIV
; }
; BTS
;
EN ; - entry point to process insurance messages
;
N IVMPID,PIDSTR,COMP,CNTR,NOPID,TMPARY,PID3ARY,ICN,DFN,CNTR2,IVMZIV,IVMIDOB ;IVM*2.0*172 HM
F IVMDA=1:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D
.K HLERR
.;
.; - message control id from MSH segment
.S MSGID=$P(IVMSEG,HLFS,10)
.;
.; - get message segments from (#772) file
.S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0)) I $E(IVMSEG,1,3)'="PID" D Q
..S HLERR="Missing PID segment" D ACK^IVMPREC
.S CNTR=1,NOPID=0,PIDSTR(CNTR)=$P(IVMSEG,HLFS,2,999)
.;Handle wrapped PID segment
.F I=1:1 D Q:NOPID
..S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
..I $E(IVMSEG,1,4)="IN1^" S NOPID=1,IVMDA=IVMDA-1 Q
..S CNTR=CNTR+1,PIDSTR(CNTR)=IVMSEG
.D BLDPID^IVMPREC6(.PIDSTR,.IVMPID) ;Create IVMPID subscripted 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^IVMPRECA(IVMPID(CNTR,CNTR2),$E(HLECH))
..I IVMPID(CNTR)=HLQ S IVMPID(CNTR)=""
.M TMPARY(3)=IVMPID(3) D PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
.S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
.K TMPARY,PID3ARY
.I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) S HLERR=ERRMSG D ACK^IVMPREC Q
.S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0)) I $E(IVMSEG,1,3)'="IN1" D Q
..S HLERR="Missing IN1 segment" D ACK^IVMPREC
.S IVMSEG1=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,2,999),HLFS,",5,")
.S $P(IVMSEG1,HLFS,5)=$$CLEARF^IVMPRECA($P(IVMSEG1,HLFS,5),$E(HLECH))
.I $P(IVMSEG1,HLFS,4)']"" D Q
..S HLERR="Missing insurance company name" D ACK^IVMPREC
.I $P(IVMSEG1,HLFS,8)']"",($P(IVMSEG1,HLFS,9)']"") D Q
..S HLERR=$S($P(IVMSEG1,HLFS,7)']"":"Missing group number",1:"Missing group name") D ACK^IVMPREC
.I $P(IVMSEG1,HLFS,17)']"" D Q
..S HLERR="Missing insured's relation to patient" D ACK^IVMPREC
.I $P(IVMSEG1,HLFS,17)'="v",($P(IVMSEG1,HLFS,16)']"") D Q
..S HLERR="Missing name of insured" D ACK^IVMPREC
.I $P(IVMSEG1,HLFS,17)'="v",($P(IVMSEG1,HLFS,18)="") D Q
..S HLERR="Missing Insured's Date of Birth" D ACK^IVMPREC
.; - IVM Insured's Date of Birth IVM*2.0*172 HM
.I $P(IVMSEG1,HLFS,17)'="v",($P(IVMSEG1,HLFS,18)]"") S IVMIDOB=$$FMDATE^HLFNC($P(IVMSEG1,HLFS,18))
.S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0)) I $E(IVMSEG,1,3)'="ZIV",$L(IVMSEG1)'=241 D Q
..S HLERR="Missing ZIV segment" D ACK^IVMPREC
.S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
.I $P(IVMSEG,HLFS,10)']"" D Q
..S HLERR="Missing IVM internal entry number" D ACK^IVMPREC
.I $L(IVMSEG1)=241 D Q:$D(IVMERR)
..K IVMERR
..S IVMSEG3=IVMSEG
..S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$$CLEARF^IVMPRECA($G(^(+IVMDA,0)),HLFS)
..I $E(IVMSEG,1,3)'="ZIV" S HLERR="Missing ZIV segment",IVMERR="" D ACK^IVMPREC
.;S IVMSEG2=$P(IVMSEG,"^",10)
.; - set IVM ZIV segment data IVM*2.0*172 HM
.I $E(IVMSEG,1,3)="ZIV" S IVMZIV=IVMSEG
.;
.; - check for date of death from IVM
.I $P(IVMSEG,"^",13)]"" S $P(IVMSEG,"^",13)=$$FMDATE^HLFNC($P(IVMSEG,"^",13))
.;
.; - ivm ien/fm date of death
.S IVMSEG2=$S($P(IVMSEG,"^",13)']"":$P(IVMSEG,"^",10),1:$P(IVMSEG,"^",10)_"/"_$P(IVMSEG,"^",13))
.S IVMDOD=IVMSEG2
.;
.; - IVM Source of Information IVM*2.0*172 HM
.N IVMSOI
.S IVMSOI=$P(IVMSEG,"^",14)
.I IVMSOI'=3&(IVMSOI'=14) D Q
..S HLERR="Invalid Source of Information code expecting 3 or 14" D ACK^IVMPREC
.;
.; - if no error encountered - store insurance fields in VistA
.I '$D(HLERR) D
..N IVMRTN,IVMDA
..D STORE
;
Q
;
;
STORE ; - store IN1 segment fields in (#301.5) file and in buffer file
; (remove data from 301.5 'ASEG' xref on successful buffer file filing)
;
N IVMI,IVMJ,IVMIN1,IVMADD
S DA(1)=$O(^IVM(301.5,"B",DFN,0)),X=$$IEN^IVMUFNC4("IN1")
I DA(1)']"" S HLERR="patient missing from IVM PATIENT file" D ACK^IVMPREC Q
I X<0 S HLERR="IN1 segment not in HL7 SEGMENT NAME file" D ACK^IVMPREC Q
I $G(^IVM(301.5,DA(1),"IN",0))']"" S ^(0)="^301.501PA^^"
S DIC="^IVM(301.5,"_DA(1)_",""IN"",",DIC(0)="L"
S DIC("DR")=".03///NOW;.07////^S X=IVMSEG2;10////^S X=IVMSEG1",DLAYGO=301.501
S:$D(IVMSEG3) DIC("DR")=".03///NOW;.07////^S X=IVMSEG2;10////^S X=IVMSEG1;11////^S X=IVMSEG3"
K DD,DO D FILE^DICN K DIC,DLAYGO
Q:Y'>0
S IVMI=DA(1),IVMJ=+Y
; Patch IVMB*2*111 automatically files the record into the buffer file
; and removes the notification bulletin to IVM and the segment from
; file 301.501
K DA,X,Y
S IVMIN1=$$GETIN1^IVMLINS1(IVMI,IVMJ),IVMADD=$P(IVMIN1,U,5)
D TRANSFER^IVMLINS3(1),IVMQ^IVMLINS1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMPREC3 5208 printed Sep 23, 2025@19:37:36 Page 2
IVMPREC3 ;ALB/KCL/CKN,TDM,HM - PROCESS INCOMING (Z04 EVENT TYPE) HL7 MESSAGES ;8/15/08 10:21am
+1 ;;2.0;INCOME VERIFICATION MATCH;**3,17,34,111,115,172**;21-OCT-94;Build 27
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
+5 ; This routine will process batch ORU insurance(event type Z04) HL7
+6 ; messages received from the IVM center. Format of batch:
+7 ; BHS
+8 ; {MSH
+9 ; PID
+10 ; IN1 could be a continuation of IN1
+11 ; ZIV
+12 ; }
+13 ; BTS
+14 ;
EN ; - entry point to process insurance messages
+1 ;
+2 ;IVM*2.0*172 HM
NEW IVMPID,PIDSTR,COMP,CNTR,NOPID,TMPARY,PID3ARY,ICN,DFN,CNTR2,IVMZIV,IVMIDOB
+3 FOR IVMDA=1:0
SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
if 'IVMDA
QUIT
SET IVMSEG=$GET(^(IVMDA,0))
IF $EXTRACT(IVMSEG,1,3)="MSH"
Begin DoDot:1
+4 KILL HLERR
+5 ;
+6 ; - message control id from MSH segment
+7 SET MSGID=$PIECE(IVMSEG,HLFS,10)
+8 ;
+9 ; - get message segments from (#772) file
+10 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
SET IVMSEG=$GET(^(+IVMDA,0))
IF $EXTRACT(IVMSEG,1,3)'="PID"
Begin DoDot:2
+11 SET HLERR="Missing PID segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+12 SET CNTR=1
SET NOPID=0
SET PIDSTR(CNTR)=$PIECE(IVMSEG,HLFS,2,999)
+13 ;Handle wrapped PID segment
+14 FOR I=1:1
Begin DoDot:2
+15 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
SET IVMSEG=$GET(^(+IVMDA,0))
+16 IF $EXTRACT(IVMSEG,1,4)="IN1^"
SET NOPID=1
SET IVMDA=IVMDA-1
QUIT
+17 SET CNTR=CNTR+1
SET PIDSTR(CNTR)=IVMSEG
End DoDot:2
if NOPID
QUIT
+18 ;Create IVMPID subscripted by seq #
DO BLDPID^IVMPREC6(.PIDSTR,.IVMPID)
+19 ;convert "" to null for PID segment
+20 SET CNTR=""
FOR
SET CNTR=$ORDER(IVMPID(CNTR))
if CNTR=""
QUIT
Begin DoDot:2
+21 IF $ORDER(IVMPID(CNTR,""))
Begin DoDot:3
+22 SET CNTR2=""
FOR
SET CNTR2=$ORDER(IVMPID(CNTR,CNTR2))
if CNTR2=""
QUIT
Begin DoDot:4
+23 SET IVMPID(CNTR,CNTR2)=$$CLEARF^IVMPRECA(IVMPID(CNTR,CNTR2),$EXTRACT(HLECH))
End DoDot:4
End DoDot:3
QUIT
+24 IF IVMPID(CNTR)=HLQ
SET IVMPID(CNTR)=""
End DoDot:2
+25 MERGE TMPARY(3)=IVMPID(3)
DO PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
+26 SET DFN=$GET(PID3ARY("PI"))
SET ICN=$GET(PID3ARY("NI"))
+27 KILL TMPARY,PID3ARY
+28 IF '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG)
SET HLERR=ERRMSG
DO ACK^IVMPREC
QUIT
+29 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
SET IVMSEG=$GET(^(+IVMDA,0))
IF $EXTRACT(IVMSEG,1,3)'="IN1"
Begin DoDot:2
+30 SET HLERR="Missing IN1 segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+31 SET IVMSEG1=$$CLEARF^IVMPRECA($PIECE(IVMSEG,HLFS,2,999),HLFS,",5,")
+32 SET $PIECE(IVMSEG1,HLFS,5)=$$CLEARF^IVMPRECA($PIECE(IVMSEG1,HLFS,5),$EXTRACT(HLECH))
+33 IF $PIECE(IVMSEG1,HLFS,4)']""
Begin DoDot:2
+34 SET HLERR="Missing insurance company name"
DO ACK^IVMPREC
End DoDot:2
QUIT
+35 IF $PIECE(IVMSEG1,HLFS,8)']""
IF ($PIECE(IVMSEG1,HLFS,9)']"")
Begin DoDot:2
+36 SET HLERR=$SELECT($PIECE(IVMSEG1,HLFS,7)']"":"Missing group number",1:"Missing group name")
DO ACK^IVMPREC
End DoDot:2
QUIT
+37 IF $PIECE(IVMSEG1,HLFS,17)']""
Begin DoDot:2
+38 SET HLERR="Missing insured's relation to patient"
DO ACK^IVMPREC
End DoDot:2
QUIT
+39 IF $PIECE(IVMSEG1,HLFS,17)'="v"
IF ($PIECE(IVMSEG1,HLFS,16)']"")
Begin DoDot:2
+40 SET HLERR="Missing name of insured"
DO ACK^IVMPREC
End DoDot:2
QUIT
+41 IF $PIECE(IVMSEG1,HLFS,17)'="v"
IF ($PIECE(IVMSEG1,HLFS,18)="")
Begin DoDot:2
+42 SET HLERR="Missing Insured's Date of Birth"
DO ACK^IVMPREC
End DoDot:2
QUIT
+43 ; - IVM Insured's Date of Birth IVM*2.0*172 HM
+44 IF $PIECE(IVMSEG1,HLFS,17)'="v"
IF ($PIECE(IVMSEG1,HLFS,18)]"")
SET IVMIDOB=$$FMDATE^HLFNC($PIECE(IVMSEG1,HLFS,18))
+45 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
SET IVMSEG=$GET(^(+IVMDA,0))
IF $EXTRACT(IVMSEG,1,3)'="ZIV"
IF $LENGTH(IVMSEG1)'=241
Begin DoDot:2
+46 SET HLERR="Missing ZIV segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+47 SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
+48 IF $PIECE(IVMSEG,HLFS,10)']""
Begin DoDot:2
+49 SET HLERR="Missing IVM internal entry number"
DO ACK^IVMPREC
End DoDot:2
QUIT
+50 IF $LENGTH(IVMSEG1)=241
Begin DoDot:2
+51 KILL IVMERR
+52 SET IVMSEG3=IVMSEG
+53 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
SET IVMSEG=$$CLEARF^IVMPRECA($GET(^(+IVMDA,0)),HLFS)
+54 IF $EXTRACT(IVMSEG,1,3)'="ZIV"
SET HLERR="Missing ZIV segment"
SET IVMERR=""
DO ACK^IVMPREC
End DoDot:2
if $DATA(IVMERR)
QUIT
+55 ;S IVMSEG2=$P(IVMSEG,"^",10)
+56 ; - set IVM ZIV segment data IVM*2.0*172 HM
+57 IF $EXTRACT(IVMSEG,1,3)="ZIV"
SET IVMZIV=IVMSEG
+58 ;
+59 ; - check for date of death from IVM
+60 IF $PIECE(IVMSEG,"^",13)]""
SET $PIECE(IVMSEG,"^",13)=$$FMDATE^HLFNC($PIECE(IVMSEG,"^",13))
+61 ;
+62 ; - ivm ien/fm date of death
+63 SET IVMSEG2=$SELECT($PIECE(IVMSEG,"^",13)']"":$PIECE(IVMSEG,"^",10),1:$PIECE(IVMSEG,"^",10)_"/"_$PIECE(IVMSEG,"^",13))
+64 SET IVMDOD=IVMSEG2
+65 ;
+66 ; - IVM Source of Information IVM*2.0*172 HM
+67 NEW IVMSOI
+68 SET IVMSOI=$PIECE(IVMSEG,"^",14)
+69 IF IVMSOI'=3&(IVMSOI'=14)
Begin DoDot:2
+70 SET HLERR="Invalid Source of Information code expecting 3 or 14"
DO ACK^IVMPREC
End DoDot:2
QUIT
+71 ;
+72 ; - if no error encountered - store insurance fields in VistA
+73 IF '$DATA(HLERR)
Begin DoDot:2
+74 NEW IVMRTN,IVMDA
+75 DO STORE
End DoDot:2
End DoDot:1
+76 ;
+77 QUIT
+78 ;
+79 ;
STORE ; - store IN1 segment fields in (#301.5) file and in buffer file
+1 ; (remove data from 301.5 'ASEG' xref on successful buffer file filing)
+2 ;
+3 NEW IVMI,IVMJ,IVMIN1,IVMADD
+4 SET DA(1)=$ORDER(^IVM(301.5,"B",DFN,0))
SET X=$$IEN^IVMUFNC4("IN1")
+5 IF DA(1)']""
SET HLERR="patient missing from IVM PATIENT file"
DO ACK^IVMPREC
QUIT
+6 IF X<0
SET HLERR="IN1 segment not in HL7 SEGMENT NAME file"
DO ACK^IVMPREC
QUIT
+7 IF $GET(^IVM(301.5,DA(1),"IN",0))']""
SET ^(0)="^301.501PA^^"
+8 SET DIC="^IVM(301.5,"_DA(1)_",""IN"","
SET DIC(0)="L"
+9 SET DIC("DR")=".03///NOW;.07////^S X=IVMSEG2;10////^S X=IVMSEG1"
SET DLAYGO=301.501
+10 if $DATA(IVMSEG3)
SET DIC("DR")=".03///NOW;.07////^S X=IVMSEG2;10////^S X=IVMSEG1;11////^S X=IVMSEG3"
+11 KILL DD,DO
DO FILE^DICN
KILL DIC,DLAYGO
+12 if Y'>0
QUIT
+13 SET IVMI=DA(1)
SET IVMJ=+Y
+14 ; Patch IVMB*2*111 automatically files the record into the buffer file
+15 ; and removes the notification bulletin to IVM and the segment from
+16 ; file 301.501
+17 KILL DA,X,Y
+18 SET IVMIN1=$$GETIN1^IVMLINS1(IVMI,IVMJ)
SET IVMADD=$PIECE(IVMIN1,U,5)
+19 DO TRANSFER^IVMLINS3(1)
DO IVMQ^IVMLINS1
+20 QUIT
+21 ;
