source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMPREC6.m@ 1397

IVMPREC6 ;ALB/KCL/BRM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES ; 12/29/2004
 ;;2.0; INCOME VERIFICATION MATCH ;**3,4,12,17,34,58,79,102**; 21-OCT-94
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; This routine will process batch ORU demographic (event type Z05) HL7
 ; messages received from the IVM center.  Format of HL7 batch message:
 ;
 ;       BHS
 ;       {MSH
 ;        PID
 ;        ZPD
 ;        ZGD
 ;        RF1 (optional)
 ;       }
 ;       BTS
 ;
 ;
EN ; - entry point to process HL7 patient demographic message 
 ;
 N DGENUPLD,VAFCA08,DGRUGA08
 ;
 ; prevent a return Z07 when uploading a Z05 (Patient file triggers)
 S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
 ;
 ; prevent MPI A08 message when uploading Z05 (Patient file triggers)
 S VAFCA08=1  ;MPI/CIRN A08 suppression flag
 ;
 S IVMFLG=0
 ; - get incoming HL7 message from HL7 Transmission (#772) file
 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
 .K HLERR
 .;
 .; - message control id from MSH segment
 .S MSGID=$P(IVMSEG,HLFS,10),HLMID=MSGID
 .;
 .; - perform demographics message consistency check
 .D EN^IVMPRECA Q:$D(HLERR)
 .;
 .; - get next msg segment
 .D NEXT I $E(IVMSEG,1,3)'="PID" D  Q
 ..S HLERR="Missing PID segment" D ACK^IVMPREC
 .;
 .; - patient IEN (DFN) from PID segment
 .S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH),1)
 .;
 .I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D  Q
 ..S HLERR="Invalid DFN" D ACK^IVMPREC
 .I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) D  Q
 ..S HLERR="Couldn't match HEC SSN with DHCP SSN" D ACK^IVMPREC
 .;
 .; - check for entry in IVM PATIENT file, otherwise create stub entry
 .S IVM3015=$O(^IVM(301.5,"B",DFN,0))
 .I 'IVM3015 S IVM3015=$$LOG^IVMPLOG(DFN,DT)
 .I 'IVM3015 D  Q
 ..S HLERR="Failed to create entry in IVM PATIENT file"
 ..D ACK^IVMPREC
 .;
 .; - compare PID segment fields with DHCP fields
 .D COMPARE(IVMSEG) Q:$D(HLERR)
 .;
 .; - get next msg segment
 .D NEXT I $E(IVMSEG,1,3)'="ZPD" D  Q
 ..S HLERR="Missing ZPD segment" D ACK^IVMPREC
 .;
 .; - compare ZPD segment fields with DHCP fields
 .D COMPARE(IVMSEG)
 .;
 .; - get next msg segment
 .D NEXT I $E(IVMSEG,1,3)="ZEL" D  Q
 ..S HLERR="ZEL segment should not be sent in Z05 message" D ACK^IVMPREC
 .;
 .; - get next msg segment
 .I $E(IVMSEG,1,3)'="ZGD" D  Q
 ..S HLERR="Missing ZGD segment" D ACK^IVMPREC
 .;
 .; - compare ZGD segment fields with DHCP fields
 .D COMPARE(IVMSEG)
 .;S IVMFLG=0
 .;
 .; - check for RF1 segment and get segment if it exists
 .;     This process will automatically update patient address data
 .;     in the Patient (#2) file if the incoming address is more
 .;     recent than the existing one.
 .I $$RF1CHK(IVMRTN,IVMDA) D NEXT,COMPARE(IVMSEG) S IVMFLG=0
 ;
 ; - send mail message if necessary
 I IVMCNTR D MAIL^IVMUFNC()
 ; Cleanup variables if no msg necessary
 I 'IVMCNTR K IVMTEXT,XMSUB
 ;
ENQ ; - cleanup variables
 K DA,DFN,IVMADDR,IVMADFLG,IVMDA,IVMDHCP,IVMFLAG,IVMFLD,IVMPIECE,IVMSEG,IVMSTART,IVMXREF,DGENUPLD
 Q
 ;
 ;
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
 ;
 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
 Q
 ;
 ;
COMPARE(IVMSEG) ; - compare incoming HL7 segment/fields with DHCP fields
 ;
 ;  Input:  IVMSEG  --  as the text of the incoming HL7 message
 ;
 ; Output:  None
 ;
 ; - get 3 letter HL7 segment name
 S IVMXREF=$P(IVMSEG,HLFS,1),IVMSTART=IVMXREF
 ;
 ; - strip off HL7 segment name
 S IVMSEG=$P(IVMSEG,HLFS,2,99)
 ;
 ; - roll through "C" x-ref in IVM Demographic Upload Fields (#301.92) file
 F  S IVMXREF=$O(^IVM(301.92,"C",IVMXREF)) Q:IVMXREF']""  D
 .S IVMDEMDA=$O(^IVM(301.92,"C",IVMXREF,"")) Q:IVMDEMDA']""
 .I $$INACTIVE(IVMDEMDA) Q
 .;
 .; - compare incoming HL7 segment fields with DHCP fields
 .I IVMXREF["PID",(IVMSTART["PID") D PID^IVMPREC8
 .I IVMXREF["ZPD",(IVMSTART["ZPD") D ZPD^IVMPREC8
 .I IVMXREF["ZGD",(IVMSTART["ZGD") D ZGD^IVMPREC8
 .I IVMXREF["RF1",(IVMSTART["RF1") D RF1^IVMPREC8
 Q
 ;
 ;
DEMBULL ; -  build mail message for transmission to IVM mail group notifying
 ;    them that patients with updated demographic data has been received
 ;    from the IVM Center and may now be uploaded into DHCP.
 ;
 ; If record is auto uploaded, don't add veteran to bulletin
 I $$CKAUTO Q
 ;
 S IVMPTID=$$PT^IVMUFNC4(DFN)
 S XMSUB="IVM - DEMOGRAPHIC UPLOAD for "_$P($P(IVMPTID,"^"),",")_" ("_$P(IVMPTID,"^",3)_")"
 S IVMTEXT(1)="Updated demographic information has been received from the"
 S IVMTEXT(2)="Health Eligibilty Center.  Please select the 'Demographic Upload'"
 S IVMTEXT(3)="option from the IVM Upload Menu in order to take action on this"
 S IVMTEXT(4)="demographic information.  If you have any questions concerning the"
 S IVMTEXT(5)="information received, please contact the Health Eligibility Center."
 S IVMTEXT(7)=""
 S IVMTEXT(8)="The Health Eligibilty Center has identified the following"
 S IVMTEXT(9)="patients as having updated demographic information:"
 S IVMTEXT(10)=""
 S IVMCNTR=IVMCNTR+1
 S IVMTEXT(IVMCNTR+10)=$J(IVMCNTR_")",5)_"  "_$P(IVMPTID,"^")_" ("_$P(IVMPTID,"^",3)_")"
 Q
 ;
INACTIVE(IVMDEMDA) ;Check if field is inactive in Demographic Upload
 ; Input  -- IVMDEMDA IVM Demographic Upload Fields IEN
 ; Output -- 1=Yes and 0=No
 Q +$P($G(^IVM(301.92,IVMDEMDA,0)),U,9)
 ;
RF1CHK(IVMRTN,IVMDA) ;does an RF1 segment exist in this message?
 N RF1
 S RF1=$O(^TMP($J,IVMRTN,IVMDA))
 I $E($G(^(+RF1,0)),1,3)'="RF1" Q 0
 Q 1
 ;
CKAUTO() ;
 ; Chect if message qualifies for an auto upload.
 N AUTO,IVMI,DOD
 S AUTO=0,IVMI=$O(^IVM(301.92,"C","ZPD09",""))
 I IVMI=IVMDEMDA  D
 .I +IVMFLD'>0 S AUTO=1 Q
 .S DOD=$P($G(^DPT(DFN,.35)),U)
 .I DOD=IVMFLD S AUTO=1 Q
 ;
 Q AUTO