BADEUTIL.m

BADEUTIL ;IHS/MSC/PLS - Dentrix HL7 inbound interface  ;12-Feb-2010 09:35;PLS

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

 ; Returns patient corresponding to 12 digit facility/hrn code

 ;; Modified - IHS/OIT/GAB 03/2016 **5** Check & Add POV's (ICD10 code) coming from Dentrix

HRCNF(HRCN12) ; EP

 N DFN,ASUFAC,HRN,Y

 S DFN=-1

 S ASUFAC=+$E(HRCN12,1,6),HRN=+$E(HRCN12,7,12)

 Q:'ASUFAC!'HRN DFN

 S ASUFAC=$$FIND1^DIC(9999999.06,,,ASUFAC,"C")

 Q:'ASUFAC DFN

 S Y=0 F  S Y=$O(^AUPNPAT("D",HRN,Y)) Q:'Y  Q:$D(^(Y,ASUFAC))

 S:Y DFN=Y

 Q DFN

 ;

 ; Enable/Disable a protocol

 ; Input: P-Protocol

 ;        T-Text - Null or not passed removes text.

EDPROT(P,T,ERR) ;EP

 N IENARY,PIEN,AIEN,FDA

 S T=$G(T,"")

 D

 .I '$L(P) S ERR="Missing input parameter" Q

 .S IENARY(1)=$$FIND1^DIC(101,"","",P)

 .I 'IENARY(1) S ERR="Unknown protocol name" Q

 .S FDA(101,IENARY(1)_",",2)=$S($L(T):T,1:"@")

 .D UPDATE^DIE("S","FDA","IENARY","ERR")

 Q

 ; Returns default user based on Location

DUSER(LOC) ;EP

 N RET

 S RET=$$GET^XPAR("DIV.`"_LOC_"^SYS","BADE EDR DEFAULT USER")

 Q RET

 ; Returns MERGED TO DFN, when present, traversing the chain

MRGTODFN(DFN) ;EP

 N RES

 S RES=DFN

 Q:'$D(^DPT(DFN,-9)) RES  ;DFN has not been merged

 F  S DFN=$P($G(^DPT(DFN,-9)),U) Q:'DFN  S RES=DFN Q:'$D(^DPT(DFN,-9))

 Q RES

GETPOV    ;IHS/OIT/GAB 03/2016 **5** ADDED THIS SEGMENT - GET THE POV FROM THE FT1 SEGMENT & ADD TO THE VISIT

 S CNT=1,NOPOV="",FIRST=""

 K CODE

 F CNT=1:1:4 D

 .Q:$G(SEGFT1(20,CNT,1,1))=""

 .S CODE(CNT)=(SEGFT1(20,CNT,1,1))

 .S POV=CODE(CNT)

 .I CNT=1 S FIRST=CODE(CNT)

 .Q:FIRST="V72.2"

 .D VALIDPOV^BADEUTIL(POV)

 .I YES=1 D

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

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

 I FIRST="" S NOPOV=1

 Q

VALIDPOV(POV)    ; IHS/OIT/GAB **5** ADD A CHECK FOR A VALID POV COMING FROM DENTRIX

 N STR,IEN

 S YES=""

 S STR=$$ICDDATA^ICDXCODE(30,POV,VISDT,"E")

 S IEN=$P(STR,"^") S:IEN<0 IEN=""

 I IEN="" S YES="" Q   ;SET DEFAULT CODE IF IEN DOESN'T EXIST								; Not a valid code

 S YES=1

 S APCDALVR("APCDTPOV")=POV

 S APCDALVR("APCDTEXK")=APCDTEXK        ; add the EXKEY for the POV entry to associate with the procedure

 Q

HASPOV(V,Y)     ;EP  IHS/OIT/GAB **5** ADD A CHECK FOR DUPLICATE POV's

 ;V is visit ien

 ;Y is value of icd code, e.g. Z98.810

 I '$G(V) Q ""  ;not a valid visit ien

 I '$D(^AUPNVSIT(V,0)) Q ""  ;not a valid visit ien

 NEW X,G,I

 S (X,G)=0

 F  S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!(G)  D

 .S I=$$VAL^XBDIQ1(9000010.07,X,.01)  ;external value of .01 of V POV

 .I I=Y S G=X  ;if it equals Y quit on ien of the V POV, yes, we already have that V POV

 .Q

 Q G

BADEUTIL  ;IHS/MSC/PLS - Dentrix HL7 inbound interface  ;12-Feb-2010 09:35;PLS

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

 +2       ; Returns patient corresponding to 12 digit facility/hrn code

 +3       ;; Modified - IHS/OIT/GAB 03/2016 **5** Check & Add POV's (ICD10 code) coming from Dentrix

HRCNF(HRCN12) ; EP

 +1        NEW DFN,ASUFAC,HRN,Y

 +2        SET DFN=-1

 +3        SET ASUFAC=+$EXTRACT(HRCN12,1,6)

           SET HRN=+$EXTRACT(HRCN12,7,12)

 +4        IF 'ASUFAC!'HRN

               QUIT DFN

 +5        SET ASUFAC=$$FIND1^DIC(9999999.06,,,ASUFAC,"C")

 +6        IF 'ASUFAC

               QUIT DFN

 +7        SET Y=0

           FOR 

               SET Y=$ORDER(^AUPNPAT("D",HRN,Y))

               IF 'Y

                   QUIT 

               IF $DATA(^(Y,ASUFAC))

                   QUIT 

 +8        IF Y

               SET DFN=Y

 +9        QUIT DFN

 +10      ;

 +11      ; Enable/Disable a protocol

 +12      ; Input: P-Protocol

 +13      ;        T-Text - Null or not passed removes text.

EDPROT(P,T,ERR) ;EP

 +1        NEW IENARY,PIEN,AIEN,FDA

 +2        SET T=$GET(T,"")

 +3        Begin DoDot:1

 +4            IF '$LENGTH(P)

                   SET ERR="Missing input parameter"

                   QUIT 

 +5            SET IENARY(1)=$$FIND1^DIC(101,"","",P)

 +6            IF 'IENARY(1)

                   SET ERR="Unknown protocol name"

                   QUIT 

 +7            SET FDA(101,IENARY(1)_",",2)=$SELECT($LENGTH(T):T,1:"@")

 +8            DO UPDATE^DIE("S","FDA","IENARY","ERR")

           End DoDot:1

 +9        QUIT 

 +10      ; Returns default user based on Location

DUSER(LOC) ;EP

 +1        NEW RET

 +2        SET RET=$$GET^XPAR("DIV.`"_LOC_"^SYS","BADE EDR DEFAULT USER")

 +3        QUIT RET

 +4       ; Returns MERGED TO DFN, when present, traversing the chain

MRGTODFN(DFN) ;EP

 +1        NEW RES

 +2        SET RES=DFN

 +3       ;DFN has not been merged

           IF '$DATA(^DPT(DFN,-9))

               QUIT RES

 +4        FOR 

               SET DFN=$PIECE($GET(^DPT(DFN,-9)),U)

               IF 'DFN

                   QUIT 

               SET RES=DFN

               IF '$DATA(^DPT(DFN,-9))

                   QUIT 

 +5        QUIT RES

GETPOV    ;IHS/OIT/GAB 03/2016 **5** ADDED THIS SEGMENT - GET THE POV FROM THE FT1 SEGMENT & ADD TO THE VISIT

 +1        SET CNT=1

           SET NOPOV=""

           SET FIRST=""

 +2        KILL CODE

 +3        FOR CNT=1:1:4

               Begin DoDot:1

 +4                IF $GET(SEGFT1(20,CNT,1,1))=""

                       QUIT 

 +5                SET CODE(CNT)=(SEGFT1(20,CNT,1,1))

 +6                SET POV=CODE(CNT)

 +7                IF CNT=1

                       SET FIRST=CODE(CNT)

 +8                IF FIRST="V72.2"

                       QUIT 

 +9                DO VALIDPOV^BADEUTIL(POV)

 +10               IF YES=1

                       Begin DoDot:2

 +11                       IF '$$HASPOV(APCDVSIT,POV)

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

                               DO EN^APCDALVR

                       End DoDot:2

               End DoDot:1

 +12       IF (FIRST="V72.2")&&('$$HASPOV(APCDVSIT,"ZZZ.999"))

               SET APCDALVR("APCDTPOV")="ZZZ.999"

               SET APCDALVR("APCDTEXK")=APCDTEXK

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

               DO EN^APCDALVR

 +13       IF FIRST=""

               SET NOPOV=1

 +14       QUIT 

VALIDPOV(POV) ; IHS/OIT/GAB **5** ADD A CHECK FOR A VALID POV COMING FROM DENTRIX

 +1        NEW STR,IEN

 +2        SET YES=""

 +3        SET STR=$$ICDDATA^ICDXCODE(30,POV,VISDT,"E")

 +4        SET IEN=$PIECE(STR,"^")

           IF IEN<0

               SET IEN=""

 +5       ;SET DEFAULT CODE IF IEN DOESN'T EXIST								; Not a valid code

           IF IEN=""

               SET YES=""

               QUIT 

 +6        SET YES=1

 +7        SET APCDALVR("APCDTPOV")=POV

 +8       ; add the EXKEY for the POV entry to associate with the procedure

           SET APCDALVR("APCDTEXK")=APCDTEXK

 +9        QUIT 

HASPOV(V,Y) ;EP  IHS/OIT/GAB **5** ADD A CHECK FOR DUPLICATE POV's

 +1       ;V is visit ien

 +2       ;Y is value of icd code, e.g. Z98.810

 +3       ;not a valid visit ien

           IF '$GET(V)

               QUIT ""

 +4       ;not a valid visit ien

           IF '$DATA(^AUPNVSIT(V,0))

               QUIT ""

 +5        NEW X,G,I

 +6        SET (X,G)=0

 +7        FOR 

               SET X=$ORDER(^AUPNVPOV("AD",V,X))

               IF X'=+X!(G)

                   QUIT 

               Begin DoDot:1

 +8       ;external value of .01 of V POV

                   SET I=$$VAL^XBDIQ1(9000010.07,X,.01)

 +9       ;if it equals Y quit on ien of the V POV, yes, we already have that V POV

                   IF I=Y

                       SET G=X

 +10               QUIT 

               End DoDot:1

 +11       QUIT G