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

AUM91102.m

Go to the documentation of this file. 
  1. AUM91102 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999DEC01 ; [ 12/09/1999  10:15 AM ]
  1.  ;;99.1;TABLE MAINTENANCE;**10**;NOV 6,1998
  1.  ;
  1.  Q
  1.  ;
  1. START ;EP
  1.  ;
  1.  NEW A,C,DIC,DIE,DINUM,DLAYGO,DR,E,L,M,N,O,P,R,S,T
  1.  ;
  1.  S E(0)="ERROR : ",E(1)="NOT ADDED : "
  1.  D TRIBNEW,DASH,HFADD,DASH,DXPRMOD,DASH
  1.  Q
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ;
  1. ADDOK D RSLT($J("",5)_"Added : "_L) Q
  1. ADDFAIL D RSLT($J("",5)_E(0)_"ADD FAILED => "_L) Q
  1. DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("") Q
  1. DIE NEW A,C,E,L,M,N,O,P,R,S,T
  1.  LOCK +(@(DIE_DA_")")):10 E  D RSLT($J("",5)_E(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.") S Y=1 Q
  1.  D ^DIE LOCK -(@(DIE_DA_")")) KILL DA,DIE,DR Q
  1. E(L) Q $P($P($T(@L^AUM9110A),";",3),":",1)
  1. IEN(X,%,Y) ;
  1.  S Y=$O(@(X_"""C"",%,0)"))
  1.  I 'Y S Y=$$VAL^AUM9110M(X,%) I Y NEW Z S Z=E D  S:Y<0 Y="" S E=Z
  1.  . NEW A,C,L,M,N,O,P,R,S,V,%
  1.  . S L=Y
  1.  . I X["AREA" NEW X D RSLT("(Add Missing Area)") D ADDAREA D RSLT("(END Add Missing Area)") Q
  1.  . I X["SU" NEW X D RSLT("(Add Missing SU)") D ADDSU D RSLT("(END Add Missing SU)") Q
  1.  . I X["CTY" NEW X D RSLT("(Add Missing County)") D ADDCNTY D RSLT("(END Add Missing County)") Q
  1.  .Q
  1.  D:'Y RSLT($J("",5)_E(0)_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
  1.  Q +Y
  1. DIK NEW A,C,E,L,M,N,O,P,R,S,T D ^DIK KILL DIK Q
  1. FILE NEW A,C,E,L,M,N,O,P,R,S,T K DD,DO S DIC(0)="L" D FILE^DICN KILL DIC Q
  1. MODOK D RSLT($J("",5)_"Changed : "_L) Q
  1. RSLT(%) S ^(0)=$G(^TMP("AUM9110",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
  1. ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ; Return 0th node.  A is file #, rest fields.
  1.  I '$G(A) Q -1
  1.  I '$G(B) Q -1
  1.  F %=67:1:75 Q:'$G(@($C(%)))  S A=+$P(^DD(A,B,0),U,2),B=@($C(%))
  1.  I 'A!('B) Q -1
  1.  I '$D(^DD(A,B,0)) Q -1
  1.  Q U_$P(^DD(A,B,0),U,2)
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ;
  1. ADDAREA ; 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=A_" "_N_" "_R_" "_C
  1.  I $D(^AUTTAREA("B",N)) D RSLT($J("",5)_E(1)_"NAME EXISTS => "_N) Q
  1.  I $D(^AUTTAREA("C",A)) D RSLT($J("",5)_E(1)_"CODE EXISTS => "_A) Q
  1.  S DLAYGO=9999999.21,DIC="^AUTTAREA(",X=N,DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
  1.  D FILE,ADDFAIL:Y<0,ADDOK:Y>0
  1.  KILL DLAYGO
  1.  Q
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ;
  1. ADDCNTY ; 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),L=S_" "_C_" "_N
  1.  I $D(^AUTTCTY("C",S_C)) D RSLT($J("",5)_E(1)_"CODE EXISTS => "_S_C) Q
  1.  S P("S")=$$IEN("^DIC(5,",S)
  1.  Q:'P("S")
  1.  S DIC="^AUTTCTY(",X=N,DIC("DR")=".02////"_P("S")_";.03///"_C
  1.  D FILE,ADDFAIL:Y<0,ADDOK:Y>0
  1.  Q
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ;
  1. ADDSU ; 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=A_" "_S_" "_N
  1.  I $D(^AUTTSU("C",A_S)) D RSLT($J("",5)_E(1)_"ASU EXISTS => "_A_S) Q
  1.  S P=$$IEN("^AUTTAREA(",A)
  1.  Q:'P
  1.  S DLAYGO=9999999.22,DIC="^AUTTSU(",X=N,DIC("DR")=".02////"_P_";.03///"_S
  1.  D FILE,ADDFAIL:Y<0,ADDOK:Y>0
  1.  KILL DLAYGO
  1.  Q
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ;
  1. HFADD ;
  1.  D RSLT($$E("HFADD"))
  1.  F T=1:1 S L=$T(HFADD+T^AUM9110A) Q:$P(L,";",3)="END"  D ADDHF
  1.  KILL DLAYGO
  1.  Q
  1.  ;
  1. ADDHF ;
  1.  S L=$P(L,";;",2),N=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),R=$P(L,U,4),S=$P(L,U,5),L=N_" "_O_"  "_C_"  "_R_"  "_S
  1.  I $D(^AUTTHF("B",N)) D RSLT($J("",5)_E(1)_"HEALTH FACTOR EXISTS => "_N) Q
  1.  S DLAYGO=9999999.64,DIC="^AUTTHF(",X=N,DIC("DR")=".02///"_O_";.03///"_C_";.08///"_R_";.1///"_S
  1.  D FILE,ADDFAIL:Y<0,ADDOK:Y>0
  1.  Q
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ;
  1. TRIBNEW ;
  1.  S E=$$E("TRIBNEW")
  1.  D RSLT(E)
  1.  D RSLT($J("",13)_"CCC NAME")
  1.  D RSLT($J("",13)_"--- ----")
  1.  F T=1:1 S L=$T(TRIBNEW+T^AUM9110A) Q:$P(L,";",3)="END"  D ADDTRIB
  1.  Q
  1.  ;
  1. ADDTRIB ;
  1.  S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N
  1.  I $D(^AUTTTRI("C",C)) D RSLT($J("",5)_E(1)_"TRIBE CODE EXISTS => "_C) Q
  1.  S DLAYGO=9999999.03,DIC="^AUTTTRI(",X=N,DIC("DR")=".02///"_C
  1.  D FILE,ADDFAIL:Y<0,ADDOK:Y>0
  1.  Q
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ;
  1. ADDDXPR ;
  1.  S L=$P(L,";;",2),R=$P(L,U),M=$P(L,U,2),N=$P(L,U,3),S=$P(L,U,4),C=$P(L,U,5),O=$P(L,U,6),L=R_"..."_M_"..."
  1.  I $D(^AUTTDXPR("B",R)) D RSLT($J("",5)_E(1)_"DIAGNOSTIC PROCEDURE RESULT EXISTS => "_R) Q
  1.  S DLAYGO=9999999.68,DIC="^AUTTDXPR(",X=R,DIC("DR")=".02///"_M_";.07///"_S_";3///"_O
  1.  ;
  1.  ; The Input Transform for the .01 field requires a variable from the
  1.  ; Medicine Package be SET.  I'll fix the dd next year.
  1.  ; gth 12/08/99
  1.  S (DINUM,MCQSDXPR)=691.500002
  1.  D FILE,ADDFAIL:Y<0,ADDOK:Y>0
  1.  KILL MCQSDXPR,DINUM
  1.  Q:Y<0
  1.  ;
  1.  ; Field .03 must be direct SET since value contains ";" and
  1.  ; disrupts the parsing of DR by FileMan.  gth 12/08/99
  1.  S $P(^AUTTDXPR(+Y,0),U,3)=N
  1.  ;
  1.  ; edit WP field DESCRIPTION.
  1.  S DIE="^AUTTDXPR(",DA=+Y,DR="2///"_C,DR(1,9999999.68)="2;",DR(2,9999999.682)=".01"
  1.  D DIE
  1.  I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT DESCRIPTION FAILED => "_L) Q
  1.  D DISDXPR
  1.  KILL DLAYGO
  1.  Q
  1.  ;
  1. DXPRMOD ;
  1.  S E=$$E("DXPRMOD")
  1.  D RSLT(E)
  1.  F T=1:2 S L=$T(DXPRMOD+T^AUM9110A) Q:$P(L,";",3)="END"  S L("TO")=$T(DXPRMOD+T+1^AUM9110A) D
  1.  . S L=$P(L,U,2,99),R=$P(L,U)
  1.  . S P=$O(^AUTTDXPR("B",R,0))
  1.  . S L=$P(L("TO"),U,2,99),R=$P(L,U),M=$P(L,U,2),N=$P(L,U,3),S=$P(L,U,4),C=$P(L,U,5),O=$P(L,U,6)
  1.  . I 'P S L=";;"_L D ADDDXPR Q
  1.  . S L=R_"..."_M_"..."
  1.  . S DIE="^AUTTDXPR(",DA=P,DR=".02///"_M_";.07///"_S_";3///"_O
  1.  . D DIE
  1.  . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT FAILED => "_L) Q
  1.  . ; Field .03 must be direct SET since value contains ";" and
  1.  . ; disrupts the parsing of DR by FileMan.  gth 12/08/99
  1.  . S $P(^AUTTDXPR(P,0),U,3)=N
  1.  . ; edit WP field DESCRIPTION.
  1.  . S DIE="^AUTTDXPR(",DA=P,DR="2///"_C,DR(1,9999999.68)="2;",DR(2,9999999.682)=".01"
  1.  . D DIE
  1.  . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT DESCRIPTION FAILED => "_L) Q
  1.  . D MODOK,DISDXPR
  1.  .Q
  1.  Q
  1.  ;
  1. DISDXPR ;
  1.  D RSLT("         RESULT: "_R),RSLT("      DATA TYPE: "_M),RSLT("         PARAMS: "_N),RSLT("AQ INDEX ACTIVE: "_S),RSLT("    DESCRIPTION: "_C),RSLT("   HELP MESSAGE: "_O)
  1.  Q
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ;