Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AUM41031

AUM41031.m

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