EC2P144B ;ALB/JR - EC National Procedure Update ;5/4/18 12:00pm
;;2.0;EVENT CAPTURE;**144**;8 May 96;Build 6
;
;this routine is used as a post-init in a KIDS build
;to modify the EC National Procedure file (#725)
;
Q
;
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,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
N ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN
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),ECCOUNT=$P(^EC(725,0),U,4)
F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
.S ECNAME=$P(ECXX,U,1),ECCODE=$P(ECXX,U,2),ECCPTN=$P(ECXX,U,3),ECCODX=ECCODE
.S ECCPT=""
.I ECCPTN'="" S ECCPT=$$FIND1^DIC(81,"","X",ECCPTN) I +ECCPT<1 D Q
..S ECSTR=" CPT code "_ECCPTN_" not a valid code in CPT File."
..D MES^XPDUTL(" ")
..D BMES^XPDUTL(" ["_ECCODE_"] "_ECSTR)
.S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),ECNAMX=ECNAME
.I ECBEG="" S X=ECNAME D FILPROC Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..;S ECNAME=ECNAMX_ECADD,X=ECNAME,ECCODE=ECCODX_ECADD
..I $E(ECCODX,1,3)'="RCM" S ECNAME=ECNAMX_ECSEQ,X=ECNAME,ECCODE=ECCODX_ECADD
..E S ECNAME=ECNAMX_$E(ECADD,2,99),X=ECNAME,ECCODE=ECCODX_$E(ECADD,2,99)
..D FILPROC
S $P(^EC(725,0),U,4)=ECCOUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
Q
;
FILPROC ;File national procedures
I '$D(^EC(725,"D",ECCODE)) D
.S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
.S DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"
.D FILE^DICN
.I +Y>0 D
..S ECCOUNT=ECCOUNT+1
..D MES^XPDUTL(" ")
..S ECSTR=" Entry #"_+Y_" for "_$P(Y,U,2)
..S ECSTR=ECSTR_$S(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"
..D BMES^XPDUTL(ECSTR)
..D BMES^XPDUTL(" ...successfully added.")
.I Y=-1 D
..D MES^XPDUTL(" ")
..D BMES^XPDUTL("ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
I $D(^EC(725,"DL",ECCODE)) D
.S ECLIEN=$O(^EC(725,"DL",ECCODE,""))
.D MES^XPDUTL(" ")
.D BMES^XPDUTL(" Your site has a local procedure (entry #"_ECLIEN_") in File #725")
.D BMES^XPDUTL(" which uses "_ECCODE_" 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
;;DX- ENERGY BALANCE^NU300^
;;DX- ORAL/NUTR SUPPORT^NU301^
;;DX- FLUID INTAKE^NU302^
;;DX- BIOACTIVE SUBSTANCES^NU303^
;;DX- NUTRIENT INTAKE^NU304^
;;DX- FUNCTIONAL^NU305^
;;DX- BIOCHEMICAL^NU306^
;;DX- WEIGHT^NU307^
;;DX- KNOWLEDGE/BELIEFS^NU308^
;;DX- ACTIVITY & FXN^NU309^
;;DX- FOOD SAFETY & ACCESS^NU310^
;;INTERV-MEALS/SNACKS^NU400^
;;INTERV-EN or PN^NU401^
;;INTERV-SUPPL^NU402^
;;INTERV-FEEDING ASSIST^NU403^
;;INTERV-FEEDING ENVIRON^NU404^
;;INTERV-MED MGMT^NU405^
;;INTERV - NUTR EDUC^NU406^
;;INTERV- NUTR COUNSELING^NU407^
;;INTERV-COORD OF CARE^NU408^
;;INTERV-POP ACTION^NU409^
;;M&E-PROBLEM RESOLVED^NU500^
;;M&E-PROBLEM IMPROVED^NU501^
;;COGNITIVE SKILLS DVMNT^RC132^G0515
;;INPT CONSULT NO PSYCHOTHERAPY^SW183^T1016
;;INPT D/C PLAN COORDINATION^SW184^T1016
;;CONTRACT NURSING HOME F/U^SW185^T1016
;;INELIG NON-PT REFER/CM^SW186^T1016
;;INELIG PT REFER/CASE MGMT^SW187^T1016
;;COMMUNITY RES CARE F/U^SW188^T1016
;;QUIT
;
NAMECHG ;* change national procedure names
;
; ECXX is in format:
; NATIONAL NUMBER^NEW NAME
;
N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,ECSTR
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 ECSTR="Can't find entry for "_$P(ECXX,U,1)
..D BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")
Q
;
CHNG ;name changes -national code #^new procedure name
;;NU007^ASSMT-NO PROBLEM
;;NU008^ASSMT-PREDICTED PROBLEM
;;NU009^ASSMT-PROBLEM PRESENT
;;NU215^DX-MALNUTR DISORDERS
;;SP101^INTRAOP MONITORING PER HR
;;SW006^HEALTH & BEH INTERVENT IND
;;SW009^TEAM CONFERENCE W/PT 30M
;;SW019^HEALTH & BEH INTERVENT GRP
;;SW020^GROUP PSYCHOTHERAPY
;;SW087^CASE MGMT 15M IN-HOME F/U
;;SW093^TEAM CONF W/O PT NO PRESCRIBER
;;SW122^ADVANCED DIRECTIVES
;;SW137^MH ASSESSMENT BY NON-MD
;;SW138^PSYCHIATRIC DIAGNOSTIC EVALUATION
;;SW153^PROGRAM INTAKE SCREENING
;;SW154^HOME VISIT IND/FM MARRIAGE COUNSEL
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P144B 4999 printed Apr 09, 2024@21:03:12 Page 2
EC2P144B ;ALB/JR - EC National Procedure Update ;5/4/18 12:00pm
+1 ;;2.0;EVENT CAPTURE;**144**;8 May 96;Build 6
+2 ;
+3 ;this routine is used as a post-init in a KIDS build
+4 ;to modify the EC National Procedure file (#725)
+5 ;
+6 QUIT
+7 ;
ADDPROC ;* add national procedures
+1 ;
+2 ; ECXX is in format:
+3 ; NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
+4 ; LAST NATIONAL NUMBER SEQUENCE
+5 ;
+6 NEW ECX,ECXX,ECDINUM,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
+7 NEW ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN
+8 DO MES^XPDUTL(" ")
+9 DO BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
+10 DO MES^XPDUTL(" ")
+11 SET ECDINUM=$ORDER(^EC(725,9999),-1)
SET ECCOUNT=$PIECE(^EC(725,0),U,4)
+12 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(NEW+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+13 SET ECNAME=$PIECE(ECXX,U,1)
SET ECCODE=$PIECE(ECXX,U,2)
SET ECCPTN=$PIECE(ECXX,U,3)
SET ECCODX=ECCODE
+14 SET ECCPT=""
+15 IF ECCPTN'=""
SET ECCPT=$$FIND1^DIC(81,"","X",ECCPTN)
IF +ECCPT<1
Begin DoDot:2
+16 SET ECSTR=" CPT code "_ECCPTN_" not a valid code in CPT File."
+17 DO MES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" ["_ECCODE_"] "_ECSTR)
End DoDot:2
QUIT
+19 SET ECBEG=$PIECE(ECXX,U,4)
SET ECEND=$PIECE(ECXX,U,5)
SET ECNAMX=ECNAME
+20 IF ECBEG=""
SET X=ECNAME
DO FILPROC
QUIT
+21 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+22 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+23 ;S ECNAME=ECNAMX_ECADD,X=ECNAME,ECCODE=ECCODX_ECADD
+24 IF $EXTRACT(ECCODX,1,3)'="RCM"
SET ECNAME=ECNAMX_ECSEQ
SET X=ECNAME
SET ECCODE=ECCODX_ECADD
+25 IF '$TEST
SET ECNAME=ECNAMX_$EXTRACT(ECADD,2,99)
SET X=ECNAME
SET ECCODE=ECCODX_$EXTRACT(ECADD,2,99)
+26 DO FILPROC
End DoDot:2
End DoDot:1
+27 SET $PIECE(^EC(725,0),U,4)=ECCOUNT
SET X=$ORDER(^EC(725,999999),-1)
SET $PIECE(^EC(725,0),U,3)=X
+28 QUIT
+29 ;
FILPROC ;File national procedures
+1 IF '$DATA(^EC(725,"D",ECCODE))
Begin DoDot:1
+2 SET ECDINUM=ECDINUM+1
SET DINUM=ECDINUM
SET DIC(0)="L"
SET DLAYGO=725
SET DIC="^EC(725,"
+3 SET DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"
+4 DO FILE^DICN
+5 IF +Y>0
Begin DoDot:2
+6 SET ECCOUNT=ECCOUNT+1
+7 DO MES^XPDUTL(" ")
+8 SET ECSTR=" Entry #"_+Y_" for "_$PIECE(Y,U,2)
+9 SET ECSTR=ECSTR_$SELECT(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"
+10 DO BMES^XPDUTL(ECSTR)
+11 DO BMES^XPDUTL(" ...successfully added.")
End DoDot:2
+12 IF Y=-1
Begin DoDot:2
+13 DO MES^XPDUTL(" ")
+14 DO BMES^XPDUTL("ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
End DoDot:2
End DoDot:1
+15 IF $DATA(^EC(725,"DL",ECCODE))
Begin DoDot:1
+16 SET ECLIEN=$ORDER(^EC(725,"DL",ECCODE,""))
+17 DO MES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" Your site has a local procedure (entry #"_ECLIEN_") in File #725")
+19 DO BMES^XPDUTL(" which uses "_ECCODE_" as its National Number.")
+20 DO BMES^XPDUTL(" Please inactivate this local procedure.")
+21 KILL Y
End DoDot:1
+22 QUIT
NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
+1 ;;DX- ENERGY BALANCE^NU300^
+2 ;;DX- ORAL/NUTR SUPPORT^NU301^
+3 ;;DX- FLUID INTAKE^NU302^
+4 ;;DX- BIOACTIVE SUBSTANCES^NU303^
+5 ;;DX- NUTRIENT INTAKE^NU304^
+6 ;;DX- FUNCTIONAL^NU305^
+7 ;;DX- BIOCHEMICAL^NU306^
+8 ;;DX- WEIGHT^NU307^
+9 ;;DX- KNOWLEDGE/BELIEFS^NU308^
+10 ;;DX- ACTIVITY & FXN^NU309^
+11 ;;DX- FOOD SAFETY & ACCESS^NU310^
+12 ;;INTERV-MEALS/SNACKS^NU400^
+13 ;;INTERV-EN or PN^NU401^
+14 ;;INTERV-SUPPL^NU402^
+15 ;;INTERV-FEEDING ASSIST^NU403^
+16 ;;INTERV-FEEDING ENVIRON^NU404^
+17 ;;INTERV-MED MGMT^NU405^
+18 ;;INTERV - NUTR EDUC^NU406^
+19 ;;INTERV- NUTR COUNSELING^NU407^
+20 ;;INTERV-COORD OF CARE^NU408^
+21 ;;INTERV-POP ACTION^NU409^
+22 ;;M&E-PROBLEM RESOLVED^NU500^
+23 ;;M&E-PROBLEM IMPROVED^NU501^
+24 ;;COGNITIVE SKILLS DVMNT^RC132^G0515
+25 ;;INPT CONSULT NO PSYCHOTHERAPY^SW183^T1016
+26 ;;INPT D/C PLAN COORDINATION^SW184^T1016
+27 ;;CONTRACT NURSING HOME F/U^SW185^T1016
+28 ;;INELIG NON-PT REFER/CM^SW186^T1016
+29 ;;INELIG PT REFER/CASE MGMT^SW187^T1016
+30 ;;COMMUNITY RES CARE F/U^SW188^T1016
+31 ;;QUIT
+32 ;
NAMECHG ;* change national procedure names
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^NEW NAME
+4 ;
+5 NEW ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,ECSTR
+6 DO MES^XPDUTL(" ")
+7 DO BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
+8 DO MES^XPDUTL(" ")
+9 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(CHNG+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+10 IF $DATA(^EC(725,"D",$PIECE(ECXX,U,1)))
Begin DoDot:2
+11 SET ECDA=+$ORDER(^EC(725,"D",$PIECE(ECXX,U,1),0))
+12 IF $DATA(^EC(725,ECDA,0))
Begin DoDot:3
+13 SET DA=ECDA
SET DR=".01////^S X=$P(ECXX,U,2)"
SET DIE="^EC(725,"
DO ^DIE
+14 DO MES^XPDUTL(" ")
+15 DO MES^XPDUTL(" Entry #"_ECDA_" for "_$PIECE(ECXX,U,1))
+16 DO BMES^XPDUTL(" ... field (#.01) updated to "_$PIECE(ECXX,U,2)_".")
End DoDot:3
End DoDot:2
+17 IF '$DATA(^EC(725,"D",$PIECE(ECXX,U,1)))
Begin DoDot:2
+18 DO MES^XPDUTL(" ")
+19 SET ECSTR="Can't find entry for "_$PIECE(ECXX,U,1)
+20 DO BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
CHNG ;name changes -national code #^new procedure name
+1 ;;NU007^ASSMT-NO PROBLEM
+2 ;;NU008^ASSMT-PREDICTED PROBLEM
+3 ;;NU009^ASSMT-PROBLEM PRESENT
+4 ;;NU215^DX-MALNUTR DISORDERS
+5 ;;SP101^INTRAOP MONITORING PER HR
+6 ;;SW006^HEALTH & BEH INTERVENT IND
+7 ;;SW009^TEAM CONFERENCE W/PT 30M
+8 ;;SW019^HEALTH & BEH INTERVENT GRP
+9 ;;SW020^GROUP PSYCHOTHERAPY
+10 ;;SW087^CASE MGMT 15M IN-HOME F/U
+11 ;;SW093^TEAM CONF W/O PT NO PRESCRIBER
+12 ;;SW122^ADVANCED DIRECTIVES
+13 ;;SW137^MH ASSESSMENT BY NON-MD
+14 ;;SW138^PSYCHIATRIC DIAGNOSTIC EVALUATION
+15 ;;SW153^PROGRAM INTAKE SCREENING
+16 ;;SW154^HOME VISIT IND/FM MARRIAGE COUNSEL
+17 ;;QUIT
