- 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 Feb 18, 2025@23:22:49 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