BADEHL4.m

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

 ;;1.0;DENTAL/EDR INTERFACE;**1,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 - IHS/OIT/GAB **4** 05/2015 for ICD10 Implementation

 ;; Modified - IHS/OIT/GAB **5** 03/2016 for ICD10 to accept POV from Dentrix (v 8.0.5 or later)

UPD ;EP Update a V Dental entry

 N DIEN,MATCH,DA,APCDVSIT,CODEIEN,APCDSUR,APCDTEE

 N TYPE,TCODE,SCODE,PROV,X,Y,Y2,PIEN,POVIEN2,ADACODE,VTIME

 N NOOPSITE

 S APCDALVR("APCDPAT")=DFN    ;patient

 ;visit stored in V Dental file

 S APCDVSIT=$P($G(^AUPNVDEN(EXKEY,0)),U,3)

 ;Added patient name, DFN, and Visit date. can't add ASUFAC or HLBIEN

 I '$D(^AUPNVSIT(APCDVSIT)) D ACK^BADEHL3(HLMSGIEN,DFN,"Can't update visit "_APCDVSIT_". Not in RPMS:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 S APCDALVR("APCDVSIT")=APCDVSIT

 ;ADA code stored in V Dental file

 S APCDTSC=$P($G(^AUPNVDEN(EXKEY,0)),U,1)

 S ADACODE=$P($G(^AUTTADA(APCDTSC,0)),U,1)

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

 ;See if the provider was changed

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

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

 D CHECKPRV(PROV)

 S APCDALVR("APCDACS")=""

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

 ;Check the date/time in the message

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

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

 I $L(X)=8 D

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

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

 .S X=X_VTIME

 S Y=$$FMDATE^HLFNC(X)

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

 S Y2=$P($G(^AUPNVDEN(EXKEY,12)),U,1)

 ;If the date and time of the visit is different, the old procedure

 ;and possibly the visit must be deleted and everything restarted

 I Y'=Y2 D DEL,NEW^BADEHL3 Q

 ;ADA code in the message

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

 I TCODE="" D ACK^BADEHL3(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=$O(^AUTTADA("B",SCODE,""))

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

 ;Check to see if the code has changed. If the code was changed,

 ;the old code needs to be deleted and a new one stored

 I CODEIEN'=APCDTSC  D DELV,SETUP,ADD

 I SCODE=ADACODE D DELV,SETUP,ADD

 Q

SETUP ;Setup the variables needed to modifiy or add

 N SURGDES

 S APCDALVR("AUPNTALK")=""

 S APCDALVR("APCDANE")=""

 ;number of units

 S APCDALVR("APCDTNOU")=1

 ;Tooth surface

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

 S APCDALVR("APCDTSUR")=APCDTSUR

 ;Fee for procedure

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

 S APCDALVR("APCDTFEE")=APCDTFEE

 ;Date/Time

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

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

 I $L(X)=8 D

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

 .I VTIME="" S VTIME=1138

 .S X=X_VTIME

 S Y=$$FMDATE^HLFNC(X)

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

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

 S APCDALVR("APCDTCDT")=APCDTCDT

 S APCDALVR("APCDTCLN")="DENTAL"

 S APCDALVR("APCDTEXK")=APCDTEXK

 ;Provider

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

 S APCDALVR("APCDTEPR")=PNAME

 S APCDALVR("APCDTPRV")=PNAME

 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(MOD,SURGDES))

 I 'NOOPSITE,'APCDTOS D ACK^BADEHL3(HLMSGIEN,DFN,"No valid ADA code in FT1:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

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

 ; ----- 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),'$L(HOSLOC) S ASUFAC=ASUFAC2

 ;

 S BADEWARN=""

 I $L(HOSLOC)  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 '$L(HOSLOC) D

 .S LOC=$O(^AUTTLOC("C",ASUFAC,"")) I '$L(LOC) S BADERR="No location associated 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 " Q

 .S LOCA=+$P($G(^SC(PARLOC,0)),U,4) I LOCA'=LOC S BADERR=" The LOCATION associated with this ASUFAC and BADE EDR DEFAULT CLINIC is incorrect " Q

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

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

 ;location

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

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

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

 ;S (LOC,PARLOC)=""

 ;S LOC=$O(^AUTTLOC("C",ASUFAC,LOC))

 ;Get the clinic location

 ;I HOSLOC="" D

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

 ;E  D

 .;S PARLOC=+$O(^SC("B",HOSLOC,PARLOC))

 ;I 'PARLOC S BADERR=" Clinic does not exist in RPMS in msg: "_$P($G(^DPT(DFN,0)),"^",1)_" "_DFN_" "_ASUFAC_" "_MIEN D ACK^BADEHL3(BADERR) Q  ;IHS/MSC/VAC 10/2010

 ;I LOC'=$P($G(^SC(PARLOC,0)),U,4) S BADERR=" Clinic "_HOSLOC_" isn't defined for ASUFAC location "_$P($G(^DPT(DFN,0)),"^",1)_" "_DFN_" "_ASUFAC D ACK^BADEHL3(BADERR) Q  ;IHS/MSC/VAC 10/2010

 ;

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

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

 ;External key

 S APCDALVR("APCDTEXK")=APCDTEXK

 Q

MOD S APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"

 D EN^APCDALVR

 Q

ADD S APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"

 D EN^APCDALVR

 Q

DELV S FILE=9000010.05

 D VDEL(FILE,EXKEY,APCDVSIT)

 Q

DEL ;EP  Delete V file entry

 ;Find the entry in the V DENTAL file and the visit

 N MATCH,DIEN,VSIT,DIK,DA,POV,PRV,DCNT,TEXK,DCNT2

 N APCDALVR

 S DIEN=EXKEY

 S TEXK=APCDTEXK

 ;Delete the entry

 I '$D(^AUPNVDEN(DIEN)) D ACK^BADEHL3(HLMSGIEN,DFN,"Can't delete visit "_DIEN_". Not in RPMS:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 S VSIT=$P($G(^AUPNVDEN(+DIEN,0)),U,3)

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

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

 ;Get the dependent count for this visit

 S DCNT=$P(^AUPNVSIT(VSIT,0),U,9)

 ;Delete this entry and quit

 ;I DCNT>3 D							;/IHS/OIT/GAB 3/2016 **5** commented this line

 S FILE=9000010.05

 D VDEL(FILE,DIEN,VSIT)

 S FILE=9000010.07

 D POVDEL(FILE,TEXK,VSIT)               ;/IHS/OIT/GAB 3/2016 **5** DELETE POV AFTER PROCEDURE IS REMOVED 

 I DCNT<2 D PROVDEL(VSIT,PROV)          ;/IHS/OIT/GAB 3/2016 **5** REMOVE PROVIDER ENTRY IF ONE ENTRY LEFT

 ;If its 3, delete the VPOV and VPRV entries then delete the visit

 ;I DCNT<4 D                            ;/IHS/OIT/GAB **5** COMMENTED NEXT 4 LINES-REPLACED WITH ABOVE

 ;.S FILE=9000010.05

 ;.D VDEL(FILE,DIEN,VSIT)

 ;.D CHECK(VSIT,PROV)

 ;Delete visit if dependent count is 0

 I DCNT=0 D VSTDEL(VSIT)

 Q

VDEL(FILE,IEN,VSIT) ;Delete a V-file entry

 N X,DIK,DA

 S DIK=FILE,DA=IEN

 S X=$$DEL^APCDALVR(DIK,DA)

 I X>0 D ACK^BADEHL3(HLMSGIEN,DFN,"Can't delete V file entry:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 Q

VSTDEL(VSIT) ;Delete the visit with zero dependents

 N APCDVDLT,U,APCDVFLE,AUPNVSIT,APCDVNM,APCDVDG,APCDVIGR,APCDVDFN

 N APCDVI,DIK,DA

 S APCDVDLT=VSIT

 D EN^APCDVDLT

 Q

CHECK(VSIT,PROV) ;Remove the POV and PRV if those are the 2 remaining dependent entries

 N POVIEN,MATCH,ICD,VPRV,PROVIEN,ICDIEN,PROV2,PROVIEN2

 ;IHS/OIT/GAB **4**  ADDED BELOW 7 LINES

 S ICD=""

 S I=$$IMP^BADEHL3(VISDT)  ;/IHS/OIT/GAB **4** CK FOR WHICH CODING SYSTEM TO USE

 ;IHS/OIT/GAB **4**  IF I=30 USING ICD10, IF I=1 USING ICD9

 I I=30 D

 .S ICD=$O(^ICD9("AB","ZZZ.999",ICD))

 .I ICD="" S ICD=$O(^ICD9("AB","ZZZ.999 ",ICD))

 I I=1  D

 .I ICD="" S ICD=$O(^ICD9("AB","V72.2",ICD))

 .S:'ICD ICD=$O(^ICD9("AB","V72.2 ",ICD))

 Q:ICD=""

 ;First the POV

 S MATCH=0

 S POVIEN="" F  S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN)) Q:POVIEN=""!(MATCH=1)  D

 .S POVIEN2=$P($G(^AUPNVPOV(POVIEN,0)),U,1)

 .I ICD=POVIEN2 S ICDIEN=POVIEN S MATCH=1

 Q:MATCH=0

 ;Found the POV for this visit so delete the dependent entry

 I MATCH=1 D

 .S FILE=9000010.07

 .D VDEL(FILE,ICDIEN,VSIT)

 ;Next the provider

 S (VPRV,MATCH)=0

 S PROVIEN="" F  S PROVIEN=$O(^AUPNVPRV("AD",VSIT,PROVIEN)) Q:PROVIEN=""!(MATCH=1)  D

 .S PROV2=$P($G(^AUPNVPRV(PROVIEN,0)),U,1)

 .I PROV=PROV2 S PROVIEN2=PROVIEN S MATCH=1

 Q:MATCH=0

 I MATCH=1 D

 .S FILE=9000010.06

 .D VDEL(FILE,PROVIEN2,VSIT)

 ;Recheck the dependent count

 S DCNT=$P(^AUPNVSIT(VSIT,0),U,9)

 Q

CHECKPRV(PROV) ;See if the provider in the message is new

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

 S MATCH=0,PRIM="P" ;IHS/MSC/MGH 7/2010 new var PRIM for patch 1

 ;Find the provider in the existing V dental file

 S DPRV=$P($G(^AUPNVDEN(EXKEY,12)),U,2)

 ;If its the same provider quit

 Q:DPRV=PROV

 ;If its not the same provider, check the visit to see if the new provider

 ;is already on this visit

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

 .;IHS/MSC/MGH patch 1 check for primary

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

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

 .I PROV=PRVIEN S MATCH=1

 ;If this new provider is already attached to this visit we are OK

 Q:MATCH=1

 ;If the new provider is not on this visit,add this provider

 I MATCH=0 D PRV^BADEHL3(PRIM)   ;patch 1 IHS/MSC/MGH

 ;Now we need to see if we need to delete the old provider.

 ;If this provider does not have any procedures attached we will delete

 S MATCH=0

 S IEN="" F  S IEN=$O(^AUPNVDEN("AD",APCDVSIT,IEN)) Q:IEN=""!(MATCH=1)  D

 .S PPRV=$P($G(^AUPNVDEN(IEN,12)),U,2)

 .I PPRV=DPRV&(IEN'=EXKEY) S MATCH=1

 ;This provider is on other procedures

 Q:MATCH=1

 I MATCH=0 D

 .N PP,FDA ;IHS/MSC/MGH patch 1 check for primary

 .S PP=0 ;IHS/MSC/MGH patch 1 check for primary

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

 ..S PROVIEN=$P($G(^AUPNVPRV(PIEN,0)),U,1)

 ..;IHS/MSC/MGH patch 1 check for primary

 ..I $P($G(^AUPNVPRV(PIEN,0)),U,4)="P" S PP=1   ; IHS/MSC/MGH patch 1 We are deleting the primary provider

 ..I PROVIEN=DPRV D

 ...S FILE=9000010.06

 ...D VDEL(FILE,PIEN,APCDVSIT)

 ...;ISH/MSC/MGH PATCH 1  If primary provider was deleted, make the new provider primary

 ...I PP=1 D

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

 .....S PROVIEN=$P($G(^AUPNVPRV(PIEN,0)),U,1)

 .....I PROVIEN=PROV D

 ......S FDA=9000010.06

 ......S FDA=$NA(FDA(FNUM,PIEN_","))

 ......S @FDA@(.04)="P"

 ......K FDA

 ; ----- end ISH/MSC/MGH PATCH 1  If primary provider was deleted

 Q

 ; Returns Dental Operative Code IEN

GETTOS(CODE,DESC) ;EP

 Q:'$L(DESC) 0

 N RET,LP

 S RET=0

 I $L(DESC)>30 D  ;"B" only contains first 30 characters

 .S LP=0 F  S LP=$O(^ADEOPS(LP)) Q:'LP  D  Q:RET

 ..S:$P(^ADEOPS(LP,0),U)=DESC RET=LP

 E  D

 .S RET=+$O(^ADEOPS("B",DESC,0))

 Q RET

POVDEL(FILE,IEN,VSIT)       ;/IHS/OIT/GAB **5** ADDED THIS SEGMENT TO CHECK THE POV ENTRIES & DELETE

 N EKEY,MATCH,VPRV,PROVIEN,PROV2,PROVIEN2

 S ICDIEN="",POVIEN="",POVIEN2="",KEY="",ICD=""

 S EKEY=IEN                 ;SET THE EXTERNAL KEY

 S I=$$IMP^BADEHL3(VISDT)   ;WHICH CODING SYSTEM TO USE ICD9=1 OR ICD10=30

 I I=30 D

 .S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN))

 .Q:POVIEN=""

 .S KEY=$P($G(^AUPNVPOV(POVIEN,12)),U,9)     ; set the external key

 .I KEY  D

 ..S POVIEN="" F  S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN)) Q:POVIEN=""  D

 ...S KEY=$P($G(^AUPNVPOV(POVIEN,12)),U,9)

 ...I KEY=EKEY  D

 ....S ICDIEN=$P($G(^AUPNVPOV(POVIEN,0)),U,1)

 ....I ICDIEN  D

 .....S FILE=9000010.07

 .....S ICDIEN=POVIEN

 .....D VDEL(FILE,ICDIEN,VSIT)

 .E  D                         ;/IHS/OIT/GAB **5** NO EXTERNAL KEY SO SET TO ZZZ.999

 ..S ICD=$O(^ICD9("AB","ZZZ.999",ICD))

 ..I ICD="" S ICD=$O(^ICD9("AB","ZZZ.999 ",ICD))

 ..Q:ICD=""

 ..S MATCH=0

 ..S POVIEN="" F  S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN)) Q:POVIEN=""!(MATCH=1)  D

 ...S POVIEN2=$P($G(^AUPNVPOV(POVIEN,0)),U,1)

 ...I ICD=POVIEN2 S ICDIEN=POVIEN S MATCH=1

 ..Q:MATCH=0

 ..I MATCH=1 D           ;Found the POV for this visit so delete the dependent entry

 ...S FILE=9000010.07

 ...D VDEL(FILE,ICDIEN,VSIT)

 I I=1  D               ;/IHS/OIT/GAB **5** IF NOT ICD10 REMOVE V72.2

 .S ICD=$O(^ICD9("AB","V72.2",ICD))

 .S:'ICD ICD=$O(^ICD9("AB","V72.2 ",ICD))

 .Q:ICD=""

 .S MATCH=0               ;find the POV

 .S POVIEN="" F  S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN)) Q:POVIEN=""!(MATCH=1)  D

 ..S POVIEN2=$P($G(^AUPNVPOV(POVIEN,0)),U,1)

 ..I ICD=POVIEN2 S ICDIEN=POVIEN S MATCH=1

 .Q:MATCH=0

 .I MATCH=1 D                  ;found the match so remove the POV

 ..S FILE=9000010.07

 ..D VDEL(FILE,ICDIEN,VSIT)

 S DCNT=$P(^AUPNVSIT(VSIT,0),U,9)

 Q

PROVDEL(VSIT,PROV)         ;/IHS/OIT/GAB ADDED TO REMOVE PROVIDER ENTRY

 N MATCH,VPRV,PROVIEN,PROV2,PROVIEN2

 S (VPRV,MATCH)=0

 S PROVIEN="" F  S PROVIEN=$O(^AUPNVPRV("AD",VSIT,PROVIEN)) Q:PROVIEN=""!(MATCH=1)  D

 .S PROV2=$P($G(^AUPNVPRV(PROVIEN,0)),U,1)

 .I PROV=PROV2 S PROVIEN2=PROVIEN S MATCH=1

 Q:MATCH=0

 I MATCH=1 D

 .S FILE=9000010.06

 .D VDEL(FILE,PROVIEN2,VSIT)

 S DCNT=$P(^AUPNVSIT(VSIT,0),U,9)      ; Recheck the dependent count

 Q

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

 +1       ;;1.0;DENTAL/EDR INTERFACE;**1,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 - IHS/OIT/GAB **4** 05/2015 for ICD10 Implementation

 +5       ;; Modified - IHS/OIT/GAB **5** 03/2016 for ICD10 to accept POV from Dentrix (v 8.0.5 or later)

UPD       ;EP Update a V Dental entry

 +1        NEW DIEN,MATCH,DA,APCDVSIT,CODEIEN,APCDSUR,APCDTEE

 +2        NEW TYPE,TCODE,SCODE,PROV,X,Y,Y2,PIEN,POVIEN2,ADACODE,VTIME

 +3        NEW NOOPSITE

 +4       ;patient

           SET APCDALVR("APCDPAT")=DFN

 +5       ;visit stored in V Dental file

 +6        SET APCDVSIT=$PIECE($GET(^AUPNVDEN(EXKEY,0)),U,3)

 +7       ;Added patient name, DFN, and Visit date. can't add ASUFAC or HLBIEN

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

           IF '$DATA(^AUPNVSIT(APCDVSIT))

               DO ACK^BADEHL3(HLMSGIEN,DFN,"Can't update visit "_APCDVSIT_". Not in RPMS:")

               QUIT 

 +9        SET APCDALVR("APCDVSIT")=APCDVSIT

 +10      ;ADA code stored in V Dental file

 +11       SET APCDTSC=$PIECE($GET(^AUPNVDEN(EXKEY,0)),U,1)

 +12       SET ADACODE=$PIECE($GET(^AUTTADA(APCDTSC,0)),U,1)

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

 +14      ;See if the provider was changed

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

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

           IF PROV=""

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

               QUIT 

 +17       DO CHECKPRV(PROV)

 +18       SET APCDALVR("APCDACS")=""

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

 +20      ;Check the date/time in the message

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

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

           IF X=""

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

               QUIT 

 +23       IF $LENGTH(X)=8

               Begin DoDot:1

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

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

                   IF VTIME=""

                       SET VTIME=1138

 +26               SET X=X_VTIME

               End DoDot:1

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

 +28      ;/IHS/OIT/GAB CHECK FOR CODING SYSTEM TO USE **4**

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

 +29       SET Y2=$PIECE($GET(^AUPNVDEN(EXKEY,12)),U,1)

 +30      ;If the date and time of the visit is different, the old procedure

 +31      ;and possibly the visit must be deleted and everything restarted

 +32       IF Y'=Y2

               DO DEL

               DO NEW^BADEHL3

               QUIT 

 +33      ;ADA code in the message

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

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

           IF TCODE=""

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

               QUIT 

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

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

 +37      IF '$TEST

               SET SCODE=TCODE

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

 +39       SET APCDALVR("APCDTSC")="`"_CODEIEN

 +40      ;Check to see if the code has changed. If the code was changed,

 +41      ;the old code needs to be deleted and a new one stored

 +42       IF CODEIEN'=APCDTSC

               DO DELV

               DO SETUP

               DO ADD

 +43       IF SCODE=ADACODE

               DO DELV

               DO SETUP

               DO ADD

 +44       QUIT 

SETUP     ;Setup the variables needed to modifiy or add

 +1        NEW SURGDES

 +2        SET APCDALVR("AUPNTALK")=""

 +3        SET APCDALVR("APCDANE")=""

 +4       ;number of units

 +5        SET APCDALVR("APCDTNOU")=1

 +6       ;Tooth surface

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

 +8        SET APCDALVR("APCDTSUR")=APCDTSUR

 +9       ;Fee for procedure

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

 +11       SET APCDALVR("APCDTFEE")=APCDTFEE

 +12      ;Date/Time

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

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

           IF X=""

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

               QUIT 

 +15       IF $LENGTH(X)=8

               Begin DoDot:1

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

 +17               IF VTIME=""

                       SET VTIME=1138

 +18               SET X=X_VTIME

               End DoDot:1

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

 +20      ;/IHS/OIT/GAB CHECK FOR CODING SYSTEM TO USE **4**

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

 +21      ;External format

           DO DD^%DT

           SET APCDTCDT=Y

 +22       SET APCDALVR("APCDTCDT")=APCDTCDT

 +23       SET APCDALVR("APCDTCLN")="DENTAL"

 +24       SET APCDALVR("APCDTEXK")=APCDTEXK

 +25      ;Provider

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

 +27       SET APCDALVR("APCDTEPR")=PNAME

 +28       SET APCDALVR("APCDTPRV")=PNAME

 +29      ; Operative Site Code (may contain text)

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

 +30      ;Operative Site Descriptive Text

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

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

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

           IF 'NOOPSITE

               IF 'APCDTOS

                   DO ACK^BADEHL3(HLMSGIEN,DFN,"No valid ADA code in FT1:")

                   QUIT 

 +33       IF APCDTOS

               SET APCDALVR("APCDTOS")="`"_APCDTOS

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

 +35      ;Find the location and clinic location

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

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

 +38       IF $LENGTH(ASUFAC2)

               IF '$LENGTH(HOSLOC)

                   SET ASUFAC=ASUFAC2

 +39      ;

 +40       SET BADEWARN=""

 +41       IF $LENGTH(HOSLOC)

               Begin DoDot:1

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

                   IF 'PARLOC

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

                       SET HOSLOC=""

                       QUIT 

 +43               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

 +44       IF '$LENGTH(HOSLOC)

               Begin DoDot:1

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

                   IF '$LENGTH(LOC)

                       SET BADERR="No location associated ASUFAC "_ASUFAC_":"

                       QUIT 

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

                   IF 'PARLOC

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

                       QUIT 

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

                   IF LOCA'=LOC

                       SET BADERR=" The LOCATION associated with this ASUFAC and BADE EDR DEFAULT CLINIC is incorrect "

                       QUIT 

               End DoDot:1

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

           IF $LENGTH(BADERR)

               DO ACK^BADEHL3(HLMSGIEN,DFN,BADERR)

               QUIT 

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

           IF $LENGTH(BADEWARN)

               DO ACK^BADEHL3(HLMSGIEN,DFN,BADEWARN)

 +50      ;location

 +51      ;S ASUFAC=$$GET^HLOPRS(.SEGFT1,16,1)

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

 +53      ;I ASUFAC="" D ACK^BADEHL3(HLMSGIEN,DFN,"Missing location in FT1:") Q  ;IHS/MSC/AMF 11/23/10 More descriptive alert

 +54      ;S (LOC,PARLOC)=""

 +55      ;S LOC=$O(^AUTTLOC("C",ASUFAC,LOC))

 +56      ;Get the clinic location

 +57      ;I HOSLOC="" D

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

 +59      ;E  D

 +60      ;S PARLOC=+$O(^SC("B",HOSLOC,PARLOC))

 +61      ;I 'PARLOC S BADERR=" Clinic does not exist in RPMS in msg: "_$P($G(^DPT(DFN,0)),"^",1)_" "_DFN_" "_ASUFAC_" "_MIEN D ACK^BADEHL3(BADERR) Q  ;IHS/MSC/VAC 10/2010

 +62      ;I LOC'=$P($G(^SC(PARLOC,0)),U,4) S BADERR=" Clinic "_HOSLOC_" isn't defined for ASUFAC location "_$P($G(^DPT(DFN,0)),"^",1)_" "_DFN_" "_ASUFAC D ACK^BADEHL3(BADERR) Q  ;IHS/MSC/VAC 10/2010

 +63      ;

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

 +65       SET APCDALVR("APCDLOC")="`"_LOC

 +66      ;External key

 +67       SET APCDALVR("APCDTEXK")=APCDTEXK

 +68       QUIT 

MOD        SET APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"

 +1        DO EN^APCDALVR

 +2        QUIT 

ADD        SET APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"

 +1        DO EN^APCDALVR

 +2        QUIT 

DELV       SET FILE=9000010.05

 +1        DO VDEL(FILE,EXKEY,APCDVSIT)

 +2        QUIT 

DEL       ;EP  Delete V file entry

 +1       ;Find the entry in the V DENTAL file and the visit

 +2        NEW MATCH,DIEN,VSIT,DIK,DA,POV,PRV,DCNT,TEXK,DCNT2

 +3        NEW APCDALVR

 +4        SET DIEN=EXKEY

 +5        SET TEXK=APCDTEXK

 +6       ;Delete the entry

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

           IF '$DATA(^AUPNVDEN(DIEN))

               DO ACK^BADEHL3(HLMSGIEN,DFN,"Can't delete visit "_DIEN_". Not in RPMS:")

               QUIT 

 +8        SET VSIT=$PIECE($GET(^AUPNVDEN(+DIEN,0)),U,3)

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

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

           IF PROV=""

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

               QUIT 

 +11      ;Get the dependent count for this visit

 +12       SET DCNT=$PIECE(^AUPNVSIT(VSIT,0),U,9)

 +13      ;Delete this entry and quit

 +14      ;I DCNT>3 D							;/IHS/OIT/GAB 3/2016 **5** commented this line

 +15       SET FILE=9000010.05

 +16       DO VDEL(FILE,DIEN,VSIT)

 +17       SET FILE=9000010.07

 +18      ;/IHS/OIT/GAB 3/2016 **5** DELETE POV AFTER PROCEDURE IS REMOVED 

           DO POVDEL(FILE,TEXK,VSIT)

 +19      ;/IHS/OIT/GAB 3/2016 **5** REMOVE PROVIDER ENTRY IF ONE ENTRY LEFT

           IF DCNT<2

               DO PROVDEL(VSIT,PROV)

 +20      ;If its 3, delete the VPOV and VPRV entries then delete the visit

 +21      ;I DCNT<4 D                            ;/IHS/OIT/GAB **5** COMMENTED NEXT 4 LINES-REPLACED WITH ABOVE

 +22      ;.S FILE=9000010.05

 +23      ;.D VDEL(FILE,DIEN,VSIT)

 +24      ;.D CHECK(VSIT,PROV)

 +25      ;Delete visit if dependent count is 0

 +26       IF DCNT=0

               DO VSTDEL(VSIT)

 +27       QUIT 

VDEL(FILE,IEN,VSIT) ;Delete a V-file entry

 +1        NEW X,DIK,DA

 +2        SET DIK=FILE

           SET DA=IEN

 +3        SET X=$$DEL^APCDALVR(DIK,DA)

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

           IF X>0

               DO ACK^BADEHL3(HLMSGIEN,DFN,"Can't delete V file entry:")

               QUIT 

 +5        QUIT 

VSTDEL(VSIT) ;Delete the visit with zero dependents

 +1        NEW APCDVDLT,U,APCDVFLE,AUPNVSIT,APCDVNM,APCDVDG,APCDVIGR,APCDVDFN

 +2        NEW APCDVI,DIK,DA

 +3        SET APCDVDLT=VSIT

 +4        DO EN^APCDVDLT

 +5        QUIT 

CHECK(VSIT,PROV) ;Remove the POV and PRV if those are the 2 remaining dependent entries

 +1        NEW POVIEN,MATCH,ICD,VPRV,PROVIEN,ICDIEN,PROV2,PROVIEN2

 +2       ;IHS/OIT/GAB **4**  ADDED BELOW 7 LINES

 +3        SET ICD=""

 +4       ;/IHS/OIT/GAB **4** CK FOR WHICH CODING SYSTEM TO USE

           SET I=$$IMP^BADEHL3(VISDT)

 +5       ;IHS/OIT/GAB **4**  IF I=30 USING ICD10, IF I=1 USING ICD9

 +6        IF I=30

               Begin DoDot:1

 +7                SET ICD=$ORDER(^ICD9("AB","ZZZ.999",ICD))

 +8                IF ICD=""

                       SET ICD=$ORDER(^ICD9("AB","ZZZ.999 ",ICD))

               End DoDot:1

 +9        IF I=1

               Begin DoDot:1

 +10               IF ICD=""

                       SET ICD=$ORDER(^ICD9("AB","V72.2",ICD))

 +11               IF 'ICD

                       SET ICD=$ORDER(^ICD9("AB","V72.2 ",ICD))

               End DoDot:1

 +12       IF ICD=""

               QUIT 

 +13      ;First the POV

 +14       SET MATCH=0

 +15       SET POVIEN=""

           FOR 

               SET POVIEN=$ORDER(^AUPNVPOV("AD",VSIT,POVIEN))

               IF POVIEN=""!(MATCH=1)

                   QUIT 

               Begin DoDot:1

 +16               SET POVIEN2=$PIECE($GET(^AUPNVPOV(POVIEN,0)),U,1)

 +17               IF ICD=POVIEN2

                       SET ICDIEN=POVIEN

                       SET MATCH=1

               End DoDot:1

 +18       IF MATCH=0

               QUIT 

 +19      ;Found the POV for this visit so delete the dependent entry

 +20       IF MATCH=1

               Begin DoDot:1

 +21               SET FILE=9000010.07

 +22               DO VDEL(FILE,ICDIEN,VSIT)

               End DoDot:1

 +23      ;Next the provider

 +24       SET (VPRV,MATCH)=0

 +25       SET PROVIEN=""

           FOR 

               SET PROVIEN=$ORDER(^AUPNVPRV("AD",VSIT,PROVIEN))

               IF PROVIEN=""!(MATCH=1)

                   QUIT 

               Begin DoDot:1

 +26               SET PROV2=$PIECE($GET(^AUPNVPRV(PROVIEN,0)),U,1)

 +27               IF PROV=PROV2

                       SET PROVIEN2=PROVIEN

                       SET MATCH=1

               End DoDot:1

 +28       IF MATCH=0

               QUIT 

 +29       IF MATCH=1

               Begin DoDot:1

 +30               SET FILE=9000010.06

 +31               DO VDEL(FILE,PROVIEN2,VSIT)

               End DoDot:1

 +32      ;Recheck the dependent count

 +33       SET DCNT=$PIECE(^AUPNVSIT(VSIT,0),U,9)

 +34       QUIT 

CHECKPRV(PROV) ;See if the provider in the message is new

 +1       ;IHS/MSC/MGH 7/2010 new var PRIM for patch 1

           NEW VPRV,DPRV,MATCH,PRVIEN,IEN,PPRV,PRIM

 +2       ;IHS/MSC/MGH 7/2010 new var PRIM for patch 1

           SET MATCH=0

           SET PRIM="P"

 +3       ;Find the provider in the existing V dental file

 +4        SET DPRV=$PIECE($GET(^AUPNVDEN(EXKEY,12)),U,2)

 +5       ;If its the same provider quit

 +6        IF DPRV=PROV

               QUIT 

 +7       ;If its not the same provider, check the visit to see if the new provider

 +8       ;is already on this visit

 +9        SET VPRV=""

           FOR 

               SET VPRV=$ORDER(^AUPNVPRV("AD",APCDVSIT,VPRV))

               IF VPRV=""

                   QUIT 

               Begin DoDot:1

 +10      ;IHS/MSC/MGH patch 1 check for primary

 +11               IF $PIECE($GET(^AUPNVPRV(VPRV,0)),U,4)="P"

                       SET PRIM="S"

 +12               SET PRVIEN=$PIECE($GET(^AUPNVPRV(VPRV,0)),U,1)

 +13               IF PROV=PRVIEN

                       SET MATCH=1

               End DoDot:1

 +14      ;If this new provider is already attached to this visit we are OK

 +15       IF MATCH=1

               QUIT 

 +16      ;If the new provider is not on this visit,add this provider

 +17      ;patch 1 IHS/MSC/MGH

           IF MATCH=0

               DO PRV^BADEHL3(PRIM)

 +18      ;Now we need to see if we need to delete the old provider.

 +19      ;If this provider does not have any procedures attached we will delete

 +20       SET MATCH=0