Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IVMPREC7

IVMPREC7.m

Go to the documentation of this file.
  1. IVMPREC7 ;ALB/SEK,RTK - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ; 31 May 94
  1. ;;2.0;INCOME VERIFICATION MATCH;**1,17,44,34,77**;21-OCT-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ; This routine will process (validate) batch ORU Means Test(event type
  1. ; Z06) HL7 messages received from the IVM center. Format of batch:
  1. ; BHS
  1. ; {MSH
  1. ; PID
  1. ; ZIC
  1. ; ZIR
  1. ; {ZDP
  1. ; ZIC
  1. ; ZIR
  1. ; }
  1. ; ZMT
  1. ; }
  1. ; BTS
  1. ;
  1. EN ; entry point to validate Means Test messages
  1. ;
  1. 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 Q:'IVMDA
  1. .K HLERR
  1. EN1 .S HLMID=$P(IVMSEG,HLFS,10) ; message control id from MSH
  1. .S IVMFLGC=0
  1. .D GET I IVMSEG1'="PID" D Q
  1. ..S HLERR="Missing PID segment" D ACK^IVMPREC
  1. .S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
  1. .I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
  1. ..S HLERR="Invalid DFN" D ACK^IVMPREC
  1. .I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVM SSN with DHCP SSN" D ACK^IVMPREC Q
  1. .S IVMDAP=IVMDA ; save IVMDA for veteran PID segment
  1. .;
  1. .; check for veteran's ZIC and ZIR segments
  1. .D GET I IVMSEG1'="ZIC" D Q
  1. ..S HLERR="Missing veteran's ZIC segment" D ACK^IVMPREC
  1. .S IVMDGLY=$P(IVMSEG,"^",3) ; income year
  1. .D GET I IVMSEG1'="ZIR" D Q
  1. ..S HLERR="Missing veteran's ZIR segment" D ACK^IVMPREC
  1. .;
  1. .; check for spouse's ZDP, ZIC, ZIR segments
  1. .D GET I IVMSEG1'="ZDP" D Q
  1. ..S HLERR="Missing spouse's ZDP segment" D ACK^IVMPREC
  1. .S IVMDAS=IVMDA ; save IVMDA for spouse ZDP segment
  1. .D GET I IVMSEG1'="ZIC" D Q
  1. ..S HLERR="Missing spouse's ZIC segment" D ACK^IVMPREC
  1. .D GET I IVMSEG1'="ZIR" D Q
  1. ..S HLERR="Missing spouse's ZIR segment" D ACK^IVMPREC
  1. .;
  1. .; check for dependent children's ZDP, ZIC, ZIR segments and ZMT segment
  1. .K IVMERR
  1. .S IVMFLG7=0
  1. .F D Q:$D(IVMERR)!(IVMSEG1="ZMT")
  1. ..D GET I IVMSEG1'="ZDP"&(IVMSEG1'="ZMT") D Q
  1. ...S HLERR="Missing child's ZDP segment or ZMT segment",IVMERR="" D ACK^IVMPREC
  1. ..I IVMSEG1="ZMT" D Q
  1. ...S:$P(IVMSEG,"^",4)=HLQ IVMFLG7=1 ; delete MT if status is HLQ
  1. ...S IVMDAZ=IVMDA ; ZMT segment ivmda
  1. ..I $P(IVMSEG,"^",2)']""!($P(IVMSEG,"^",3)']"")!($P(IVMSEG,"^",4)']"") D Q
  1. ... S HLERR="Missing child data from ZDP segment",IVMERR="" D ACK^IVMPREC
  1. ..D GET I IVMSEG1'="ZIC" D Q
  1. ...S HLERR="Missing child's ZIC segment",IVMERR="" D ACK^IVMPREC
  1. ..D GET I IVMSEG1'="ZIR" D Q
  1. ...S HLERR="Missing child's ZIR segment",IVMERR="" D ACK^IVMPREC
  1. ..S IVMFLGC=IVMFLGC+1 ; # of children
  1. .;
  1. .Q:$D(IVMERR)&(IVMSEG1'="MSH")
  1. .G EN1:IVMSEG1="MSH"
  1. .;
  1. .; get primary means test
  1. .; ivmmtdt - means test date
  1. .; dgly - income year
  1. .; if Means Test not in DHCP don't upload IVM Means Test
  1. .S IVMMTDT=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3)) ; means test date from ZMT segment
  1. .S DGLY=$$LYR^DGMTSCU1(IVMMTDT)
  1. .S IVMMTIEN=+$$LST^DGMTU(DFN,IVMMTDT) ; primary means test IEN
  1. .;
  1. .I IVMFLG7 D ^IVMUM7 Q ; delete means test
  1. .;
  1. .S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0)) ; dgmtp is event driver variable
  1. .I $P(IVMMT31,"^")'=IVMMTDT D Q
  1. ..S Y=IVMMTDT X ^DD("DD")
  1. ..S IVMTEXT(6)="Means Test of "_Y_" not in DHCP."
  1. ..D ERRBULL,MAIL^IVMUFNC()
  1. ..S HLERR="Means test not in DHCP" D ACK^IVMPREC
  1. ..Q
  1. .I $P(IVMMT31,"^",23)=2 S Y=IVMMTDT X ^DD("DD") S HLERR="2nd means test sent for "_Y D ACK^IVMPREC Q
  1. .;
  1. .; do not upload IVM means test if primary means test status is
  1. .; 3-no longer required
  1. .; or if hardship case
  1. .S IVMSTAT=$P(IVMMT31,"^",3)
  1. .I IVMSTAT=3 S HLERR="NOT UPLOADED no longer required" D ACK^IVMPREC Q
  1. .I $P(IVMMT31,"^",20)=1 S HLERR="NOT UPLOADED hardship case" D ACK^IVMPREC Q
  1. .D ^IVMUM1 ; upload means test
  1. .I $D(HLERR) D ACK^IVMPREC
  1. .;
  1. .; cleanup
  1. .K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,IVMFLG7,IVMFLGC,IVMMT31,IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB
  1. .Q
  1. Q
  1. ;
  1. GET ; get HL7 segment from ^HL
  1. S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA)),IVMSEG=$G(^(+IVMDA,0))
  1. S IVMSEG1=$E(IVMSEG,1,3)
  1. Q
  1. ;
  1. ERRBULL ; build mail message for transmission to IVM mail group notifying site
  1. ; of upload error.
  1. S IVMPAT=$$PT^IVMUFNC4(DFN)
  1. S XMSUB="IVM - MEANS TEST UPLOAD"
  1. S IVMTEXT(1)="The following error occured when an Income Verification Match"
  1. S IVMTEXT(2)="verified Means Test was being uploaded for the following patient:"
  1. S IVMTEXT(3)=" "
  1. S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
  1. S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
  1. S IVMTEXT(6)=" ERROR: "_IVMTEXT(6)
  1. Q
  1. ORF ;entry point for Means Test Signature Z06 msgs.
  1. I $G(HLFS)="" S HLFS="^"
  1. I $G(HLECH)="" S HLECH="~"
  1. F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D Q:'IVMDA
  1. .K HLERR
  1. .S HLMID=$P(IVMSEG,HLFS,10) ; message control id from MSH
  1. .S IVMFLGC=0
  1. .D GET I IVMSEG1'="PID" D Q
  1. ..S HLERR="Missing PID segment" D ACK^IVMPREC
  1. .S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
  1. .I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
  1. ..S HLERR="Invalid DFN" D ACK^IVMPREC
  1. .I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVMSSN with DHCP SSN" D ACK^IVMPREC Q
  1. .S IVMDAP=IVMDA ; save IVMDA for veteran PID segment
  1. .D GET I IVMSEG1'="ZMT" D Q
  1. ..S HLERR="Missing ZMT segment" D ACK^IVMPREC
  1. .; IVMMTDT - means test date
  1. .; DGLY - income year
  1. .; if Means Test not in DHCP don't upload IVM Means Test
  1. .S IVMMTDT=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3)) ; means test date from ZMT segment
  1. .S DGLY=$$LYR^DGMTSCU1(IVMMTDT)
  1. .; get means test to be updated
  1. .N UPMTS
  1. .S MTDATE=-IVMMTDT,IVMMTIEN="",MTFND=0
  1. .F S IVMMTIEN=$O(^DGMT(408.31,"AID",1,DFN,MTDATE,IVMMTIEN),-1) Q:MTFND!(IVMMTIEN="") D
  1. ..I $$Z06MT^EASPTRN1(IVMMTIEN) Q ;EDB Z06 - Don't use this one
  1. ..; match site completing in case multiple tests for same date
  1. ..I $P(IVMSEG,HLFS,23)=$P(^DGMT(408.31,IVMMTIEN,2),HLFS,5) S UPMTS=IVMMTIEN,MTFND=1 Q
  1. .S (IVMMT31,DGMTP)=$G(^DGMT(408.31,UPMTS,0)) ; DGMTP is event driver variable
  1. .I $P(IVMMT31,"^")'=IVMMTDT D Q
  1. ..S Y=IVMMTDT X ^DD("DD")
  1. ..S IVMTEXT(6)="Means Test of "_Y_" not in DHCP."
  1. ..D ERRBULL,MAIL^IVMUFNC()
  1. ..S HLERR="Means test not in DHCP" D ACK^IVMPREC
  1. ..Q
  1. .I $P(IVMMT31,"^",23)=2 S Y=IVMMTDT X ^DD("DD") S HLERR="2nd means test sent for "_Y D ACK^IVMPREC Q
  1. .; do not upload IVM means test if primary means test status is
  1. .; 3-no longer required
  1. .; or if hardship case
  1. .S IVMSTAT=$P(IVMMT31,"^",3)
  1. .I IVMSTAT=3 S HLERR="NOT UPLOADED no longer required" D ACK^IVMPREC Q
  1. .I $P(IVMMT31,"^",20)=1 S HLERR="NOT UPLOADED hardship case" D ACK^IVMPREC Q
  1. .;get MT signature and date/time edited info, update means test
  1. .N DATA
  1. .S DATA(.29)=$P(IVMSEG,HLFS,28),DATA(2.02)=$$FMDATE^HLFNC($P(IVMSEG,HLFS,26)) I $D(DATA(.29)) D
  1. ..I $$UPD^DGENDBS(408.31,UPMTS,.DATA)
  1. .I '$D(HLERR) D ACK^IVMPREC
  1. .;
  1. .; cleanup
  1. .K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,IVMFLG7,IVMFLGC,IVMMT31,IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,FMDATE,MTDATE
  1. .Q
  1. Q