EC725CH8 ;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 a KIDS build
;to modify the EC National Procedure file #725
;
NAMECHG ;* change national procedure names
;
; ECXX is in format:
; NATIONAL NUMBER^NEW NAME
;
N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y
D MES^XPDUTL(" ")
D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
D MES^XPDUTL(" ")
F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT" D
.I $D(^EC(725,"D",$P(ECXX,U,1))) D
..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
..I $D(^EC(725,ECDA,0)) D
...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
...D MES^XPDUTL(" ")
...D BMES^XPDUTL(" Entry #"_ECDA_" for "_$P(ECXX,U,1))
...D BMES^XPDUTL(" ...field (#.01) updated to "_$P(ECXX,U,2)_".")
.I '$D(^EC(725,"D",$P(ECXX,U,1))) D
..D MES^XPDUTL(" ")
..D BMES^XPDUTL("Can't find entry for "_$P(ECXX,U,1))
..D BMES^XPDUTL("...field (#.01) not updated.")
Q
;
CHNG ;name changes
;;SP016^APHASIA ASSESSMENT, PER HOUR
;;SP024^OTHER NONINVASIVE INSTRUM EXAM
;;SP056^NON-INSTRUMENT SWALLOWING EVAL
;;SP100^CENTRAL AUDITORY FUNCTION TEST
;;SP124^SPEECH/HEAR PROSTH DEVICE ORIENT
;;SP130^EXPERT TESTIMONY/OPINION
;;QUIT
;
ADDPROC ;* add national procedures
;
; ECXX is in format:
; NAME^NATIONAL NUMBER^CPT CODE
;
N ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
D MES^XPDUTL(" ")
D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
D MES^XPDUTL(" ")
S ECDINUM=$O(^EC(725,9999),-1),COUNT=$P(^EC(725,0),U,4)
F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
.S NAME=$P(ECXX,U,1),CODE=$P(ECXX,U,2),CPT=$P(ECXX,U,3)
.I '$D(^EC(725,"D",CODE)) D
..S X=NAME,ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,",DIC("DR")="1////^S X=CODE;4////^S X=CPT"
..D FILE^DICN
..I +Y>0 D
...S COUNT=COUNT+1
...D MES^XPDUTL(" ")
...D BMES^XPDUTL(" Entry #"_+Y_" for "_$P(Y,U,2)_" ("_CODE_")")
...D BMES^XPDUTL(" ...successfully added.")
..I Y=-1 D
...D MES^XPDUTL(" ")
...D BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
.I $D(^EC(725,"DL",CODE)) D
..S LIEN=$O(^EC(725,"DL",CODE,""))
..D MES^XPDUTL(" ")
..D BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
..D BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
..D BMES^XPDUTL(" Please inactivate this local procedure.")
..K Y
S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
Q
;
NEW ;national procedures to add
;;CRYOPRECIPITATE, THAWING^BB989^86999
;;FRESH FROZEN PLASMA, THAWI^BB990^86999
;;SASSI 2 SUBS ABS SCRN INV^PL057^96100
;;CPAQ-CHRNPAIN ACC QUESTN^PL058^96100
;;CSQ-COPING STRATEGY QUEST^PL059^96100
;;CISS-COPING INVENT STRESS^PL060^96100
;;CAI-CAREER ASSESS INVNTRY^PL061^96100
;;WRAT-R WIDE RNG ACH TST R^PL062^96100
;;ADD-ATTENTION DEFICIT DIS^PL063^96100
;;BECK DEPRESSION INV SPANISH^PL064^96100
;;ADHD-WENDER UTAH (ADHD)^PL065^96100
;;STROOP NEURO SCREENING^PL900^96100
;;PPVT PEABODY PICTURE VOCA^PL995^96100
;;LOGIC/JUDGEMENT^PL996^96100
;;Y-BOC^PL997^96100
;;CTS CATEGORY TEST SLIDES^PL998^96100
;;MHLC MULTIDIMEN LOCUS CNTR^PL999^96100
;;ORTHOTIC MATERIAL COSTS^PR001^L8499
;;ORTHOTIC LABOR MINUTES^PR002^L8499
;;PSYC PT CONST WATCH/HOUR^PS101^99199
;;SUCTIONING, 20 MIN^RT001^94799
;;TRANSPORTING VENTILATOR^RT002^94799
;;OXYGEN SETUPS, 10 MIN^RT003^94799
;;CLEANINGEQUIPMENT, 10 M^RT004^94799
;;INCENTIVESPIROMETRY, 10^RT005^94799
;;WEANING PARAMETERS15 MIN^RT006^94799
;;VENTILATOR SELF TESTS (E^RT007^94799
;;EXTUBATIONS, 15 MIN^RT008^94799
;;MONITOR EKG DURING BRONC^RT009^94799
;;CHECK AEROSOLS & DRAIN T^RT010^94799
;;NEW EQUIPSETUPS & CHANG^RT011^94799
;;VENTILATOR CHANGES (RATE^RT012^94799
;;END EXHALED C02 MANEUVER^RT013^94799
;;CUFF PRESSURE CHECKS, TR^RT014^94799
;;CYLINDEREXCHANGE, 15 MI^RT015^94799
;;METERED DOSE INHALATION^RT016^94799
;;HOME OXYGEN INSTRUCTION^RT017^94799
;;TRACH TUBE CHANGING SUBSEQ^RT993^94799
;;EXTUBATION^RT994^94799
;;QUAD COUGH^RT995^94799
;;AIRWAY CARE^RT996^94799
;;WEANING CRITERIA^RT997^94799
;;EQUIPMENTCHANGE^RT998^94799
;;TRANSPORT^RT999^99082
;;TINNITUS DEVICE SELECTION^SP261^92506
;;ASSESS/EVAL, INI, BRIEF (15MIN)^RT989^94799
;;REASSESSMENT^RT990^94799
;;TEAM CONFERENCE^RT991^94799
;;OXYGEN THERAPY^RT992^94799
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725CH8 4546 printed Dec 13, 2024@01:56:25 Page 2
EC725CH8 ;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 a KIDS build
+4 ;to modify the EC National Procedure file #725
+5 ;
NAMECHG ;* change national procedure names
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^NEW NAME
+4 ;
+5 NEW ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y
+6 DO MES^XPDUTL(" ")
+7 DO BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
+8 DO MES^XPDUTL(" ")
+9 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(CHNG+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+10 IF $DATA(^EC(725,"D",$PIECE(ECXX,U,1)))
Begin DoDot:2
+11 SET ECDA=+$ORDER(^EC(725,"D",$PIECE(ECXX,U,1),0))
+12 IF $DATA(^EC(725,ECDA,0))
Begin DoDot:3
+13 SET DA=ECDA
SET DR=".01////^S X=$P(ECXX,U,2)"
SET DIE="^EC(725,"
DO ^DIE
+14 DO MES^XPDUTL(" ")
+15 DO BMES^XPDUTL(" Entry #"_ECDA_" for "_$PIECE(ECXX,U,1))
+16 DO BMES^XPDUTL(" ...field (#.01) updated to "_$PIECE(ECXX,U,2)_".")
End DoDot:3
End DoDot:2
+17 IF '$DATA(^EC(725,"D",$PIECE(ECXX,U,1)))
Begin DoDot:2
+18 DO MES^XPDUTL(" ")
+19 DO BMES^XPDUTL("Can't find entry for "_$PIECE(ECXX,U,1))
+20 DO BMES^XPDUTL("...field (#.01) not updated.")
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
CHNG ;name changes
+1 ;;SP016^APHASIA ASSESSMENT, PER HOUR
+2 ;;SP024^OTHER NONINVASIVE INSTRUM EXAM
+3 ;;SP056^NON-INSTRUMENT SWALLOWING EVAL
+4 ;;SP100^CENTRAL AUDITORY FUNCTION TEST
+5 ;;SP124^SPEECH/HEAR PROSTH DEVICE ORIENT
+6 ;;SP130^EXPERT TESTIMONY/OPINION
+7 ;;QUIT
+8 ;
ADDPROC ;* add national procedures
+1 ;
+2 ; ECXX is in format:
+3 ; NAME^NATIONAL NUMBER^CPT CODE
+4 ;
+5 NEW ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
+6 DO MES^XPDUTL(" ")
+7 DO BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
+8 DO MES^XPDUTL(" ")
+9 SET ECDINUM=$ORDER(^EC(725,9999),-1)
SET COUNT=$PIECE(^EC(725,0),U,4)
+10 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(NEW+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+11 SET NAME=$PIECE(ECXX,U,1)
SET CODE=$PIECE(ECXX,U,2)
SET CPT=$PIECE(ECXX,U,3)
+12 IF '$DATA(^EC(725,"D",CODE))
Begin DoDot:2
+13 SET X=NAME
SET ECDINUM=ECDINUM+1
SET DINUM=ECDINUM
SET DIC(0)="L"
SET DLAYGO=725
SET DIC="^EC(725,"
SET DIC("DR")="1////^S X=CODE;4////^S X=CPT"
+14 DO FILE^DICN
+15 IF +Y>0
Begin DoDot:3
+16 SET COUNT=COUNT+1
+17 DO MES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" Entry #"_+Y_" for "_$PIECE(Y,U,2)_" ("_CODE_")")
+19 DO BMES^XPDUTL(" ...successfully added.")
End DoDot:3
+20 IF Y=-1
Begin DoDot:3
+21 DO MES^XPDUTL(" ")
+22 DO BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
End DoDot:3
End DoDot:2
+23 IF $DATA(^EC(725,"DL",CODE))
Begin DoDot:2
+24 SET LIEN=$ORDER(^EC(725,"DL",CODE,""))
+25 DO MES^XPDUTL(" ")
+26 DO BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
+27 DO BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
+28 DO BMES^XPDUTL(" Please inactivate this local procedure.")
+29 KILL Y
End DoDot:2
End DoDot:1
+30 SET $PIECE(^EC(725,0),U,4)=COUNT
SET X=$ORDER(^EC(725,999999),-1)
SET $PIECE(^EC(725,0),U,3)=X
+31 QUIT
+32 ;
NEW ;national procedures to add
+1 ;;CRYOPRECIPITATE, THAWING^BB989^86999
+2 ;;FRESH FROZEN PLASMA, THAWI^BB990^86999
+3 ;;SASSI 2 SUBS ABS SCRN INV^PL057^96100
+4 ;;CPAQ-CHRNPAIN ACC QUESTN^PL058^96100
+5 ;;CSQ-COPING STRATEGY QUEST^PL059^96100
+6 ;;CISS-COPING INVENT STRESS^PL060^96100
+7 ;;CAI-CAREER ASSESS INVNTRY^PL061^96100
+8 ;;WRAT-R WIDE RNG ACH TST R^PL062^96100
+9 ;;ADD-ATTENTION DEFICIT DIS^PL063^96100
+10 ;;BECK DEPRESSION INV SPANISH^PL064^96100
+11 ;;ADHD-WENDER UTAH (ADHD)^PL065^96100
+12 ;;STROOP NEURO SCREENING^PL900^96100
+13 ;;PPVT PEABODY PICTURE VOCA^PL995^96100
+14 ;;LOGIC/JUDGEMENT^PL996^96100
+15 ;;Y-BOC^PL997^96100
+16 ;;CTS CATEGORY TEST SLIDES^PL998^96100
+17 ;;MHLC MULTIDIMEN LOCUS CNTR^PL999^96100
+18 ;;ORTHOTIC MATERIAL COSTS^PR001^L8499
+19 ;;ORTHOTIC LABOR MINUTES^PR002^L8499
+20 ;;PSYC PT CONST WATCH/HOUR^PS101^99199
+21 ;;SUCTIONING, 20 MIN^RT001^94799
+22 ;;TRANSPORTING VENTILATOR^RT002^94799
+23 ;;OXYGEN SETUPS, 10 MIN^RT003^94799
+24 ;;CLEANINGEQUIPMENT, 10 M^RT004^94799
+25 ;;INCENTIVESPIROMETRY, 10^RT005^94799
+26 ;;WEANING PARAMETERS15 MIN^RT006^94799
+27 ;;VENTILATOR SELF TESTS (E^RT007^94799
+28 ;;EXTUBATIONS, 15 MIN^RT008^94799
+29 ;;MONITOR EKG DURING BRONC^RT009^94799
+30 ;;CHECK AEROSOLS & DRAIN T^RT010^94799
+31 ;;NEW EQUIPSETUPS & CHANG^RT011^94799
+32 ;;VENTILATOR CHANGES (RATE^RT012^94799
+33 ;;END EXHALED C02 MANEUVER^RT013^94799
+34 ;;CUFF PRESSURE CHECKS, TR^RT014^94799
+35 ;;CYLINDEREXCHANGE, 15 MI^RT015^94799
+36 ;;METERED DOSE INHALATION^RT016^94799
+37 ;;HOME OXYGEN INSTRUCTION^RT017^94799
+38 ;;TRACH TUBE CHANGING SUBSEQ^RT993^94799
+39 ;;EXTUBATION^RT994^94799
+40 ;;QUAD COUGH^RT995^94799
+41 ;;AIRWAY CARE^RT996^94799
+42 ;;WEANING CRITERIA^RT997^94799
+43 ;;EQUIPMENTCHANGE^RT998^94799
+44 ;;TRANSPORT^RT999^99082
+45 ;;TINNITUS DEVICE SELECTION^SP261^92506
+46 ;;ASSESS/EVAL, INI, BRIEF (15MIN)^RT989^94799
+47 ;;REASSESSMENT^RT990^94799
+48 ;;TEAM CONFERENCE^RT991^94799
+49 ;;OXYGEN THERAPY^RT992^94799
+50 ;;QUIT
