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

ADE697A.m

Go to the documentation of this file. 
  1. ADE697A ; IHS/DIR/FHL - DENTAL TABLE UPDATES ;  [ 03/24/1999   8:35 AM ]
  1.  ;;6.0;ADE;;APRIL 1999
  1.  ;;This is the Post-Init routine
  1.  ;Q
  1.  ;
  1. START ;EP
  1.  ;
  1.  NEW A,C,DIC,DIE,DLAYGO,DR,E,L,M,N,O,P,R,S,T
  1.  K ^TMP("ADE697",$J)
  1.  ;
  1.  D DASH,RSLT($J("",15)_"IHS DENTAL TABLE UPDATES")
  1.  D DASH,MOD,DASH,ADD,DASH,USE
  1.  D DASH,OPSITE^ADE697B
  1.  D DASH,GROUP^ADE697B,DASH,EDIT^ADE697B
  1.  D DASH,COMPILE^ADE697C
  1.  Q
  1.  ;
  1. ADDOK(L) ;EP
  1.  D RSLT($J("",5)_"Added : "_L) Q
  1. ADDFAIL(L) ;EP
  1.  D RSLT($J("",5)_"Error: "_"Add Failed => "_L) Q
  1. MODOK(L) ;EP
  1.  D RSLT($J("",5)_"Changed : "_L) Q
  1. RSLT(%) ;EP
  1.  S ^TMP("ADE697",$J,0)=$G(^TMP("ADE697",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
  1.  W:'$D(ZTQUEUED) !,% Q
  1. DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("") Q
  1. DIE(DIE,DA,DR)     ;EP
  1.  K Y
  1.  LOCK +(@(DIE_DA_")")):10
  1.  E  D RSLT($J("",5)_"ERROR: "_"Entry '"_DIE_DA_"' Is locked -- unable to edit.") Q "ERROR"
  1.  D ^DIE
  1.  LOCK -(@(DIE_DA_")"))
  1.  Q "OK"
  1.  ;
  1. FILE(DIC,X,ADEDR,DLAYGO) ;EP
  1.  K DD,DO
  1.  S:ADEDR]"" DIC("DR")=ADEDR
  1.  S DIC(0)="L"
  1.  D FILE^DICN
  1.  Q Y
  1.  ;
  1. ADD ;
  1.  N T,L,ADEJ
  1.  D RSLT("Add ADA Code")
  1.  F ADEJ=1:1:2 S ADERTN="^ADE6A"_ADEJ D
  1.  . F T=1:1 S ADELINE="S L=$T(ADAADD+T"_ADERTN_")" X ADELINE S L=$P(L,";",3) Q:L="END"  D ADAADD(L)
  1.  . Q
  1.  Q
  1.  ;
  1. ADAADD(L) ;
  1.  N ADEJ,N,Y,ADEDR
  1.  F ADEJ=2:1:11 S N(ADEJ-1)=$P(L,U,ADEJ)
  1.  I $D(^AUTTADA("B",N(1))) D RSLT("NOT ADDED: ADA CODE EXISTS => "_N(1)) Q
  1.  S %=$O(^ICD9("AB",N(3),0))
  1.  I '% D RSLT("NOT ADDED: ICD DIAGNOSIS "_N(3)_" DOES NOT EXIST => "_N(1)) Q
  1.  S ADEDR=".02///"_N(2)
  1.  S:N(4)=0 N(4)=""
  1.  F ADEJ=3:1:9 S ADEDR=ADEDR_";.0"_ADEJ_"///"_N(ADEJ)
  1.  S ADEDR=ADEDR_";8801///"_N(10)
  1.  S Y=$$FILE("^AUTTADA(",N(1),ADEDR,9999999.31)
  1.  D ADDFAIL(N(1)):Y<0,ADDOK(N(1)):Y>0
  1.  Q
  1.  ;
  1. USE ;EP
  1.  N ADET,ADEC,ADEWP,ADECNT,ADECOD,ADERET,ADEDA,ADENEXT,ADERR
  1.  D RSLT("Modify ADA CODE 'RECOMMENDED USE' WP Field")
  1.  S ADECOD="",ADERR=""
  1.  F ADET=1:1 S ADEC=$T(ADAUSE+ADET^ADE6U1) S ADEC=$P(ADEC,";",3) D  Q:ADEC="END"
  1.  . S ADENEXT=$E(ADEC,1,4)
  1.  . I (ADECOD'=ADENEXT) D
  1.  . . I (ADECOD]"") D
  1.  . . . I ADEDA D
  1.  . . . . D WP^DIE(9999999.31,ADEDA_",",1101,"","ADEWP","ADERET")
  1.  . . . . D RSLT($J("",5)_ADECOD_" 'USE' added")
  1.  . . . K ADECNT,ADEWP
  1.  . . Q:ADENEXT="END"
  1.  . . S ADECOD=ADENEXT
  1.  . . S ADEDA=$O(^AUTTADA("B",$E(ADECOD,1,4),0))
  1.  . . I 'ADEDA&(ADERR'=ADECOD) D RSLT($J("",5)_"Code "_ADECOD_" Doesn't exist to add 'USE' field")
  1.  . . S:'ADEDA ADERR=ADECOD
  1.  . . S ADECNT=0
  1.  . . Q
  1.  . Q:ADENEXT="END"
  1.  . S ADECNT=ADECNT+1
  1.  . S ADEWP(ADECNT)=$P(ADEC,U,2)
  1.  . Q
  1.  Q
  1.  ;
  1. MOD ;
  1.  N ADET,ADEFROM,ADETO,ADEJ,ADELINE,ADERTN
  1.  D RSLT("ADA Code Changes")
  1.  D CHECK
  1.  F ADEJ=1:1:9 S ADERTN="^ADE6M"_ADEJ D
  1.  . F ADET=1:2 S ADELINE="S ADEFROM=$T(ADAMOD+"_ADET_ADERTN_")" X ADELINE Q:$P(ADEFROM,";",3)="END"  S ADELINE="S ADETO=$T(ADAMOD+"_(ADET+1)_ADERTN_")" X ADELINE D ADAMOD(ADEFROM,ADETO)
  1.  . Q
  1.  Q
  1.  ;
  1. ADAMOD(ADEFROM,ADETO)        ;EP
  1.  ;ADEFROM and ADETO are in the form:
  1.  ;  CODE^DESC^DX^EST MIN^
  1.  ;  LVL^SYN^EXC^INACT^NOOPSITE^MN
  1.  ;
  1.  N ADEJ,ADE,ADEDA,ADEDIE,ADEDR,ADEY
  1.  F ADEJ=2:1:11 S ADE("FROM",ADEJ-1)=$P(ADEFROM,U,ADEJ),ADE("TO",ADEJ-1)=$P(ADETO,U,ADEJ)
  1.  D RSLT($J("",15)_ADE("FROM",1)_"---->"_ADE("TO",1))
  1.  S ADEDA=$O(^AUTTADA("B",ADE("FROM",1),0))
  1.  ;FHL 09/09/98 I 'ADEDA B  S ADEDA=$O(^AUTTADA("B",ADE("TO",1),0))
  1.  I 'ADEDA S ADEDA=$O(^AUTTADA("B",ADE("TO",1),0))
  1.  I 'ADEDA D  Q
  1.  . D RSLT(ADE("FROM",1)_" NOT PRESENT, "_ADE("TO",1)_" WILL BE ADDED.")
  1.  . D ADAADD(U_$P(ADETO,U,2,11))
  1.  . Q
  1.  ; Modify ADA Code
  1.  S ADEDIE="^AUTTADA("
  1.  S ADEDR=".01////"_ADE("TO",1)
  1.  F ADEJ=2:1:9 S ADEDR=ADEDR_";.0"_ADEJ_"///"_ADE("TO",ADEJ)
  1.  S ADEDR=ADEDR_";8801///"_ADE("TO",10)
  1.  S ADEY=$$DIE(ADEDIE,ADEDA,ADEDR)
  1.  I ADEY["ERR" D RSLT("ERROR: EDIT ADA CODE FAILED => "_ADE("FROM",1)) Q
  1.  Q
  1.  ;
  1. CHECK ;Check for exam code changes
  1.  ;
  1.  N ADEDA,ADE
  1.  D CHK1,CHK2,CHK3
  1.  Q
  1. CHK1 S ADEDA=$O(^AUTTADA("B","0140",0))
  1.  Q:'+ADEDA
  1.  Q:'$D(^AUTTADA(ADEDA,0))
  1.  Q:$P(^AUTTADA(ADEDA,0),U,2)'["SCREEN"
  1.  S ADE("FROM")="FROM^0140^SCREENING ORAL EXAM^V72.2^1^0^SCREEN EXAM^^^n^"
  1.  S ADE("TO")="TO^0114^SCREENING ORAL EXAM^V72.2^1^0^SCREEN EXAM^^^n^"
  1.  D ADAMOD(ADE("FROM"),ADE("TO"))
  1.  Q
  1.  ;
  1. CHK2 S ADEDA=$O(^AUTTADA("B","0130",0))
  1.  Q:'+ADEDA
  1.  Q:$D(^AUTTADA("B","0140"))
  1.  S ADE("FROM")="FROM^0130^ORAL EXAMINATION, EMERGENCY^V72.2^5^1^EMERG. EXAM^^^n^EOE"
  1.  S ADE("TO")="TO^0140^ORAL EXAMINATION, EMERGENCY^V72.2^5^1^EMERG. EXAM^^^n^EOE"
  1.  D ADAMOD(ADE("FROM"),ADE("TO"))
  1.  Q
  1.  ;
  1. CHK3 S ADEDA=$O(^AUTTADA("B","0110",0))
  1.  Q:'+ADEDA
  1.  Q:$D(^AUTTADA("B","0150"))
  1.  S ADE("FROM")="FROM^0110^ORAL EXAMINATION, INITIAL^V72.2^15^3^ORAL EXAM INIT.^^^n^IOE"
  1.  S ADE("TO")="TO^0150^ORAL EXAMINATION, INITIAL^V72.2^15^3^ORAL EXAM INIT.^^^n^IOE"
  1.  D ADAMOD(ADE("FROM"),ADE("TO"))
  1.  Q