Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ADEGRL34

ADEGRL34.m

Go to the documentation of this file. 
  1. ADEGRL34 ; IHS/ANMC/HMW - PROCESS 'IH' CODES ;
  1.  ;;6.0;ADE;**10,11,26**;APRIL 1999;Build 13
  1.  ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
  1.  ;
  1. IH(ADEPAT,ADEVDATE) ;EP
  1.  ;IHS/ANMC/HMW 10-31-2001 Patch 10
  1.  ;IHS/ANMC/HMW 8-14-2002 Patch 11 added prompts for broken and cancelled appt codes
  1.  ;ADA Codes begining with 'IH' are IHS-created codes used to track patient dental treatment and status.
  1.  ;Dental patients must receive at least one IH code per fiscal year.
  1.  ;This routine checks patient dental treatment history in ADEHXC for existence
  1.  ;of any 'IH' code for fiscal year of visit date.
  1.  ;
  1.  ;INPUT:
  1.  ;       ADEPAT Patient DFN
  1.  ;       ADEVDATE Visit Date
  1.  ;
  1.  ;UPDATE:
  1.  ;       ADEV( and ADEDES( arrays
  1.  ;
  1.  ;RETURN:
  1.  ;If an IH code exists for visit's FY, returns +1
  1.  ;If no record of an IH code, prompts user for an IH code and
  1.  ;       Returns -1 if user does not select an IH code
  1.  ;       Returns +1 if a proper IH code selected
  1.  ;
  1.  N ADEIH,ADEIHD,ADEFY,ADEHIT,ADEVFM,%DT,J,DIR,DTOUT,DUOUT,DIRUT,DIROUT,Y
  1.  N ADETXT,ADEAGE
  1.  I ADECON Q 1 ;No IH code necessary on CONTRACT visits
  1.  S X=ADEVDATE,%DT="T" D ^%DT S ADEVFM=Y
  1.  I '+ADEVFM Q 0
  1.  S ADEFY=$P($$FISCAL^XBDT(ADEVFM),U)
  1.  ;
  1.  ;$O Through ADEXHC("IH") looking for at least one code that occurred during this FY
  1.  S ADEIH="IH",ADEHIT=0
  1.  F  S ADEIH=$O(ADEHXC(ADEIH)) Q:ADEIH'["IH"  D  Q:ADEHIT
  1.  . S ADEIHD=0
  1.  . F  S ADEIHD=$O(ADEHXC(ADEIH,ADEIHD)) Q:'+ADEIHD  D  Q:ADEHIT
  1.  . . I ADEFY=$P($$FISCAL^XBDT(ADEIHD),U) S ADEHIT=1
  1.  . . Q
  1.  . Q
  1.  ;
  1.  I ADEHIT Q 1 ;An IH code exists for the visit's FY
  1.  ;
  1.  D LIST^ADEGRL3
  1.  ;
  1.  S ADEAGE=$G(AGE)
  1.  S DIR(0)="SX^"
  1.  ;/IHS/OIT/GAB 11.2014 Patch #26 Removed below 2 lines to replace 9130 & 9140 with 2015 codes 9986 & 9987
  1.  ;S DIR(0)=DIR(0)_"BA:9130 - Broken Appointment;"
  1.  ;S DIR(0)=DIR(0)_"CA:9140 - Cancelled Appointment;"
  1.  ;/IHS/OIT/GAB 11.2014 Patch #26 Added below 2 lines to change to 9986 & 9987 for 2015 code updates
  1.  S DIR(0)=DIR(0)_"BA:9986 - Broken Appointment;"
  1.  S DIR(0)=DIR(0)_"CA:9987 - Cancelled Appointment;"
  1.  S DIR(0)=DIR(0)_"0:IH70 - PATIENT ASSESSED FOR OBJECTIVES;"
  1.  I ADEAGE>0&(ADEAGE<20) S DIR(0)=DIR(0)_"1:IH71 - CARIES FREE PATIENT;"
  1.  I ADEAGE>0&(ADEAGE<20) S DIR(0)=DIR(0)_"2:IH72 - UNTREATED TOOTH DECAY;"
  1.  I ADEAGE>0&(ADEAGE<20) S DIR(0)=DIR(0)_"3:IH73 - PERMANENT MOLAR SEALANT(S);"
  1.  I ADEAGE>14&(ADEAGE<46) S DIR(0)=DIR(0)_"4:IH74 - ACCEPTABLE PERIO (AGE 15-45);"
  1.  I ADEAGE>14&(ADEAGE<46) S DIR(0)=DIR(0)_"5:IH75 - DEEP POCKETING (AGE 15-45);"
  1.  I ADEAGE>14&(ADEAGE<46) S DIR(0)=DIR(0)_"6:IH76 - MISSING TEETH DUE TO DISEASE;"
  1.  I ADEAGE>14&(ADEAGE<75) S DIR(0)=DIR(0)_"7:IH77 - BECAME EDENTULOUS AT THIS VISIT"
  1.  S DIR("?")="Patient is "_ADEAGE_" years old.  Select the appropriate 'IH' code"
  1.  S DIR("A")="Select Oral Health Code"
  1.  D ^DIR
  1.  I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) Q 0
  1.  ;/IHS/OIT/GAB 11.2014 Patch #26 modified below If statement to replace 9130 with 2015 code 9986
  1.  I Y="BA" D  Q 1
  1.  .  K ADEV,ADEDES
  1.  .  ;S ADEV("9130")="1^"
  1.  .  ;S ADEDES("9130")="BROKEN APPT"
  1.  .  S ADEV("9986")="1^"
  1.  .  S ADEDES("9986")="BROKEN APPT"
  1.  ;/IHS/OIT/GAB 11.2014 Patch #26 modified below If statement to replace 9140 with 2015 code 9987
  1.  I Y="CA" D  Q 1
  1.  .  K ADEV,ADEDES
  1.  .  ;S ADEV("9140")="1^"
  1.  .  ;S ADEDES("9140")="CANCELLED APPT"
  1.  .  S ADEV("9987")="1^"
  1.  .  S ADEDES("9987")="CANCELLED APPT"
  1.  I Y?1N,Y>-1,Y<8 S Y="IH7"_Y
  1.  I Y'["IH" Q 0
  1.  S ADEV(Y)="1^"
  1.  S ADETXT="IH70:ASSESSED;"
  1.  S ADETXT=ADETXT_"IH71:CARIES FREE;"
  1.  S ADETXT=ADETXT_"IH72:UNTREATED DECAY;"
  1.  S ADETXT=ADETXT_"IH73:MOLAR SEALANTS;"
  1.  S ADETXT=ADETXT_"IH74:GINGIVITIS;"
  1.  S ADETXT=ADETXT_"IH75:DEEP POCKETS;"
  1.  S ADETXT=ADETXT_"IH76:TOOTH LOSS;"
  1.  S ADETXT=ADETXT_"IH77:PATIENT EDENT"
  1.  S ADEDES(Y)=$P(ADETXT,Y_":",2),ADEDES(Y)=$P(ADEDES(Y),";")
  1.  Q 1