6:31 PM  1-JUL-99
AUM v 99.1 Patch 7, SCB 30Jun99, etc.  Restore 5 routines and DO ^AUM9107.
A9AUM7
A9AUM7 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999JUN30 ETC., RPI ; [ 07/01/1999   6:30 PM ]
 ;;99.1;TABLE MAINTENANCE;**7**;NOV 6,1998
 ;
 D START^AUM9107
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 ;     
 ;;A9AUM6
 ;;AUM9107
 ;;AUM91071
 ;;AUM9107A
 ;;AUM9107M

AUM9107
AUM9107 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999JUN30 ETC. ; [ 07/01/1999   6:30 PM ]
 ;;99.1;TABLE MAINTENANCE;**7**;NOV 6,1998
 ;
 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^AUM9107(""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 AUM9107
 S X=+Y
 D H^%DTC
 S ZTDTH=%H_","_%T
 S ZTRTN="START^AUM9107",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("AUM9107",$J)
 D START^AUM91071
 S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AUM9107"",$J,",XMY(1)="",XMY(DUZ)=""
 D ^XMD
 KILL ^TMP("AUM9107",$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^A9AUM7
 Q
 ;
INTRO ;
 ;;This updates standard tables according to the changes specified in
 ;;the message time stamped 30Jun99 12:55PM.  Please consult that message,
 ;;and the mail message produced by this update.                       
 ;;  
 ;;Also included are:
 ;;   a correction of an EDUCATION TOPICS mnenomic;
 ;;   additions of several REVENUE CODES from the UB-92 manual;
 ;;   corrections to several REVENUE CODES;
 ;;   inactivation of one REVENUE CODE.
 ;;  
 ;;Please see the notes file for further documentation.
 ;;###
 ;
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
 ;

AUM91071
AUM91071 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999JUN30 ETC. ; [ 07/01/1999   6:30 PM ]
 ;;99.1;TABLE MAINTENANCE;**7**;NOV 6,1998
 ;
 Q
 ;
START ;EP
 ;
 NEW A,C,DIC,DIE,DINUM,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^AUM9107A),";",3))
 D DASH,SUNEW,DASH,SUMOD,DASH,COMMNEW,DASH,COMMMOD,DASH,EDTMOD,DASH,REVNEW,DASH,REVMOD,DASH,REVINACT,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^AUM9107A),";",3),":",1)
IEN(X,%,Y) ;
 S Y=$O(@(X_"""C"",%,0)"))
 I 'Y S Y=$$VAL^AUM9107M(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("AUM9107",$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
 ;
 ; -----------------------------------------------------
 ;
SUNEW ;
 D RSLT($$E("SUNEW"))
 D RSLT($J("",13)_"AA SU NAME")
 D RSLT($J("",13)_"-- -- ----")
 F T=1:1 S L=$T(SUNEW+T^AUM9107A) Q:$P(L,";",3)="END"  D ADDSU
 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
 ;
 ; -----------------------------------------------------
SUMOD ;
 D RSLT($$E("SUMOD"))
 D RSLT($J("",15)_"AA SU NAME")
 D RSLT($J("",15)_"-- -- ----")
 F T=1:2 S L=$T(SUMOD+T^AUM9107A) Q:$P(L,";",3)="END"  S L("TO")=$T(SUMOD+T+1^AUM9107A) D
 . S L=$P(L,U,2,99),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3)
 . S P=$O(^AUTTSU("C",A_S,0))
 . S L=$P(L("TO"),U,2,99),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3)
 . I 'P S P=$O(^AUTTSU("C",A_S,0)) I 'P S L=";;"_L D ADDSU Q
 . S L=A_" "_S_" "_N
 . S P("A")=$$IEN("^AUTTAREA(",A)
 . Q:'P("A")
 . S DIE="^AUTTSU(",DA=P,DR=".01///"_N_";.02////"_P("A")_";.03///"_S
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_" : EDIT SERVICE UNIT FAILED => "_L) Q
 . D MODOK
 .Q
 ;
 Q
 ;
 ; -----------------------------------------------------
 ;
COMMNEW ;
 D RSLT($$E("COMMNEW"))
 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^AUM9107A) 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("^AUTTCTY(",S_O)
 Q:'P("O")
 S P("A")=$$IEN("^AUTTAREA(",A)
 Q:'P("A")
 S P("V")=$$IEN("^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 ;
 D RSLT($$E("COMMMOD"))
 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^AUM9107A) Q:$P(L,";",3)="END"  S L("TO")=$T(COMMMOD+T+1^AUM9107A) 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("^AUTTCTY(",S_O)
 . Q:'P("O")
 . S P("A")=$$IEN("^AUTTAREA(",A)
 . Q:'P("A")
 . S P("V")=$$IEN("^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("AUM9107A")_" patients marked for export because of the Community Code changes.")
 ;
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDEDT ;
 S L=$P(L,";;",2),N=$P(L,U),O=$P(L,U,2),L=$E(N_$J("",30),1,30)_"  "_O
 I $D(^AUTTEDT("B",N)) D RSLT(E(1)_"TOPIC EXISTS => "_N) Q
 I $D(^AUTTEDT("C",O)) D RSLT(E(1)_"MNEMONIC EXISTS => "_O_" for "_N) Q
 S DLAYGO=9999999.09,DIC="^AUTTEDT(",X=N,DIC("DR")="1///"_O
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
EDTMOD ;
 D RSLT($$E("EDTMOD"))
 D RSLT($J("",13)_"NAME"_$J("",28)_"MNEMONIC")
 D RSLT($J("",13)_$$REPEAT^XLFSTR("-",30)_"  --------")
 F T=1:1 S L=$T(EDTMOD+T^AUM9107A) Q:$P(L,";",3)="END"  D
 . S L=$P(L,";;",2)
 . Q:$P(L,U)="FROM"
 . S N=$P(L,U,2),O=$P(L,U,3),L=C_"  "_$E(N,1,25)_$J("",25-$L(N))_"  "_$E(O,1,25)
 . I '$D(^AUTTEDT("B",N)) S L=";;"_L D ADDEDT Q
 . S DIE="^AUTTEDT(",DA=$O(^AUTTEDT("B",N,0)),DR="1///"_O
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT EDUCATION TOPICS FAILED => "_L) Q
 . D MODOK
 .Q
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
REVNEW ;
 ; C = Revenue Code, .01
 ; N = Standard Abbreviation, 1
 ; O = Description, 3
 ;
 D RSLT($$E("REVNEW"))
 D RSLT($J("",13)_"CODE ABBREVIATION"_$J("",13)_"  DESCRIPTION")
 D RSLT($J("",13)_"---  "_$$REPEAT^XLFSTR("-",25)_"  "_$$REPEAT^XLFSTR("-",25))
 F T=1:1 S L=$T(REVNEW+T^AUM9107A) Q:$P(L,";",3)="END"  D ADDREV
 KILL DINUM,DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDREV ;
 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),O=$P(L,U,3),L=C_"  "_$E(N,1,25)_$J("",25-$L(N))_"  "_$E(O,1,25)
 I $D(^AUTTREVN(+C)) D RSLT(E(1)_"REVENUE CODE EXISTS => "_C) Q
 S DINUM=+C,DLAYGO=9999999.72,DIC="^AUTTREVN(",X=C,DIC("DR")="1///"_N_";3///"_O
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
REVMOD ;
 D RSLT($$E("REVMOD"))
 D RSLT($J("",15)_"CODE ABBREVIATION"_$J("",13)_"  DESCRIPTION")
 D RSLT($J("",15)_"---  "_$$REPEAT^XLFSTR("-",25)_"  "_$$REPEAT^XLFSTR("-",25))
 F T=1:1 S L=$T(REVMOD+T^AUM9107A) Q:$P(L,";",3)="END"  D
 . S L=$P(L,";;",2)
 . Q:$P(L,U)="FROM"
 . S C=$P(L,U,2),N=$P(L,U,3),O=$P(L,U,4),L=C_"  "_$E(N,1,25)_$J("",25-$L(N))_"  "_$E(O,1,25)
 . I '$D(^AUTTREVN(+C)) S L=";;"_L D ADDREV Q
 . S DIE="^AUTTREVN(",DA=+C,DR="1///"_N_";3///"_O
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT REVENUE CODES FAILED => "_L) Q
 . D MODOK
 .Q
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
REVINACT ;
 D RSLT($$E("REVINACT"))
 D RSLT($J("",15)_"CODE ABBREVIATION"_$J("",13)_"  DESCRIPTION")
 D RSLT($J("",15)_"---  "_$$REPEAT^XLFSTR("-",25)_"  "_$$REPEAT^XLFSTR("-",25))
 F T=1:1 S L=$T(REVINACT+T^AUM9107A) Q:$P(L,";",3)="END"  D
 . S L=$P(L,";;",2),C=$P(L,U,1),N=$P(L,U,2),O=$P(L,U,3),L=C_"  "_$E(N,1,25)_$J("",25-$L(N))_"  "_$E(O,1,25)
 . I '$D(^AUTTREVN(+C)) D RSLT($J("",6)_"REVENUE DOES NOT EXIST (That'S OK) => "_C) Q
 . S DIE="^AUTTREVN(",DA=+C,DR="2///1"
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT REVENUE CODES FAILED => "_L) Q
 . D MODOK
 .Q
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;

AUM9107A
AUM9107A ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999JUN30 ETC. ; [ 07/01/1999   6:30 PM ]
 ;;99.1;TABLE MAINTENANCE;**7**;NOV 6,1998
 ;
UPDATE ;;IHS STANDARD CODE BOOK MODIFICATIONS - JUNE 1999 6/30/99
 ;
SUNEW ;;A.  NEW SERVICE UNIT CODES (SECTION VIII-B): AREA^S.U.^NAME
 ;;65^73^DUCK VALLEY
 ;;END
 ;
SUMOD ;;B.  SERVICE UNIT CODE CHANGE (SECTION VIII-B): AREA^S.U.^NAME
 ;;FROM^60^63^OWYHEE
 ;;TO^60^63^ELKO
 ;;FROM^65^63^OWYHEE
 ;;TO^65^63^ELKO
 ;;FROM^66^12^HUPA HEALTH ASSOCIATION
 ;;TO^66^12^HOOPA HEALTH ASSOCIATION
 ;;END
 ;
 ;
COMMNEW ;;C.  NEW COMMUNITY CODES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U.
 ;;26^19^411^OVID^11^00
 ;;26^50^412^CHESTERFIELD^11^00
 ;;26^57^110^MC BAIN^18^23
 ;;26^73^413^HEMLOCK^11^00
 ;;26^79^414^KINGSTON^11^00
 ;;32^04^200^CURRIE^60^63
 ;;32^04^201^DEETH^60^63
 ;;32^04^202^ELBURZ^60^63
 ;;32^04^203^HALLECK^60^63
 ;;32^04^204^JACKPOT^60^63
 ;;32^04^205^JIGGS^60^63
 ;;32^04^206^LAMOILLE^60^63
 ;;32^04^207^LEE^60^63
 ;;32^04^208^OASIS^60^63
 ;;32^04^209^OSINO^60^63
 ;;32^04^210^RYNDON^60^63
 ;;32^04^211^STARR VALLEY^60^63
 ;;32^04^212^WENDOVER^60^63
 ;;32^05^573^SILVER PEAK^60^69
 ;;32^06^213^CRESCENT VALLEY^60^63
 ;;32^07^360^GOLCONDA^60^69
 ;;32^07^361^VALMY^60^69
 ;;END
 ;
COMMMOD ;;D.  COMMUNITY CODES CHANGES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U.
 ;;FROM^06^12^666^OTHER HUPA^66^12
 ;;TO^06^12^666^OTHER HOOPA^66^12
 ;;END
 ;
EDTMOD ;;EDUCATION TOPICS CHANGES, FROM THE PEP COMMITTEE: NAME^MNEMONIC
 ;;FROM^STD-TESTING^STD-T
 ;;TO  ^STD-TESTING^STD-TE
 ;;END
 ;
REVNEW ;;NEW REVENUE CODES, FROM THE UB-92 MANUAL: CODE^ABBREVIATION^DESCRIPTION
 ;;022^SNF PPS (RUG)^SKILLED NURSING FACILITY PROSPECTIVE PAYMENT SYSTEM
 ;;173^NURSERY/LEVEL III^NEWBORN LEVEL 3
 ;;174^NURSERY/LEVEL IV^NEWBORN LEVEL 4
 ;;190^SUBACUTE^GENERAL CLASSIFICATION
 ;;191^SUBACUTE/LEVEL I^SUBACUTE CARE - LEVEL 1
 ;;192^SUBACUTE/LEVEL II^SUBACUTE CARE - LEVEL 2
 ;;193^SUBACUTE/LEVEL III^SUBACUTE CARE - LEVEL 3
 ;;194^SUBACUTE/LEVEL IV^SUBACUTE CARE - LEVEL 4
 ;;199^SUBACUTE/OTHER^OTHER SUBACUTE CARE
 ;;241^ALL INCL BASIC^BASIC
 ;;242^ALL INCL COMP^COMPREHENSIVE
 ;;243^ALL INCL SPECIAL^SPECIALTY
 ;;404^PET SCAN^POSITRON EMISSION TOMOGRAPHY
 ;;451^ER/EMTALA^EMTALA EMERGENCY MEDICAL SCREENING SERVICE
 ;;452^ER/BEYOND EMTALA^ER BEYOND EMTALA SCREENING
 ;;456^URGENT CARE^URGENT CARE
 ;;483^ECHOCARDIOLOGY^ECHOCARDIOLOGY
 ;;516^URGENT CLINIC^URGENT CARE CLINIC
 ;;517^FAMILY CLINIC^FAMILY PRACTICE CLINIC
 ;;526^FR/STD URGENT CLINIC^URGENT CARE CLINIC
 ;;609^O2 - OTHER^OTHER OXYGEN
 ;;614^MRI - OTHER^OTHER MRI
 ;;615^MRA - HEAD AND NECK^HEAD AND NECK
 ;;616^MRA - LOWER EXT^LOWE EXTREMETIES
 ;;618^MRA - OTHER^OTHER MRA
 ;;623^SURG DRESSING^SURGICAL DRESSINGS
 ;;624^FDA INVEST DEVICE^FDA INVESTIGATIONAL DEVICES
 ;;637^DRUGS/SELF ADMIN^SELF-ADMINISTRABLE DRUGS
 ;;658^HOSPICE LOW NF^HOSPICE LOW NF
 ;;669^RESPITE OTHER^OTHER RESPITE CARE
 ;;670^OP SPEC RES^GENERAL CLASSIFICATION
 ;;671^OP SPEC RES/HOSP BASED^HOSPITAL BASED
 ;;672^OP SPEC RES/CONTRACTED^CONTRACTED
 ;;679^OP SPEC RES/OTHER^OTHER SPECIAL RESIDENCE CHARGES
 ;;761^TREATMENT RM^TREATMENT ROOM
 ;;762^OBSERVATION RM^OBSERVATION ROOM
 ;;770^PREVENT CARE SVS^GENERAL CLASSIFICATION
 ;;771^VACCINE ADMIN^VACCINE ADMINISTRATION
 ;;779^OTHER PREVENT^OTHER
 ;;780^TELEMEDICINE^GENERAL CLASSIFICATION
 ;;789^TELEMEDICINE/OTHER^OTHER TELEMEDICINE
 ;;904^PLAY ACTIVITY^ACTIVITY THERAPY
 ;;947^CMPLX MED EQUIP-ANC^COMPLEX MEDICAL EQUIPMENT - ANCILLARY
 ;;END
 ;
REVMOD ;;REVENUE CODES CHANGES, FROM THE UB-92 MANUAL: CODE^ABBREVIATION^DESCRIPTION
 ;;FROM^171^NURSERY/NEWBORN^NEWBORN
 ;;TO  ^171^NURSERY/LEVEL I^NEWBORN - LEVEL 1
 ;;FROM^172^NURSERY/PREMIE^PREMATURE
 ;;TO  ^172^NURSERY/LEVEL II^NEWBORN - LEVEL 2
 ;;FROM^619^MRI - OTHER^OTHER MRI
 ;;TO  ^619^MRT - OTHER^OTHER MRT
 ;;FROM^760^TREATMENT ROOM^GENERAL CLASSIFICATION
 ;;TO  ^760^TREATMENT/OBSERVATION ROOM^GENERAL CLASSIFICATION
 ;;FROM^769^OTHER TREATMENT RM^OTHER TREATMENT ROOM
 ;;TO  ^769^OTHER TREAT/OBSERV ROOM^OTHER TREATMENT/OBSERVATION ROOM
 ;;FROM^946^CMPLX MED EQUIP (SNF)^COMPLEX MEDICAL EQUIPMENT (SNF ONLY)
 ;;TO  ^946^CMPLX MED EQUIP-ROUT^COMPLEX MEDICAL EQUIPMENT - ROUTINE
 ;;END
 ;
REVINACT ;;INACTIVATED REVENUE CODES, FROM THE UB-92 MANUAL: CODE^ABBREVIATION^DESCRIPTION
 ;;175^NURSERY/ICU^NEONATAL ICU
 ;;END
 ;
IT ; Check IT
 NEW T,U,X
 S U="^"
 F T=2:2 S L=$T(REVMOD+T) Q:$P(L,";",3)="END"  D
 . W "."
 . S L=$P(L,";",3)
 . S C=$P(L,U,1),A=$P(L,U,2),S=$P(L,U,3)
 . S X=C X $P(^DD(9999999.72,.01,0),U,99) I '$D(X) W !,L," FAIL .01"
 . S X=A X $P(^DD(9999999.72,1,0),U,99) I '$D(X) W !,L," FAIL 1"
 . S X=S X $P(^DD(9999999.72,3,0),U,99) I '$D(X) W !,L," FAIL 3"
 .Q
 Q
 ;

AUM9107M
AUM9107M ; IHS/ASDST/GTH -  BACKGROUND VALUES FOR STANDARD TABLE UPDATES, 1999JUN30 ETC. ; [ 07/01/1999   6:30 PM ]
 ;;99.1;TABLE MAINTENANCE;**7**;NOV 6,1998
 ;
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
60 ;;60^PHOENIX^X^J40
65 ;;65^PHOENIX TRIBE/638^X^J40
66 ;;66^CALIFORNIA TRIBE/638^L^J41
 ;;END
 ;
SU ; AREA^SU^NAME
1100 ;;11^00^NON SERVICE UNIT
1823 ;;18^23^EASTERN MICHIGAN
6063 ;;60^63^OWYHEE
6069 ;;60^69^SCHURZ
6563 ;;65^63^OWYHEE
6612 ;;66^12^HUPA HEALTH ASSOCIATION
 ;;END
 ;
COUNTY ; STATE^COUNTY^NAME
0612 ;;06^12^HUMBOLDT
2619 ;;26^19^CLINTON
2650 ;;26^50^MACOMB
2657 ;;26^57^MISSAUKEE
2673 ;;26^73^SAGINAW
2679 ;;26^79^TUSCOLA
3204 ;;32^04^ELKO
3205 ;;32^05^ESMERALDA
3206 ;;32^06^EUREKA
3207 ;;32^07^HUMBOLDT
 ;;END
 ;