4:19 PM  14-NOV-97
AUM v 97.1 Patch 12, SCB Updates from 07Nov97 Banyan.  Restore 5 routines and DO ^AUM7112.
A9AUM12
A9AUM12 ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 07NOV97 BANYAN, RPI ; [ 11/14/97   4:17 PM ]
 ;;97.1;TABLE MAINTENANCE;**12**;DEC 10,1996
 ;
 D START^AUM7112
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 ;     
 ;;A9AUM10
 ;;AUM7112
 ;;AUM71121
 ;;AUM7112A
 ;;AUM7112M

AUM7112
AUM7112 ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 07NOV97 BANYAN ; [ 11/14/97   4:17 PM ]
 ;;97.1;TABLE MAINTENANCE;**12**;DEC 10,1996
 ;
 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^AUM7112(""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 AUM7112
 S X=+Y
 D H^%DTC
 S ZTDTH=%H_","_%T
 S ZTRTN="START^AUM7112",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("AUM7112",$J)
 D START^AUM71121
 S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AUM7112"",$J,",XMY(1)="",XMY(DUZ)=""
 D ^XMD
 KILL ^TMP("AUM7112",$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^A9AUM12
 Q
 ;
INTRO ;
 ;;This updates standard tables according to the changes specified in
 ;;the Banyan message time stamped 07Nov97@14:22:16 MST. 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
 ;

AUM71121
AUM71121 ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 07NOV97 BANYAN ; [ 11/14/97   4:17 PM ]
 ;;97.1;TABLE MAINTENANCE;**12**;DEC 10,1996
 ;
 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^AUM7112A),";",3))
 D DASH,COMMNEW,DASH,CNTYMOD,DASH,COMMMOD,DASH,RESNEW,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^AUM7112A),";",3),":",1)
IEN(X,%,Y) ;
 S Y=$O(@(X_"""C"",%,0)"))
 I 'Y S Y=$$VAL^AUM7112M(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("AUM7112",$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
 ;
 ; -----------------------------------------------------
 ;
CNTYMOD ;
 S E=$$E("CNTYMOD")
 D RSLT(E)
 F T=1:2 S L=$T(CNTYMOD+T^AUM7112A) Q:$P(L,";",3)="END"  S L("TO")=$T(CNTYMOD+T+1^AUM7112A) 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
 ;
 ; -----------------------------------------------------
 ;
SUNEW ;
 S E=$$E("SUNEW")
 D RSLT(E)
 D RSLT($J("",13)_"AA SU NAME")
 D RSLT($J("",13)_"-- -- ----")
 F T=1:1 S L=$T(SUNEW+T^AUM7112A) 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
 ;
 ; -----------------------------------------------------
 ;
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^AUM7112A) 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^AUM71121("^AUTTCTY(",S_O)
 Q:'P("O")
 S P("A")=$$IEN^AUM71121("^AUTTAREA(",A)
 Q:'P("A")
 S P("V")=$$IEN^AUM71121("^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^AUM7112A) Q:$P(L,";",3)="END"  S L("TO")=$T(COMMMOD+T+1^AUM7112A) 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^AUM71121("^AUTTCTY(",S_O)
 . Q:'P("O")
 . S P("A")=$$IEN^AUM71121("^AUTTAREA(",A)
 . Q:'P("A")
 . S P("V")=$$IEN^AUM71121("^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 comment'd because the only change is to the name of the community.
 ; D DASH,RSLT($$COMMMOD^AUMXPORT("AUM7112A")_" patients marked for export because of the Community Code changes.")
 Q
 ;
 ; -----------------------------------------------------
 ;
RESNEW ;
 S E=$$E("RESNEW")
 D RSLT(E)
 D RSLT($J("",12)_"CODE NAME"_$J("",26)_"AREA1 AREA2 STATE")
 D RSLT($J("",12)_"---- ----"_$J("",26)_"----- ----- -----")
 F T=1:1 S L=$T(RESNEW+T^AUM7112A) Q:$P(L,";",3)="END"  D ADDRES
 Q
 ;
ADDRES ;
 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),O=$P(L,U,4),S=$P(L,U,5),L=C_" "_$E(N_$J("",30),1,30)_" "_A_"    "_$E(O_"  ",1,2)_"    "_S
 I $D(^AUTTRES("C",C)) D RSLT($J("",5)_E(1)_"RESERVATION CODE EXISTS => "_C) Q
 S P("A1")=$$IEN("^AUTTAREA(",A)
 Q:'P("A1")
 I O S P("A2")=$$IEN("^AUTTAREA(",O) Q:'P("A2")
 S P("S")=$$IEN("^DIC(5,",S)
 Q:'P("S")
 S DLAYGO=9999999.47,DIC="^AUTTRES(",X=N,DIC("DR")=".02///"_C_";.03////"_P("S")_";.04////"_P("A1")
 I O,$G(P("A2")) S DIC("DR")=DIC("DR")_";.05////"_P("A2")
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;

AUM7112A
AUM7112A ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 07NOV97 BANYAN ; [ 11/14/97   4:17 PM ]
 ;;97.1;TABLE MAINTENANCE;**12**;DEC 10,1996
 ;
UPDATE ;;IHS STANDARD CODE BOOK MODIFICATIONS - OCTOBER 1997   11/7/97
 ;
COMMNEW ;;A.  NEW COMMUNITY CODES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^SU
 ;;28^01^001^NATCHEZ^58^00
 ;;28^04^105^WEST^58^57
 ;;28^09^002^HOUSTON^58^00
 ;;28^09^003^OKOLONA^58^00
 ;;28^10^004^ACKERMAN^58^00
 ;;28^17^005^HORN LAKE^58^00
 ;;28^17^006^OLIVE BRANCH^58^00
 ;;28^17^007^WALLS^58^00
 ;;28^18^008^HATTLESBURG^58^00
 ;;28^20^009^LUCEDALE^58^00
 ;;28^22^010^GRENADA^58^00
 ;;28^24^011^DIBERVILLE^58^00
 ;;28^25^012^RAYMOND^58^00
 ;;28^25^013^TERRY^58^00
 ;;28^29^018^FULTON^58^00
 ;;28^30^019^OCEAN SPRINGS^58^00
 ;;28^30^042^VAN CLEAVE^58^00
 ;;28^38^043^COLLINSVILLE^58^00
 ;;28^41^044^TUPELO^58^00
 ;;28^42^045^GREENWOOD^58^00
 ;;28^42^046^SIDON^58^00
 ;;28^43^047^BROOKHAVEN^58^00
 ;;28^44^048^CALEDONI^58^00
 ;;28^44^049^COLUMBUS^58^00
 ;;28^44^050^STEENS^58^00
 ;;28^45^051^CANTON^58^00
 ;;28^45^052^RIDGELAND^58^00
 ;;28^47^053^BYHALIA^58^00
 ;;28^48^054^ABERDEEN^58^00
 ;;28^49^055^WINONA^58^00
 ;;28^53^056^MABEN^58^00
 ;;28^55^057^MCNEILL^58^00
 ;;28^55^058^NICHOLSON^58^00
 ;;28^61^059^FLORENCE^58^00
 ;;28^61^062^PEARL^58^00
 ;;28^61^063^RICHLAND^58^00
 ;;28^64^066^MENDENHALL^58^00
 ;;28^64^067^PINOLA^58^00
 ;;28^65^064^TAYLORSVILLE^58^00
 ;;28^70^068^FALKNER^58^00
 ;;28^70^069^RIPLEY^58^00
 ;;28^78^073^EUPORA^58^00
 ;;END
 ;
CNTYMOD ;;B.  STATE - COUNTY CHANGES (SECTION V-B): STATE^CNTY^NAME
 ;;FROM^28^43^LINCOLNN
 ;;  TO^28^43^LINCOLN
 ;;END
 ;
 ;
COMMMOD ;;C.  COMMUNITY CODE CHANGES  (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^SU
 ;;FROM^28^52^258^SCHUQUALAK^58^57
 ;;  TO^28^52^258^SHUQUALAK^58^57
 ;;END
 ;
 ;
RESNEW ;;D.  NEW RESERVATION CODE (SECTION XIV): CODE^NAME^AREA1^AREA2^STATE
 ;;321^HURON POTAWATOMI, INC.^11^18^26
 ;;END
 ;

AUM7112M
AUM7112M ; IHS/ADC/GTH -  BACKGROUND VALUES FOR STANDARD TABLE UPDATES, 07NOV97 BANYAN ; [ 11/14/97   4:17 PM ]
 ;;97.1;TABLE MAINTENANCE;**12**;DEC 10,1996
 ;
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
58 ;;58^NASHVILLE NON-IHS^U^J51
 ;;END
 ;
SU ; AREA^SU^NAME
5800 ;;58^00^NON SERVICE UNIT
5857 ;;58^57^CHOCTAW
 ;;END
 ;
COUNTY ; STATE^COUNTY^NAME
2801 ;;28^01^ADAMS
2804 ;;28^04^ATTALA
2809 ;;28^09^CHICKASAW
2810 ;;28^10^CHOCTAW
2817 ;;28^17^DE SOTO
2818 ;;28^18^FORREST
2820 ;;28^20^GEORGE
2822 ;;28^22^GRENADA
2824 ;;28^24^HARRISON
2825 ;;28^25^HINDS
2829 ;;28^29^ITAWAMBA
2830 ;;28^30^JACKSON
2838 ;;28^38^LAUDERDALE
2841 ;;28^41^LEE
2842 ;;28^42^LEFLORE
2843 ;;28^43^LINCOLNN
2844 ;;28^44^LOWNDES
2845 ;;28^45^MADISON
2847 ;;28^47^MARSHALL
2848 ;;28^48^MONROE
2849 ;;28^49^MONTGOMERY
2852 ;;28^52^NOXUBEE
2853 ;;28^53^OKTIBBEHA
2855 ;;28^55^PEARL RIVER
2861 ;;28^61^RANKIN
2864 ;;28^64^SIMPSON
2865 ;;28^65^SMITH
2870 ;;28^70^TIPPAH
2878 ;;28^78^WEBSTER
 ;;END
 ;