- EC2P157C ;ALB/TXH - EC National Procedure Update; May 19, 2022@10:15
- ;;2.0;EVENT CAPTURE;**157**;May 8, 1996;Build 4
- ;
- ; This routine is used as a post-init in a KIDS build
- ; to inactivate national procedure codes and update
- ; CPT codes in the EC National Procedure File (#725).
- ;
- ; Reference to ^%DT supported by DBIA #10003
- ; Reference to $$FIND1^DIC supported by DBIA #2051
- ; Reference to ^DIE supported by DBIA #10018
- ; Reference to BMES^XPDUTL,MES^XPDUTL supported by DBIA #10141
- ;
- 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,ECCNT2
- S ECCNT2=0
- D BMES^XPDUTL("*** Inactivating procedures in the 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
- D BMES^XPDUTL(" Total "_ECCNT2_" CPT codes have been inactivated.")
- 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(" "_ECCODE_" inactivated as of "_ECEXDT_".")
- .S ECCNT2=ECCNT2+1
- Q
- ;
- OLD ;national procedures to be inactivated - national code#^inact. date
- ;;NU019^10/1/2022
- ;;NU020^10/1/2022
- ;;NU021^10/1/2022
- ;;NU022^10/1/2022
- ;;NU023^10/1/2022
- ;;NU024^10/1/2022
- ;;NU216^10/1/2022
- ;;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("*** Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
- D MES^XPDUTL(" ")
- ;
- N ECCNT3,ECCNT33 S (ECCNT3,ECCNT33)=0
- 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 MES^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 MES^XPDUTL(" Can't find entry for "_ECXX_",CPT code not updated.")
- ..S ECCNT33=ECCNT33+1
- .S ECCPT=$P(ECCPT(ECXX),U),DA=ECX,DR="4///"_ECCPT,DIE="^EC(725," D ^DIE
- .S ECSTR=" Entry #"_ECX_" for "_ECXX
- .D MES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))
- .S ECCNT3=ECCNT3+1
- ;
- D BMES^XPDUTL(" Total "_ECCNT3_" CPT codes have been updated.")
- I ECCNT33>0 D MES^XPDUTL(" Total "_ECCNT33_" CPT codes did NOT get updated.")
- Q
- ;
- CPT ;cpt codes to be changed - national #^new CPT code
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P157C 3465 printed Feb 18, 2025@23:22 Page 2
- EC2P157C ;ALB/TXH - EC National Procedure Update; May 19, 2022@10:15
- +1 ;;2.0;EVENT CAPTURE;**157**;May 8, 1996;Build 4
- +2 ;
- +3 ; This routine is used as a post-init in a KIDS build
- +4 ; to inactivate national procedure codes and update
- +5 ; CPT codes in the EC National Procedure File (#725).
- +6 ;
- +7 ; Reference to ^%DT supported by DBIA #10003
- +8 ; Reference to $$FIND1^DIC supported by DBIA #2051
- +9 ; Reference to ^DIE supported by DBIA #10018
- +10 ; Reference to BMES^XPDUTL,MES^XPDUTL supported by DBIA #10141
- +11 ;
- +12 QUIT
- +13 ;
- 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,ECCNT2
- +8 SET ECCNT2=0
- +9 DO BMES^XPDUTL("*** Inactivating procedures in the 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 DO BMES^XPDUTL(" Total "_ECCNT2_" CPT codes have been inactivated.")
- +20 QUIT
- +21 ;
- UPINACT ;Update codes as inactive
- +1 SET ECDA=+$ORDER(^EC(725,"D",ECCODE,0))
- +2 IF $DATA(^EC(725,ECDA,0))
- Begin DoDot:1
- +3 SET DA=ECDA
- SET DR="2///^S X=ECINDT"
- SET DIE="^EC(725,"
- DO ^DIE
- +4 DO MES^XPDUTL(" "_ECCODE_" inactivated as of "_ECEXDT_".")
- +5 SET ECCNT2=ECCNT2+1
- End DoDot:1
- +6 QUIT
- +7 ;
- OLD ;national procedures to be inactivated - national code#^inact. date
- +1 ;;NU019^10/1/2022
- +2 ;;NU020^10/1/2022
- +3 ;;NU021^10/1/2022
- +4 ;;NU022^10/1/2022
- +5 ;;NU023^10/1/2022
- +6 ;;NU024^10/1/2022
- +7 ;;NU216^10/1/2022
- +8 ;;QUIT
- +9 ;
- 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("*** Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
- +8 DO MES^XPDUTL(" ")
- +9 ;
- +10 NEW ECCNT3,ECCNT33
- SET (ECCNT3,ECCNT33)=0
- +11 FOR ECX=1:1
- SET ECXX=$PIECE($TEXT(CPT+ECX),";;",2)
- if ECXX="QUIT"
- QUIT
- Begin DoDot:1
- +12 SET ECBEG=$PIECE(ECXX,U,3)
- SET ECEND=$PIECE(ECXX,U,4)
- SET ECCPTIEN=$PIECE(ECXX,U,2)
- +13 SET ECCPTIEN=$SELECT(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))
- +14 IF ECCPTIEN'="@"
- IF +ECCPTIEN<1
- Begin DoDot:2
- +15 SET ECSTR=$PIECE(ECXX,U)_": CPT code "_$PIECE(ECXX,U,2)_" is invalid."
- +16 DO MES^XPDUTL(" ")
- +17 DO MES^XPDUTL(" "_ECSTR)
- End DoDot:2
- QUIT
- +18 IF ECBEG=""
- SET ECCPT($PIECE(ECXX,U))=ECCPTIEN_U_$PIECE(ECXX,U,2)
- QUIT
- +19 FOR ECSEQ=ECBEG:1:ECEND
- Begin DoDot:2
- +20 SET ECADD="000"_ECSEQ
- SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
- +21 SET ECCPT($PIECE(ECXX,U)_ECADD)=ECCPTIEN_U_$PIECE(ECXX,U,2)
- End DoDot:2
- End DoDot:1
- +22 ;
- +23 SET ECXX=""
- +24 FOR
- SET ECXX=$ORDER(ECCPT(ECXX))
- if ECXX=""
- QUIT
- Begin DoDot:1
- +25 SET ECX=$ORDER(^EC(725,"D",ECXX,0))
- +26 if +ECX=0
- QUIT
- +27 IF '$DATA(^EC(725,ECX,0))!(+ECX=0)
- Begin DoDot:2
- +28 DO MES^XPDUTL(" ")
- +29 DO MES^XPDUTL(" Can't find entry for "_ECXX_",CPT code not updated.")
- +30 SET ECCNT33=ECCNT33+1
- End DoDot:2
- QUIT
- +31 SET ECCPT=$PIECE(ECCPT(ECXX),U)
- SET DA=ECX
- SET DR="4///"_ECCPT
- SET DIE="^EC(725,"
- DO ^DIE
- +32 SET ECSTR=" Entry #"_ECX_" for "_ECXX
- +33 DO MES^XPDUTL(ECSTR_" updated to use CPT code "_$PIECE(ECCPT(ECXX),U,2))
- +34 SET ECCNT3=ECCNT3+1
- End DoDot:1
- +35 ;
- +36 DO BMES^XPDUTL(" Total "_ECCNT3_" CPT codes have been updated.")
- +37 IF ECCNT33>0
- DO MES^XPDUTL(" Total "_ECCNT33_" CPT codes did NOT get updated.")
- +38 QUIT
- +39 ;
- CPT ;cpt codes to be changed - national #^new CPT code
- +1 ;;QUIT