EC2P117 ;ALB/DE - EC National Update ; 10/4/12 11:00am
;;2.0;EVENT CAPTURE;**117**;;Build 6
;
;this routine is used as a post-init in a KIDS build
;to modify the EC National Procedure file #725
;and the Medical Specialty file #723
;
Q
;
START ; entry point for post-init
;
D ADDPROC
D ADDSPEC
Q
;
ADDPROC ;* add procedure to national procedure file
;
; Some routine structure is left in place, in the event, additional EC National
; Procedures are desired before the patch is released.
;
; 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
;;TELE ICU MONITOR PT SITE^TC001
;;QUIT
;
ADDSPEC ;add "PTSD" to medical specialty file
;
N ECEXIST,ECFLAG,DIC,DA,DLAYGO,X,Y
D MES^XPDUTL(" ")
D BMES^XPDUTL("Adding new entry to the MEDICAL SPECIALTY File (#723)...")
D MES^XPDUTL(" ")
S (ECEXIST,ECFLAG)=0
S ECEXIST=0 F S ECEXIST=$O(^ECC(723,ECEXIST)) Q:ECEXIST'>0 I ^ECC(723,ECEXIST,0)="PTSD" S ECFLAG=1 Q
I ECFLAG D Q
.D MES^XPDUTL(" ")
.D BMES^XPDUTL("PTSD already exists")
.D MES^XPDUTL(" ")
S X="PTSD",DIC="^ECC(723,",DIC(0)="L",DLAYGO=723
D FILE^DICN
I +Y>0 D Q
.D MES^XPDUTL(" ")
.D BMES^XPDUTL(" Entry #"_+Y_" for "_$P(Y,U,2)_" ...successfully added.")
I +Y=-1 D
.D MES^XPDUTL(" ")
.D BMES^XPDUTL("ERROR when attempting to add PTSD")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P117 3403 printed Apr 09, 2024@21:01:27 Page 2
EC2P117 ;ALB/DE - EC National Update ; 10/4/12 11:00am
+1 ;;2.0;EVENT CAPTURE;**117**;;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 ;and the Medical Specialty file #723
+6 ;
+7 QUIT
+8 ;
START ; entry point for post-init
+1 ;
+2 DO ADDPROC
+3 DO ADDSPEC
+4 QUIT
+5 ;
ADDPROC ;* add procedure to national procedure file
+1 ;
+2 ; Some routine structure is left in place, in the event, additional EC National
+3 ; Procedures are desired before the patch is released.
+4 ;
+5 ; ECXX is in format:
+6 ; NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
+7 ; LAST NATIONAL NUMBER SEQUENCE
+8 ;
+9 NEW ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
+10 NEW ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
+11 DO MES^XPDUTL(" ")
+12 DO BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
+13 DO MES^XPDUTL(" ")
+14 SET ECDINUM=$ORDER(^EC(725,9999),-1)
SET COUNT=$PIECE(^EC(725,0),U,4)
+15 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(NEW+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+16 SET NAME=$PIECE(ECXX,U,1)
SET CODE=$PIECE(ECXX,U,2)
SET CPTN=$PIECE(ECXX,U,3)
SET CODX=CODE
+17 SET CPT=""
+18 IF CPTN'=""
SET CPT=$$FIND1^DIC(81,"","X",CPTN)
IF +CPT<1
Begin DoDot:2
+19 SET STR=" CPT code "_CPTN_" not a valid code in CPT File."
+20 DO MES^XPDUTL(" ")
+21 DO BMES^XPDUTL(" ["_CODE_"] "_STR)
End DoDot:2
QUIT
+22 SET ECBEG=$PIECE(ECXX,U,4)
SET ECEND=$PIECE(ECXX,U,5)
SET NAMX=NAME
+23 IF ECBEG=""
SET X=NAME
DO FILPROC
QUIT
+24 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+25 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+26 ;S NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
+27 IF $EXTRACT(CODX,1,3)'="RCM"
SET NAME=NAMX_ECSEQ
SET X=NAME
SET CODE=CODX_ECADD
+28 IF '$TEST
SET NAME=NAMX_$EXTRACT(ECADD,2,99)
SET X=NAME
SET CODE=CODX_$EXTRACT(ECADD,2,99)
+29 DO FILPROC
End DoDot:2
End DoDot:1
+30 SET $PIECE(^EC(725,0),U,4)=COUNT
SET X=$ORDER(^EC(725,999999),-1)
SET $PIECE(^EC(725,0),U,3)=X
+31 QUIT
+32 ;
FILPROC ;file national procedures
+1 IF '$DATA(^EC(725,"D",CODE))
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=CODE;4///^S X=CPT"
+4 DO FILE^DICN
+5 IF +Y>0
Begin DoDot:2
+6 SET COUNT=COUNT+1
+7 DO MES^XPDUTL(" ")
+8 SET STR=" Entry #"_+Y_" for "_$PIECE(Y,U,2)
+9 SET STR=STR_$SELECT(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
+10 DO BMES^XPDUTL(STR_" ...successfully added.")
End DoDot:2
+11 IF Y=-1
Begin DoDot:2
+12 DO MES^XPDUTL(" ")
+13 DO BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
End DoDot:2
End DoDot:1
+14 IF $DATA(^EC(725,"DL",CODE))
Begin DoDot:1
+15 SET LIEN=$ORDER(^EC(725,"DL",CODE,""))
+16 DO MES^XPDUTL(" ")
+17 DO BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
+18 DO BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
+19 DO BMES^XPDUTL(" Please inactivate this local procedure.")
+20 KILL Y
End DoDot:1
+21 QUIT
NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
+1 ;;TELE ICU MONITOR PT SITE^TC001
+2 ;;QUIT
+3 ;
ADDSPEC ;add "PTSD" to medical specialty file
+1 ;
+2 NEW ECEXIST,ECFLAG,DIC,DA,DLAYGO,X,Y
+3 DO MES^XPDUTL(" ")
+4 DO BMES^XPDUTL("Adding new entry to the MEDICAL SPECIALTY File (#723)...")
+5 DO MES^XPDUTL(" ")
+6 SET (ECEXIST,ECFLAG)=0
+7 SET ECEXIST=0
FOR
SET ECEXIST=$ORDER(^ECC(723,ECEXIST))
if ECEXIST'>0
QUIT
IF ^ECC(723,ECEXIST,0)="PTSD"
SET ECFLAG=1
QUIT
+8 IF ECFLAG
Begin DoDot:1
+9 DO MES^XPDUTL(" ")
+10 DO BMES^XPDUTL("PTSD already exists")
+11 DO MES^XPDUTL(" ")
End DoDot:1
QUIT
+12 SET X="PTSD"
SET DIC="^ECC(723,"
SET DIC(0)="L"
SET DLAYGO=723
+13 DO FILE^DICN
+14 IF +Y>0
Begin DoDot:1
+15 DO MES^XPDUTL(" ")
+16 DO BMES^XPDUTL(" Entry #"_+Y_" for "_$PIECE(Y,U,2)_" ...successfully added.")
End DoDot:1
QUIT
+17 IF +Y=-1
Begin DoDot:1
+18 DO MES^XPDUTL(" ")
+19 DO BMES^XPDUTL("ERROR when attempting to add PTSD")
End DoDot:1
+20 QUIT
