RMPRPS36 ;HIN CIO/RVD - HCPCS Update Utilities ; 3/25/04 12:29pm
;;3.0;PROSTHETICS;**76,77,84**,FEB 09,1996
Q
;
; RVD 2/12/03 patch #76 - replace a list of deactivated 2003 HCPCS
; for sites with patch #61 installed.
; RVD patch #77 - added list of old HCPCS in PIP for conversion.
; - added HCPCS G0290, G0291, TM100, TM101, TM101,
; TM102, TM103, TM104 and TM105.
;
; AAC 3/26/04 - Patch 84: Convert old HCPCS to new/replacement HCPCS in PIP.
; Replace all CPT Codes with pointer 104840 - code A9900 begin with 1/1/04
; Update all Modifier codes with null
;
Q
;
F6111 ; Update PIP files 661.11
K RMI
F RMI=0:0 S RMI=$O(^RMPR(661.11,"B",RMHOLD,RMI)) Q:RMI'>0 D
.S RMIT=""
.Q:'$D(^RMPR(661.11,RMI,0))
.S RMIT=$P(^RMPR(661.11,RMI,0),U,2)
.K RMPRFDA,RMPRFME
.S RMPRIEN=RMI_","
.S RMPRFDA(661.11,RMPRIEN,.01)=RMHNEW
.S RMPRFDA(661.11,RMPRIEN,6)=RMHNEW_"-"_RMIT
.D FILE^DIE("","RMPRFDA","RMPRFME")
Q
;
F614 ; Update PIP files 661.4
K RMI
F RMI=0:0 S RMI=$O(^RMPR(661.4,"B",RMHOLD,RMI)) Q:RMI'>0 D
.Q:'$D(^RMPR(661.4,RMI,0))
.K RMPRFDA,RMPRFME
.S RMPRIEN=RMI_","
.S RMPRFDA(661.4,RMPRIEN,.01)=RMHNEW
.D FILE^DIE("","RMPRFDA","RMPRFME")
Q
;
F6141 ; Update PIP files 661.41
K RMI
F RMI=0:0 S RMI=$O(^RMPR(661.41,"B",RMHOLD,RMI)) Q:RMI'>0 D
.Q:'$D(^RMPR(661.41,RMI,0))
.K RMPRFDA,RMPRFME
.S RMPRIEN=RMI_","
.S RMPRFDA(661.41,RMPRIEN,5)=RMHNEW
.D FILE^DIE("","RMPRFDA","RMPRFME")
Q
;
F616 ; Update PIP files 661.6
K RMI
F RMI=0:0 S RMI=$O(^RMPR(661.6,"B",RMHOLD,RMI)) Q:RMI'>0 D
.Q:'$D(^RMPR(661.6,RMI,0))
.K RMPRFDA,RMPRFME
.S RMPRIEN=RMI_","
.S RMPRFDA(661.6,RMPRIEN,.01)=RMHNEW
.D FILE^DIE("","RMPRFDA","RMPRFME")
Q
;
F6163 ; Update PIP files 661.63
K RMI
F RMI=0:0 S RMI=$O(^RMPR(661.63,RMI)) Q:RMI'>0 D
.S RM63DAT=^RMPR(661.63,RMI,0)
.S RM63HCP=$P(RM63DAT,U,4)
.Q:RM63HCP'=RMHOLD
.K RMPRFDA,RMPRFME
.S RMPRIEN=RMI_","
.S RMPRFDA(661.63,RMPRIEN,4)=RMHNEW
.D FILE^DIE("","RMPRFDA","RMPRFME")
Q
;
F617 ; Update PIP files 661.7
K RMI
F RMI=0:0 S RMI=$O(^RMPR(661.7,"B",RMHOLD,RMI)) Q:RMI'>0 D
.Q:'$D(^RMPR(661.7,RMI,0))
.K RMPRFDA,RMPRFME
.S RMPRIEN=RMI_","
.S RMPRFDA(661.7,RMPRIEN,.01)=RMHNEW
.D FILE^DIE("","RMPRFDA","RMPRFME")
Q
;
F619 ; Update PIP files 661.9
K RMI
F RMI=0:0 S RMI=$O(^RMPR(661.9,RMI)) Q:RMI'>0 D
.S RM9DAT=^RMPR(661.9,RMI,0)
.S RM9HCP=$P(RM9DAT,U,2)
.Q:RM9HCP'=RMHOLD
.K RMPRFDA,RMPRFME
.S RMPRIEN=RMI_","
.S RMPRFDA(661.9,RMPRIEN,1)=RMHNEW
.D FILE^DIE("","RMPRFDA","RMPRFME")
Q
;
;for next update, change RMPRA() local array to the HCPCS that need
;to be replaced.
PAT76 ; Set up array and replace HCPCS
S U="^"
I '$D(IO("Q")) D
. W !!,"Replacing the following HCPCS...",!
. Q
;list of replacement HCPCS.
;K RMPRA
;S RMPRA(1)="K0182^A7018"
;S RMPRA(2)="K0269^E0572"
S I=""
;patch #76 - replacement code
F RMIJ=0:0 S RMIJ=$O(^RMPR(661.1,"RMPR",RMIJ)) Q:RMIJ'>0 D
.S RMHDA=^RMPR(661.1,"RMPR",RMIJ)
.S RMHOLD=$P(RMHDA,"^",1),RMHNEW=$P(RMHDA,U,2)
.I '$D(IO("Q")) D
.. W !,RMHOLD," with ",RMHNEW
.;convert 661.11
.D F6111
.;convert 661.4
.D F614
.;convert 661.41
.D F6141
.;convert 661.6
.D F616
.;convert 661.7
.D F617
.;convert 661.9
.D F619
I '$D(IO("Q")) D
. W !!,"HCPCS replacement complete.",!
. Q
Q
;
PAT77 ;Convert old HCPCS and set consult service requestor in file 660.
;this label is called by patch 77 post-init.
;add new HCPCS to file #661.1
S U="^"
W !!,"Adding new PSAS HCPCS to file #661.1.....",!
S DIK="^RMPR(661.1,"
F RMI=1:1 S RMDAT=$P($T(ADDHCPC+RMI),";",3) Q:RMDAT="END" D
.S RIEN=$P(RMDAT,":",1)
.S RNOD=$P(RMDAT,":",2)
.S RDAT=$P(RMDAT,":",3)
.S RARR(RIEN)=""
.I RNOD=2 S ^RMPR(661.1,RIEN,RNOD,1,0)=RDAT
.E S ^RMPR(661.1,RIEN,RNOD)=RDAT
F RMI=0:0 S RMI=$O(RARR(RMI)) Q:RMI'>0 D
.S ^RMPR(661.1,RMI,2,0)="^661.18^1^1"
.S DA=RMI D IX1^DIK
S $P(^RMPR(661.1,0),U,3)=3915
S $P(^RMPR(661.1,0),U,4)=3035
W !!,"Done adding new PSAS HCPCS!!!",!
; D CONV
; D SCRS^RMPRPCE1
; D CFLG^RMPRPS35
Q
ADDHCPC ;list of HCPCS added in #77
;;3906:0:G0290^STENT, DRUG ELUTING W/DEL SYS^^106939^1^^960 E
;;3906:2:STENT, DRUG ELUTING WITH DELIVERY SYSTEM
;;3906:4:GY,NU
;;3907:0:G0291^STENT, DRUG ELUTING W/O DEL^^106940^1^^960 E
;;3907:2:STENT, DRUG ELUTING WITH OUT DELIVERY SYSTEM
;;3907:4:GY,NU
;;3908:0:TM100^TELEMED HOME COMPUTER/EQUIPMT^^100201^1^R80 C^900 K
;;3908:2:TELEMEDICINE HOME COMPUTER EQUIPMENT
;;3908:4:NU,RP
;;3910:0:TM102^TELEMED HOME EQUIPMENT^^100201^1^R80 C^900 K
;;3910:2:TELEMEDICINE HOME EQUIPMENT
;;3910:4:NU,RP
;;3912:0:TM104^TELEMED AUDIO/VIDEO^^100201^1^R80 C^900 K
;;3912:2:TELEMEDICINE VIDEOPHONE/AUDIO VIDEO
;;3912:4:NU,RP
;;3913:0:TM105^TELEMED WOUND CARE^^100201^1^R80 C^900 K
;;3913:2:TELEMEDICINE WOUND CARE EQUIPMENT
;;3913:4:NU,RP
;;3914:0:TM101^TELEMED VIDEO MONITOR^^100201^1^R80 C^900 K
;;3914:2:TELEMEDICINE VIDEO MONITOR
;;3914:4:NU,RP
;;3915:0:TM103^TELEMED MESSAGE/MONITORING^^100201^1^R80 C^900 K
;;3915:2:TELEMEDICINE IN HOME MESSAGE MONITORING
;;3915:4:NU,RP
;;END
CONV ;convert old HCPCS in PIP to new HCPCS
W !!,"Replacing old/INACTIVE HCPCS to new/ACTIVE HCPCS in PIP.....",!
S RMFLG61=""
I $D(^RMPR(661.6)),$D(^RMPR(661.7)),$D(^RMPR(661.9)) S RMFLG61=1
CONV35 F RMPRII=1:1 S RMHCDA=$P($T(HLST+RMPRII),";",3) Q:RMHCDA="" D
.S RMHOLD=$P(RMHCDA,U,1),RMHNEW=$P(RMHCDA,U,2)
.Q:'$D(^RMPR(661.1,"B",RMHOLD))!'$D(^RMPR(661.1,"B",RMHNEW))
.S RMHNEWI=$O(^RMPR(661.1,"B",RMHNEW,0)) Q:'$G(RMHNEWI)
.;quit if the new HCPCS has been used in stock issue.
.S RMFLG=""
.F R6I=0:0 S R6I=$O(^RMPR(660,"H",RMHNEWI,R6I)) Q:R6I'>0!$G(RMFLG) D
..I $D(^RMPR(660,R6I,0)),$P(^RMPR(660,R6I,0),U,13)=11 S RMFLG=1 Q
.Q:$G(RMFLG)
.I $G(RMFLG61) D
..;convert 661.11
..D F6111
..;convert 661.4
..D F614
..;convert 661.41
..D F6141
..;convert 661.6
..D F616
..;convert 661.7
..D F617
..;convert 661.9
..D F619
. E D ITEM^RMPRPS35(RMHOLD,RMHNEW)
I '$D(IO("Q")) W !!,"HCPCS replacement complete!!!",!
Q
;
HLST ;List of old^new HCPCS
;;E0165^E0166
;;E0943^DL191
;;E0975^E0981
;;E0979^E0978
;;E0991^E0981
;;E0993^E0982
;;E1066^E2367
;;E1069^E2366
;;K0002^E1084
;;K0003^E1240
;;K0004^E1088
;;K0006^E1290
;;K0010^E1213
;;K0016^E0973
;;K0022^E0982
;;K0025^E0966
;;K0026^E0982
;;K0027^E0982
;;K0028^E1226
;;K0029^E0981
;;K0030^E0992
;;K0031^E0978
;;K0032^E0981
;;K0033^E0981
;;K0035^E0951
;;K0036^E0952
;;K0048^E0990
;;K0049^E0995
;;K0062^E0967
;;K0063^E0967
;;K0079^E0961
;;K0080^E0974
;;K0082^E2360
;;K0083^E2361
;;K0084^E2362
;;K0085^E2363
;;K0086^E2361
;;K0087^E2365
;;K0088^E2366
;;K0089^E2367
;;K0100^E0959
;;K0103^E0972
;;K0107^E0950
;;K0112^E0980
;;K0113^E0980
;;K0268^E0561
;;K0460^E0983
;;K0461^E0984
;;K0531^E0562
;;K0538^E2402
;;K0540^A6551
;;K0541^E2500
;;K0542^E2502
;;K0543^E2508
;;K0544^E2510
;;K0545^E2511
;;K0546^E2512
;;K0547^E2599
;;K0549^E0301
;;K0550^E0302
;;K0556^L5673
;;K0557^L5679
;;K0558^L5681
;;K0559^L5683
;;L1885^L1831
;;L2102^L2106
;;L2104^L2108
;;L2122^L2126
;;L2124^L2128
;;S8180^A7523
;;S8181^A7526
;;V2116^V2199
;;V2117^V2199
;;V2216^V2299
;;V2217^V2299
;;V2316^V2399
;;V2317^V2399
;;VA123^E0470
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPS36 7531 printed Dec 13, 2024@02:37:28 Page 2
RMPRPS36 ;HIN CIO/RVD - HCPCS Update Utilities ; 3/25/04 12:29pm
+1 ;;3.0;PROSTHETICS;**76,77,84**,FEB 09,1996
+2 QUIT
+3 ;
+4 ; RVD 2/12/03 patch #76 - replace a list of deactivated 2003 HCPCS
+5 ; for sites with patch #61 installed.
+6 ; RVD patch #77 - added list of old HCPCS in PIP for conversion.
+7 ; - added HCPCS G0290, G0291, TM100, TM101, TM101,
+8 ; TM102, TM103, TM104 and TM105.
+9 ;
+10 ; AAC 3/26/04 - Patch 84: Convert old HCPCS to new/replacement HCPCS in PIP.
+11 ; Replace all CPT Codes with pointer 104840 - code A9900 begin with 1/1/04
+12 ; Update all Modifier codes with null
+13 ;
+14 QUIT
+15 ;
F6111 ; Update PIP files 661.11
+1 KILL RMI
+2 FOR RMI=0:0
SET RMI=$ORDER(^RMPR(661.11,"B",RMHOLD,RMI))
if RMI'>0
QUIT
Begin DoDot:1
+3 SET RMIT=""
+4 if '$DATA(^RMPR(661.11,RMI,0))
QUIT
+5 SET RMIT=$PIECE(^RMPR(661.11,RMI,0),U,2)
+6 KILL RMPRFDA,RMPRFME
+7 SET RMPRIEN=RMI_","
+8 SET RMPRFDA(661.11,RMPRIEN,.01)=RMHNEW
+9 SET RMPRFDA(661.11,RMPRIEN,6)=RMHNEW_"-"_RMIT
+10 DO FILE^DIE("","RMPRFDA","RMPRFME")
End DoDot:1
+11 QUIT
+12 ;
F614 ; Update PIP files 661.4
+1 KILL RMI
+2 FOR RMI=0:0
SET RMI=$ORDER(^RMPR(661.4,"B",RMHOLD,RMI))
if RMI'>0
QUIT
Begin DoDot:1
+3 if '$DATA(^RMPR(661.4,RMI,0))
QUIT
+4 KILL RMPRFDA,RMPRFME
+5 SET RMPRIEN=RMI_","
+6 SET RMPRFDA(661.4,RMPRIEN,.01)=RMHNEW
+7 DO FILE^DIE("","RMPRFDA","RMPRFME")
End DoDot:1
+8 QUIT
+9 ;
F6141 ; Update PIP files 661.41
+1 KILL RMI
+2 FOR RMI=0:0
SET RMI=$ORDER(^RMPR(661.41,"B",RMHOLD,RMI))
if RMI'>0
QUIT
Begin DoDot:1
+3 if '$DATA(^RMPR(661.41,RMI,0))
QUIT
+4 KILL RMPRFDA,RMPRFME
+5 SET RMPRIEN=RMI_","
+6 SET RMPRFDA(661.41,RMPRIEN,5)=RMHNEW
+7 DO FILE^DIE("","RMPRFDA","RMPRFME")
End DoDot:1
+8 QUIT
+9 ;
F616 ; Update PIP files 661.6
+1 KILL RMI
+2 FOR RMI=0:0
SET RMI=$ORDER(^RMPR(661.6,"B",RMHOLD,RMI))
if RMI'>0
QUIT
Begin DoDot:1
+3 if '$DATA(^RMPR(661.6,RMI,0))
QUIT
+4 KILL RMPRFDA,RMPRFME
+5 SET RMPRIEN=RMI_","
+6 SET RMPRFDA(661.6,RMPRIEN,.01)=RMHNEW
+7 DO FILE^DIE("","RMPRFDA","RMPRFME")
End DoDot:1
+8 QUIT
+9 ;
F6163 ; Update PIP files 661.63
+1 KILL RMI
+2 FOR RMI=0:0
SET RMI=$ORDER(^RMPR(661.63,RMI))
if RMI'>0
QUIT
Begin DoDot:1
+3 SET RM63DAT=^RMPR(661.63,RMI,0)
+4 SET RM63HCP=$PIECE(RM63DAT,U,4)
+5 if RM63HCP'=RMHOLD
QUIT
+6 KILL RMPRFDA,RMPRFME
+7 SET RMPRIEN=RMI_","
+8 SET RMPRFDA(661.63,RMPRIEN,4)=RMHNEW
+9 DO FILE^DIE("","RMPRFDA","RMPRFME")
End DoDot:1
+10 QUIT
+11 ;
F617 ; Update PIP files 661.7
+1 KILL RMI
+2 FOR RMI=0:0
SET RMI=$ORDER(^RMPR(661.7,"B",RMHOLD,RMI))
if RMI'>0
QUIT
Begin DoDot:1
+3 if '$DATA(^RMPR(661.7,RMI,0))
QUIT
+4 KILL RMPRFDA,RMPRFME
+5 SET RMPRIEN=RMI_","
+6 SET RMPRFDA(661.7,RMPRIEN,.01)=RMHNEW
+7 DO FILE^DIE("","RMPRFDA","RMPRFME")
End DoDot:1
+8 QUIT
+9 ;
F619 ; Update PIP files 661.9
+1 KILL RMI
+2 FOR RMI=0:0
SET RMI=$ORDER(^RMPR(661.9,RMI))
if RMI'>0
QUIT
Begin DoDot:1
+3 SET RM9DAT=^RMPR(661.9,RMI,0)
+4 SET RM9HCP=$PIECE(RM9DAT,U,2)
+5 if RM9HCP'=RMHOLD
QUIT
+6 KILL RMPRFDA,RMPRFME
+7 SET RMPRIEN=RMI_","
+8 SET RMPRFDA(661.9,RMPRIEN,1)=RMHNEW
+9 DO FILE^DIE("","RMPRFDA","RMPRFME")
End DoDot:1
+10 QUIT
+11 ;
+12 ;for next update, change RMPRA() local array to the HCPCS that need
+13 ;to be replaced.
PAT76 ; Set up array and replace HCPCS
+1 SET U="^"
+2 IF '$DATA(IO("Q"))
Begin DoDot:1
+3 WRITE !!,"Replacing the following HCPCS...",!
+4 QUIT
End DoDot:1
+5 ;list of replacement HCPCS.
+6 ;K RMPRA
+7 ;S RMPRA(1)="K0182^A7018"
+8 ;S RMPRA(2)="K0269^E0572"
+9 SET I=""
+10 ;patch #76 - replacement code
+11 FOR RMIJ=0:0
SET RMIJ=$ORDER(^RMPR(661.1,"RMPR",RMIJ))
if RMIJ'>0
QUIT
Begin DoDot:1
+12 SET RMHDA=^RMPR(661.1,"RMPR",RMIJ)
+13 SET RMHOLD=$PIECE(RMHDA,"^",1)
SET RMHNEW=$PIECE(RMHDA,U,2)
+14 IF '$DATA(IO("Q"))
Begin DoDot:2
+15 WRITE !,RMHOLD," with ",RMHNEW
End DoDot:2
+16 ;convert 661.11
+17 DO F6111
+18 ;convert 661.4
+19 DO F614
+20 ;convert 661.41
+21 DO F6141
+22 ;convert 661.6
+23 DO F616
+24 ;convert 661.7
+25 DO F617
+26 ;convert 661.9
+27 DO F619
End DoDot:1
+28 IF '$DATA(IO("Q"))
Begin DoDot:1
+29 WRITE !!,"HCPCS replacement complete.",!
+30 QUIT
End DoDot:1
+31 QUIT
+32 ;
PAT77 ;Convert old HCPCS and set consult service requestor in file 660.
+1 ;this label is called by patch 77 post-init.
+2 ;add new HCPCS to file #661.1
+3 SET U="^"
+4 WRITE !!,"Adding new PSAS HCPCS to file #661.1.....",!
+5 SET DIK="^RMPR(661.1,"
+6 FOR RMI=1:1
SET RMDAT=$PIECE($TEXT(ADDHCPC+RMI),";",3)
if RMDAT="END"
QUIT
Begin DoDot:1
+7 SET RIEN=$PIECE(RMDAT,":",1)
+8 SET RNOD=$PIECE(RMDAT,":",2)
+9 SET RDAT=$PIECE(RMDAT,":",3)
+10 SET RARR(RIEN)=""
+11 IF RNOD=2
SET ^RMPR(661.1,RIEN,RNOD,1,0)=RDAT
+12 IF '$TEST
SET ^RMPR(661.1,RIEN,RNOD)=RDAT
End DoDot:1
+13 FOR RMI=0:0
SET RMI=$ORDER(RARR(RMI))
if RMI'>0
QUIT
Begin DoDot:1
+14 SET ^RMPR(661.1,RMI,2,0)="^661.18^1^1"
+15 SET DA=RMI
DO IX1^DIK
End DoDot:1
+16 SET $PIECE(^RMPR(661.1,0),U,3)=3915
+17 SET $PIECE(^RMPR(661.1,0),U,4)=3035
+18 WRITE !!,"Done adding new PSAS HCPCS!!!",!
+19 ; D CONV
+20 ; D SCRS^RMPRPCE1
+21 ; D CFLG^RMPRPS35
+22 QUIT
ADDHCPC ;list of HCPCS added in #77
+1 ;;3906:0:G0290^STENT, DRUG ELUTING W/DEL SYS^^106939^1^^960 E
+2 ;;3906:2:STENT, DRUG ELUTING WITH DELIVERY SYSTEM
+3 ;;3906:4:GY,NU
+4 ;;3907:0:G0291^STENT, DRUG ELUTING W/O DEL^^106940^1^^960 E
+5 ;;3907:2:STENT, DRUG ELUTING WITH OUT DELIVERY SYSTEM
+6 ;;3907:4:GY,NU
+7 ;;3908:0:TM100^TELEMED HOME COMPUTER/EQUIPMT^^100201^1^R80 C^900 K
+8 ;;3908:2:TELEMEDICINE HOME COMPUTER EQUIPMENT
+9 ;;3908:4:NU,RP
+10 ;;3910:0:TM102^TELEMED HOME EQUIPMENT^^100201^1^R80 C^900 K
+11 ;;3910:2:TELEMEDICINE HOME EQUIPMENT
+12 ;;3910:4:NU,RP
+13 ;;3912:0:TM104^TELEMED AUDIO/VIDEO^^100201^1^R80 C^900 K
+14 ;;3912:2:TELEMEDICINE VIDEOPHONE/AUDIO VIDEO
+15 ;;3912:4:NU,RP
+16 ;;3913:0:TM105^TELEMED WOUND CARE^^100201^1^R80 C^900 K
+17 ;;3913:2:TELEMEDICINE WOUND CARE EQUIPMENT
+18 ;;3913:4:NU,RP
+19 ;;3914:0:TM101^TELEMED VIDEO MONITOR^^100201^1^R80 C^900 K
+20 ;;3914:2:TELEMEDICINE VIDEO MONITOR
+21 ;;3914:4:NU,RP
+22 ;;3915:0:TM103^TELEMED MESSAGE/MONITORING^^100201^1^R80 C^900 K
+23 ;;3915:2:TELEMEDICINE IN HOME MESSAGE MONITORING
+24 ;;3915:4:NU,RP
+25 ;;END
CONV ;convert old HCPCS in PIP to new HCPCS
+1 WRITE !!,"Replacing old/INACTIVE HCPCS to new/ACTIVE HCPCS in PIP.....",!
+2 SET RMFLG61=""
+3 IF $DATA(^RMPR(661.6))
IF $DATA(^RMPR(661.7))
IF $DATA(^RMPR(661.9))
SET RMFLG61=1
CONV35 FOR RMPRII=1:1
SET RMHCDA=$PIECE($TEXT(HLST+RMPRII),";",3)
if RMHCDA=""
QUIT
Begin DoDot:1
+1 SET RMHOLD=$PIECE(RMHCDA,U,1)
SET RMHNEW=$PIECE(RMHCDA,U,2)
+2 if '$DATA(^RMPR(661.1,"B",RMHOLD))!'$DATA(^RMPR(661.1,"B",RMHNEW))
QUIT
+3 SET RMHNEWI=$ORDER(^RMPR(661.1,"B",RMHNEW,0))
if '$GET(RMHNEWI)
QUIT
+4 ;quit if the new HCPCS has been used in stock issue.
+5 SET RMFLG=""
+6 FOR R6I=0:0
SET R6I=$ORDER(^RMPR(660,"H",RMHNEWI,R6I))
if R6I'>0!$GET(RMFLG)
QUIT
Begin DoDot:2
+7 IF $DATA(^RMPR(660,R6I,0))
IF $PIECE(^RMPR(660,R6I,0),U,13)=11
SET RMFLG=1
QUIT
End DoDot:2
+8 if $GET(RMFLG)
QUIT
+9 IF $GET(RMFLG61)
Begin DoDot:2
+10 ;convert 661.11
+11 DO F6111
+12 ;convert 661.4
+13 DO F614
+14 ;convert 661.41
+15 DO F6141
+16 ;convert 661.6
+17 DO F616
+18 ;convert 661.7
+19 DO F617
+20 ;convert 661.9
+21 DO F619
End DoDot:2
+22 IF '$TEST
DO ITEM^RMPRPS35(RMHOLD,RMHNEW)
End DoDot:1
+23 IF '$DATA(IO("Q"))
WRITE !!,"HCPCS replacement complete!!!",!
+24 QUIT
+25 ;
HLST ;List of old^new HCPCS
+1 ;;E0165^E0166
+2 ;;E0943^DL191
+3 ;;E0975^E0981
+4 ;;E0979^E0978
+5 ;;E0991^E0981
+6 ;;E0993^E0982
+7 ;;E1066^E2367
+8 ;;E1069^E2366
+9 ;;K0002^E1084
+10 ;;K0003^E1240
+11 ;;K0004^E1088
+12 ;;K0006^E1290
+13 ;;K0010^E1213
+14 ;;K0016^E0973
+15 ;;K0022^E0982
+16 ;;K0025^E0966
+17 ;;K0026^E0982
+18 ;;K0027^E0982
+19 ;;K0028^E1226
+20 ;;K0029^E0981
+21 ;;K0030^E0992
+22 ;;K0031^E0978
+23 ;;K0032^E0981
+24 ;;K0033^E0981
+25 ;;K0035^E0951
+26 ;;K0036^E0952
+27 ;;K0048^E0990
+28 ;;K0049^E0995
+29 ;;K0062^E0967
+30 ;;K0063^E0967
+31 ;;K0079^E0961
+32 ;;K0080^E0974
+33 ;;K0082^E2360
+34 ;;K0083^E2361
+35 ;;K0084^E2362
+36 ;;K0085^E2363
+37 ;;K0086^E2361
+38 ;;K0087^E2365
+39 ;;K0088^E2366
+40 ;;K0089^E2367
+41 ;;K0100^E0959
+42 ;;K0103^E0972
+43 ;;K0107^E0950
+44 ;;K0112^E0980
+45 ;;K0113^E0980
+46 ;;K0268^E0561
+47 ;;K0460^E0983
+48 ;;K0461^E0984
+49 ;;K0531^E0562
+50 ;;K0538^E2402
+51 ;;K0540^A6551
+52 ;;K0541^E2500
+53 ;;K0542^E2502
+54 ;;K0543^E2508
+55 ;;K0544^E2510
+56 ;;K0545^E2511
+57 ;;K0546^E2512
+58 ;;K0547^E2599
+59 ;;K0549^E0301
+60 ;;K0550^E0302
+61 ;;K0556^L5673
+62 ;;K0557^L5679
+63 ;;K0558^L5681
+64 ;;K0559^L5683
+65 ;;L1885^L1831
+66 ;;L2102^L2106
+67 ;;L2104^L2108
+68 ;;L2122^L2126
+69 ;;L2124^L2128
+70 ;;S8180^A7523
+71 ;;S8181^A7526
+72 ;;V2116^V2199
+73 ;;V2117^V2199
+74 ;;V2216^V2299
+75 ;;V2217^V2299
+76 ;;V2316^V2399
+77 ;;V2317^V2399
+78 ;;VA123^E0470
