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

DGENUPL1.m

Go to the documentation of this file.
  1. DGENUPL1 ;ALB/CJM,ISA,KWP,CKN,LBD,LMD,TDM,TGH,DJS,HM,JAM,KUM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;30 Oct 2017 7:32PM
  1. ;;5.3;REGISTRATION;**147,222,232,314,397,379,407,363,673,653,688,797,842,894,871,935,959,975,972,952,996,1014,1082**;Aug 13,1993;Build 29
  1. ;
  1. PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST,DGNMSE,DGHBP,DGOTH,DGZHF) ;
  1. ;
  1. ;Description: This function parses the HL7 segments. It creates arrays
  1. ;defined by the PATIENT, ENROLLMENT, ELIGIBILY, CATASTROPHIC DISABILITY,
  1. ;OEF/OIF CONFLICT objects.
  1. ;Field values are put in DHCP format and the validity at the
  1. ;field level is tested. Fields to be deleted are set to "@".
  1. ;
  1. ;Input:
  1. ; MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file (772)
  1. ; MSGID -message control id of HL7 msg in the MSH segment
  1. ; CURLINE - the subscript of the PID segment of the current message (pass by reference)
  1. ; ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by ref)
  1. ;
  1. ;Output:
  1. ; Function Value: Returns 1 on success, 0 on failure.
  1. ; CURLINE - upon leaving the procedure this parameter should be set to the end of the current message.
  1. ; ERRCOUNT - set to count of messages that were not processed due to errors encountered. (pass by ref)
  1. ; DGPAT - array defined by the PATIENT object. (pass by ref)
  1. ; DGENR - array defined by the PATIENT ENROLLMENT object. (pass by ref)
  1. ; DGELG - array defined by the PATIENT ELIGIBILITY object. (pass by ref)
  1. ; DGCDIS - array defined by the CATASTROPHIC DISABILITY object. (pass by ref)
  1. ; DGSEC - array defined by the PATIENT SECURITY object. (pass by ref)
  1. ; DGOEIF - array defined by the OEF/OIF CONFLICT object. (pass by ref)
  1. ; DGNTR - array defined for NTR data.
  1. ; DGMST - array defined for MST data.
  1. ; DGNMSE - array define for MILITARY SERVICE EPISODE data (pass by ref)
  1. ; DGHBP - array define for HEALTH BENEFIT PLAN data (pass by ref) DG*5.3*871
  1. ; DGOTH - array for OTH data (passed by ref)
  1. ; DGZHF - array for Presumptive Psychosis data (pass by ref) DG*5.3*1082
  1. ;
  1. N SEG,ERROR,COUNT,QFLG,NFLG,DGCCPC
  1. ;
  1. ;DJS, Set TMP global to track the presence of ZMH segment; DG*5.3*935
  1. K ^TMP($J,"DGENUPL") S ^TMP($J,"DGENUPL","ZMH",0)=0
  1. ;
  1. K DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST
  1. ;
  1. S ERROR=0,NFLG=1
  1. F SEG="PID","ZPD","ZIE","ZIO","ZEL" D Q:ERROR
  1. .D:NFLG NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. .I SEG="ZIO",SEG("TYPE")'="ZIO" S NFLG=0 Q
  1. .I SEG("TYPE")=SEG D Q
  1. ..I SEG'="ZEL" N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN ; DG*5.3*894
  1. ..D:(SEG="ZEL") ZEL^DGENUPL2(1)
  1. ..S NFLG=1
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
  1. .S ERROR=1
  1. .;
  1. .;possible that in a bad message we are now past the end
  1. .S CURLINE=CURLINE-1
  1. ;
  1. ;DJS, Set segment before processing possible multiple segments; DG*5.3*935
  1. I 'ERROR S SEG="ZEL" F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZEL") D Q:ERROR
  1. .S CURLINE=CURLINE+1
  1. .D ZEL^DGENUPL2(COUNT)
  1. ;
  1. ;ZE2 is optional, If no ZE2 segment delete pension data
  1. I 'ERROR D
  1. .I SEG("TYPE")="ZE2" D ZE2^DGENUPLB S CURLINE=CURLINE+1 Q
  1. .I SEG("TYPE")'="ZE2" D
  1. ..Q:$$GET1^DIQ(2,DFN,.3852,"I")=$O(^DG(27.18,"C","00",""))
  1. ..N PSUB
  1. ..F PSUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S DGPAT(PSUB)="@"
  1. ;
  1. ; DG*5.3*1082 - ZHF is optional
  1. I 'ERROR S SEG="ZHF" I $$CHKNXT(CURLINE+1,SEG) D
  1. .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. .I SEG("TYPE")="ZHF" D ZHF^DGENUPLB Q
  1. ;
  1. ; ZTE is optional and repeatable DG*5.3*952
  1. K DGOTH I 'ERROR S SEG="ZTE" I $$CHKNXT(CURLINE+1,SEG) D
  1. .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. .S QFLG=0 F D Q:QFLG
  1. ..I SEG("TYPE")'="ZTE" S QFLG=1,CURLINE=CURLINE-1 Q
  1. ..D ZTE^DGENUPLB
  1. ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. ..Q
  1. .Q
  1. ;
  1. ; ZCE is optional and repeatable DG*5.3*1014
  1. S DGCCPC=0
  1. K DGOTH I 'ERROR S SEG="ZCE" I $$CHKNXT(CURLINE+1,SEG) D
  1. .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. .S QFLG=0 F D Q:QFLG
  1. ..I SEG("TYPE")'="ZCE" S QFLG=1,CURLINE=CURLINE-1 Q
  1. ..D ZCE^DGENUPLB
  1. ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. ..Q
  1. .Q
  1. ;
  1. ;ZHP is optional & can repeat. DG*5.3*871
  1. K DGHBP
  1. ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
  1. I 'ERROR S SEG="ZHP" I $$CHKNXT(CURLINE+1,SEG) D Q:ERROR $S(ERROR:0,1:1)
  1. . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. . S QFLG=0 F D Q:QFLG!(ERROR) ;DG*5.3*996; JAM; Trap error - do not continue processing
  1. . . I SEG("TYPE")'="ZHP" S QFLG=1,CURLINE=CURLINE-1 Q
  1. . . D ZHP^DGENUPLB Q:ERROR ;DG*5.3*996; JAM; Trap error - do not continue processing
  1. . . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. ;
  1. ;Phase II Add the capability to accept more than 1 ZCD
  1. I 'ERROR F SEG="ZEN","ZMT","ZCD" D Q:ERROR
  1. .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. .I SEG("TYPE")=SEG D
  1. ..N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN ; DG*5.3*894
  1. .E D
  1. ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
  1. ..S ERROR=1
  1. ..;
  1. ..;possible that in a bad message we are now past the end
  1. ..S CURLINE=CURLINE-1
  1. ;
  1. ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
  1. I 'ERROR S SEG="ZCD" I $$CHKNXT(CURLINE+1,SEG) F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZCD") D Q:ERROR
  1. .S CURLINE=CURLINE+1
  1. .D ZCD^DGENUPL2
  1. ;
  1. ; Purple Heart/OEF-OIF Addition of optional ZMH segment
  1. ; Modified handling of ZSP and ZRD to accommodate ZMH
  1. ;
  1. ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
  1. I 'ERROR S SEG="ZSP" I $$CHKNXT(CURLINE+1,SEG) D Q:ERROR $S(ERROR:0,1:1)
  1. .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. .I SEG("TYPE")="ZSP" D ZSP^DGENUPL2 Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
  1. .S ERROR=1
  1. .;possible that in a bad message we are now past the end
  1. .S CURLINE=CURLINE-1
  1. ;
  1. ;Modified following code to receive multiple ZMH segment for
  1. ;Military service information - DG*5.3*653
  1. ;
  1. ;DJS, Check for no MSE ZMH segments present and non-MSE ZMH segments ; DG*5.3*959
  1. I 'ERROR S SEG="ZMH" D ; DG*5.3*972 ;HM - remove Q:ERROR and let code quit with value below
  1. .N SEGNAM,MSECNT,CURLN,MHSTYP,NONMSE,SGMNT S SEGNAM="",(MSECNT,NONMSE)=0,CURLN=CURLINE
  1. .F S CURLN=$O(^TMP($J,IVMRTN,CURLN)) Q:'CURLN D
  1. ..S SGMNT=$G(^TMP($J,IVMRTN,CURLN,0)),SEGNAM=$P($G(SGMNT),U) Q:SEGNAM'="ZMH" S MHSTYP=$P($G(SGMNT),U,3)
  1. ..I "^SL^SNL^SNNL^MSD^FDD^"[("^"_MHSTYP_"^") S MSECNT=MSECNT+1 Q
  1. ..E S NONMSE=NONMSE+1 Q ;ZMH segment present, but not an MSE
  1. .;DJS, No MSE-type ZMH segment present, so branch to DGNOZMH to kill HEC-owned MSEs; DG*5.3*935
  1. .I MSECNT=0 I ^TMP($J,"DGENUPL","ZMH",0)=0 D EN^DGNOZMH(DFN) K ^TMP($J,"DGENUPL")
  1. .Q:('NONMSE&('MSECNT))
  1. .;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
  1. .S QFLG=0 F D Q:QFLG!(ERROR)
  1. ..I '$$CHKNXT(CURLINE+1,SEG) S QFLG=1 Q
  1. ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) ;process any ZMH segments that are present in Z11
  1. ..D ZMH^DGENUPL2
  1. ;
  1. ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
  1. I 'ERROR S SEG="ZRD" I $$CHKNXT(CURLINE+1,SEG) F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZRD") D Q:ERROR
  1. .S CURLINE=CURLINE+1
  1. .D ZRD^DGENUPL2
  1. ;
  1. ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
  1. I 'ERROR S SEG="OBX" F D Q:(ERROR!('$$CHKNXT(CURLINE+1,SEG)))
  1. .;possible if OBX segment not present that we are now past the end
  1. .Q:'$$CHKNXT(CURLINE+1,SEG)
  1. .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
  1. .D OBX^DGENUPL2
  1. .Q
  1. ;
  1. K ^TMP($J,"DGENUPL")
  1. Q $S(ERROR:0,1:1)
  1. ;
  1. CONVERT(VAL,DATATYPE,ERROR) ;
  1. ;Description: Converts the value found in the HL7 segment to DHCP format
  1. ;
  1. ;Input:
  1. ; VAL - value parsed from the HL7 segment
  1. ; DATATYPE: indicates the type of conversion necessary
  1. ; "DATE" - needs to be converted to FM format
  1. ; "TS" - time stamp, needs to be converted to FM format
  1. ; "Y/N" - 0->"N",1->"Y"
  1. ; "1/0" - "Y"->1,"N"->0
  1. ; "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file
  1. ; "ELIGIBILITY" - VAL is a pointer to the national eligibility code file (#8.1), needs to be converted to a local eligibility code (file #8)
  1. ;
  1. ; "MT" - VAL is a Means Test Status code, it needs to be converted
  1. ; to a pointer to the Means Test Status file
  1. ; Phase II convert code to RSN IEN for DGCDIS object
  1. ; "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5)
  1. ; "CDDSCR" data type converts the codes descriptor(s) to DSCR IEN. (HL7TODSC^DGENA5) DG*5.3*894
  1. ; "EXT" convert from code to abbreviation
  1. ; "POS" convert from Period of Service code to a point to Period of Service file
  1. ; "AGENCY" convert Agency/Allied Country code from file 35
  1. ; "PENSIONCD" convert Pension Award/Termination Reason code from file 27.18
  1. ; "HBP" convert from code to file 25.11 ien DG*5.3*871
  1. ;OUTPUT:
  1. ; Function Value - the result of the conversion
  1. ; ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref)
  1. S ERROR=0
  1. D
  1. .I VAL="" Q
  1. .I VAL="""""" S VAL="@" Q
  1. .I $G(DATATYPE)="EXT" D Q
  1. ..S VAL=$$HLTOLIMB^DGENA5(VAL)
  1. .I $G(DATATYPE)="CDRSN" D Q
  1. ..S VAL=$$HL7TORSN^DGENA5(VAL)
  1. .; * check the new DESCRIPTOR seq - DG*5.3*894
  1. .I $G(DATATYPE)="CDDSCR" D Q
  1. ..S VAL=$$HL7TODSC^DGENA5(VAL)
  1. .I ($G(DATATYPE)="MT") D Q
  1. ..S VAL=$O(^DG(408.32,"AC",1,VAL,0))
  1. ..I 'VAL S ERROR=1
  1. .I ($G(DATATYPE)="DATE") D Q
  1. ..I $L(VAL)'=8 S ERROR=1 Q
  1. ..S VAL=$$FMDATE^HLFNC(VAL)
  1. ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
  1. .I ($G(DATATYPE)="TS") D Q
  1. ..I $L(VAL)<8 S ERROR=1 Q
  1. ..S VAL=$$FMDATE^HLFNC(VAL)
  1. ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
  1. .I ($G(DATATYPE)="Y/N") D Q
  1. ..I VAL=0 S VAL="N" Q
  1. ..I VAL=1 S VAL="Y" Q
  1. ..S ERROR=1
  1. .I ($G(DATATYPE)="1/0") D Q
  1. ..I VAL="N" S VAL=0 Q
  1. ..I VAL="Y" S VAL=1 Q
  1. ..S ERROR=1
  1. .I ($G(DATATYPE)="ELIGIBILITY") D Q
  1. ..S VAL=$$MAP(VAL)
  1. ..I 'VAL S ERROR=1
  1. .I ($G(DATATYPE)="INSTITUTION") D Q
  1. ..N OLDVAL
  1. ..S OLDVAL=VAL
  1. ..S VAL=$O(^DIC(4,"D",OLDVAL,0))
  1. ..I 'VAL S VAL=$O(^DIC(4,"D",(+OLDVAL),0))
  1. ..I 'VAL S ERROR=1
  1. .I ($G(DATATYPE)="POS") D Q
  1. ..N OLDVAL
  1. ..S OLDVAL=VAL
  1. ..S VAL=$O(^DIC(21,"D",OLDVAL,0))
  1. ..I 'VAL S ERROR=1
  1. .I ($G(DATATYPE)="AGENCY") D Q
  1. ..N OLDVAL
  1. ..S OLDVAL=VAL
  1. ..S VAL=$O(^DIC(35,"C",OLDVAL,0))
  1. ..I 'VAL S ERROR=1
  1. .I ($G(DATATYPE)="PENSIONCD") D Q
  1. ..N OLDVAL
  1. ..S OLDVAL=VAL
  1. ..S VAL=$O(^DG(27.18,"C",OLDVAL,0))
  1. ..I 'VAL S ERROR=1
  1. .I ($G(DATATYPE)="HBP") D Q ; DG*5.3*871
  1. ..N OLDVAL
  1. ..S OLDVAL=VAL
  1. ..S VAL=$O(^DGHBP(25.11,"C",OLDVAL,0))
  1. ..I 'VAL S ERROR=1
  1. Q VAL
  1. ;
  1. MAP(VALUE) ;
  1. ;Description: Tries to map an eligibility code from file #8.1 (the national MAS ELIGIBILITY CODE file) to file #8 (the local ELIGIBILITY CODE file)
  1. ;
  1. ;Input: VALUE - ien of an entry in file #8.1
  1. ;
  1. ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8
  1. ;
  1. N ECODE,NODE,COUNT,NAME
  1. ;try to choose a code from file 8 to use that is appropriate
  1. S (COUNT,ECODE)=0
  1. ;
  1. F S ECODE=$O(^DIC(8,"D",VALUE,ECODE)) Q:'ECODE D
  1. .S NODE=$G(^DIC(8,ECODE,0))
  1. .;put code on list if active
  1. .I (NODE'=""),'$P(NODE,"^",7) S ECODE(ECODE)=$P(NODE,"^"),COUNT=COUNT+1
  1. ;
  1. ;only one match found, so use it
  1. Q:COUNT=1 $O(ECODE(0))
  1. ;
  1. ;no match found
  1. Q:'COUNT ""
  1. ;
  1. ;multiple matches found, try to match by name
  1. I COUNT>1 D
  1. .S ECODE=0
  1. .S NAME=$P($G(^DIC(8.1,VALUE,0)),"^")
  1. .F S ECODE=$O(ECODE(ECODE)) Q:'ECODE Q:ECODE(ECODE)=NAME
  1. Q ECODE
  1. ;
  1. ACCEPT(MSGID) ;
  1. ;Description: Writes an ack (AA) to a global to be transmitted later.
  1. ;
  1. ;Inputs:
  1. ; MSGID -message control id of HL7 msg in the MSH segment
  1. ;
  1. ;Outputs: none
  1. ;
  1. N MID
  1. K HL,HLMID,HLMTIEN,HLDT,HLDT1
  1. D INIT^HLFNC2(HLEID,.HL)
  1. D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
  1. S HLEVN=1
  1. S MID=HLMID_"-"_HLEVN
  1. D MSH^HLFNC2(.HL,MID,.HLRES)
  1. S ^TMP("HLS",$J,1)=HLRES
  1. ;
  1. ;it seems HLFS sometimes disappears upon reaching this point
  1. I $G(HLFS)="" S HLFS="^"
  1. ;
  1. S ^TMP("HLS",$J,2)="MSA"_HLFS_"AA"_HLFS_MSGID
  1. Q
  1. ;
  1. MVERRORS ;
  1. ;Error messages were being deleted from ^TMP("HLS",$J by another package
  1. ;during the upload. To fix this, errors are written to another
  1. ;subscript, then moved when the error list is complete.
  1. ;
  1. M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J)
  1. K ^TMP("IVM","HLS",$J)
  1. Q
  1. ;
  1. ;DJS, Added Extrinsic Function to determine if multiple segments are present ; DG*5.3*935
  1. CHKNXT(DGNVAL,DGNSEG) ; Check the SEG in the next segment manually
  1. ; DGNVAL = CURLINE or CURLINE+1
  1. ; DGNSEG = SEG (3 character SEG)
  1. ; Returns 1 if there is a match or 0 if there is no match
  1. ;
  1. Q $S($E($G(^TMP($J,IVMRTN,+DGNVAL,0)),1,3)=DGNSEG:1,1:0)