11:33 AM  27-OCT-98
AUM98.1 Patch 6, SCB Updates 5&6Oct98.  Restore 6 routines and DO ^AUM8106.
A9AUM6
A9AUM6 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 5&6OCT1998 MESSAGES, RPI ; [ 10/27/1998  11:32 AM ]
 ;;98.1;TABLE MAINTENANCE;**6**;NOV 17,1997
 ;
 D START^AUM8106
INTERACT ;EP - Delete routines from interactive call.
 Q:'$L($G(^%ZOSF("DEL")))
 NEW AUM,X
 F AUM=1:1 S X=$P($T(DEL+AUM),";",3) Q:X=""  X ^%ZOSF("DEL") I '$D(ZTQUEUED) W !,X,$E("...........",1,11-$L(X)),"<poof'd>"
 Q
 ;
DEL ;     
 ;;A9AUM5
 ;;AUM8106
 ;;AUM81061
 ;;AUM8106A
 ;;AUM8106M

AUM8106
AUM8106 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 5&6OCT1998 MESSAGES ; [ 10/27/1998  11:32 AM ]
 ;;98.1;TABLE MAINTENANCE;**6**;NOV 17,1997
 ;
 I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
 D HOME^%ZIS,DT^DICRW,HELP("INTRO")
 S (DIR(0),DIR("B"))="Y"
 S DIR("A")="Do you want to queue the update to TaskMan"
 S DIR("??")="^D HELP^AUM8106(""Q2"")"
 D ^DIR
 KILL DIR
 I $D(DIRUT) D HELP("Q2") Q
 G START:'Y
QUE ;
 S %DT="AERSX",%DT("A")="Requested Start Time: ",%DT("B")="T@2015",%DT(0)="NOW"
 D ^%DT
 I Y<1 W !,"QUEUE INFORMATION MISSING - NOT QUEUED" D HELP("Q2") G AUM8106
 S X=+Y
 D H^%DTC
 S ZTDTH=%H_","_%T
 S ZTRTN="START^AUM8106",ZTIO="",ZTDESC=$P($P($T(+1),";",2)," ",4,99)
 D ^%ZTLOAD,HOME^%ZIS
 I $D(ZTSK) W !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",!
 E  W !!,*7,"QUEUE UNSUCCESSFUL.  RESTART UTILITY."
 Q
 ;
START ;EP - From Taskman
 ;
 NEW XMSUB,XMDUZ,XMTEXT,XMY
 KILL ^TMP("AUM8106",$J)
 D START^AUM81061,START^AUM81062
 S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AUM8106"",$J,",XMY(1)="",XMY(DUZ)=""
 D ^XMD
 KILL ^TMP("AUM8106",$J)
 I $D(ZTQUEUED) S ZTREQ="@" Q
 W !!,"The results are in your MailMan 'IN' basket.",!
 I $L($T(DIR^XBDIR)),$$DIR^XBDIR("Y","Want me to delete the routines in this patch","Y") G INTERACT^A9AUM6
 Q
 ;
INTRO ;
 ;;This updates standard tables according to the changes specified in
 ;;the messages time stamped 5Oct98@5:26PM MDT, and 6Oct98@10:09AM MDT.
 ;;Please consult that message, and the mail message produced by this
 ;;update.
 ;;
 ;;###
 ;
Q2 ;
 ;;Answer "Y" if you want to queue this standard table update to TaskMan.
 ;;Answer "N" if you want to run this update interactively.
 ;;
 ;;If you run interactively, results will be displayed on your screen,
 ;;as well as in the mail message sent to you and user 1.  If you queue
 ;;to TaskMan, please read the mail message for results of this update.
 ;;###
 ;
HELP(L) ;EP - Display text at label L.
 W !
 F %=1:1 W !?4,$P($T(@L+%),";",3) Q:$P($T(@L+%+1),";",3)="###"
 Q
 ;

AUM81061
AUM81061 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 5&6OCT1998 MESSAGES ; [ 10/27/1998  11:32 AM ]
 ;;98.1;TABLE MAINTENANCE;**6**;NOV 17,1997
 ;
 Q
 ;
START ;EP
 ;
 NEW A,C,DIC,DIE,DLAYGO,DR,E,L,M,N,O,P,R,S,T
 ;
 S E(0)="ERROR : ",E(1)="NOT ADDED : "
 D RSLT($J("",5)_$P($T(UPDATE^AUM8106A),";",3))
 D DASH,LOCNEW,DASH,CNTYMOD,DASH,COMMNEW,DASH,COMMMOD,DASH,CSCNEW,DASH,PCLASNEW,DASH,PCLASMOD,DASH,CLINNEW,DASH
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDOK D RSLT($J("",5)_"Added : "_L) Q
ADDFAIL D RSLT($J("",5)_E(0)_"ADD FAILED => "_L) Q
DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("") Q
DIE NEW A,C,E,L,M,N,O,P,R,S,T
 LOCK +(@(DIE_DA_")")):10 E  D RSLT($J("",5)_E(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.") S Y=1 Q
 D ^DIE LOCK -(@(DIE_DA_")")) KILL DA,DIE,DR Q
E(L) Q $P($P($T(@L^AUM8106A),";",3),":",1)
IEN(X,%,Y) ;
 S Y=$O(@(X_"""C"",%,0)"))
 I 'Y S Y=$$VAL^AUM8106M(X,%) I Y NEW Z S Z=E D  S:Y<0 Y="" S E=Z
 . NEW A,C,L,M,N,O,P,R,S,V,%
 . S L=Y
 . I X["AREA" NEW X D RSLT("(Add Missing Area)") D ADDAREA D RSLT("(END Add Missing Area)") Q
 . I X["SU" NEW X D RSLT("(Add Missing SU)") D ADDSU D RSLT("(END Add Missing SU)") Q
 . I X["CTY" NEW X D RSLT("(Add Missing County)") D ADDCNTY D RSLT("(END Add Missing County)") Q
 .Q
 D:'Y RSLT($J("",5)_E(0)_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
 Q +Y
DIK NEW A,C,E,L,M,N,O,P,R,S,T D ^DIK KILL DIK Q
FILE NEW A,C,E,L,M,N,O,P,R,S,T K DD,DO S DIC(0)="L" D FILE^DICN KILL DIC Q
MODOK D RSLT($J("",5)_"Changed : "_L) Q
RSLT(%) S ^(0)=$G(^TMP("AUM8106",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ; Return 0th node.  A is file #, rest fields.
 I '$G(A) Q -1
 I '$G(B) Q -1
 F %=67:1:75 Q:'$G(@($C(%)))  S A=+$P(^DD(A,B,0),U,2),B=@($C(%))
 I 'A!('B) Q -1
 I '$D(^DD(A,B,0)) Q -1
 Q U_$P(^DD(A,B,0),U,2)
 ;
 ; -----------------------------------------------------
 ;
ADDAREA ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),A=$P(L,U),N=$P(L,U,2),R=$P(L,U,3),C=$P(L,U,4),L=A_" "_N_" "_R_" "_C
 I $D(^AUTTAREA("B",N)) D RSLT($J("",5)_E(1)_"NAME EXISTS => "_N) Q
 I $D(^AUTTAREA("C",A)) D RSLT($J("",5)_E(1)_"CODE EXISTS => "_A) Q
 S DLAYGO=9999999.21,DIC="^AUTTAREA(",X=N,DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDCNTY ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3),L=S_" "_C_" "_N
 I $D(^AUTTCTY("C",S_C)) D RSLT($J("",5)_E(1)_"CODE EXISTS => "_S_C) Q
 S P("S")=$$IEN("^DIC(5,",S)
 Q:'P("S")
 S DIC="^AUTTCTY(",X=N,DIC("DR")=".02////"_P("S")_";.03///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDSU ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3),L=A_" "_S_" "_N
 I $D(^AUTTSU("C",A_S)) D RSLT($J("",5)_E(1)_"ASU EXISTS => "_A_S) Q
 S P=$$IEN("^AUTTAREA(",A)
 Q:'P
 S DLAYGO=9999999.22,DIC="^AUTTSU(",X=N,DIC("DR")=".02////"_P_";.03///"_S
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
COMMNEW ;
 S E=$$E("COMMNEW")
 D RSLT(E)
 D RSLT($J("",13)_"ST CT COM NAME"_$J("",28)_"AA SU")
 D RSLT($J("",13)_"-- -- --- ----"_$J("",28)_"-- --")
 F T=1:1 S L=$T(COMMNEW+T^AUM8106A) Q:$P(L,";",3)="END"  D ADDCOMM
 Q
 ;
ADDCOMM ;
 S L=$P(L,";;",2),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6),L=S_" "_O_" "_C_" "_N_$J("",32-$L(N))_A_" "_V
 I $D(^AUTTCOM("C",S_O_C)) D RSLT($J("",5)_E(1)_"STCTYCOM CODE EXISTS => "_S_O_C) Q
 S P("O")=$$IEN^AUM81061("^AUTTCTY(",S_O)
 Q:'P("O")
 S P("A")=$$IEN^AUM81061("^AUTTAREA(",A)
 Q:'P("A")
 S P("V")=$$IEN^AUM81061("^AUTTSU(",A_V)
 Q:'P("V")
 S DLAYGO=9999999.05,DIC="^AUTTCOM(",X=N,DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
COMMMOD ;
 S E=$$E("COMMMOD")
 D RSLT(E)
 D RSLT($J("",15)_"ST CT COM NAME"_$J("",28)_"AA SU")
 D RSLT($J("",15)_"-- -- --- ----"_$J("",28)_"-- --")
 F T=1:2 S L=$T(COMMMOD+T^AUM8106A) Q:$P(L,";",3)="END"  S L("TO")=$T(COMMMOD+T+1^AUM8106A) D
 . S L=$P(L,U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3)
 . S P=$O(^AUTTCOM("C",S_O_C,0))
 . S L=$P(L("TO"),U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6)
 . I 'P S P=$O(^AUTTCOM("C",S_O_C,0)) I 'P S L=";;"_L D ADDCOMM Q
 . S L=S_" "_O_" "_C_" "_N_$J("",32-$L(N))_A_" "_V
 . S P("O")=$$IEN^AUM81061("^AUTTCTY(",S_O)
 . Q:'P("O")
 . S P("A")=$$IEN^AUM81061("^AUTTAREA(",A)
 . Q:'P("A")
 . S P("V")=$$IEN^AUM81061("^AUTTSU(",A_V)
 . Q:'P("V")
 . S DIE="^AUTTCOM(",DA=P,DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"CHANGE FAILED => "_L) Q
 . D MODOK
 .Q
 ;
 ; Line below is comment'd if the only change is to the name of the community.
 ; D DASH,RSLT($$COMMMOD^AUMXPORT("AUM8106A")_" patients marked for export because of the Community Code changes.")
 Q
 ;
 ; -----------------------------------------------------
 ;
LOCNEW ;
 S E=$$E("LOCNEW")
 D RSLT(E)
 D RSLT($J("",13)_"AA SU FA NAME"_$J("",28)_"PSEUDO")
 D RSLT($J("",13)_"-- -- -- ----"_$J("",28)_"------")
 F T=1:1 S L=$T(LOCNEW+T^AUM8106A) Q:$P(L,";",3)="END"  D ADDLOC
 Q
 ;
ADDLOC ;
 S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4),P=$P(L,U,5)
 S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_P
 S %=A_S_F,%=$O(^AUTTLOC("C",%,0))
 I % D RSLT($J("",5)_E(1)_"ASUFAC EXISTS => "_A_S_F) D  Q
 . I $P($G(^AUTTLOC(%,0)),U,21) S DIE="^AUTTLOC(",DA=%,DR=".27///@" D DIE D:$D(Y) RSLT($J("",5)_E(0)_"DELETE INACTIVE DATE FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"INACTIVE DATE DELETED => "_L)
 . S %=$O(^AUTTLOC("C",A_S_F,0)),%=$P(^AUTTLOC(%,0),U)
 . I %,$D(^DIC(4,%,0)),N'=$P(^DIC(4,%,0),U) S DIE="^DIC(4,",DA=%,DR=".01///"_N D DIE D:$D(Y) RSLT($J("",5)_E(0)_"EDIT INSTITUTION FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"INSTITUTION NAME UPDATED => "_L)
 . S %=$O(^AUTTLOC("C",A_S_F,0))
 . I P'=$P($G(^AUTTLOC(%,1)),U,2) S DIE="^AUTTLOC(",DA=%,DR=".31///"_P D DIE D:$D(Y) RSLT($J("",5)_E(0)_"EDIT PSEUDO PREFIX FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"PSEUDO PREFIX UPDATED => "_L)
 .Q
 S P("A")=$$IEN("^AUTTAREA(",A)
 Q:'P("A")
 S P("S")=$$IEN("^AUTTSU(",A_S)
 Q:'P("S")
 F DINUM=+$P(^DIC(4,0),U,3):1 Q:'$D(^DIC(4,DINUM))&('$D(^AUTTLOC(DINUM)))  I DINUM>99999 D RSLT($J("",5)_E(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.") Q
 Q:DINUM>99999
 S DLAYGO=4,DIC="^DIC(4,",X=N
 D FILE
 KILL DINUM,DLAYGO
 I Y<0 D RSLT($J("",5)_E(0)_"^DIC(4 ADD FAILED => "_L) Q
 S DINUM=+Y,DLAYGO=9999999.06,DIC="^AUTTLOC(",X=DINUM,DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.31///"_P
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DINUM,DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
CNTYMOD ;
 S E=$$E("CNTYMOD")
 D RSLT(E)
 F T=1:2 S L=$T(CNTYMOD+T^AUM8106A) Q:$P(L,";",3)="END"  S L("TO")=$T(CNTYMOD+T+1^AUM8106A) D
 . S L=$P(L,U,2,99),S=$P(L,U),C=$P(L,U,2)
 . S P=$O(^AUTTCTY("C",S_C,0))
 . S L=$P(L("TO"),U,2,99),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3)
 . I 'P S P=$O(^AUTTCTY("C",S_C,0)) I 'P S L=";;"_L D ADDCNTY Q
 . S L=S_" "_C_" "_N
 . S P("S")=$$IEN("^DIC(5,",S)
 . Q:'P("S")
 . S DIE="^AUTTCTY(",DA=P,DR=".01///"_N_";.02////"_P("S")_";.03///"_C
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT COUNTY FAILED => "_L) Q
 . D MODOK
 .Q
 Q
 ;
 ; -----------------------------------------------------
 ;
CSCNEW ;
 S E=$$E("CSCNEW")
 D RSLT(E)
 D RSLT($J("",11)_"CODE NAME")
 D RSLT($J("",11)_"---- ----")
 F T=1:1 S L=$T(CSCNEW+T^AUM8106A) Q:$P(L,";",3)="END"  D ADDCSC
 KILL DLAYGO
 Q
 ;
ADDCSC ;
 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N
 I $D(^DIC(45.7,"B",N)) D RSLT($J("",5)_E(1)_"NAME EXISTS => "_N) Q
 I $D(^DIC(45.7,"CIHS",C)) D RSLT($J("",5)_E(1)_"IHS CODE EXISTS => "_C) Q
 S DLAYGO=45.7,DIC="^DIC(45.7,",X=N,DIC("DR")="9999999.01///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
CLINNEW ;
 S E=$$E("CLINNEW")
 D RSLT(E)
 D RSLT($J("",11)_"CODE NAME")
 D RSLT($J("",11)_"---- ----")
 F T=1:1 S L=$T(CLINNEW+T^AUM8106A) Q:$P(L,";",3)="END"  D ADDCLIN
 KILL DLAYGO
 Q
 ;
ADDCLIN ;
 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N
 I $D(^DIC(40.7,"C",C)) D RSLT($J("",5)_E(1)_"CLINIC CODE EXISTS => "_C) Q
 S DLAYGO=40.7,DIC="^DIC(40.7,",X=N,DIC("DR")="1///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
PCLASNEW ;
 S E=$$E("PCLASNEW")
 D RSLT(E)
 D RSLT($J("",11)_"CODE NAME"_$J("",28)_"ABRV.")
 D RSLT($J("",11)_"---- ----"_$J("",28)_"-----")
 F T=1:1 S L=$T(PCLASNEW+T^AUM8106A) Q:$P(L,";",3)="END"  D ADDPCLAS
 KILL DLAYGO
 Q
 ;
ADDPCLAS ;
 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),L=C_" "_N_$J("",(32-$L(N)))_A
 I $D(^DIC(7,"D",C)) D RSLT($J("",5)_E(1)_"PROVIDER CODE EXISTS => "_C) Q
 S DLAYGO=7,DIC="^DIC(7,",X=N,DIC("DR")="1///"_A_";9999999.01///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
PCLASMOD ;
 S E=$$E("PCLASMOD")
 D RSLT(E)
 F T=1:2 S L=$T(PCLASMOD+T^AUM8106A) Q:$P(L,";",3)="END"  S L("TO")=$T(PCLASMOD+T+1^AUM8106A) D
 . S L=$P(L,U,2,99),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3)
 . S P=$O(^DIC(7,"D",C,0))
 . I 'P S L=L("TO") D ADDPCLAS Q
 . S L=$P(L("TO"),U,2,99),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3)
 . S L=C_" "_N_" "_A
 . S DIE="^DIC(7,",DA=P,DR=".01///"_N_";1///"_A_";9999999.01///"_C
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT PROVIDER CODE FAILED => "_L) Q
 . D MODOK
 .Q
 Q
 ;
 ; -----------------------------------------------------
 ;

AUM81062
AUM81062 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 5&6OCT1998 MESSAGES ; [ 10/27/1998  11:32 AM ]
 ;;98.1;TABLE MAINTENANCE;**6**;NOV 17,1997
 ;
 Q
 ;
START ;EP
 ;
 NEW A,C,DIC,DIE,DLAYGO,DR,E,L,N,O,P,R,S,T
 S E(0)="ERROR : ",E(1)="NOT ADDED : "
 D DASH,CHAADD,DASH
 Q
 ; ===   utility sub-routines   ====
 ;
ADDOK D RSLT($J("",5)_"Added : "_L) Q
ADDFAIL D RSLT($J("",5)_E(0)_" : ADD FAILED => "_L) Q
DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("") Q
DIE NEW A,C,E,L,N,O,P,R,S,T
 LOCK +(@(DIE_DA_")")):10
 E  D RSLT($J("",5)_E(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.") S Y=1 Q
 D ^DIE
 LOCK -(@(DIE_DA_")"))
 KILL DA,DIE,DR
 Q
DIK NEW A,C,E,L,N,O,P,R,S,T D ^DIK KILL DIK Q
FILE NEW A,C,E,L,N,O,P,R,S,T KILL DD,DO S DIC(0)="L" D FILE^DICN KILL DIC Q
MODOK D RSLT($J("",5)_"Changed : "_L) Q
RSLT(%) S ^(0)=$G(^TMP("AUM8106",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ; Return 0th node.  A is file #, rest fields.
 I '$G(A) Q -1
 I '$G(B) Q -1
 F %=67:1:75 Q:'$G(@($C(%)))  S A=+$P(^DD(A,B,0),U,2),B=@($C(%))
 I 'A!('B) Q -1
 I '$D(^DD(A,B,0)) Q -1
 Q U_$P(^DD(A,B,0),U,2)
 ;
 ; =================================
 ;
CHANEW ;
 D RSLT("New CHA ICD Recode Table")
 F T=1:1 S L=$T(CHANEW+T^AUM8106A) Q:$P(L,";",3)="END"  D ADDCHA
 Q
 ;
ADDCHA ;
 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N
 I $D(^AUTTCHA("B",C)) D RSLT($J("",5)_E(1)_" : CHA ICD RECODE EXISTS => "_C) Q
 S DLAYGO=9999999.74,DIC="^AUTTCHA(",X=C,DIC("DR")=".03///"_N
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 I Y>0,'$D(^AUTTCHA(+Y,11)) S %=$$ZEROTH(9999999.74,1101) I '(%=-1) S ^AUTTCHA(+Y,11,0)=%
 Q
 ;
CHAADD ;
 D RSLT("CHA ICD Recode, Add Range")
 F T=1:1 S L=$T(CHAADD+T^AUM8106A) Q:$P(L,";",3)="END"  D
 . S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),O=$P(L,U,3),S=$P(L,U,4)
 . S P=$O(^AUTTCHA("B",C,0))
 . I 'P S L=";;"_L D ADDCHA Q:Y<0
 . S L=C_" "_N_"  "_O_"  "_S
 . I $O(^AUTTCHA(P,11,"B",$E(O,1,30),0)),$O(^AUTTCHA(P,11,"B",$E(O,1,30),0))=$O(^AUTTCHA("AH",S_" ",P,0)) D RSLT($J("",5)_"Range Exists (That's OK)"),RSLT($J("",10)_"=> "_L) Q
 . I '$D(^AUTTCHA(P,11)) S %=$$ZEROTH(9999999.74,1101) I '(%=-1) S ^AUTTCHA(P,11,0)=%
 . S DIC="^AUTTCHA("_P_",11,",X=O,DA(1)=P
 . D FILE
 . I Y<0 D RSLT($J("",5)_E(0)_" : ADD RANGE FAILED => "_L) Q
 . S DIE="^AUTTCHA("_P_",11,",DA(1)=P,DA=+Y,P(1)=DA,DR=".02///"_S
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_" : ADD RANGE FAILED => "_L) S DA(1)=P,DA=P(1),DIK="^AUTTCHA("_DA(1)_",11," D DIK Q
 . D RSLT($J("",5)_"Added => "_L)
 .Q
 Q
 ;

AUM8106A
AUM8106A ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 5&6OCT1998 MESSAGES ; [ 10/27/1998  11:32 AM ]
 ;;98.1;TABLE MAINTENANCE;**6**;NOV^17,1997
 ;
UPDATE ;;IHS STANDARD CODE BOOK MODIFICATIONS - AUG/SEP 1998  10/5/98
 ;
LOCNEW ;;A.  NEW FACILITY CODE (SECTION VIII-C): AREA^S.U.^FAC.^NAME^PSEUDO
 ;;20^26^80^SOUTHWEST MEMORIAL HOSPITAL^QAV
 ;;20^26^81^VISTA GRANDE NURSING HOME^QAW
 ;;20^26^83^VALLEY VIEW NURSING HOME^QBD
 ;;65^66^12^GUADALUPE HEALTH COMPLEX^XCZ
 ;;67^61^80^INDIAN WALK-IN CENTER^XDD
 ;;END
 ;
CNTYMOD ;;B.  COUNTY CODE CHANGES (SECTION V-B): STATE^CNTY^NAME
 ;;FROM^26^65^OGENAW
 ;;  TO^26^65^OGEMAW
 ;;END
 ;
COMMNEW ;;C.  NEW COMMUNITY CODES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U.
 ;;26^04^130^ALPENA^18^23
 ;;26^04^131^LACHINE^18^23
 ;;26^16^132^AFTON^18^23
 ;;26^16^133^INDIAN RIVER^18^23
 ;;26^16^134^TOPINABEE^18^23
 ;;26^20^135^SOUTH BRANCH^18^23
 ;;26^22^530^SAGOLA^11^00
 ;;26^23^531^BELLEVUE^11^00
 ;;26^23^532^DIMONDALE^11^00
 ;;26^23^533^EATON RAPIDS^11^00
 ;;26^25^534^LENNON^11^00
 ;;26^29^535^RIVERDALE^11^00
 ;;26^34^536^CLARKSVILLE^11^00
 ;;26^38^537^BROOKLYN^11^00
 ;;26^38^538^GRASS LAKE^11^00
 ;;26^39^539^GALESBURG^11^00
 ;;26^40^136^KALKASKA^18^23
 ;;26^41^540^GRANDVILLE^11^00
 ;;26^41^541^LOWELL^11^00
 ;;26^44^542^IMLAY CITY^11^00
 ;;26^46^543^RIGA^11^00
 ;;26^46^544^TECUMSEH^11^00
 ;;26^47^545^BRIGHTON^11^00
 ;;26^50^546^UTICA^11^00
 ;;26^54^547^STANWOOD^11^00
 ;;26^55^110^CEDAR RIVER^18^34
 ;;26^55^111^STEPHENSON^18^34
 ;;26^55^112^WALLACE^18^34
 ;;26^59^548^MCBRIDE^11^00
 ;;26^61^549^RAVENNA^11^00
 ;;26^61^550^TWIN LAKE^11^00
 ;;26^63^551^BERKLEY^11^00
 ;;26^63^552^FARMINGTON HILL^11^00
 ;;26^63^553^NOVI^11^00
 ;;26^63^554^ROCHESTER^11^00
 ;;26^63^555^TROY^11^00
 ;;26^67^556^REED CITY^11^00
 ;;26^69^137^ELMIRA^18^23
 ;;26^69^138^VANDERBILT^18^23
 ;;26^70^557^JENISON^11^00
 ;;26^71^558^MILLERSBURG^11^00
 ;;26^71^559^OCQUEOC^11^00
 ;;26^71^560^ONAWAY^11^00
 ;;26^71^561^POSEN^11^00
 ;;26^71^562^ROGERS CITY^11^00
 ;;26^74^563^PORT HURON^11^00
 ;;26^76^564^MARLETTE^11^00
 ;;26^81^565^DEXTER^11^00
 ;;26^82^566^FLAT ROCK^11^00
 ;;26^82^567^GARDEN CITY^11^00
 ;;26^82^568^GROSSE POINTE^11^00
 ;;26^82^569^NORTHVILLE^11^00
 ;;26^82^570^PLYMOUTH^11^00
 ;;26^82^571^ROMULUS^11^00
 ;;26^82^572^WESTLAND^11^00
 ;;26^82^573^WOODHAVEN^11^00
 ;;32^06^579^EUREKA SOUTH^60^63
 ;;53^25^177^TOKELAND^70^78
 ;;END
 ;
COMMMOD ;;D.  COMMUNITY CODE CHANGES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U.
 ;;FROM^32^06^578^EUREKA^60^63
 ;;  TO^32^06^578^EUREKA EAST^60^63
 ;;END
 ;
CSCNEW ;;E.  NEW INPATIENT CLINICAL SERVICE CODES (SECTION X): CODE^NAME
 ;;22^NURSE-MIDWIFERY SERVICE
 ;;END
 ;
PCLASNEW ;;F.  NEW SERVICES RENDERED BY (PROVIDER) CODES (SECTION XV): CODE^NAME^ABRV
 ;;89^AUDIOLOGY HEALTH TECHNICIAN^AHT
 ;;90^OCCUPATIONAL THERAPIST^OCT
 ;;91^PHN DRIVER/INTERPRETER^PDI
 ;;92^PSYCHOTHERAPIST^PST
 ;;93^TRADITIONAL MEDICINE PRACTITIONER^TMP
 ;;END
 ;
PCLASMOD ;;G.  SERVICES RENDERED BY (PROVIDER) CODE CHANGES (SECTION XV): CODE^NAME^ABRV
 ;;FROM^48^ALCOHOLISM COUNSELOR^ALC
 ;;  TO^48^ALCOHOLISM/SUB ABUSE COUNSELOR^ALC
 ;;END
 ;
CLINNEW ;;H.  NEW CLINIC CODES (SECTION XIX): CODE^NAME
 ;;82^DAY TREATMENT PROGRAM
 ;;83^LABOR AND DELIVERY
 ;;84^PAIN REDUCTION
 ;;85^TEEN CLINIC
 ;;86^TRADITIONAL MEDICINE
 ;;END
 ;
CHAADD ;; CHA ICD RECODE TABLE: CODE^NARRATIVE^LO ICD9^HI ICD9
 ;;58^OTHER PROBLEMS OF THE DIGESTIVE SYSTEM^78799^78799
 ;;END
 ;

AUM8106M
AUM8106M ; IHS/ASDST/GTH -  BACKGROUND VALUES FOR STANDARD TABLE UPDATES, 5&6OCT1998 MESSAGES ; [ 10/27/1998  11:32 AM ]
 ;;98.1;TABLE MAINTENANCE;**6**;NOV 17,1997
 ;
VAL(X,%,Y) ;EP - return background info.
 I X["AREA" Q $T(@%)
 S Y=0
 I X["SU" D  Q Y
 . NEW C,T
 . F C=1:1 S T=$P($T(SU+C),";",3) Q:T="END"  I $P(T,U,1,2)=($E(%,1,2)_U_$E(%,3,4)) S Y=1_";;"_T Q
 .Q
 I '(X["CTY") Q 0
 NEW C,T
 F C=1:1 S T=$P($T(COUNTY+C),";",3) Q:T="END"  I $P(T,U,1,2)=($E(%,1,2)_U_$E(%,3,4)) S Y=1_";;"_T Q
 Q Y
 ;
AREA ; CODE^NAME^PREFIX/REGION^CAN PREFIX
11 ;;11^BEMIDJI^D^J46
18 ;;18^BEMIDJI NON-IHS^D^J46
20 ;;20^ALBUQUERQUE^Q^J53
60 ;;60^PHOENIX^X^J40
65 ;;65^PHOENIX TRIBE/638^X^J40
67 ;;67^PHOENIX URBAN^X^J40
 ;;END
 ;
SU ; AREA^SU^NAME
1100 ;;11^00^NON SERVICE UNIT
1823 ;;18^23^EASTERN MICHIGAN
1834 ;;18^34^WEST MICHIGAN
2026 ;;20^26^SOUTHERN COL
6063 ;;60^63^OWYHEE
6566 ;;65^66^PHOENIX
6761 ;;67^61^UINTAH-OURAY
7078 ;;70^78^TAHOLAH
 ;;END
 ;
COUNTY ; STATE^COUNTY^NAME
2604 ;;26^04^ALPENA
2616 ;;26^16^CHEBOYGAN
2620 ;;26^20^CRAWFORD
2622 ;;26^22^DICKINSON
2623 ;;26^23^EATON
2625 ;;26^25^GENESEE
2629 ;;26^29^GRATIOT
2634 ;;26^34^IONIA
2638 ;;26^38^JACKSON
2639 ;;26^39^KALAMAZOO
2640 ;;26^40^KALKASKA
2641 ;;26^41^KENT
2644 ;;26^44^LAPEER
2646 ;;26^46^LENAWEE
2647 ;;26^47^LIVINGSTON
2650 ;;26^50^MACOMB
2654 ;;26^54^MECOSTA
2655 ;;26^55^MENOMINEE
2659 ;;26^59^MONTCALM
2661 ;;26^61^MUSKEGON
2663 ;;26^63^OAKLAND
2665 ;;26^65^OGENAW
2667 ;;26^67^OSCEOLA
2669 ;;26^69^OTSEGO
2670 ;;26^70^OTTAWA
2671 ;;26^71^PRESQUE ISLE
2674 ;;26^74^ST CLAIR
2676 ;;26^76^SANILAC
2681 ;;26^81^WASHTENAW
2682 ;;26^82^WAYNE
2665 ;;26^65^OGEMAW
3206 ;;32^06^EUREKA
5325 ;;53^25^PACIFIC
 ;;END
 ;