4:48 PM 16-DEC-97 AUM v 97.1 Patch 13, SCB Updates from 03Dec97 Banyan. Restore 5 routines and DO ^AUM7113. A9AUM13 A9AUM13 ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 03DEC97 BANYAN, RPI ; [ 12/16/97 4:46 PM ] ;;97.1;TABLE MAINTENANCE;**13**;DEC 10,1996 ; D START^AUM7113 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)),"" Q ; DEL ; ;;A9AUM12 ;;AUM7113 ;;AUM71131 ;;AUM7113A ;;AUM7113M AUM7113 AUM7113 ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 03DEC97 BANYAN ; [ 12/16/97 4:46 PM ] ;;97.1;TABLE MAINTENANCE;**13**;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^AUM7113(""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 AUM7113 S X=+Y D H^%DTC S ZTDTH=%H_","_%T S ZTRTN="START^AUM7113",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("AUM7113",$J) D START^AUM71131 S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AUM7113"",$J,",XMY(1)="",XMY(DUZ)="" D ^XMD KILL ^TMP("AUM7113",$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^A9AUM13 Q ; INTRO ; ;;This updates standard tables according to the changes specified in ;;the Banyan message time stamped 03Dec97@11:13:19 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 ; AUM71131 AUM71131 ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 03DEC97 BANYAN ; [ 12/16/97 4:46 PM ] ;;97.1;TABLE MAINTENANCE;**13**;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^AUM7113A),";",3)) D DASH,LOCNEW,DASH,LOCMOD,DASH,COMMNEW,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^AUM7113A),";",3),":",1) IEN(X,%,Y) ; S Y=$O(@(X_"""C"",%,0)")) I 'Y S Y=$$VAL^AUM7113M(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("AUM7113",$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^AUM7113A) 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^AUM71131("^AUTTCTY(",S_O) Q:'P("O") S P("A")=$$IEN^AUM71131("^AUTTAREA(",A) Q:'P("A") S P("V")=$$IEN^AUM71131("^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^AUM7113A) Q:$P(L,";",3)="END" S L("TO")=$T(COMMMOD+T+1^AUM7113A) 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^AUM71131("^AUTTCTY(",S_O) . Q:'P("O") . S P("A")=$$IEN^AUM71131("^AUTTAREA(",A) . Q:'P("A") . S P("V")=$$IEN^AUM71131("^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("AUM7113A")_" 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^AUM7113A) 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 ; ; ----------------------------------------------------- ; LOCMOD ; S E=$$E("LOCMOD") D RSLT(E) 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^AUM7113A) Q:$P(L,";",3)="END" S L("TO")=$T(LOCMOD+T+1^AUM7113A) 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_";.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 ; Locations were name changes, only. Following line commented. ; D DASH,RSLT($$LOCMOD^AUMXPORT("AUM7113A")_" patients marked for export because of the Location Code changes.") ; Q ; ; ----------------------------------------------------- ; AUM7113A AUM7113A ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 03DEC97 BANYAN ; [ 12/16/97 4:46 PM ] ;;97.1;TABLE MAINTENANCE;**13**;DEC 10,1996 ; UPDATE ;;IHS STANDARD CODE BOOK MODIFICATIONS - NOVEMBER 1997 12/3/97 ; LOCNEW ;;A. NEW FACILITY CODES (SECTION VIII-C): AREA^S.U.^FAC^NAME^PSEUDO ;;10^00^95^REGIONAL YOUTH TRTMNT CTR^CDS ;;65^66^86^OFFICE^XRT ;;65^66^89^HOME^XRS ;;65^66^96^OTHER^XRU ;;75^73^10^NORTH IDAHO^POV ;;75^73^30^KAMIAH^POW ;;80^81^49^CHINLE HIGH SCHOOL^NIW ;;80^82^48^CROWNPOINT HIGH SCHOOL^NIX ;;80^82^49^THOREAU HIGH SCHOOL^NIY ;;80^83^44^NAVAJO PINE HIGH SCHOOL^NJU ;;80^83^45^NAVAJO PINE ELEMENTARY SCHOOL^NJV ;;80^83^46^WINDOW ROCK HIGH SCHOOL^NJW ;;80^83^47^TSE HOOTSOOI MIDDLE SCHOOL^NJX ;;80^83^48^HOGAN HOZHONI^NJY ;;80^83^49^WINDOW ROCK DETENTION CENTER^NJZ ;;80^84^49^FORT WINGATE HIGH SCHOOL^NKO ;;80^85^48^MONUMENT VALLEY HIGH SCHOOL^NKP ;;80^85^49^MONUMENT VALLEY H.S. (ND2)^NKQ ;;80^86^41^SHIPROCK HIGH SCHOOL^NKR ;;80^86^42^SHIPROCK NORTHWEST HIGH SCHOOL^NKS ;;80^86^43^TSE BIT AI MIDDLE SCHOOL^NKT ;;80^86^44^NEWCOMB HIGH SCHOOL^NKU ;;80^86^45^NEWCOMB JUNIOR HIGH SCHOOL^NKV ;;80^86^46^CAREER PREP HIGH SCHOOL^NKW ;;80^86^47^NAVAJO PREP HIGH SCHOOL^NKX ;;80^86^48^RED MESA HIGH SCHOOL^NKY ;;80^86^49^RED MESA JUNIOR HIGH SCHOOL^NKZ ;;80^87^52^GREYHILLS HIGH SCHOOL^NLC ;;80^87^53^TUBA CITY HIGH SCHOOL^NLD ;;END ; LOCMOD ;;B. FACILITY CODE CHANGES (SECTION VIII-C): AREA^S.U.^FAC^NAME^PSEUDO ;;FROM^10^21^53^MARTY CHURCH^CMC ;; TO^10^21^53^MARTY INDIAN SCHOOL^CMC ;;END ; COMMNEW ;;C. NEW COMMUNITY CODES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U. ;;55^68^992^WAUKESHA^11^00 ;;END ; AUM7113M AUM7113M ; IHS/ADC/GTH - BACKGROUND VALUES FOR STANDARD TABLE UPDATES, 03DEC97 BANYAN ; [ 12/16/97 4:46 PM ] ;;97.1;TABLE MAINTENANCE;**13**;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 10 ;;10^ABERDEEN^C^J45 11 ;;11^BEMIDJI^D^J46 65 ;;65^PHOENIX TRIBE/638^X^J40 75 ;;75^PORTLAND TRIBE/638^P^J64 80 ;;80^NAVAJO^N^J54 ;;END ; SU ; AREA^SU^NAME 1000 ;;10^00^NON SERVICE UNIT 1021 ;;10^21^YANKTON 1100 ;;11^00^NON SERVICE UNIT 6566 ;;65^66^PHOENIX 7573 ;;75^73^NORTHERN IDAHO 8081 ;;80^81^CHINLE 8082 ;;80^82^CROWNPOINT 8083 ;;80^83^FT.DEFIANCE 8084 ;;80^84^GALLUP 8085 ;;80^85^KAYENTA 8086 ;;80^86^SHIPROCK 8087 ;;80^87^TUBA CITY ;;END ; COUNTY ; STATE^COUNTY^NAME 5568 ;;55^68^WAUKESHA ;;END ;