AUMUPD3 ;IHS/OIT/NKD - SCB UPDATE 05/23/2012 ;
;;12.0;TABLE MAINTENANCE;**3**;SEP 27,2011;Build 1
;ORIG RTN AUMUPDT
Q ;
;Called at POST by KIDS for AUM updates
POST ;EP -- MAIN EP
N DA,DIC,DIE,DINUM,DLAYGO,DR,@($P($T(SVARS),";",3)),EDTC,MJTC,AUMACT,AUMIEN,AUMRTN
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
.I AUMACT="PCLASALL" S AUMPRV($P(L,"^",1),0)=$P(L,"^",3,8),AUMPRV(0)="AUM PRV DATA^^^"_$P(L,"^",1) ;AUM*12.0*1 - IHS/OIT/NKD
.E S L=$P(L,"^",3,8) D @AUMACT
.Q
I $D(AUMPRV(0)) D PCLASALL^AUMUPD4 ;AUM*12.0*1 - IHS/OIT/NKD - ROUTE TO PROVIDER TABLE UPDATE
;IHS/OIT/NKD AUM*12.0*3 ADDED PICKLIST REPORT
I $D(EDTC) D PKLST^AUMUPD4
D STUP
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, SU, 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(%) ;ERR MESSAGE
Q $S(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")
MODOK ;IF MOD OK
D RSLT($J("",5)_"Changed : "_L)
Q
RSLT(%) ;MESSAGES DURING INSTALL
N @($P($T(SVARS),";",3))
D MES^XPDUTL(%)
Q
IXDIC(DIC,DIC0,D,X,DLAYGO) ;
;CALL TO FM 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 ADDCNTY
Q
ADDCNTY ;NEW COUNTY
;STATE^COUNTY CODE^NAME^FIPS CODE
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 Q
.S DA=$O(^AUTTCTY("C",S_C,0))
.I N'=$P(^AUTTCTY(DA,0),U) D RSLT("County Name Change: "_N_" "_$P(^AUTTCTY(DA,0),U)) S DIE="^AUTTCTY(",DR=".01///"_N D ^DIE
.; ADDED LINE BACK IN RNB
.I $D(^AUTTCTY("C",S_C)) D RSLT($J("",5)_$$M(1)_"COUNTY 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 RSLT("NEW COUNTY (SECTION V-B)")
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
CNTYFR ;EP
S LFR=L
Q
CNTYMOD ;EP
D RSLT("COUNTY CODE CHANGES (SECTION V-C)")
S S=$P(LFR,U),C=$P(LFR,U,2),N=$P(LFR,U,3),A=$P(LFR,U,4),L1=S_" "_C_" "_N_$J("",30-$L(N))_A
S P=$O(^AUTTCTY("C",S_C,0))
S LTO=L
S S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3),A=$P(L,U,4),L2=S_" "_C_" "_N_$J("",30-$L(N))_A
I 'P S P=$O(^AUTTCTY("C",S_C,0)) I 'P D ADDCNTY Q
S P("S")=$$IEN("^DIC(5,",S)
Q:'P("S")
S DIE="^AUTTCTY("
S DA=P
S DR=".01///"_N_";.02////"_P("S")_";.03///"_C
D DIE
I $D(Y) D RSLT($J("",5)_" : EDIT COUNTY CODE FAILED => "_L1)
E D RSLT($J("",5)_" : EDIT COUNTY "_L1_" TO "_L2)
Q
CNTYDEL ; County Delete
; Temporary action to physically remove a county entry
D CNTYDEL^AUMUPD2
Q
SUNEW ;--- ADD NEW SU
;AREA CODE^SU CODE^SU NAME
D RSLT("NEW/REACTIVATED SERVICE UNIT CODE (SECTION VIII-B")
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
S EINSU=$O(^AUTTSU("C",A_S,"")) I EINSU'="" I $D(^AUTTSU("C",A_S))&($G(^AUTTSU(EINSU,-9))="") D RSLT($J("",5)_$$M(1)_"ASU EXISTS => "_A_S) Q
I EINSU'="" I $G(^AUTTSU(EINSU,-9))'="" K ^AUTTSU(EINSU,-9)
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 CHANGES (SECTION VIII-B)")
S A=$P(LFR,U),S=$P(LFR,U,2),N=$P(LFR,U,3),L1=A_" "_S_" "_N
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
I $D(^AUTTSU(P,-9)) D RSLT($J("",5)_" : EDIT SERVICE UNIT FAILED ENTY INACTIVE=> "_A_" "_S_" "_N) 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)_"SERVICE UNIT EDIT FAILED => "_L)
E D RSLT($J("",5)_"SERVICE UNIT CHANGED => "_L1_" to "_L)
Q
SUINA ;--- INACTIVATE SU
;D RSLT("Inactivated Service Unit Codes (SECTION VIII-B)")
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("Service Unit Inactivated => "_L)
Q
;
LOCNEW ;--- ADD NEW LOC
D RSLT("NEW FACILITY CODES (SECTION VIII-C)")
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)
I 'P("S") D RSLT($J("",5)_"FAILED : "_L) Q
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 RSLT("Location ") 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 ;LOC FR
S LFR=L
Q
LOCMOD ;--- MOD LOC
;D RSLT("FACILITY CODE CHANGES (SECTION VIII-C)")
S A=$P(LFR,U),S=$P(LFR,U,2),F=$P(LFR,U,3),N=$P(LFR,U,4),L1=A_" "_S_" "_F_" "_N
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),L2=A_" "_S_" "_F_" "_N
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)
I 'P("S") D RSLT($J("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L) Q
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 RSLT(""),RSLT("Location Changed: "_L1_" TO "_L2)
D RSLT($$LOCMOD^AUMXPORT(LFR,LTO)_" patients marked for export because of the Location Code changes.")
Q
LOCACT ;---ACTIVATE LOC
D RSLT("Activate Location Code")
S LORG=L
S STAT="@" D LOCST I '% S STAT="",L=LORG D ADDLOC Q
I $D(Y) D RSLT($J("",5)_"EDIT ACTIVE DATE FAILED => "_L) I 1
E D RSLT($J("",5)_"ACTIVATED => "_L)
Q
LOCINA ;--- INACTIVATE LOC
D RSLT("Inactivate Location Code")
S STAT=DT D LOCST I '% Q
I $D(Y) D RSLT($J("",5)_"EDIT INACTIVE DATE FAILED => "_L) I 1
E D RSLT($J("",5)_"INACTIVATED => "_L)
Q
LOCST ;CHANGE THE STATUS OF THE LOCATION ENTRY
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////"_STAT
D DIE
K STAT Q
COMNEW ;--- ADD COMMUNITY
;D RSLT("NEW COMMUNITY CODES (SECTION V-C)")
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 Q
.S DA=$O(^AUTTCOM("C",S_O_C,0))
.I N'=$P(^AUTTCOM(DA,0),U) D RSLT("Community Name Change: "_N_" "_$P(^AUTTCOM(DA,0),U)) S DIE="^AUTTCOM(",DR=".01///"_N D ^DIE
.S P("V")=$$IEN("^AUTTSU(",A_V) Q:'P("V") I P("V")'=$P(^AUTTCOM(DA,0),U,5) D RSLT("Community: "_N_$J("",5)_"SU Change: "_V) S DIE="^AUTTCOM(",DR=".05///"_P("V") D ^DIE
.S P("A")=$$IEN("^AUTTAREA(",A) Q:'P("A") I P("A")'=$P(^AUTTCOM(DA,0),U,6) D RSLT("Community: "_N_$J("",5)_" AREA Change: "_A) S DIE="^AUTTCOM(",DR=".06///"_P("A") D ^DIE
.;D RSLT($J("",5)_$$M(1)_"STCTYCOM CODE EXISTS => "_S_O_C_" "_N_" "_$P(^AUTTCOM(DA,0),U))
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 RSLT("NEW COMMUNITY")
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,RSLT($$COMMMOD^AUMXPORT(LFR,LTO)_" patients marked for export because of the Community Code changes.")
Q
COMINAC ;INACTIVATE COMMUNITY
D COMINAC^AUMUPD2
Q
COMACT ; ACTIVATE COMMUNITY
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)) S L=^AUMDATA(AUMIEN,0),L=$P(L,"^",3,8) D COMNEW Q
S DA=$O(^AUTTCOM("C",S_O_C,0))
S DIE="^AUTTCOM(",DR=".18////@"
D DIE
I $D(Y) D RSLT($J("",5)_"EDIT ACTIVATION FAILED => "_L)
E D RSLT($J("",5)_"ACTIVATED => "_L)
Q
CLINNEW ;--- ADD NEW CLINIC
D RSLT("NEW CLINIC CODES (SECTION XIX)")
D ADDCLIN
KILL DLAYGO
Q
ADDCLIN ;
;CLINIC CODE^CLINIC NAME^ABBREVIATION^PRIMARY CARE^WORKLOAD FLG
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")
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
D TRIBEFR^AUMUPD2
Q
TRIBEMOD ;--- MOD TRIBE
D TRIBEMOD^AUMUPD2
Q
TRIBENEW ;--- NEW TRIBE
D TRIBENEW^AUMUPD2
Q
PCLASNEW ;NEW PROVIDER CLASS (SERVICES)
D PCLASNEW^AUMUPD2
Q
PCLASFR ;provider class (services)
D PCLASFR^AUMUPD2
Q
PCLASMOD ;provider class change
D PCLASMOD^AUMUPD2
Q
EXAMNEW ;new exam
D EXAMNEW^AUMUPD2
Q
;IHS/OIT/NKD AUM*12.0*3 Added measurement type update
MEASMOD ;update measurement type
D MEASMOD^AUMUPD2
Q
EDTMOD ;update education topics
D EDTMOD^AUMUPD4
Q
MJTMOD ;update major education topics
D MJTMOD^AUMUPD4
Q
INSMOD ;new insurer type
D INSMOD^AUMUPD2
Q
RESNEW ;RESERVATION CODE
;CODE^NAME^AREA^STATE
D RESNEW^AUMUPD2
Q
RESFR ;RESERVATION CHANGES
D RESFR^AUMUPD2
Q
RESMOD ;RESERVATION CHANGE TO
D RESMOD^AUMUPD2
Q
ADDINST ; Add institution
D ADDINST^AUMUPD2
Q
ADDSTNM ; Add station no
D ADDSTNM^AUMUPD2
Q
DELSTNM ; Delete station no
D DELSTNM^AUMUPD2
Q
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables
Q
STUP ;UPDATE THE STATE CHANGES
Q
S (DIE,DIC)="^DIC(5,"
F L="NEWFOUNDLAND;NL;83","QUEBEC;QC;92","CANADA;CA;96","UNKNOWN;;99","PUERTO RICO;PR;72" D
.S DA=$S($D(^DIC(5,"B",$P(L,";"))):$O(^DIC(5,"B",$P(L,";"),0)),$D(^DIC(5,"C",$P(L,";",3))):$O(^DIC(5,"C",$P(L,";",3),0)),1:"")
.I DA="" D Q
..S X=$P(L,";")
..S DIC("DR")="2///"_$P(L,";",3)_";1///"_$P(L,";",2)
..D FILE
..I $D(Y) D RSLT($J("",5)_$$M(0)_"STATE ADD FAILED => "_$P(L,";")) Q
..D RSLT("STATE ADDED: "_$P(L,";"))
.S DR="1///"_$P(L,";",2)
.D ^DIE
.I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT STATE FAILED => "_$P(L,";")) Q
.D RSLT("Changed STATE ABBR: "_$P(L,";")_" "_$P(L,";",2))
Q
AUMUPD3 ;IHS/OIT/NKD - SCB UPDATE 05/23/2012 ;
+1 ;;12.0;TABLE MAINTENANCE;**3**;SEP 27,2011;Build 1
+2 ;ORIG RTN AUMUPDT
+3 ;
QUIT
+4 ;Called at POST by KIDS for AUM updates
POST ;EP -- MAIN EP
+1 NEW DA,DIC,DIE,DINUM,DLAYGO,DR,@($PIECE($TEXT(SVARS),";",3)),EDTC,MJTC,AUMACT,AUMIEN,AUMRTN
+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 ;AUM*12.0*1 - IHS/OIT/NKD
IF AUMACT="PCLASALL"
SET AUMPRV($PIECE(L,"^",1),0)=$PIECE(L,"^",3,8)
SET AUMPRV(0)="AUM PRV DATA^^^"_$PIECE(L,"^",1)
+9 IF '$TEST
SET L=$PIECE(L,"^",3,8)
DO @AUMACT
+10 QUIT
End DoDot:1
+11 ;AUM*12.0*1 - IHS/OIT/NKD - ROUTE TO PROVIDER TABLE UPDATE
IF $DATA(AUMPRV(0))
DO PCLASALL^AUMUPD4
+12 ;IHS/OIT/NKD AUM*12.0*3 ADDED PICKLIST REPORT
+13 IF $DATA(EDTC)
DO PKLST^AUMUPD4
+14 DO STUP
+15 QUIT
ADDOK ;ADDED MESSAGE
+1 DO RSLT($JUSTIFY("",5)_"Added : "_L)
+2 QUIT
ADDFAIL ;FAILED MESSAGE
+1 DO RSLT($JUSTIFY("",5)_$$M(0)_"ADD FAILED => "_L)
+2 QUIT
DASH ;PRT DASH LINE
+1 DO RSLT("")
+2 DO RSLT($$REPEAT^XLFSTR("-",$SELECT($GET(IOM):IOM-10,1:70)))
+3 DO RSLT("")
+4 QUIT
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
IEN(X,%,Y) ;
+1 ;UPDATE AREA, SU, 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
DIK ;KILL ENTRY
+1 NEW @($PIECE($TEXT(SVARS),";",3)),DIK
+2 DO ^DIK
+3 QUIT
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
M(%) ;ERR MESSAGE
+1 QUIT $SELECT(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")
MODOK ;IF MOD OK
+1 DO RSLT($JUSTIFY("",5)_"Changed : "_L)
+2 QUIT
RSLT(%) ;MESSAGES DURING INSTALL
+1 NEW @($PIECE($TEXT(SVARS),";",3))
+2 DO MES^XPDUTL(%)
+3 QUIT
IXDIC(DIC,DIC0,D,X,DLAYGO) ;
+1 ;CALL TO FM 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
AREANEW ;
+1 SET E="New Area Codes"
+2 DO ADDAREA
+3 QUIT
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
CNTYNEW ;NEW COUNTY
+1 DO ADDCNTY
+2 QUIT
ADDCNTY ;NEW COUNTY
+1 ;STATE^COUNTY CODE^NAME^FIPS CODE
+2 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
+3 IF $DATA(^AUTTCTY("C",S_C))
Begin DoDot:1
+4 SET DA=$ORDER(^AUTTCTY("C",S_C,0))
+5 IF N'=$PIECE(^AUTTCTY(DA,0),U)
DO RSLT("County Name Change: "_N_" "_$PIECE(^AUTTCTY(DA,0),U))
SET DIE="^AUTTCTY("
SET DR=".01///"_N
DO ^DIE
+6 ; ADDED LINE BACK IN RNB
+7 IF $DATA(^AUTTCTY("C",S_C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"COUNTY CODE EXISTS => "_S_C)
QUIT
End DoDot:1
QUIT
+8 SET P("S")=$$IEN("^DIC(5,",S)
+9 IF 'P("S")
QUIT
+10 SET DIC="^AUTTCTY("
+11 SET X=N
+12 SET DIC("DR")=".02////"_P("S")_";.03///"_C_";.06///"_A
+13 DO FILE
+14 DO RSLT("NEW COUNTY (SECTION V-B)")
+15 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+16 QUIT
CNTYFR ;EP
+1 SET LFR=L
+2 QUIT
CNTYMOD ;EP
+1 DO RSLT("COUNTY CODE CHANGES (SECTION V-C)")
+2 SET S=$PIECE(LFR,U)
SET C=$PIECE(LFR,U,2)
SET N=$PIECE(LFR,U,3)
SET A=$PIECE(LFR,U,4)
SET L1=S_" "_C_" "_N_$JUSTIFY("",30-$LENGTH(N))_A
+3 SET P=$ORDER(^AUTTCTY("C",S_C,0))
+4 SET LTO=L
+5 SET S=$PIECE(L,U)
SET C=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET A=$PIECE(L,U,4)
SET L2=S_" "_C_" "_N_$JUSTIFY("",30-$LENGTH(N))_A
+6 IF 'P
SET P=$ORDER(^AUTTCTY("C",S_C,0))
IF 'P
DO ADDCNTY
QUIT
+7 SET P("S")=$$IEN("^DIC(5,",S)
+8 IF 'P("S")
QUIT
+9 SET DIE="^AUTTCTY("
+10 SET DA=P
+11 SET DR=".01///"_N_";.02////"_P("S")_";.03///"_C
+12 DO DIE
+13 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_" : EDIT COUNTY CODE FAILED => "_L1)
+14 IF '$TEST
DO RSLT($JUSTIFY("",5)_" : EDIT COUNTY "_L1_" TO "_L2)
+15 QUIT
CNTYDEL ; County Delete
+1 ; Temporary action to physically remove a county entry
+2 DO CNTYDEL^AUMUPD2
+3 QUIT
SUNEW ;--- ADD NEW SU
+1 ;AREA CODE^SU CODE^SU NAME
+2 DO RSLT("NEW/REACTIVATED SERVICE UNIT CODE (SECTION VIII-B")
+3 DO ADDSU
+4 QUIT
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 SET EINSU=$ORDER(^AUTTSU("C",A_S,""))
IF EINSU'=""
IF $DATA(^AUTTSU("C",A_S))&($GET(^AUTTSU(EINSU,-9))="")
DO RSLT($JUSTIFY("",5)_$$M(1)_"ASU EXISTS => "_A_S)
QUIT
+3 IF EINSU'=""
IF $GET(^AUTTSU(EINSU,-9))'=""
KILL ^AUTTSU(EINSU,-9)
+4 SET P=$$IEN("^AUTTAREA(",A)
+5 IF 'P
QUIT
+6 SET DLAYGO=9999999.22
+7 SET DIC="^AUTTSU("
+8 SET X=N
+9 SET DIC("DR")=".02////"_P_";.03///"_S
+10 DO FILE
+11 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+12 QUIT
SUFR ;--- SU FROM
+1 SET LFR=L
+2 QUIT
SUMOD ;--- MOD SU
+1 DO RSLT("SERVICE UNIT CHANGES (SECTION VIII-B)")
+2 SET A=$PIECE(LFR,U)
SET S=$PIECE(LFR,U,2)
SET N=$PIECE(LFR,U,3)
SET L1=A_" "_S_" "_N
+3 SET P=$ORDER(^AUTTSU("C",A_S,0))
+4 SET LTO=L
+5 SET A=$PIECE(LTO,U)
SET S=$PIECE(LTO,U,2)
SET N=$PIECE(LTO,U,3)
+6 IF 'P
SET P=$ORDER(^AUTTSU("C",A_S,0))
IF 'P
DO ADDSU
QUIT
+7 IF $DATA(^AUTTSU(P,-9))
DO RSLT($JUSTIFY("",5)_" : EDIT SERVICE UNIT FAILED ENTY INACTIVE=> "_A_" "_S_" "_N)
QUIT
+8 SET L=A_" "_S_" "_N
+9 SET P("A")=$$IEN("^AUTTAREA(",A)
+10 IF 'P("A")
QUIT
+11 SET DIE="^AUTTSU("
+12 SET DA=P
+13 SET DR=".01///"_N_";.02////"_P("A")_";.03///"_S
+14 DO DIE
+15 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_"SERVICE UNIT EDIT FAILED => "_L)
+16 IF '$TEST
DO RSLT($JUSTIFY("",5)_"SERVICE UNIT CHANGED => "_L1_" to "_L)
+17 QUIT
SUINA ;--- INACTIVATE SU
+1 ;D RSLT("Inactivated Service Unit Codes (SECTION VIII-B)")
+2 SET A=$PIECE(L,"^",1)
SET S=$PIECE(L,"^",2)
SET N=$PIECE(L,"^",3)
+3 SET P=$ORDER(^AUTTSU("C",A_S,0))
+4 IF 'P
Begin DoDot:1
+5 DO RSLT("SERVICE UNIT CODE NOT FOUND")
End DoDot:1
QUIT
+6 SET ^AUTTSU(P,-9)="INACTIVE"
+7 SET L=$TRANSLATE(L,"^"," ")
+8 DO RSLT("Service Unit Inactivated => "_L)
+9 QUIT
+10 ;
LOCNEW ;--- ADD NEW LOC
+1 DO RSLT("NEW FACILITY CODES (SECTION VIII-C)")
+2 DO ADDLOC
+3 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 %
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")
DO RSLT($JUSTIFY("",5)_"FAILED : "_L)
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 RSLT("Location ")
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
LOCFR ;LOC FR
+1 SET LFR=L
+2 QUIT
LOCMOD ;--- MOD LOC
+1 ;D RSLT("FACILITY CODE CHANGES (SECTION VIII-C)")
+2 SET A=$PIECE(LFR,U)
SET S=$PIECE(LFR,U,2)
SET F=$PIECE(LFR,U,3)
SET N=$PIECE(LFR,U,4)
SET L1=A_" "_S_" "_F_" "_N
+3 SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
+4 SET LTO=L
+5 SET A=$PIECE(LTO,U)
SET S=$PIECE(LTO,U,2)
SET F=$PIECE(LTO,U,3)
SET N=$PIECE(LTO,U,4)
SET L2=A_" "_S_" "_F_" "_N
+6 IF 'P
SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
IF 'P
DO ADDLOC
QUIT
+7 SET L=A_" "_S_" "_F_" "_N_$JUSTIFY("",32-$LENGTH(N))_$PIECE(LTO,U,5)
+8 SET P("A")=$$IEN("^AUTTAREA(",A)
+9 IF 'P("A")
QUIT
+10 SET P("S")=$$IEN("^AUTTSU(",A_S)
+11 IF 'P("S")
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L)
QUIT
+12 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)
+13 SET ZZDIE=DIE
SET ZZDA=DA
SET ZZDR=DR
+14 DO DIE
+15 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L)
QUIT
+16 SET DIE="^DIC(4,"
SET DA=$PIECE(^AUTTLOC(P,0),U)
SET DR=".01///"_N
+17 DO DIE
+18 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L)
QUIT
+19 DO RSLT("")
DO RSLT("Location Changed: "_L1_" TO "_L2)
+20 DO RSLT($$LOCMOD^AUMXPORT(LFR,LTO)_" patients marked for export because of the Location Code changes.")
+21 QUIT
LOCACT ;---ACTIVATE LOC
+1 DO RSLT("Activate Location Code")
+2 SET LORG=L
+3 SET STAT="@"
DO LOCST
IF '%
SET STAT=""
SET L=LORG
DO ADDLOC
QUIT
+4 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_"EDIT ACTIVE DATE FAILED => "_L)
IF 1
+5 IF '$TEST
DO RSLT($JUSTIFY("",5)_"ACTIVATED => "_L)
+6 QUIT
LOCINA ;--- INACTIVATE LOC
+1 DO RSLT("Inactivate Location Code")
+2 SET STAT=DT
DO LOCST
IF '%
QUIT
+3 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_"EDIT INACTIVE DATE FAILED => "_L)
IF 1
+4 IF '$TEST
DO RSLT($JUSTIFY("",5)_"INACTIVATED => "_L)
+5 QUIT
LOCST ;CHANGE THE STATUS OF THE LOCATION ENTRY
+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)
+2 SET L=A_" "_S_" "_F_" "_N_" "_P
+3 SET %=A_S_F
SET %=$ORDER(^AUTTLOC("C",%,0))
+4 IF '%
DO RSLT($JUSTIFY("",5)_"ASUFAC "_A_S_F_" not found (OK).")
QUIT
+5 SET DIE="^AUTTLOC("
SET DA=%
SET DR=".27////"_STAT
+6 DO DIE
+7 KILL STAT
QUIT
COMNEW ;--- ADD COMMUNITY
+1 ;D RSLT("NEW COMMUNITY CODES (SECTION V-C)")
+2 DO ADDCOMM
+3 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))
Begin DoDot:1
+3 SET DA=$ORDER(^AUTTCOM("C",S_O_C,0))
+4 IF N'=$PIECE(^AUTTCOM(DA,0),U)
DO RSLT("Community Name Change: "_N_" "_$PIECE(^AUTTCOM(DA,0),U))
SET DIE="^AUTTCOM("
SET DR=".01///"_N
DO ^DIE
+5 SET P("V")=$$IEN("^AUTTSU(",A_V)
IF 'P("V")
QUIT
IF P("V")'=$PIECE(^AUTTCOM(DA,0),U,5)
DO RSLT("Community: "_N_$JUSTIFY("",5)_"SU Change: "_V)
SET DIE="^AUTTCOM("
SET DR=".05///"_P("V")
DO ^DIE
+6 SET P("A")=$$IEN("^AUTTAREA(",A)
IF 'P("A")
QUIT
IF P("A")'=$PIECE(^AUTTCOM(DA,0),U,6)
DO RSLT("Community: "_N_$JUSTIFY("",5)_" AREA Change: "_A)
SET DIE="^AUTTCOM("
SET DR=".06///"_P("A")
DO ^DIE
+7 ;D RSLT($J("",5)_$$M(1)_"STCTYCOM CODE EXISTS => "_S_O_C_" "_N_" "_$P(^AUTTCOM(DA,0),U))
End DoDot:1
QUIT
+8 SET P("O")=$$IEN("^AUTTCTY(",S_O)
+9 IF 'P("O")
QUIT
+10 SET P("A")=$$IEN("^AUTTAREA(",A)
+11 IF 'P("A")
QUIT
+12 SET P("V")=$$IEN("^AUTTSU(",A_V)
+13 IF 'P("V")
QUIT
+14 SET DLAYGO=9999999.05
SET DIC="^AUTTCOM("
SET X=N
SET DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
+15 DO FILE
+16 DO RSLT("NEW COMMUNITY")
+17 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+18 QUIT
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
DO RSLT($$COMMMOD^AUMXPORT(LFR,LTO)_" patients marked for export because of the Community Code changes.")
+23 QUIT
COMINAC ;INACTIVATE COMMUNITY
+1 DO COMINAC^AUMUPD2
+2 QUIT
COMACT ; ACTIVATE COMMUNITY
+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))
SET L=^AUMDATA(AUMIEN,0)
SET L=$PIECE(L,"^",3,8)
DO COMNEW
QUIT
+3 SET DA=$ORDER(^AUTTCOM("C",S_O_C,0))
+4 SET DIE="^AUTTCOM("
SET DR=".18////@"
+5 DO DIE
+6 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_"EDIT ACTIVATION FAILED => "_L)
+7 IF '$TEST
DO RSLT($JUSTIFY("",5)_"ACTIVATED => "_L)
+8 QUIT
CLINNEW ;--- ADD NEW CLINIC
+1 DO RSLT("NEW CLINIC CODES (SECTION XIX)")
+2 DO ADDCLIN
+3 KILL DLAYGO
+4 QUIT
ADDCLIN ;
+1 ;CLINIC CODE^CLINIC NAME^ABBREVIATION^PRIMARY CARE^WORKLOAD FLG
+2 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
+3 IF $DATA(^DIC(40.7,"C",C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"CLINIC CODE EXISTS => "_C)
DO RSLT("")
QUIT
+4 SET DLAYGO=40.7
SET DIC="^DIC(40.7,"
SET X=N
SET DIC("DR")="1///"_C_";999999901///"_A_";90000.01///"_R
+5 IF $LENGTH(P)
SET DIC("DR")=DIC("DR")_";999999902///"_P
+6 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+7 QUIT
CLINFR ;clinic from
+1 SET LFR=L
+2 QUIT
CLINMOD ;--- MOD CLINIC
+1 DO RSLT("MODIFY CLINIC")
+2 SET LTO=L
+3 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)
+4 SET DA=$ORDER(^DIC(40.7,"C",C,0))
+5 IF 'DA
DO ADDCLIN
QUIT
+6 SET DIE="^DIC(40.7,"
+7 SET DR=".01///"_N_";999999901///"_A_";999999902///"_P_";90000.01///"_R
+8 DO ^DIE
+9 SET L=C_" "_N_$JUSTIFY("",(32-$LENGTH(N)))_$$LJ^XLFSTR(A,8)_$$LJ^XLFSTR(P,11)_R
+10 DO MODOK
+11 QUIT
TRIBEFR ;tribe from
+1 DO TRIBEFR^AUMUPD2
+2 QUIT
TRIBEMOD ;--- MOD TRIBE
+1 DO TRIBEMOD^AUMUPD2
+2 QUIT
TRIBENEW ;--- NEW TRIBE
+1 DO TRIBENEW^AUMUPD2
+2 QUIT
PCLASNEW ;NEW PROVIDER CLASS (SERVICES)
+1 DO PCLASNEW^AUMUPD2
+2 QUIT
PCLASFR ;provider class (services)
+1 DO PCLASFR^AUMUPD2
+2 QUIT
PCLASMOD ;provider class change
+1 DO PCLASMOD^AUMUPD2
+2 QUIT
EXAMNEW ;new exam
+1 DO EXAMNEW^AUMUPD2
+2 QUIT
+3 ;IHS/OIT/NKD AUM*12.0*3 Added measurement type update
MEASMOD ;update measurement type
+1 DO MEASMOD^AUMUPD2
+2 QUIT
EDTMOD ;update education topics
+1 DO EDTMOD^AUMUPD4
+2 QUIT
MJTMOD ;update major education topics
+1 DO MJTMOD^AUMUPD4
+2 QUIT
INSMOD ;new insurer type
+1 DO INSMOD^AUMUPD2
+2 QUIT
RESNEW ;RESERVATION CODE
+1 ;CODE^NAME^AREA^STATE
+2 DO RESNEW^AUMUPD2
+3 QUIT
RESFR ;RESERVATION CHANGES
+1 DO RESFR^AUMUPD2
+2 QUIT
RESMOD ;RESERVATION CHANGE TO
+1 DO RESMOD^AUMUPD2
+2 QUIT
ADDINST ; Add institution
+1 DO ADDINST^AUMUPD2
+2 QUIT
ADDSTNM ; Add station no
+1 DO ADDSTNM^AUMUPD2
+2 QUIT
DELSTNM ; Delete station no
+1 DO DELSTNM^AUMUPD2
+2 QUIT
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables
+1 QUIT
STUP ;UPDATE THE STATE CHANGES
+1 QUIT
+2 SET (DIE,DIC)="^DIC(5,"
+3 FOR L="NEWFOUNDLAND;NL;83","QUEBEC;QC;92","CANADA;CA;96","UNKNOWN;;99","PUERTO RICO;PR;72"
Begin DoDot:1
+4 SET DA=$SELECT($DATA(^DIC(5,"B",$PIECE(L,";"))):$ORDER(^DIC(5,"B",$PIECE(L,";"),0)),$DATA(^DIC(5,"C",$PIECE(L,";",3))):$ORDER(^DIC(5,"C",$PIECE(L,";",3),0)),1:"")
+5 IF DA=""
Begin DoDot:2
+6 SET X=$PIECE(L,";")
+7 SET DIC("DR")="2///"_$PIECE(L,";",3)_";1///"_$PIECE(L,";",2)
+8 DO FILE
+9 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"STATE ADD FAILED => "_$PIECE(L,";"))
QUIT
+10 DO RSLT("STATE ADDED: "_$PIECE(L,";"))
End DoDot:2
QUIT
+11 SET DR="1///"_$PIECE(L,";",2)
+12 DO ^DIE
+13 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT STATE FAILED => "_$PIECE(L,";"))
QUIT
+14 DO RSLT("Changed STATE ABBR: "_$PIECE(L,";")_" "_$PIECE(L,";",2))
End DoDot:1
+15 QUIT
