BADEHL3.m

BADEHL3 ;IHS/MSC/MGH/VAC - Dentrix HL7 inbound interface  ;01-Oct-2010

 ;;1.0;DENTAL/EDR INTERFACE;**1,3,4,5**;FEB 22, 2010;Build 23

 ;; Modified - IHS/MSC/AMF - 11/23/10 - More descriptive alert messages

 ;; Modified - IHS/MSC/AMF 10/2010 fix for hospital location FT1-16,2

 ;; Modified - GDIT/KJH Patch 3 - Comment out incorrect call to tag ACK pending further review

 ;; Modified - IHS/OIT/GAB 05/2015 fix for ICD10 Implementation	**4**

 ;; Modified - IHS/OIT/GAB **5** 12/2015 Process POV from Dentrix (v8.0.5 or later)

 ; Return array of message data

 ; Input: MIEN - IEN to HLO MESSAGES and HLO MESSAGE BODY files

 ; Output: DATA

 ;         HLMSTATE

PARSE(DATA,MIEN,HLMSTATE) ;EP

 N SEG,CNT

 Q:'$$STARTMSG^HLOPRS(.HLMSTATE,MIEN)

 M DATA("HDR")=HLMSTATE("HDR")

 S CNT=0

 F  Q:'$$NEXTSEG^HLOPRS(.HLMSTATE,.SEG)  D

 .S CNT=CNT+1

 .M DATA(CNT)=SEG

 Q

 ; Process incoming DFT message

PROC ;EP

 ;todo- check APP ACK TYPE

 N DATA,ARY,SEGPID,SEGPV1,SEGFT1,ERR,RET,DFN,NAME,NOPV1,APTIME,LOC,OUT,PNAME,POV,PROV,PROVFN,PROVLN,PROVMN,SCODE

 N DRG,DCODE,DCODEQ,PVDIEN,DSPNUM,BADIN,APCDALVR,APCDTNOV,APCDVSIT,SEGIEN,SEGRXD,SURGDES,TCODE,TYPE,VTYPE

 N APCDPAT,APCDTNOU,APCDTOS,APCDTSUR,APCDTFEE,APCDTCDT,APCDTPRV,APCDTEPR,APCDTPNT,APCDTEXK,APCDTSC,APCDTOPR,PARLOC

 N HLNAME,HFNAME,LNAME,NAME,DOB,HLDOB,BADERR,BADEWARN,X,Y,IEN,ASUFAC,ASUFAC2,CCODE,CODEIEN,DESC,VTIME,EXKEY,HOSLOC,MOD

 N PRVNPI,NOOPSITE

 S BADERR=""

 S (APCDTOPR,APCDTPNT)=""

 Q:'$G(HLMSGIEN)

 D PARSE(.DATA,HLMSGIEN,.HLMSTATE)

PID ;Get the PID segment and find the correct patient

 S SEGIEN=$$FSEGIEN(.DATA,"PID")

 I 'SEGIEN D ACK(HLMSGIEN,"","Missing PID segment.") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 M SEGPID=DATA(SEGIEN)

 S DFN=$$GET^HLOPRS(.SEGPID,2)

 I DFN="" D ACK(HLMSGIEN,DFN,"Missing DFN in PID:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 ; Get the ASUFAC number

 N ASUFAC,HFCN,FAC

 S X=$$GET^HLOPRS(.SEGPID,3)

 I X="" D ACK(HLMSGIEN,DFN,"Missing ASUFAC in PID:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 S ASUFAC=$E(X,1,6)

 S IEN=$$HRCNF^BADEUTIL(X)

 ; Added new capture of ASUFAC IHS/MSC/VAC 8/2010

 I IEN="" D ACK(HLMSGIEN,DFN,"Missing HRCN in PID:")  Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 ; Check if patient has been merged

 S DFN=$$MRGTODFN^BADEUTIL(DFN)

 I '$D(^DPT(DFN))  D ACK(HLMSGIEN,DFN,"Patient DFN: "_DFN_" not in RPMS.") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 S (APCDPAT,BADIN("PAT"))=DFN

 ; Match on birth dates and last names

 S HLNAME=$$GET^HLOPRS(.SEGPID,5,1)

 S HFNAME=$$GET^HLOPRS(.SEGPID,5,2)

 S HLDOB=$$GET^HLOPRS(.SEGPID,7)

 I $L(HLDOB)>8 S HLDOB=$E(HLDOB,1,8)

 S DOB=$$GET1^DIQ(2,DFN,.03,"I")

 S DOB=$$HLDATE^HLFNC(DOB,"DT")

 S NAME=$$GET1^DIQ(2,DFN,.01),LNAME=$P(NAME,",",1)

 ; I LNAME'=HLNAME S BADERR=" Last names for "_DFN_" do not match in message"

 ; I DOB'=HLDOB S BADERR=" Birth dates for "_DFN_" do not match in message"

 ; I BADERR'="" D ACK(BADERR) Q

PV1 ;Get the PV1 segment and get enough data to create the visit

 S NOPV1=0

 S SEGIEN=$$FSEGIEN(.DATA,"PV1")

 I 'SEGIEN S NOPV1=1

 E  M SEGRXD=DATA(SEGIEN)

FT1 ;Get the FT1 segment

 S SEGIEN=$$FSEGIEN(.DATA,"FT1")

 I 'SEGIEN D ACK(HLMSGIEN,DFN,"Missing FT1 segment:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 M SEGFT1=DATA(SEGIEN)

 ;Get the date/time of visit

 S X=$$GET^HLOPRS(.SEGFT1,4)

 I X="" D ACK(HLMSGIEN,DFN,"Missing visit date in FT1:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 ; If no time on this visit, check the parameter to see if a default time exists

 I $L(X)=8 D

 .S VTIME=$$GET^XPAR("ALL","BADE EDR DEFAULT TIME")

 .S:VTIME="" VTIME=1138 ;IHS/MSC/AMF 10/2010 Change in default visit time

 .S X=X_VTIME

 S Y=$$FMDATE^HLFNC(X)

 I $P(Y,".")>$$DT^XLFDT S BADERR=" " D ACK(HLMSGIEN,DFN,"Future visit date not allowed:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 S VISDT=$P(Y,".")  ;/IHS/OIT/GAB TO CHECK FOR ICD10 DATE **4**

 S BADIN("VISIT DATE")=Y

 D DD^%DT S APCDTCDT=Y   ;External format

 ;This field determines if its new (0), update (2) or delete (1)

 S DESC=$$GET^HLOPRS(.SEGFT1,9)

 S APCDTEXK=$$GET^HLOPRS(.SEGFT1,2)  ;Special code

 I APCDTEXK="" D ACK(HLMSGIEN,DFN,"Missing Dentrix ID in FT1:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 ;First, check to see if this code is already in the V dental file

 S EXKEY="" S EXKEY=$O(^AUPNVDEN("AXK",APCDTEXK,EXKEY))

 I EXKEY'="" D

 .I DESC=0 S BADERR=" Unique id "_APCDTEXK_" already exists " Q

 .;If transaction description is to delete, must find existing entry

 .I DESC=1 D DEL^BADEHL4 Q

 .;If transcaction description is to update, must find existing entry

 .I DESC=2 D UPD^BADEHL4  Q

 I EXKEY="" D

 .I DESC=1 S BADERR="Can't delete Dentrix ID "_APCDTEXK_" doesn't exist:" Q  ;IHS/MSC/AMF 10/2010 eliminate jump out of loop

 .I DESC=2 S BADERR="Can't update Dentrix ID "_APCDTEXK_" doesn't exist:" Q  ;IHS/MSC/AMF 10/2010 eliminate jump out of loop

 .I DESC=0 D NEW

 I $L(BADERR) D ACK(HLMSGIEN,DFN,BADERR) Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 Q

NEW ;Create a new dental procedure

 N DUSER

 S APCDTNOV=1

 S TYPE=$$GET^HLOPRS(.SEGFT1,6)

 S TCODE=$$GET^HLOPRS(.SEGFT1,7)

 I TCODE="" D ACK(HLMSGIEN,DFN,"Missing ADA code in FT1:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 I $E(TCODE,1,1)="D" S SCODE=$E(TCODE,2,$L(TCODE))

 E  S SCODE=TCODE

 S CODEIEN="" S CODEIEN=$O(^AUTTADA("B",SCODE,CODEIEN))

 I CODEIEN="" D ACK(HLMSGIEN,DFN,"ADA code "_TCODE_" not in RPMS:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 S NOOPSITE=$$GET1^DIQ(9999999.31,CODEIEN,.09,"I")="n"

 ;Charge amount

 S APCDTFEE=$$GET^HLOPRS(.SEGFT1,11)

 ; ----- IHS/MSC/AMF 10/2010 fix for FT1-16,2

 ;Find the location and clinic location

 S ASUFAC2=$$GET^HLOPRS(.SEGFT1,16,1)

 S HOSLOC=$$GET^HLOPRS(.SEGFT1,16,2)

 I $L(ASUFAC2) I HOSLOC="" S ASUFAC=ASUFAC2

 ;

 S BADEWARN=""

 S HOSLOC2=0 I $L(HOSLOC) S HOSLOC2=1

 I +HOSLOC2=1  D

 .S PARLOC=+$O(^SC("B",HOSLOC,"")) I 'PARLOC S BADEWARN="Warning: Clinic "_HOSLOC_" is not valid ",HOSLOC="" Q

 .S LOC=+$P($G(^SC(PARLOC,0)),U,4) I LOC="" S BADEWARN="Warning: Location not found for Clinic "_HOSLOC,HOSLOC=""

 I +HOSLOC2=0 D

 .S LOC=$O(^AUTTLOC("C",ASUFAC,"")) I '$L(LOC) S BADERR="No location associated with ASUFAC "_ASUFAC Q

 .S PARLOC=+$$GET^XPAR("DIV.`"_LOC_"^SYS","BADE EDR DEFAULT CLINIC") I 'PARLOC S BADERR=" There is no default clinic for this location "_ASUFAC Q

 .S LOCA=+$P($G(^SC(PARLOC,0)),U,4) I LOCA'=LOC S BADERR="Location, this ASUFAC, and the DEFAULT CLINIC is incorrect "_ASUFAC Q

 I $L(BADERR) D ACK(HLMSGIEN,DFN,BADERR) Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 I $L(BADEWARN) D ACK(HLMSGIEN,DFN,BADEWARN) ;IHS/MSC/AMF 11/23/10 More descriptive alert

 ; ----- end IHS/MSC/AMF 10/2010 fix for FT1-16,2

 ;

 I LOC>0 D

 .S DUZ(2)=LOC  ;SAC Exemption requested

 .S DUSER=$$DUSER^BADEUTIL(LOC)

 .S:DUSER DUZ=DUSER

 S POV=$$GET^HLOPRS(.SEGFT1,19)

 ;Provider ID

 S PROV=+$$GET^HLOPRS(.SEGFT1,20,1)

 ;S PROV="" S PROV=+$O(^VA(200,"ANPI",PRVNPI,PROV))

 I 'PROV D ACK(HLMSGIEN,DFN,"Missing provider in FT1:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 S BADIN("PROVIDER")=PROV

 S PNAME=$P($G(^VA(200,PROV,0)),U,1)

 S PROVLN=$$GET^HLOPRS(.SEGFT1,20,2)

 S PROVFN=$$GET^HLOPRS(.SEGFT1,20,3)

 S PROVMN=$$GET^HLOPRS(.SEGFT1,20,4)

 S MOD=$$GET^HLOPRS(.SEGFT1,26,1)  ;Operative Site Code (may contain text)

 S SURGDES=$$GET^HLOPRS(.SEGFT1,26,2)  ;Operative Site Descriptive Text

 S APCDTOS=$S(NOOPSITE:"",1:$$GETTOS^BADEHL4(MOD,SURGDES))

 I 'NOOPSITE,'APCDTOS S BADERR=" Message lacks a valid ADA Code. Mod/Surg:"_MOD_"/"_SURGDES  D ACK(HLMSGIEN,DFN,BADERR) Q

 S APCDTSUR=$$GET^HLOPRS(.SEGFT1,26,4)  ;Surface Code

 D VISIT

 Q

VISIT ;Create the visit

 S BADIN("PAT")=DFN

 S BADIN("TIME RANGE")=0  ; Try for exact match

 S BADIN("SRV CAT")="A"    ; Ambulatory

 S BADIN("VISIT TYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^(0),U,4),1:"I")

 S CCODE="" S CCODE=$O(^DIC(40.7,"C",56,CCODE))  ;Stop Code

 S BADIN("CLINIC CODE")=CCODE

 S BADIN("HOS LOC")=PARLOC  ;

 S BADIN("SITE")=DUZ(2)

 S BADIN("USR")=DUZ

 S BADIN("APCDOPT")=$$GETOPT()

 S BADIN("NEVER ADD")=1

 S FVST=$$FNDVST(.BADIN)

 I 'FVST D

 .S FVST=$$MAKEVST(.BADIN) ; FAILED TO FIND MATCH

 .S VTYPE="NEW"

 E  D

 .S VTYPE="ADD"

 I 'FVST S BADERR=" Unable to create visit for message "

 I BADERR'="" D ACK(HLMSGIEN,DFN,BADERR) Q

 S APCDVSIT=FVST

 ;Add the data to the dental file

 ;Deletion type to existing visit

 ;IHS/MGH/MGH added parameter to PRV call for patch 1

 I VTYPE="NEW" D POV,PRV("P"),DENT

 ; I VTYPE="ADD" D CHECKPRV,DENT   /IHS/OIT/GAB **5** CHANGED TO BELOW LINE

 I VTYPE="ADD" D POV,CHECKPRV,DENT

 N MSHMSG,MSA

 ;07/18/2013 - KJH - Following line was originally not called because "AL" was never set.

 ;                 - Line became active after a fix to the adapter but calls ACK with wrong number of parameters.

 ;                 - Comment out to restore original functionality until the code can be reviewed further.

 ;I DATA("HDR","APP ACK TYPE")="AL" D ACK(BADERR)

 Q

ACK(HLMSGIEN,DFN,BADERR) ;Send acknowledgement IHS/MSC/AMF 11/23/10 More descriptive alert

 N STR

 I BADERR'="" D

 .S STR="" I $L(DFN) S STR=$E($P($G(^DPT(DFN,0)),U,1),1,15)_" ["_DFN_"]"

 .S BADERR="Msg: "_HLMSGIEN_" "_BADERR_" "_STR

 .D NOTIF(HLMSGIEN,BADERR)

 ; End IHS/MSC/AMF 11/23/10

 N PARMS,ACK,ERR

 I BADERR=""  S PARMS("ACK CODE")="AA",MSHMSG="Transaction successful"

 I BADERR'="" S PARMS("ACK CODE")="AR",MSHMSG=BADERR

 S:PARMS("ACK CODE")'="AA" PARMS("ERROR MESSAGE")=BADERR

 I '$$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR) D NOTIF(HLMSGIEN,ERR) Q

 ; Comment out following line to not send ACK's to Dentrix  IHS/MSC/VAC 8/2010

 ;I '$$SENDACK^HLOAPI2(.ACK,.ERR) D NOTIF(HLMSGIEN,ERR) Q

 Q

POV ;Store the POV

 N APCDALVR,CODE

 S APCDALVR("APCDPAT")=DFN

 S APCDALVR("APCDVSIT")=APCDVSIT

 S APCDALVR("APCDTNQ")="DENTAL/ORAL HEALTH VISIT"

 S APCDALVR("APCDOVRR")=1

 ;S APCDALVR("APCDTPOV")="V72.2"   ;/IHS/OIT/GAB REMOVE FOR ICD10

 ;/IHS/OIT/GAB 4.2015 ADDED NEXT LINE -TO SEE WHICH CODING SYSTEM TO USE

 ;If 1 USE ICD9, 30 USE ICD10 **4**

 S I=$$IMP^BADEHL3(VISDT)

 ;I I=30 S APCDALVR("APCDTPOV")="ZZZ.999"  ;/IHS/OIT/GAB **5** REMOVED & ADD NEXT 6 LINES

 I I=30	 D

  .D GETPOV^BADEUTIL

  .I NOPOV=1  D

  ..S POV="ZZZ.999"

  ..I '$$HASPOV^BADEUTIL(APCDVSIT,POV) S APCDALVR("APCDTPOV")="ZZZ.999" S APCDALVR("APCDTEXK")=APCDTEXK S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]" D EN^APCDALVR

 E  D

 .S APCDALVR("APCDTPOV")="V72.2",POV="V72.2"

 .I '$$HASPOV^BADEUTIL(APCDVSIT,POV) S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]" D EN^APCDALVR   ; **5** historical visits use ICD9  

 ;S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]" D EN^APCDALVR

 K APCDOVRR,APCDALVR("APCDOVRR")

 Q

CHECKPRV ;Check to see if the provider in the message is already on this visit

 ;If not, add the provider

 N VPRV,MATCH,PRVIEN,PRIM ;IHS/MSC/MGH 7/2010 new var PRIM for patch 1

 S PRIM="P"

 S MATCH=0

 S VPRV="" F  S VPRV=$O(^AUPNVPRV("AD",APCDVSIT,VPRV)) Q:VPRV=""  D

 .S PRVIEN=$P($G(^AUPNVPRV(VPRV,0)),U,1)

 .;IHS/MSC/MGH 7/2010 Check for primary provider patch 1

 .I $P($G(^AUPNVPRV(VPRV,0)),U,4)="P" S PRIM="S"

 .I PROV=PRVIEN S MATCH=1

 I MATCH=0 D PRV(PRIM)   ;patch 1 parameter added

 Q

PRV(PRIMARY) ;Store the provider patch 1 added parameter

 N APCDALVR

 S APCDALVR("APCDVSIT")=APCDVSIT

 S APCDALVR("APCDPAT")=DFN

 S APCDALVR("APCDTPRO")="`"_PROV

 S APCDALVR("APCDTPS")=PRIMARY

 I DESC=0 S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]" D EN^APCDALVR

 I DESC=2 S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]" D EN^APCDALVR

 Q

DENT ;Store the procedure

 N APCDALVR

 S APCDALVR("APCDACS")=""

 S APCDALVR("APCDTSC")="`"_CODEIEN

 S APCDALVR("APCDPAT")=DFN

 S APCDALVR("APCDVSIT")=APCDVSIT

 S APCDALVR("AUPNTALK")=""

 S APCDALVR("APCDANE")=""

 S APCDALVR("APCDTNOU")=1

 S APCDALVR("APCDTSUR")=APCDTSUR

 S APCDALVR("APCDTFEE")=APCDTFEE

 S APCDALVR("APCDTCDT")=APCDTCDT

 S APCDALVR("APCDTCLN")="DENTAL"

 S APCDALVR("APCDTEPR")=PNAME

 S APCDALVR("APCDTPRV")=PNAME

 S:APCDTOS APCDALVR("APCDTOS")="`"_APCDTOS

 S APCDALVR("APCDLOC")="`"_LOC

 S APCDALVR("APCDTEXK")=APCDTEXK

 I DESC=0 S APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"

 I DESC=2 S APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"

 D EN^APCDALVR

 ;IHS/FJE patch 1 added alert notification if VDENT is not added in PCC

 D:$D(APCDAFLG) ACK(HLMSGIEN,DFN,"Unable to create Dental Procedure entry in PCC")

 K APCDAFLG

 Q

 ; Return IEN to particular segment

FSEGIEN(SRC,SEG) ;Segment item

 N LP,RES

 S (LP,RES)=0

 F  S LP=$O(SRC(LP)) Q:'LP  D  Q:RES

 .I $G(SRC(LP,"SEGMENT TYPE"))=SEG S RES=LP

 Q RES

 ;Notification on errors

NOTIF(MSGIEN,MSG) ;Send a alert to a mail group

 N XQA,XQAID,XQDATA,XQAMSG

 S XQAMSG="Msg: "_MSGIEN_" "_$G(MSG) ;IHS/MSC/AMF 11/23/10 More descriptive alert

 S XQAID="ADEN,"_DFN_","_50

 S XQDATA="Message Number="_MSGIEN

 S XQA("G.RPMS DENTAL")=""

 D SETUP^XQALERT

 Q

 ; Return Option IEN used to Create

GETOPT() ; EP  IHS/MSC/MGH patch 1

 N RET

 S RET=$$FIND1^DIC(19,,"O","BADE EDR MAIN MENU")

 Q $S(RET:RET,1:"")

 ; Return whether an existing visit can be used or need to create one.

OPT(IEN) ;Check to see if the option n the visit matches the dental option

 N MATCH,OPT

 S MATCH=0

 S OPT=$$GETOPT()

 I $P($G(^AUPNVSIT(IEN,0)),U,24)=OPT S MATCH=1

 Q MATCH

 ; end IHS/MSC/MGH patch 1

FNDVST(CRIT) ;EP

 N IEN,EFLG,OUT,RET

 S RET=0

 D GETVISIT^BSDAPI4(.CRIT,.OUT)

 Q:'OUT(0) 0  ; No visits were found

 S IEN=0,EFLG=0

 F  S IEN=$O(OUT(IEN)) Q:'IEN  D  Q:EFLG

 .I OUT(IEN)="ADD" D

 ..N X

 ..S X="CIANBEVT" X ^%ZOSF("TEST") I $T D BRDCAST^CIANBEVT("PCC."_DFN_".VST",IEN)

 .;IHS/MSC/MGH patch 1 added to check option

 .I $$OPT(IEN) S EFLG=1,RET=IEN Q

 ;IHS/MSC/MGH patch 1 added to check option

 Q $S(RET:RET,OUT(0)=1:$O(OUT(0)),1:0)

 ;

MAKEVST(CRIT) ;EP

 N RET,OUT

 K CRIT("NEVER ADD")

 S CRIT("FORCE ADD")=1

 D GETVISIT^BSDAPI4(.CRIT,.OUT)

 Q:'OUT(0) OUT(0)

 S RET=+$O(OUT(0))

 I OUT(RET)="ADD" D

 .N X

 .S X="CIANBEVT" X ^%ZOSF("TEST") I $T D BRDCAST^CIANBEVT("PCC."_DFN_".VST",RET)

 Q RET

 ;

IMP(D) ;  which coding system should be used

 ;IHS/OIT/GAB ADDED THIS FUNCTION FOR ICD10 **4**

 ;RETURN IEN of entry in ^ICDS

 ;1 = ICD9  30 = ICD10

 ;

 I $G(D)="" S D=DT

 NEW X,Y,IMPDT

 I '$O(^ICDS("F",80,0)) Q 1

 S Y=""

 S X=0 F  S X=$O(^ICDS("F",80,X)) Q:X'=+X  D

 .I $P(^ICDS(X,0),U,4)="" Q   ;NO IMPLEMENTATION DATE

 .S IMPDT=$P(^ICDS(X,0),U,4)

 ;Compare the visit date to ensure it should use ICD10

 I D>(IMPDT-1) S Y=30

 E  S Y=1

 Q Y

BADEHL3   ;IHS/MSC/MGH/VAC - Dentrix HL7 inbound interface  ;01-Oct-2010

 +1       ;;1.0;DENTAL/EDR INTERFACE;**1,3,4,5**;FEB 22, 2010;Build 23

 +2       ;; Modified - IHS/MSC/AMF - 11/23/10 - More descriptive alert messages

 +3       ;; Modified - IHS/MSC/AMF 10/2010 fix for hospital location FT1-16,2

 +4       ;; Modified - GDIT/KJH Patch 3 - Comment out incorrect call to tag ACK pending further review

 +5       ;; Modified - IHS/OIT/GAB 05/2015 fix for ICD10 Implementation	**4**

 +6       ;; Modified - IHS/OIT/GAB **5** 12/2015 Process POV from Dentrix (v8.0.5 or later)

 +7       ; Return array of message data

 +8       ; Input: MIEN - IEN to HLO MESSAGES and HLO MESSAGE BODY files

 +9       ; Output: DATA

 +10      ;         HLMSTATE

PARSE(DATA,MIEN,HLMSTATE) ;EP

 +1        NEW SEG,CNT

 +2        IF '$$STARTMSG^HLOPRS(.HLMSTATE,MIEN)

               QUIT 

 +3        MERGE DATA("HDR")=HLMSTATE("HDR")

 +4        SET CNT=0

 +5        FOR 

               IF '$$NEXTSEG^HLOPRS(.HLMSTATE,.SEG)

                   QUIT 

               Begin DoDot:1

 +6                SET CNT=CNT+1

 +7                MERGE DATA(CNT)=SEG

               End DoDot:1

 +8        QUIT 

 +9       ; Process incoming DFT message

PROC      ;EP

 +1       ;todo- check APP ACK TYPE

 +2        NEW DATA,ARY,SEGPID,SEGPV1,SEGFT1,ERR,RET,DFN,NAME,NOPV1,APTIME,LOC,OUT,PNAME,POV,PROV,PROVFN,PROVLN,PROVMN,SCODE

 +3        NEW DRG,DCODE,DCODEQ,PVDIEN,DSPNUM,BADIN,APCDALVR,APCDTNOV,APCDVSIT,SEGIEN,SEGRXD,SURGDES,TCODE,TYPE,VTYPE

 +4        NEW APCDPAT,APCDTNOU,APCDTOS,APCDTSUR,APCDTFEE,APCDTCDT,APCDTPRV,APCDTEPR,APCDTPNT,APCDTEXK,APCDTSC,APCDTOPR,PARLOC

 +5        NEW HLNAME,HFNAME,LNAME,NAME,DOB,HLDOB,BADERR,BADEWARN,X,Y,IEN,ASUFAC,ASUFAC2,CCODE,CODEIEN,DESC,VTIME,EXKEY,HOSLOC,MOD

 +6        NEW PRVNPI,NOOPSITE

 +7        SET BADERR=""

 +8        SET (APCDTOPR,APCDTPNT)=""

 +9        IF '$GET(HLMSGIEN)

               QUIT 

 +10       DO PARSE(.DATA,HLMSGIEN,.HLMSTATE)

PID       ;Get the PID segment and find the correct patient

 +1        SET SEGIEN=$$FSEGIEN(.DATA,"PID")

 +2       ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF 'SEGIEN

               DO ACK(HLMSGIEN,"","Missing PID segment.")

               QUIT 

 +3        MERGE SEGPID=DATA(SEGIEN)

 +4        SET DFN=$$GET^HLOPRS(.SEGPID,2)

 +5       ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF DFN=""

               DO ACK(HLMSGIEN,DFN,"Missing DFN in PID:")

               QUIT 

 +6       ; Get the ASUFAC number

 +7        NEW ASUFAC,HFCN,FAC

 +8        SET X=$$GET^HLOPRS(.SEGPID,3)

 +9       ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF X=""

               DO ACK(HLMSGIEN,DFN,"Missing ASUFAC in PID:")

               QUIT 

 +10       SET ASUFAC=$EXTRACT(X,1,6)

 +11       SET IEN=$$HRCNF^BADEUTIL(X)

 +12      ; Added new capture of ASUFAC IHS/MSC/VAC 8/2010

 +13      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF IEN=""

               DO ACK(HLMSGIEN,DFN,"Missing HRCN in PID:")

               QUIT 

 +14      ; Check if patient has been merged

 +15       SET DFN=$$MRGTODFN^BADEUTIL(DFN)

 +16      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF '$DATA(^DPT(DFN))

               DO ACK(HLMSGIEN,DFN,"Patient DFN: "_DFN_" not in RPMS.")

               QUIT 

 +17       SET (APCDPAT,BADIN("PAT"))=DFN

 +18      ; Match on birth dates and last names

 +19       SET HLNAME=$$GET^HLOPRS(.SEGPID,5,1)

 +20       SET HFNAME=$$GET^HLOPRS(.SEGPID,5,2)

 +21       SET HLDOB=$$GET^HLOPRS(.SEGPID,7)

 +22       IF $LENGTH(HLDOB)>8

               SET HLDOB=$EXTRACT(HLDOB,1,8)

 +23       SET DOB=$$GET1^DIQ(2,DFN,.03,"I")

 +24       SET DOB=$$HLDATE^HLFNC(DOB,"DT")

 +25       SET NAME=$$GET1^DIQ(2,DFN,.01)

           SET LNAME=$PIECE(NAME,",",1)

 +26      ; I LNAME'=HLNAME S BADERR=" Last names for "_DFN_" do not match in message"

 +27      ; I DOB'=HLDOB S BADERR=" Birth dates for "_DFN_" do not match in message"

 +28      ; I BADERR'="" D ACK(BADERR) Q

PV1       ;Get the PV1 segment and get enough data to create the visit

 +1        SET NOPV1=0

 +2        SET SEGIEN=$$FSEGIEN(.DATA,"PV1")

 +3        IF 'SEGIEN

               SET NOPV1=1

 +4       IF '$TEST

               MERGE SEGRXD=DATA(SEGIEN)

FT1       ;Get the FT1 segment

 +1        SET SEGIEN=$$FSEGIEN(.DATA,"FT1")

 +2       ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF 'SEGIEN

               DO ACK(HLMSGIEN,DFN,"Missing FT1 segment:")

               QUIT 

 +3        MERGE SEGFT1=DATA(SEGIEN)

 +4       ;Get the date/time of visit

 +5        SET X=$$GET^HLOPRS(.SEGFT1,4)

 +6       ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF X=""

               DO ACK(HLMSGIEN,DFN,"Missing visit date in FT1:")

               QUIT 

 +7       ; If no time on this visit, check the parameter to see if a default time exists

 +8        IF $LENGTH(X)=8

               Begin DoDot:1

 +9                SET VTIME=$$GET^XPAR("ALL","BADE EDR DEFAULT TIME")

 +10      ;IHS/MSC/AMF 10/2010 Change in default visit time

                   IF VTIME=""

                       SET VTIME=1138

 +11               SET X=X_VTIME

               End DoDot:1

 +12       SET Y=$$FMDATE^HLFNC(X)

 +13      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF $PIECE(Y,".")>$$DT^XLFDT

               SET BADERR=" "

               DO ACK(HLMSGIEN,DFN,"Future visit date not allowed:")

               QUIT 

 +14      ;/IHS/OIT/GAB TO CHECK FOR ICD10 DATE **4**

           SET VISDT=$PIECE(Y,".")

 +15       SET BADIN("VISIT DATE")=Y

 +16      ;External format

           DO DD^%DT

           SET APCDTCDT=Y

 +17      ;This field determines if its new (0), update (2) or delete (1)

 +18       SET DESC=$$GET^HLOPRS(.SEGFT1,9)

 +19      ;Special code

           SET APCDTEXK=$$GET^HLOPRS(.SEGFT1,2)

 +20      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF APCDTEXK=""

               DO ACK(HLMSGIEN,DFN,"Missing Dentrix ID in FT1:")

               QUIT 

 +21      ;First, check to see if this code is already in the V dental file

 +22       SET EXKEY=""

           SET EXKEY=$ORDER(^AUPNVDEN("AXK",APCDTEXK,EXKEY))

 +23       IF EXKEY'=""

               Begin DoDot:1

 +24               IF DESC=0

                       SET BADERR=" Unique id "_APCDTEXK_" already exists "

                       QUIT 

 +25      ;If transaction description is to delete, must find existing entry

 +26               IF DESC=1

                       DO DEL^BADEHL4

                       QUIT 

 +27      ;If transcaction description is to update, must find existing entry

 +28               IF DESC=2

                       DO UPD^BADEHL4

                       QUIT 

               End DoDot:1

 +29       IF EXKEY=""

               Begin DoDot:1

 +30      ;IHS/MSC/AMF 10/2010 eliminate jump out of loop

                   IF DESC=1

                       SET BADERR="Can't delete Dentrix ID "_APCDTEXK_" doesn't exist:"

                       QUIT 

 +31      ;IHS/MSC/AMF 10/2010 eliminate jump out of loop

                   IF DESC=2

                       SET BADERR="Can't update Dentrix ID "_APCDTEXK_" doesn't exist:"

                       QUIT 

 +32               IF DESC=0

                       DO NEW

               End DoDot:1

 +33      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF $LENGTH(BADERR)

               DO ACK(HLMSGIEN,DFN,BADERR)

               QUIT 

 +34       QUIT 

NEW       ;Create a new dental procedure

 +1        NEW DUSER

 +2        SET APCDTNOV=1

 +3        SET TYPE=$$GET^HLOPRS(.SEGFT1,6)

 +4        SET TCODE=$$GET^HLOPRS(.SEGFT1,7)

 +5       ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF TCODE=""

               DO ACK(HLMSGIEN,DFN,"Missing ADA code in FT1:")

               QUIT 

 +6        IF $EXTRACT(TCODE,1,1)="D"

               SET SCODE=$EXTRACT(TCODE,2,$LENGTH(TCODE))

 +7       IF '$TEST

               SET SCODE=TCODE

 +8        SET CODEIEN=""

           SET CODEIEN=$ORDER(^AUTTADA("B",SCODE,CODEIEN))

 +9       ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF CODEIEN=""

               DO ACK(HLMSGIEN,DFN,"ADA code "_TCODE_" not in RPMS:")

               QUIT 

 +10       SET NOOPSITE=$$GET1^DIQ(9999999.31,CODEIEN,.09,"I")="n"

 +11      ;Charge amount

 +12       SET APCDTFEE=$$GET^HLOPRS(.SEGFT1,11)

 +13      ; ----- IHS/MSC/AMF 10/2010 fix for FT1-16,2

 +14      ;Find the location and clinic location

 +15       SET ASUFAC2=$$GET^HLOPRS(.SEGFT1,16,1)

 +16       SET HOSLOC=$$GET^HLOPRS(.SEGFT1,16,2)

 +17       IF $LENGTH(ASUFAC2)

               IF HOSLOC=""

                   SET ASUFAC=ASUFAC2

 +18      ;

 +19       SET BADEWARN=""

 +20       SET HOSLOC2=0

           IF $LENGTH(HOSLOC)

               SET HOSLOC2=1

 +21       IF +HOSLOC2=1

               Begin DoDot:1

 +22               SET PARLOC=+$ORDER(^SC("B",HOSLOC,""))

                   IF 'PARLOC

                       SET BADEWARN="Warning: Clinic "_HOSLOC_" is not valid "

                       SET HOSLOC=""

                       QUIT 

 +23               SET LOC=+$PIECE($GET(^SC(PARLOC,0)),U,4)

                   IF LOC=""

                       SET BADEWARN="Warning: Location not found for Clinic "_HOSLOC

                       SET HOSLOC=""

               End DoDot:1

 +24       IF +HOSLOC2=0

               Begin DoDot:1

 +25               SET LOC=$ORDER(^AUTTLOC("C",ASUFAC,""))

                   IF '$LENGTH(LOC)

                       SET BADERR="No location associated with ASUFAC "_ASUFAC

                       QUIT 

 +26               SET PARLOC=+$$GET^XPAR("DIV.`"_LOC_"^SYS","BADE EDR DEFAULT CLINIC")

                   IF 'PARLOC

                       SET BADERR=" There is no default clinic for this location "_ASUFAC

                       QUIT 

 +27               SET LOCA=+$PIECE($GET(^SC(PARLOC,0)),U,4)

                   IF LOCA'=LOC

                       SET BADERR="Location, this ASUFAC, and the DEFAULT CLINIC is incorrect "_ASUFAC

                       QUIT 

               End DoDot:1

 +28      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF $LENGTH(BADERR)

               DO ACK(HLMSGIEN,DFN,BADERR)

               QUIT 

 +29      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF $LENGTH(BADEWARN)

               DO ACK(HLMSGIEN,DFN,BADEWARN)

 +30      ; ----- end IHS/MSC/AMF 10/2010 fix for FT1-16,2

 +31      ;

 +32       IF LOC>0

               Begin DoDot:1

 +33      ;SAC Exemption requested

                   SET DUZ(2)=LOC

 +34               SET DUSER=$$DUSER^BADEUTIL(LOC)

 +35               IF DUSER

                       SET DUZ=DUSER

               End DoDot:1

 +36       SET POV=$$GET^HLOPRS(.SEGFT1,19)

 +37      ;Provider ID

 +38       SET PROV=+$$GET^HLOPRS(.SEGFT1,20,1)

 +39      ;S PROV="" S PROV=+$O(^VA(200,"ANPI",PRVNPI,PROV))

 +40      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF 'PROV

               DO ACK(HLMSGIEN,DFN,"Missing provider in FT1:")

               QUIT 

 +41       SET BADIN("PROVIDER")=PROV

 +42       SET PNAME=$PIECE($GET(^VA(200,PROV,0)),U,1)

 +43       SET PROVLN=$$GET^HLOPRS(.SEGFT1,20,2)

 +44       SET PROVFN=$$GET^HLOPRS(.SEGFT1,20,3)

 +45       SET PROVMN=$$GET^HLOPRS(.SEGFT1,20,4)

 +46      ;Operative Site Code (may contain text)

           SET MOD=$$GET^HLOPRS(.SEGFT1,26,1)

 +47      ;Operative Site Descriptive Text

           SET SURGDES=$$GET^HLOPRS(.SEGFT1,26,2)

 +48       SET APCDTOS=$SELECT(NOOPSITE:"",1:$$GETTOS^BADEHL4(MOD,SURGDES))

 +49       IF 'NOOPSITE

               IF 'APCDTOS

                   SET BADERR=" Message lacks a valid ADA Code. Mod/Surg:"_MOD_"/"_SURGDES

                   DO ACK(HLMSGIEN,DFN,BADERR)

                   QUIT 

 +50      ;Surface Code

           SET APCDTSUR=$$GET^HLOPRS(.SEGFT1,26,4)

 +51       DO VISIT

 +52       QUIT 

VISIT     ;Create the visit

 +1        SET BADIN("PAT")=DFN

 +2       ; Try for exact match

           SET BADIN("TIME RANGE")=0

 +3       ; Ambulatory

           SET BADIN("SRV CAT")="A"

 +4        SET BADIN("VISIT TYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^(0),U,4),1:"I")

 +5       ;Stop Code

           SET CCODE=""

           SET CCODE=$ORDER(^DIC(40.7,"C",56,CCODE))

 +6        SET BADIN("CLINIC CODE")=CCODE

 +7       ;

           SET BADIN("HOS LOC")=PARLOC

 +8        SET BADIN("SITE")=DUZ(2)

 +9        SET BADIN("USR")=DUZ

 +10       SET BADIN("APCDOPT")=$$GETOPT()

 +11       SET BADIN("NEVER ADD")=1

 +12       SET FVST=$$FNDVST(.BADIN)

 +13       IF 'FVST

               Begin DoDot:1

 +14      ; FAILED TO FIND MATCH

                   SET FVST=$$MAKEVST(.BADIN)

 +15               SET VTYPE="NEW"

               End DoDot:1

 +16      IF '$TEST

               Begin DoDot:1

 +17               SET VTYPE="ADD"

               End DoDot:1

 +18       IF 'FVST

               SET BADERR=" Unable to create visit for message "

 +19       IF BADERR'=""

               DO ACK(HLMSGIEN,DFN,BADERR)

               QUIT 

 +20       SET APCDVSIT=FVST

 +21      ;Add the data to the dental file

 +22      ;Deletion type to existing visit

 +23      ;IHS/MGH/MGH added parameter to PRV call for patch 1

 +24       IF VTYPE="NEW"

               DO POV

               DO PRV("P")

               DO DENT

 +25      ; I VTYPE="ADD" D CHECKPRV,DENT   /IHS/OIT/GAB **5** CHANGED TO BELOW LINE

 +26       IF VTYPE="ADD"

               DO POV

               DO CHECKPRV

               DO DENT