- EC725CH7 ;ALB/GTS/JAP - EC National Procedure Update; 10/28/98
- ;;2.0; EVENT CAPTURE ;**16**;8 May 96
- ;
- ;this routine is used as a post-init in KIDS build
- ;to modify the the EC National Procedure file #725
- ;
- INACT ;* inactivate national procedures
- ;
- ; ECXX is in format:
- ; NATIONAL NUMBER^INACTIVATION DATE
- ;
- N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT
- 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)
- .S X=ECEXDT
- .S %DT="X" D ^%DT
- .S ECINDT=$P(Y,".",1)
- .S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),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(" "_$P(ECXX,U,1)_" inactivated as of "_ECEXDT_".")
- Q
- ;
- OLD ;national procedures to be inactivated
- ;;SP002^1/1/1999
- ;;SP122^1/1/1999
- ;;SP135^1/1/1999
- ;;SP136^1/1/1999
- ;;SP138^1/1/1999
- ;;SP141^1/1/1999
- ;;SP146^1/1/1999
- ;;SP151^1/1/1999
- ;;SP156^1/1/1999
- ;;SP161^1/1/1999
- ;;SP169^1/1/1999
- ;;SP232^1/1/1999
- ;;SP240^1/1/1999
- ;;SP243^1/1/1999
- ;;SP244^1/1/1999
- ;;SP250^1/1/1999
- ;;SP251^1/1/1999
- ;;SP252^1/1/1999
- ;;QUIT
- ;
- CPTCHG ;* change cpt codes
- ;
- ; ECXX is in format:
- ; NATIONAL NUMBER^NEW CPT
- ;
- N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y
- 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" S CPT($P(ECXX,U,1))=$P(ECXX,U,2)
- S ECXX=""
- F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
- .S ECX=$O(^EC(725,"D",ECXX,0))
- .Q:+ECX=0
- .Q:'$D(^EC(725,ECX,0))
- .S CPT=CPT(ECXX)
- .S DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
- .D MES^XPDUTL(" ")
- .D BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
- .D BMES^XPDUTL(" ...updated to use CPT code "_CPT_".")
- Q
- ;
- CPT ;cpt codes to be changed
- ;;SP037^97703
- ;;SP038^97703
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725CH7 2015 printed Feb 18, 2025@23:22:48 Page 2
- EC725CH7 ;ALB/GTS/JAP - EC National Procedure Update; 10/28/98
- +1 ;;2.0; EVENT CAPTURE ;**16**;8 May 96
- +2 ;
- +3 ;this routine is used as a post-init in KIDS build
- +4 ;to modify the the EC National Procedure file #725
- +5 ;
- INACT ;* inactivate national procedures
- +1 ;
- +2 ; ECXX is in format:
- +3 ; NATIONAL NUMBER^INACTIVATION DATE
- +4 ;
- +5 NEW ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT
- +6 DO MES^XPDUTL(" ")
- +7 DO BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
- +8 DO MES^XPDUTL(" ")
- +9 FOR ECX=1:1
- KILL DD,DO,DA
- SET ECXX=$PIECE($TEXT(OLD+ECX),";;",2)
- if ECXX="QUIT"
- QUIT
- Begin DoDot:1
- +10 SET ECEXDT=$PIECE(ECXX,U,2)
- +11 SET X=ECEXDT
- +12 SET %DT="X"
- DO ^%DT
- +13 SET ECINDT=$PIECE(Y,".",1)
- +14 SET ECDA=+$ORDER(^EC(725,"D",$PIECE(ECXX,U,1),0))
- +15 IF $DATA(^EC(725,ECDA,0))
- Begin DoDot:2
- +16 SET DA=ECDA
- SET DR="2////^S X=ECINDT"
- SET DIE="^EC(725,"
- DO ^DIE
- +17 DO MES^XPDUTL(" ")
- +18 DO BMES^XPDUTL(" "_$PIECE(ECXX,U,1)_" inactivated as of "_ECEXDT_".")
- End DoDot:2
- End DoDot:1
- +19 QUIT
- +20 ;
- OLD ;national procedures to be inactivated
- +1 ;;SP002^1/1/1999
- +2 ;;SP122^1/1/1999
- +3 ;;SP135^1/1/1999
- +4 ;;SP136^1/1/1999
- +5 ;;SP138^1/1/1999
- +6 ;;SP141^1/1/1999
- +7 ;;SP146^1/1/1999
- +8 ;;SP151^1/1/1999
- +9 ;;SP156^1/1/1999
- +10 ;;SP161^1/1/1999
- +11 ;;SP169^1/1/1999
- +12 ;;SP232^1/1/1999
- +13 ;;SP240^1/1/1999
- +14 ;;SP243^1/1/1999
- +15 ;;SP244^1/1/1999
- +16 ;;SP250^1/1/1999
- +17 ;;SP251^1/1/1999
- +18 ;;SP252^1/1/1999
- +19 ;;QUIT
- +20 ;
- CPTCHG ;* change cpt codes
- +1 ;
- +2 ; ECXX is in format:
- +3 ; NATIONAL NUMBER^NEW CPT
- +4 ;
- +5 NEW ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y
- +6 DO MES^XPDUTL(" ")
- +7 DO BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)...")
- +8 DO MES^XPDUTL(" ")
- +9 FOR ECX=1:1
- SET ECXX=$PIECE($TEXT(CPT+ECX),";;",2)
- if ECXX="QUIT"
- QUIT
- SET CPT($PIECE(ECXX,U,1))=$PIECE(ECXX,U,2)
- +10 SET ECXX=""
- +11 FOR
- SET ECXX=$ORDER(CPT(ECXX))
- if ECXX=""
- QUIT
- Begin DoDot:1
- +12 SET ECX=$ORDER(^EC(725,"D",ECXX,0))
- +13 if +ECX=0
- QUIT
- +14 if '$DATA(^EC(725,ECX,0))
- QUIT
- +15 SET CPT=CPT(ECXX)
- +16 SET DA=ECX
- SET DR="4////"_CPT
- SET DIE="^EC(725,"
- DO ^DIE
- +17 DO MES^XPDUTL(" ")
- +18 DO BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
- +19 DO BMES^XPDUTL(" ...updated to use CPT code "_CPT_".")
- End DoDot:1
- +20 QUIT
- +21 ;
- CPT ;cpt codes to be changed
- +1 ;;SP037^97703
- +2 ;;SP038^97703
- +3 ;;QUIT