AUM41031 ;IHS/ITSC/DMJ - SCB UPDATE 2/18/2004 [ 04/01/2004 11:05 AM ]
;;04.1;TABLE MAINTENANCE;**3**;OCT 13,2003
;
START ;EP -- MAIN EP
N DA,DIC,DIE,DINUM,DLAYGO,DR,@($P($T(SVARS),";",3))
D GREET
D DASH,AREANEW
D DASH,SUNEW
D DASH,SUMOD
D DASH,LOCNEW
D DASH,LOCMOD
D DASH,LOCINACT
D DASH,COMMNEW
D DASH,COMMMOD
D DASH,TRIBEMOD^AUM41032
D DASH,EXAMNEW^AUM41032
D DASH,EXAMMOD^AUM41032
D DASH,CLINNEW^AUM41032
D DASH,CLINMOD^AUM41032
D DASH,PCLASNEW^AUM41032
D DASH,PCLASMOD^AUM41032
D DASH,EDUCNEW^AUM41032
D DASH,HFNEW^AUM41032
D DASH,MEASNEW^AUM41032
Q
GREET ;----- GREETING/INTRO TEXT
D RSLT($J("",5)_$P($T(UPDATE^AUM4103A),";",3))
F L="GREET","INTROE","INTROI" D
. F %=1:1 D RSLT($P($T(@L+%^AUM4103),";",3)) Q:$P($T(@L+%+1^AUM4103),";",3)="###"
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
;
E(L) ;-----
Q $P($P($T(@L^AUM4103A),";",3),":",1)
;
IEN(X,%,Y) ;
;----- UPDATE AREA, SERVICE UNIT, COUNTY
S Y=$O(@(X_"""C"",%,0)")) I Y Q +Y
I 'Y S Y=$$VAL^AUM4103M(X,%)
I Y D S:Y<0 Y=""
. N %,@($P($T(SVARS),";",3))
. S L=Y
. I X["AREA" D Q
. . N X
. . D RSLT("(Add Missing Area)")
. . D ADDAREA
. . D RSLT("(END Add Missing Area)")
. I X["SU" D Q
. . N X
. . D RSLT("(Add Missing SU)")
. . D ADDSU
. . D RSLT("(END Add Missing SU)")
. I X["CTY" D Q
. . N X
. . D RSLT("(Add Missing County)")
. . D ADDCNTY
. . D RSLT("(END Add Missing County)")
;
D:'Y RSLT($J("",5)_$$M(0)_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
Q +Y
;
DIK ;--- KILL ENTRY
N @($P($T(SVARS),";",3)),DIK
D ^DIK
Q
;
FILE ;--- FILE NEW ENTRY
N @($P($T(SVARS),";",3))
K DD,DO
S DIC(0)="L"
D FILE^DICN
K DIC,DLAYGO
Q
;
M(%) ;--- ERROR MESSAGE
Q $S(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")
;
MODOK ;--- IF MOD OK
D RSLT($J("",5)_"Changed : "_L)
Q
;
RSLT(%) ; EP- INCREMENTS/UPDATES ^TMP("AUM4103,$J) called here and AUM4103
; global used to generate the email message sent by
; post-install routine
S ^(0)=$G(^TMP("AUM4103",$J,0))+1,^(^(0))=% D MES(%)
Q
;
MES(%) ;--- ISSUE MESSAGES DURING INSTALL
N @($P($T(SVARS),";",3))
D MES^XPDUTL(%)
Q
;
IXDIC(DIC,DIC0,D,X,DLAYGO) ;
;--- CALL TO FILEMAN IX^DIC
N @($P($T(SVARS),";",3))
S DIC(0)=DIC0
K DIC0
I '$G(DLAYGO) K DLAYGO
D IX^DIC
Q Y
;
AREANEW ;
S E="New Area Codes"
F T=1:1 S L=$T(AREANEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDAREA
Q
;
ADDAREA ;--- NEW AREA
; PROGRAMMER NOTE: This s/r is required for every patch.
S L=$P(L,";;",2),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
;
ADDCNTY ;--- NEW COUNTY
; PROGRAMMER NOTE: This s/r is required for every patch.
S L=$P(L,";;",2),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3),A=$P(L,U,4),L=S_" "_C_" "_N_$J("",30-$L(N))_A
I $D(^AUTTCTY("C",S_C)) D RSLT($J("",5)_$$M(1)_"CODE EXISTS => "_S_C) Q
S P("S")=$$IEN("^DIC(5,",S)
Q:'P("S")
S DIC="^AUTTCTY("
S X=N
S DIC("DR")=".02////"_P("S")_";.03///"_C_";.06///"_A
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
ADDSU ;
; PROGRAMMER NOTE: This s/r is required for every patch.
S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3),L=$$LJ^XLFSTR(A,6)_$$LJ^XLFSTR(S,6)_N
I $D(^AUTTSU("C",A_S)) D RSLT($J("",5)_$$M(1)_"ASU EXISTS => "_A_S) Q
S P=$$IEN("^AUTTAREA(",A)
Q:'P
S DLAYGO=9999999.22
S DIC="^AUTTSU("
S X=N
S DIC("DR")=".02////"_P_";.03///"_S
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
SUNEW ;--- ADD NEW SU
D RSLT($$E("SUNEW"))
D RSLT($J("",13)_$$LJ^XLFSTR("AREA",6)_$$LJ^XLFSTR("S.U.",6)_"NAME")
D RSLT($J("",13)_$$LJ^XLFSTR("----",6)_$$LJ^XLFSTR("----",6)_"----")
F T=1:1 S L=$T(SUNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDSU
Q
;
SUMOD ;--- MOD SU
D RSLT($$E("SUMOD"))
D RSLT($J("",15)_"AA SU NAME")
D RSLT($J("",15)_"-- -- ----")
F T=1:2 S L=$T(SUMOD+T^AUM4103A) Q:$P(L,";",3)="END" S L("TO")=$T(SUMOD+T+1^AUM4103A) D
. S L=$P(L,U,2,99),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3)
. S P=$O(^AUTTSU("C",A_S,0))
. S L=$P(L("TO"),U,2,99),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3)
. I 'P S P=$O(^AUTTSU("C",A_S,0)) I 'P S L=";;"_L D ADDSU Q
. S L=A_" "_S_" "_N
. S P("A")=$$IEN("^AUTTAREA(",A)
. Q:'P("A")
. S DIE="^AUTTSU(",DA=P,DR=".01///"_N_";.02////"_P("A")_";.03///"_S
. D DIE
. I $D(Y) D RSLT($J("",5)_$$E(0)_" : EDIT SERVICE UNIT FAILED => "_L) Q
. D MODOK
Q
;
LOCNEW ;--- ADD NEW LOCATION
D RSLT($$E("LOCNEW"))
D RSLT($$RJ^XLFSTR("AA SU FA NAME",26)_$$RJ^XLFSTR("PSEUDO",34))
D RSLT($$RJ^XLFSTR("-- -- -- ----",26)_$$RJ^XLFSTR("------",34))
F T=1:1 S L=$T(LOCNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDLOC
Q
ADDLOC ;
S L=$P(L,";;",2),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_$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)
.Q
S P("A")=$$IEN("^AUTTAREA(",A)
Q:'P("A")
S P("S")=$$IEN("^AUTTSU(",A_S)
Q:'P("S")
F DINUM=+$P(^DIC(4,0),U,3):1 Q:'$D(^DIC(4,DINUM))&('$D(^AUTTLOC(DINUM))) I DINUM>99999 D RSLT($J("",5)_$$M(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.") Q
Q:DINUM>99999
S DLAYGO=4,DIC="^DIC(4,",X=N
D FILE
K DINUM,DLAYGO
I Y<0 D RSLT($J("",5)_$$M(0)_"^DIC(4 ADD FAILED => "_L) Q
NEW AUMAD
S AUMAD=0
F S AUMAD=$O(^DD(4,.01,1,AUMAD)) Q:'AUMAD I $P(^(AUMAD,0),U,2)="AD",$E(^(1),1)="I" Q
; If AD xref on 4 is active, edit LOCATION and Quit.
I AUMAD D Q
. S DA=+Y,DIE="^AUTTLOC(",DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P
. D DIE
. I '$D(Y) D ADDOK Q
. D RSLT($J("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L)
.Q
S DINUM=+Y,DLAYGO=9999999.06,DIC="^AUTTLOC(",X=DINUM,DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P
D FILE,@$S(Y>0:"ADDOK",1:"ADDFAIL")
KILL DINUM,DLAYGO
Q
;
LOCMOD ;--- MOD LOCATION
D RSLT($$E("LOCMOD"))
D RSLT($$RJ^XLFSTR("AA SU FA NAME",28)_$$RJ^XLFSTR("PSEUDO",34))
D RSLT($$RJ^XLFSTR("-- -- -- ----",28)_$$RJ^XLFSTR("------",34))
F T=1:2 S L=$T(LOCMOD+T^AUM4103A) Q:$P(L,";",3)="END" S L("TO")=$T(LOCMOD+T+1^AUM4103A) D
. S L=$P(L,U,2,99),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3)
. S P=$O(^AUTTLOC("C",A_S_F,0))
. S L=$P(L("TO"),U,2,99),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4)
. I 'P S P=$O(^AUTTLOC("C",A_S_F,0)) I 'P S L=";;"_L D ADDLOC Q
. S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_$P(L("TO"),U,6)
. S P("A")=$$IEN("^AUTTAREA(",A)
. Q:'P("A")
. S P("S")=$$IEN("^AUTTSU(",A_S)
. Q:'P("S")
. S DIE="^AUTTLOC(",DA=P,DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_$P(L("TO"),U,6)
. D DIE
. I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L) Q
. S DIE="^DIC(4,",DA=$P(^AUTTLOC(P,0),U),DR=".01///"_N
. D DIE
. I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L) Q
. D MODOK
.Q
;
D DASH
D RSLT("Checking Location Code changes to determine export status.")
D RSLT("Patient data is not exported if the only change is to the Location NAME.")
D RSLT("Location Code changes must be rolled up into the national data repository...")
D DASH,RSLT($$LOCMOD^AUMXPORT("AUM4103A")_" patients marked for export because of the Location Code changes.")
Q
;
LOCINACT ;--- INACTIVATE LOCATION
D RSLT("Inactivated Location Codes")
F T=1:1 S L=$T(LOCINACT+T^AUM4103A) Q:$P(L,";",3)="END" D
. S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4),P=$P(L,U,5)
. S L=A_" "_S_" "_F_" "_N_" "_P
. S %=A_S_F,%=$O(^AUTTLOC("C",%,0))
. I '% D RSLT($J("",5)_"ASUFAC "_A_S_F_" not found (OK).") Q
. S DIE="^AUTTLOC(",DA=%,DR=".27////"_DT
. D DIE
. I $D(Y) D RSLT($J("",5)_$$E(0)_"EDIT INACTIVE DATE FAILED => "_L) I 1
. E D RSLT($J("",5)_"INACTIVATED => "_L)
.Q
Q
;
COMMNEW ;--- ADD COMMUNITY
D RSLT($$E("COMMNEW"))
D RSLT($$RJ^XLFSTR("ST CT COM NAME",27)_$$RJ^XLFSTR("AA SU",33))
D RSLT($$RJ^XLFSTR("-- -- --- ----",27)_$$RJ^XLFSTR("-- --",33))
F T=1:1 S L=$T(COMMNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDCOMM
Q
ADDCOMM ;
S L=$P(L,";;",2),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6),L=S_" "_O_" "_C_" "_N_$J("",32-$L(N))_A_" "_V
I $D(^AUTTCOM("C",S_O_C)) D RSLT($J("",5)_$$M(1)_"STCTYCOM CODE EXISTS => "_S_O_C) Q
S P("O")=$$IEN("^AUTTCTY(",S_O)
Q:'P("O")
S P("A")=$$IEN("^AUTTAREA(",A)
Q:'P("A")
S P("V")=$$IEN("^AUTTSU(",A_V)
Q:'P("V")
S DLAYGO=9999999.05,DIC="^AUTTCOM(",X=N,DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
COMMMOD ;--- MOD COMMUNITY
D RSLT($$E("COMMMOD"))
D RSLT($J("",15)_"ST CT COM NAME"_$J("",28)_"AA SU")
D RSLT($J("",15)_"-- -- --- ----"_$J("",28)_"-- --")
F T=1:2 S L=$T(COMMMOD+T^AUM4103A) Q:$P(L,";",3)="END" S L("TO")=$T(COMMMOD+T+1^AUM4103A) D
. S L=$P(L,U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3)
. S P=$O(^AUTTCOM("C",S_O_C,0))
. S L=$P(L("TO"),U,2,99),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)
. I 'P S P=$O(^AUTTCOM("C",S_O_C,0)) I 'P S L=";;"_L 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(",DA=P,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
.Q
D DASH
D RSLT("Checking Community Code changes to determine export status.")
D RSLT("Patient data is not exported if the only change is to the Commnuity NAME.")
D RSLT("Commnity Code changes must be rolled up into the national data repository...")
D DASH,RSLT($$COMMMOD^AUMXPORT("AUM4103A")_" patients marked for export because of the Community Code changes.")
Q
;
CLINNEW ;--- ADD NEW CLINIC
D RSLT($$E("CLINNEW"))
D RSLT($J("",11)_"CODE NAME"_$J("",28)_"ABRV. PRI.CARE 1A WL RPT")
D RSLT($J("",11)_"---- ----"_$J("",28)_"----- -------- ---------")
F T=1:1 S L=$T(CLINNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDCLIN
KILL DLAYGO
Q
;
ADDCLIN ;
S L=$P(L,";;",2),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
;
CLINMOD ;
S E="Clinic Name Changes"
F T=1:2 S L=$T(CLINMOD+T^AUM4103A) Q:$P(L,";",3)="END" D
.S L("TO")=$T(CLINMOD+T+1^AUM4103A)
.S L=$P(L("TO"),"^",2,99),C=$P(L,"^",1),N=$P(L,"^",2)
.S DA=$O(^DIC(40.7,"C",C,0))
.I 'DA S L=";;"_L D ADDCLIN Q
.S DIE="^DIC(40.7,",DR=".01///"_N D ^DIE
.I $D(Y) D RSLT(E_" : CHANGE FAILED => "_L) Q
.D MODOK
Q
;
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V,W;Single-character work variables
Q
AUM41031 ;IHS/ITSC/DMJ - SCB UPDATE 2/18/2004 [ 04/01/2004 11:05 AM ]
+1 ;;04.1;TABLE MAINTENANCE;**3**;OCT 13,2003
+2 ;
START ;EP -- MAIN EP
+1 NEW DA,DIC,DIE,DINUM,DLAYGO,DR,@($PIECE($TEXT(SVARS),";",3))
+2 DO GREET
+3 DO DASH
DO AREANEW
+4 DO DASH
DO SUNEW
+5 DO DASH
DO SUMOD
+6 DO DASH
DO LOCNEW
+7 DO DASH
DO LOCMOD
+8 DO DASH
DO LOCINACT
+9 DO DASH
DO COMMNEW
+10 DO DASH
DO COMMMOD
+11 DO DASH
DO TRIBEMOD^AUM41032
+12 DO DASH
DO EXAMNEW^AUM41032
+13 DO DASH
DO EXAMMOD^AUM41032
+14 DO DASH
DO CLINNEW^AUM41032
+15 DO DASH
DO CLINMOD^AUM41032
+16 DO DASH
DO PCLASNEW^AUM41032
+17 DO DASH
DO PCLASMOD^AUM41032
+18 DO DASH
DO EDUCNEW^AUM41032
+19 DO DASH
DO HFNEW^AUM41032
+20 DO DASH
DO MEASNEW^AUM41032
+21 QUIT
GREET ;----- GREETING/INTRO TEXT
+1 DO RSLT($JUSTIFY("",5)_$PIECE($TEXT(UPDATE^AUM4103A),";",3))
+2 FOR L="GREET","INTROE","INTROI"
Begin DoDot:1
+3 FOR %=1:1
DO RSLT($PIECE($TEXT(@L+%^AUM4103),";",3))
IF $PIECE($TEXT(@L+%+1^AUM4103),";",3)="###"
QUIT
End DoDot:1
+4 QUIT
+5 ;
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 ;
E(L) ;-----
+1 QUIT $PIECE($PIECE($TEXT(@L^AUM4103A),";",3),":",1)
+2 ;
IEN(X,%,Y) ;
+1 ;----- UPDATE AREA, SERVICE UNIT, COUNTY
+2 SET Y=$ORDER(@(X_"""C"",%,0)"))
IF Y
QUIT +Y
+3 IF 'Y
SET Y=$$VAL^AUM4103M(X,%)
+4 IF Y
Begin DoDot:1
+5 NEW %,@($PIECE($TEXT(SVARS),";",3))
+6 SET L=Y
+7 IF X["AREA"
Begin DoDot:2
+8 NEW X
+9 DO RSLT("(Add Missing Area)")
+10 DO ADDAREA
+11 DO RSLT("(END Add Missing Area)")
End DoDot:2
QUIT
+12 IF X["SU"
Begin DoDot:2
+13 NEW X
+14 DO RSLT("(Add Missing SU)")
+15 DO ADDSU
+16 DO RSLT("(END Add Missing SU)")
End DoDot:2
QUIT
+17 IF X["CTY"
Begin DoDot:2
+18 NEW X
+19 DO RSLT("(Add Missing County)")
+20 DO ADDCNTY
+21 DO RSLT("(END Add Missing County)")
End DoDot:2
QUIT
End DoDot:1
IF Y<0
SET Y=""
+22 ;
+23 IF 'Y
DO RSLT($JUSTIFY("",5)_$$M(0)_$PIECE(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
+24 QUIT +Y
+25 ;
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(%) ; EP- INCREMENTS/UPDATES ^TMP("AUM4103,$J) called here and AUM4103
+1 ; global used to generate the email message sent by
+2 ; post-install routine
+3 SET ^(0)=$GET(^TMP("AUM4103",$JOB,0))+1
SET ^(^(0))=%
DO MES(%)
+4 QUIT
+5 ;
MES(%) ;--- ISSUE MESSAGES DURING INSTALL
+1 NEW @($PIECE($TEXT(SVARS),";",3))
+2 DO MES^XPDUTL(%)
+3 QUIT
+4 ;
IXDIC(DIC,DIC0,D,X,DLAYGO) ;
+1 ;--- CALL TO FILEMAN IX^DIC
+2 NEW @($PIECE($TEXT(SVARS),";",3))
+3 SET DIC(0)=DIC0
+4 KILL DIC0
+5 IF '$GET(DLAYGO)
KILL DLAYGO
+6 DO IX^DIC
+7 QUIT Y
+8 ;
AREANEW ;
+1 SET E="New Area Codes"
+2 FOR T=1:1
SET L=$TEXT(AREANEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDAREA
+3 QUIT
+4 ;
ADDAREA ;--- NEW AREA
+1 ; PROGRAMMER NOTE: This s/r is required for every patch.
+2 SET L=$PIECE(L,";;",2)
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
+3 IF $DATA(^AUTTAREA("B",N))
DO RSLT($JUSTIFY("",5)_$$M(1)_"NAME EXISTS => "_N)
QUIT
+4 IF $DATA(^AUTTAREA("C",A))
DO RSLT($JUSTIFY("",5)_$$M(1)_"CODE EXISTS => "_A)
QUIT
+5 SET DLAYGO=9999999.21
+6 SET DIC="^AUTTAREA("
+7 SET X=N
+8 SET DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
+9 DO FILE
+10 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+11 QUIT
+12 ;
ADDCNTY ;--- NEW COUNTY
+1 ; PROGRAMMER NOTE: This s/r is required for every patch.
+2 SET L=$PIECE(L,";;",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))
DO RSLT($JUSTIFY("",5)_$$M(1)_"CODE EXISTS => "_S_C)
QUIT
+4 SET P("S")=$$IEN("^DIC(5,",S)
+5 IF 'P("S")
QUIT
+6 SET DIC="^AUTTCTY("
+7 SET X=N
+8 SET DIC("DR")=".02////"_P("S")_";.03///"_C_";.06///"_A
+9 DO FILE
+10 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+11 QUIT
+12 ;
ADDSU ;
+1 ; PROGRAMMER NOTE: This s/r is required for every patch.
+2 SET L=$PIECE(L,";;",2)
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
+3 IF $DATA(^AUTTSU("C",A_S))
DO RSLT($JUSTIFY("",5)_$$M(1)_"ASU EXISTS => "_A_S)
QUIT
+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
+13 ;
SUNEW ;--- ADD NEW SU
+1 DO RSLT($$E("SUNEW"))
+2 DO RSLT($JUSTIFY("",13)_$$LJ^XLFSTR("AREA",6)_$$LJ^XLFSTR("S.U.",6)_"NAME")
+3 DO RSLT($JUSTIFY("",13)_$$LJ^XLFSTR("----",6)_$$LJ^XLFSTR("----",6)_"----")
+4 FOR T=1:1
SET L=$TEXT(SUNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDSU
+5 QUIT
+6 ;
SUMOD ;--- MOD SU
+1 DO RSLT($$E("SUMOD"))
+2 DO RSLT($JUSTIFY("",15)_"AA SU NAME")
+3 DO RSLT($JUSTIFY("",15)_"-- -- ----")
+4 FOR T=1:2
SET L=$TEXT(SUMOD+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(SUMOD+T+1^AUM4103A)
Begin DoDot:1
+5 SET L=$PIECE(L,U,2,99)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
+6 SET P=$ORDER(^AUTTSU("C",A_S,0))
+7 SET L=$PIECE(L("TO"),U,2,99)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
+8 IF 'P
SET P=$ORDER(^AUTTSU("C",A_S,0))
IF 'P
SET L=";;"_L
DO ADDSU
QUIT
+9 SET L=A_" "_S_" "_N
+10 SET P("A")=$$IEN("^AUTTAREA(",A)
+11 IF 'P("A")
QUIT
+12 SET DIE="^AUTTSU("
SET DA=P
SET DR=".01///"_N_";.02////"_P("A")_";.03///"_S
+13 DO DIE
+14 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$E(0)_" : EDIT SERVICE UNIT FAILED => "_L)
QUIT
+15 DO MODOK
End DoDot:1
+16 QUIT
+17 ;
LOCNEW ;--- ADD NEW LOCATION
+1 DO RSLT($$E("LOCNEW"))
+2 DO RSLT($$RJ^XLFSTR("AA SU FA NAME",26)_$$RJ^XLFSTR("PSEUDO",34))
+3 DO RSLT($$RJ^XLFSTR("-- -- -- ----",26)_$$RJ^XLFSTR("------",34))
+4 FOR T=1:1
SET L=$TEXT(LOCNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDLOC
+5 QUIT
ADDLOC ;
+1 SET L=$PIECE(L,";;",2)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET P=$PIECE(L,U,5)
+2 SET L=A_" "_S_" "_F_" "_N_$JUSTIFY("",32-$LENGTH(N))_P
+3 SET %=A_S_F
SET %=$ORDER(^AUTTLOC("C",%,0))
+4 IF %
DO RSLT($JUSTIFY("",5)_$$M(1)_"ASUFAC EXISTS => "_A_S_F)
Begin DoDot:1
+5 IF $PIECE($GET(^AUTTLOC(%,0)),U,21)
SET DIE="^AUTTLOC("
SET DA=%
SET DR=".27///@;.28////"_DT
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"DELETE INACTIVE DATE FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"INACTIVE DATE DELETED => "_L)
+6 SET %=$ORDER(^AUTTLOC("C",A_S_F,0))
SET %=$PIECE(^AUTTLOC(%,0),U)
+7 IF %
IF $DATA(^DIC(4,%,0))
IF N'=$PIECE(^DIC(4,%,0),U)
SET DIE="^DIC(4,"
SET DA=%
SET DR=".01///"_N
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"INSTITUTION NAME UPDATED => "_L)
+8 SET %=$ORDER(^AUTTLOC("C",A_S_F,0))
+9 IF P'=$PIECE($GET(^AUTTLOC(%,1)),U,2)
SET DIE="^AUTTLOC("
SET DA=%
SET DR=".28////"_DT_";.31///"_P
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT PSEUDO PREFIX FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"PSEUDO PREFIX UPDATED => "_L)
+10 QUIT
End DoDot:1
QUIT
+11 SET P("A")=$$IEN("^AUTTAREA(",A)
+12 IF 'P("A")
QUIT
+13 SET P("S")=$$IEN("^AUTTSU(",A_S)
+14 IF 'P("S")
QUIT
+15 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
+16 IF DINUM>99999
QUIT
+17 SET DLAYGO=4
SET DIC="^DIC(4,"
SET X=N
+18 DO FILE
+19 KILL DINUM,DLAYGO
+20 IF Y<0
DO RSLT($JUSTIFY("",5)_$$M(0)_"^DIC(4 ADD FAILED => "_L)
QUIT
+21 NEW AUMAD
+22 SET AUMAD=0
+23 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
+24 ; If AD xref on 4 is active, edit LOCATION and Quit.
+25 IF AUMAD
Begin DoDot:1
+26 SET DA=+Y
SET DIE="^AUTTLOC("
SET DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P
+27 DO DIE
+28 IF '$DATA(Y)
DO ADDOK
QUIT
+29 DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L)
+30 QUIT
End DoDot:1
QUIT
+31 SET DINUM=+Y
SET DLAYGO=9999999.06
SET DIC="^AUTTLOC("
SET X=DINUM
SET DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P
+32 DO FILE
DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+33 KILL DINUM,DLAYGO
+34 QUIT
+35 ;
LOCMOD ;--- MOD LOCATION
+1 DO RSLT($$E("LOCMOD"))
+2 DO RSLT($$RJ^XLFSTR("AA SU FA NAME",28)_$$RJ^XLFSTR("PSEUDO",34))
+3 DO RSLT($$RJ^XLFSTR("-- -- -- ----",28)_$$RJ^XLFSTR("------",34))
+4 FOR T=1:2
SET L=$TEXT(LOCMOD+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(LOCMOD+T+1^AUM4103A)
Begin DoDot:1
+5 SET L=$PIECE(L,U,2,99)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
+6 SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
+7 SET L=$PIECE(L("TO"),U,2,99)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
+8 IF 'P
SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
IF 'P
SET L=";;"_L
DO ADDLOC
QUIT
+9 SET L=A_" "_S_" "_F_" "_N_$JUSTIFY("",32-$LENGTH(N))_$PIECE(L("TO"),U,6)
+10 SET P("A")=$$IEN("^AUTTAREA(",A)
+11 IF 'P("A")
QUIT
+12 SET P("S")=$$IEN("^AUTTSU(",A_S)
+13 IF 'P("S")
QUIT
+14 SET DIE="^AUTTLOC("
SET DA=P
SET DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_$PIECE(L("TO"),U,6)
+15 DO DIE
+16 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L)
QUIT
+17 SET DIE="^DIC(4,"
SET DA=$PIECE(^AUTTLOC(P,0),U)
SET DR=".01///"_N
+18 DO DIE
+19 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L)
QUIT
+20 DO MODOK
+21 QUIT
End DoDot:1
+22 ;
+23 DO DASH
+24 DO RSLT("Checking Location Code changes to determine export status.")
+25 DO RSLT("Patient data is not exported if the only change is to the Location NAME.")
+26 DO RSLT("Location Code changes must be rolled up into the national data repository...")
+27 DO DASH
DO RSLT($$LOCMOD^AUMXPORT("AUM4103A")_" patients marked for export because of the Location Code changes.")
+28 QUIT
+29 ;
LOCINACT ;--- INACTIVATE LOCATION
+1 DO RSLT("Inactivated Location Codes")
+2 FOR T=1:1
SET L=$TEXT(LOCINACT+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
Begin DoDot:1
+3 SET L=$PIECE(L,";;",2)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET P=$PIECE(L,U,5)
+4 SET L=A_" "_S_" "_F_" "_N_" "_P
+5 SET %=A_S_F
SET %=$ORDER(^AUTTLOC("C",%,0))
+6 IF '%
DO RSLT($JUSTIFY("",5)_"ASUFAC "_A_S_F_" not found (OK).")
QUIT
+7 SET DIE="^AUTTLOC("
SET DA=%
SET DR=".27////"_DT
+8 DO DIE
+9 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$E(0)_"EDIT INACTIVE DATE FAILED => "_L)
IF 1
+10 IF '$TEST
DO RSLT($JUSTIFY("",5)_"INACTIVATED => "_L)
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
COMMNEW ;--- ADD COMMUNITY
+1 DO RSLT($$E("COMMNEW"))
+2 DO RSLT($$RJ^XLFSTR("ST CT COM NAME",27)_$$RJ^XLFSTR("AA SU",33))
+3 DO RSLT($$RJ^XLFSTR("-- -- --- ----",27)_$$RJ^XLFSTR("-- --",33))
+4 FOR T=1:1
SET L=$TEXT(COMMNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDCOMM
+5 QUIT
ADDCOMM ;
+1 SET L=$PIECE(L,";;",2)
SET S=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET A=$PIECE(L,U,5)
SET V=$PIECE(L,U,6)
SET L=S_" "_O_" "_C_" "_N_$JUSTIFY("",32-$LENGTH(N))_A_" "_V
+2 IF $DATA(^AUTTCOM("C",S_O_C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"STCTYCOM CODE EXISTS => "_S_O_C)
QUIT
+3 SET P("O")=$$IEN("^AUTTCTY(",S_O)
+4 IF 'P("O")
QUIT
+5 SET P("A")=$$IEN("^AUTTAREA(",A)
+6 IF 'P("A")
QUIT
+7 SET P("V")=$$IEN("^AUTTSU(",A_V)
+8 IF 'P("V")
QUIT
+9 SET DLAYGO=9999999.05
SET DIC="^AUTTCOM("
SET X=N
SET DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
+10 DO FILE
+11 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+12 QUIT
+13 ;
COMMMOD ;--- MOD COMMUNITY
+1 DO RSLT($$E("COMMMOD"))
+2 DO RSLT($JUSTIFY("",15)_"ST CT COM NAME"_$JUSTIFY("",28)_"AA SU")
+3 DO RSLT($JUSTIFY("",15)_"-- -- --- ----"_$JUSTIFY("",28)_"-- --")
+4 FOR T=1:2
SET L=$TEXT(COMMMOD+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(COMMMOD+T+1^AUM4103A)
Begin DoDot:1
+5 SET L=$PIECE(L,U,2,99)
SET S=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
+6 SET P=$ORDER(^AUTTCOM("C",S_O_C,0))
+7 SET L=$PIECE(L("TO"),U,2,99)
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)
+8 IF 'P
SET P=$ORDER(^AUTTCOM("C",S_O_C,0))
IF 'P
SET L=";;"_L
DO ADDCOMM
QUIT
+9 SET L=S_" "_O_" "_C_" "_N_$JUSTIFY("",32-$LENGTH(N))_A_" "_V
+10 SET P("O")=$$IEN("^AUTTCTY(",S_O)
+11 IF 'P("O")
QUIT
+12 SET P("A")=$$IEN("^AUTTAREA(",A)
+13 IF 'P("A")
QUIT
+14 SET P("V")=$$IEN("^AUTTSU(",A_V)
+15 IF 'P("V")
QUIT
+16 SET DIE="^AUTTCOM("
SET DA=P
SET DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
+17 DO DIE
+18 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"CHANGE FAILED => "_L)
QUIT
+19 DO MODOK
+20 QUIT
End DoDot:1
+21 DO DASH
+22 DO RSLT("Checking Community Code changes to determine export status.")
+23 DO RSLT("Patient data is not exported if the only change is to the Commnuity NAME.")
+24 DO RSLT("Commnity Code changes must be rolled up into the national data repository...")
+25 DO DASH
DO RSLT($$COMMMOD^AUMXPORT("AUM4103A")_" patients marked for export because of the Community Code changes.")
+26 QUIT
+27 ;
CLINNEW ;--- ADD NEW CLINIC
+1 DO RSLT($$E("CLINNEW"))
+2 DO RSLT($JUSTIFY("",11)_"CODE NAME"_$JUSTIFY("",28)_"ABRV. PRI.CARE 1A WL RPT")
+3 DO RSLT($JUSTIFY("",11)_"---- ----"_$JUSTIFY("",28)_"----- -------- ---------")
+4 FOR T=1:1
SET L=$TEXT(CLINNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDCLIN
+5 KILL DLAYGO
+6 QUIT
+7 ;
ADDCLIN ;
+1 SET L=$PIECE(L,";;",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
+2 IF $DATA(^DIC(40.7,"C",C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"CLINIC CODE EXISTS => "_C)
DO RSLT("")
QUIT
+3 SET DLAYGO=40.7
SET DIC="^DIC(40.7,"
SET X=N
SET DIC("DR")="1///"_C_";999999901///"_A_";90000.01///"_R
+4 IF $LENGTH(P)
SET DIC("DR")=DIC("DR")_";999999902///"_P
+5 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+6 QUIT
+7 ;
CLINMOD ;
+1 SET E="Clinic Name Changes"
+2 FOR T=1:2
SET L=$TEXT(CLINMOD+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
Begin DoDot:1
+3 SET L("TO")=$TEXT(CLINMOD+T+1^AUM4103A)
+4 SET L=$PIECE(L("TO"),"^",2,99)
SET C=$PIECE(L,"^",1)
SET N=$PIECE(L,"^",2)
+5 SET DA=$ORDER(^DIC(40.7,"C",C,0))
+6 IF 'DA
SET L=";;"_L
DO ADDCLIN
QUIT
+7 SET DIE="^DIC(40.7,"
SET DR=".01///"_N
DO ^DIE
+8 IF $DATA(Y)
DO RSLT(E_" : CHANGE FAILED => "_L)
QUIT
+9 DO MODOK
End DoDot:1
+10 QUIT
+11 ;
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V,W;Single-character work variables
+1 QUIT
