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

DVBAPADD.m

Go to the documentation of this file.
  1. DVBAPADD ;ALB/JLU;adds new disability codes to file 31
  1. ;;2.7;AMIE;;Apr 10, 1995
  1. EN ;start of routine
  1. I +$$VERSION^DVBAPST1>2.59 DO Q
  1. .S VAR=" - Version 2.6 of AMIE has already been loaded."
  1. .D BUMPBLK^DVBAPOST
  1. .D BUMPBLK^DVBAPOST
  1. .D BUMP^DVBAPOST(VAR)
  1. .W !!,VAR
  1. .S VAR="There is no need to update the Disability Condition file."
  1. .D BUMP^DVBAPOST(VAR)
  1. .W !,VAR,!
  1. .D BUMPBLK^DVBAPOST
  1. .Q
  1. S JCNT=0
  1. N LP,LP1
  1. S VAR="Adding to the Disability Condition file."
  1. W !!,VAR,!
  1. D BUMPBLK^DVBAPOST
  1. D BUMPBLK^DVBAPOST
  1. D BUMP^DVBAPOST(VAR)
  1. D BUMPBLK^DVBAPOST
  1. F LP=1:1 S LP1=$T(TXT+LP) Q:LP1="" DO
  1. .S DCODE=$P(LP1,";;",2)
  1. .S DTEXT=$P(DCODE,";",2)
  1. .S DCODE=$P(DCODE,";",1)
  1. .I $L(DTEXT)>45 S DTEXT=$E(DTEXT,1,45)
  1. .K JSTOP
  1. .D CHK
  1. .I $D(JSTOP) Q
  1. .S DIC="^DIC(31,",DIC("DR")="2///"_DCODE,X=DTEXT,DLAYGO=31,DIC(0)="L"
  1. .K DD,DO
  1. .D FILE^DICN
  1. .K DO,DD,DLAYGO
  1. .I +Y>0 S JCNT=JCNT+1 W "."
  1. .I +Y<0 D ERR
  1. .Q
  1. S VAR="Additions to the Disability Condition file (31) has finished. "_JCNT_" were added."
  1. W !!,VAR
  1. D BUMPBLK^DVBAPOST
  1. D BUMPBLK^DVBAPOST
  1. D BUMP^DVBAPOST(VAR)
  1. K DIC,JSTOP,JCNT,DLAYGO,X,DCODE,DTEXT
  1. Q
  1. ;
  1. CHK ;checks for the existance of the codes in the c cross ref.
  1. I $D(^DIC(31,"C",DCODE)) S JSTOP=1
  1. I $D(^DIC(31,"B",$E(DTEXT,1,30))) S JSTOP=1
  1. I $D(JSTOP) DO
  1. .S VAR="Disability Condition "_DCODE_" was not added. Entry already exists."
  1. .W !,VAR
  1. .D BUMPBLK^DVBAPOST
  1. .D BUMP^DVBAPOST(VAR)
  1. .Q
  1. Q
  1. ;
  1. ERR ;not added
  1. S VAR="Not able to add Disability Condition "_DCODE_". Consult the Install Guide."
  1. W !,VAR
  1. D BUMPBLK^DVBAPOST
  1. D BUMP^DVBAPOST(VAR)
  1. Q
  1. ;
  1. TXT ;new exams to be added.
  1. ;;7532;RENAL TUBULAR DISORDERS
  1. ;;7533;CYSTIC DISEASES OF THE KIDNEYS
  1. ;;7534;ATHEROSCLEROTIC RENAL DISEASE
  1. ;;7535;TOXIC NEUROPATHY
  1. ;;7536;GLOMERULONEPHRITIS
  1. ;;7537;INTERSTITIAL NEPHRITIS
  1. ;;7538;PAPILLARY NECROSIS
  1. ;;7539;RENAL AMYLOID DISEASE
  1. ;;7540;DISSEMINATED INTRAVASCULAR COAGULATION WITH RENAL CORTICAL NECROSIS
  1. ;;7541;RENAL INVOLVEMENT IN DIABETES, SICKLE CELL ANEMIA, SYSTEMIC LUPUS ERYTHEMATOSUS, VASCULITIS OR OTHER SYSTEMIC DISEASE PROCESES
  1. ;;7542;NEUROGENIC BLADDER
  1. ;;9914;MAXILLA, LOSS OF MORE THAN HALF
  1. ;;9915;MAXILLA, LOSS OF HALF OR LESS
  1. ;;9916;MAXILLA, MALUNION OR NONUNION