- 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
