source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U30.m

EC725U30 ;ALB/GTS/JAP/GT - EC National Procedure Update; 1/05/2005
 ;;2.0; EVENT CAPTURE ;**71**;8 May 96
 ;
 ;this routine is used as a post-init in a KIDS build 
 ;to modify the EC National Procedure file #725
 ;
ADDPROC ;* add national procedures
 ;
 ;  ECXX is in format:
 ;   NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
 ;   LAST NATIONAL NUMBER SEQUENCE
 ;
 N ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
 N ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
 D MES^XPDUTL(" ")
 D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
 D MES^XPDUTL(" ")
 S ECDINUM=$O(^EC(725,9999),-1),COUNT=$P(^EC(725,0),U,4)
 F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT"  D
 .S NAME=$P(ECXX,U,1),CODE=$P(ECXX,U,2),CPTN=$P(ECXX,U,3),CODX=CODE
 .S CPT=""
 .I CPTN'="" S CPT=$$FIND1^DIC(81,"","X",CPTN) I +CPT<1 D  Q
 ..S STR="   CPT code "_CPTN_" not a valid code in CPT File."
 ..D MES^XPDUTL(" ")
 ..D BMES^XPDUTL("   ["_CODE_"] "_STR)
 .S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),NAMX=NAME
 .I ECBEG="" S X=NAME D FILPROC Q
 .F ECSEQ=ECBEG:1:ECEND D
 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
 ..;S NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
 ..I $E(CODX,1,3)'="RCM" S NAME=NAMX_ECSEQ,X=NAME,CODE=CODX_ECADD
 ..E  S NAME=NAMX_$E(ECADD,2,99),X=NAME,CODE=CODX_$E(ECADD,2,99)
 ..D FILPROC
 S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
 Q
 ;
FILPROC ;File national procedures
 I '$D(^EC(725,"D",CODE)) D
 .S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
 .S DIC("DR")="1////^S X=CODE;4////^S X=CPT"
 .D FILE^DICN
 .I +Y>0 D
 ..S COUNT=COUNT+1
 ..D MES^XPDUTL(" ")
 ..S STR="   Entry #"_+Y_" for "_$P(Y,U,2)
 ..S STR=STR_$S(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
 ..D BMES^XPDUTL(STR_"  ...successfully added.")
 .I Y=-1 D
 ..D MES^XPDUTL(" ")
 ..D BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
 I $D(^EC(725,"DL",CODE)) D
 .S LIEN=$O(^EC(725,"DL",CODE,""))
 .D MES^XPDUTL(" ")
 .D BMES^XPDUTL("   Your site has a local procedure (entry #"_LIEN_") in File #725")
 .D BMES^XPDUTL("   which uses "_CODE_" as its National Number.")
 .D BMES^XPDUTL("   Please inactivate this local procedure.")
 .K Y
 Q
NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
 ;;HH PRCH ADHC RATE1 VSTS/MO^HH130
 ;;HH PRCH ADHC RATE2 VSTS/MO^HH131
 ;;HH PRCH ADHC RATE3 VSTS/MO^HH132
 ;;NUT SCREENING/REFERRAL,5M^NU001
 ;;STATUS NORMAL^NU002
 ;;STATUS MILD^NU003
 ;;STATUS MODERATE^NU004
 ;;STATUS SEVERE^NU005
 ;;MEDICAL RECORD REVIEW,5M^NU006
 ;;INP/NH NUT CARE-BASIC,10M^NU007
 ;;INP/NH NUT CARE-INTRM,10M^NU008
 ;;INP/NH NUT CARE-CMPLX,10M^NU009
 ;;MEAL ROUNDS/PT OBS,5M^NU010
 ;;FOOD PREF/ALLERGIES,5M^NU011
 ;;CALORIE COUNT,5M^NU012
 ;;MENU ANAL/MEAL PLN DEV,5M^NU013
 ;;MDS CARE PLAN DOC.10M^NU014
 ;;TEAM ROUNDS,5M(W/WO PT)^NU015
 ;;INTERDISC.CARE PLN MTG,5M^NU016
 ;;CASE MGMT,15M(W/WO PT)^NU017
 ;;COMMUNITY REFERRAL,5M^NU018
 ;;PHONE CALL-BRIEF W/PT^NU019
 ;;PHONE CALL-INTERMED. W/PT^NU020
 ;;PHONE CALL-LENGTHY W/PT^NU021
 ;;PHONE CALL-BRIEF W/OTHER^NU022
 ;;PHONE CALL-INTRM W/OTHER^NU023
 ;;PHONE CALL-LENGTHY W/OTHR^NU024
 ;;INTERDISC.GRP,1-3PTS,15M^NU025
 ;;INTERDISC.GRP,4-6PTS,15M^NU026
 ;;INTERDISC.GRP,7-9PTS,15M^NU027
 ;;INTERDISC.GP,10-13PTS,15M^NU028
 ;;INTERDISC.GP,14-17PTS,15M^NU029
 ;;INTERDISC.GP,18-20PTS,15M^NU030
 ;;INTERDISC.GP,21-25PTS,15M^NU031
 ;;INTERDISC.GP,>25PTS,15M^NU032
 ;;IP NUT.ED.GP,1-3PT,30M^NU033
 ;;IP NUT.ED.GP,4-6PT,30M^NU034
 ;;IP NUT.ED.GP,7-9PT,30M^NU035
 ;;IP NUT.ED.GP,10-13PT,30M^NU036
 ;;IP NUT.ED.GP,14-17PT,30M^NU037
 ;;IP NUT.ED.GP,18-20PT,30M^NU038
 ;;IP NUT.ED.GP,21-25PT,30M^NU039
 ;;IP NUT.ED.GP,>25PT,30M^NU040
 ;;CORRESPONDENCE, 5M^NU041
 ;;HOME HEALTH-INITIAL-15M^NU042^97802
 ;;HOME HEALTH-F/U-15M^NU043^97803
 ;;MNT NUTRI GP,1-3 PTS,30M^NU044^97804
 ;;MNT NUTRI GP,4-6 PTS,30M^NU045^97804
 ;;MNT NUTRI GP,7-9 PTS,30M^NU046^97804
 ;;MNT NUTRI GP,10-13PTS,30M^NU047^97804
 ;;MNT NUTRI GP,14-17PTS,30M^NU048^97804
 ;;MNT NUTRI GP,18-20PTS,30M^NU049^97804
 ;;MNT NUTRI GP,21-25PTS,30M^NU050^97804
 ;;MNT NUTRI GP,>25PTS,30M^NU051^97804
 ;;MNT GP,2ND REF,1-3PTS,30M^NU052^G0271
 ;;MNT GP,2ND REF,4-6PTS,30M^NU053^G0271
 ;;MNT GP,2ND REF,7-9PTS,30M^NU054^G0271
 ;;MNT GP2ND REF10-13PTS,30M^NU055^G0271
 ;;MNT GP2ND REF14-17PTS,30M^NU056^G0271
 ;;MNT GP2ND REF18-20PTS,30M^NU057^G0271
 ;;MNT GP2ND REF21-25PTS,30M^NU058^G0271
 ;;MNT GP2ND REF,>25PTS,30M^NU059^G0271
 ;;DSMT GP,1-3PTS,30M^NU060^G0109
 ;;DSMT GP,4-6PTS,30M^NU061^G0109
 ;;DSMT GP,7-9PTS,30M^NU062^G0109
 ;;DSMT GP,10-13PTS,30M^NU063^G0109
 ;;DSMT GP,14-17PTS,30M^NU064^G0109
 ;;DSMT GP,18-20PTS,30M^NU065^G0109
 ;;DSMT GP,21-25PTS,30M^NU066^G0109
 ;;DSMT GP,>25PTS,30M^NU067^G0109
 ;;CASE MGMT,15M (WO PT)^NU068
 ;;WEIGHT MGMT CLASS,1-3PTS^NU069^S9449
 ;;WEIGHT MGMT CLASS,4-6PTS^NU070^S9449
 ;;WEIGHT MGMT CLASS,7-9PTS^NU071^S9449
 ;;WEIGHT MGMT CLASS,10-13PTS^NU072^S9449
 ;;WEIGHT MGMT CLASS,14-17PTS^NU073^S9449
 ;;WEIGHT MGMT CLASS,18-20PTS^NU074^S9449
 ;;WEIGHT MGMT CLASS,21-25PTS^NU075^S9449
 ;;WEIGHT MGMT CLASS,>25PTS^NU076^S9449
 ;;OPT NUT.ED.GP,1-3PT,30M^NU077^S9452
 ;;OPT NUT.ED.GP,4-6PT,30M^NU078^S9452
 ;;OPT NUT.ED.GP,7-9 PT,30M^NU079^S9452
 ;;OPT NUT.ED.GP,10-13PT,30M^NU080^S9452
 ;;OPT NUT.ED.GP,14-17PT,30M^NU081^S9452
 ;;OPT NUT.ED.GP,18-20PT,30M^NU082^S9452
 ;;OPT NUT.ED.GP,21-25PT,30M^NU083^S9452
 ;;OPT NUT.ED.GP,>25PT,30M^NU084^S9452
 ;;DIAB MGMT GP,1-3 PTS^NU085^S9455
 ;;DIAB MGMT GP,4-6 PTS^NU086^S9455
 ;;DIAB MGMT GP,7-9 PTS^NU087^S9455
 ;;DIAB MGMT GP,10-13 PTS^NU088^S9455
 ;;DIAB MGMT GP,14-17 PTS^NU089^S9455
 ;;DIAB MGMT GP,18-20 PTS^NU090^S9455
 ;;DIAB MGMT GP,21-25 PTS^NU091^S9455
 ;;DIAB MGMT GP,>25 PTS^NU092^S9455
 ;;NU093RESERVE^NU093
 ;;NU094RESERVE^NU094
 ;;NU095RESERVE^NU095
 ;;QUIT
NAMECHG ;* change national procedure names
 ;
 ;  ECXX is in format:
 ;   NATIONAL NUMBER^NEW NAME
 ;
 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,STR
 D MES^XPDUTL(" ")
 D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
 D MES^XPDUTL(" ")
 F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT"  D
 .I $D(^EC(725,"D",$P(ECXX,U,1))) D
 ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
 ..I $D(^EC(725,ECDA,0)) D
 ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
 ...D MES^XPDUTL(" ")
 ...D MES^XPDUTL("   Entry #"_ECDA_" for "_$P(ECXX,U,1))
 ...D BMES^XPDUTL("      ... field (#.01) updated to  "_$P(ECXX,U,2)_".")
 .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
 ..D MES^XPDUTL(" ")
 ..S STR="Can't find entry for "_$P(ECXX,U,1)
 ..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
 Q
 ;
CHNG ;name changes -national code #^new procedure name
 ;;SP100^CENT AUD FNCT EVL INIT 60 M
 ;;SP228^SPEECH/LANG EVAL LEV1
 ;;SP229^SPEECH/LANG TRTMT LEV1
 ;;SP317^CENT AUD FNCT EVL ADDL 15 M
 ;;SP331^SPEECH/LANG EVAL LEV2
 ;;SP332^SPEECH/LANG EVAL LEV3
 ;;SP333^SPEECH/LANG TRTMT LEV2
 ;;SP334^SPEECH/LANG TRTMT LEV3
 ;;QUIT