- EC2P168C ;MNT/JB - EC National Procedure Update; April 19, 2024@15:50
- ;;2.0;EVENT CAPTURE;**168**;May 8, 1996;Build 8
- ;
- ; 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)
- ; for FY25.
- ;
- ; references to ^%DT supported by ICR# 10003
- ; References to $$FIND1^DIC supported by ICR# 2051
- ; References to ^DIE supported by ICR# 10018
- ; References to BMES^XPDUTL supported by ICR# 10141
- ; References to MES^XPDUTL supported by ICR# 10141
- ;
- Q
- ;
- REACT ;* reactivate national procedures
- ;
- ; ECREC is in format: CODE #^
- ;
- N ECDA,ECX,ECXX,DA,DIE,DR,ECERR,ECNT
- D BMES^XPDUTL("*** Reactivating Procedure in EC NATIONAL PROCEDURE File (#725)")
- ;
- ; Load entries
- S ECNT=0
- F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
- . S ECDA=+$O(^EC(725,"D",ECXX,0))
- . ; Check if inactive
- . I $P($G(^EC(725,ECDA,0)),U,3)'="" D
- . . K ECFDA
- . . S ECFDA(725,ECDA_",",2)=""
- . . D FILE^DIE(,"ECFDA","ECERR")
- . . ; check if error
- . . I '$D(ECERR) D BMES^XPDUTL(" Reactivated: "_ECXX_" "_$P($G(^EC(725,ECDA,0)),"^",1))
- . . I $D(ECERR) D Q
- . . . D BMES^XPDUTL(" >> ... Unable to reactivate stop code: "_ECDA)
- . . . D MES^XPDUTL(" >> ... "_$G(ECERR("DIERR",1,"TEXT",1))_".")
- . . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
- . . . K ECERR
- . . S ECNT=ECNT+1
- D BMES^XPDUTL(" Total "_ECNT_" procedure codes have been reactivated.")
- D MES^XPDUTL(" ")
- Q
- ;
- ACT ; Code to be reactivated - ;;number^
- ;;NU093
- ;;QUIT
- ;
- 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
- ;;NU149^10/1/2024
- ;;NU150^10/1/2024
- ;;NU152^10/1/2024
- ;;NU154^10/1/2024
- ;;NU195^10/1/2024
- ;;NU211^10/1/2024
- ;;NU212^10/1/2024
- ;;NU213^10/1/2024
- ;;NU214^10/1/2024
- ;;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
- ;;NU071^99078
- ;;NU072^99078
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P168C 4647 printed Feb 18, 2025@23:22:13 Page 2
- EC2P168C ;MNT/JB - EC National Procedure Update; April 19, 2024@15:50
- +1 ;;2.0;EVENT CAPTURE;**168**;May 8, 1996;Build 8
- +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 ; for FY25.
- +7 ;
- +8 ; references to ^%DT supported by ICR# 10003
- +9 ; References to $$FIND1^DIC supported by ICR# 2051
- +10 ; References to ^DIE supported by ICR# 10018
- +11 ; References to BMES^XPDUTL supported by ICR# 10141
- +12 ; References to MES^XPDUTL supported by ICR# 10141
- +13 ;
- +14 QUIT
- +15 ;
- REACT ;* reactivate national procedures
- +1 ;
- +2 ; ECREC is in format: CODE #^
- +3 ;
- +4 NEW ECDA,ECX,ECXX,DA,DIE,DR,ECERR,ECNT
- +5 DO BMES^XPDUTL("*** Reactivating Procedure in EC NATIONAL PROCEDURE File (#725)")
- +6 ;
- +7 ; Load entries
- +8 SET ECNT=0
- +9 FOR ECX=1:1
- KILL DD,DO,DA
- SET ECXX=$PIECE($TEXT(ACT+ECX),";;",2)
- if ECXX="QUIT"
- QUIT
- Begin DoDot:1
- +10 SET ECDA=+$ORDER(^EC(725,"D",ECXX,0))
- +11 ; Check if inactive
- +12 IF $PIECE($GET(^EC(725,ECDA,0)),U,3)'=""
- Begin DoDot:2
- +13 KILL ECFDA
- +14 SET ECFDA(725,ECDA_",",2)=""
- +15 DO FILE^DIE(,"ECFDA","ECERR")
- +16 ; check if error
- +17 IF '$DATA(ECERR)
- DO BMES^XPDUTL(" Reactivated: "_ECXX_" "_$PIECE($GET(^EC(725,ECDA,0)),"^",1))
- +18 IF $DATA(ECERR)
- Begin DoDot:3
- +19 DO BMES^XPDUTL(" >> ... Unable to reactivate stop code: "_ECDA)
- +20 DO MES^XPDUTL(" >> ... "_$GET(ECERR("DIERR",1,"TEXT",1))_".")
- +21 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
- +22 KILL ECERR
- End DoDot:3
- QUIT
- +23 SET ECNT=ECNT+1
- End DoDot:2
- End DoDot:1
- +24 DO BMES^XPDUTL(" Total "_ECNT_" procedure codes have been reactivated.")
- +25 DO MES^XPDUTL(" ")
- +26 QUIT
- +27 ;
- ACT ; Code to be reactivated - ;;number^
- +1 ;;NU093
- +2 ;;QUIT
- +3 ;
- 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 ;;NU149^10/1/2024
- +2 ;;NU150^10/1/2024
- +3 ;;NU152^10/1/2024
- +4 ;;NU154^10/1/2024
- +5 ;;NU195^10/1/2024
- +6 ;;NU211^10/1/2024
- +7 ;;NU212^10/1/2024
- +8 ;;NU213^10/1/2024
- +9 ;;NU214^10/1/2024
- +10 ;;QUIT
- +11 ;
- 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 ;;NU071^99078
- +2 ;;NU072^99078
- +3 ;;QUIT