EC725U60 ;ALB/BP - EC National Procedure Update ; 1/19/10 2:49pm
;;2.0; EVENT CAPTURE ;**111**;8 May 96;Build 12
;
;this routine is used as a post-init in a KIDS build
;to modify the EC National Procedure file #725
;
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,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
;;HH DRIVE TIME (15MIN) PSO^HH144
;;HH DRIVE TIME (15MIN) KT^HH145
;;HH DRIVE TIME (15MIN) SPCH PTH^HH146
;;INPT NUTR ED,IND,Q15M^NU187
;;STATUS - UNCLASSIFIED^NU188
;;DRIVE TIME-CBOC Q5M^NU189
;;CCHT INIT. SCREENING^NU190^99499
;;CCHT TECH ED/INSTALL^NU191^97762
;;CCHT ASSESS TX PLAN^NU192^99211
;;CCHT PHONE TX PLAN^NU193^98968
;;MOVE QUEST.W/PT1ST30^NU194^99499
;;MOV QUEST.W/PT QADL5^NU195
;;MV HOTLINE RVW&FU,Q5^NU196
;;MV QUEST.W/O PT Q10^NU197
;;MV QUEST.W/IP Q10M^NU198
;;COOK PREP/CLN2-5PT Q15^NU199
;;COOK PREP/CLN6-10PT Q15^NU200
;;COOK PREP/CLN11-20PT Q15^NU201
;;COOK PREP/CLN>20PT Q15^NU202
;;SECURE MSG CORRESPOND^NU203^98969
;;CCHT PHONE INIT SCREEN^NU204^98968
;;SENSORY INTEGRATION IND^RC099^97533
;;WHEELCHAIR ASSESSMENT^RC100^97542
;;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
;;NU007^IN/CLC NUT CARE-BASIC,10M
;;NU008^IN/CLC NUT CARE-INTRM,10M
;;NU009^IN/CLC NUT CARE-CMPLX,10M
;;NU060^DSMT ACCR GP,2-5PT,30M
;;NU061^DSMT ACCR GP,6-10PT,30M
;;NU062^DSMT ACCR GP,11-20PT,30M
;;NU063^DSMT ACCR GP,>20PT,30M
;;NU077^NUTR GP, 2-5 PT 1ST 30M
;;NU078^NUTR GP, 6-10 PT 1ST 30M
;;NU079^NUTR GP, 11-20 PT 1ST 30M
;;NU080^NUTR GP, >20 PT 1ST 30M
;;NU156^HBPC NUTR DRIVE TIME,EA 15M
;;NU162^MNT F/U EA 15M
;;NU163^MNT SUBSEQ EA 15M
;;NU164^NUT CNSG IND,1ST15M
;;NU165^CASE MGT,W/PT EA15M
;;NU166^NUT SCREENING 10M
;;NU167^OTHER OPT VISIT
;;NU168^PT EDUC 1ST 15M
;;NU169^INSLN PMP ED 1ST15M
;;NU170^GLUC FINGER STICK
;;NU171^PHONE 5-10 MIN
;;NU172^PHONE 11-20 MIN
;;NU173^PHONE 21-30 MIN
;;NU174^DSMT ACCRED IND Q30M
;;NU175^DIABMGT NONACRD1ST15
;;NU176^DIAB MGT F/U 1ST15M
;;NU177^CGM-CONT.GLUC MNTR
;;NU178^SELF-MGT ED IND,EA 30M
;;NU179^SELF MGT GP2-4,EA 30M
;;NU180^SELF MGT GP5-8,EA 30M
;;NU181^CCHT MONTHLY MONITOR
;;NU182^MNT INIT EA 15M
;;NU185^HBPC-NUTR INPT 1ST 10M
;;NU186^HBPC-NUTR IP QADL10M
;;RC001^REFER/CONS/SCREEN
;;RC002^RECORD REVIEW
;;RC003^ASMNT INIT 30M
;;RC004^ASMNT UPREVDISC 30M
;;RC005^ASMNT PROG NOTE
;;RC006^ASMNT PROG NOTE 15M
;;RC007^DISCH/COMM REF 15M
;;RC008^DISCH/COMM REF 30M
;;RC010^TEAMEETCAREPLAN 30M
;;RC014^REC CREATARTGRP 2-4
;;RC015^REC CREATARTGRP 5-20
;;RC016^REC CREATARTGRP >20
;;RC053^MUSTHER SOC IND 15M
;;RC054^MUSTHER COG IND 15M
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U60 5578 printed Nov 22, 2024@17:06:55 Page 2
EC725U60 ;ALB/BP - EC National Procedure Update ; 1/19/10 2:49pm
+1 ;;2.0; EVENT CAPTURE ;**111**;8 May 96;Build 12
+2 ;
+3 ;this routine is used as a post-init in a KIDS build
+4 ;to modify the EC National Procedure file #725
+5 ;
+6 QUIT
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 ;;HH DRIVE TIME (15MIN) PSO^HH144
+2 ;;HH DRIVE TIME (15MIN) KT^HH145
+3 ;;HH DRIVE TIME (15MIN) SPCH PTH^HH146
+4 ;;INPT NUTR ED,IND,Q15M^NU187
+5 ;;STATUS - UNCLASSIFIED^NU188
+6 ;;DRIVE TIME-CBOC Q5M^NU189
+7 ;;CCHT INIT. SCREENING^NU190^99499
+8 ;;CCHT TECH ED/INSTALL^NU191^97762
+9 ;;CCHT ASSESS TX PLAN^NU192^99211
+10 ;;CCHT PHONE TX PLAN^NU193^98968
+11 ;;MOVE QUEST.W/PT1ST30^NU194^99499
+12 ;;MOV QUEST.W/PT QADL5^NU195
+13 ;;MV HOTLINE RVW&FU,Q5^NU196
+14 ;;MV QUEST.W/O PT Q10^NU197
+15 ;;MV QUEST.W/IP Q10M^NU198
+16 ;;COOK PREP/CLN2-5PT Q15^NU199
+17 ;;COOK PREP/CLN6-10PT Q15^NU200
+18 ;;COOK PREP/CLN11-20PT Q15^NU201
+19 ;;COOK PREP/CLN>20PT Q15^NU202
+20 ;;SECURE MSG CORRESPOND^NU203^98969
+21 ;;CCHT PHONE INIT SCREEN^NU204^98968
+22 ;;SENSORY INTEGRATION IND^RC099^97533
+23 ;;WHEELCHAIR ASSESSMENT^RC100^97542
+24 ;;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 ;;NU007^IN/CLC NUT CARE-BASIC,10M
+2 ;;NU008^IN/CLC NUT CARE-INTRM,10M
+3 ;;NU009^IN/CLC NUT CARE-CMPLX,10M
+4 ;;NU060^DSMT ACCR GP,2-5PT,30M
+5 ;;NU061^DSMT ACCR GP,6-10PT,30M
+6 ;;NU062^DSMT ACCR GP,11-20PT,30M
+7 ;;NU063^DSMT ACCR GP,>20PT,30M
+8 ;;NU077^NUTR GP, 2-5 PT 1ST 30M
+9 ;;NU078^NUTR GP, 6-10 PT 1ST 30M
+10 ;;NU079^NUTR GP, 11-20 PT 1ST 30M
+11 ;;NU080^NUTR GP, >20 PT 1ST 30M
+12 ;;NU156^HBPC NUTR DRIVE TIME,EA 15M
+13 ;;NU162^MNT F/U EA 15M
+14 ;;NU163^MNT SUBSEQ EA 15M
+15 ;;NU164^NUT CNSG IND,1ST15M
+16 ;;NU165^CASE MGT,W/PT EA15M
+17 ;;NU166^NUT SCREENING 10M
+18 ;;NU167^OTHER OPT VISIT
+19 ;;NU168^PT EDUC 1ST 15M
+20 ;;NU169^INSLN PMP ED 1ST15M
+21 ;;NU170^GLUC FINGER STICK
+22 ;;NU171^PHONE 5-10 MIN
+23 ;;NU172^PHONE 11-20 MIN
+24 ;;NU173^PHONE 21-30 MIN
+25 ;;NU174^DSMT ACCRED IND Q30M
+26 ;;NU175^DIABMGT NONACRD1ST15
+27 ;;NU176^DIAB MGT F/U 1ST15M
+28 ;;NU177^CGM-CONT.GLUC MNTR
+29 ;;NU178^SELF-MGT ED IND,EA 30M
+30 ;;NU179^SELF MGT GP2-4,EA 30M
+31 ;;NU180^SELF MGT GP5-8,EA 30M
+32 ;;NU181^CCHT MONTHLY MONITOR
+33 ;;NU182^MNT INIT EA 15M
+34 ;;NU185^HBPC-NUTR INPT 1ST 10M
+35 ;;NU186^HBPC-NUTR IP QADL10M
+36 ;;RC001^REFER/CONS/SCREEN
+37 ;;RC002^RECORD REVIEW
+38 ;;RC003^ASMNT INIT 30M
+39 ;;RC004^ASMNT UPREVDISC 30M
+40 ;;RC005^ASMNT PROG NOTE
+41 ;;RC006^ASMNT PROG NOTE 15M
+42 ;;RC007^DISCH/COMM REF 15M
+43 ;;RC008^DISCH/COMM REF 30M
+44 ;;RC010^TEAMEETCAREPLAN 30M
+45 ;;RC014^REC CREATARTGRP 2-4
+46 ;;RC015^REC CREATARTGRP 5-20
+47 ;;RC016^REC CREATARTGRP >20
+48 ;;RC053^MUSTHER SOC IND 15M
+49 ;;RC054^MUSTHER COG IND 15M
+50 ;;QUIT
