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

EC725U40.m

Go to the documentation of this file.
  1. EC725U40 ;ALB/GTS/JAP/GT - EC National Procedure Update; 4/03/2006
  1. ;;2.0; EVENT CAPTURE ;**81**;8 May 96
  1. ;
  1. ;this routine is used as a post-init in a KIDS build
  1. ;to modify the EC National Procedure file #725
  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,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
  1. N ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
  1. D MES^XPDUTL(" ")
  1. S ECDINUM=$O(^EC(725,9999),-1),COUNT=$P(^EC(725,0),U,4)
  1. F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
  1. .S NAME=$P(ECXX,U,1),CODE=$P(ECXX,U,2),CPTN=$P(ECXX,U,3),CODX=CODE
  1. .S CPT=""
  1. .I CPTN'="" S CPT=$$FIND1^DIC(81,"","X",CPTN) I +CPT<1 D Q
  1. ..S STR=" CPT code "_CPTN_" not a valid code in CPT File."
  1. ..D MES^XPDUTL(" ")
  1. ..D BMES^XPDUTL(" ["_CODE_"] "_STR)
  1. .S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),NAMX=NAME
  1. .I ECBEG="" S X=NAME D FILPROC Q
  1. .F ECSEQ=ECBEG:1:ECEND D
  1. ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
  1. ..;S NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
  1. ..I $E(CODX,1,3)'="RCM" S NAME=NAMX_ECSEQ,X=NAME,CODE=CODX_ECADD
  1. ..E S NAME=NAMX_$E(ECADD,2,99),X=NAME,CODE=CODX_$E(ECADD,2,99)
  1. ..D FILPROC
  1. S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
  1. Q
  1. ;
  1. FILPROC ;File national procedures
  1. I '$D(^EC(725,"D",CODE)) D
  1. .S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
  1. .S DIC("DR")="1////^S X=CODE;4////^S X=CPT"
  1. .D FILE^DICN
  1. .I +Y>0 D
  1. ..S COUNT=COUNT+1
  1. ..D MES^XPDUTL(" ")
  1. ..S STR=" Entry #"_+Y_" for "_$P(Y,U,2)
  1. ..S STR=STR_$S(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
  1. ..D BMES^XPDUTL(STR_" ...successfully added.")
  1. .I Y=-1 D
  1. ..D MES^XPDUTL(" ")
  1. ..D BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
  1. I $D(^EC(725,"DL",CODE)) D
  1. .S LIEN=$O(^EC(725,"DL",CODE,""))
  1. .D MES^XPDUTL(" ")
  1. .D BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
  1. .D BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
  1. .D BMES^XPDUTL(" Please inactivate this local procedure.")
  1. .K Y
  1. Q
  1. NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
  1. ;;THERAPEUTIC PROCEDURE, GROUP^SP545^97150
  1. ;;EDUC & TRAINING, IND, 30 MIN^SP546^98960
  1. ;;EDUC & TRAINING 2-4 PT, 30 MIN^SP547^98961
  1. ;;EDUC & TRAINING 5-8 PT, 30 MIN^SP548^98962
  1. ;;L8624 LITHIUM BAT,CIDEV,EARLVL^SP549^L8624
  1. ;;V5095 SEMI-IMPLNT MIDEAR HRDV^SP550^V5095
  1. ;;QUIT
  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,STR
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
  1. D MES^XPDUTL(" ")
  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 BMES^XPDUTL(" ... field (#.01) updated to "_$P(ECXX,U,2)_".")
  1. .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
  1. ..D MES^XPDUTL(" ")
  1. ..S STR="Can't find entry for "_$P(ECXX,U,1)
  1. ..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
  1. Q
  1. ;
  1. CHNG ;name changes -national code #^new procedure name
  1. ;;NU157^FOOT ASSESSMENT EA 10MIN
  1. ;;SP038^INITIAL ACOUSTIC DEVICE FIT
  1. ;;SP107^INITIAL HEARING AID FIT, MON
  1. ;;SP108^INITIAL HEARING AID FIT, BIN
  1. ;;SP449^FOLLOW-UP ACOUSTIC DEV FIT
  1. ;;SP450^FOLLOW-UP HEARING AID FIT, MON
  1. ;;SP451^FOLLOW-UP HEARING AID FIT, BIN
  1. ;;SP506^A5120 SKIN BARRIER WIPE/SWAB
  1. ;;SP531^L8623 LITHIUM ION BAT,CIDEVBDY
  1. ;;QUIT