10:18 AM  12-JUL-2000
AUM v 99.1 Patch 14, 16 new Cost Centers, 6Jul2000.  Restore 5 routines and DO ^AUM9114.
A9AUM14
A9AUM14 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 2000JUL06, RPI ; [ 07/12/2000  10:17 AM ]
 ;;99.1;TABLE MAINTENANCE;**14**;NOV 6,1998
 ;
 D START^AUM9114
DEL ;EP - Delete routines.
 Q:'$L($G(^%ZOSF("DEL")))
 NEW X
 I $$RSEL^ZIBRSEL("AUM9114*") D D
 I $$RSEL^ZIBRSEL("A9AUM*")
 KILL ^TMP("ZIBRSEL",$J,"A9AUM14") ; 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
 ;

AUM9114
AUM9114 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 2000JUL06 ; [ 07/12/2000  10:17 AM ]
 ;;99.1;TABLE MAINTENANCE;**14**;NOV 6,1998
 ;
 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^AUM9114(""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 AUM9114
 S X=+Y
 D H^%DTC
 S ZTDTH=%H_","_%T
 S ZTRTN="START^AUM9114",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("AUM9114",$J)
 D START^AUM91141
 S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""AUM9114"",$J,",XMY(DUZ)=""
 F %="XUPROGMODE","ACRZ TABLE MAINTENANCE" D SINGLE(%)
 D ^XMD
 KILL ^TMP("AUM9114",$J)
 I $D(ZTQUEUED) S ZTREQ="@" G DEL^A9AUM14
 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^A9AUM14
 Q
 ;
INTRO ;EP - To write to mail message, too.
 ;;16 new financial Cost Centers have been developed by a national work
 ;;group to support improved Cost Reporting.  The new Cost Centers were
 ;;approved by IHS Headquarters in late 1999.
 ;;  
 ;;This patch -only- adds the 16 approved new Cost Centers to the COST
 ;;CENTER file.  No other standard RPMS tables are effected.
 ;;  
 ;;The primary RPMS application user of COST CENTER is ARMS.  The RPMS
 ;;DBA Team knows of no other application that requires the COST CENTER
 ;;file.  No harm is done in installing the Cost Centers where ARMS is
 ;;not running, and might be desired to support locally developed
 ;;applications.
 ;;  
 ;;Copies of correspondence authorizing the addition of the 16 new Cost
 ;;Centers are in the notes file accompanying this patch, and in the
 ;;patch description on IHS MailMan.
 ;;  
 ;;Questions about this patch, which is a product of the RPMS DBA
 ;;Team, can be directed to the DIR/RPMS Support Center, at
 ;;505-248-4371, or via e-mail to "hqwhd@mail.ihs.gov".  Please
 ;;refer to patch "AUM*99.1*14".
 ;;     
 ;;###;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
 ;

AUM91141
AUM91141 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 2000JUL06 ; [ 07/12/2000  10:17 AM ]
 ;;99.1;TABLE MAINTENANCE;**14**;NOV 6,1998
 ;;  
 ;;  
 ;;***************************************************************
 ;;**  AREA OFFICE PERSONNEL:  Please ensure that your Area     **
 ;;**  Financial Management Officer and staff are aware that    **
 ;;**  Cost Centers have been added to the COST CENTER file.    **
 ;;***************************************************************
 ;;  
 ;;Greetings.
 ;;  
 ;;Standard tables on your RPMS system have been updated.
 ;;  
 ;;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).
 ;;  
 ;;###;NOTE: This line indicates the end of text in this message.
 ;
 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^AUM9114A),";",3))
 F %=4:1 D RSLT($P($T(+%),";",3)) Q:$P($T(+%+1),";",3)="###"
 F %=1:1 D RSLT($P($T(INTRO+%^AUM9114),";",3)) Q:$P($T(INTRO+(%+1)^AUM9114),";",3)="###"
 D DASH,CCNEW,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^AUM9114A),";",3),":",1)
IEN(X,%,Y) ;
 S Y=$O(@(X_"""C"",%,0)"))
 I 'Y S Y=$$VAL^AUM9114M(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("AUM9114",$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
 ;
 ; -----------------------------------------------------
CCNEW ;
 S E=$$E("CCNEW")
 D RSLT(E)
 D RSLT($J("",13)_"NO. TITLE")
 D RSLT($J("",13)_"--  ------")
 F T=1:1 S L=$T(CCNEW+T^AUM9114A) Q:$P(L,";",3)="END"  D ADDCC
 KILL DLAYGO
 Q
 ;
ADDCC ;
 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_"  "_N
 I $D(^AUTTCCT("B",C)) D RSLT($J("",5)_E(1)_"COST CENTER EXISTS => "_C) Q
 S DLAYGO=9999999.58,DIC="^AUTTCCT(",X=C,DIC("DR")="1///"_N
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;

AUM9114A
AUM9114A ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 2000JUL06 ; [ 07/12/2000  10:17 AM ]
 ;;99.1;TABLE MAINTENANCE;**14**;NOV 6,1998
 ;
UPDATE ;;IHS COST CENTER ADDITIONS - JULY 06, 2000
 ;
CCNEW ;;-->  NEW COST CENTERS: NO.^TITLE
 ;;72^FLOAT POOL
 ;;76^TELEMEDICINE
 ;;87^LABOR/DELIV./RECOV./POST-PARTUM (LDRP)
 ;;88^SPECIALTY CLINIC
 ;;A1^ORTHOPEDIC CLINIC
 ;;A2^SURGICAL CLINIC
 ;;A3^PODIATRY
 ;;A4^STAFF DEVELOPMENT
 ;;A5^SPEECH THERAPY
 ;;A6^AIDS
 ;;A7^HEPATITIS MANAGEMENT
 ;;A8^EEO
 ;;A9^ONCOLOGY SERVICES
 ;;B1^MEDICAL STAFF SERVICES
 ;;B2^PROCEDURE ROOM
 ;;B3^MANAGED CARE
 ;;END
 ;

AUM9114M
AUM9114M ; IHS/ASDST/GTH -  BACKGROUND VALUES FOR STANDARD TABLE UPDATES, 2000JUL06 ; [ 07/12/2000  10:17 AM ]
 ;;99.1;TABLE MAINTENANCE;**14**;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
 ;;END
 ;
SU ; AREA^SU^NAME
 ;;END
 ;
COUNTY ; STATE^COUNTY^NAME
 ;;END
 ;