- AUMUPD2 ;IHS/OIT/NKD - SCB UPDATE 05/23/2012 ;
- ;;12.0;TABLE MAINTENANCE;**3**;SEP 27,2011;Build 1
- ;AUM*9.1*4 8/18/2009 OIT.IHS.FCJ ADDED RESNEW, RESFR AND RESMOD MODULES
- ;and Line description for Provider class
- ;
- 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
- ;
- 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
- ;
- EXAMNEW ;EP --- NEW EXAM
- D RSLT("NEW EXAM")
- D RSLT($J("",13)_"NAME")
- D RSLT($J("",13)_"----")
- D ADDEXAM
- Q
- ADDEXAM ;
- S N=$P(L,U),C=$P(L,U,2),L=N
- I $D(^AUTTEXAM("C",C)) D RSLT($J("",5)_$$M(1)_"EXAM CODE EXISTS => "_C_" "_N) Q
- S DLAYGO=9999999.15,DIC="^AUTTEXAM(",X=N
- S DIC("DR")=".02///"_C
- D FILE
- D @$S(Y>0:"ADDOK",1:"ADDFAIL")
- K DLAYGO
- Q
- ;
- EXAMFR ;EP - exam from
- S LFR=L
- Q
- EXAMMOD ;EP - modify exam file
- S E="Exam Name Changes"
- S N=$P(LFR,"^",1),C=$P(LFR,"^",2)
- S DA=$O(^AUTTEXAM("C",C,0))
- S LTO=L
- S N=$P(LTO,"^"),C=$P(LTO,"^",2)
- S:'DA DA=$O(^AUTTEXAM("C",C,0))
- I 'DA D ADDEXAM Q
- S L=C_" "_N
- S DIE="^AUTTEXAM(",DR=".01///"_N D DIE
- I $D(Y) D RSLT(E_" : CHANGE FAILED => "_L) Q
- D MODOK
- Q
- EXAMINA ;EP - inactivate exam
- D RSLT("Inactivated Exam Codes")
- S N=$P(L,U)
- S C=$P(L,"^",2)
- S DA=$O(^AUTTEXAM("C",C,0)) Q:'DA
- S DIE="^AUTTEXAM("
- S DR=".04///1"
- D ^DIE
- I $D(Y) D RSLT("CHANGE FAILED => "_L) Q
- D RSLT("Code Inactivated: "_N_" "_C)
- Q
- EDUCNEW ;EP --- NEW PATIENT ED- P&F
- D RSLT("EDUCATION - PATIENT AND FAMILY")
- D RSLT($J("",13)_"NAME")
- D RSLT($J("",13)_"----")
- D ADDEDUC
- Q
- ADDEDUC ;--- ADD THE NEW PATIENT EDUCATION
- S N=$P(L,U),M=$P(L,U,2),C=$P(L,U,3),L=N
- I $D(^AUTTEDPF("B",N)) D RSLT($J("",5)_$$M(1)_"PT ED NAME EXISTS => "_N) Q
- S DLAYGO=9999999.98,DIC="^AUTTEDPF(",X=N
- S DIC("DR")=".02///"_M_";.03///"_C
- D FILE
- D @$S(Y>0:"ADDOK",1:"ADDFAIL")
- Q
- ;
- HFNEW ;EP --- NEW HEALTH FACTORS
- D RSLT("NEW HEALTH FACTORS")
- ;D RSLT($J("",13)_"NAME")
- ;D RSLT($J("",13)_"----")
- D ADDHF
- Q
- ADDHF ;
- S N=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),S=$P(L,U,4),D=$P(L,U,5)
- S L=N_" "_O_" "_C_" "_S_" "_D
- I $D(^AUTTHF("B",N)) D RSLT($J("",5)_$$M(1)_"HEALTH FACTOR EXISTS => "_N),RSLT("") Q
- S DLAYGO=9999999.64,DIC="^AUTTHF(",X=N
- S DIC("DR")=".02///"_D_";.03///"_O_";.1///"_C_";.14///"_S
- D FILE
- D @$S(Y>0:"ADDOK",1:"ADDFAIL")
- Q
- ;
- HFFR ;EP --- HEALTH FACTOR FROM
- S LFR=L
- Q
- HFMOD ;EP --- MODIFY HEALTH FACTOR
- S E="Health Factor Changes"
- S LTO=L
- S N=$P(LFR,"^",1)
- S DA=$O(^AUTTHF("B",N,0))
- S N=$P(LTO,"^",1),O=$P(LTO,"^",2),C=$P(LTO,"^",3),S=$P(LTO,"^",4),D=$P(LTO,"^",5),M=$P(LTO,"^",6)
- I 'DA S DA=$O(^AUTTHF("B",N,0))
- I 'DA D ADDHF Q
- S $P(^AUTTHF(DA,0),"^",13)=""
- S $P(^AUTTHF(DA,0),"^",15)=""
- S DIE="^AUTTHF("
- S DR=".01///"_N_";.03///"_O_";.1///"_C_";.14///"_S_";.02///"_D_";8801///"_M
- D DIE
- I $D(Y) D RSLT(E_" : CHANGE FAILED => "_L) Q
- D MODOK
- Q
- HFINA ;EP --- INACTIVATE HEALTH FACTOR
- D RSLT("Inactivated Health Factors")
- S N=$P(L,U)
- S D=$P(L,U,2)
- S L=N_" "_D
- S DA=$O(^AUTTHF("B",N,0)) Q:'DA
- S DIE="^AUTTHF("
- S DR=".13///1;.15///"_D
- D ^DIE
- I $D(Y) D RSLT($J("",5)_"EDIT FAILED => "_L)
- E D RSLT($J("",5)_"INACTIVATED => "_L)
- Q
- ;
- PCLASNEW ;EP --- NEW PROV CLASS
- ;CODE^NAME^ABRV^PCP^WL ;AUM9.1*4 IHS/OIT/FCJ NEW LINE
- S E="NEW SERVICES RENDERED BY (PROVIDER CODES)"
- D RSLT(E)
- ;D RSLT($J("",11)_"CODE NAME"_$J("",28)_"ABRV.")
- ;D RSLT($J("",11)_"---- ----"_$J("",28)_"-----")
- D ADDPCLAS
- Q
- ADDPCLAS ;
- 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)
- S L=C_" "_N_$J("",(32-$L(N)))_A
- I $D(^DIC(7,"D",C)) D RSLT($J("",5)_$$M(1)_"PROVIDER CODE EXISTS => "_C),RSLT("") Q
- S DLAYGO=7,DIC="^DIC(7,",X=N,DIC("DR")="1///"_A_";9999999.01///"_C_";9999999.03///"_P_";9999999.05///"_R
- D FILE
- D @$S(Y>0:"ADDOK",1:"ADDFAIL")
- Q
- ;
- PCLASFR ;EP - provider class from
- S LFR=L
- Q
- PCLASMOD ;EP
- D RSLT("SERVICES RENDERED BY (PROVIDER) CODE CHANGES (SECTION XV)")
- S C=$P(LFR,"^",1),N=$P(LFR,"^",2),A=$P(LFR,"^",3)
- S LTO=L
- S C=$P(LTO,"^",1),N=$P(LTO,"^",2),A=$P(LTO,"^",3),I=$P(LTO,"^",4),II=$P(LTO,"^",5)
- S P=$O(^DIC(7,"D",C,0))
- I 'P D ADDPCLAS Q
- S L=C_" "_N_" "_A
- S DIE="^DIC(7,",DA=P,DR=".01///"_N_";1///"_A_";9999999.01///"_C_";9999999.03///"_I_";9999999.05///"_II
- D ^DIE
- I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT PROVIDER CODE FAILED => "_L) Q
- D MODOK
- Q
- ;
- ;IHS/OIT/NKD AUM*12.0*3 Replace previous processing
- ;MEASNEW ;EP --- NEW MEASUREMENT TYPE
- ;S E="New Measurement Type"
- ;D RSLT(E)
- ;D ADDMEAS
- ;Q
- ;ADDMEAS ;
- ;S N=$P(L,"^"),S=$P(L,"^",2),C=$P(L,"^",3),L=N_" "_S_" "_C
- ;I $D(^AUTTMSR("C",C)) D RSLT(E_" : MEASUREMENT TYPE CODE EXISTS => "_C) Q
- ;S DLAYGO=9999999.07,DIC="^AUTTMSR(",X=N,DIC("DR")=".02///"_S_";.03///"_C D FILE
- ;D ADDFAIL:Y<0,ADDOK:Y>0
- ;Q
- MEASMOD ;EP --- UPDATE MEASUREMENT TYPE
- N AUMACT,AUMTYP,AUMDES,AUMCOD,AUMHTXT,AUMINP,AUMRES,FDA,NEWIEN,ERR,AUMCHG,AUMD0,AUMCNT,AUMIEN
- D RSLT("MEASUREMENT TYPE")
- S U="^",AUMIEN=""
- S AUMACT=$P(L,U,4),AUMTYP=$P(L,U,2),AUMDES=$P(L,U,3),AUMCOD=$P(L,U,1),AUMHTXT=$P(L,U,5),AUMINP=$TR($P(L,U,6),"|","^")
- S L=AUMCOD_$J("",6-$L(AUMCOD))_AUMTYP_$J("",8-$L(AUMTYP))_AUMDES
- K AUMRES
- D FIND^DIC(9999999.07,"","@;.01;.03","PX",AUMCOD,,"C",,,"AUMRES")
- S AUMCNT=$P($G(AUMRES("DILIST",0)),"^",1)
- I AUMCNT=0 S AUMIEN="" ; No matches found, create new
- I AUMCNT=1 S AUMIEN=$P($G(AUMRES("DILIST",1,0)),"^",1) ; One match found, store IEN
- I AUMCNT>1 S AUMIEN=$P($G(AUMRES("DILIST",$P($G(AUMRES("DILIST",0)),"^",1),0)),"^",1)
- I 'AUMIEN,$L(AUMACT)>0 D Q
- . D RSLT($J("",5)_"INACTIVATE MEASUREMENT TYPE FAILED : MEASUREMENT TYPE DOES NOT EXIST => "_L)
- I 'AUMIEN D
- . K FDA,NEWIEN,ERR
- . S FDA(9999999.07,"+1,",.01)=AUMTYP ; Type (.01)
- . S FDA(9999999.07,"+1,",.02)=AUMDES ; Description (.02)
- . S FDA(9999999.07,"+1,",.03)=AUMCOD ; Code (.03)
- . D UPDATE^DIE(,"FDA","NEWIEN","ERR")
- . I $D(ERR) D ADDFAIL Q
- . S AUMIEN=NEWIEN(1),AUMCHG=1
- Q:'AUMIEN
- S AUMD0=$G(^AUTTMSR(AUMIEN,0))
- ;
- K FDA
- S FDA(9999999.07,AUMIEN_",",.01)=AUMTYP ; Type (.01)
- S FDA(9999999.07,AUMIEN_",",.02)=AUMDES ; Description (.02)
- S FDA(9999999.07,AUMIEN_",",.03)=AUMCOD ; Code (.03)
- S FDA(9999999.07,AUMIEN_",",.04)=$S($L(AUMACT)>0:1,1:"@") ; Inactive (.04)
- S FDA(9999999.07,AUMIEN_",",1201)=AUMINP ; Value Input Transform (1201)
- D UPDATE^DIE(,"FDA",)
- I AUMD0'=$G(^AUTTMSR(AUMIEN,0)) S AUMCHG=1
- ;
- ; Help Text (1100) WP
- D TEXT^AUMUPD4(.AUMHTXT) ; convert string to WP array
- D WP^DIE(9999999.07,AUMIEN_",",1100,,"AUMHTXT")
- ;
- I AUMCHG D @$S($D(NEWIEN):"ADDOK",$L(AUMACT)>0:"INAOK",1:"MODOK")
- ;
- Q
- RESNEW ; NEW RESERVATION
- ;CODE^NAME^AREA^STATE
- I $G(AUMFLG)=1 S L=LTO
- D RSLT("NEW RESERVATION CODE")
- S N=$P(L,U,2),C=$P(L,U),A=$P(L,U,3),S=$P(L,U,4)
- S L=N_" "_C_" "_A_" "_S
- I $D(^AUTTRES("B",N))!$D(^AUTTRES("C",C)) D RSLT($J("",5)_$$M(1)_"RESERVATION ENTRY EXISTS => "_N_" "_C) Q
- S DLAYGO=9999999.47,DIC="^AUTTRES(",X=N
- S DIC("DR")=".02///"_C_";.03///"_S_";.04///"_A
- D FILE
- D @$S(Y>0:"ADDOK",1:"ADDFAIL")
- K AUMFLG Q
- ;
- RESFR ;EP --- EDIT RESERVATION ENTRY
- S AUMFLG=0
- D RSLT("RESERVATION CODE CHANGES")
- S LFR=L
- Q
- RESMOD ;EP --- CONT EDIT RESERVATION ENTRY
- S LTO=L
- S N=$P(LFR,U,2),C=$P(LFR,U)
- S L=N_" "_C_" "_$P(LFR,U,3)_" "_$P(LFR,U,4)
- S DA=$O(^AUTTRES("B",N,0)) I 'DA S DA=$O(^AUTTRES("C",C,0))
- S N=$P(LTO,U,2),C=$P(LTO,U),A=$P(LTO,U,3),S=$P(LTO,U,4)
- RESMOD2 ;
- I 'DA S DA=$O(^AUTTRES("C",C,0)) I 'DA S DA=$O(^AUTTRES("B",N,0))
- I 'DA S AUMFLG=1 D RESNEW Q
- S DIE="^AUTTRES("
- S DR=".01///"_N_";.02///"_C_";.03///"_S_";.04///"_A
- D DIE
- I $D(Y) D RSLT($J("",5)_"RESERVATION CHANGE FAILED => "_L)
- E D RSLT($J("",5)_"RESERVATION CHANGE => "_N_" "_C_" "_S_" "_A)
- Q
- ;
- COMINAC ;INACTIVATE 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)) D RSLT($J("",5)_"INACTIVATE COMMUNITY FAILED: STCTYCOM CODE DOES NOT EXIST => "_S_O_C) Q
- S DA=$O(^AUTTCOM("C",S_O_C,0))
- S DIE="^AUTTCOM(",DR=".18////"_DT
- D DIE
- I $D(Y) D RSLT($J("",5)_"EDIT INACTIVE DATE FAILED => "_L)
- E D RSLT($J("",5)_"INACTIVATED => "_L)
- Q
- CNTYDEL ; County Delete
- ; Temporary action to physically remove a county entry
- D RSLT("COUNTY CODE DELETE (SECTION V-C)")
- 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
- S P=$O(^AUTTCTY("C",S_C,0))
- I 'P D RSLT($J("",5)_"NOT DELETED : COUNTY CODE DOES NOT EXIST => "_L2) Q
- S DIK="^AUTTCTY("
- S DA=P
- D ^DIK
- I '$D(Y) D RSLT($J("",5)_" : DELETE COUNTY CODE FAILED => "_L2)
- E D RSLT($J("",5)_" : COUNTY CODE DELETED: "_L2)
- Q
- TRIBEFR ;EP --- tribe from
- S LFR=L
- Q
- TRIBEMOD ;EP --- MOD TRIBE
- ; C=CODE, N=NAME, LN=LONG NAME, P=IEN
- D RSLT("MODIFY TRIBE")
- S C=$P(LFR,U),N=$P(LFR,U,2),LN=$P(LFR,U,3),L1=C_" "_N
- S P=$O(^AUTTTRI("C",C,0))
- S LTO=L
- S C=$P(LTO,U),N=$P(LTO,U,2),LN=$P(LTO,U,3)
- I 'P S P=$O(^AUTTTRI("C",C,0))
- I 'P D ADDTRIBE Q
- S L=C_" "_N
- S DIE="^AUTTTRI("
- S DA=P
- S DR=".01///"_N_";.02///"_C_";.03///"_LN
- D DIE
- I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT TRIBE FAILED => "_L) Q
- D RSLT("Changed: "_L1_" TO "_L)
- Q
- TRIBENEW ;EP --- NEW TRIBE
- D RSLT("NEW TRIBE")
- D ADDTRIBE
- Q
- ADDTRIBE ;
- S C=$P(L,U),N=$P(L,U,2)
- S L=" "_$$LJ^XLFSTR(C,5)_$$LJ^XLFSTR(N,4)
- 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
- D FILE
- D @$S(Y>0:"ADDOK",1:"ADDFAIL")
- Q
- ADDINST ;EP --- Add institute
- ;
- D RSLT("ADD INSTITUTION AND STATION NUMBER")
- S INSNAM=$P(L,"^",1),STNUM=$P(L,"^",3)
- F %=+$P(^DIC(4,0),U,3):1 Q:'$D(^DIC(4,%))
- I %>99999 D RSLT($J("",5)_$$M(0)_"DINUM FOR INSTITUTION TOO BIG. NOTIFY ISC.") Q
- ;I %,$D(^DIC(4,%,0))
- S DLAYGO=4,DIC="^DIC(4,",DINUM=%,X=INSNAM
- ;S DIE="^DIC(4,",DA=%,DR=".01///"_INSNAM_";
- ;S DR="99///"_STNUM
- D FILE I Y<0 D RSLT($J("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L) Q
- I $D(Y) D RSLT($J("",5)_"INSTITUTION NAME UPDATED => "_INSNAM)
- K DINUM,DLAYGO
- S DIE="^DIC(4,",DA=%,DR="99////"_STNUM D DIE
- Q
- ADDSTNM ;EP --- Add station number
- ;
- D RSLT("ADD STATION NUMBER TO INSTITUTION")
- S INSNAM=$P(L,"^",1),ASUFAC=$P(L,"^",2),STNUM=$P(L,"^",3)
- ;AUM*12.0*2 - IHS/OIT/NKD - ADDED LOGIC TO ENSURE A LOCATION IS FOUND
- ;S XLOCEIN=$O(^AUTTLOC("C",ASUFAC,"")),XLOCDAT=$G(^AUTTLOC(XLOCEIN,0))
- S XLOCEIN=$O(^AUTTLOC("C",ASUFAC,""))
- I $L(XLOCEIN)<1 D RSLT($J("",5)_"STATION NUMBER ADD FAILED => "_L) Q
- S XLOCDAT=$G(^AUTTLOC(XLOCEIN,0))
- ;AUM*12.0*2 - END NEW CODE
- S XINSTEIN=$P(XLOCDAT,"^",1),XINSTDAT=$G(^DIC(4,XINSTEIN,0))
- S XINSTNM=$P(XINSTDAT,"^",1)
- S DA=XINSTEIN
- S DR="99////"_STNUM
- S DIE="^DIC(4,"
- ;S AUMDA=DA
- D DIE
- I $D(Y) D RSLT($J("",5)_"STATION NUMBER ADD FAILED => "_L)
- E D RSLT($J("",5)_"STATION NUMBER ADD => "_INSNAM_" "_ASUFAC_" "_STNUM)
- Q
- DELSTNM ;EP --- Remove station number
- ;
- D RSLT("REMOVE STATION NUMBER FROM INSTITUTION")
- S INSNAM=$P(L,"^",1),ASUFAC=$P(L,"^",2),STNUM=$P(L,"^",3)
- ;AUM*12.0*2 - IHS/OIT/NKD - ADDED LOGIC TO ENSURE A LOCATION IS FOUND
- ;S XLOCEIN=$O(^AUTTLOC("C",ASUFAC,"")),XLOCDAT=$G(^AUTTLOC(XLOCEIN,0))
- S XLOCEIN=$O(^AUTTLOC("C",ASUFAC,""))
- I $L(XLOCEIN)<1 D RSLT($J("",5)_"STATION NUMBER DELETE FAILED => "_L) Q
- S XLOCDAT=$G(^AUTTLOC(XLOCEIN,0))
- ;AUM*12.0*2 - END NEW CODE
- S XINSTEIN=$P(XLOCDAT,"^",1),XINSTDAT=$G(^DIC(4,XINSTEIN,0))
- S XINSTNM=$P(XINSTDAT,"^",1)
- S DA=XINSTEIN
- S DR="99////@"
- S DIE="^DIC(4,"
- ;S AUMDA=DA
- D DIE
- I $D(Y) D RSLT($J("",5)_"STATION NUMBER DELETE FAILED => "_L)
- E D RSLT($J("",5)_"STATION NUMBER DELETE => "_INSNAM_" "_ASUFAC_" "_STNUM)
- Q
- INSMOD ;EP - update insurer type
- N AUMNAM,AUMCOD,AUMRES,FDA,NEWIEN,ERR,AUMCHG,AUMD0,AUMCNT,AUMIEN
- D RSLT("INSURER TYPE")
- S U="^",AUMIEN=""
- S AUMCOD=$P(L,U,1),AUMNAM=$P(L,U,2)
- S L=AUMCOD_$J("",1)_AUMNAM
- K AUMRES
- D FIND^DIC(9999999.181,"","@;.01;1","PX",AUMCOD,,"C",,,"AUMRES")
- S AUMCNT=$P($G(AUMRES("DILIST",0)),"^",1)
- I AUMCNT=0 S AUMIEN="" ; No matches found, create new
- I AUMCNT=1 S AUMIEN=$P($G(AUMRES("DILIST",1,0)),"^",1) ; One match found, store IEN
- I AUMCNT>1 S AUMIEN=$P($G(AUMRES("DILIST",$P($G(AUMRES("DILIST",0)),"^",1),0)),"^",1)
- I 'AUMIEN D
- . K FDA,NEWIEN,ERR
- . S FDA(9999999.181,"+1,",.01)=AUMNAM ; Name (.01)
- . S FDA(9999999.181,"+1,",1)=AUMCOD ; Code (1)
- . D UPDATE^DIE(,"FDA","NEWIEN","ERR")
- . I $D(ERR) D ADDFAIL Q
- . S AUMIEN=NEWIEN(1),AUMCHG=1
- Q:'AUMIEN
- S AUMD0=$G(^AUTTINTY(AUMIEN,0))
- ;
- K FDA
- S FDA(9999999.181,AUMIEN_",",.01)=AUMNAM ; Name (.01)
- S FDA(9999999.181,AUMIEN_",",1)=AUMCOD ; Code (1)
- D UPDATE^DIE(,"FDA",)
- I AUMD0'=$G(^AUTTINTY(AUMIEN,0)) S AUMCHG=1
- ;
- I AUMCHG D @$S($D(NEWIEN):"ADDOK",1:"MODOK")
- Q
- SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables
- Q
- AUMUPD2 ;IHS/OIT/NKD - SCB UPDATE 05/23/2012 ;
- +1 ;;12.0;TABLE MAINTENANCE;**3**;SEP 27,2011;Build 1
- +2 ;AUM*9.1*4 8/18/2009 OIT.IHS.FCJ ADDED RESNEW, RESFR AND RESMOD MODULES
- +3 ;and Line description for Provider class
- +4 ;
- 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 ;
- 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 ;
- EXAMNEW ;EP --- NEW EXAM
- +1 DO RSLT("NEW EXAM")
- +2 DO RSLT($JUSTIFY("",13)_"NAME")
- +3 DO RSLT($JUSTIFY("",13)_"----")
- +4 DO ADDEXAM
- +5 QUIT
- ADDEXAM ;
- +1 SET N=$PIECE(L,U)
- SET C=$PIECE(L,U,2)
- SET L=N
- +2 IF $DATA(^AUTTEXAM("C",C))
- DO RSLT($JUSTIFY("",5)_$$M(1)_"EXAM CODE EXISTS => "_C_" "_N)
- QUIT
- +3 SET DLAYGO=9999999.15
- SET DIC="^AUTTEXAM("
- SET X=N
- +4 SET DIC("DR")=".02///"_C
- +5 DO FILE
- +6 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
- +7 KILL DLAYGO
- +8 QUIT
- +9 ;
- EXAMFR ;EP - exam from
- +1 SET LFR=L
- +2 QUIT
- EXAMMOD ;EP - modify exam file
- +1 SET E="Exam Name Changes"
- +2 SET N=$PIECE(LFR,"^",1)
- SET C=$PIECE(LFR,"^",2)
- +3 SET DA=$ORDER(^AUTTEXAM("C",C,0))
- +4 SET LTO=L
- +5 SET N=$PIECE(LTO,"^")
- SET C=$PIECE(LTO,"^",2)
- +6 IF 'DA
- SET DA=$ORDER(^AUTTEXAM("C",C,0))
- +7 IF 'DA
- DO ADDEXAM
- QUIT
- +8 SET L=C_" "_N
- +9 SET DIE="^AUTTEXAM("
- SET DR=".01///"_N
- DO DIE
- +10 IF $DATA(Y)
- DO RSLT(E_" : CHANGE FAILED => "_L)
- QUIT
- +11 DO MODOK
- +12 QUIT
- EXAMINA ;EP - inactivate exam
- +1 DO RSLT("Inactivated Exam Codes")
- +2 SET N=$PIECE(L,U)
- +3 SET C=$PIECE(L,"^",2)
- +4 SET DA=$ORDER(^AUTTEXAM("C",C,0))
- IF 'DA
- QUIT
- +5 SET DIE="^AUTTEXAM("
- +6 SET DR=".04///1"
- +7 DO ^DIE
- +8 IF $DATA(Y)
- DO RSLT("CHANGE FAILED => "_L)
- QUIT
- +9 DO RSLT("Code Inactivated: "_N_" "_C)
- +10 QUIT
- EDUCNEW ;EP --- NEW PATIENT ED- P&F
- +1 DO RSLT("EDUCATION - PATIENT AND FAMILY")
- +2 DO RSLT($JUSTIFY("",13)_"NAME")
- +3 DO RSLT($JUSTIFY("",13)_"----")
- +4 DO ADDEDUC
- +5 QUIT
- ADDEDUC ;--- ADD THE NEW PATIENT EDUCATION
- +1 SET N=$PIECE(L,U)
- SET M=$PIECE(L,U,2)
- SET C=$PIECE(L,U,3)
- SET L=N
- +2 IF $DATA(^AUTTEDPF("B",N))
- DO RSLT($JUSTIFY("",5)_$$M(1)_"PT ED NAME EXISTS => "_N)
- QUIT
- +3 SET DLAYGO=9999999.98
- SET DIC="^AUTTEDPF("
- SET X=N
- +4 SET DIC("DR")=".02///"_M_";.03///"_C
- +5 DO FILE
- +6 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
- +7 QUIT
- +8 ;
- HFNEW ;EP --- NEW HEALTH FACTORS
- +1 DO RSLT("NEW HEALTH FACTORS")
- +2 ;D RSLT($J("",13)_"NAME")
- +3 ;D RSLT($J("",13)_"----")
- +4 DO ADDHF
- +5 QUIT
- ADDHF ;
- +1 SET N=$PIECE(L,U)
- SET O=$PIECE(L,U,2)
- SET C=$PIECE(L,U,3)
- SET S=$PIECE(L,U,4)
- SET D=$PIECE(L,U,5)
- +2 SET L=N_" "_O_" "_C_" "_S_" "_D
- +3 IF $DATA(^AUTTHF("B",N))
- DO RSLT($JUSTIFY("",5)_$$M(1)_"HEALTH FACTOR EXISTS => "_N)
- DO RSLT("")
- QUIT
- +4 SET DLAYGO=9999999.64
- SET DIC="^AUTTHF("
- SET X=N
- +5 SET DIC("DR")=".02///"_D_";.03///"_O_";.1///"_C_";.14///"_S
- +6 DO FILE
- +7 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
- +8 QUIT
- +9 ;
- HFFR ;EP --- HEALTH FACTOR FROM
- +1 SET LFR=L
- +2 QUIT
- HFMOD ;EP --- MODIFY HEALTH FACTOR
- +1 SET E="Health Factor Changes"
- +2 SET LTO=L
- +3 SET N=$PIECE(LFR,"^",1)
- +4 SET DA=$ORDER(^AUTTHF("B",N,0))
- +5 SET N=$PIECE(LTO,"^",1)
- SET O=$PIECE(LTO,"^",2)
- SET C=$PIECE(LTO,"^",3)
- SET S=$PIECE(LTO,"^",4)
- SET D=$PIECE(LTO,"^",5)
- SET M=$PIECE(LTO,"^",6)
- +6 IF 'DA
- SET DA=$ORDER(^AUTTHF("B",N,0))
- +7 IF 'DA
- DO ADDHF
- QUIT
- +8 SET $PIECE(^AUTTHF(DA,0),"^",13)=""
- +9 SET $PIECE(^AUTTHF(DA,0),"^",15)=""
- +10 SET DIE="^AUTTHF("
- +11 SET DR=".01///"_N_";.03///"_O_";.1///"_C_";.14///"_S_";.02///"_D_";8801///"_M
- +12 DO DIE
- +13 IF $DATA(Y)
- DO RSLT(E_" : CHANGE FAILED => "_L)
- QUIT
- +14 DO MODOK
- +15 QUIT
- HFINA ;EP --- INACTIVATE HEALTH FACTOR
- +1 DO RSLT("Inactivated Health Factors")
- +2 SET N=$PIECE(L,U)
- +3 SET D=$PIECE(L,U,2)
- +4 SET L=N_" "_D
- +5 SET DA=$ORDER(^AUTTHF("B",N,0))
- IF 'DA
- QUIT
- +6 SET DIE="^AUTTHF("
- +7 SET DR=".13///1;.15///"_D
- +8 DO ^DIE
- +9 IF $DATA(Y)
- DO RSLT($JUSTIFY("",5)_"EDIT FAILED => "_L)
- +10 IF '$TEST
- DO RSLT($JUSTIFY("",5)_"INACTIVATED => "_L)
- +11 QUIT
- +12 ;
- PCLASNEW ;EP --- NEW PROV CLASS
- +1 ;CODE^NAME^ABRV^PCP^WL ;AUM9.1*4 IHS/OIT/FCJ NEW LINE
- +2 SET E="NEW SERVICES RENDERED BY (PROVIDER CODES)"
- +3 DO RSLT(E)
- +4 ;D RSLT($J("",11)_"CODE NAME"_$J("",28)_"ABRV.")
- +5 ;D RSLT($J("",11)_"---- ----"_$J("",28)_"-----")
- +6 DO ADDPCLAS
- +7 QUIT
- ADDPCLAS ;
- +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)
- +2 SET L=C_" "_N_$JUSTIFY("",(32-$LENGTH(N)))_A
- +3 IF $DATA(^DIC(7,"D",C))
- DO RSLT($JUSTIFY("",5)_$$M(1)_"PROVIDER CODE EXISTS => "_C)
- DO RSLT("")
- QUIT
- +4 SET DLAYGO=7
- SET DIC="^DIC(7,"
- SET X=N
- SET DIC("DR")="1///"_A_";9999999.01///"_C_";9999999.03///"_P_";9999999.05///"_R
- +5 DO FILE
- +6 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
- +7 QUIT
- +8 ;
- PCLASFR ;EP - provider class from
- +1 SET LFR=L
- +2 QUIT
- PCLASMOD ;EP
- +1 DO RSLT("SERVICES RENDERED BY (PROVIDER) CODE CHANGES (SECTION XV)")
- +2 SET C=$PIECE(LFR,"^",1)
- SET N=$PIECE(LFR,"^",2)
- SET A=$PIECE(LFR,"^",3)
- +3 SET LTO=L
- +4 SET C=$PIECE(LTO,"^",1)
- SET N=$PIECE(LTO,"^",2)
- SET A=$PIECE(LTO,"^",3)
- SET I=$PIECE(LTO,"^",4)
- SET II=$PIECE(LTO,"^",5)
- +5 SET P=$ORDER(^DIC(7,"D",C,0))
- +6 IF 'P
- DO ADDPCLAS
- QUIT
- +7 SET L=C_" "_N_" "_A
- +8 SET DIE="^DIC(7,"
- SET DA=P
- SET DR=".01///"_N_";1///"_A_";9999999.01///"_C_";9999999.03///"_I_";9999999.05///"_II
- +9 DO ^DIE
- +10 IF $DATA(Y)
- DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT PROVIDER CODE FAILED => "_L)
- QUIT
- +11 DO MODOK
- +12 QUIT
- +13 ;
- +14 ;IHS/OIT/NKD AUM*12.0*3 Replace previous processing
- +15 ;MEASNEW ;EP --- NEW MEASUREMENT TYPE
- +16 ;S E="New Measurement Type"
- +17 ;D RSLT(E)
- +18 ;D ADDMEAS
- +19 ;Q
- +20 ;ADDMEAS ;
- +21 ;S N=$P(L,"^"),S=$P(L,"^",2),C=$P(L,"^",3),L=N_" "_S_" "_C
- +22 ;I $D(^AUTTMSR("C",C)) D RSLT(E_" : MEASUREMENT TYPE CODE EXISTS => "_C) Q
- +23 ;S DLAYGO=9999999.07,DIC="^AUTTMSR(",X=N,DIC("DR")=".02///"_S_";.03///"_C D FILE
- +24 ;D ADDFAIL:Y<0,ADDOK:Y>0
- +25 ;Q
- MEASMOD ;EP --- UPDATE MEASUREMENT TYPE
- +1 NEW AUMACT,AUMTYP,AUMDES,AUMCOD,AUMHTXT,AUMINP,AUMRES,FDA,NEWIEN,ERR,AUMCHG,AUMD0,AUMCNT,AUMIEN
- +2 DO RSLT("MEASUREMENT TYPE")
- +3 SET U="^"
- SET AUMIEN=""
- +4 SET AUMACT=$PIECE(L,U,4)
- SET AUMTYP=$PIECE(L,U,2)
- SET AUMDES=$PIECE(L,U,3)
- SET AUMCOD=$PIECE(L,U,1)
- SET AUMHTXT=$PIECE(L,U,5)
- SET AUMINP=$TRANSLATE($PIECE(L,U,6),"|","^")
- +5 SET L=AUMCOD_$JUSTIFY("",6-$LENGTH(AUMCOD))_AUMTYP_$JUSTIFY("",8-$LENGTH(AUMTYP))_AUMDES
- +6 KILL AUMRES
- +7 DO FIND^DIC(9999999.07,"","@;.01;.03","PX",AUMCOD,,"C",,,"AUMRES")
- +8 SET AUMCNT=$PIECE($GET(AUMRES("DILIST",0)),"^",1)
- +9 ; No matches found, create new
- IF AUMCNT=0
- SET AUMIEN=""
- +10 ; One match found, store IEN
- IF AUMCNT=1
- SET AUMIEN=$PIECE($GET(AUMRES("DILIST",1,0)),"^",1)
- +11 IF AUMCNT>1
- SET AUMIEN=$PIECE($GET(AUMRES("DILIST",$PIECE($GET(AUMRES("DILIST",0)),"^",1),0)),"^",1)
- +12 IF 'AUMIEN
- IF $LENGTH(AUMACT)>0
- Begin DoDot:1
- +13 DO RSLT($JUSTIFY("",5)_"INACTIVATE MEASUREMENT TYPE FAILED : MEASUREMENT TYPE DOES NOT EXIST => "_L)
- End DoDot:1
- QUIT
- +14 IF 'AUMIEN
- Begin DoDot:1
- +15 KILL FDA,NEWIEN,ERR
- +16 ; Type (.01)
- SET FDA(9999999.07,"+1,",.01)=AUMTYP
- +17 ; Description (.02)
- SET FDA(9999999.07,"+1,",.02)=AUMDES
- +18 ; Code (.03)
- SET FDA(9999999.07,"+1,",.03)=AUMCOD
- +19 DO UPDATE^DIE(,"FDA","NEWIEN","ERR")
- +20 IF $DATA(ERR)
- DO ADDFAIL
- QUIT
- +21 SET AUMIEN=NEWIEN(1)
- SET AUMCHG=1
- End DoDot:1
- +22 IF 'AUMIEN
- QUIT
- +23 SET AUMD0=$GET(^AUTTMSR(AUMIEN,0))
- +24 ;
- +25 KILL FDA
- +26 ; Type (.01)
- SET FDA(9999999.07,AUMIEN_",",.01)=AUMTYP
- +27 ; Description (.02)
- SET FDA(9999999.07,AUMIEN_",",.02)=AUMDES
- +28 ; Code (.03)
- SET FDA(9999999.07,AUMIEN_",",.03)=AUMCOD
- +29 ; Inactive (.04)
- SET FDA(9999999.07,AUMIEN_",",.04)=$SELECT($LENGTH(AUMACT)>0:1,1:"@")
- +30 ; Value Input Transform (1201)
- SET FDA(9999999.07,AUMIEN_",",1201)=AUMINP
- +31 DO UPDATE^DIE(,"FDA",)
- +32 IF AUMD0'=$GET(^AUTTMSR(AUMIEN,0))
- SET AUMCHG=1
- +33 ;
- +34 ; Help Text (1100) WP
- +35 ; convert string to WP array
- DO TEXT^AUMUPD4(.AUMHTXT)
- +36 DO WP^DIE(9999999.07,AUMIEN_",",1100,,"AUMHTXT")
- +37 ;
- +38 IF AUMCHG
- DO @$SELECT($DATA(NEWIEN):"ADDOK",$LENGTH(AUMACT)>0:"INAOK",1:"MODOK")
- +39 ;
- +40 QUIT
- RESNEW ; NEW RESERVATION
- +1 ;CODE^NAME^AREA^STATE
- +2 IF $GET(AUMFLG)=1
- SET L=LTO
- +3 DO RSLT("NEW RESERVATION CODE")
- +4 SET N=$PIECE(L,U,2)
- SET C=$PIECE(L,U)
- SET A=$PIECE(L,U,3)
- SET S=$PIECE(L,U,4)
- +5 SET L=N_" "_C_" "_A_" "_S
- +6 IF $DATA(^AUTTRES("B",N))!$DATA(^AUTTRES("C",C))
- DO RSLT($JUSTIFY("",5)_$$M(1)_"RESERVATION ENTRY EXISTS => "_N_" "_C)
- QUIT
- +7 SET DLAYGO=9999999.47
- SET DIC="^AUTTRES("
- SET X=N
- +8 SET DIC("DR")=".02///"_C_";.03///"_S_";.04///"_A
- +9 DO FILE
- +10 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
- +11 KILL AUMFLG
- QUIT
- +12 ;
- RESFR ;EP --- EDIT RESERVATION ENTRY
- +1 SET AUMFLG=0
- +2 DO RSLT("RESERVATION CODE CHANGES")
- +3 SET LFR=L
- +4 QUIT
- RESMOD ;EP --- CONT EDIT RESERVATION ENTRY
- +1 SET LTO=L
- +2 SET N=$PIECE(LFR,U,2)
- SET C=$PIECE(LFR,U)
- +3 SET L=N_" "_C_" "_$PIECE(LFR,U,3)_" "_$PIECE(LFR,U,4)
- +4 SET DA=$ORDER(^AUTTRES("B",N,0))
- IF 'DA
- SET DA=$ORDER(^AUTTRES("C",C,0))
- +5 SET N=$PIECE(LTO,U,2)
- SET C=$PIECE(LTO,U)
- SET A=$PIECE(LTO,U,3)
- SET S=$PIECE(LTO,U,4)
- RESMOD2 ;
- +1 IF 'DA
- SET DA=$ORDER(^AUTTRES("C",C,0))
- IF 'DA
- SET DA=$ORDER(^AUTTRES("B",N,0))
- +2 IF 'DA
- SET AUMFLG=1
- DO RESNEW
- QUIT
- +3 SET DIE="^AUTTRES("
- +4 SET DR=".01///"_N_";.02///"_C_";.03///"_S_";.04///"_A
- +5 DO DIE
- +6 IF $DATA(Y)
- DO RSLT($JUSTIFY("",5)_"RESERVATION CHANGE FAILED => "_L)
- +7 IF '$TEST
- DO RSLT($JUSTIFY("",5)_"RESERVATION CHANGE => "_N_" "_C_" "_S_" "_A)
- +8 QUIT
- +9 ;
- COMINAC ;INACTIVATE 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))
- DO RSLT($JUSTIFY("",5)_"INACTIVATE COMMUNITY FAILED: STCTYCOM CODE DOES NOT EXIST => "_S_O_C)
- QUIT
- +3 SET DA=$ORDER(^AUTTCOM("C",S_O_C,0))
- +4 SET DIE="^AUTTCOM("
- SET DR=".18////"_DT
- +5 DO DIE
- +6 IF $DATA(Y)
- DO RSLT($JUSTIFY("",5)_"EDIT INACTIVE DATE FAILED => "_L)
- +7 IF '$TEST
- DO RSLT($JUSTIFY("",5)_"INACTIVATED => "_L)
- +8 QUIT
- CNTYDEL ; County Delete
- +1 ; Temporary action to physically remove a county entry
- +2 DO RSLT("COUNTY CODE DELETE (SECTION V-C)")
- +3 SET LTO=L
- +4 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
- +5 SET P=$ORDER(^AUTTCTY("C",S_C,0))
- +6 IF 'P
- DO RSLT($JUSTIFY("",5)_"NOT DELETED : COUNTY CODE DOES NOT EXIST => "_L2)
- QUIT
- +7 SET DIK="^AUTTCTY("
- +8 SET DA=P
- +9 DO ^DIK
- +10 IF '$DATA(Y)
- DO RSLT($JUSTIFY("",5)_" : DELETE COUNTY CODE FAILED => "_L2)
- +11 IF '$TEST
- DO RSLT($JUSTIFY("",5)_" : COUNTY CODE DELETED: "_L2)
- +12 QUIT
- TRIBEFR ;EP --- tribe from
- +1 SET LFR=L
- +2 QUIT
- TRIBEMOD ;EP --- MOD TRIBE
- +1 ; C=CODE, N=NAME, LN=LONG NAME, P=IEN
- +2 DO RSLT("MODIFY TRIBE")
- +3 SET C=$PIECE(LFR,U)
- SET N=$PIECE(LFR,U,2)
- SET LN=$PIECE(LFR,U,3)
- SET L1=C_" "_N
- +4 SET P=$ORDER(^AUTTTRI("C",C,0))
- +5 SET LTO=L
- +6 SET C=$PIECE(LTO,U)
- SET N=$PIECE(LTO,U,2)
- SET LN=$PIECE(LTO,U,3)
- +7 IF 'P
- SET P=$ORDER(^AUTTTRI("C",C,0))
- +8 IF 'P
- DO ADDTRIBE
- QUIT
- +9 SET L=C_" "_N
- +10 SET DIE="^AUTTTRI("
- +11 SET DA=P
- +12 SET DR=".01///"_N_";.02///"_C_";.03///"_LN
- +13 DO DIE
- +14 IF $DATA(Y)
- DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT TRIBE FAILED => "_L)
- QUIT
- +15 DO RSLT("Changed: "_L1_" TO "_L)
- +16 QUIT
- TRIBENEW ;EP --- NEW TRIBE
- +1 DO RSLT("NEW TRIBE")
- +2 DO ADDTRIBE
- +3 QUIT
- ADDTRIBE ;
- +1 SET C=$PIECE(L,U)
- SET N=$PIECE(L,U,2)
- +2 SET L=" "_$$LJ^XLFSTR(C,5)_$$LJ^XLFSTR(N,4)
- +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
- +9 DO FILE
- +10 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
- +11 QUIT
- ADDINST ;EP --- Add institute
- +1 ;
- +2 DO RSLT("ADD INSTITUTION AND STATION NUMBER")
- +3 SET INSNAM=$PIECE(L,"^",1)
- SET STNUM=$PIECE(L,"^",3)
- +4 FOR %=+$PIECE(^DIC(4,0),U,3):1
- IF '$DATA(^DIC(4,%))
- QUIT
- +5 IF %>99999
- DO RSLT($JUSTIFY("",5)_$$M(0)_"DINUM FOR INSTITUTION TOO BIG. NOTIFY ISC.")
- QUIT
- +6 ;I %,$D(^DIC(4,%,0))
- +7 SET DLAYGO=4
- SET DIC="^DIC(4,"
- SET DINUM=%
- SET X=INSNAM
- +8 ;S DIE="^DIC(4,",DA=%,DR=".01///"_INSNAM_";
- +9 ;S DR="99///"_STNUM
- +10 DO FILE
- IF Y<0
- DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L)
- QUIT
- +11 IF $DATA(Y)
- DO RSLT($JUSTIFY("",5)_"INSTITUTION NAME UPDATED => "_INSNAM)
- +12 KILL DINUM,DLAYGO
- +13 SET DIE="^DIC(4,"
- SET DA=%
- SET DR="99////"_STNUM
- DO DIE
- +14 QUIT
- ADDSTNM ;EP --- Add station number
- +1 ;
- +2 DO RSLT("ADD STATION NUMBER TO INSTITUTION")
- +3 SET INSNAM=$PIECE(L,"^",1)
- SET ASUFAC=$PIECE(L,"^",2)
- SET STNUM=$PIECE(L,"^",3)
- +4 ;AUM*12.0*2 - IHS/OIT/NKD - ADDED LOGIC TO ENSURE A LOCATION IS FOUND
- +5 ;S XLOCEIN=$O(^AUTTLOC("C",ASUFAC,"")),XLOCDAT=$G(^AUTTLOC(XLOCEIN,0))
- +6 SET XLOCEIN=$ORDER(^AUTTLOC("C",ASUFAC,""))
- +7 IF $LENGTH(XLOCEIN)<1
- DO RSLT($JUSTIFY("",5)_"STATION NUMBER ADD FAILED => "_L)
- QUIT
- +8 SET XLOCDAT=$GET(^AUTTLOC(XLOCEIN,0))
- +9 ;AUM*12.0*2 - END NEW CODE
- +10 SET XINSTEIN=$PIECE(XLOCDAT,"^",1)
- SET XINSTDAT=$GET(^DIC(4,XINSTEIN,0))
- +11 SET XINSTNM=$PIECE(XINSTDAT,"^",1)
- +12 SET DA=XINSTEIN
- +13 SET DR="99////"_STNUM
- +14 SET DIE="^DIC(4,"
- +15 ;S AUMDA=DA
- +16 DO DIE
- +17 IF $DATA(Y)
- DO RSLT($JUSTIFY("",5)_"STATION NUMBER ADD FAILED => "_L)
- +18 IF '$TEST
- DO RSLT($JUSTIFY("",5)_"STATION NUMBER ADD => "_INSNAM_" "_ASUFAC_" "_STNUM)
- +19 QUIT
- DELSTNM ;EP --- Remove station number
- +1 ;
- +2 DO RSLT("REMOVE STATION NUMBER FROM INSTITUTION")
- +3 SET INSNAM=$PIECE(L,"^",1)
- SET ASUFAC=$PIECE(L,"^",2)
- SET STNUM=$PIECE(L,"^",3)
- +4 ;AUM*12.0*2 - IHS/OIT/NKD - ADDED LOGIC TO ENSURE A LOCATION IS FOUND
- +5 ;S XLOCEIN=$O(^AUTTLOC("C",ASUFAC,"")),XLOCDAT=$G(^AUTTLOC(XLOCEIN,0))
- +6 SET XLOCEIN=$ORDER(^AUTTLOC("C",ASUFAC,""))
- +7 IF $LENGTH(XLOCEIN)<1
- DO RSLT($JUSTIFY("",5)_"STATION NUMBER DELETE FAILED => "_L)
- QUIT
- +8 SET XLOCDAT=$GET(^AUTTLOC(XLOCEIN,0))
- +9 ;AUM*12.0*2 - END NEW CODE
- +10 SET XINSTEIN=$PIECE(XLOCDAT,"^",1)
- SET XINSTDAT=$GET(^DIC(4,XINSTEIN,0))
- +11 SET XINSTNM=$PIECE(XINSTDAT,"^",1)
- +12 SET DA=XINSTEIN
- +13 SET DR="99////@"
- +14 SET DIE="^DIC(4,"
- +15 ;S AUMDA=DA
- +16 DO DIE
- +17 IF $DATA(Y)
- DO RSLT($JUSTIFY("",5)_"STATION NUMBER DELETE FAILED => "_L)
- +18 IF '$TEST
- DO RSLT($JUSTIFY("",5)_"STATION NUMBER DELETE => "_INSNAM_" "_ASUFAC_" "_STNUM)
- +19 QUIT
- INSMOD ;EP - update insurer type
- +1 NEW AUMNAM,AUMCOD,AUMRES,FDA,NEWIEN,ERR,AUMCHG,AUMD0,AUMCNT,AUMIEN
- +2 DO RSLT("INSURER TYPE")
- +3 SET U="^"
- SET AUMIEN=""
- +4 SET AUMCOD=$PIECE(L,U,1)
- SET AUMNAM=$PIECE(L,U,2)
- +5 SET L=AUMCOD_$JUSTIFY("",1)_AUMNAM
- +6 KILL AUMRES
- +7 DO FIND^DIC(9999999.181,"","@;.01;1","PX",AUMCOD,,"C",,,"AUMRES")
- +8 SET AUMCNT=$PIECE($GET(AUMRES("DILIST",0)),"^",1)
- +9 ; No matches found, create new
- IF AUMCNT=0
- SET AUMIEN=""
- +10 ; One match found, store IEN
- IF AUMCNT=1
- SET AUMIEN=$PIECE($GET(AUMRES("DILIST",1,0)),"^",1)
- +11 IF AUMCNT>1
- SET AUMIEN=$PIECE($GET(AUMRES("DILIST",$PIECE($GET(AUMRES("DILIST",0)),"^",1),0)),"^",1)
- +12 IF 'AUMIEN
- Begin DoDot:1
- +13 KILL FDA,NEWIEN,ERR
- +14 ; Name (.01)
- SET FDA(9999999.181,"+1,",.01)=AUMNAM
- +15 ; Code (1)
- SET FDA(9999999.181,"+1,",1)=AUMCOD
- +16 DO UPDATE^DIE(,"FDA","NEWIEN","ERR")
- +17 IF $DATA(ERR)
- DO ADDFAIL
- QUIT
- +18 SET AUMIEN=NEWIEN(1)
- SET AUMCHG=1
- End DoDot:1
- +19 IF 'AUMIEN
- QUIT
- +20 SET AUMD0=$GET(^AUTTINTY(AUMIEN,0))
- +21 ;
- +22 KILL FDA
- +23 ; Name (.01)
- SET FDA(9999999.181,AUMIEN_",",.01)=AUMNAM
- +24 ; Code (1)
- SET FDA(9999999.181,AUMIEN_",",1)=AUMCOD
- +25 DO UPDATE^DIE(,"FDA",)
- +26 IF AUMD0'=$GET(^AUTTINTY(AUMIEN,0))
- SET AUMCHG=1
- +27 ;
- +28 IF AUMCHG
- DO @$SELECT($DATA(NEWIEN):"ADDOK",1:"MODOK")
- +29 QUIT
- SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables
- +1 QUIT
