- 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
- ;;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
- ;
- PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST,DGNMSE,DGHBP,DGOTH,DGZHF) ;
- ;
- ;Description: This function parses the HL7 segments. It creates arrays
- ;defined by the PATIENT, ENROLLMENT, ELIGIBILY, CATASTROPHIC DISABILITY,
- ;OEF/OIF CONFLICT objects.
- ;Field values are put in DHCP format and the validity at the
- ;field level is tested. Fields to be deleted are set to "@".
- ;
- ;Input:
- ; MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file (772)
- ; MSGID -message control id of HL7 msg in the MSH segment
- ; CURLINE - the subscript of the PID segment of the current message (pass by reference)
- ; ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by ref)
- ;
- ;Output:
- ; Function Value: Returns 1 on success, 0 on failure.
- ; CURLINE - upon leaving the procedure this parameter should be set to the end of the current message.
- ; ERRCOUNT - set to count of messages that were not processed due to errors encountered. (pass by ref)
- ; DGPAT - array defined by the PATIENT object. (pass by ref)
- ; DGENR - array defined by the PATIENT ENROLLMENT object. (pass by ref)
- ; DGELG - array defined by the PATIENT ELIGIBILITY object. (pass by ref)
- ; DGCDIS - array defined by the CATASTROPHIC DISABILITY object. (pass by ref)
- ; DGSEC - array defined by the PATIENT SECURITY object. (pass by ref)
- ; DGOEIF - array defined by the OEF/OIF CONFLICT object. (pass by ref)
- ; DGNTR - array defined for NTR data.
- ; DGMST - array defined for MST data.
- ; DGNMSE - array define for MILITARY SERVICE EPISODE data (pass by ref)
- ; DGHBP - array define for HEALTH BENEFIT PLAN data (pass by ref) DG*5.3*871
- ; DGOTH - array for OTH data (passed by ref)
- ; DGZHF - array for Presumptive Psychosis data (pass by ref) DG*5.3*1082
- ;
- N SEG,ERROR,COUNT,QFLG,NFLG,DGCCPC
- ;
- ;DJS, Set TMP global to track the presence of ZMH segment; DG*5.3*935
- K ^TMP($J,"DGENUPL") S ^TMP($J,"DGENUPL","ZMH",0)=0
- ;
- K DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST
- ;
- S ERROR=0,NFLG=1
- F SEG="PID","ZPD","ZIE","ZIO","ZEL" D Q:ERROR
- .D:NFLG NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- .I SEG="ZIO",SEG("TYPE")'="ZIO" S NFLG=0 Q
- .I SEG("TYPE")=SEG D Q
- ..I SEG'="ZEL" N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN ; DG*5.3*894
- ..D:(SEG="ZEL") ZEL^DGENUPL2(1)
- ..S NFLG=1
- .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
- .S ERROR=1
- .;
- .;possible that in a bad message we are now past the end
- .S CURLINE=CURLINE-1
- ;
- ;DJS, Set segment before processing possible multiple segments; DG*5.3*935
- I 'ERROR S SEG="ZEL" F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZEL") D Q:ERROR
- .S CURLINE=CURLINE+1
- .D ZEL^DGENUPL2(COUNT)
- ;
- ;ZE2 is optional, If no ZE2 segment delete pension data
- I 'ERROR D
- .I SEG("TYPE")="ZE2" D ZE2^DGENUPLB S CURLINE=CURLINE+1 Q
- .I SEG("TYPE")'="ZE2" D
- ..Q:$$GET1^DIQ(2,DFN,.3852,"I")=$O(^DG(27.18,"C","00",""))
- ..N PSUB
- ..F PSUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S DGPAT(PSUB)="@"
- ;
- ; DG*5.3*1082 - ZHF is optional
- I 'ERROR S SEG="ZHF" I $$CHKNXT(CURLINE+1,SEG) D
- .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- .I SEG("TYPE")="ZHF" D ZHF^DGENUPLB Q
- ;
- ; ZTE is optional and repeatable DG*5.3*952
- K DGOTH I 'ERROR S SEG="ZTE" I $$CHKNXT(CURLINE+1,SEG) D
- .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- .S QFLG=0 F D Q:QFLG
- ..I SEG("TYPE")'="ZTE" S QFLG=1,CURLINE=CURLINE-1 Q
- ..D ZTE^DGENUPLB
- ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- ..Q
- .Q
- ;
- ; ZCE is optional and repeatable DG*5.3*1014
- S DGCCPC=0
- K DGOTH I 'ERROR S SEG="ZCE" I $$CHKNXT(CURLINE+1,SEG) D
- .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- .S QFLG=0 F D Q:QFLG
- ..I SEG("TYPE")'="ZCE" S QFLG=1,CURLINE=CURLINE-1 Q
- ..D ZCE^DGENUPLB
- ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- ..Q
- .Q
- ;
- ;ZHP is optional & can repeat. DG*5.3*871
- K DGHBP
- ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- I 'ERROR S SEG="ZHP" I $$CHKNXT(CURLINE+1,SEG) D Q:ERROR $S(ERROR:0,1:1)
- . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- . S QFLG=0 F D Q:QFLG!(ERROR) ;DG*5.3*996; JAM; Trap error - do not continue processing
- . . I SEG("TYPE")'="ZHP" S QFLG=1,CURLINE=CURLINE-1 Q
- . . D ZHP^DGENUPLB Q:ERROR ;DG*5.3*996; JAM; Trap error - do not continue processing
- . . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- ;
- ;Phase II Add the capability to accept more than 1 ZCD
- I 'ERROR F SEG="ZEN","ZMT","ZCD" D Q:ERROR
- .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- .I SEG("TYPE")=SEG D
- ..N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN ; DG*5.3*894
- .E D
- ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
- ..S ERROR=1
- ..;
- ..;possible that in a bad message we are now past the end
- ..S CURLINE=CURLINE-1
- ;
- ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- 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
- .S CURLINE=CURLINE+1
- .D ZCD^DGENUPL2
- ;
- ; Purple Heart/OEF-OIF Addition of optional ZMH segment
- ; Modified handling of ZSP and ZRD to accommodate ZMH
- ;
- ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- I 'ERROR S SEG="ZSP" I $$CHKNXT(CURLINE+1,SEG) D Q:ERROR $S(ERROR:0,1:1)
- .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- .I SEG("TYPE")="ZSP" D ZSP^DGENUPL2 Q
- .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
- .S ERROR=1
- .;possible that in a bad message we are now past the end
- .S CURLINE=CURLINE-1
- ;
- ;Modified following code to receive multiple ZMH segment for
- ;Military service information - DG*5.3*653
- ;
- ;DJS, Check for no MSE ZMH segments present and non-MSE ZMH segments ; DG*5.3*959
- I 'ERROR S SEG="ZMH" D ; DG*5.3*972 ;HM - remove Q:ERROR and let code quit with value below
- .N SEGNAM,MSECNT,CURLN,MHSTYP,NONMSE,SGMNT S SEGNAM="",(MSECNT,NONMSE)=0,CURLN=CURLINE
- .F S CURLN=$O(^TMP($J,IVMRTN,CURLN)) Q:'CURLN D
- ..S SGMNT=$G(^TMP($J,IVMRTN,CURLN,0)),SEGNAM=$P($G(SGMNT),U) Q:SEGNAM'="ZMH" S MHSTYP=$P($G(SGMNT),U,3)
- ..I "^SL^SNL^SNNL^MSD^FDD^"[("^"_MHSTYP_"^") S MSECNT=MSECNT+1 Q
- ..E S NONMSE=NONMSE+1 Q ;ZMH segment present, but not an MSE
- .;DJS, No MSE-type ZMH segment present, so branch to DGNOZMH to kill HEC-owned MSEs; DG*5.3*935
- .I MSECNT=0 I ^TMP($J,"DGENUPL","ZMH",0)=0 D EN^DGNOZMH(DFN) K ^TMP($J,"DGENUPL")
- .Q:('NONMSE&('MSECNT))
- .;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- .S QFLG=0 F D Q:QFLG!(ERROR)
- ..I '$$CHKNXT(CURLINE+1,SEG) S QFLG=1 Q
- ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) ;process any ZMH segments that are present in Z11
- ..D ZMH^DGENUPL2
- ;
- ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- 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
- .S CURLINE=CURLINE+1
- .D ZRD^DGENUPL2
- ;
- ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- I 'ERROR S SEG="OBX" F D Q:(ERROR!('$$CHKNXT(CURLINE+1,SEG)))
- .;possible if OBX segment not present that we are now past the end
- .Q:'$$CHKNXT(CURLINE+1,SEG)
- .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- .D OBX^DGENUPL2
- .Q
- ;
- K ^TMP($J,"DGENUPL")
- Q $S(ERROR:0,1:1)
- ;
- CONVERT(VAL,DATATYPE,ERROR) ;
- ;Description: Converts the value found in the HL7 segment to DHCP format
- ;
- ;Input:
- ; VAL - value parsed from the HL7 segment
- ; DATATYPE: indicates the type of conversion necessary
- ; "DATE" - needs to be converted to FM format
- ; "TS" - time stamp, needs to be converted to FM format
- ; "Y/N" - 0->"N",1->"Y"
- ; "1/0" - "Y"->1,"N"->0
- ; "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file
- ; "ELIGIBILITY" - VAL is a pointer to the national eligibility code file (#8.1), needs to be converted to a local eligibility code (file #8)
- ;
- ; "MT" - VAL is a Means Test Status code, it needs to be converted
- ; to a pointer to the Means Test Status file
- ; Phase II convert code to RSN IEN for DGCDIS object
- ; "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5)
- ; "CDDSCR" data type converts the codes descriptor(s) to DSCR IEN. (HL7TODSC^DGENA5) DG*5.3*894
- ; "EXT" convert from code to abbreviation
- ; "POS" convert from Period of Service code to a point to Period of Service file
- ; "AGENCY" convert Agency/Allied Country code from file 35
- ; "PENSIONCD" convert Pension Award/Termination Reason code from file 27.18
- ; "HBP" convert from code to file 25.11 ien DG*5.3*871
- ;OUTPUT:
- ; Function Value - the result of the conversion
- ; ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref)
- S ERROR=0
- D
- .I VAL="" Q
- .I VAL="""""" S VAL="@" Q
- .I $G(DATATYPE)="EXT" D Q
- ..S VAL=$$HLTOLIMB^DGENA5(VAL)
- .I $G(DATATYPE)="CDRSN" D Q
- ..S VAL=$$HL7TORSN^DGENA5(VAL)
- .; * check the new DESCRIPTOR seq - DG*5.3*894
- .I $G(DATATYPE)="CDDSCR" D Q
- ..S VAL=$$HL7TODSC^DGENA5(VAL)
- .I ($G(DATATYPE)="MT") D Q
- ..S VAL=$O(^DG(408.32,"AC",1,VAL,0))
- ..I 'VAL S ERROR=1
- .I ($G(DATATYPE)="DATE") D Q
- ..I $L(VAL)'=8 S ERROR=1 Q
- ..S VAL=$$FMDATE^HLFNC(VAL)
- ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
- .I ($G(DATATYPE)="TS") D Q
- ..I $L(VAL)<8 S ERROR=1 Q
- ..S VAL=$$FMDATE^HLFNC(VAL)
- ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
- .I ($G(DATATYPE)="Y/N") D Q
- ..I VAL=0 S VAL="N" Q
- ..I VAL=1 S VAL="Y" Q
- ..S ERROR=1
- .I ($G(DATATYPE)="1/0") D Q
- ..I VAL="N" S VAL=0 Q
- ..I VAL="Y" S VAL=1 Q
- ..S ERROR=1
- .I ($G(DATATYPE)="ELIGIBILITY") D Q
- ..S VAL=$$MAP(VAL)
- ..I 'VAL S ERROR=1
- .I ($G(DATATYPE)="INSTITUTION") D Q
- ..N OLDVAL
- ..S OLDVAL=VAL
- ..S VAL=$O(^DIC(4,"D",OLDVAL,0))
- ..I 'VAL S VAL=$O(^DIC(4,"D",(+OLDVAL),0))
- ..I 'VAL S ERROR=1
- .I ($G(DATATYPE)="POS") D Q
- ..N OLDVAL
- ..S OLDVAL=VAL
- ..S VAL=$O(^DIC(21,"D",OLDVAL,0))
- ..I 'VAL S ERROR=1
- .I ($G(DATATYPE)="AGENCY") D Q
- ..N OLDVAL
- ..S OLDVAL=VAL
- ..S VAL=$O(^DIC(35,"C",OLDVAL,0))
- ..I 'VAL S ERROR=1
- .I ($G(DATATYPE)="PENSIONCD") D Q
- ..N OLDVAL
- ..S OLDVAL=VAL
- ..S VAL=$O(^DG(27.18,"C",OLDVAL,0))
- ..I 'VAL S ERROR=1
- .I ($G(DATATYPE)="HBP") D Q ; DG*5.3*871
- ..N OLDVAL
- ..S OLDVAL=VAL
- ..S VAL=$O(^DGHBP(25.11,"C",OLDVAL,0))
- ..I 'VAL S ERROR=1
- Q VAL
- ;
- MAP(VALUE) ;
- ;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)
- ;
- ;Input: VALUE - ien of an entry in file #8.1
- ;
- ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8
- ;
- N ECODE,NODE,COUNT,NAME
- ;try to choose a code from file 8 to use that is appropriate
- S (COUNT,ECODE)=0
- ;
- F S ECODE=$O(^DIC(8,"D",VALUE,ECODE)) Q:'ECODE D
- .S NODE=$G(^DIC(8,ECODE,0))
- .;put code on list if active
- .I (NODE'=""),'$P(NODE,"^",7) S ECODE(ECODE)=$P(NODE,"^"),COUNT=COUNT+1
- ;
- ;only one match found, so use it
- Q:COUNT=1 $O(ECODE(0))
- ;
- ;no match found
- Q:'COUNT ""
- ;
- ;multiple matches found, try to match by name
- I COUNT>1 D
- .S ECODE=0
- .S NAME=$P($G(^DIC(8.1,VALUE,0)),"^")
- .F S ECODE=$O(ECODE(ECODE)) Q:'ECODE Q:ECODE(ECODE)=NAME
- Q ECODE
- ;
- ACCEPT(MSGID) ;
- ;Description: Writes an ack (AA) to a global to be transmitted later.
- ;
- ;Inputs:
- ; MSGID -message control id of HL7 msg in the MSH segment
- ;
- ;Outputs: none
- ;
- N MID
- K HL,HLMID,HLMTIEN,HLDT,HLDT1
- D INIT^HLFNC2(HLEID,.HL)
- D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
- S HLEVN=1
- S MID=HLMID_"-"_HLEVN
- D MSH^HLFNC2(.HL,MID,.HLRES)
- S ^TMP("HLS",$J,1)=HLRES
- ;
- ;it seems HLFS sometimes disappears upon reaching this point
- I $G(HLFS)="" S HLFS="^"
- ;
- S ^TMP("HLS",$J,2)="MSA"_HLFS_"AA"_HLFS_MSGID
- Q
- ;
- MVERRORS ;
- ;Error messages were being deleted from ^TMP("HLS",$J by another package
- ;during the upload. To fix this, errors are written to another
- ;subscript, then moved when the error list is complete.
- ;
- M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J)
- K ^TMP("IVM","HLS",$J)
- Q
- ;
- ;DJS, Added Extrinsic Function to determine if multiple segments are present ; DG*5.3*935
- CHKNXT(DGNVAL,DGNSEG) ; Check the SEG in the next segment manually
- ; DGNVAL = CURLINE or CURLINE+1
- ; DGNSEG = SEG (3 character SEG)
- ; Returns 1 if there is a match or 0 if there is no match
- ;
- Q $S($E($G(^TMP($J,IVMRTN,+DGNVAL,0)),1,3)=DGNSEG:1,1:0)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENUPL1 13227 printed Jan 18, 2025@03:43:59 Page 2
- 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
- +2 ;
- PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST,DGNMSE,DGHBP,DGOTH,DGZHF) ;
- +1 ;
- +2 ;Description: This function parses the HL7 segments. It creates arrays
- +3 ;defined by the PATIENT, ENROLLMENT, ELIGIBILY, CATASTROPHIC DISABILITY,
- +4 ;OEF/OIF CONFLICT objects.
- +5 ;Field values are put in DHCP format and the validity at the
- +6 ;field level is tested. Fields to be deleted are set to "@".
- +7 ;
- +8 ;Input:
- +9 ; MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file (772)
- +10 ; MSGID -message control id of HL7 msg in the MSH segment
- +11 ; CURLINE - the subscript of the PID segment of the current message (pass by reference)
- +12 ; ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by ref)
- +13 ;
- +14 ;Output:
- +15 ; Function Value: Returns 1 on success, 0 on failure.
- +16 ; CURLINE - upon leaving the procedure this parameter should be set to the end of the current message.
- +17 ; ERRCOUNT - set to count of messages that were not processed due to errors encountered. (pass by ref)
- +18 ; DGPAT - array defined by the PATIENT object. (pass by ref)
- +19 ; DGENR - array defined by the PATIENT ENROLLMENT object. (pass by ref)
- +20 ; DGELG - array defined by the PATIENT ELIGIBILITY object. (pass by ref)
- +21 ; DGCDIS - array defined by the CATASTROPHIC DISABILITY object. (pass by ref)
- +22 ; DGSEC - array defined by the PATIENT SECURITY object. (pass by ref)
- +23 ; DGOEIF - array defined by the OEF/OIF CONFLICT object. (pass by ref)
- +24 ; DGNTR - array defined for NTR data.
- +25 ; DGMST - array defined for MST data.
- +26 ; DGNMSE - array define for MILITARY SERVICE EPISODE data (pass by ref)
- +27 ; DGHBP - array define for HEALTH BENEFIT PLAN data (pass by ref) DG*5.3*871
- +28 ; DGOTH - array for OTH data (passed by ref)
- +29 ; DGZHF - array for Presumptive Psychosis data (pass by ref) DG*5.3*1082
- +30 ;
- +31 NEW SEG,ERROR,COUNT,QFLG,NFLG,DGCCPC
- +32 ;
- +33 ;DJS, Set TMP global to track the presence of ZMH segment; DG*5.3*935
- +34 KILL ^TMP($JOB,"DGENUPL")
- SET ^TMP($JOB,"DGENUPL","ZMH",0)=0
- +35 ;
- +36 KILL DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST
- +37 ;
- +38 SET ERROR=0
- SET NFLG=1
- +39 FOR SEG="PID","ZPD","ZIE","ZIO","ZEL"
- Begin DoDot:1
- +40 if NFLG
- DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +41 IF SEG="ZIO"
- IF SEG("TYPE")'="ZIO"
- SET NFLG=0
- QUIT
- +42 IF SEG("TYPE")=SEG
- Begin DoDot:2
- +43 ; DG*5.3*894
- IF SEG'="ZEL"
- NEW DGRTN
- SET DGRTN=SEG_"^DGENUPL2"
- DO @DGRTN
- +44 if (SEG="ZEL")
- DO ZEL^DGENUPL2(1)
- +45 SET NFLG=1
- End DoDot:2
- QUIT
- +46 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
- +47 SET ERROR=1
- +48 ;
- +49 ;possible that in a bad message we are now past the end
- +50 SET CURLINE=CURLINE-1
- End DoDot:1
- if ERROR
- QUIT
- +51 ;
- +52 ;DJS, Set segment before processing possible multiple segments; DG*5.3*935
- +53 IF 'ERROR
- SET SEG="ZEL"
- FOR COUNT=2:1
- DO NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG)
- if (SEG("TYPE")'="ZEL")
- QUIT
- Begin DoDot:1
- +54 SET CURLINE=CURLINE+1
- +55 DO ZEL^DGENUPL2(COUNT)
- End DoDot:1
- if ERROR
- QUIT
- +56 ;
- +57 ;ZE2 is optional, If no ZE2 segment delete pension data
- +58 IF 'ERROR
- Begin DoDot:1
- +59 IF SEG("TYPE")="ZE2"
- DO ZE2^DGENUPLB
- SET CURLINE=CURLINE+1
- QUIT
- +60 IF SEG("TYPE")'="ZE2"
- Begin DoDot:2
- +61 if $$GET1^DIQ(2,DFN,.3852,"I")=$ORDER(^DG(27.18,"C","00",""))
- QUIT
- +62 NEW PSUB
- +63 FOR PSUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4"
- SET DGPAT(PSUB)="@"
- End DoDot:2
- End DoDot:1
- +64 ;
- +65 ; DG*5.3*1082 - ZHF is optional
- +66 IF 'ERROR
- SET SEG="ZHF"
- IF $$CHKNXT(CURLINE+1,SEG)
- Begin DoDot:1
- +67 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +68 IF SEG("TYPE")="ZHF"
- DO ZHF^DGENUPLB
- QUIT
- End DoDot:1
- +69 ;
- +70 ; ZTE is optional and repeatable DG*5.3*952
- +71 KILL DGOTH
- IF 'ERROR
- SET SEG="ZTE"
- IF $$CHKNXT(CURLINE+1,SEG)
- Begin DoDot:1
- +72 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +73 SET QFLG=0
- FOR
- Begin DoDot:2
- +74 IF SEG("TYPE")'="ZTE"
- SET QFLG=1
- SET CURLINE=CURLINE-1
- QUIT
- +75 DO ZTE^DGENUPLB
- +76 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +77 QUIT
- End DoDot:2
- if QFLG
- QUIT
- +78 QUIT
- End DoDot:1
- +79 ;
- +80 ; ZCE is optional and repeatable DG*5.3*1014
- +81 SET DGCCPC=0
- +82 KILL DGOTH
- IF 'ERROR
- SET SEG="ZCE"
- IF $$CHKNXT(CURLINE+1,SEG)
- Begin DoDot:1
- +83 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +84 SET QFLG=0
- FOR
- Begin DoDot:2
- +85 IF SEG("TYPE")'="ZCE"
- SET QFLG=1
- SET CURLINE=CURLINE-1
- QUIT
- +86 DO ZCE^DGENUPLB
- +87 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +88 QUIT
- End DoDot:2
- if QFLG
- QUIT
- +89 QUIT
- End DoDot:1
- +90 ;
- +91 ;ZHP is optional & can repeat. DG*5.3*871
- +92 KILL DGHBP
- +93 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- +94 IF 'ERROR
- SET SEG="ZHP"
- IF $$CHKNXT(CURLINE+1,SEG)
- Begin DoDot:1
- +95 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +96 ;DG*5.3*996; JAM; Trap error - do not continue processing
- SET QFLG=0
- FOR
- Begin DoDot:2
- +97 IF SEG("TYPE")'="ZHP"
- SET QFLG=1
- SET CURLINE=CURLINE-1
- QUIT
- +98 ;DG*5.3*996; JAM; Trap error - do not continue processing
- DO ZHP^DGENUPLB
- if ERROR
- QUIT
- +99 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- End DoDot:2
- if QFLG!(ERROR)
- QUIT
- End DoDot:1
- if ERROR
- QUIT $SELECT(ERROR:0,1:1)
- +100 ;
- +101 ;Phase II Add the capability to accept more than 1 ZCD
- +102 IF 'ERROR
- FOR SEG="ZEN","ZMT","ZCD"
- Begin DoDot:1
- +103 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +104 IF SEG("TYPE")=SEG
- Begin DoDot:2
- +105 ; DG*5.3*894
- NEW DGRTN
- SET DGRTN=SEG_"^DGENUPL2"
- DO @DGRTN
- End DoDot:2
- +106 IF '$TEST
- Begin DoDot:2
- +107 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
- +108 SET ERROR=1
- +109 ;
- +110 ;possible that in a bad message we are now past the end
- +111 SET CURLINE=CURLINE-1
- End DoDot:2
- End DoDot:1
- if ERROR
- QUIT
- +112 ;
- +113 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- +114 IF 'ERROR
- SET SEG="ZCD"
- IF $$CHKNXT(CURLINE+1,SEG)
- FOR COUNT=2:1
- DO NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG)
- if (SEG("TYPE")'="ZCD")
- QUIT
- Begin DoDot:1
- +115 SET CURLINE=CURLINE+1
- +116 DO ZCD^DGENUPL2
- End DoDot:1
- if ERROR
- QUIT
- +117 ;
- +118 ; Purple Heart/OEF-OIF Addition of optional ZMH segment
- +119 ; Modified handling of ZSP and ZRD to accommodate ZMH
- +120 ;
- +121 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- +122 IF 'ERROR
- SET SEG="ZSP"
- IF $$CHKNXT(CURLINE+1,SEG)
- Begin DoDot:1
- +123 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +124 IF SEG("TYPE")="ZSP"
- DO ZSP^DGENUPL2
- QUIT
- +125 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
- +126 SET ERROR=1
- +127 ;possible that in a bad message we are now past the end
- +128 SET CURLINE=CURLINE-1
- End DoDot:1
- if ERROR
- QUIT $SELECT(ERROR:0,1:1)
- +129 ;
- +130 ;Modified following code to receive multiple ZMH segment for
- +131 ;Military service information - DG*5.3*653
- +132 ;
- +133 ;DJS, Check for no MSE ZMH segments present and non-MSE ZMH segments ; DG*5.3*959
- +134 ; DG*5.3*972 ;HM - remove Q:ERROR and let code quit with value below
- IF 'ERROR
- SET SEG="ZMH"
- Begin DoDot:1
- +135 NEW SEGNAM,MSECNT,CURLN,MHSTYP,NONMSE,SGMNT
- SET SEGNAM=""
- SET (MSECNT,NONMSE)=0
- SET CURLN=CURLINE
- +136 FOR
- SET CURLN=$ORDER(^TMP($JOB,IVMRTN,CURLN))
- if 'CURLN
- QUIT
- Begin DoDot:2
- +137 SET SGMNT=$GET(^TMP($JOB,IVMRTN,CURLN,0))
- SET SEGNAM=$PIECE($GET(SGMNT),U)
- if SEGNAM'="ZMH"
- QUIT
- SET MHSTYP=$PIECE($GET(SGMNT),U,3)
- +138 IF "^SL^SNL^SNNL^MSD^FDD^"[("^"_MHSTYP_"^")
- SET MSECNT=MSECNT+1
- QUIT
- +139 ;ZMH segment present, but not an MSE
- IF '$TEST
- SET NONMSE=NONMSE+1
- QUIT
- End DoDot:2
- +140 ;DJS, No MSE-type ZMH segment present, so branch to DGNOZMH to kill HEC-owned MSEs; DG*5.3*935
- +141 IF MSECNT=0
- IF ^TMP($JOB,"DGENUPL","ZMH",0)=0
- DO EN^DGNOZMH(DFN)
- KILL ^TMP($JOB,"DGENUPL")
- +142 if ('NONMSE&('MSECNT))
- QUIT
- +143 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- +144 SET QFLG=0
- FOR
- Begin DoDot:2
- +145 IF '$$CHKNXT(CURLINE+1,SEG)
- SET QFLG=1
- QUIT
- +146 ;process any ZMH segments that are present in Z11
- DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +147 DO ZMH^DGENUPL2
- End DoDot:2
- if QFLG!(ERROR)
- QUIT
- End DoDot:1
- +148 ;
- +149 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- +150 IF 'ERROR
- SET SEG="ZRD"
- IF $$CHKNXT(CURLINE+1,SEG)
- FOR COUNT=2:1
- DO NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG)
- if (SEG("TYPE")'="ZRD")
- QUIT
- Begin DoDot:1
- +151 SET CURLINE=CURLINE+1
- +152 DO ZRD^DGENUPL2
- End DoDot:1
- if ERROR
- QUIT
- +153 ;
- +154 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
- +155 IF 'ERROR
- SET SEG="OBX"
- FOR
- Begin DoDot:1
- +156 ;possible if OBX segment not present that we are now past the end
- +157 if '$$CHKNXT(CURLINE+1,SEG)
- QUIT
- +158 DO NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
- +159 DO OBX^DGENUPL2
- +160 QUIT
- End DoDot:1
- if (ERROR!('$$CHKNXT(CURLINE+1,SEG)))
- QUIT
- +161 ;
- +162 KILL ^TMP($JOB,"DGENUPL")
- +163 QUIT $SELECT(ERROR:0,1:1)
- +164 ;
- CONVERT(VAL,DATATYPE,ERROR) ;
- +1 ;Description: Converts the value found in the HL7 segment to DHCP format
- +2 ;
- +3 ;Input:
- +4 ; VAL - value parsed from the HL7 segment
- +5 ; DATATYPE: indicates the type of conversion necessary
- +6 ; "DATE" - needs to be converted to FM format
- +7 ; "TS" - time stamp, needs to be converted to FM format
- +8 ; "Y/N" - 0->"N",1->"Y"
- +9 ; "1/0" - "Y"->1,"N"->0
- +10 ; "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file
- +11 ; "ELIGIBILITY" - VAL is a pointer to the national eligibility code file (#8.1), needs to be converted to a local eligibility code (file #8)
- +12 ;
- +13 ; "MT" - VAL is a Means Test Status code, it needs to be converted
- +14 ; to a pointer to the Means Test Status file
- +15 ; Phase II convert code to RSN IEN for DGCDIS object
- +16 ; "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5)
- +17 ; "CDDSCR" data type converts the codes descriptor(s) to DSCR IEN. (HL7TODSC^DGENA5) DG*5.3*894
- +18 ; "EXT" convert from code to abbreviation
- +19 ; "POS" convert from Period of Service code to a point to Period of Service file
- +20 ; "AGENCY" convert Agency/Allied Country code from file 35
- +21 ; "PENSIONCD" convert Pension Award/Termination Reason code from file 27.18
- +22 ; "HBP" convert from code to file 25.11 ien DG*5.3*871
- +23 ;OUTPUT:
- +24 ; Function Value - the result of the conversion
- +25 ; ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref)
- +26 SET ERROR=0
- +27 Begin DoDot:1
- +28 IF VAL=""
- QUIT
- +29 IF VAL=""""""
- SET VAL="@"
- QUIT
- +30 IF $GET(DATATYPE)="EXT"
- Begin DoDot:2
- +31 SET VAL=$$HLTOLIMB^DGENA5(VAL)
- End DoDot:2
- QUIT
- +32 IF $GET(DATATYPE)="CDRSN"
- Begin DoDot:2
- +33 SET VAL=$$HL7TORSN^DGENA5(VAL)
- End DoDot:2
- QUIT
- +34 ; * check the new DESCRIPTOR seq - DG*5.3*894
- +35 IF $GET(DATATYPE)="CDDSCR"
- Begin DoDot:2
- +36 SET VAL=$$HL7TODSC^DGENA5(VAL)
- End DoDot:2
- QUIT
- +37 IF ($GET(DATATYPE)="MT")
- Begin DoDot:2
- +38 SET VAL=$ORDER(^DG(408.32,"AC",1,VAL,0))
- +39 IF 'VAL
- SET ERROR=1
- End DoDot:2
- QUIT
- +40 IF ($GET(DATATYPE)="DATE")
- Begin DoDot:2
- +41 IF $LENGTH(VAL)'=8
- SET ERROR=1
- QUIT
- +42 SET VAL=$$FMDATE^HLFNC(VAL)
- +43 IF ((VAL'=+VAL)!($LENGTH($PIECE(VAL,"."))<7))
- SET ERROR=1
- End DoDot:2
- QUIT
- +44 IF ($GET(DATATYPE)="TS")
- Begin DoDot:2
- +45 IF $LENGTH(VAL)<8
- SET ERROR=1
- QUIT
- +46 SET VAL=$$FMDATE^HLFNC(VAL)
- +47 IF ((VAL'=+VAL)!($LENGTH($PIECE(VAL,"."))<7))
- SET ERROR=1
- End DoDot:2
- QUIT
- +48 IF ($GET(DATATYPE)="Y/N")
- Begin DoDot:2
- +49 IF VAL=0
- SET VAL="N"
- QUIT
- +50 IF VAL=1
- SET VAL="Y"
- QUIT
- +51 SET ERROR=1
- End DoDot:2
- QUIT
- +52 IF ($GET(DATATYPE)="1/0")
- Begin DoDot:2
- +53 IF VAL="N"
- SET VAL=0
- QUIT
- +54 IF VAL="Y"
- SET VAL=1
- QUIT
- +55 SET ERROR=1
- End DoDot:2
- QUIT
- +56 IF ($GET(DATATYPE)="ELIGIBILITY")
- Begin DoDot:2
- +57 SET VAL=$$MAP(VAL)
- +58 IF 'VAL
- SET ERROR=1
- End DoDot:2
- QUIT
- +59 IF ($GET(DATATYPE)="INSTITUTION")
- Begin DoDot:2
- +60 NEW OLDVAL
- +61 SET OLDVAL=VAL
- +62 SET VAL=$ORDER(^DIC(4,"D",OLDVAL,0))
- +63 IF 'VAL
- SET VAL=$ORDER(^DIC(4,"D",(+OLDVAL),0))
- +64 IF 'VAL
- SET ERROR=1
- End DoDot:2
- QUIT
- +65 IF ($GET(DATATYPE)="POS")
- Begin DoDot:2
- +66 NEW OLDVAL
- +67 SET OLDVAL=VAL
- +68 SET VAL=$ORDER(^DIC(21,"D",OLDVAL,0))
- +69 IF 'VAL
- SET ERROR=1
- End DoDot:2
- QUIT
- +70 IF ($GET(DATATYPE)="AGENCY")
- Begin DoDot:2
- +71 NEW OLDVAL
- +72 SET OLDVAL=VAL
- +73 SET VAL=$ORDER(^DIC(35,"C",OLDVAL,0))
- +74 IF 'VAL
- SET ERROR=1
- End DoDot:2
- QUIT
- +75 IF ($GET(DATATYPE)="PENSIONCD")
- Begin DoDot:2
- +76 NEW OLDVAL
- +77 SET OLDVAL=VAL
- +78 SET VAL=$ORDER(^DG(27.18,"C",OLDVAL,0))
- +79 IF 'VAL
- SET ERROR=1
- End DoDot:2
- QUIT
- +80 ; DG*5.3*871
- IF ($GET(DATATYPE)="HBP")
- Begin DoDot:2
- +81 NEW OLDVAL
- +82 SET OLDVAL=VAL
- +83 SET VAL=$ORDER(^DGHBP(25.11,"C",OLDVAL,0))
- +84 IF 'VAL
- SET ERROR=1
- End DoDot:2
- QUIT
- End DoDot:1
- +85 QUIT VAL
- +86 ;
- 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)
- +2 ;
- +3 ;Input: VALUE - ien of an entry in file #8.1
- +4 ;
- +5 ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8
- +6 ;
- +7 NEW ECODE,NODE,COUNT,NAME
- +8 ;try to choose a code from file 8 to use that is appropriate
- +9 SET (COUNT,ECODE)=0
- +10 ;
- +11 FOR
- SET ECODE=$ORDER(^DIC(8,"D",VALUE,ECODE))
- if 'ECODE
- QUIT
- Begin DoDot:1
- +12 SET NODE=$GET(^DIC(8,ECODE,0))
- +13 ;put code on list if active
- +14 IF (NODE'="")
- IF '$PIECE(NODE,"^",7)
- SET ECODE(ECODE)=$PIECE(NODE,"^")
- SET COUNT=COUNT+1
- End DoDot:1
- +15 ;
- +16 ;only one match found, so use it
- +17 if COUNT=1
- QUIT $ORDER(ECODE(0))
- +18 ;
- +19 ;no match found
- +20 if 'COUNT
- QUIT ""
- +21 ;
- +22 ;multiple matches found, try to match by name
- +23 IF COUNT>1
- Begin DoDot:1
- +24 SET ECODE=0
- +25 SET NAME=$PIECE($GET(^DIC(8.1,VALUE,0)),"^")
- +26 FOR
- SET ECODE=$ORDER(ECODE(ECODE))
- if 'ECODE
- QUIT
- if ECODE(ECODE)=NAME
- QUIT
- End DoDot:1
- +27 QUIT ECODE
- +28 ;
- ACCEPT(MSGID) ;
- +1 ;Description: Writes an ack (AA) to a global to be transmitted later.
- +2 ;
- +3 ;Inputs:
- +4 ; MSGID -message control id of HL7 msg in the MSH segment
- +5 ;
- +6 ;Outputs: none
- +7 ;
- +8 NEW MID
- +9 KILL HL,HLMID,HLMTIEN,HLDT,HLDT1
- +10 DO INIT^HLFNC2(HLEID,.HL)
- +11 DO CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
- +12 SET HLEVN=1
- +13 SET MID=HLMID_"-"_HLEVN
- +14 DO MSH^HLFNC2(.HL,MID,.HLRES)
- +15 SET ^TMP("HLS",$JOB,1)=HLRES
- +16 ;
- +17 ;it seems HLFS sometimes disappears upon reaching this point
- +18 IF $GET(HLFS)=""
- SET HLFS="^"
- +19 ;
- +20 SET ^TMP("HLS",$JOB,2)="MSA"_HLFS_"AA"_HLFS_MSGID
- +21 QUIT
- +22 ;
- MVERRORS ;
- +1 ;Error messages were being deleted from ^TMP("HLS",$J by another package
- +2 ;during the upload. To fix this, errors are written to another
- +3 ;subscript, then moved when the error list is complete.
- +4 ;
- +5 MERGE ^TMP("HLS",$JOB)=^TMP("IVM","HLS",$JOB)
- +6 KILL ^TMP("IVM","HLS",$JOB)
- +7 QUIT
- +8 ;
- +9 ;DJS, Added Extrinsic Function to determine if multiple segments are present ; DG*5.3*935
- CHKNXT(DGNVAL,DGNSEG) ; Check the SEG in the next segment manually
- +1 ; DGNVAL = CURLINE or CURLINE+1
- +2 ; DGNSEG = SEG (3 character SEG)
- +3 ; Returns 1 if there is a match or 0 if there is no match
- +4 ;
- +5 QUIT $SELECT($EXTRACT($GET(^TMP($JOB,IVMRTN,+DGNVAL,0)),1,3)=DGNSEG:1,1:0)