- EC725U40 ;ALB/GTS/JAP/GT - EC National Procedure Update; 4/03/2006
- ;;2.0; EVENT CAPTURE ;**81**;8 May 96
- ;
- ;this routine is used as a post-init in a KIDS build
- ;to modify the EC National Procedure file #725
- ;
- ADDPROC ;* add national procedures
- ;
- ; ECXX is in format:
- ; NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
- ; LAST NATIONAL NUMBER SEQUENCE
- ;
- N ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
- N ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
- 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),CPTN=$P(ECXX,U,3),CODX=CODE
- .S CPT=""
- .I CPTN'="" S CPT=$$FIND1^DIC(81,"","X",CPTN) I +CPT<1 D Q
- ..S STR=" CPT code "_CPTN_" not a valid code in CPT File."
- ..D MES^XPDUTL(" ")
- ..D BMES^XPDUTL(" ["_CODE_"] "_STR)
- .S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),NAMX=NAME
- .I ECBEG="" S X=NAME D FILPROC Q
- .F ECSEQ=ECBEG:1:ECEND D
- ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
- ..;S NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
- ..I $E(CODX,1,3)'="RCM" S NAME=NAMX_ECSEQ,X=NAME,CODE=CODX_ECADD
- ..E S NAME=NAMX_$E(ECADD,2,99),X=NAME,CODE=CODX_$E(ECADD,2,99)
- ..D FILPROC
- S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
- Q
- ;
- FILPROC ;File national procedures
- I '$D(^EC(725,"D",CODE)) D
- .S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
- .S DIC("DR")="1////^S X=CODE;4////^S X=CPT"
- .D FILE^DICN
- .I +Y>0 D
- ..S COUNT=COUNT+1
- ..D MES^XPDUTL(" ")
- ..S STR=" Entry #"_+Y_" for "_$P(Y,U,2)
- ..S STR=STR_$S(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
- ..D BMES^XPDUTL(STR_" ...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
- Q
- NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
- ;;THERAPEUTIC PROCEDURE, GROUP^SP545^97150
- ;;EDUC & TRAINING, IND, 30 MIN^SP546^98960
- ;;EDUC & TRAINING 2-4 PT, 30 MIN^SP547^98961
- ;;EDUC & TRAINING 5-8 PT, 30 MIN^SP548^98962
- ;;L8624 LITHIUM BAT,CIDEV,EARLVL^SP549^L8624
- ;;V5095 SEMI-IMPLNT MIDEAR HRDV^SP550^V5095
- ;;QUIT
- NAMECHG ;* change national procedure names
- ;
- ; ECXX is in format:
- ; NATIONAL NUMBER^NEW NAME
- ;
- N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,STR
- 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 MES^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(" ")
- ..S STR="Can't find entry for "_$P(ECXX,U,1)
- ..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
- Q
- ;
- CHNG ;name changes -national code #^new procedure name
- ;;NU157^FOOT ASSESSMENT EA 10MIN
- ;;SP038^INITIAL ACOUSTIC DEVICE FIT
- ;;SP107^INITIAL HEARING AID FIT, MON
- ;;SP108^INITIAL HEARING AID FIT, BIN
- ;;SP449^FOLLOW-UP ACOUSTIC DEV FIT
- ;;SP450^FOLLOW-UP HEARING AID FIT, MON
- ;;SP451^FOLLOW-UP HEARING AID FIT, BIN
- ;;SP506^A5120 SKIN BARRIER WIPE/SWAB
- ;;SP531^L8623 LITHIUM ION BAT,CIDEVBDY
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U40 3907 printed Feb 18, 2025@23:23 Page 2
- EC725U40 ;ALB/GTS/JAP/GT - EC National Procedure Update; 4/03/2006
- +1 ;;2.0; EVENT CAPTURE ;**81**;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 ;
- ADDPROC ;* add national procedures
- +1 ;
- +2 ; ECXX is in format:
- +3 ; NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
- +4 ; LAST NATIONAL NUMBER SEQUENCE
- +5 ;
- +6 NEW ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
- +7 NEW ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
- +8 DO MES^XPDUTL(" ")
- +9 DO BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
- +10 DO MES^XPDUTL(" ")
- +11 SET ECDINUM=$ORDER(^EC(725,9999),-1)
- SET COUNT=$PIECE(^EC(725,0),U,4)
- +12 FOR ECX=1:1
- SET ECXX=$PIECE($TEXT(NEW+ECX),";;",2)
- if ECXX="QUIT"
- QUIT
- Begin DoDot:1
- +13 SET NAME=$PIECE(ECXX,U,1)
- SET CODE=$PIECE(ECXX,U,2)
- SET CPTN=$PIECE(ECXX,U,3)
- SET CODX=CODE
- +14 SET CPT=""
- +15 IF CPTN'=""
- SET CPT=$$FIND1^DIC(81,"","X",CPTN)
- IF +CPT<1
- Begin DoDot:2
- +16 SET STR=" CPT code "_CPTN_" not a valid code in CPT File."
- +17 DO MES^XPDUTL(" ")
- +18 DO BMES^XPDUTL(" ["_CODE_"] "_STR)
- End DoDot:2
- QUIT
- +19 SET ECBEG=$PIECE(ECXX,U,4)
- SET ECEND=$PIECE(ECXX,U,5)
- SET NAMX=NAME
- +20 IF ECBEG=""
- SET X=NAME
- DO FILPROC
- QUIT
- +21 FOR ECSEQ=ECBEG:1:ECEND
- Begin DoDot:2
- +22 SET ECADD="000"_ECSEQ
- SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
- +23 ;S NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
- +24 IF $EXTRACT(CODX,1,3)'="RCM"
- SET NAME=NAMX_ECSEQ
- SET X=NAME
- SET CODE=CODX_ECADD
- +25 IF '$TEST
- SET NAME=NAMX_$EXTRACT(ECADD,2,99)
- SET X=NAME
- SET CODE=CODX_$EXTRACT(ECADD,2,99)
- +26 DO FILPROC
- End DoDot:2
- End DoDot:1
- +27 SET $PIECE(^EC(725,0),U,4)=COUNT
- SET X=$ORDER(^EC(725,999999),-1)
- SET $PIECE(^EC(725,0),U,3)=X
- +28 QUIT
- +29 ;
- FILPROC ;File national procedures
- +1 IF '$DATA(^EC(725,"D",CODE))
- Begin DoDot:1
- +2 SET ECDINUM=ECDINUM+1
- SET DINUM=ECDINUM
- SET DIC(0)="L"
- SET DLAYGO=725
- SET DIC="^EC(725,"
- +3 SET DIC("DR")="1////^S X=CODE;4////^S X=CPT"
- +4 DO FILE^DICN
- +5 IF +Y>0
- Begin DoDot:2
- +6 SET COUNT=COUNT+1
- +7 DO MES^XPDUTL(" ")
- +8 SET STR=" Entry #"_+Y_" for "_$PIECE(Y,U,2)
- +9 SET STR=STR_$SELECT(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
- +10 DO BMES^XPDUTL(STR_" ...successfully added.")
- End DoDot:2
- +11 IF Y=-1
- Begin DoDot:2
- +12 DO MES^XPDUTL(" ")
- +13 DO BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
- End DoDot:2
- End DoDot:1
- +14 IF $DATA(^EC(725,"DL",CODE))
- Begin DoDot:1
- +15 SET LIEN=$ORDER(^EC(725,"DL",CODE,""))
- +16 DO MES^XPDUTL(" ")
- +17 DO BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
- +18 DO BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
- +19 DO BMES^XPDUTL(" Please inactivate this local procedure.")
- +20 KILL Y
- End DoDot:1
- +21 QUIT
- NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
- +1 ;;THERAPEUTIC PROCEDURE, GROUP^SP545^97150
- +2 ;;EDUC & TRAINING, IND, 30 MIN^SP546^98960
- +3 ;;EDUC & TRAINING 2-4 PT, 30 MIN^SP547^98961
- +4 ;;EDUC & TRAINING 5-8 PT, 30 MIN^SP548^98962
- +5 ;;L8624 LITHIUM BAT,CIDEV,EARLVL^SP549^L8624
- +6 ;;V5095 SEMI-IMPLNT MIDEAR HRDV^SP550^V5095
- +7 ;;QUIT
- 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,STR
- +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 MES^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 SET STR="Can't find entry for "_$PIECE(ECXX,U,1)
- +20 DO BMES^XPDUTL(STR_" ...field (#.01) not updated.")
- End DoDot:2
- End DoDot:1
- +21 QUIT
- +22 ;
- CHNG ;name changes -national code #^new procedure name
- +1 ;;NU157^FOOT ASSESSMENT EA 10MIN
- +2 ;;SP038^INITIAL ACOUSTIC DEVICE FIT
- +3 ;;SP107^INITIAL HEARING AID FIT, MON
- +4 ;;SP108^INITIAL HEARING AID FIT, BIN
- +5 ;;SP449^FOLLOW-UP ACOUSTIC DEV FIT
- +6 ;;SP450^FOLLOW-UP HEARING AID FIT, MON
- +7 ;;SP451^FOLLOW-UP HEARING AID FIT, BIN
- +8 ;;SP506^A5120 SKIN BARRIER WIPE/SWAB
- +9 ;;SP531^L8623 LITHIUM ION BAT,CIDEVBDY
- +10 ;;QUIT