ADEGRL34 ; IHS/ANMC/HMW - PROCESS 'IH' CODES ;
;;6.0;ADE;**10,11,26**;APRIL 1999;Build 13
;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
;
IH(ADEPAT,ADEVDATE) ;EP
;IHS/ANMC/HMW 10-31-2001 Patch 10
;IHS/ANMC/HMW 8-14-2002 Patch 11 added prompts for broken and cancelled appt codes
;ADA Codes begining with 'IH' are IHS-created codes used to track patient dental treatment and status.
;Dental patients must receive at least one IH code per fiscal year.
;This routine checks patient dental treatment history in ADEHXC for existence
;of any 'IH' code for fiscal year of visit date.
;
;INPUT:
; ADEPAT Patient DFN
; ADEVDATE Visit Date
;
;UPDATE:
; ADEV( and ADEDES( arrays
;
;RETURN:
;If an IH code exists for visit's FY, returns +1
;If no record of an IH code, prompts user for an IH code and
; Returns -1 if user does not select an IH code
; Returns +1 if a proper IH code selected
;
N ADEIH,ADEIHD,ADEFY,ADEHIT,ADEVFM,%DT,J,DIR,DTOUT,DUOUT,DIRUT,DIROUT,Y
N ADETXT,ADEAGE
I ADECON Q 1 ;No IH code necessary on CONTRACT visits
S X=ADEVDATE,%DT="T" D ^%DT S ADEVFM=Y
I '+ADEVFM Q 0
S ADEFY=$P($$FISCAL^XBDT(ADEVFM),U)
;
;$O Through ADEXHC("IH") looking for at least one code that occurred during this FY
S ADEIH="IH",ADEHIT=0
F S ADEIH=$O(ADEHXC(ADEIH)) Q:ADEIH'["IH" D Q:ADEHIT
. S ADEIHD=0
. F S ADEIHD=$O(ADEHXC(ADEIH,ADEIHD)) Q:'+ADEIHD D Q:ADEHIT
. . I ADEFY=$P($$FISCAL^XBDT(ADEIHD),U) S ADEHIT=1
. . Q
. Q
;
I ADEHIT Q 1 ;An IH code exists for the visit's FY
;
D LIST^ADEGRL3
;
S ADEAGE=$G(AGE)
S DIR(0)="SX^"
;/IHS/OIT/GAB 11.2014 Patch #26 Removed below 2 lines to replace 9130 & 9140 with 2015 codes 9986 & 9987
;S DIR(0)=DIR(0)_"BA:9130 - Broken Appointment;"
;S DIR(0)=DIR(0)_"CA:9140 - Cancelled Appointment;"
;/IHS/OIT/GAB 11.2014 Patch #26 Added below 2 lines to change to 9986 & 9987 for 2015 code updates
S DIR(0)=DIR(0)_"BA:9986 - Broken Appointment;"
S DIR(0)=DIR(0)_"CA:9987 - Cancelled Appointment;"
S DIR(0)=DIR(0)_"0:IH70 - PATIENT ASSESSED FOR OBJECTIVES;"
I ADEAGE>0&(ADEAGE<20) S DIR(0)=DIR(0)_"1:IH71 - CARIES FREE PATIENT;"
I ADEAGE>0&(ADEAGE<20) S DIR(0)=DIR(0)_"2:IH72 - UNTREATED TOOTH DECAY;"
I ADEAGE>0&(ADEAGE<20) S DIR(0)=DIR(0)_"3:IH73 - PERMANENT MOLAR SEALANT(S);"
I ADEAGE>14&(ADEAGE<46) S DIR(0)=DIR(0)_"4:IH74 - ACCEPTABLE PERIO (AGE 15-45);"
I ADEAGE>14&(ADEAGE<46) S DIR(0)=DIR(0)_"5:IH75 - DEEP POCKETING (AGE 15-45);"
I ADEAGE>14&(ADEAGE<46) S DIR(0)=DIR(0)_"6:IH76 - MISSING TEETH DUE TO DISEASE;"
I ADEAGE>14&(ADEAGE<75) S DIR(0)=DIR(0)_"7:IH77 - BECAME EDENTULOUS AT THIS VISIT"
S DIR("?")="Patient is "_ADEAGE_" years old. Select the appropriate 'IH' code"
S DIR("A")="Select Oral Health Code"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) Q 0
;/IHS/OIT/GAB 11.2014 Patch #26 modified below If statement to replace 9130 with 2015 code 9986
I Y="BA" D Q 1
. K ADEV,ADEDES
. ;S ADEV("9130")="1^"
. ;S ADEDES("9130")="BROKEN APPT"
. S ADEV("9986")="1^"
. S ADEDES("9986")="BROKEN APPT"
;/IHS/OIT/GAB 11.2014 Patch #26 modified below If statement to replace 9140 with 2015 code 9987
I Y="CA" D Q 1
. K ADEV,ADEDES
. ;S ADEV("9140")="1^"
. ;S ADEDES("9140")="CANCELLED APPT"
. S ADEV("9987")="1^"
. S ADEDES("9987")="CANCELLED APPT"
I Y?1N,Y>-1,Y<8 S Y="IH7"_Y
I Y'["IH" Q 0
S ADEV(Y)="1^"
S ADETXT="IH70:ASSESSED;"
S ADETXT=ADETXT_"IH71:CARIES FREE;"
S ADETXT=ADETXT_"IH72:UNTREATED DECAY;"
S ADETXT=ADETXT_"IH73:MOLAR SEALANTS;"
S ADETXT=ADETXT_"IH74:GINGIVITIS;"
S ADETXT=ADETXT_"IH75:DEEP POCKETS;"
S ADETXT=ADETXT_"IH76:TOOTH LOSS;"
S ADETXT=ADETXT_"IH77:PATIENT EDENT"
S ADEDES(Y)=$P(ADETXT,Y_":",2),ADEDES(Y)=$P(ADEDES(Y),";")
Q 1
ADEGRL34 ; IHS/ANMC/HMW - PROCESS 'IH' CODES ;
+1 ;;6.0;ADE;**10,11,26**;APRIL 1999;Build 13
+2 ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
+3 ;
IH(ADEPAT,ADEVDATE) ;EP
+1 ;IHS/ANMC/HMW 10-31-2001 Patch 10
+2 ;IHS/ANMC/HMW 8-14-2002 Patch 11 added prompts for broken and cancelled appt codes
+3 ;ADA Codes begining with 'IH' are IHS-created codes used to track patient dental treatment and status.
+4 ;Dental patients must receive at least one IH code per fiscal year.
+5 ;This routine checks patient dental treatment history in ADEHXC for existence
+6 ;of any 'IH' code for fiscal year of visit date.
+7 ;
+8 ;INPUT:
+9 ; ADEPAT Patient DFN
+10 ; ADEVDATE Visit Date
+11 ;
+12 ;UPDATE:
+13 ; ADEV( and ADEDES( arrays
+14 ;
+15 ;RETURN:
+16 ;If an IH code exists for visit's FY, returns +1
+17 ;If no record of an IH code, prompts user for an IH code and
+18 ; Returns -1 if user does not select an IH code
+19 ; Returns +1 if a proper IH code selected
+20 ;
+21 NEW ADEIH,ADEIHD,ADEFY,ADEHIT,ADEVFM,%DT,J,DIR,DTOUT,DUOUT,DIRUT,DIROUT,Y
+22 NEW ADETXT,ADEAGE
+23 ;No IH code necessary on CONTRACT visits
IF ADECON
QUIT 1
+24 SET X=ADEVDATE
SET %DT="T"
DO ^%DT
SET ADEVFM=Y
+25 IF '+ADEVFM
QUIT 0
+26 SET ADEFY=$PIECE($$FISCAL^XBDT(ADEVFM),U)
+27 ;
+28 ;$O Through ADEXHC("IH") looking for at least one code that occurred during this FY
+29 SET ADEIH="IH"
SET ADEHIT=0
+30 FOR
SET ADEIH=$ORDER(ADEHXC(ADEIH))
IF ADEIH'["IH"
QUIT
Begin DoDot:1
+31 SET ADEIHD=0
+32 FOR
SET ADEIHD=$ORDER(ADEHXC(ADEIH,ADEIHD))
IF '+ADEIHD
QUIT
Begin DoDot:2
+33 IF ADEFY=$PIECE($$FISCAL^XBDT(ADEIHD),U)
SET ADEHIT=1
+34 QUIT
End DoDot:2
IF ADEHIT
QUIT
+35 QUIT
End DoDot:1
IF ADEHIT
QUIT
+36 ;
+37 ;An IH code exists for the visit's FY
IF ADEHIT
QUIT 1
+38 ;
+39 DO LIST^ADEGRL3
+40 ;
+41 SET ADEAGE=$GET(AGE)
+42 SET DIR(0)="SX^"
+43 ;/IHS/OIT/GAB 11.2014 Patch #26 Removed below 2 lines to replace 9130 & 9140 with 2015 codes 9986 & 9987
+44 ;S DIR(0)=DIR(0)_"BA:9130 - Broken Appointment;"
+45 ;S DIR(0)=DIR(0)_"CA:9140 - Cancelled Appointment;"
+46 ;/IHS/OIT/GAB 11.2014 Patch #26 Added below 2 lines to change to 9986 & 9987 for 2015 code updates
+47 SET DIR(0)=DIR(0)_"BA:9986 - Broken Appointment;"
+48 SET DIR(0)=DIR(0)_"CA:9987 - Cancelled Appointment;"
+49 SET DIR(0)=DIR(0)_"0:IH70 - PATIENT ASSESSED FOR OBJECTIVES;"
+50 IF ADEAGE>0&(ADEAGE<20)
SET DIR(0)=DIR(0)_"1:IH71 - CARIES FREE PATIENT;"
+51 IF ADEAGE>0&(ADEAGE<20)
SET DIR(0)=DIR(0)_"2:IH72 - UNTREATED TOOTH DECAY;"
+52 IF ADEAGE>0&(ADEAGE<20)
SET DIR(0)=DIR(0)_"3:IH73 - PERMANENT MOLAR SEALANT(S);"
+53 IF ADEAGE>14&(ADEAGE<46)
SET DIR(0)=DIR(0)_"4:IH74 - ACCEPTABLE PERIO (AGE 15-45);"
+54 IF ADEAGE>14&(ADEAGE<46)
SET DIR(0)=DIR(0)_"5:IH75 - DEEP POCKETING (AGE 15-45);"
+55 IF ADEAGE>14&(ADEAGE<46)
SET DIR(0)=DIR(0)_"6:IH76 - MISSING TEETH DUE TO DISEASE;"
+56 IF ADEAGE>14&(ADEAGE<75)
SET DIR(0)=DIR(0)_"7:IH77 - BECAME EDENTULOUS AT THIS VISIT"
+57 SET DIR("?")="Patient is "_ADEAGE_" years old. Select the appropriate 'IH' code"
+58 SET DIR("A")="Select Oral Health Code"
+59 DO ^DIR
+60 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT 0
+61 ;/IHS/OIT/GAB 11.2014 Patch #26 modified below If statement to replace 9130 with 2015 code 9986
+62 IF Y="BA"
Begin DoDot:1
+63 KILL ADEV,ADEDES
+64 ;S ADEV("9130")="1^"
+65 ;S ADEDES("9130")="BROKEN APPT"
+66 SET ADEV("9986")="1^"
+67 SET ADEDES("9986")="BROKEN APPT"
End DoDot:1
QUIT 1
+68 ;/IHS/OIT/GAB 11.2014 Patch #26 modified below If statement to replace 9140 with 2015 code 9987
+69 IF Y="CA"
Begin DoDot:1
+70 KILL ADEV,ADEDES
+71 ;S ADEV("9140")="1^"
+72 ;S ADEDES("9140")="CANCELLED APPT"
+73 SET ADEV("9987")="1^"
+74 SET ADEDES("9987")="CANCELLED APPT"
End DoDot:1
QUIT 1
+75 IF Y?1N
IF Y>-1
IF Y<8
SET Y="IH7"_Y
+76 IF Y'["IH"
QUIT 0
+77 SET ADEV(Y)="1^"
+78 SET ADETXT="IH70:ASSESSED;"
+79 SET ADETXT=ADETXT_"IH71:CARIES FREE;"
+80 SET ADETXT=ADETXT_"IH72:UNTREATED DECAY;"
+81 SET ADETXT=ADETXT_"IH73:MOLAR SEALANTS;"
+82 SET ADETXT=ADETXT_"IH74:GINGIVITIS;"
+83 SET ADETXT=ADETXT_"IH75:DEEP POCKETS;"
+84 SET ADETXT=ADETXT_"IH76:TOOTH LOSS;"
+85 SET ADETXT=ADETXT_"IH77:PATIENT EDENT"
+86 SET ADEDES(Y)=$PIECE(ADETXT,Y_":",2)
SET ADEDES(Y)=$PIECE(ADEDES(Y),";")
+87 QUIT 1
