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

AUM94031.m

Go to the documentation of this file. 
  1. AUM94031 ; DSD/GTH - STANDARD TABLE UPDATES (1), 31MAR94 BANYAN ; [ 04/07/94  10:18 AM ]
  1.  ;;94.1;TABLE MAINTENANCE;**3**;DECEMBER 15, 1993
  1.  Q
  1.  ;
  1. START ;EP
  1.  NEW A,C,DIC,DIE,DLAYGO,DR,E,L,N,O,P,R,S,T
  1.  S E(0)="ERROR : ",E(1)="NOT ADDED : "
  1.  D SUNEW,LOCNEW,LOCMOD
  1.  Q
  1.  ;
  1. ADDOK D RSLT(E_", Added : "_L) Q
  1. ADDFAIL D RSLT(E(0)_E_" : ADD FAILED => "_L) Q
  1. DIE NEW A,C,E,L,N,O,P,R,S,T
  1.  LOCK +(@(DIE_DA_")")):10 E  D RSLT(E(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.") S Y=1 Q
  1.  D ^DIE LOCK -(@(DIE_DA_")")) K DA,DIE,DR Q
  1. IEN(X,%,Y) ;EP
  1.  S Y=$O(@(X_"""C"",%,0)"))
  1.  I 'Y S Y=$T(@%^AUM9403M) I Y NEW Z S Z=E D  S:Y<0 Y="" S E=Z
  1.  . NEW A,C,L,N,O,P,R,S,V,%
  1.  . S L=Y
  1.  . I X["AREA" NEW X S E=E_" (Add Area) " D ADDAREA Q
  1.  . I X["SU" NEW X S E=E_" (Add SU) " D ADDSU Q
  1.  . I X["CTY" NEW X S E=E_" (Add County) " D ADDCNTY Q
  1.  .Q
  1.  D:'Y RSLT(E(0)_E_" : "_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
  1.  Q +Y
  1. FILE NEW A,C,E,L,N,O,P,R,S,T K DD,DO S DIC(0)="L" D FILE^DICN K DIC Q
  1. MODOK D RSLT(E_", Changed : "_L) Q
  1. RSLT(%) S ^(0)=$G(^TMP($J,"RSLT",0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
  1.  ;
  1. AREANEW ;
  1.  S E="New Area Codes"
  1.  F T=1:1 S L=$T(AREANEW+T^AUM9403A) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D ADDAREA
  1.  Q
  1.  ;
  1. ADDAREA ;
  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=A_"  "_N_"  "_R_"  "_C
  1.  I $D(^AUTTAREA("B",N)) D RSLT(E(1)_E_" : NAME EXISTS => "_N) Q
  1.  I $D(^AUTTAREA("C",A)) D RSLT(E(1)_E_" : CODE EXISTS => "_A) Q
  1.  S DLAYGO=9999999.21,DIC="^AUTTAREA(",X=N,DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C D FILE
  1.  D ADDFAIL:Y<0,ADDOK:Y>0
  1.  Q
  1.  ;
  1. SUNEW ;
  1.  S E="New Service Unit Codes"
  1.  F T=1:1 S L=$T(SUNEW+T^AUM9403A) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D ADDSU
  1.  Q
  1.  ;
  1. ADDSU ;
  1.  S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3),L=A_"  "_S_"  "_N
  1.  I $D(^AUTTSU("C",A_S)) D RSLT(E(1)_E_" : ASU EXISTS => "_A_S) Q
  1.  S P=$$IEN("^AUTTAREA(",A) Q:'P
  1.  S DLAYGO=9999999.22,DIC="^AUTTSU(",X=N,DIC("DR")=".02////"_P_";.03///"_S D FILE
  1.  D ADDFAIL:Y<0,ADDOK:Y>0
  1.  Q
  1.  ;
  1. LOCNEW ;
  1.  S E="New Location Codes"
  1.  F T=1:1 S L=$T(LOCNEW+T^AUM9403A) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D ADDLOC
  1.  Q
  1.  ;
  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_"  "_P
  1.  S %=A_S_F,%=$O(^AUTTLOC("C",%,0))
  1.  I % D RSLT(E(1)_E_" : ASUFAC EXISTS => "_A_S_F) D  Q
  1.  .I $P($G(^AUTTLOC(%,0)),U,21) S DIE="^AUTTLOC(",DA=%,DR=".27///@" D DIE D:$D(Y) RSLT(E(1)_E_" : DELETE INACTIVE DATE FAILED => "_L) D:'$D(Y) RSLT(E_" : 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(E(0)_E_" : EDIT INSTITUTION FAILED => "_L) D:'$D(Y) RSLT(E_" : 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=".31///"_P D DIE D:$D(Y) RSLT(E(0)_E_" : EDIT PSEUDO PREFIX FAILED => "_L) D:'$D(Y) RSLT(E_" : PSEUDO PREFIX UPDATED => "_L)
  1.  .Q
  1.  S P("A")=$$IEN("^AUTTAREA(",A) Q:'P("A")
  1.  S P("S")=$$IEN("^AUTTSU(",A_S) 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(E(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.") Q
  1.  Q:DINUM>99999
  1.  S DLAYGO=4,DIC="^DIC(4,",X=N D FILE
  1.  I Y<0 D RSLT(E(0)_E_" : ^DIC(4 ADD FAILED => "_L) Q
  1.  S DINUM=+Y,DLAYGO=9999999.06,DIC="^AUTTLOC(",X=DINUM,DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.31///"_P D FILE
  1.  D ADDFAIL:Y<0,ADDOK:Y>0
  1.  Q
  1.  ;
  1. LOCMOD ;
  1.  S E="Location Code Changes"
  1.  F T=1:2 S L=$T(LOCMOD+T^AUM9403A) Q:$P(L,";",3)="END"  S L("TO")=$T(LOCMOD+T+1^AUM9403A) I $P(L("TO"),U,$L(L("TO"),U))="Y" 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_"  "_$P(L("TO"),U,6)
  1.  .S P("A")=$$IEN("^AUTTAREA(",A) Q:'P("A")
  1.  .S P("S")=$$IEN("^AUTTSU(",A_S) Q:'P("S")
  1.  .S DIE="^AUTTLOC(",DA=P,DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.31///"_$P(L("TO"),U,6) D DIE
  1.  .I $D(Y) D RSLT(E(0)_E_" : EDIT LOCATION FAILED => "_L) Q
  1.  .S DIE="^DIC(4,",DA=$P(^AUTTLOC(P,0),U),DR=".01///"_N D DIE
  1.  .I $D(Y) D RSLT(E(0)_E_" : EDIT INSTITUTION FAILED => "_L) Q
  1.  .D MODOK
  1.  .Q
  1.  Q
  1.  ;
  1. CNTYNEW ;
  1.  Q
  1.  ;
  1. ADDCNTY ;
  1.  S L=$P(L,";;",2),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3),L=S_"  "_C_"  "_N
  1.  S P("S")=$$IEN("^DIC(5,",S) Q:'P("S")
  1.  S DIC="^AUTTCTY(",X=N,DIC("DR")=".02////"_P("S")_";.03///"_C D FILE
  1.  D ADDFAIL:Y<0,ADDOK:Y>0
  1.  Q
  1.  ;
  1. CNTYMOD ;
  1.  S E="County Code Changes"
  1.  F T=1:2 S L=$T(CNTYMOD+T^AUM9403A) Q:$P(L,";",3)="END"  S L("TO")=$T(CNTYMOD+T+1^AUM9403A) I $P(L("TO"),U,$L(L("TO"),U))="Y" D
  1.  .S L=$P(L,U,2,99),S=$P(L,U),C=$P(L,U,2)
  1.  .S P=$O(^AUTTCTY("C",S_C,0))
  1.  .S L=$P(L("TO"),U,2,99),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3)
  1.  .I 'P S P=$O(^AUTTCTY("C",S_C,0)) I 'P S L=";;"_L D ADDCNTY Q
  1.  .S L=S_"  "_C_"  "_N
  1.  .S P("S")=$$IEN("^DIC(5,",S) Q:'P("S")
  1.  .S DIE="^AUTTCTY(",DA=P,DR=".01///"_N_";.02////"_P("S")_";.03///"_C D DIE
  1.  .I $D(Y) D RSLT(E(0)_E_" : EDIT COUNTY FAILED => "_L) Q
  1.  .D MODOK
  1.  .Q
  1.  Q