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
