EC2P132C ;ALB/DE - EC National Procedure Update ; 4/8/16 11:00am
;;2.0;EVENT CAPTURE;**132**;8 May 96;Build 3
;
;this routine is used as a post-init in a KIDS build
;to modify the EC National Procedure file (#725)
;
Q
;
INACT ;* inactivate national procedures
;
; ECXX is in format:
; NATIONAL NUMBER^INACTIVATION DATE^FIRST NATIONAL NUMBER SEQUENCE^
; LAST NATIONAL NUMBER SEQUENCE
;
N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
N ECSEQ,ECCODE,ECCODX
D MES^XPDUTL(" ")
D BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
D MES^XPDUTL(" ")
F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT" D
.S ECEXDT=$P(ECXX,U,2),X=ECEXDT,%DT="X" D ^%DT S ECINDT=$P(Y,".",1)
.S ECCODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),ECCODX=ECCODE
.I ECBEG="" D UPINACT Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..S ECCODE=ECCODX_ECADD
..D UPINACT
Q
UPINACT ;Update codes as inactive
;
S ECDA=+$O(^EC(725,"D",ECCODE,0))
I $D(^EC(725,ECDA,0)) D
.S DA=ECDA,DR="2///^S X=ECINDT",DIE="^EC(725," D ^DIE
.D MES^XPDUTL(" ")
.D BMES^XPDUTL(" "_ECCODE_" inactivated as of "_ECEXDT_".")
Q
;
OLD ;national procedures to be inactivated - national code #^inact. date
;;SD001^10/1/2016
;;SD002^10/1/2016
;;SD003^10/1/2016
;;SD004^10/1/2016
;;SD005^10/1/2016
;;SD006^10/1/2016
;;SD007^10/1/2016
;;SD008^10/1/2016
;;SD009^10/1/2016
;;SD012^10/1/2016
;;SD013^10/1/2016
;;SD014^10/1/2016
;;SD015^10/1/2016
;;SD016^10/1/2016
;;SD017^10/1/2016
;;SD018^10/1/2016
;;SD019^10/1/2016
;;SD020^10/1/2016
;;SD021^10/1/2016
;;SD022^10/1/2016
;;SD023^10/1/2016
;;SD024^10/1/2016
;;SD025^10/1/2016
;;SD026^10/1/2016
;;SD027^10/1/2016
;;SD028^10/1/2016
;;SD029^10/1/2016
;;SD030^10/1/2016
;;SD031^10/1/2016
;;SD032^10/1/2016
;;SD033^10/1/2016
;;SD034^10/1/2016
;;SD035^10/1/2016
;;SD036^10/1/2016
;;SD037^10/1/2016
;;SD038^10/1/2016
;;SD039^10/1/2016
;;SD040^10/1/2016
;;SD041^10/1/2016
;;SD042^10/1/2016
;;SH001^10/1/2016
;;SH002^10/1/2016
;;SH003^10/1/2016
;;SH004^10/1/2016
;;SH005^10/1/2016
;;SH006^10/1/2016
;;SH007^10/1/2016
;;SH008^10/1/2016
;;SH009^10/1/2016
;;SH012^10/1/2016
;;SH013^10/1/2016
;;SH014^10/1/2016
;;SH015^10/1/2016
;;SH016^10/1/2016
;;SH017^10/1/2016
;;SH018^10/1/2016
;;SH019^10/1/2016
;;SH020^10/1/2016
;;SN001^10/1/2016
;;SN002^10/1/2016
;;SN003^10/1/2016
;;SN004^10/1/2016
;;SN005^10/1/2016
;;SN006^10/1/2016
;;SN007^10/1/2016
;;SN008^10/1/2016
;;SN009^10/1/2016
;;SN012^10/1/2016
;;SN013^10/1/2016
;;SN014^10/1/2016
;;SN015^10/1/2016
;;SN016^10/1/2016
;;SN017^10/1/2016
;;SN018^10/1/2016
;;SN019^10/1/2016
;;SN020^10/1/2016
;;SN021^10/1/2016
;;SN022^10/1/2016
;;SN023^10/1/2016
;;SN024^10/1/2016
;;SN025^10/1/2016
;;SN026^10/1/2016
;;SN027^10/1/2016
;;SN028^10/1/2016
;;SN029^10/1/2016
;;SN030^10/1/2016
;;SN031^10/1/2016
;;SN032^10/1/2016
;;SN033^10/1/2016
;;SN034^10/1/2016
;;SN035^10/1/2016
;;SN036^10/1/2016
;;SN037^10/1/2016
;;SN038^10/1/2016
;;SN039^10/1/2016
;;SN040^10/1/2016
;;SN041^10/1/2016
;;SN042^10/1/2016
;;SN043^10/1/2016
;;SN044^10/1/2016
;;SN045^10/1/2016
;;SN046^10/1/2016
;;SN047^10/1/2016
;;SN048^10/1/2016
;;SN049^10/1/2016
;;SN050^10/1/2016
;;SN051^10/1/2016
;;SN052^10/1/2016
;;SN053^10/1/2016
;;SN054^10/1/2016
;;SN055^10/1/2016
;;SN056^10/1/2016
;;SN057^10/1/2016
;;SN058^10/1/2016
;;SN059^10/1/2016
;;SN060^10/1/2016
;;SN061^10/1/2016
;;SN062^10/1/2016
;;SN063^10/1/2016
;;SN064^10/1/2016
;;SN065^10/1/2016
;;SN066^10/1/2016
;;SN067^10/1/2016
;;SN068^10/1/2016
;;SN069^10/1/2016
;;SN070^10/1/2016
;;SN071^10/1/2016
;;SN072^10/1/2016
;;SN073^10/1/2016
;;SN074^10/1/2016
;;SN075^10/1/2016
;;SN076^10/1/2016
;;SN077^10/1/2016
;;SN078^10/1/2016
;;SN079^10/1/2016
;;SN080^10/1/2016
;;SN081^10/1/2016
;;SN082^10/1/2016
;;SN083^10/1/2016
;;SN084^10/1/2016
;;SN085^10/1/2016
;;SN086^10/1/2016
;;SN087^10/1/2016
;;SN088^10/1/2016
;;SN089^10/1/2016
;;SN090^10/1/2016
;;SN091^10/1/2016
;;SN092^10/1/2016
;;SN093^10/1/2016
;;SN094^10/1/2016
;;SN095^10/1/2016
;;SN096^10/1/2016
;;SN097^10/1/2016
;;SN098^10/1/2016
;;SN099^10/1/2016
;;SN100^10/1/2016
;;QUIT
;
CPTCHG ;* change cpt codes
;
; ECXX is in format:
; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
; NUMBER SEQUENCE
;
N ECX,ECXX,ECCPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,ECSEQ,ECSTR,ECCPTIEN
D MES^XPDUTL(" ")
D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
D MES^XPDUTL(" ")
F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" D
.S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),ECCPTIEN=$P(ECXX,U,2)
.S ECCPTIEN=$S(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))
.I ECCPTIEN'="@",+ECCPTIEN<1 D Q
..S ECSTR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
..D MES^XPDUTL(" ")
..D BMES^XPDUTL(" "_ECSTR)
.I ECBEG="" S ECCPT($P(ECXX,U))=ECCPTIEN_U_$P(ECXX,U,2) Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..S ECCPT($P(ECXX,U)_ECADD)=ECCPTIEN_U_$P(ECXX,U,2)
S ECXX=""
F S ECXX=$O(ECCPT(ECXX)) Q:ECXX="" D
.S ECX=$O(^EC(725,"D",ECXX,0))
.Q:+ECX=0
.I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
..D MES^XPDUTL(" ")
..D BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT code not updated.")
.S ECCPT=$P(ECCPT(ECXX),U),DA=ECX,DR="4///"_ECCPT,DIE="^EC(725," D ^DIE
.D MES^XPDUTL(" ")
.S ECSTR=" Entry #"_ECX_" for "_ECXX
.D BMES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))
Q
;
CPT ;cpt codes to be changed - national #^new CPT code
;;SP086^92570
;;SP256^92522
;;SP064^92537
;;SP231^92538
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P132C 5939 printed Oct 16, 2024@17:55:40 Page 2
EC2P132C ;ALB/DE - EC National Procedure Update ; 4/8/16 11:00am
+1 ;;2.0;EVENT CAPTURE;**132**;8 May 96;Build 3
+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 ;
INACT ;* inactivate national procedures
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^INACTIVATION DATE^FIRST NATIONAL NUMBER SEQUENCE^
+4 ; LAST NATIONAL NUMBER SEQUENCE
+5 ;
+6 NEW ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
+7 NEW ECSEQ,ECCODE,ECCODX
+8 DO MES^XPDUTL(" ")
+9 DO BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
+10 DO MES^XPDUTL(" ")
+11 FOR ECX=1:1
KILL DD,DO,DA
SET ECXX=$PIECE($TEXT(OLD+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+12 SET ECEXDT=$PIECE(ECXX,U,2)
SET X=ECEXDT
SET %DT="X"
DO ^%DT
SET ECINDT=$PIECE(Y,".",1)
+13 SET ECCODE=$PIECE(ECXX,U)
SET ECBEG=$PIECE(ECXX,U,3)
SET ECEND=$PIECE(ECXX,U,4)
SET ECCODX=ECCODE
+14 IF ECBEG=""
DO UPINACT
QUIT
+15 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+16 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+17 SET ECCODE=ECCODX_ECADD
+18 DO UPINACT
End DoDot:2
End DoDot:1
+19 QUIT
UPINACT ;Update codes as inactive
+1 ;
+2 SET ECDA=+$ORDER(^EC(725,"D",ECCODE,0))
+3 IF $DATA(^EC(725,ECDA,0))
Begin DoDot:1
+4 SET DA=ECDA
SET DR="2///^S X=ECINDT"
SET DIE="^EC(725,"
DO ^DIE
+5 DO MES^XPDUTL(" ")
+6 DO BMES^XPDUTL(" "_ECCODE_" inactivated as of "_ECEXDT_".")
End DoDot:1
+7 QUIT
+8 ;
OLD ;national procedures to be inactivated - national code #^inact. date
+1 ;;SD001^10/1/2016
+2 ;;SD002^10/1/2016
+3 ;;SD003^10/1/2016
+4 ;;SD004^10/1/2016
+5 ;;SD005^10/1/2016
+6 ;;SD006^10/1/2016
+7 ;;SD007^10/1/2016
+8 ;;SD008^10/1/2016
+9 ;;SD009^10/1/2016
+10 ;;SD012^10/1/2016
+11 ;;SD013^10/1/2016
+12 ;;SD014^10/1/2016
+13 ;;SD015^10/1/2016
+14 ;;SD016^10/1/2016
+15 ;;SD017^10/1/2016
+16 ;;SD018^10/1/2016
+17 ;;SD019^10/1/2016
+18 ;;SD020^10/1/2016
+19 ;;SD021^10/1/2016
+20 ;;SD022^10/1/2016
+21 ;;SD023^10/1/2016
+22 ;;SD024^10/1/2016
+23 ;;SD025^10/1/2016
+24 ;;SD026^10/1/2016
+25 ;;SD027^10/1/2016
+26 ;;SD028^10/1/2016
+27 ;;SD029^10/1/2016
+28 ;;SD030^10/1/2016
+29 ;;SD031^10/1/2016
+30 ;;SD032^10/1/2016
+31 ;;SD033^10/1/2016
+32 ;;SD034^10/1/2016
+33 ;;SD035^10/1/2016
+34 ;;SD036^10/1/2016
+35 ;;SD037^10/1/2016
+36 ;;SD038^10/1/2016
+37 ;;SD039^10/1/2016
+38 ;;SD040^10/1/2016
+39 ;;SD041^10/1/2016
+40 ;;SD042^10/1/2016
+41 ;;SH001^10/1/2016
+42 ;;SH002^10/1/2016
+43 ;;SH003^10/1/2016
+44 ;;SH004^10/1/2016
+45 ;;SH005^10/1/2016
+46 ;;SH006^10/1/2016
+47 ;;SH007^10/1/2016
+48 ;;SH008^10/1/2016
+49 ;;SH009^10/1/2016
+50 ;;SH012^10/1/2016
+51 ;;SH013^10/1/2016
+52 ;;SH014^10/1/2016
+53 ;;SH015^10/1/2016
+54 ;;SH016^10/1/2016
+55 ;;SH017^10/1/2016
+56 ;;SH018^10/1/2016
+57 ;;SH019^10/1/2016
+58 ;;SH020^10/1/2016
+59 ;;SN001^10/1/2016
+60 ;;SN002^10/1/2016
+61 ;;SN003^10/1/2016
+62 ;;SN004^10/1/2016
+63 ;;SN005^10/1/2016
+64 ;;SN006^10/1/2016
+65 ;;SN007^10/1/2016
+66 ;;SN008^10/1/2016
+67 ;;SN009^10/1/2016
+68 ;;SN012^10/1/2016
+69 ;;SN013^10/1/2016
+70 ;;SN014^10/1/2016
+71 ;;SN015^10/1/2016
+72 ;;SN016^10/1/2016
+73 ;;SN017^10/1/2016
+74 ;;SN018^10/1/2016
+75 ;;SN019^10/1/2016
+76 ;;SN020^10/1/2016
+77 ;;SN021^10/1/2016
+78 ;;SN022^10/1/2016
+79 ;;SN023^10/1/2016
+80 ;;SN024^10/1/2016
+81 ;;SN025^10/1/2016
+82 ;;SN026^10/1/2016
+83 ;;SN027^10/1/2016
+84 ;;SN028^10/1/2016
+85 ;;SN029^10/1/2016
+86 ;;SN030^10/1/2016
+87 ;;SN031^10/1/2016
+88 ;;SN032^10/1/2016
+89 ;;SN033^10/1/2016
+90 ;;SN034^10/1/2016
+91 ;;SN035^10/1/2016
+92 ;;SN036^10/1/2016
+93 ;;SN037^10/1/2016
+94 ;;SN038^10/1/2016
+95 ;;SN039^10/1/2016
+96 ;;SN040^10/1/2016
+97 ;;SN041^10/1/2016
+98 ;;SN042^10/1/2016
+99 ;;SN043^10/1/2016
+100 ;;SN044^10/1/2016
+101 ;;SN045^10/1/2016
+102 ;;SN046^10/1/2016
+103 ;;SN047^10/1/2016
+104 ;;SN048^10/1/2016
+105 ;;SN049^10/1/2016
+106 ;;SN050^10/1/2016
+107 ;;SN051^10/1/2016
+108 ;;SN052^10/1/2016
+109 ;;SN053^10/1/2016
+110 ;;SN054^10/1/2016
+111 ;;SN055^10/1/2016
+112 ;;SN056^10/1/2016
+113 ;;SN057^10/1/2016
+114 ;;SN058^10/1/2016
+115 ;;SN059^10/1/2016
+116 ;;SN060^10/1/2016
+117 ;;SN061^10/1/2016
+118 ;;SN062^10/1/2016
+119 ;;SN063^10/1/2016
+120 ;;SN064^10/1/2016
+121 ;;SN065^10/1/2016
+122 ;;SN066^10/1/2016
+123 ;;SN067^10/1/2016
+124 ;;SN068^10/1/2016
+125 ;;SN069^10/1/2016
+126 ;;SN070^10/1/2016
+127 ;;SN071^10/1/2016
+128 ;;SN072^10/1/2016
+129 ;;SN073^10/1/2016
+130 ;;SN074^10/1/2016
+131 ;;SN075^10/1/2016
+132 ;;SN076^10/1/2016
+133 ;;SN077^10/1/2016
+134 ;;SN078^10/1/2016
+135 ;;SN079^10/1/2016
+136 ;;SN080^10/1/2016
+137 ;;SN081^10/1/2016
+138 ;;SN082^10/1/2016
+139 ;;SN083^10/1/2016
+140 ;;SN084^10/1/2016
+141 ;;SN085^10/1/2016
+142 ;;SN086^10/1/2016
+143 ;;SN087^10/1/2016
+144 ;;SN088^10/1/2016
+145 ;;SN089^10/1/2016
+146 ;;SN090^10/1/2016
+147 ;;SN091^10/1/2016
+148 ;;SN092^10/1/2016
+149 ;;SN093^10/1/2016
+150 ;;SN094^10/1/2016
+151 ;;SN095^10/1/2016
+152 ;;SN096^10/1/2016
+153 ;;SN097^10/1/2016
+154 ;;SN098^10/1/2016
+155 ;;SN099^10/1/2016
+156 ;;SN100^10/1/2016
+157 ;;QUIT
+158 ;
CPTCHG ;* change cpt codes
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
+4 ; NUMBER SEQUENCE
+5 ;
+6 NEW ECX,ECXX,ECCPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,ECSEQ,ECSTR,ECCPTIEN
+7 DO MES^XPDUTL(" ")
+8 DO BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
+9 DO MES^XPDUTL(" ")
+10 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(CPT+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+11 SET ECBEG=$PIECE(ECXX,U,3)
SET ECEND=$PIECE(ECXX,U,4)
SET ECCPTIEN=$PIECE(ECXX,U,2)
+12 SET ECCPTIEN=$SELECT(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))
+13 IF ECCPTIEN'="@"
IF +ECCPTIEN<1
Begin DoDot:2
+14 SET ECSTR=$PIECE(ECXX,U)_": CPT code "_$PIECE(ECXX,U,2)_" is invalid."
+15 DO MES^XPDUTL(" ")
+16 DO BMES^XPDUTL(" "_ECSTR)
End DoDot:2
QUIT
+17 IF ECBEG=""
SET ECCPT($PIECE(ECXX,U))=ECCPTIEN_U_$PIECE(ECXX,U,2)
QUIT
+18 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+19 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+20 SET ECCPT($PIECE(ECXX,U)_ECADD)=ECCPTIEN_U_$PIECE(ECXX,U,2)
End DoDot:2
End DoDot:1
+21 SET ECXX=""
+22 FOR
SET ECXX=$ORDER(ECCPT(ECXX))
if ECXX=""
QUIT
Begin DoDot:1
+23 SET ECX=$ORDER(^EC(725,"D",ECXX,0))
+24 if +ECX=0
QUIT
+25 IF '$DATA(^EC(725,ECX,0))!(+ECX=0)
Begin DoDot:2
+26 DO MES^XPDUTL(" ")
+27 DO BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT code not updated.")
End DoDot:2
QUIT
+28 SET ECCPT=$PIECE(ECCPT(ECXX),U)
SET DA=ECX
SET DR="4///"_ECCPT
SET DIE="^EC(725,"
DO ^DIE
+29 DO MES^XPDUTL(" ")
+30 SET ECSTR=" Entry #"_ECX_" for "_ECXX
+31 DO BMES^XPDUTL(ECSTR_" updated to use CPT code "_$PIECE(ECCPT(ECXX),U,2))
End DoDot:1
+32 QUIT
+33 ;
CPT ;cpt codes to be changed - national #^new CPT code
+1 ;;SP086^92570
+2 ;;SP256^92522
+3 ;;SP064^92537
+4 ;;SP231^92538
+5 ;;QUIT
