EC2P118 ;ALB/DE - EC National Update ; 4/2/13 3:17pm
;;2.0;EVENT CAPTURE;**118**;8 May 96;Build 5
;
;this routine is used as a post-init in a KIDS build
;to modify the EC National Procedure (#725) file
;
Q
;
START ; entry point for post-init
;
D ADDPROC
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,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 (#725) File...")
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))
..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_" ...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
;;PAT COORD/ASSIST^BR001^99199
;;NON-MD IDT PAT^BR002^99368
;;NON-MD IDT NO PAT^BR003^99366
;;OTH THERAPY EXERCISE^BR004^97110
;;COG SKILLS DVMNT^BR005^97532
;;CASE MGMT/ADJ COUNSEL^BR006^96152
;;GRP TRAIN/SUP 2-5^BR007^96153
;;GRP TRAIN/SUP 6-10^BR008^96153
;;GRP TRAIN/SUP >11^BR009^96153
;;TRAIN/SUP PAT/FAM^BR010^96154
;;TRAIN/SUP FAM ONLY^BR011^96155
;;PHONE 5-10M^BR012^98966
;;PHONE 11-20M^BR013^98967
;;PHONE 21-30M^BR014^98968
;;PHONE 5-10M, NO PT^BR015^98966
;;PHONE 11-20M, NO PT^BR016^98967
;;PHONE 21-30M, NO PT^BR017^98968
;;TRANSPORT/ESCORT PAT^BR018^99082
;;CAT INITIAL ASSESS^BR019^97755
;;CAT RE-ASSESS^BR020^96151
;;CAT SENS INTEG TECH^BR021^97535
;;CAT ADAPT SOFTWARE^BR022^97537
;;CAT APP SOFTWARE^BR023^97537
;;CAT EMAIL/INTERNET^BR024^97537
;;CAT EQUIP/MAINT/TRBL^BR025^97537
;;CAT PROG INTRO^BR026^97537
;;LS INITIAL ASSESS^BR027^96150
;;LS RE-ASSESS^BR028^96151
;;LS SENS INTEG TECH^BR029^97535
;;LS COMM BASIC^BR030^97535
;;LS COMM/OCCUP TRNG^BR031^97537
;;LS SCM BRAILLE^BR032^97535
;;LS SCM ADL^BR033^97535
;;LS SCM KITCHEN^BR034^97535
;;MS INITIAL ASSESS^BR035^96150
;;MS RE-ASSESS^BR036^96151
;;MS SIT SENS SKILLTRG^BR037^97535
;;MS SIT BASIC SKILLS^BR038^97533
;;MS SELF CARE MGMT^BR039^97535
;;MS ADV SKILLTRG^BR040^97533
;;MS HOUSE RPR WW^BR041^97535
;;OM INITIAL ASSESS^BR042^96150
;;OM RE-ASSESS^BR043^96151
;;OM SENS INTEG TECH^BR044^97535
;;OM INDOOR TRG^BR045^97116
;;OM RES RURAL TVL^BR046^97116
;;OM BUSINESS TVL^BR047^97537
;;OM COMMUNITY TVL^BR048^97537
;;LV INITIAL ASSESS^BR049^96150
;;LV RE-ASSESS^BR050^96151
;;LV SIT VSTRNG NO DEV^BR051^97533
;;LV SIT VSTRNG DEV^BR052^97533
;;LV SELF CARE MGMT^BR053^97535
;;LV SIT INTDIST REC TASK^BR054^97533
;;LV SIT DISTANCE VIEW^BR055^97533
;;HH DRIVE TIME (15MIN) PA^HH147
;;INDIRCALORMTRY 20M^NU205^94690
;;INDIRCALORMTRY ADD5M^NU206
;;SECURE MSGEVAL MD^SM001^99444
;;SECURE MSGEVAL NONMD^SM002^98969
;;SECURE MSG <2M^SM003
;;SECURE MSG 2-5M^SM004
;;SECURE MSG 5-10M^SM005
;;SECURE MSG >10M^SM006
;;FEES INTERPRET/RPT^SP564^92613
;;FLST INTERPRET/RPT^SP565^92615
;;FEEST INTERPRET/RPT^SP566^92617
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P118 4886 printed Oct 16, 2024@17:55:28 Page 2
EC2P118 ;ALB/DE - EC National Update ; 4/2/13 3:17pm
+1 ;;2.0;EVENT CAPTURE;**118**;8 May 96;Build 5
+2 ;
+3 ;this routine is used as a post-init in a KIDS build
+4 ;to modify the EC National Procedure (#725) file
+5 ;
+6 QUIT
+7 ;
START ; entry point for post-init
+1 ;
+2 DO ADDPROC
+3 QUIT
+4 ;
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,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
+10 NEW ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN
+11 DO MES^XPDUTL(" ")
+12 DO BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE (#725) File...")
+13 DO MES^XPDUTL(" ")
+14 SET ECDINUM=$ORDER(^EC(725,9999),-1)
SET ECCOUNT=$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 ECNAME=$PIECE(ECXX,U,1)
SET ECCODE=$PIECE(ECXX,U,2)
SET ECCPTN=$PIECE(ECXX,U,3)
SET ECCODX=ECCODE
+17 SET ECCPT=""
+18 IF ECCPTN'=""
SET ECCPT=$$FIND1^DIC(81,"","X",ECCPTN)
IF +ECCPT<1
Begin DoDot:2
+19 SET ECSTR=" CPT code "_ECCPTN_" not a valid code in CPT File."
+20 DO MES^XPDUTL(" ")
+21 DO BMES^XPDUTL(" ["_ECCODE_"] "_ECSTR)
End DoDot:2
QUIT
+22 SET ECBEG=$PIECE(ECXX,U,4)
SET ECEND=$PIECE(ECXX,U,5)
SET ECNAMX=ECNAME
+23 IF ECBEG=""
SET X=ECNAME
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 IF $EXTRACT(ECCODX,1,3)'="RCM"
SET ECNAME=ECNAMX_ECSEQ
SET X=ECNAME
SET ECCODE=ECCODX_ECADD
+27 IF '$TEST
SET ECNAME=ECNAMX_$EXTRACT(ECADD,2,99)
SET X=ECNAME
SET ECCODE=ECCODX_$EXTRACT(ECADD,2,99)
+28 DO FILPROC
End DoDot:2
End DoDot:1
+29 SET $PIECE(^EC(725,0),U,4)=ECCOUNT
SET X=$ORDER(^EC(725,999999),-1)
SET $PIECE(^EC(725,0),U,3)=X
+30 QUIT
+31 ;
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_" ...added.")
End DoDot:2
+11 IF Y=-1
Begin DoDot:2
+12 DO MES^XPDUTL(" ")
+13 DO BMES^XPDUTL("ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
End DoDot:2
End DoDot:1
+14 IF $DATA(^EC(725,"DL",ECCODE))
Begin DoDot:1
+15 SET ECLIEN=$ORDER(^EC(725,"DL",ECCODE,""))
+16 DO MES^XPDUTL(" ")
+17 DO BMES^XPDUTL(" Your site has a local procedure (entry #"_ECLIEN_") in File #725")
+18 DO BMES^XPDUTL(" which uses "_ECCODE_" 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 ;;PAT COORD/ASSIST^BR001^99199
+2 ;;NON-MD IDT PAT^BR002^99368
+3 ;;NON-MD IDT NO PAT^BR003^99366
+4 ;;OTH THERAPY EXERCISE^BR004^97110
+5 ;;COG SKILLS DVMNT^BR005^97532
+6 ;;CASE MGMT/ADJ COUNSEL^BR006^96152
+7 ;;GRP TRAIN/SUP 2-5^BR007^96153
+8 ;;GRP TRAIN/SUP 6-10^BR008^96153
+9 ;;GRP TRAIN/SUP >11^BR009^96153
+10 ;;TRAIN/SUP PAT/FAM^BR010^96154
+11 ;;TRAIN/SUP FAM ONLY^BR011^96155
+12 ;;PHONE 5-10M^BR012^98966
+13 ;;PHONE 11-20M^BR013^98967
+14 ;;PHONE 21-30M^BR014^98968
+15 ;;PHONE 5-10M, NO PT^BR015^98966
+16 ;;PHONE 11-20M, NO PT^BR016^98967
+17 ;;PHONE 21-30M, NO PT^BR017^98968
+18 ;;TRANSPORT/ESCORT PAT^BR018^99082
+19 ;;CAT INITIAL ASSESS^BR019^97755
+20 ;;CAT RE-ASSESS^BR020^96151
+21 ;;CAT SENS INTEG TECH^BR021^97535
+22 ;;CAT ADAPT SOFTWARE^BR022^97537
+23 ;;CAT APP SOFTWARE^BR023^97537
+24 ;;CAT EMAIL/INTERNET^BR024^97537
+25 ;;CAT EQUIP/MAINT/TRBL^BR025^97537
+26 ;;CAT PROG INTRO^BR026^97537
+27 ;;LS INITIAL ASSESS^BR027^96150
+28 ;;LS RE-ASSESS^BR028^96151
+29 ;;LS SENS INTEG TECH^BR029^97535
+30 ;;LS COMM BASIC^BR030^97535
+31 ;;LS COMM/OCCUP TRNG^BR031^97537
+32 ;;LS SCM BRAILLE^BR032^97535
+33 ;;LS SCM ADL^BR033^97535
+34 ;;LS SCM KITCHEN^BR034^97535
+35 ;;MS INITIAL ASSESS^BR035^96150
+36 ;;MS RE-ASSESS^BR036^96151
+37 ;;MS SIT SENS SKILLTRG^BR037^97535
+38 ;;MS SIT BASIC SKILLS^BR038^97533
+39 ;;MS SELF CARE MGMT^BR039^97535
+40 ;;MS ADV SKILLTRG^BR040^97533
+41 ;;MS HOUSE RPR WW^BR041^97535
+42 ;;OM INITIAL ASSESS^BR042^96150
+43 ;;OM RE-ASSESS^BR043^96151
+44 ;;OM SENS INTEG TECH^BR044^97535
+45 ;;OM INDOOR TRG^BR045^97116
+46 ;;OM RES RURAL TVL^BR046^97116
+47 ;;OM BUSINESS TVL^BR047^97537
+48 ;;OM COMMUNITY TVL^BR048^97537
+49 ;;LV INITIAL ASSESS^BR049^96150
+50 ;;LV RE-ASSESS^BR050^96151
+51 ;;LV SIT VSTRNG NO DEV^BR051^97533
+52 ;;LV SIT VSTRNG DEV^BR052^97533
+53 ;;LV SELF CARE MGMT^BR053^97535
+54 ;;LV SIT INTDIST REC TASK^BR054^97533
+55 ;;LV SIT DISTANCE VIEW^BR055^97533
+56 ;;HH DRIVE TIME (15MIN) PA^HH147
+57 ;;INDIRCALORMTRY 20M^NU205^94690
+58 ;;INDIRCALORMTRY ADD5M^NU206
+59 ;;SECURE MSGEVAL MD^SM001^99444
+60 ;;SECURE MSGEVAL NONMD^SM002^98969
+61 ;;SECURE MSG <2M^SM003
+62 ;;SECURE MSG 2-5M^SM004
+63 ;;SECURE MSG 5-10M^SM005
+64 ;;SECURE MSG >10M^SM006
+65 ;;FEES INTERPRET/RPT^SP564^92613
+66 ;;FLST INTERPRET/RPT^SP565^92615
+67 ;;FEEST INTERPRET/RPT^SP566^92617
+68 ;;QUIT
