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

IVMPRECZ.m

Go to the documentation of this file. 
  1. IVMPRECZ ;ALB/SEK,RTK,TDM - ROUTINE TO PROCESS V1.5 ORF-Z06 INCOMING HL7 MESSAGES ; 8/15/08 10:28am
  1.  ;;2.0;INCOME VERIFICATION MATCH;**34,64,71,115**;21-OCT-94;Build 28
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ;
  1. GET ; get HL7 segment from ^HL
  1.  S IVMDA=$O(^HL(772,HLDA,"IN",+IVMDA)),IVMSEG=$G(^(+IVMDA,0))
  1.  S IVMSEG1=$E(IVMSEG,1,3)
  1.  I IVMSEG1="PID" D  Q
  1.  .N NOPID,PIDCNTR,PIDSTR
  1.  .K IVMPID
  1.  .S (NOPID,PIDCNTR)=1,PIDSTR(PIDCNTR)=$P(IVMSEG,HLFS,2,99)
  1.  .F I=1:1 D  Q:NOPID
  1.  ..I $E($G(^HL(772,HLDA,"IN",IVMDA+1,0)),1,4)="ZMT^" S NOPID=1 Q
  1.  ..S IVMDA=$O(^HL(772,HLDA,"IN",+IVMDA))
  1.  ..S IVMSEG=$G(^HL(772,HLDA,"IN",+IVMDA,0))
  1.  ..S PIDCNTR=PIDCNTR+1,PIDSTR(PIDCNTR)=IVMSEG
  1.  .D BLDPID^IVMPREC6(.PIDSTR,.IVMPID)
  1.  Q
  1.  ;
  1. ACK ; - prepare acknowledgment (ACK) message
  1.  S IVMCT=$G(IVMCT)+1
  1.  S HLSDT="IVMQ",^TMP("HLS",$J,HLSDT,IVMCT)=HLSDATA(1),IVMCT=IVMCT+1
  1.  S ^TMP("HLS",$J,HLSDT,IVMCT)="MSA"_HLFS_$S($D(HLERR):"AE",1:"AA")_HLFS_HLMID_$S($D(HLERR):HLFS_HLERR_" - SSN "_$S($G(DFN):$P($$PT^IVMUFNC4(DFN),"^",2),1:"NOT FOUND"),1:"")
  1.  I $D(HLERR) S HLEVN=HLEVN+1,IVMERROR=1
  1.  Q
  1.  ;
  1. NXTSEG(MSGIEN,CURLINE,SEG) ;
  1.  ;Description: Returns the next segment
  1.  ;
  1.  ;Input:
  1.  ;  MSGIEN - IEN in HL7 MESSAGE TEXT file
  1.  ;  CURLINE - subscript of the current segment
  1.  ;
  1.  ;Output:
  1.  ;  SEG - an array with the fields of the segment (pass by reference)
  1.  ;  CURLINE - upone exiting, will be the subscript of the next segment
  1.  ;
  1.  S CURLINE=CURLINE+1
  1.  S SEGMENT=$G(^HL(772,MSGIEN,"IN",CURLINE,0))
  1.  S SEG("TYPE")=$E(SEGMENT,1,3)
  1.  ;
  1.  ; MSH & BHS segs first piece is the field separator, which makes breaking the segment into fields a bit different
  1.  I (SEG("TYPE")="MSH")!(SEG("TYPE")="BHS") D
  1.  . S SEG(1)=$E(SEGMENT,4)
  1.  . F I=2:1:30 S SEG(I)=$P(SEGMENT,HLFS,I)
  1.  E  D
  1.  . F I=2:1:31 S SEG(I-1)=$P(SEGMENT,HLFS,I)
  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="MT SIGNATURE UPLOAD "_$E($P(IVMPAT,"^"),1)_$P(IVMPAT,"^",3)
  1.  S IVMTEXT(1)="Unable to upload a MT Signature.  A Means Test was not found that"
  1.  S IVMTEXT(2)="matches the Centralized Anniversary Date (CAD) on file at the HEC."
  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.  N SEG,EVENT,MSGID,COMP,TMPARY,PID3ARY,DFN,ICN
  1.  S:'$D(HLEVN) HLEVN=0
  1.  D NXTSEG(HLDA,0,.SEG)
  1.  Q:(SEG("TYPE")'="MSH")  ;wouldn't have reached here if this happened!
  1.  S EVENT=$P(SEG(9),$E(HLECH),2)
  1.  I EVENT'="Z06" G ORF^IVMCM
  1.  I $G(HLFS)="" S HLFS="^"
  1.  I $G(HLECH)="" S HLECH="~"
  1.  F IVMDA=0:0 S IVMDA=$O(^HL(772,HLDA,"IN",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
  1.  .;S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
  1.  .M TMPARY(3)=IVMPID(3) D PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
  1.  .S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
  1.  .I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) S HLERR=ERRMSG D ACK Q
  1.  .K TMPARY,PID3ARY
  1.  .;I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVMSSN with DHCP SSN" D ACK 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
  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="",(UPMTS,MTFND)=0
  1.  .F  S IVMMTIEN=$O(^DGMT(408.31,"AID",1,DFN,MTDATE,IVMMTIEN),-1) Q:MTFND!(IVMMTIEN="")  D
  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 found in VistA."
  1.  ..D ERRBULL,MAIL^IVMUFNC()
  1.  ..S HLERR="Means test not in VistA" D ACK
  1.  ..Q
  1.  .I $P(IVMMT31,"^",23)=2 S Y=IVMMTDT X ^DD("DD") S HLERR="2nd means test  sent for "_Y D ACK 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 Q
  1.  .I $P(IVMMT31,"^",20)=1 S HLERR="NOT UPLOADED hardship case" D ACK 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
  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