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

EC2P150B.m

Go to the documentation of this file. 
  1. EC2P150B ;ALB/TXH - EC National Procedure Update; Apr 27, 2020@14:13
  1.  ;;2.0;EVENT CAPTURE;**150**;May 8, 1996;Build 5
  1.  ;
  1.  ;This routine is used as a post-init in a KIDS build
  1.  ;to add new procedure codes and change procedure names  
  1.  ;in the EC National Procedure file (#725).
  1.  ;
  1.  Q
  1.  ;
  1. ADDPROC ;* add national procedures
  1.  ;
  1.  ;  ECXX is in format:
  1.  ;   NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
  1.  ;   LAST NATIONAL NUMBER SEQUENCE
  1.  ;
  1.  N ECX,ECXX,ECDINUM,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
  1.  N ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN,ECCNT1,ECCNT11
  1.  ;
  1.  D MES^XPDUTL("*** Adding new procedures to the EC NATIONAL PROCEDURE File (#725)...")
  1.  ;
  1.  S ECDINUM=$O(^EC(725,9999),-1),ECCOUNT=$P(^EC(725,0),U,4)
  1.  S (ECCNT1,ECCNT11)=0
  1.  F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT"  D
  1.  .S ECNAME=$P(ECXX,U,1),ECCODE=$P(ECXX,U,2),ECCPTN=$P(ECXX,U,3),ECCODX=ECCODE
  1.  .S ECCPT=""
  1.  .I ECCPTN'="" S ECCPT=$$FIND1^DIC(81,"","X",ECCPTN) I +ECCPT<1 D  Q
  1.  ..S ECSTR="   CPT code "_ECCPTN_" not a valid code in CPT File."
  1.  ..D MES^XPDUTL(" ")
  1.  ..D MES^XPDUTL("   ["_ECCODE_"] "_ECSTR)
  1.  .S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),ECNAMX=ECNAME
  1.  .I ECBEG="" S X=ECNAME D FILPROC Q
  1.  .F ECSEQ=ECBEG:1:ECEND D
  1.  ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
  1.  ..I $E(ECCODX,1,3)'="RCM" S ECNAME=ECNAMX_ECSEQ,X=ECNAME,ECCODE=ECCODX_ECADD
  1.  ..E  S ECNAME=ECNAMX_$E(ECADD,2,99),X=ECNAME,ECCODE=ECCODX_$E(ECADD,2,99)
  1.  ..D FILPROC
  1.  S $P(^EC(725,0),U,4)=ECCOUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
  1.  D BMES^XPDUTL("    Total "_ECCNT1_" new codes have been added.")
  1.  I ECCNT11>0 D MES^XPDUTL("    Total "_ECCNT11_" new codes have NOT added.")
  1.  D MES^XPDUTL(" ")
  1.  Q
  1.  ;
  1. FILPROC ;File national procedures
  1.  I '$D(^EC(725,"D",ECCODE)) D
  1.  .S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
  1.  .S DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"
  1.  .D FILE^DICN
  1.  .;
  1.  .I +Y>0 D
  1.  ..S ECCOUNT=ECCOUNT+1
  1.  ..D MES^XPDUTL(" ")
  1.  ..S ECSTR="    Entry #"_+Y_" for "_$P(Y,U,2)
  1.  ..S ECSTR=ECSTR_$S(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"
  1.  ..D MES^XPDUTL(ECSTR)
  1.  ..D MES^XPDUTL("      ...successfully added.")
  1.  ..S ECCNT1=ECCNT1+1
  1.  .;
  1.  .I Y=-1 D
  1.  ..D MES^XPDUTL(" ")
  1.  ..D BMES^XPDUTL("    ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
  1.  ..S ECCNT11=ECCNT11+1
  1.  ;
  1.  I $D(^EC(725,"DL",ECCODE)) D
  1.  .S ECLIEN=$O(^EC(725,"DL",ECCODE,""))
  1.  .D BMES^XPDUTL(" ")
  1.  .D MES^XPDUTL("    ** Your site has a local procedure (entry #"_ECLIEN_") in File #725")
  1.  .D MES^XPDUTL("       which uses "_ECCODE_" as its National Number.")
  1.  .D MES^XPDUTL("       Please inactivate this local procedure.")
  1.  .D MES^XPDUTL(" ")
  1.  .K Y
  1.  Q
  1. NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
  1.  ;;CGM PT EQ TRAIN 30M^NU221^95249^^
  1.  ;;CGM ANALY/INTERP 45M^NU222^95251^^
  1.  ;;INTERDIS CARE PLN MTG 3M^NU223^^^
  1.  ;;DX-INCR ENERGY EXPEND 0M^NU311^^^
  1.  ;;DX-INAD ENERGY INTAKE 0M^NU312^^^
  1.  ;;DX-EXC ENERGY INTAKE 0M^NU313^^^
  1.  ;;DX-PRED INAD ENER INT 0M^NU314^^^
  1.  ;;DX-PRED EXC ENER INT 0M^NU315^^^
  1.  ;;DX-INAD ORAL INTAKE 0M^NU316^^^
  1.  ;;DX-EXC ORAL INTAKE 0M^NU317^^^
  1.  ;;DX-INAD EN INFUSION 0M^NU318^^^
  1.  ;;DX-EXC EN INFUSION 0M^NU319^^^
  1.  ;;DX-EN COMP INCONST 0M^NU320^^^
  1.  ;;DX-EN ADM INCONST 0M^NU321^^^
  1.  ;;DX-LMT FOOD ACCEPT 0M^NU322^^^
  1.  ;;DX-INAD FLUID INTAKE 0M^NU323^^^
  1.  ;;DX-EXC FLUID INTAKE 0M^NU324^^^
  1.  ;;DX-INCR NUTR NEEDS 0M^NU325^^^
  1.  ;;DX-INAD PRO/ENER INT 0M^NU326^^^ 
  1.  ;;DX-DECR NUTR NEEDS 0M^NU327^^^
  1.  ;;DX-IMBAL OF NUTR 0M^NU328^^^
  1.  ;;DS-INAD FAT INTAKE 0M^NU329^^^
  1.  ;;DX-EXC FAT INTAKE 0M^NU330^^^
  1.  ;;DX-FATS INCON W/NEEDS 0M^NU331^^^
  1.  ;;DX-INAD PRO INTAKE 0M^NU332^^^
  1.  ;;DX-EXC PRO INTAKE 0M^NU333^^^
  1.  ;;DX-PRO INCON W/NEEDS 0M^NU334^^^
  1.  ;;DX-INAD CHO 0M^NU335^^^
  1.  ;;DX-EXC CHO 0M^NU336^^^
  1.  ;;DX-CHO INCON W/NEEDS 0M^NU337^^^
  1.  ;;DX-INCON CHO INTAKE 0M^NU338^^^
  1.  ;;DX-INAD FIBER INTAKE 0M^NU339^^^
  1.  ;;DX-EXC FIBER INTAKE 0M^NU340^^^
  1.  ;;DX-INAD VIT INTAKE 0M^NU341^^^
  1.  ;;DX-EXC VIT INTAKE 0M^NU342^^^
  1.  ;;DX-INAD MIN INTAKE 0M^NU343^^^
  1.  ;;DX-EXC MIN INTAKE 0M^NU344^^^
  1.  ;;DX-PRED SUB NUT INTAKE 0M^NU345^^^
  1.  ;;DX-PRED EXC NUT INTAKE 0M^NU346^^^
  1.  ;;DX-SWALLOW DIFF 0M^NU347^^^
  1.  ;;DX-CHEW DIFF 0M^NU348^^^
  1.  ;;DX-ALT GI FX 0M^NU349^^^
  1.  ;;DX-IMPAIR NUTR UTIL 0M^NU350^^^
  1.  ;;DX-ALTERED LABS 0M^NU351^^^
  1.  ;;DX-FOOD-MED INTERACT 0M^NU352^^^
  1.  ;;DX-PRED FD-MED INTER 0M^NU353^^^
  1.  ;;DX-UNDERWEIGHT 0M^NU354^^^
  1.  ;;DX-UNINTEN WT LOSS 0M^NU355^^^
  1.  ;;DX-OVERWEIGHT 0M^NU356^^^
  1.  ;;DX-OBESE, CLASS 1 0M^NU357^^^
  1.  ;;DX-OBESE, CLASS II 0M^NU358^^^
  1.  ;;DX-OBESE, CLASS III 0M^NU359^^^
  1.  ;;DX-UNINTEND WT GAIN 0M^NU360^^^
  1.  ;;DX-FN KNOW DEF 0M^NU361^^^
  1.  ;;DX-UNSUP BELIEFS/ATT 0M^NU362^^^
  1.  ;;DX-NOT RDY DT/LIF CHG 0M^NU363^^^
  1.  ;;DX-SELF-MONITOR DEF 0M^NU364^^^
  1.  ;;DX-DISORDERED EAT PAT 0M^NU365^^^
  1.  ;;DX-LIMITED ADHERENCE 0M^NU366^^^
  1.  ;;DX-UNDES FOOD CHOICES 0M^NU367^^^
  1.  ;;DX-PHYSICAL INACATIVITY 0M^NU368^^^
  1.  ;;DX-EXC PHYSI ACTIVITY 0M^NU369^^^
  1.  ;;DX-INAB MGE SELF-CARE 0M^NU370^^^
  1.  ;;DX-IMP ABILITY PREP FD 0M^NU371^^^
  1.  ;;DX-POOR NUTR QOL 0M^NU372^^^
  1.  ;;DX-SELF-FEED DIFF 0M^NU373^^^
  1.  ;;DX-INT OF UNSAFE FOOD 0M^NU374^^^
  1.  ;;DX-LMT ACCESS FD/WATER 0M^NU375^^^
  1.  ;;DX-LMT ACCESS NUTR SUP 0M^NU376^^^
  1.  ;;DX-NO NUTR DX 0M^NU377^^^
  1.  ;;DX-NOC 0M^NU378^^^
  1.  ;;ET-ACCESS 0M^NU390^^^
  1.  ;;ET-BEHAVIOR 0M^NU391^^^
  1.  ;;ET-BELIEFS-ATTITUDES 0M^NU392^^^
  1.  ;;ET-CULTURAL 0M^NU393^^^
  1.  ;;ET-KNOWLEDGE 0M^NU394^^^
  1.  ;;ET-PHYSICAL FUNCTION 0M^NU395^^^
  1.  ;;ET-PHYSIOLOGIC-METAB 0M^NU396^^^
  1.  ;;ET-PSYCHOLOGICAL 0M^NU397^^^
  1.  ;;ET-SOCIAL-PERSONAL 0M^NU398^^^
  1.  ;;ET-TREATMENT 0M^NU399^^^
  1.  ;;IN-GEN HEALT DIET 0M^NU411^^^
  1.  ;;IN-MOD COMP MEAL/SN 0M^NU412^^^
  1.  ;;IN-TEXT MOD DIET 0M^NU413^^^
  1.  ;;IN-ENERGY MOD DIET 0M^NU414^^^
  1.  ;;IN-PROT MOD DIET 0M^NU415^^^
  1.  ;;IN-CHO MODIFIED DIET 0M^NU416^^^
  1.  ;;IN-FAT MODIFIED DIET 0M^NU417^^^
  1.  ;;IN-FIBER MODIFIED DIET 0M^NU418^^^
  1.  ;;IN-FLUID MODIFIED DIET 0M^NU419^^^
  1.  ;;IN-MOD SPEC FOOD/INGR 0M^NU420^^^
  1.  ;;IN-VIT MOD DIET 0M^NU421^^^
  1.  ;;IN-MOD EN 0M^NU422^^^
  1.  ;;IN-MOD PN 0M^NU423^^^
  1.  ;;IN-INSERT FT 0M^NU424^^^
  1.  ;;IN-EN SITE CARE 0M^NU425^^^
  1.  ;;IN-EN FLUSH 0M^NU426^^^
  1.  ;;IN-COM BEV 0M^NU427^^^
  1.  ;;IN-COM FOOD 0M^NU428^^^
  1.  ;;IN-MOD BEV 0M^NU429^^^
  1.  ;;IN-MOD FOOD 0M^NU430^^^
  1.  ;;IN-SPEC FOODS/BEV 0M^NU431^^^
  1.  ;;IN-MULTIVIT/MIN SUPP 0M^NU432^^^
  1.  ;;IN-MULTITRACE SUPP 0M^NU433^^^
  1.  ;;IN-VIT SUPP 0M^NU434^^^
  1.  ;;IN-MIN SUPP 0M^NU435^^^
  1.  ;;IN-FEED ASSIST 0M^NU436^^^
  1.  ;;IN-ADAPTIVE DEVICE 0M^NU437^^^
  1.  ;;IN-FEED POS 0M^NU438^^^
  1.  ;;IN-MEAL SET UP 0M^NU439^^^
  1.  ;;IN-MOUTH CARE 0M^NU440^^^
  1.  ;;IN-MENU ASSIST 0M^NU441^^^
  1.  ;;IN-MANAG FEED ENVIRON 0M^NU442^^^
  1.  ;;IN-PRESCRIPTION RX 0M^NU443^^^
  1.  ;;IN-(OTC) MED 0M^NU444^^^
  1.  ;;IN-CAM 0M^NU445^^^
  1.  ;;IN-CONTENT ED 0M^NU446^^^
  1.  ;;IN-ED-INFLUE ON HEALTHi 0M^NU447^^^
  1.  ;;IN-PA GUIDE 0M^NU448^^^
  1.  ;;IN-LAB RESULT INTERPR 0M^NU449^^^
  1.  ;;IN-NUTR SKILL ED 0M^NU450^^^
  1.  ;;IN-TECH NUT ED 0M^NU451^^^
  1.  ;;IN-CBT 0M^NU452^^^
  1.  ;;IN-HBM 0M^NU453^^^
  1.  ;;IN-SOCIAL LEARN 0M^NU454^^^
  1.  ;;IN-TRANSTH ST OF CHG 0M^NU455^^^
  1.  ;;IN-MI 0M^NU456^^^
  1.  ;;IN-GOAL SET 0M^NU457^^^
  1.  ;;IN-SELF-MONITOR 0M^NU458^^^
  1.  ;;IN-PROBLEM SOLVING 0M^NU459^^^
  1.  ;;IN-SOCIAL SUPPORT 0M^NU460^^^
  1.  ;;IN-STRESS MANAGEMENT 0M^NU461^^^
  1.  ;;IN-STIMULUS CONTROL 0M^NU462^^^
  1.  ;;IN-COGNIT RESTRUCT 0M^NU463^^^
  1.  ;;IN-RELAPSE PREVENTION 0M^NU464^^^
  1.  ;;IN-REWARDS 0M^NU465^^^
  1.  ;;IN-TEAM MEETING 0M^NU466^^^
  1.  ;;IN-REFERRAL TO RDN 0M^NU467^^^
  1.  ;;IN-COLLAB WITH RDN/DT 0M^NU468^^^
  1.  ;;IN-COLLAB W/ OTHER PROV 0M^NU469^^^
  1.  ;;IN-REFER TO OTHER PROV 0M^NU470^^^
  1.  ;;IN-REFERRAL TO COM 0M^NU471^^^
  1.  ;;IN-D/C-TX CARE OTH PROV 0M^NU472^^^
  1.  ;;IN-D/C-TX CARE OTH AGEN 0M^NU473^^^
  1.  ;;IN-D/C-TX CARE OTH RDN 0M^NU474^^^
  1.  ;;IN-INTERV NOC 0M^NU475^^^
  1.  ;;M&E GOAL MET 0M^NU510^^^
  1.  ;;M&E GOAL NOT MET 0M^NU511^^^
  1.  ;;HEALTH BEHAV INTERV INI 30^SW189^96158^^
  1.  ;;HEALTH BEHAV INTERV INI GRP 30^SW190^96164^^
  1.  ;;HEALTH BEHAV INTERV FAM INI W/PT 30^SW191^96167^^
  1.  ;;HEALTH BEHAV INTERV FAM INI W/O PT 30^SW192^96170^^
  1.  ;;SELF CARE MGMT TRAINING^SW193^97535^^
  1.  ;;COMMUNITY/WORK REINTEGRT^SW194^97537^^
  1.  ;;SECURE MESG 11-20 MIN^SW195^98971^^
  1.  ;;SECURE MESG 21+ MIN^SW196^98972^^
  1.  ;;GROUP EDUCATION SVS^SW197^99078^^
  1.  ;;E-CONSLT 5-10 MIN^SW198^G2061^^
  1.  ;;E-CONSLT 11-20 MIN^SW199^G2062^^
  1.  ;;E-CONSLT 21+ MIN^SW200^G2063^^
  1.  ;;CRISIS INT SVC^SW201^S9484^^
  1.  ;;TELE GROUP^SW202^T1015^^
  1.  ;;QUIT
  1.  ;
  1. NAMECHG ;* change national procedure names
  1.  ;
  1.  ;  ECXX is in format:
  1.  ;   NATIONAL NUMBER^NEW NAME
  1.  ;
  1.  N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,ECSTR,ECCNT4
  1.  D MES^XPDUTL("*** Changing names in EC NATIONAL PROCEDURE File (#725)...")
  1.  ;
  1.  S ECCNT4=0
  1.  F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT"  D
  1.  .I $D(^EC(725,"D",$P(ECXX,U,1))) D
  1.  ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
  1.  ..I $D(^EC(725,ECDA,0)) D
  1.  ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
  1.  ...D MES^XPDUTL(" ")
  1.  ...D MES^XPDUTL("    Entry #"_ECDA_" for "_$P(ECXX,U,1))
  1.  ...D MES^XPDUTL("    ... field (#.01) updated to "_$P(ECXX,U,2)_".")
  1.  ...S ECCNT4=ECCNT4+1
  1.  .;
  1.  .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
  1.  ..D MES^XPDUTL(" ")
  1.  ..S ECSTR="Can't find entry for "_$P(ECXX,U,1)
  1.  ..D BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")
  1.  ;
  1.  D BMES^XPDUTL("    Total "_ECCNT4_" names have been changed.")
  1.  D MES^XPDUTL(" ")
  1.  Q
  1.  ;
  1. CHNG ;name changes -national code #^new procedure name
  1.  ;;CH100^RITE/SACRAMENT/ORDINANCE
  1.  ;;CH109^FUNERAL/MEMORIAL
  1.  ;;CH110^INDIVIDUAL CARE COUNSELING
  1.  ;;CH114^FAMILY CARE/COUNSELING
  1.  ;;CH118^GROUP
  1.  ;;CH125^INTERDISCIPLINARY TEAM
  1.  ;;NU181^REM MNTR PHYSIO PARAM DEV
  1.  ;;SW019^PREVENTATIVE COUNSEL, GRP
  1.  ;;SW181^SECURE MESG 5-10 MIN
  1.  ;;QUIT