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

AUM94034.m

Go to the documentation of this file. 
  1. AUM94034 ; DSD/GTH - STANDARD TABLE UPDATES (4), 31MAR94 BANYAN ; [ 04/08/94  1:06 PM ]
  1.  ;;94.1;TABLE MAINTENANCE;**3**;DECEMBER 15, 1993
  1.  ;
  1.  Q
  1.  ;
  1. START ;EP
  1.  ;
  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 CHAADD,RCDNEW,RCDADD,RCDDEL,ICD0ACT,ICD0INAC
  1.  Q
  1.  ; ===   utility sub-routines   ====
  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. DIK NEW A,C,E,L,N,O,P,R,S,T D ^DIK K DIK Q
  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.  ; =================================
  1.  ;
  1. CHANEW ;
  1.  S E="New CHA ICD Recode Table"
  1.  F T=1:1 S L=$T(CHANEW+T^AUM9403D) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D ADDCHA
  1.  Q
  1.  ;
  1. ADDCHA ;
  1.  S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N
  1.  I $D(^AUTTCHA("B",C)) D RSLT(E(1)_E_" : CHA ICD RECODE EXISTS => "_C) Q
  1.  S DLAYGO=9999999.74,DIC="^AUTTCHA(",X=C,DIC("DR")=".03///"_N D FILE
  1.  D ADDFAIL:Y<0,ADDOK:Y>0
  1.  I Y>0,'$D(^AUTTCHA(+Y,11)) S ^(11,0)="^9999999.7411^^"
  1.  Q
  1.  ;
  1. CHAADD ;
  1.  S E="CHA ICD Recode, add range"
  1.  F T=1:1 S L=$T(CHAADD+T^AUM9403D) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D
  1.  .S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),O=$P(L,U,3),S=$P(L,U,4)
  1.  .S P=$O(^AUTTCHA("B",C,0))
  1.  .I 'P S L=";;"_L D ADDCHA Q:Y<0
  1.  .S L=C_" "_N_"  "_O_"  "_S
  1.  .I $O(^AUTTCHA(P,11,"B",$E(O,1,30),0)),$O(^AUTTCHA(P,11,"B",$E(O,1,30),0))=$O(^AUTTCHA("AH",S_" ",P,0)) D RSLT(E_" : RANGE EXISTS => "_L) Q
  1.  .S DIC="^AUTTCHA("_P_",11,",X=O,DA(1)=P D FILE
  1.  .I Y<0 D RSLT(E(0)_E_" : ADD RANGE FAILED => "_L) Q
  1.  .S DIE="^AUTTCHA("_P_",11,",DA(1)=P,DA=+Y,P(1)=DA,DR=".02///"_S D DIE
  1.  .I $D(Y) D RSLT(E(0)_E_" : ADD RANGE FAILED => "_L) S DA(1)=P,DA=P(1),DIK="^AUTTCHA("_DA(1)_",11," D DIK Q
  1.  .D RSLT(E_" : Added => "_L)
  1.  .Q
  1.  Q
  1.  ;
  1. RCDNEW ;
  1.  S E="New Recode ICD/APC"
  1.  F T=1:1 S L=$T(RCDNEW+T^AUM9403D) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D ADDRCD
  1.  Q
  1.  ;
  1. ADDRCD ;
  1.  S L=$P(L,";;",2),C=$P(L,U),R=$P(L,U,2),N=$P(L,U,3),L=C_" "_R_"  "_N
  1.  I $D(^AUTTRCD("B",C)) D RSLT(E(1)_E_" : RECODE ICD/APC EXISTS => "_C) Q
  1.  S DLAYGO=9999999.08,DIC="^AUTTRCD(",X=C,DIC("DR")=".02///"_R_";.03///"_N D FILE
  1.  D ADDFAIL:Y<0,ADDOK:Y>0
  1.  I Y>0,'$D(^AUTTRCD(+Y,11)) S ^(11,0)="^9999999.81101^^"
  1.  Q
  1.  ;
  1. RCDADD ;
  1.  S E="Recode ICD/APC, add range"
  1.  F T=1:1 S L=$T(RCDADD+T^AUM9403D) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D
  1.  .S L=$P(L,";;",2),C=$P(L,U),R=$P(L,U,2),N=$P(L,U,3),O=$P(L,U,4),S=$P(L,U,5)
  1.  .S P=$O(^AUTTRCD("B",C,0))
  1.  .I 'P S L=";;"_L D ADDRCD Q:Y<0
  1.  .S L=C_" "_R_"  "_N_"  "_O_"  "_S
  1.  .I $O(^AUTTRCD(P,11,"B",$E(O,1,30),0)),$O(^AUTTRCD(P,11,"B",$E(O,1,30),0))=$O(^AUTTRCD("AH",S_" ",P,0)) D RSLT(E_" : RANGE EXISTS => "_L) Q
  1.  .I '$D(^AUTTRCD(P,11)) S ^(11,0)="^9999999.81101^^"
  1.  .S DIC="^AUTTRCD("_P_",11,",X=O,DA(1)=P D FILE
  1.  .I Y<0 D RSLT(E(0)_E_" : ADD RANGE FAILED => "_L) Q
  1.  .S DIE="^AUTTRCD("_P_",11,",DA(1)=P,DA=+Y,P(1)=DA,DR=".02///"_S D DIE
  1.  .I $D(Y) D RSLT(E(0)_E_" : ADD RANGE FAILED => "_L) S DA(1)=P,DA=P(1),DIK="^AUTTRCD("_DA(1)_",11," D DIK Q
  1.  .D RSLT(E_" : Added => "_L)
  1.  .Q
  1.  Q
  1.  ;
  1. RCDDEL ;
  1.  S E="Recode ICD/APC, delete range"
  1.  F T=1:1 S L=$T(RCDDEL+T^AUM9403D) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D
  1.  .S L=$P(L,";;",2),C=$P(L,U),R=$P(L,U,2),N=$P(L,U,3),O=$P(L,U,4),S=$P(L,U,5),L=C_" "_R_"  "_N_"  "_O_"  "_S
  1.  .S P=$O(^AUTTRCD("B",C,0))
  1.  .I 'P D RSLT(E_" : Code does not exist => "_L) Q
  1.  .I '$O(^AUTTRCD(P,11,"B",$E(O,1,30),0)) D RSLT(E_" : Range does not exist => "_L) Q
  1.  .I $O(^AUTTRCD(P,11,"B",$E(O,1,30),0))'=$O(^AUTTRCD("AH",S_" ",P,0)) D RSLT(E_" : Range does not exist => "_L) Q
  1.  .S DA(1)=P,DA=$O(^AUTTRCD(P,11,"B",$E(O,1,30),0)),DIK="^AUTTRCD("_DA(1)_",11," D DIK
  1.  .D RSLT(E_" : Deleted => "_L)
  1.  .Q
  1.  Q
  1.  ;
  1. ICD0ACT ;
  1.  S E="ICD0, Activate"
  1.  F T=1:1 S L=$T(ICD0ACT+T^AUM9403D) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D
  1.  .S L=$P(L,";;",2),C=$P(L,U),L=C
  1.  .S P=$O(^ICD0("B",C,0))
  1.  .I 'P S P=$O(^ICD0("AB",C,0))
  1.  .I 'P S P=$O(^ICD0("BA",C_" ",0))
  1.  .I 'P,+C[$P(C,".",1) S P=$O(^ICD0("BA",+C,0))
  1.  .I 'P D RSLT(E_" : Code does not exist => "_L) Q
  1.  .S DIE="^ICD0(",DA=P,DR="100///@;102///@" D DIE
  1.  .I $D(Y) D RSLT(E(0)_E_" : EDIT ICD0 FAILED => "_L) Q
  1.  .D RSLT(E_" : Activated => "_L)
  1.  .Q
  1.  Q
  1.  ;
  1. ICD0INAC ;
  1.  S E="ICD0, IN-Activate"
  1.  F T=1:1 S L=$T(ICD0INAC+T^AUM9403D) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D
  1.  .S L=$P(L,";;",2),C=$P(L,U),O=$P(L,U,2),L=C_"  "_O
  1.  .S P=$O(^ICD0("B",C,0))
  1.  .I 'P S P=$O(^ICD0("AB",C,0))
  1.  .I 'P S P=$O(^ICD0("BA",C_" ",0))
  1.  .I 'P,+C[$P(C,".",1) S P=$O(^ICD0("BA",+C,0))
  1.  .I 'P D RSLT(E_" : Code does not exist => "_L) Q
  1.  .S DIE="^ICD0(",DA=P,DR="100///1;102///"_O D DIE
  1.  .I $D(Y) D RSLT(E(0)_E_" : EDIT ICD0 FAILED => "_L) Q
  1.  .D RSLT(E_" : IN-Activated => "_L)
  1.  .Q
  1.  Q
  1.  ;