- EC2P146C ;ALB/DBE - EC National Procedure Update;11/28/18 12:00pm
- ;;2.0;EVENT CAPTURE;**146**;8 May 96;Build 4
- ;
- ;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 in the EC NATIONAL PROCEDURE File (#725)...")
- 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 MES^XPDUTL(" "_ECCODE_" inactivated as of "_ECEXDT_".")
- Q
- ;
- OLD ;national procedures to be inactivated - national code #^inact. date
- ;;SN101^4/1/2019
- ;;SN102^4/1/2019
- ;;SN103^4/1/2019
- ;;SN104^4/1/2019
- ;;SN105^4/1/2019
- ;;SN106^4/1/2019
- ;;SN107^4/1/2019
- ;;SN108^4/1/2019
- ;;SN109^4/1/2019
- ;;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 MES^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 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 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 MES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))
- Q
- ;
- CPT ;cpt codes to be changed - national #^new CPT code
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P146C 2909 printed Feb 18, 2025@23:21:38 Page 2
- EC2P146C ;ALB/DBE - EC National Procedure Update;11/28/18 12:00pm
- +1 ;;2.0;EVENT CAPTURE;**146**;8 May 96;Build 4
- +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 in the EC NATIONAL PROCEDURE File (#725)...")
- +10 FOR ECX=1:1
- KILL DD,DO,DA
- SET ECXX=$PIECE($TEXT(OLD+ECX),";;",2)
- if ECXX="QUIT"
- QUIT
- Begin DoDot:1
- +11 SET ECEXDT=$PIECE(ECXX,U,2)
- SET X=ECEXDT
- SET %DT="X"
- DO ^%DT
- SET ECINDT=$PIECE(Y,".",1)
- +12 SET ECCODE=$PIECE(ECXX,U)
- SET ECBEG=$PIECE(ECXX,U,3)
- SET ECEND=$PIECE(ECXX,U,4)
- SET ECCODX=ECCODE
- +13 IF ECBEG=""
- DO UPINACT
- QUIT
- +14 FOR ECSEQ=ECBEG:1:ECEND
- Begin DoDot:2
- +15 SET ECADD="000"_ECSEQ
- SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
- +16 SET ECCODE=ECCODX_ECADD
- +17 DO UPINACT
- End DoDot:2
- End DoDot:1
- +18 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 MES^XPDUTL(" "_ECCODE_" inactivated as of "_ECEXDT_".")
- End DoDot:1
- +7 QUIT
- +8 ;
- OLD ;national procedures to be inactivated - national code #^inact. date
- +1 ;;SN101^4/1/2019
- +2 ;;SN102^4/1/2019
- +3 ;;SN103^4/1/2019
- +4 ;;SN104^4/1/2019
- +5 ;;SN105^4/1/2019
- +6 ;;SN106^4/1/2019
- +7 ;;SN107^4/1/2019
- +8 ;;SN108^4/1/2019
- +9 ;;SN109^4/1/2019
- +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(" ")
- +8 DO MES^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 MES^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 MES^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 MES^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 ;;QUIT