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

EC2P125.m

Go to the documentation of this file.
  1. EC2P125 ;ALB/DE - EC National Procedure (#725) Update ; 10/4/12 11:00am
  1. ;;2.0;EVENT CAPTURE;**125**;8 May 96;Build 1
  1. ;
  1. ;this routine is used as a post-init in a KIDS build
  1. ;to modify the EC National Procedure (#725) file
  1. ;
  1. Q
  1. ;
  1. POST ;* entry point
  1. N ECVRRV
  1. ;* if 725 already updated, write message
  1. ; since check inserted in addproc subroutine, patch may be re-installed
  1. I $$GET1^DID(725,"","","PACKAGE REVISION DATA")["EC*2*125" D
  1. .D MES^XPDUTL(" ")
  1. .D MES^XPDUTL("It appears that the EC NATIONAL PROCEDURE")
  1. .D MES^XPDUTL("(#725) file has already been updated")
  1. .D MES^XPDUTL("with Patch EC*2*125.")
  1. .D MES^XPDUTL(" ")
  1. .D MES^XPDUTL("But the patch may be re-installed...")
  1. .D MES^XPDUTL(" ")
  1. D UPDATE
  1. Q
  1. ;
  1. UPDATE ;* update the file
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Updating the EC NATIONAL PROCEDURE (#725) file...")
  1. D MES^XPDUTL(" ")
  1. ;
  1. ;* add new/edit national procedures
  1. D ADDPROC ;add new procedures
  1. D NAMECHG ;change description
  1. ;
  1. S ECVRRV=$$GET1^DID(725,"","","PACKAGE REVISION DATA")
  1. S ECVRRV=ECVRRV_"^EC*2*125"
  1. D PRD^DILFD(725,ECVRRV)
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Update of EC NATIONAL PROCEDURE (#725) file")
  1. D BMES^XPDUTL(" completed...")
  1. D MES^XPDUTL(" ")
  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
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE (#725) file...")
  1. D MES^XPDUTL(" ")
  1. S ECDINUM=$O(^EC(725,9999),-1),ECCOUNT=$P(^EC(725,0),U,4)
  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 BMES^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. 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. .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 BMES^XPDUTL(ECSTR_" ...successfully added.")
  1. .I Y=-1 D
  1. ..D MES^XPDUTL(" ")
  1. ..D BMES^XPDUTL("ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
  1. I $D(^EC(725,"DL",ECCODE)) D
  1. .S ECLIEN=$O(^EC(725,"DL",ECCODE,""))
  1. .D MES^XPDUTL(" ")
  1. .D BMES^XPDUTL(" Your site has a local procedure (entry #"_ECLIEN_") in File #725")
  1. .D BMES^XPDUTL(" which uses "_ECCODE_" as its National Number.")
  1. .D BMES^XPDUTL(" Please inactivate this local procedure.")
  1. .K Y
  1. Q
  1. ;
  1. NEW ;* national procedures to add -procedure name^national #^CPT code^beg seq^end seq
  1. ;;GROUP IPT^CH125^
  1. ;;STATUS MALNUTRITION^NU215^
  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
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE (#725) file...")
  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 ECSTR="Can't find entry for "_$P(ECXX,U,1)
  1. ..D BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")
  1. Q
  1. ;
  1. CHNG ;* name changes -national #^new procedure name
  1. ;;NU151^NUTR CNSLG IND EA A'L 15M
  1. ;;SW136^CONSULT F2F ONLY, 15M
  1. ;;QUIT