- EC2P162B ;HDSO/RD - EC National Procedure Update; May 19, 2023@09:50
- ;;2.0;EVENT CAPTURE;**162**;May 8, 1996;Build 2
- ;
- ; This routine is used as a post-init in a KIDS build
- ; to add new procedure codes and change procedure names
- ; in the EC National Procedure file (#725) for FY24.
- ;
- ; Reference to $$FIND1^DIC supported by ICR# 2051
- ; Reference to FILE^DICN supported by ICE # 10009
- ; Reference to ^DIE supported by ICR# 10018
- ; Reference to BMES^XPDUTL supported by ICR# 10141
- ; Reference to MES^XPDUTL supported by ICR# 10141
- ;
- Q
- ;
- 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,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
- N ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN,ECCNT1,ECCNT11
- ;
- D MES^XPDUTL("*** Adding new procedures to the EC NATIONAL PROCEDURE File (#725)...")
- ;
- S ECDINUM=$O(^EC(725,9999),-1),ECCOUNT=$P(^EC(725,0),U,4)
- S (ECCNT1,ECCNT11)=0
- F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
- .S ECNAME=$P(ECXX,U,1),ECCODE=$P(ECXX,U,2),ECCPTN=$P(ECXX,U,3),ECCODX=ECCODE
- .S ECCPT=""
- .I ECCPTN'="" S ECCPT=$$FIND1^DIC(81,"","X",ECCPTN) I +ECCPT<1 D Q
- ..S ECSTR=" CPT code "_ECCPTN_" not a valid code in CPT File."
- ..D MES^XPDUTL(" ")
- ..D MES^XPDUTL(" ["_ECCODE_"] "_ECSTR)
- .S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),ECNAMX=ECNAME
- .I ECBEG="" S X=ECNAME D FILPROC Q
- .F ECSEQ=ECBEG:1:ECEND D
- ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
- ..I $E(ECCODX,1,3)'="RCM" S ECNAME=ECNAMX_ECSEQ,X=ECNAME,ECCODE=ECCODX_ECADD
- ..E S ECNAME=ECNAMX_$E(ECADD,2,99),X=ECNAME,ECCODE=ECCODX_$E(ECADD,2,99)
- ..D FILPROC
- S $P(^EC(725,0),U,4)=ECCOUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
- D BMES^XPDUTL(" Total "_ECCNT1_" new codes have been added.")
- I ECCNT11>0 D MES^XPDUTL(" Total "_ECCNT11_" new codes have NOT added.")
- D MES^XPDUTL(" ")
- Q
- ;
- FILPROC ;File national procedures
- ;
- I '$D(^EC(725,"D",ECCODE)) D
- .S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
- .S DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"
- .D FILE^DICN
- .;
- .I +Y>0 D
- ..S ECCOUNT=ECCOUNT+1
- ..D MES^XPDUTL(" ")
- ..S ECSTR=" Entry #"_+Y_" for "_$P(Y,U,2)
- ..S ECSTR=ECSTR_$S(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"
- ..D MES^XPDUTL(ECSTR)
- ..D MES^XPDUTL(" ...successfully added.")
- ..S ECCNT1=ECCNT1+1
- .;
- .I Y=-1 D
- ..D MES^XPDUTL(" ")
- ..D BMES^XPDUTL(" ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
- ..S ECCNT11=ECCNT11+1
- ;
- I $D(^EC(725,"DL",ECCODE)) D
- .S ECLIEN=$O(^EC(725,"DL",ECCODE,""))
- .D BMES^XPDUTL(" ")
- .D MES^XPDUTL(" ** Your site has a local procedure (entry #"_ECLIEN_") in File #725")
- .D MES^XPDUTL(" which uses "_ECCODE_" as its National Number.")
- .D MES^XPDUTL(" Please inactivate this local procedure.")
- .D MES^XPDUTL(" ")
- .K Y
- Q
- ;
- NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
- ;;QUIT
- ;
- NAMECHG ;* change national procedure names
- ;
- ; ECXX is in format:
- ; NATIONAL NUMBER^NEW NAME
- ;
- N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,ECSTR,ECCNT4
- D MES^XPDUTL("*** Changing names in EC NATIONAL PROCEDURE File (#725)...")
- ;
- S ECCNT4=0
- 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 MES^XPDUTL(" ... field (#.01) updated to "_$P(ECXX,U,2)_".")
- ...S ECCNT4=ECCNT4+1
- .;
- .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
- ..D MES^XPDUTL(" ")
- ..S ECSTR="Can't find entry for "_$P(ECXX,U,1)
- ..D BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")
- ;
- D BMES^XPDUTL(" Total "_ECCNT4_" names have been changed.")
- D MES^XPDUTL(" ")
- Q
- ;
- CHNG ;name changes -national code #^new procedure name
- ;;NU189^DRIVE TIME - PT CARE, 5M
- ;;NU223^PT CARE DISCUSSION/MTG, 3M
- ;;NU500^M&E - NUTR DX RESOLVED, 0M
- ;;NU502^M&E - NUTR DX ACTIVE, 0M
- ;;NU503^M&E - NUTR DX D/C'D, 0M
- ;;NU504^M&E - NUTR DX IMPROVED, 0M
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P162B 4318 printed Jan 18, 2025@02:56:54 Page 2
- EC2P162B ;HDSO/RD - EC National Procedure Update; May 19, 2023@09:50
- +1 ;;2.0;EVENT CAPTURE;**162**;May 8, 1996;Build 2
- +2 ;
- +3 ; This routine is used as a post-init in a KIDS build
- +4 ; to add new procedure codes and change procedure names
- +5 ; in the EC National Procedure file (#725) for FY24.
- +6 ;
- +7 ; Reference to $$FIND1^DIC supported by ICR# 2051
- +8 ; Reference to FILE^DICN supported by ICE # 10009
- +9 ; Reference to ^DIE supported by ICR# 10018
- +10 ; Reference to BMES^XPDUTL supported by ICR# 10141
- +11 ; Reference to MES^XPDUTL supported by ICR# 10141
- +12 ;
- +13 QUIT
- +14 ;
- 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,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
- +7 NEW ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN,ECCNT1,ECCNT11
- +8 ;
- +9 DO MES^XPDUTL("*** Adding new procedures to the EC NATIONAL PROCEDURE File (#725)...")
- +10 ;
- +11 SET ECDINUM=$ORDER(^EC(725,9999),-1)
- SET ECCOUNT=$PIECE(^EC(725,0),U,4)
- +12 SET (ECCNT1,ECCNT11)=0
- +13 FOR ECX=1:1
- SET ECXX=$PIECE($TEXT(NEW+ECX),";;",2)
- if ECXX="QUIT"
- QUIT
- Begin DoDot:1
- +14 SET ECNAME=$PIECE(ECXX,U,1)
- SET ECCODE=$PIECE(ECXX,U,2)
- SET ECCPTN=$PIECE(ECXX,U,3)
- SET ECCODX=ECCODE
- +15 SET ECCPT=""
- +16 IF ECCPTN'=""
- SET ECCPT=$$FIND1^DIC(81,"","X",ECCPTN)
- IF +ECCPT<1
- Begin DoDot:2
- +17 SET ECSTR=" CPT code "_ECCPTN_" not a valid code in CPT File."
- +18 DO MES^XPDUTL(" ")
- +19 DO MES^XPDUTL(" ["_ECCODE_"] "_ECSTR)
- End DoDot:2
- QUIT
- +20 SET ECBEG=$PIECE(ECXX,U,4)
- SET ECEND=$PIECE(ECXX,U,5)
- SET ECNAMX=ECNAME
- +21 IF ECBEG=""
- SET X=ECNAME
- DO FILPROC
- QUIT
- +22 FOR ECSEQ=ECBEG:1:ECEND
- Begin DoDot:2
- +23 SET ECADD="000"_ECSEQ
- SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
- +24 IF $EXTRACT(ECCODX,1,3)'="RCM"
- SET ECNAME=ECNAMX_ECSEQ
- SET X=ECNAME
- SET ECCODE=ECCODX_ECADD
- +25 IF '$TEST
- SET ECNAME=ECNAMX_$EXTRACT(ECADD,2,99)
- SET X=ECNAME
- SET ECCODE=ECCODX_$EXTRACT(ECADD,2,99)
- +26 DO FILPROC
- End DoDot:2
- End DoDot:1
- +27 SET $PIECE(^EC(725,0),U,4)=ECCOUNT
- SET X=$ORDER(^EC(725,999999),-1)
- SET $PIECE(^EC(725,0),U,3)=X
- +28 DO BMES^XPDUTL(" Total "_ECCNT1_" new codes have been added.")
- +29 IF ECCNT11>0
- DO MES^XPDUTL(" Total "_ECCNT11_" new codes have NOT added.")
- +30 DO MES^XPDUTL(" ")
- +31 QUIT
- +32 ;
- FILPROC ;File national procedures
- +1 ;
- +2 IF '$DATA(^EC(725,"D",ECCODE))
- Begin DoDot:1
- +3 SET ECDINUM=ECDINUM+1
- SET DINUM=ECDINUM
- SET DIC(0)="L"
- SET DLAYGO=725
- SET DIC="^EC(725,"
- +4 SET DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"
- +5 DO FILE^DICN
- +6 ;
- +7 IF +Y>0
- Begin DoDot:2
- +8 SET ECCOUNT=ECCOUNT+1
- +9 DO MES^XPDUTL(" ")
- +10 SET ECSTR=" Entry #"_+Y_" for "_$PIECE(Y,U,2)
- +11 SET ECSTR=ECSTR_$SELECT(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"
- +12 DO MES^XPDUTL(ECSTR)
- +13 DO MES^XPDUTL(" ...successfully added.")
- +14 SET ECCNT1=ECCNT1+1
- End DoDot:2
- +15 ;
- +16 IF Y=-1
- Begin DoDot:2
- +17 DO MES^XPDUTL(" ")
- +18 DO BMES^XPDUTL(" ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
- +19 SET ECCNT11=ECCNT11+1
- End DoDot:2
- End DoDot:1
- +20 ;
- +21 IF $DATA(^EC(725,"DL",ECCODE))
- Begin DoDot:1
- +22 SET ECLIEN=$ORDER(^EC(725,"DL",ECCODE,""))
- +23 DO BMES^XPDUTL(" ")
- +24 DO MES^XPDUTL(" ** Your site has a local procedure (entry #"_ECLIEN_") in File #725")
- +25 DO MES^XPDUTL(" which uses "_ECCODE_" as its National Number.")
- +26 DO MES^XPDUTL(" Please inactivate this local procedure.")
- +27 DO MES^XPDUTL(" ")
- +28 KILL Y
- End DoDot:1
- +29 QUIT
- +30 ;
- NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
- +1 ;;QUIT
- +2 ;
- 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,ECSTR,ECCNT4
- +6 DO MES^XPDUTL("*** Changing names in EC NATIONAL PROCEDURE File (#725)...")
- +7 ;
- +8 SET ECCNT4=0
- +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 MES^XPDUTL(" ... field (#.01) updated to "_$PIECE(ECXX,U,2)_".")
- +17 SET ECCNT4=ECCNT4+1
- End DoDot:3
- End DoDot:2
- +18 ;
- +19 IF '$DATA(^EC(725,"D",$PIECE(ECXX,U,1)))
- Begin DoDot:2
- +20 DO MES^XPDUTL(" ")
- +21 SET ECSTR="Can't find entry for "_$PIECE(ECXX,U,1)
- +22 DO BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")
- End DoDot:2
- End DoDot:1
- +23 ;
- +24 DO BMES^XPDUTL(" Total "_ECCNT4_" names have been changed.")
- +25 DO MES^XPDUTL(" ")
- +26 QUIT
- +27 ;
- CHNG ;name changes -national code #^new procedure name
- +1 ;;NU189^DRIVE TIME - PT CARE, 5M
- +2 ;;NU223^PT CARE DISCUSSION/MTG, 3M
- +3 ;;NU500^M&E - NUTR DX RESOLVED, 0M
- +4 ;;NU502^M&E - NUTR DX ACTIVE, 0M
- +5 ;;NU503^M&E - NUTR DX D/C'D, 0M
- +6 ;;NU504^M&E - NUTR DX IMPROVED, 0M
- +7 ;;QUIT