AUMUPDT ;IHS/ITSC/DMJ - SCB UPDATE 2/18/2004 [ 10/04/2006 12:33 PM ]
;;8.1;AUM - SCB UPDATE;**1,2**;NOV 9, 2007
;
POST ;EP -- MAIN EP
N DA,DIC,DIE,DINUM,DLAYGO,DR,@($P($T(SVARS),";",3))
S AUMIEN=0
F S AUMIEN=$O(^AUMDATA(AUMIEN)) Q:'AUMIEN D
.S L=^AUMDATA(AUMIEN,0)
.S AUMACT=$P(L,"^",2)
.S AUMRTN=$P(L,"^",9)
.S:AUMRTN'="" AUMACT=AUMACT_"^"_AUMRTN
.S L=$P(L,"^",3,8)
.D @AUMACT
Q
;
ADDOK ;----- "ADDED" MESSAGE
D RSLT($J("",5)_"Added : "_L)
Q
;
ADDFAIL ;----- "FAILED" MESSAGE
D RSLT($J("",5)_$$M(0)_"ADD FAILED => "_L)
Q
;
DASH ;----- PRT DASH LINE
D RSLT("")
D RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70)))
D RSLT("")
Q
;
DIE ;----- DIE EDIT
N @($P($T(SVARS),";",3))
L +(@(DIE_DA_")")):10
E D RSLT($J("",5)_$$M(0)_"Entry '"_DIE_DA_"' IS LOCKED. NOTIFY PROGRAMMER.") S Y=1 Q
D ^DIE
L -(@(DIE_DA_")"))
Q
;
IEN(X,%,Y) ;
;----- UPDATE AREA, SERVICE UNIT, COUNTY
S Y=$O(@(X_"""C"",%,0)")) I Y Q +Y
I Y D S:Y<0 Y=""
.N %,@($P($T(SVARS),";",3))
.S L=Y
.I X["AREA" D Q
..N X
..D RSLT("(Add Missing Area)")
..D ADDAREA
..D RSLT("(END Add Missing Area)")
.I X["SU" D Q
..N X
..D RSLT("(Add Missing SU)")
..D ADDSU
..D RSLT("(END Add Missing SU)")
.I X["CTY" D Q
..N X
..D RSLT("(Add Missing County)")
..D ADDCNTY
..D RSLT("(END Add Missing County)")
;
D:'Y RSLT($J("",5)_$$M(0)_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
Q +Y
;
DIK ;--- KILL ENTRY
N @($P($T(SVARS),";",3)),DIK
D ^DIK
Q
;
FILE ;--- FILE NEW ENTRY
N @($P($T(SVARS),";",3))
K DD,DO
S DIC(0)="L"
D FILE^DICN
K DIC,DLAYGO
Q
;
M(%) ;--- ERROR MESSAGE
Q $S(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")
;
MODOK ;--- IF MOD OK
D RSLT($J("",5)_"Changed : "_L)
Q
;
RSLT(%) ;--- ISSUE MESSAGES DURING INSTALL
N @($P($T(SVARS),";",3))
D MES^XPDUTL(%)
Q
;
IXDIC(DIC,DIC0,D,X,DLAYGO) ;
;--- CALL TO FILEMAN IX^DIC
N @($P($T(SVARS),";",3))
S DIC(0)=DIC0
K DIC0
I '$G(DLAYGO) K DLAYGO
D IX^DIC
Q Y
;
AREANEW ;
S E="New Area Codes"
D ADDAREA
Q
;
ADDAREA ;--- NEW AREA
S A=$P(L,U),N=$P(L,U,2),R=$P(L,U,3),C=$P(L,U,4),L=$$LJ^XLFSTR(A,6)_$$LJ^XLFSTR(N,30)_$$LJ^XLFSTR(R,15)_C
I $D(^AUTTAREA("B",N)) D RSLT($J("",5)_$$M(1)_"NAME EXISTS => "_N) Q
I $D(^AUTTAREA("C",A)) D RSLT($J("",5)_$$M(1)_"CODE EXISTS => "_A) Q
S DLAYGO=9999999.21
S DIC="^AUTTAREA("
S X=N
S DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
CNTYNEW ;---- NEW COUNTY
D RSLT("NEW COUNTY CODES (SECTION V-B)")
D RSLT($$RJ^XLFSTR("STATE CNTY NAME",28))
D RSLT($$RJ^XLFSTR("----- ---- ----",28))
D ADDCNTY
Q
;
ADDCNTY ;--- NEW COUNTY
S S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3),A=$P(L,U,4),L=S_" "_C_" "_N_$J("",30-$L(N))_A
I $D(^AUTTCTY("C",S_C)) D RSLT($J("",5)_$$M(1)_"CODE EXISTS => "_S_C) Q
S P("S")=$$IEN("^DIC(5,",S)
Q:'P("S")
S DIC="^AUTTCTY("
S X=N
S DIC("DR")=".02////"_P("S")_";.03///"_C_";.06///"_A
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
SUNEW ;--- ADD NEW SU
D RSLT("NEW/REACTIVATED SERVICE UNIT CODE (SECTION VIII-B")
D RSLT($J("",13)_$$LJ^XLFSTR("AREA",6)_$$LJ^XLFSTR("S.U.",6)_"NAME")
D RSLT($J("",13)_$$LJ^XLFSTR("----",6)_$$LJ^XLFSTR("----",6)_"----")
D ADDSU
Q
;
ADDSU ;
S A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3),L=$$LJ^XLFSTR(A,6)_$$LJ^XLFSTR(S,6)_N
I $D(^AUTTSU("C",A_S)) D RSLT($J("",5)_$$M(1)_"ASU EXISTS => "_A_S) Q
S P=$$IEN("^AUTTAREA(",A)
Q:'P
S DLAYGO=9999999.22
S DIC="^AUTTSU("
S X=N
S DIC("DR")=".02////"_P_";.03///"_S
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
SUFR ;--- SU FROM
S LFR=L
Q
SUMOD ;--- MOD SU
D RSLT("SERVICE UNIT CODE CHANGES (SECTION VIII-B)")
D RSLT($J("",15)_"AA SU NAME")
D RSLT($J("",15)_"-- -- ----")
S A=$P(LFR,U),S=$P(LFR,U,2),N=$P(LFR,U,3)
S P=$O(^AUTTSU("C",A_S,0))
S LTO=L
S A=$P(LTO,U),S=$P(LTO,U,2),N=$P(LTO,U,3)
I 'P S P=$O(^AUTTSU("C",A_S,0)) I 'P D ADDSU Q
S L=A_" "_S_" "_N
S P("A")=$$IEN("^AUTTAREA(",A)
Q:'P("A")
S DIE="^AUTTSU("
S DA=P
S DR=".01///"_N_";.02////"_P("A")_";.03///"_S
D DIE
I $D(Y) D RSLT($J("",5)_" : EDIT SERVICE UNIT FAILED => "_L) Q
D MODOK
Q
;
SUINA ;--- INACTIVATE SERVICE UNIT
D RSLT("Inactivated Service Unit Codes (SECTION VIII-B)")
D RSLT($J("",15)_"AA SU NAME")
D RSLT($J("",15)_"-- -- ----")
S A=$P(L,"^",1),S=$P(L,"^",2),N=$P(L,"^",3)
S P=$O(^AUTTSU("C",A_S,0))
I 'P D Q
.D RSLT("SERVICE UNIT CODE NOT FOUND")
S ^AUTTSU(P,-9)="INACTIVE"
S L=$TR(L,"^"," ")
D RSLT("Inactivated => "_L)
Q
;
LOCNEW ;--- ADD NEW LOCATION
D RSLT("NEW FACILITY CODES (SECTION VIII-C)")
D RSLT($$RJ^XLFSTR("AA SU FA NAME",26)_$$RJ^XLFSTR("PSEUDO",34))
D RSLT($$RJ^XLFSTR("-- -- -- ----",26)_$$RJ^XLFSTR("------",34))
D ADDLOC
Q
ADDLOC ;
S A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4),P=$P(L,U,5),UQID=$P(L,U,6)
S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_P
S %=A_S_F,%=$O(^AUTTLOC("C",%,0))
I % D RSLT($J("",5)_$$M(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)_$$M(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)_$$M(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)_$$M(0)_"EDIT PSEUDO PREFIX FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"PSEUDO PREFIX UPDATED => "_L)
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)_$$M(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.") Q
Q:DINUM>99999
S DLAYGO=4,DIC="^DIC(4,",X=N
D FILE
K DINUM,DLAYGO
I Y<0 D RSLT($J("",5)_$$M(0)_"^DIC(4 ADD FAILED => "_L) Q
NEW AUMAD
S AUMAD=0
F S AUMAD=$O(^DD(4,.01,1,AUMAD)) Q:'AUMAD I $P(^(AUMAD,0),U,2)="AD",$E(^(1),1)="I" Q
; If AD xref on 4 is active, edit LOCATION and Quit.
I AUMAD D Q
.S DA=+Y,DIE="^AUTTLOC(",DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P_";.32///"_UQID
.D DIE
.I '$D(Y) D ADDOK Q
.D RSLT($J("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L)
S DINUM=+Y,DLAYGO=9999999.06
S DIC="^AUTTLOC(",X=DINUM,DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P_";.32///"_UQID
D FILE,@$S(Y>0:"ADDOK",1:"ADDFAIL")
KILL DINUM,DLAYGO
Q
;
LOCFR ;LOCATION FROM
S LFR=L
Q
LOCMOD ;--- MOD LOCATION
D RSLT("FACILITY CODE CHANGES (SECTION VIII-C)")
D RSLT($$RJ^XLFSTR("AA SU FA NAME",28)_$$RJ^XLFSTR("PSEUDO",34))
D RSLT($$RJ^XLFSTR("-- -- -- ----",28)_$$RJ^XLFSTR("------",34))
S A=$P(LFR,U),S=$P(LFR,U,2),F=$P(LFR,U,3)
S P=$O(^AUTTLOC("C",A_S_F,0))
S LTO=L
S A=$P(LTO,U),S=$P(LTO,U,2),F=$P(LTO,U,3),N=$P(LTO,U,4)
I 'P S P=$O(^AUTTLOC("C",A_S_F,0)) I 'P D ADDLOC Q
S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_$P(LTO,U,5)
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(LTO,U,5)_";.32////"_$P(LTO,U,6)
S ZZDIE=DIE,ZZDA=DA,ZZDR=DR
D DIE
I $D(Y) D RSLT($J("",5)_$$M(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)_$$M(0)_"EDIT INSTITUTION FAILED => "_L) Q
D MODOK
D DASH,RSLT($$LOCMOD^AUMXPORT(LFR,LTO)_" patients marked for export because of the Location Code changes.")
Q
;
LOCINA ;--- INACTIVATE LOCATION
D RSLT("Inactivated Location Codes")
S 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_" "_P
S %=A_S_F,%=$O(^AUTTLOC("C",%,0))
I '% D RSLT($J("",5)_"ASUFAC "_A_S_F_" not found (OK).") Q
S DIE="^AUTTLOC(",DA=%,DR=".27////"_DT
D DIE
I $D(Y) D RSLT($J("",5)_"EDIT INACTIVE DATE FAILED => "_L) I 1
E D RSLT($J("",5)_"INACTIVATED => "_L)
Q
;
COMNEW ;--- ADD COMMUNITY
D RSLT("NEW COMMUNITY CODES (SECTION V-C)")
D RSLT($$RJ^XLFSTR("ST CT COM NAME",27)_$$RJ^XLFSTR("AA SU",33))
D RSLT($$RJ^XLFSTR("-- -- --- ----",27)_$$RJ^XLFSTR("-- --",33))
D ADDCOMM
Q
ADDCOMM ;
S 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)_$$M(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
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
COMFR ;community from
S LFR=L
Q
COMMOD ;--- MOD COMMUNITY
D RSLT("COMMUNITY CODE CHANGES (SECTION V-C)")
D RSLT($J("",15)_"ST CT COM NAME"_$J("",28)_"AA SU")
D RSLT($J("",15)_"-- -- --- ----"_$J("",28)_"-- --")
S S=$P(LFR,U),O=$P(LFR,U,2),C=$P(LFR,U,3)
S DA=$O(^AUTTCOM("C",S_O_C,0))
S LTO=L
S S=$P(LTO,U),O=$P(LTO,U,2),C=$P(LTO,U,3),N=$P(LTO,U,4),A=$P(LTO,U,5),V=$P(LTO,U,6)
I 'DA S DA=$O(^AUTTCOM("C",S_O_C,0))
I 'DA 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("
S DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
D DIE
I $D(Y) D RSLT($J("",5)_$$M(0)_"CHANGE FAILED => "_L) Q
D MODOK
D DASH
D DASH,RSLT($$COMMMOD^AUMXPORT(LFR,LTO)_" patients marked for export because of the Community Code changes.")
Q
;
CLINNEW ;--- ADD NEW CLINIC
D RSLT("NEW CLINIC CODES (SECTION XIX)")
D RSLT($J("",11)_"CODE NAME"_$J("",28)_"ABRV. PRI.CARE 1A WL RPT")
D RSLT($J("",11)_"---- ----"_$J("",28)_"----- -------- ---------")
D ADDCLIN
KILL DLAYGO
Q
;
ADDCLIN ;
S C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),P=$P(L,U,4),R=$P(L,U,5),L=C_" "_N_$J("",(32-$L(N)))_$$LJ^XLFSTR(A,8)_$$LJ^XLFSTR(P,11)_R
I $D(^DIC(40.7,"C",C)) D RSLT($J("",5)_$$M(1)_"CLINIC CODE EXISTS => "_C),RSLT("") Q
S DLAYGO=40.7,DIC="^DIC(40.7,",X=N,DIC("DR")="1///"_C_";999999901///"_A_";90000.01///"_R
I $L(P) S DIC("DR")=DIC("DR")_";999999902///"_P
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
Q
;
CLINFR ;clinic from
S LFR=L
Q
;
CLINMOD ;--- MOD CLINIC
D RSLT("MODIFY CLINIC")
D RSLT($J("",13)_"CODE NAME"_$J("",28)_"ABRV. PRI.CARE 1A WL RPT")
D RSLT($J("",13)_"---- ----"_$J("",28)_"----- -------- ---------")
S LTO=L
S C=$P(LTO,"^",1),N=$P(LTO,"^",2),A=$P(LTO,"^",3),P=$P(LTO,"^",4),R=$P(LTO,"^",5)
S DA=$O(^DIC(40.7,"C",C,0))
I 'DA D ADDCLIN Q
S DIE="^DIC(40.7,"
S DR=".01///"_N_";999999901///"_A_";999999902///"_P_";90000.01///"_R
D ^DIE
S L=C_" "_N_$J("",(32-$L(N)))_$$LJ^XLFSTR(A,8)_$$LJ^XLFSTR(P,11)_R
D MODOK
Q
;
TRIBEFR ;tribe from
S LFR=L
Q
TRIBEMOD ;--- MOD TRIBE
; C=CODE, O=OLD, N=NAME, P=IEN
D RSLT("MODIFY TRIBE")
D RSLT($$RJ^XLFSTR("CODE OLD NAME",28))
D RSLT($$RJ^XLFSTR("---- --- ----",28))
S C=$P(LFR,U),O=$P(LFR,U,2),N=$P(LFR,U,3)
S P=$O(^AUTTTRI("C",C,0))
S LTO=L
S C=$P(LTO,U),O=$P(LTO,U,2),N=$P(LTO,U,3),G=$P(LTO,U,4)
I 'P S P=$O(^AUTTTRI("C",C,0))
I 'P D ADDTRIBE Q
S L=C_" "_O_" "_N
S DIE="^AUTTTRI("
S DA=P
S DR=".01///"_N_";.02///"_C_";.03///"_G_";.04///"_O
D DIE
I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT TRIBE FAILED => "_L) Q
D MODOK
Q
TRIBENEW ;--- NEW TRIBE
D RSLT("NEW TRIBE")
D ADDTRIBE
Q
ADDTRIBE ;
S C=$P(L,U),O=$P(L,U,2),N=$P(L,U,3),G=$P(L,"^",4)
S L=" "_$$LJ^XLFSTR(C,5)_$$LJ^XLFSTR(O,4)_N
S %=$O(^AUTTTRI("C",C,0))
I % D RSLT($J("",5)_$$M(1)_"TRIBE EXISTS => "_N) Q
S DLAYGO=9999999.03
S DIC="^AUTTTRI("
S X=N
S DIC("DR")=".02///"_C_";.03///"_G_";.04///"_O
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
PCLASFR ;provider class
D PCLASFR^AUMUPD2
Q
;
PCLASMOD ;provider class change
D PCLASMOD^AUMUPD2
Q
EXAMNEW ;new exam
D EXAMNEW^AUMUPD2
Q
ETUPDT ;update education topics
S AUMN=$P(L,"^",2)
S AUMIEN2=$O(^AUTTEDT("C",AUMN,0))
Q:'AUMIEN2
S ^AUTTEDT(AUMIEN2,0)=L
Q
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables
Q
AUMUPDT ;IHS/ITSC/DMJ - SCB UPDATE 2/18/2004 [ 10/04/2006 12:33 PM ]
+1 ;;8.1;AUM - SCB UPDATE;**1,2**;NOV 9, 2007
+2 ;
POST ;EP -- MAIN EP
+1 NEW DA,DIC,DIE,DINUM,DLAYGO,DR,@($PIECE($TEXT(SVARS),";",3))
+2 SET AUMIEN=0
+3 FOR
SET AUMIEN=$ORDER(^AUMDATA(AUMIEN))
IF 'AUMIEN
QUIT
Begin DoDot:1
+4 SET L=^AUMDATA(AUMIEN,0)
+5 SET AUMACT=$PIECE(L,"^",2)
+6 SET AUMRTN=$PIECE(L,"^",9)
+7 IF AUMRTN'=""
SET AUMACT=AUMACT_"^"_AUMRTN
+8 SET L=$PIECE(L,"^",3,8)
+9 DO @AUMACT
End DoDot:1
+10 QUIT
+11 ;
ADDOK ;----- "ADDED" MESSAGE
+1 DO RSLT($JUSTIFY("",5)_"Added : "_L)
+2 QUIT
+3 ;
ADDFAIL ;----- "FAILED" MESSAGE
+1 DO RSLT($JUSTIFY("",5)_$$M(0)_"ADD FAILED => "_L)
+2 QUIT
+3 ;
DASH ;----- PRT DASH LINE
+1 DO RSLT("")
+2 DO RSLT($$REPEAT^XLFSTR("-",$SELECT($GET(IOM):IOM-10,1:70)))
+3 DO RSLT("")
+4 QUIT
+5 ;
DIE ;----- DIE EDIT
+1 NEW @($PIECE($TEXT(SVARS),";",3))
+2 LOCK +(@(DIE_DA_")")):10
+3 IF '$TEST
DO RSLT($JUSTIFY("",5)_$$M(0)_"Entry '"_DIE_DA_"' IS LOCKED. NOTIFY PROGRAMMER.")
SET Y=1
QUIT
+4 DO ^DIE
+5 LOCK -(@(DIE_DA_")"))
+6 QUIT
+7 ;
IEN(X,%,Y) ;
+1 ;----- UPDATE AREA, SERVICE UNIT, COUNTY
+2 SET Y=$ORDER(@(X_"""C"",%,0)"))
IF Y
QUIT +Y
+3 IF Y
Begin DoDot:1
+4 NEW %,@($PIECE($TEXT(SVARS),";",3))
+5 SET L=Y
+6 IF X["AREA"
Begin DoDot:2
+7 NEW X
+8 DO RSLT("(Add Missing Area)")
+9 DO ADDAREA
+10 DO RSLT("(END Add Missing Area)")
End DoDot:2
QUIT
+11 IF X["SU"
Begin DoDot:2
+12 NEW X
+13 DO RSLT("(Add Missing SU)")
+14 DO ADDSU
+15 DO RSLT("(END Add Missing SU)")
End DoDot:2
QUIT
+16 IF X["CTY"
Begin DoDot:2
+17 NEW X
+18 DO RSLT("(Add Missing County)")
+19 DO ADDCNTY
+20 DO RSLT("(END Add Missing County)")
End DoDot:2
QUIT
End DoDot:1
IF Y<0
SET Y=""
+21 ;
+22 IF 'Y
DO RSLT($JUSTIFY("",5)_$$M(0)_$PIECE(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
+23 QUIT +Y
+24 ;
DIK ;--- KILL ENTRY
+1 NEW @($PIECE($TEXT(SVARS),";",3)),DIK
+2 DO ^DIK
+3 QUIT
+4 ;
FILE ;--- FILE NEW ENTRY
+1 NEW @($PIECE($TEXT(SVARS),";",3))
+2 KILL DD,DO
+3 SET DIC(0)="L"
+4 DO FILE^DICN
+5 KILL DIC,DLAYGO
+6 QUIT
+7 ;
M(%) ;--- ERROR MESSAGE
+1 QUIT $SELECT(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")
+2 ;
MODOK ;--- IF MOD OK
+1 DO RSLT($JUSTIFY("",5)_"Changed : "_L)
+2 QUIT
+3 ;
RSLT(%) ;--- ISSUE MESSAGES DURING INSTALL
+1 NEW @($PIECE($TEXT(SVARS),";",3))
+2 DO MES^XPDUTL(%)
+3 QUIT
+4 ;
IXDIC(DIC,DIC0,D,X,DLAYGO) ;
+1 ;--- CALL TO FILEMAN IX^DIC
+2 NEW @($PIECE($TEXT(SVARS),";",3))
+3 SET DIC(0)=DIC0
+4 KILL DIC0
+5 IF '$GET(DLAYGO)
KILL DLAYGO
+6 DO IX^DIC
+7 QUIT Y
+8 ;
AREANEW ;
+1 SET E="New Area Codes"
+2 DO ADDAREA
+3 QUIT
+4 ;
ADDAREA ;--- NEW AREA
+1 SET A=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET R=$PIECE(L,U,3)
SET C=$PIECE(L,U,4)
SET L=$$LJ^XLFSTR(A,6)_$$LJ^XLFSTR(N,30)_$$LJ^XLFSTR(R,15)_C
+2 IF $DATA(^AUTTAREA("B",N))
DO RSLT($JUSTIFY("",5)_$$M(1)_"NAME EXISTS => "_N)
QUIT
+3 IF $DATA(^AUTTAREA("C",A))
DO RSLT($JUSTIFY("",5)_$$M(1)_"CODE EXISTS => "_A)
QUIT
+4 SET DLAYGO=9999999.21
+5 SET DIC="^AUTTAREA("
+6 SET X=N
+7 SET DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
+8 DO FILE
+9 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+10 QUIT
+11 ;
CNTYNEW ;---- NEW COUNTY
+1 DO RSLT("NEW COUNTY CODES (SECTION V-B)")
+2 DO RSLT($$RJ^XLFSTR("STATE CNTY NAME",28))
+3 DO RSLT($$RJ^XLFSTR("----- ---- ----",28))
+4 DO ADDCNTY
+5 QUIT
+6 ;
ADDCNTY ;--- NEW COUNTY
+1 SET S=$PIECE(L,U)
SET C=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET A=$PIECE(L,U,4)
SET L=S_" "_C_" "_N_$JUSTIFY("",30-$LENGTH(N))_A
+2 IF $DATA(^AUTTCTY("C",S_C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"CODE EXISTS => "_S_C)
QUIT
+3 SET P("S")=$$IEN("^DIC(5,",S)
+4 IF 'P("S")
QUIT
+5 SET DIC="^AUTTCTY("
+6 SET X=N
+7 SET DIC("DR")=".02////"_P("S")_";.03///"_C_";.06///"_A
+8 DO FILE
+9 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+10 QUIT
+11 ;
SUNEW ;--- ADD NEW SU
+1 DO RSLT("NEW/REACTIVATED SERVICE UNIT CODE (SECTION VIII-B")
+2 DO RSLT($JUSTIFY("",13)_$$LJ^XLFSTR("AREA",6)_$$LJ^XLFSTR("S.U.",6)_"NAME")
+3 DO RSLT($JUSTIFY("",13)_$$LJ^XLFSTR("----",6)_$$LJ^XLFSTR("----",6)_"----")
+4 DO ADDSU
+5 QUIT
+6 ;
ADDSU ;
+1 SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET L=$$LJ^XLFSTR(A,6)_$$LJ^XLFSTR(S,6)_N
+2 IF $DATA(^AUTTSU("C",A_S))
DO RSLT($JUSTIFY("",5)_$$M(1)_"ASU EXISTS => "_A_S)
QUIT
+3 SET P=$$IEN("^AUTTAREA(",A)
+4 IF 'P
QUIT
+5 SET DLAYGO=9999999.22
+6 SET DIC="^AUTTSU("
+7 SET X=N
+8 SET DIC("DR")=".02////"_P_";.03///"_S
+9 DO FILE
+10 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+11 QUIT
+12 ;
SUFR ;--- SU FROM
+1 SET LFR=L
+2 QUIT
SUMOD ;--- MOD SU
+1 DO RSLT("SERVICE UNIT CODE CHANGES (SECTION VIII-B)")
+2 DO RSLT($JUSTIFY("",15)_"AA SU NAME")
+3 DO RSLT($JUSTIFY("",15)_"-- -- ----")
+4 SET A=$PIECE(LFR,U)
SET S=$PIECE(LFR,U,2)
SET N=$PIECE(LFR,U,3)
+5 SET P=$ORDER(^AUTTSU("C",A_S,0))
+6 SET LTO=L
+7 SET A=$PIECE(LTO,U)
SET S=$PIECE(LTO,U,2)
SET N=$PIECE(LTO,U,3)
+8 IF 'P
SET P=$ORDER(^AUTTSU("C",A_S,0))
IF 'P
DO ADDSU
QUIT
+9 SET L=A_" "_S_" "_N
+10 SET P("A")=$$IEN("^AUTTAREA(",A)
+11 IF 'P("A")
QUIT
+12 SET DIE="^AUTTSU("
+13 SET DA=P
+14 SET DR=".01///"_N_";.02////"_P("A")_";.03///"_S
+15 DO DIE
+16 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_" : EDIT SERVICE UNIT FAILED => "_L)
QUIT
+17 DO MODOK
+18 QUIT
+19 ;
SUINA ;--- INACTIVATE SERVICE UNIT
+1 DO RSLT("Inactivated Service Unit Codes (SECTION VIII-B)")
+2 DO RSLT($JUSTIFY("",15)_"AA SU NAME")
+3 DO RSLT($JUSTIFY("",15)_"-- -- ----")
+4 SET A=$PIECE(L,"^",1)
SET S=$PIECE(L,"^",2)
SET N=$PIECE(L,"^",3)
+5 SET P=$ORDER(^AUTTSU("C",A_S,0))
+6 IF 'P
Begin DoDot:1
+7 DO RSLT("SERVICE UNIT CODE NOT FOUND")
End DoDot:1
QUIT
+8 SET ^AUTTSU(P,-9)="INACTIVE"
+9 SET L=$TRANSLATE(L,"^"," ")
+10 DO RSLT("Inactivated => "_L)
+11 QUIT
+12 ;
LOCNEW ;--- ADD NEW LOCATION
+1 DO RSLT("NEW FACILITY CODES (SECTION VIII-C)")
+2 DO RSLT($$RJ^XLFSTR("AA SU FA NAME",26)_$$RJ^XLFSTR("PSEUDO",34))
+3 DO RSLT($$RJ^XLFSTR("-- -- -- ----",26)_$$RJ^XLFSTR("------",34))
+4 DO ADDLOC
+5 QUIT
ADDLOC ;
+1 SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET P=$PIECE(L,U,5)
SET UQID=$PIECE(L,U,6)
+2 SET L=A_" "_S_" "_F_" "_N_$JUSTIFY("",32-$LENGTH(N))_P
+3 SET %=A_S_F
SET %=$ORDER(^AUTTLOC("C",%,0))
+4 IF %
DO RSLT($JUSTIFY("",5)_$$M(1)_"ASUFAC EXISTS => "_A_S_F)
Begin DoDot:1
+5 IF $PIECE($GET(^AUTTLOC(%,0)),U,21)
SET DIE="^AUTTLOC("
SET DA=%
SET DR=".27///@;.28////"_DT
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"DELETE INACTIVE DATE FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"INACTIVE DATE DELETED => "_L)
+6 SET %=$ORDER(^AUTTLOC("C",A_S_F,0))
SET %=$PIECE(^AUTTLOC(%,0),U)
+7 IF %
IF $DATA(^DIC(4,%,0))
IF N'=$PIECE(^DIC(4,%,0),U)
SET DIE="^DIC(4,"
SET DA=%
SET DR=".01///"_N
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"INSTITUTION NAME UPDATED => "_L)
+8 SET %=$ORDER(^AUTTLOC("C",A_S_F,0))
+9 IF P'=$PIECE($GET(^AUTTLOC(%,1)),U,2)
SET DIE="^AUTTLOC("
SET DA=%
SET DR=".28////"_DT_";.31///"_P
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT PSEUDO PREFIX FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"PSEUDO PREFIX UPDATED => "_L)
End DoDot:1
QUIT
+10 SET P("A")=$$IEN("^AUTTAREA(",A)
+11 IF 'P("A")
QUIT
+12 SET P("S")=$$IEN("^AUTTSU(",A_S)
+13 IF 'P("S")
QUIT
+14 FOR DINUM=+$PIECE(^DIC(4,0),U,3):1
IF '$DATA(^DIC(4,DINUM))&('$DATA(^AUTTLOC(DINUM)))
QUIT
IF DINUM>99999
DO RSLT($JUSTIFY("",5)_$$M(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.")
QUIT
+15 IF DINUM>99999
QUIT
+16 SET DLAYGO=4
SET DIC="^DIC(4,"
SET X=N
+17 DO FILE
+18 KILL DINUM,DLAYGO
+19 IF Y<0
DO RSLT($JUSTIFY("",5)_$$M(0)_"^DIC(4 ADD FAILED => "_L)
QUIT
+20 NEW AUMAD
+21 SET AUMAD=0
+22 FOR
SET AUMAD=$ORDER(^DD(4,.01,1,AUMAD))
IF 'AUMAD
QUIT
IF $PIECE(^(AUMAD,0),U,2)="AD"
IF $EXTRACT(^(1),1)="I"
QUIT
+23 ; If AD xref on 4 is active, edit LOCATION and Quit.
+24 IF AUMAD
Begin DoDot:1
+25 SET DA=+Y
SET DIE="^AUTTLOC("
SET DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P_";.32///"_UQID
+26 DO DIE
+27 IF '$DATA(Y)
DO ADDOK
QUIT
+28 DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L)
End DoDot:1
QUIT
+29 SET DINUM=+Y
SET DLAYGO=9999999.06
+30 SET DIC="^AUTTLOC("
SET X=DINUM
SET DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P_";.32///"_UQID
+31 DO FILE
DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+32 KILL DINUM,DLAYGO
+33 QUIT
+34 ;
LOCFR ;LOCATION FROM
+1 SET LFR=L
+2 QUIT
LOCMOD ;--- MOD LOCATION
+1 DO RSLT("FACILITY CODE CHANGES (SECTION VIII-C)")
+2 DO RSLT($$RJ^XLFSTR("AA SU FA NAME",28)_$$RJ^XLFSTR("PSEUDO",34))
+3 DO RSLT($$RJ^XLFSTR("-- -- -- ----",28)_$$RJ^XLFSTR("------",34))
+4 SET A=$PIECE(LFR,U)
SET S=$PIECE(LFR,U,2)
SET F=$PIECE(LFR,U,3)
+5 SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
+6 SET LTO=L
+7 SET A=$PIECE(LTO,U)
SET S=$PIECE(LTO,U,2)
SET F=$PIECE(LTO,U,3)
SET N=$PIECE(LTO,U,4)
+8 IF 'P
SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
IF 'P
DO ADDLOC
QUIT
+9 SET L=A_" "_S_" "_F_" "_N_$JUSTIFY("",32-$LENGTH(N))_$PIECE(LTO,U,5)
+10 SET P("A")=$$IEN("^AUTTAREA(",A)
+11 IF 'P("A")
QUIT
+12 SET P("S")=$$IEN("^AUTTSU(",A_S)
+13 IF 'P("S")
QUIT
+14 SET DIE="^AUTTLOC("
SET DA=P
SET DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_$PIECE(LTO,U,5)_";.32////"_$PIECE(LTO,U,6)
+15 SET ZZDIE=DIE
SET ZZDA=DA
SET ZZDR=DR
+16 DO DIE
+17 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L)
QUIT
+18 SET DIE="^DIC(4,"
SET DA=$PIECE(^AUTTLOC(P,0),U)
SET DR=".01///"_N
+19 DO DIE
+20 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L)
QUIT
+21 DO MODOK
+22 DO DASH
DO RSLT($$LOCMOD^AUMXPORT(LFR,LTO)_" patients marked for export because of the Location Code changes.")
+23 QUIT
+24 ;
LOCINA ;--- INACTIVATE LOCATION
+1 DO RSLT("Inactivated Location Codes")
+2 SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET P=$PIECE(L,U,5)
+3 SET L=A_" "_S_" "_F_" "_N_" "_P
+4 SET %=A_S_F
SET %=$ORDER(^AUTTLOC("C",%,0))
+5 IF '%
DO RSLT($JUSTIFY("",5)_"ASUFAC "_A_S_F_" not found (OK).")
QUIT
+6 SET DIE="^AUTTLOC("
SET DA=%
SET DR=".27////"_DT
+7 DO DIE
+8 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_"EDIT INACTIVE DATE FAILED => "_L)
IF 1
+9 IF '$TEST
DO RSLT($JUSTIFY("",5)_"INACTIVATED => "_L)
+10 QUIT
+11 ;
COMNEW ;--- ADD COMMUNITY
+1 DO RSLT("NEW COMMUNITY CODES (SECTION V-C)")
+2 DO RSLT($$RJ^XLFSTR("ST CT COM NAME",27)_$$RJ^XLFSTR("AA SU",33))
+3 DO RSLT($$RJ^XLFSTR("-- -- --- ----",27)_$$RJ^XLFSTR("-- --",33))
+4 DO ADDCOMM
+5 QUIT
ADDCOMM ;
+1 SET S=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET A=$PIECE(L,U,5)
SET V=$PIECE(L,U,6)
SET L=S_" "_O_" "_C_" "_N_$JUSTIFY("",32-$LENGTH(N))_A_" "_V
+2 IF $DATA(^AUTTCOM("C",S_O_C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"STCTYCOM CODE EXISTS => "_S_O_C)
QUIT
+3 SET P("O")=$$IEN("^AUTTCTY(",S_O)
+4 IF 'P("O")
QUIT
+5 SET P("A")=$$IEN("^AUTTAREA(",A)
+6 IF 'P("A")
QUIT
+7 SET P("V")=$$IEN("^AUTTSU(",A_V)
+8 IF 'P("V")
QUIT
+9 SET DLAYGO=9999999.05
SET DIC="^AUTTCOM("
SET X=N
SET DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
+10 DO FILE
+11 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+12 QUIT
+13 ;
COMFR ;community from
+1 SET LFR=L
+2 QUIT
COMMOD ;--- MOD COMMUNITY
+1 DO RSLT("COMMUNITY CODE CHANGES (SECTION V-C)")
+2 DO RSLT($JUSTIFY("",15)_"ST CT COM NAME"_$JUSTIFY("",28)_"AA SU")
+3 DO RSLT($JUSTIFY("",15)_"-- -- --- ----"_$JUSTIFY("",28)_"-- --")
+4 SET S=$PIECE(LFR,U)
SET O=$PIECE(LFR,U,2)
SET C=$PIECE(LFR,U,3)
+5 SET DA=$ORDER(^AUTTCOM("C",S_O_C,0))
+6 SET LTO=L
+7 SET S=$PIECE(LTO,U)
SET O=$PIECE(LTO,U,2)
SET C=$PIECE(LTO,U,3)
SET N=$PIECE(LTO,U,4)
SET A=$PIECE(LTO,U,5)
SET V=$PIECE(LTO,U,6)
+8 IF 'DA
SET DA=$ORDER(^AUTTCOM("C",S_O_C,0))
+9 IF 'DA
DO ADDCOMM
QUIT
+10 SET L=S_" "_O_" "_C_" "_N_$JUSTIFY("",32-$LENGTH(N))_A_" "_V
+11 SET P("O")=$$IEN("^AUTTCTY(",S_O)
+12 IF 'P("O")
QUIT
+13 SET P("A")=$$IEN("^AUTTAREA(",A)
+14 IF 'P("A")
QUIT
+15 SET P("V")=$$IEN("^AUTTSU(",A_V)
+16 IF 'P("V")
QUIT
+17 SET DIE="^AUTTCOM("
+18 SET DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
+19 DO DIE
+20 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"CHANGE FAILED => "_L)
QUIT
+21 DO MODOK
+22 DO DASH
+23 DO DASH
DO RSLT($$COMMMOD^AUMXPORT(LFR,LTO)_" patients marked for export because of the Community Code changes.")
+24 QUIT
+25 ;
CLINNEW ;--- ADD NEW CLINIC
+1 DO RSLT("NEW CLINIC CODES (SECTION XIX)")
+2 DO RSLT($JUSTIFY("",11)_"CODE NAME"_$JUSTIFY("",28)_"ABRV. PRI.CARE 1A WL RPT")
+3 DO RSLT($JUSTIFY("",11)_"---- ----"_$JUSTIFY("",28)_"----- -------- ---------")
+4 DO ADDCLIN
+5 KILL DLAYGO
+6 QUIT
+7 ;
ADDCLIN ;
+1 SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET A=$PIECE(L,U,3)
SET P=$PIECE(L,U,4)
SET R=$PIECE(L,U,5)
SET L=C_" "_N_$JUSTIFY("",(32-$LENGTH(N)))_$$LJ^XLFSTR(A,8)_$$LJ^XLFSTR(P,11)_R
+2 IF $DATA(^DIC(40.7,"C",C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"CLINIC CODE EXISTS => "_C)
DO RSLT("")
QUIT
+3 SET DLAYGO=40.7
SET DIC="^DIC(40.7,"
SET X=N
SET DIC("DR")="1///"_C_";999999901///"_A_";90000.01///"_R
+4 IF $LENGTH(P)
SET DIC("DR")=DIC("DR")_";999999902///"_P
+5 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+6 QUIT
+7 ;
CLINFR ;clinic from
+1 SET LFR=L
+2 QUIT
+3 ;
CLINMOD ;--- MOD CLINIC
+1 DO RSLT("MODIFY CLINIC")
+2 DO RSLT($JUSTIFY("",13)_"CODE NAME"_$JUSTIFY("",28)_"ABRV. PRI.CARE 1A WL RPT")
+3 DO RSLT($JUSTIFY("",13)_"---- ----"_$JUSTIFY("",28)_"----- -------- ---------")
+4 SET LTO=L
+5 SET C=$PIECE(LTO,"^",1)
SET N=$PIECE(LTO,"^",2)
SET A=$PIECE(LTO,"^",3)
SET P=$PIECE(LTO,"^",4)
SET R=$PIECE(LTO,"^",5)
+6 SET DA=$ORDER(^DIC(40.7,"C",C,0))
+7 IF 'DA
DO ADDCLIN
QUIT
+8 SET DIE="^DIC(40.7,"
+9 SET DR=".01///"_N_";999999901///"_A_";999999902///"_P_";90000.01///"_R
+10 DO ^DIE
+11 SET L=C_" "_N_$JUSTIFY("",(32-$LENGTH(N)))_$$LJ^XLFSTR(A,8)_$$LJ^XLFSTR(P,11)_R
+12 DO MODOK
+13 QUIT
+14 ;
TRIBEFR ;tribe from
+1 SET LFR=L
+2 QUIT
TRIBEMOD ;--- MOD TRIBE
+1 ; C=CODE, O=OLD, N=NAME, P=IEN
+2 DO RSLT("MODIFY TRIBE")
+3 DO RSLT($$RJ^XLFSTR("CODE OLD NAME",28))
+4 DO RSLT($$RJ^XLFSTR("---- --- ----",28))
+5 SET C=$PIECE(LFR,U)
SET O=$PIECE(LFR,U,2)
SET N=$PIECE(LFR,U,3)
+6 SET P=$ORDER(^AUTTTRI("C",C,0))
+7 SET LTO=L
+8 SET C=$PIECE(LTO,U)
SET O=$PIECE(LTO,U,2)
SET N=$PIECE(LTO,U,3)
SET G=$PIECE(LTO,U,4)
+9 IF 'P
SET P=$ORDER(^AUTTTRI("C",C,0))
+10 IF 'P
DO ADDTRIBE
QUIT
+11 SET L=C_" "_O_" "_N
+12 SET DIE="^AUTTTRI("
+13 SET DA=P
+14 SET DR=".01///"_N_";.02///"_C_";.03///"_G_";.04///"_O
+15 DO DIE
+16 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT TRIBE FAILED => "_L)
QUIT
+17 DO MODOK
+18 QUIT
TRIBENEW ;--- NEW TRIBE
+1 DO RSLT("NEW TRIBE")
+2 DO ADDTRIBE
+3 QUIT
ADDTRIBE ;
+1 SET C=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET G=$PIECE(L,"^",4)
+2 SET L=" "_$$LJ^XLFSTR(C,5)_$$LJ^XLFSTR(O,4)_N
+3 SET %=$ORDER(^AUTTTRI("C",C,0))
+4 IF %
DO RSLT($JUSTIFY("",5)_$$M(1)_"TRIBE EXISTS => "_N)
QUIT
+5 SET DLAYGO=9999999.03
+6 SET DIC="^AUTTTRI("
+7 SET X=N
+8 SET DIC("DR")=".02///"_C_";.03///"_G_";.04///"_O
+9 DO FILE
+10 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+11 QUIT
+12 ;
PCLASFR ;provider class
+1 DO PCLASFR^AUMUPD2
+2 QUIT
+3 ;
PCLASMOD ;provider class change
+1 DO PCLASMOD^AUMUPD2
+2 QUIT
EXAMNEW ;new exam
+1 DO EXAMNEW^AUMUPD2
+2 QUIT
ETUPDT ;update education topics
+1 SET AUMN=$PIECE(L,"^",2)
+2 SET AUMIEN2=$ORDER(^AUTTEDT("C",AUMN,0))
+3 IF 'AUMIEN2
QUIT
+4 SET ^AUTTEDT(AUMIEN2,0)=L
+5 QUIT
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables
+1 QUIT
