12:55 PM  16-FEB-2001
AUM v 01.1, Patch 2, SCB updates from 2001Feb09.  Restore 5 routines and DO ^AUM1102.
A9AUM2
A9AUM2 ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2001FEB09, RPI ; [ 02/16/2001  12:54 PM ]
 ;;1.1;TABLE MAINTENANCE;**2**;DEC 6,2000
 ;
 D START^AUM1102
DEL ;EP - Delete routines.
 Q:'$L($G(^%ZOSF("DEL")))
 NEW X
 I $$RSEL^ZIBRSEL("AUM1102*") D D
 I $$RSEL^ZIBRSEL("A9AUM*")
 KILL ^TMP("ZIBRSEL",$J,"A9AUM2") ; Don't delete the current routine.
 D D
 Q
 ;
D ;
 S X=""
 F  S X=$O(^TMP("ZIBRSEL",$J,X)) Q:X=""  X ^%ZOSF("DEL") I '$D(ZTQUEUED) W !,X,$E("...........",1,11-$L(X)),"<poof'd>"
 KILL ^TMP("ZIBRSEL",$J)
 Q
 ;

AUM1102
AUM1102 ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2001FEB09 ; [ 02/16/2001  12:54 PM ]
 ;;1.1;TABLE MAINTENANCE;**2**;DEC 6,2000
 ;
 I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
 D HOME^%ZIS,DT^DICRW,VP,HELP("INTRO")
 S (DIR(0),DIR("B"))="Y"
 S DIR("A")="Do you want to queue the update to TaskMan"
 S DIR("??")="^D HELP^AUM1102(""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 AUM1102
 S X=+Y
 D H^%DTC
 S ZTDTH=%H_","_%T
 S ZTRTN="START^AUM1102",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("AUM1102",$J)
 D START^AUM11021
 S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""AUM1102"",$J,",XMY(DUZ)=""
 F %="XUPROGMODE","AG TM MENU","ABMDZ TABLE MAINTENANCE","APCCZMGR" D SINGLE(%)
 D ^XMD
 KILL ^TMP("AUM1102",$J)
 I $D(ZTQUEUED) S ZTREQ="@" G DEL^A9AUM2
 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 DEL^A9AUM2
 Q
 ;
INTRO ;EP - To write to mail message, too.
 ;;This updates standard tables according to the changes specified in
 ;;the message from Joe Herrera, with subject "Standard Code Book
 ;;modifications", released on Fri, 02/09/2001.  Please consult that
 ;;message, and the local RPMS mail message produced by this update.
 ;;  
 ;;###;NOTE:  This line indicates the end of the message.
 ;
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.
 ;;###;NOTE:  This line indicates the end of the message.
 ;
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
 ;
SINGLE(K) ; Get holders of a single key K.
 NEW Y
 S Y=0
 Q:'$D(^XUSEC(K))
 F  S Y=$O(^XUSEC(K,Y)) Q:'Y  S XMY(Y)=""
 Q
 ;
VP ;
 W !?4,"****    AUM Version ",$P($T(+2),";",3)," Patch ",$P($P($T(+2),";",5),"*",3),?65,"****"
 W !?4,"****   ",$P($P($T(+1),";",2),"-",2),?65,"****"
 Q
 ;
GREET ;;EP - To add to mail message.
 ;;  
 ;;Greetings.
 ;;  
 ;;Standard tables on your RPMS system have been updated.
 ;;  
 ;;****************************************************************
 ;;* NOTE:  BEGINNING WITH PATCH 2 TO AUM 01.1, DATA AUDITING IS  *
 ;;*        TURNED ON FOR FILES AND FIELDS BEING ADDED TO, OR     *
 ;;*        BEING MODIFIED BY THESE AUM UPDATES.  DATA AUDITING   *
 ;;*        IS RECORDED IN THE "AUDIT" FILE.  ENTRIES IN THE      *
 ;;*        "AUDIT" FILE RECORD WHO MODIFIED THE DATA, AND IT     *
 ;;*        MIGHT APPEAR AS THOUGH WHOMEVER RAN THIS UPDATE       *
 ;;*        MODIFIED THE DATA.  THIS PORTION OF THIS MESSAGE IS   *
 ;;*        NOTIFICATION OF THE ABOVE CONDITION.                  *
 ;;****************************************************************
 ;;  
 ;;You are receiving this message because of the particular RPMS
 ;;security keys that you hold.  This is for your information, only.
 ;;You need do nothing in response to this message.
 ;;  
 ;;Requests for modifications or additions to RPMS standard tables,
 ;;whether they are or are not reflected in the IHS Standard Code
 ;;Book (SCB), can be submitted to your Area Information System
 ;;Coordinator (ISC).
 ;;  
 ;;Sections of the current IHS SCB can be retrieved from the
 ;;IntrAnet location: http://dpsntweb1.hqw.ihs.gov/ciweb/main.html
 ;;  
 ;;Questions about this patch, which is a product of the RPMS DBA,
 ;;can be directed to the Information Technology Support Center
 ;;(ITSC) help desk, at 505-248-4371, or via e-mail to
 ;;"hqwhd@mail.ihs.gov".  Please refer to patch "AUM*1.1*2".
 ;;  
 ;;###;NOTE: This line indicates the end of text in this message.
 ;

AUM11021
AUM11021 ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2001FEB09 ; [ 02/16/2001  12:54 PM ]
 ;;1.1;TABLE MAINTENANCE;**2**;DEC 6,2000
 ;
 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^AUM1102A),";",3))
 F %=1:1 D RSLT($P($T(GREET+%^AUM1102),";",3)) Q:$P($T(GREET+%+1^AUM1102),";",3)="###"
 F %=1:1 D RSLT($P($T(INTRO+%^AUM1102),";",3)) Q:$P($T(INTRO+%+1^AUM1102),";",3)="###"
 D AUDS,DASH,LOCNEW,DASH,LOCMOD,DASH,COMMNEW,DASH,COMMMOD,DASH,CLINNEW,DASH,AUDR
 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^AUM1102A),";",3),":",1)
IEN(X,%,Y) ;
 S Y=$O(@(X_"""C"",%,0)"))
 I 'Y S Y=$$VAL^AUM1102M(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("AUM1102",$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)
 ;
 ; -----------------------------------------------------
 ; Data auditing at the file level is indicated by a lower case "a"
 ; in the 2nd piece of the 0th node of the global.
 ; Data auditing at the field level is indicated by a lowere case "a"
 ; in the 2nd piece of the 0th node of the field definition in ^DD(.
AUDS ; Save current settings, and SET data auditing 'on'.
 S ^XTMP("AUM11021",0)=$$FMADD^XLFDT(DT,56)_"^"_DT_"^"_"AUM11021 STANDARD TABLE UPDATES"
 NEW G,P
 F %=1:1 S G=$P($T(AUD+%),";",3) Q:G="END"  D
 . S P=$P(@(G_"0)"),"^",2)
 . I '$D(^XTMP("AUM11021",G)) S ^XTMP("AUM11021",G)=P
 . S:'(P["a") $P(@(G_"0)"),"^",2)=P_"a"
 . Q:'(G["^DD(")
 . I '$D(^XTMP("AUM11021",G,"AUDIT")) S ^XTMP("AUM11021",G,"AUDIT")=$G(@(G_"""AUDIT"")"))
 . S (@(G_"""AUDIT"")"))="y"
 .Q
 Q
 ;
AUDR ; Restore the file data audit values to their original values.
 NEW G,P
 F %=1:1 S G=$P($T(AUD+%),";",3) Q:G="END"  D
 . S $P(@(G_"0)"),"^",2)=^XTMP("AUM11021",G)
 . Q:'(G["^DD(")
 . S (@(G_"""AUDIT"")"))=^XTMP("AUM11021",G,"AUDIT")
 . K:@(G_"""AUDIT"")")="" @(G_"""AUDIT"")")
 .Q
 Q
 ;
AUD ;
 ;;^AUTTAREA(
 ;;^AUTTSU(
 ;;^AUTTCTY(
 ;;^AUTTLOC(
 ;;^DIC(4,
 ;;^AUTTCOM(
 ;;^DIC(40.7,
 ;;^DD(9999999.21,.01,
 ;;^DD(9999999.21,.02,
 ;;^DD(9999999.21,.03,
 ;;^DD(9999999.21,.04,
 ;;^DD(9999999.22,.01,
 ;;^DD(9999999.22,.02,
 ;;^DD(9999999.22,.03,
 ;;^DD(9999999.22,.04,
 ;;^DD(9999999.23,.01,
 ;;^DD(9999999.23,.02,
 ;;^DD(9999999.23,.03,
 ;;^DD(9999999.23,.04,
 ;;^DD(9999999.23,.06,
 ;;^DD(9999999.06,.01,
 ;;^DD(9999999.06,.04,
 ;;^DD(9999999.06,.05,
 ;;^DD(9999999.06,.07,
 ;;^DD(9999999.06,.31,
 ;;^DD(4,.01,
 ;;^DD(9999999.05,.01,
 ;;^DD(9999999.05,.02,
 ;;^DD(9999999.05,.03,
 ;;^DD(9999999.05,.05,
 ;;^DD(9999999.05,.06,
 ;;^DD(9999999.05,.07,
 ;;^DD(40.7,.01,
 ;;^DD(40.7,1,
 ;;^DD(40.7,999999901,
 ;;END
 ;
 ; -----------------------------------------------------
 ;
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
 ;
 ; -----------------------------------------------------
LOCNEW ;
 D RSLT($$E("LOCNEW"))
 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^AUM1102A) 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///@;.28////"_DT 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=".28////"_DT_";.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_";.28////"_DT_";.31///"_P
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DINUM,DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
LOCMOD ;
 D RSLT($$E("LOCMOD"))
 D RSLT($J("",15)_"AA SU FA NAME"_$J("",28)_"PSEUDO")
 D RSLT($J("",15)_"-- -- -- ----"_$J("",28)_"------")
 F T=1:2 S L=$T(LOCMOD+T^AUM1102A) Q:$P(L,";",3)="END"  S L("TO")=$T(LOCMOD+T+1^AUM1102A) D
 . S L=$P(L,U,2,99),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3)
 . S P=$O(^AUTTLOC("C",A_S_F,0))
 . S L=$P(L("TO"),U,2,99),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4)
 . I 'P S P=$O(^AUTTLOC("C",A_S_F,0)) I 'P S L=";;"_L D ADDLOC Q
 . S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_$P(L("TO"),U,6)
 . S P("A")=$$IEN("^AUTTAREA(",A)
 . Q:'P("A")
 . S P("S")=$$IEN("^AUTTSU(",A_S)
 . Q:'P("S")
 . S DIE="^AUTTLOC(",DA=P,DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_$P(L("TO"),U,6)
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT LOCATION FAILED => "_L) Q
 . S DIE="^DIC(4,",DA=$P(^AUTTLOC(P,0),U),DR=".01///"_N
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT INSTITUTION FAILED => "_L) Q
 . D MODOK
 .Q
 ;
 D DASH
 D RSLT("Checking Location Code changes to determine export status.")
 D RSLT("Patient data is not exported if the only change is to the Location NAME.")
 D RSLT("Location Code changes must be rolled up into the national data repository...")
 D DASH,RSLT($$LOCMOD^AUMXPORT("AUM1102A")_" patients marked for export because of the Location Code changes.")
 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^AUM1102A) 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^AUM1102A) Q:$P(L,";",3)="END"  S L("TO")=$T(COMMMOD+T+1^AUM1102A) 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
 ;
 D DASH
 D RSLT("Checking Community Code changes to determine export status.")
 D RSLT("Patient data is not exported if the only change is to the Commnuity NAME.")
 D RSLT("Commnity Code changes must be rolled up into the national data repository...")
 D DASH,RSLT($$COMMMOD^AUMXPORT("AUM1102A")_" patients marked for export because of the Community Code changes.")
 Q
 ;
 ; -----------------------------------------------------
 ;
CLINNEW ;
 D RSLT($$E("CLINNEW"))
 D RSLT($J("",11)_"CODE NAME"_$J("",28)_"ABRV.")
 D RSLT($J("",11)_"---- ----"_$J("",28)_"-----")
 F T=1:1 S L=$T(CLINNEW+T^AUM1102A) 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),A=$P(L,U,3),L=C_" "_N_$J("",(32-$L(N)))_A
 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_";999999901///"_A
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;

AUM1102A
AUM1102A ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2001FEB09 ; [ 02/16/2001  12:54 PM ]
 ;;1.1;TABLE MAINTENANCE;**2**;DEC 6,2000
 ;
UPDATE ;;IHS STANDARD CODE BOOK MODIFICATIONS - JANUARY 2001  02/09/2001
 ;
LOCNEW ;;A.  NEW FACILITY CODES (SECTION VIII-C): AREA^S.U.^FAC.^NAME^PSEUDO
 ;;20^26^84^SAN JUAN REGIONAL MED CTR CHS^QCR
 ;;20^28^80^JICARILLA CHS^QCS
 ;;55^56^13^PERKINS FAMILY CLINIC^ODE
 ;;55^56^14^KANZA HEALTH CENTER^OAG
 ;;70^75^76^SNOQUALMIE CHS PROGRAM^PAV
 ;;END
 ;
LOCMOD ;;B.  FACILITY CODE CHANGES (SECTION VIII-C): AREA^S.U.^FAC.^NAME^PSEUDO
 ;;FROM^20^21^11^JEMEZ HEALTH CENTER^QAU
 ;;  TO^25^21^11^JEMEZ HEALTH CENTER^QCD
 ;;FROM^15^20^80^WINNEBAGO DENTAL PROGRAM^CCD
 ;;  TO^15^20^80^WINNEBAGO TRIBAL HEALTH PROG^CCD
 ;;FROM^50^56^11^WHITE EAGLE CLINIC^OFC
 ;;  TO^55^56^11^WHITE EAGLE CLINIC^OFW
 ;;FROM^50^52^14^MIAMI HEALTH CENTER^OBE
 ;;  TO^55^52^14^MIAMI HEALTH CENTER^ODT
 ;;END
 ;
COMMNEW ;;C.  NEW COMMUNITY CODES (SECTION V-C); STATE^CNTY^COMM^NAME^AREA^S.U.
 ;;06^29^135^FLORISTAN^66^10
 ;;06^29^136^NORDEN^66^10
 ;;06^29^137^SODA SPRINGS^66^10
 ;;06^31^138^ALTA^66^10
 ;;06^31^139^BAXTER^66^10
 ;;06^31^140^CARNELIAN BAY^66^10
 ;;06^31^141^DUTCH FLAT^66^10
 ;;06^31^142^EMIGRANT GAP^66^10
 ;;06^31^143^GOLD RUN^66^10
 ;;06^31^144^HOMEWOOD^66^10
 ;;06^31^145^IOWA HILL^66^10
 ;;06^31^146^PENRYN^66^10
 ;;06^31^147^TAHOE CITY^66^10
 ;;06^31^148^TAHOE VISTA^66^10
 ;;06^31^149^TAHOMA^66^10
 ;;06^46^150^ALLEGHANY^66^10
 ;;06^46^151^GOODYEARS BAR^66^10
 ;;06^46^152^SATTLEY^66^10
 ;;06^46^153^SIERRA CITY^66^10
 ;;06^46^154^SIERRAVILLE^66^10
 ;;06^57^155^CARDANASSO^66^10
 ;;06^57^156^CLARKSBURG^66^10
 ;;06^57^157^DIXON^66^10
 ;;06^57^158^EL MACERO^66^10
 ;;06^57^159^EL RIO VILLA^66^10
 ;;06^57^160^GUINDA^66^10
 ;;06^57^161^KNIGHTS LANDING^66^10
 ;;06^57^162^MADISON^66^10
 ;;06^57^163^TANCRED^66^10
 ;;06^57^164^TYNDALL LANDING^66^10
 ;;06^57^165^YOLO^66^10
 ;;06^57^166^ZAMORA^66^10
 ;;30^55^200^GLENDIVE^40^00
 ;;END
 ;
COMMMOD ;;D.  COMMUNITY CODES CHANGES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U.
 ;;FROM^27^03^005^WOLF LAKE^18^31
 ;;  TO^27^03^005^WOLF LAKE^11^35
 ;;END
 ;
CLINNEW ;;E.  NEW CLINIC CODES (SECTION XIX): CODE^NAME^ABRV
 ;;95^DIALYSIS LABORATORY SERVICES^DLS
 ;;96^PEDIAT OUTP USE OF INP TRTM RM^POT
 ;;97^SURG OUTP USE OF INP TRTMNT RM^SOT
 ;;END
 ;

AUM1102M
AUM1102M ; IHS/RPMSDBA/GTH -  BACKGROUND VALUES FOR STANDARD TABLE UPDATES, 2001FEB09 ; [ 02/16/2001  12:54 PM ]
 ;;1.1;TABLE MAINTENANCE;**2**;DEC 6,2000
 ;
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
15 ;;15^ABERDEEN TRIBE/638^C^J45
20 ;;20^ALBUQUERQUE^Q^J53
25 ;;25^ALBUQUERQUE TRIBE/638^Q^J53
40 ;;40^BILLINGS^B^J47
55 ;;55^OKLAHOMA TRIBE/638^O^J50
66 ;;66^CALIFORNIA TRIBE/638^L^J41
70 ;;70^PORTLAND^P^J64
 ;;END
 ;
SU ; AREA^SU^NAME
1135 ;;11^35^WHITE EARTH
1520 ;;15^20^WINNEBAGO
2026 ;;20^26^SOUTHERN COL
2028 ;;20^28^JICARILLA
2521 ;;25^21^ALBUQUERQUE
4000 ;;40^00^NON SERVICE UNIT
5552 ;;55^52^CLAREMORE
5556 ;;55^56^PAWNEE
6610 ;;66^10^CHAPA-DE INDIAN HEALTH PROJECT
7075 ;;70^75^PUGET SOUND
 ;;END
 ;
COUNTY ; STATE^COUNTY^NAME
0629 ;;06^29^NEVADA
0631 ;;06^31^PLACER
0646 ;;06^46^SIERRA
0657 ;;06^57^YOLO
2703 ;;27^03^BECKER
3055 ;;30^55^WIBAUX
 ;;END
 ;