- 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 Jan 18, 2025@02:56:09 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