RMPRPS35 ;HINCIO/ODJ - HCPCS Update Utilities ; 3/25/04 12:27pm
;;3.0;PROSTHETICS;**58,69,76,77,84**,FEB 09,1996
Q
;
; RVD 2/12/02 patch #76 - replace a list of deactivated for 2003 HCPCS
;
; RVD 4/25/02 patch #69 - replace a list of deactivated HCPCS.
; files (661.1 and 661.3)
; RVD patch #77 - Convert old HCPCS to new/replacement HCPCS in PIP.
; - old HCPCS not included in patch #76
; - Remove inactive flag.
;
; 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
;
; HCPCD - Change HCPCS code in files 660, 664, 664.1, 665, 665.72
; 661.2 and 661.3
; Only to be run if users off the system
; Used where the same HCPCS code has duplicate records.
; Inputs:
; RMPRHPF - IEN of HCPCS to delete
; RMPRHPT - IEN of HCPCS to copy deleted HCPCS to
;
HCPCD(RMPRHPF,RMPRHPT) ;
N RMPRI,RMPRFDA,RMPRFME,RMPRIEN,RMPRS,RMPR65P,RMPRJ,RMPRPTP
N RMPRO1,RMPRO2,RMPRO3,RMPRO4,RMPR641P,RMPR64P,X,Y,DA
;
; Start with file 660 using the H x-ref.
S RMPRI=""
F S RMPRI=$O(^RMPR(660,"H",RMPRHPF,RMPRI)) Q:RMPRI="" D
. ;
. ; Get pointer to 665 and update HCPCS multiples
. S RMPR65P=$P($G(^RMPR(660,RMPRI,0)),"^",2)
. S RMHCIT=$P($G(^RMPR(660,RMPRI,2)),"^",1)
. I RMPR65P'="" D
.. ;
.. ; Update 665.194 multiple
.. Q:'$D(^RMPR(665,RMPR65P,0))
.. S RMPRPTP=$P(^RMPR(665,RMPR65P,0),"^",1)
.. S RMPRJ=0
.. F S RMPRJ=$O(^RMPR(665,RMPR65P,"RMPOC",RMPRJ)) Q:'RMPRJ D
... Q:$P($G(^RMPR(665,RMPR65P,"RMPOC",RMPRJ,0)),"^",7)'=RMPRHPF
... S RMPRIEN=RMPRJ_","_RMPR65P_","
... K RMPRFDA,RMPRFME
... S RMPRFDA(665.194,RMPRIEN,6)=RMPRHPT
... D FILE^DIE("","RMPRFDA","RMPRFME")
... Q
.. ;
.. ; Update 665.723191 multiple
.. S RMPRO1=0
.. F S RMPRO1=$O(^RMPO(665.72,RMPRO1)) Q:'+RMPRO1 D
... S RMPRO2=0
... F S RMPRO2=$O(^RMPO(665.72,RMPRO1,1,RMPRO2)) Q:'+RMPRO2 D
.... S RMPRO3=0
.... F S RMPRO3=$O(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3)) Q:'+RMPRO3 D
..... I $D(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP)) D
...... S RMPRO4=0
...... F S RMPRO4=$O(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP,1,RMPRO4)) Q:'+RMPRO4 D
....... Q:$P($G(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP,1,RMPRO4,0)),"^",2)'=RMPRHPF
....... S RMPRIEN=RMPRO4_","_RMPRPTP_","_RMPRO3_","_RMPRO2_","_RMPRO1_","
....... K RMPRFME,RMPRFDA
....... S RMPRFDA(665.723191,RMPRIEN,2)=RMPRHPT
....... D FILE^DIE("","RMPRFDA","RMPRFME")
....... Q
...... Q
..... Q
.... Q
... Q
.. Q
. ;
. ; Update to 664.1 and 664 HCPCS multiples
. S RMPRPTP=RMPR65P ;patient pointer
. I RMPRPTP'="" D
.. ;
.. ; Update 664.16 multiple
.. S RMPR641P=""
.. F S RMPR641P=$O(^RMPR(664.1,"D",RMPRPTP,RMPR641P)) Q:RMPR641P="" D
... S RMPRJ=0
... F S RMPRJ=$O(^RMPR(664.1,RMPR641P,2,RMPRJ)) Q:'+RMPRJ D
.... Q:$P($G(^RMPR(664.1,RMPR641P,2,RMPRJ,2)),"^",1)'=RMPRHPF
.... S RMPRIEN=RMPRJ_","_RMPR641P_","
.... K RMPRFDA,RMPRFME
.... S RMPRFDA(664.16,RMPRIEN,13)=RMPRHPT
.... D FILE^DIE("","RMPRFDA","RMPRFME")
.... Q
... Q
.. Q
. S RMPRPTP=RMPR65P ;patient pointer same as 665 pointer
. I RMPRPTP'="" D
.. ;
.. ; Update 664.02 multiple
.. S RMPR64P=""
.. F S RMPR64P=$O(^RMPR(664,"C",RMPRPTP,RMPR64P)) Q:RMPR64P="" D
... S RMPRJ=0
... F S RMPRJ=$O(^RMPR(664,RMPR64P,1,RMPRJ)) Q:'+RMPRJ D
.... Q:$P($G(^RMPR(664,RMPR64P,1,RMPRJ,0)),"^",16)'=RMPRHPF
.... K RMPRFDA,RMPRFME
.... S RMPRIEN=RMPRJ_","_RMPR64P_","
.... S RMPRFDA(664.02,RMPRIEN,16)=RMPRHPT
.... D FILE^DIE("","RMPRFDA","RMPRFME")
.... Q
... Q
.. Q
. ;
. ; finally update the 660 file
. K RMPRFDA,RMPRFME
. S RMPRIEN=RMPRI_","
. S RMPRFDA(660,RMPRIEN,4.5)=RMPRHPT
. S RMPRFDA(660,RMPRIEN,37)=RMPRHPT_"-"_$P(RMHCIT,"-",2)
. D FILE^DIE("","RMPRFDA","RMPRFME")
. Q
;
; Update PIP files 661.2 and 661.3
HCPCDP S RMPRI=""
F S RMPRI=$O(^RMPR(661.2,"D",RMPRHPF,RMPRI)) Q:RMPRI="" D
. K RMPRFDA,RMPRFME
. S RMPRIEN=RMPRI_","
. S RMPRFDA(661.2,RMPRIEN,3)=RMPRHPT
. D FILE^DIE("","RMPRFDA","RMPRFME")
. Q
S RMPRI=0
F S RMPRI=$O(^RMPR(661.3,RMPRI)) Q:'+RMPRI D
. S RMPRJ=0
. F S RMPRJ=$O(^RMPR(661.3,RMPRI,1,RMPRJ)) Q:'+RMPRJ D
.. Q:$P($G(^RMPR(661.3,RMPRI,1,RMPRJ,0)),"^",1)'=RMPRHPF
.. K RMPRFDA,RMPRFME
.. S RMPRIEN=RMPRJ_","_RMPRI_","
.. S RMPRFDA(661.31,RMPRIEN,.01)=RMPRHPT
.. D FILE^DIE("","RMPRFDA","RMPRFME")
.. Q
. Q
K RMPRFDA,RMPRFME
S RMPRIEN=RMPRHPF_","
S RMPRFDA(661.1,RMPRIEN,.01)="@"
D FILE^DIE("","RMPRFDA","RMPRFME")
HCPCDX Q
;
; ITEM - move Item records from 661.1 from old to new HCPCS
;
; Inputs:
; RMPRHPO - Old HCPCS code being replaced
; RMPRHPN - New HCPCS code
;
ITEM(RMPRHPO,RMPRHPN) ;
N RMPRHPOI,RMPRHPNI,RMPRJ,RMPRFDA,RMPRFME,RMPRIEN,X,Y,DA,RMPRIENA,RMPRK
N RMPRL,RMPRS,RMPRITEM,RMPRIFLG,RML,RMPRIN,RMPRIO
K ^TMP($J,"RM")
S RMPRHPOI=$O(^RMPR(661.1,"B",RMPRHPO,"")) ;old HCPCS ien
S RMPRHPNI=$O(^RMPR(661.1,"B",RMPRHPN,"")) ;new HCPCS ien
Q:'$G(RMPRHPNI)!'$G(RMPRHPOI)
G:$D(^RMPR(661.2,"D",RMPRHPNI)) ITEMX ;quit if Items already on new HCPCS and PIP.
S RMPRIFLG=0
I $P($G(^RMPR(661.1,RMPRHPOI,0)),"^",9)'="" S RMPRIFLG=1
;
; Loop on items and copy to new HCPCS
S RML=0
;S RMPRIEN="+1,"_RMPRHPNI_","
S (RMPRJ,RMPRN)=0
I $D(^RMPR(661.1,RMPRHPNI,3,0)) S RMPRN=$P(^RMPR(661.1,RMPRHPNI,3,0),U,3)
S RMPRIENA=RMPRN
F S RMPRJ=$O(^RMPR(661.1,RMPRHPOI,3,RMPRJ)) Q:'+RMPRJ D
. K RMPRFDA,RMPRFME,DIE
. I RMPRN=0 S RMPRIENA=RMPRJ
. I RMPRN>0 S RMPRIENA=RMPRIENA+1
. S RML=RML+1
. S RMPRIEN="+"_RML_","_RMPRHPNI_","
. S RMPRFDA(661.12,RMPRIEN,.01)=$P(^RMPR(661.1,RMPRHPOI,3,RMPRJ,0),"^",1)
. I $L(RMPRFDA(661.12,RMPRIEN,.01))>30 S RMPRFDA(661.12,RMPRIEN,.01)=$E(RMPRFDA(661.12,RMPRIEN,.01),1,30)
.;don't create an entry if it's already been created.
. Q:$D(^RMPR(661.1,RMPRHPNI,3,"B",RMPRFDA(661.12,RMPRIEN,.01)))
. S ^TMP($J,"RM",RMPRJ)=RMPRIENA
. D UPDATE^DIE("","RMPRFDA","RMPRIENA","RMPRFME")
. Q
;
; Update 661.3 file
S RMPRJ=""
F S RMPRJ=$O(^RMPR(661.3,"C",RMPRHPOI,RMPRJ)) Q:RMPRJ="" D
. S RMPRK=""
. F S RMPRK=$O(^RMPR(661.3,"C",RMPRHPOI,RMPRJ,RMPRK)) Q:RMPRK="" D
.. S RMPRL=0
.. F S RMPRL=$O(^RMPR(661.3,RMPRJ,1,RMPRK,1,RMPRL)) Q:'+RMPRL D
... S RMPRS=^RMPR(661.3,RMPRJ,1,RMPRK,1,RMPRL,0)
... S RMPRITEM=$P(RMPRS,"^",1)
... S RMPRIO=$P(RMPRITEM,"-",2)
... Q:'$D(^TMP($J,"RM",RMPRIO))
... S RMPRIN=^TMP($J,"RM",RMPRIO)
... Q:'$G(RMPRIN)
... S $P(RMPRITEM,"-",1)=RMPRHPN
... S $P(RMPRITEM,"-",2)=RMPRIN
... S RMPRIEN=RMPRL_","_RMPRK_","_RMPRJ_","
... K RMPRFDA,RMPRFME
... S RMPRFDA(661.312,RMPRIEN,.01)=RMPRITEM
... D FILE^DIE("","RMPRFDA","RMPRFME")
... Q
.. S RMPRIEN=RMPRK_","_RMPRJ_","
.. K RMPRFDA,RMPRFME
.. S RMPRFDA(661.31,RMPRIEN,.01)=RMPRHPNI
.. D FILE^DIE("","RMPRFDA","RMPRFME")
.. S RMPRIFLG=1
.. Q
. Q
I RMPRIFLG D
. K RMPRFDA,RMPRFME
. S RMPRIEN=RMPRHPNI_","
. S RMPRFDA(661.1,RMPRIEN,10)=1
. D FILE^DIE("","RMPRFDA","RMPRFME")
. Q
;
; Update PIP files 661.2
S RMPRI=""
F S RMPRI=$O(^RMPR(661.2,"D",RMPRHPOI,RMPRI)) Q:RMPRI="" D
. Q:'$D(^RMPR(661.2,RMPRI,0))
. S RMHCIT=$P(^RMPR(661.2,RMPRI,0),U,9)
. K RMPRFDA,RMPRFME
. S RMPRIEN=RMPRI_","
. S RMPRFDA(661.2,RMPRIEN,3)=RMPRHPNI
. S RMPRFDA(661.2,RMPRIEN,9)=RMPRHPN_"-"_$P(RMHCIT,"-",2)
. D FILE^DIE("","RMPRFDA","RMPRFME")
. Q
;
ITEMX Q
;
; PATCH58 -
; 1 - Repoint duplicate HCPCS
; 2 - Copy item and current inventory to new HCPCS for specified list
; (patch 58 only)
PATCH58 N RMPRA,RMPRI
I '$D(IO("Q")) D
. W !!,"Repointing specified duplicate HCPCS...",!
. Q
D HCPCD(170,133) ;E0277
I '$D(IO("Q")) D
. W !!,"Repointing complete.",!
. 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
;patch #58 - replacement code
;K RMPRA
;S RMPRA(1)="K0182^A7018"
;S RMPRA(2)="K0269^E0572"
S RMFLG61=""
I '$D(^RMPR(661.6)),'$D(^RMPR(661.7)),'$D(^RMPR(661.9)) S RMFLG61=1 D CONV35^RMPRPS36
;F RMI=0:0 S RMI=$O(^RMPR(661.1,"RMPR",RMI)) Q:RMI'>0 D
;.S RMHCDA=^RMPR(661.1,"RMPR",RMI)
;.S RMHOLD=$P(RMHCDA,U,1),RMHNEW=$P(RMHCDA,U,2)
;.I '$D(IO("Q")) D
;..W !,RMHOLD," with ",RMHNEW
;.D ITEM(RMHOLD,RMHNEW)
;.Q
I '$D(IO("Q")) D
. W !!,"HCPCS replacement complete.",!
. Q
Q
CFLG ;remove calculation flag.
W !!,"Removing the Calculation flag.....",!
F RMPRI=1:1:66 S RMPRY=$P($T(FLG+RMPRI),";",4) Q:RMPRY'>0 D
.S $P(^RMPR(661.1,RMPRY,0),U,8)=""
W !!,"Done Removing Calculation flag!!!",!
Q
FLG ;REMOVE calculation flag of the ff HCPCS:
;;E1038;3884
;;E1050;264
;;E1060;265
;;E1070;269
;;E1083;271
;;E1084;270
;;E1085;272
;;E1086;273
;;E1087;274
;;E1088;275
;;E1089;276
;;E1090;277
;;E1092;278
;;E1093;279
;;E1100;280
;;E1110;281
;;E1130;282
;;E1140;283
;;E1150;284
;;E1160;285
;;E1161;3885
;;E1170;286
;;E1171;287
;;E1172;288
;;E1180;289
;;E1190;290
;;E1195;291
;;E1200;292
;;E1210;293
;;E1211;294
;;E1212;295
;;E1213;296
;;E1220;297
;;E1221;298
;;E1222;299
;;E1223;300
;;E1224;301
;;E1225;302
;;E1226;303
;;E1227;304
;;E1228;305
;;E1230;306
;;E1240;307
;;E1250;308
;;E1260;309
;;E1270;310
;;E1280;311
;;E1285;312
;;E1290;313
;;E1295;314
;;E1296;315
;;E1297;316
;;E1298;317
;;K0001;339
;;K0002;340
;;K0003;341
;;K0004;342
;;K0005;343
;;K0006;344
;;K0007;345
;;K0009;347
;;K0010;348
;;K0011;349
;;K0012;350
;;K0014;352
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPS35 9890 printed Dec 13, 2024@02:37:27 Page 2
RMPRPS35 ;HINCIO/ODJ - HCPCS Update Utilities ; 3/25/04 12:27pm
+1 ;;3.0;PROSTHETICS;**58,69,76,77,84**,FEB 09,1996
+2 QUIT
+3 ;
+4 ; RVD 2/12/02 patch #76 - replace a list of deactivated for 2003 HCPCS
+5 ;
+6 ; RVD 4/25/02 patch #69 - replace a list of deactivated HCPCS.
+7 ; files (661.1 and 661.3)
+8 ; RVD patch #77 - Convert old HCPCS to new/replacement HCPCS in PIP.
+9 ; - old HCPCS not included in patch #76
+10 ; - Remove inactive flag.
+11 ;
+12 ; AAC 3/26/04 - Patch 84: Convert old HCPCS to new/replacement HCPCS in PIP.
+13 ; Replace all CPT Codes with pointer 104840 - code A9900 begin with 1/1/04
+14 ; Update all Modifier codes with null
+15 ;
+16 ; HCPCD - Change HCPCS code in files 660, 664, 664.1, 665, 665.72
+17 ; 661.2 and 661.3
+18 ; Only to be run if users off the system
+19 ; Used where the same HCPCS code has duplicate records.
+20 ; Inputs:
+21 ; RMPRHPF - IEN of HCPCS to delete
+22 ; RMPRHPT - IEN of HCPCS to copy deleted HCPCS to
+23 ;
HCPCD(RMPRHPF,RMPRHPT) ;
+1 NEW RMPRI,RMPRFDA,RMPRFME,RMPRIEN,RMPRS,RMPR65P,RMPRJ,RMPRPTP
+2 NEW RMPRO1,RMPRO2,RMPRO3,RMPRO4,RMPR641P,RMPR64P,X,Y,DA
+3 ;
+4 ; Start with file 660 using the H x-ref.
+5 SET RMPRI=""
+6 FOR
SET RMPRI=$ORDER(^RMPR(660,"H",RMPRHPF,RMPRI))
if RMPRI=""
QUIT
Begin DoDot:1
+7 ;
+8 ; Get pointer to 665 and update HCPCS multiples
+9 SET RMPR65P=$PIECE($GET(^RMPR(660,RMPRI,0)),"^",2)
+10 SET RMHCIT=$PIECE($GET(^RMPR(660,RMPRI,2)),"^",1)
+11 IF RMPR65P'=""
Begin DoDot:2
+12 ;
+13 ; Update 665.194 multiple
+14 if '$DATA(^RMPR(665,RMPR65P,0))
QUIT
+15 SET RMPRPTP=$PIECE(^RMPR(665,RMPR65P,0),"^",1)
+16 SET RMPRJ=0
+17 FOR
SET RMPRJ=$ORDER(^RMPR(665,RMPR65P,"RMPOC",RMPRJ))
if 'RMPRJ
QUIT
Begin DoDot:3
+18 if $PIECE($GET(^RMPR(665,RMPR65P,"RMPOC",RMPRJ,0)),"^",7)'=RMPRHPF
QUIT
+19 SET RMPRIEN=RMPRJ_","_RMPR65P_","
+20 KILL RMPRFDA,RMPRFME
+21 SET RMPRFDA(665.194,RMPRIEN,6)=RMPRHPT
+22 DO FILE^DIE("","RMPRFDA","RMPRFME")
+23 QUIT
End DoDot:3
+24 ;
+25 ; Update 665.723191 multiple
+26 SET RMPRO1=0
+27 FOR
SET RMPRO1=$ORDER(^RMPO(665.72,RMPRO1))
if '+RMPRO1
QUIT
Begin DoDot:3
+28 SET RMPRO2=0
+29 FOR
SET RMPRO2=$ORDER(^RMPO(665.72,RMPRO1,1,RMPRO2))
if '+RMPRO2
QUIT
Begin DoDot:4
+30 SET RMPRO3=0
+31 FOR
SET RMPRO3=$ORDER(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3))
if '+RMPRO3
QUIT
Begin DoDot:5
+32 IF $DATA(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP))
Begin DoDot:6
+33 SET RMPRO4=0
+34 FOR
SET RMPRO4=$ORDER(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP,1,RMPRO4))
if '+RMPRO4
QUIT
Begin DoDot:7
+35 if $PIECE($GET(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP,1,RMPRO4,0)),"^",2)'=RMPRHPF
QUIT
+36 SET RMPRIEN=RMPRO4_","_RMPRPTP_","_RMPRO3_","_RMPRO2_","_RMPRO1_","
+37 KILL RMPRFME,RMPRFDA
+38 SET RMPRFDA(665.723191,RMPRIEN,2)=RMPRHPT
+39 DO FILE^DIE("","RMPRFDA","RMPRFME")
+40 QUIT
End DoDot:7
+41 QUIT
End DoDot:6
+42 QUIT
End DoDot:5
+43 QUIT
End DoDot:4
+44 QUIT
End DoDot:3
+45 QUIT
End DoDot:2
+46 ;
+47 ; Update to 664.1 and 664 HCPCS multiples
+48 ;patient pointer
SET RMPRPTP=RMPR65P
+49 IF RMPRPTP'=""
Begin DoDot:2
+50 ;
+51 ; Update 664.16 multiple
+52 SET RMPR641P=""
+53 FOR
SET RMPR641P=$ORDER(^RMPR(664.1,"D",RMPRPTP,RMPR641P))
if RMPR641P=""
QUIT
Begin DoDot:3
+54 SET RMPRJ=0
+55 FOR
SET RMPRJ=$ORDER(^RMPR(664.1,RMPR641P,2,RMPRJ))
if '+RMPRJ
QUIT
Begin DoDot:4
+56 if $PIECE($GET(^RMPR(664.1,RMPR641P,2,RMPRJ,2)),"^",1)'=RMPRHPF
QUIT
+57 SET RMPRIEN=RMPRJ_","_RMPR641P_","
+58 KILL RMPRFDA,RMPRFME
+59 SET RMPRFDA(664.16,RMPRIEN,13)=RMPRHPT
+60 DO FILE^DIE("","RMPRFDA","RMPRFME")
+61 QUIT
End DoDot:4
+62 QUIT
End DoDot:3
+63 QUIT
End DoDot:2
+64 ;patient pointer same as 665 pointer
SET RMPRPTP=RMPR65P
+65 IF RMPRPTP'=""
Begin DoDot:2
+66 ;
+67 ; Update 664.02 multiple
+68 SET RMPR64P=""
+69 FOR
SET RMPR64P=$ORDER(^RMPR(664,"C",RMPRPTP,RMPR64P))
if RMPR64P=""
QUIT
Begin DoDot:3
+70 SET RMPRJ=0
+71 FOR
SET RMPRJ=$ORDER(^RMPR(664,RMPR64P,1,RMPRJ))
if '+RMPRJ
QUIT
Begin DoDot:4
+72 if $PIECE($GET(^RMPR(664,RMPR64P,1,RMPRJ,0)),"^",16)'=RMPRHPF
QUIT
+73 KILL RMPRFDA,RMPRFME
+74 SET RMPRIEN=RMPRJ_","_RMPR64P_","
+75 SET RMPRFDA(664.02,RMPRIEN,16)=RMPRHPT
+76 DO FILE^DIE("","RMPRFDA","RMPRFME")
+77 QUIT
End DoDot:4
+78 QUIT
End DoDot:3
+79 QUIT
End DoDot:2
+80 ;
+81 ; finally update the 660 file
+82 KILL RMPRFDA,RMPRFME
+83 SET RMPRIEN=RMPRI_","
+84 SET RMPRFDA(660,RMPRIEN,4.5)=RMPRHPT
+85 SET RMPRFDA(660,RMPRIEN,37)=RMPRHPT_"-"_$PIECE(RMHCIT,"-",2)
+86 DO FILE^DIE("","RMPRFDA","RMPRFME")
+87 QUIT
End DoDot:1
+88 ;
+89 ; Update PIP files 661.2 and 661.3
HCPCDP SET RMPRI=""
+1 FOR
SET RMPRI=$ORDER(^RMPR(661.2,"D",RMPRHPF,RMPRI))
if RMPRI=""
QUIT
Begin DoDot:1
+2 KILL RMPRFDA,RMPRFME
+3 SET RMPRIEN=RMPRI_","
+4 SET RMPRFDA(661.2,RMPRIEN,3)=RMPRHPT
+5 DO FILE^DIE("","RMPRFDA","RMPRFME")
+6 QUIT
End DoDot:1
+7 SET RMPRI=0
+8 FOR
SET RMPRI=$ORDER(^RMPR(661.3,RMPRI))
if '+RMPRI
QUIT
Begin DoDot:1
+9 SET RMPRJ=0
+10 FOR
SET RMPRJ=$ORDER(^RMPR(661.3,RMPRI,1,RMPRJ))
if '+RMPRJ
QUIT
Begin DoDot:2
+11 if $PIECE($GET(^RMPR(661.3,RMPRI,1,RMPRJ,0)),"^",1)'=RMPRHPF
QUIT
+12 KILL RMPRFDA,RMPRFME
+13 SET RMPRIEN=RMPRJ_","_RMPRI_","
+14 SET RMPRFDA(661.31,RMPRIEN,.01)=RMPRHPT
+15 DO FILE^DIE("","RMPRFDA","RMPRFME")
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 KILL RMPRFDA,RMPRFME
+19 SET RMPRIEN=RMPRHPF_","
+20 SET RMPRFDA(661.1,RMPRIEN,.01)="@"
+21 DO FILE^DIE("","RMPRFDA","RMPRFME")
HCPCDX QUIT
+1 ;
+2 ; ITEM - move Item records from 661.1 from old to new HCPCS
+3 ;
+4 ; Inputs:
+5 ; RMPRHPO - Old HCPCS code being replaced
+6 ; RMPRHPN - New HCPCS code
+7 ;
ITEM(RMPRHPO,RMPRHPN) ;
+1 NEW RMPRHPOI,RMPRHPNI,RMPRJ,RMPRFDA,RMPRFME,RMPRIEN,X,Y,DA,RMPRIENA,RMPRK
+2 NEW RMPRL,RMPRS,RMPRITEM,RMPRIFLG,RML,RMPRIN,RMPRIO
+3 KILL ^TMP($JOB,"RM")
+4 ;old HCPCS ien
SET RMPRHPOI=$ORDER(^RMPR(661.1,"B",RMPRHPO,""))
+5 ;new HCPCS ien
SET RMPRHPNI=$ORDER(^RMPR(661.1,"B",RMPRHPN,""))
+6 if '$GET(RMPRHPNI)!'$GET(RMPRHPOI)
QUIT
+7 ;quit if Items already on new HCPCS and PIP.
if $DATA(^RMPR(661.2,"D",RMPRHPNI))
GOTO ITEMX
+8 SET RMPRIFLG=0
+9 IF $PIECE($GET(^RMPR(661.1,RMPRHPOI,0)),"^",9)'=""
SET RMPRIFLG=1
+10 ;
+11 ; Loop on items and copy to new HCPCS
+12 SET RML=0
+13 ;S RMPRIEN="+1,"_RMPRHPNI_","
+14 SET (RMPRJ,RMPRN)=0
+15 IF $DATA(^RMPR(661.1,RMPRHPNI,3,0))
SET RMPRN=$PIECE(^RMPR(661.1,RMPRHPNI,3,0),U,3)
+16 SET RMPRIENA=RMPRN
+17 FOR
SET RMPRJ=$ORDER(^RMPR(661.1,RMPRHPOI,3,RMPRJ))
if '+RMPRJ
QUIT
Begin DoDot:1
+18 KILL RMPRFDA,RMPRFME,DIE
+19 IF RMPRN=0
SET RMPRIENA=RMPRJ
+20 IF RMPRN>0
SET RMPRIENA=RMPRIENA+1
+21 SET RML=RML+1
+22 SET RMPRIEN="+"_RML_","_RMPRHPNI_","
+23 SET RMPRFDA(661.12,RMPRIEN,.01)=$PIECE(^RMPR(661.1,RMPRHPOI,3,RMPRJ,0),"^",1)
+24 IF $LENGTH(RMPRFDA(661.12,RMPRIEN,.01))>30
SET RMPRFDA(661.12,RMPRIEN,.01)=$EXTRACT(RMPRFDA(661.12,RMPRIEN,.01),1,30)
+25 ;don't create an entry if it's already been created.
+26 if $DATA(^RMPR(661.1,RMPRHPNI,3,"B",RMPRFDA(661.12,RMPRIEN,.01)))
QUIT
+27 SET ^TMP($JOB,"RM",RMPRJ)=RMPRIENA
+28 DO UPDATE^DIE("","RMPRFDA","RMPRIENA","RMPRFME")
+29 QUIT
End DoDot:1
+30 ;
+31 ; Update 661.3 file
+32 SET RMPRJ=""
+33 FOR
SET RMPRJ=$ORDER(^RMPR(661.3,"C",RMPRHPOI,RMPRJ))
if RMPRJ=""
QUIT
Begin DoDot:1
+34 SET RMPRK=""
+35 FOR
SET RMPRK=$ORDER(^RMPR(661.3,"C",RMPRHPOI,RMPRJ,RMPRK))
if RMPRK=""
QUIT
Begin DoDot:2
+36 SET RMPRL=0
+37 FOR
SET RMPRL=$ORDER(^RMPR(661.3,RMPRJ,1,RMPRK,1,RMPRL))
if '+RMPRL
QUIT
Begin DoDot:3
+38 SET RMPRS=^RMPR(661.3,RMPRJ,1,RMPRK,1,RMPRL,0)
+39 SET RMPRITEM=$PIECE(RMPRS,"^",1)
+40 SET RMPRIO=$PIECE(RMPRITEM,"-",2)
+41 if '$DATA(^TMP($JOB,"RM",RMPRIO))
QUIT
+42 SET RMPRIN=^TMP($JOB,"RM",RMPRIO)
+43 if '$GET(RMPRIN)
QUIT
+44 SET $PIECE(RMPRITEM,"-",1)=RMPRHPN
+45 SET $PIECE(RMPRITEM,"-",2)=RMPRIN
+46 SET RMPRIEN=RMPRL_","_RMPRK_","_RMPRJ_","
+47 KILL RMPRFDA,RMPRFME
+48 SET RMPRFDA(661.312,RMPRIEN,.01)=RMPRITEM
+49 DO FILE^DIE("","RMPRFDA","RMPRFME")
+50 QUIT
End DoDot:3
+51 SET RMPRIEN=RMPRK_","_RMPRJ_","
+52 KILL RMPRFDA,RMPRFME
+53 SET RMPRFDA(661.31,RMPRIEN,.01)=RMPRHPNI
+54 DO FILE^DIE("","RMPRFDA","RMPRFME")
+55 SET RMPRIFLG=1
+56 QUIT
End DoDot:2
+57 QUIT
End DoDot:1
+58 IF RMPRIFLG
Begin DoDot:1
+59 KILL RMPRFDA,RMPRFME
+60 SET RMPRIEN=RMPRHPNI_","
+61 SET RMPRFDA(661.1,RMPRIEN,10)=1
+62 DO FILE^DIE("","RMPRFDA","RMPRFME")
+63 QUIT
End DoDot:1
+64 ;
+65 ; Update PIP files 661.2
+66 SET RMPRI=""
+67 FOR
SET RMPRI=$ORDER(^RMPR(661.2,"D",RMPRHPOI,RMPRI))
if RMPRI=""
QUIT
Begin DoDot:1
+68 if '$DATA(^RMPR(661.2,RMPRI,0))
QUIT
+69 SET RMHCIT=$PIECE(^RMPR(661.2,RMPRI,0),U,9)
+70 KILL RMPRFDA,RMPRFME
+71 SET RMPRIEN=RMPRI_","
+72 SET RMPRFDA(661.2,RMPRIEN,3)=RMPRHPNI
+73 SET RMPRFDA(661.2,RMPRIEN,9)=RMPRHPN_"-"_$PIECE(RMHCIT,"-",2)
+74 DO FILE^DIE("","RMPRFDA","RMPRFME")
+75 QUIT
End DoDot:1
+76 ;
ITEMX QUIT
+1 ;
+2 ; PATCH58 -
+3 ; 1 - Repoint duplicate HCPCS
+4 ; 2 - Copy item and current inventory to new HCPCS for specified list
+5 ; (patch 58 only)
PATCH58 NEW RMPRA,RMPRI
+1 IF '$DATA(IO("Q"))
Begin DoDot:1
+2 WRITE !!,"Repointing specified duplicate HCPCS...",!
+3 QUIT
End DoDot:1
+4 ;E0277
DO HCPCD(170,133)
+5 IF '$DATA(IO("Q"))
Begin DoDot:1
+6 WRITE !!,"Repointing complete.",!
+7 QUIT
End DoDot:1
+8 ;
+9 ;for next update, change RMPRA() local array to the HCPCS that need
+10 ;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 ;patch #58 - replacement code
+6 ;K RMPRA
+7 ;S RMPRA(1)="K0182^A7018"
+8 ;S RMPRA(2)="K0269^E0572"
+9 SET RMFLG61=""
+10 IF '$DATA(^RMPR(661.6))
IF '$DATA(^RMPR(661.7))
IF '$DATA(^RMPR(661.9))
SET RMFLG61=1
DO CONV35^RMPRPS36
+11 ;F RMI=0:0 S RMI=$O(^RMPR(661.1,"RMPR",RMI)) Q:RMI'>0 D
+12 ;.S RMHCDA=^RMPR(661.1,"RMPR",RMI)
+13 ;.S RMHOLD=$P(RMHCDA,U,1),RMHNEW=$P(RMHCDA,U,2)
+14 ;.I '$D(IO("Q")) D
+15 ;..W !,RMHOLD," with ",RMHNEW
+16 ;.D ITEM(RMHOLD,RMHNEW)
+17 ;.Q
+18 IF '$DATA(IO("Q"))
Begin DoDot:1
+19 WRITE !!,"HCPCS replacement complete.",!
+20 QUIT
End DoDot:1
+21 QUIT
CFLG ;remove calculation flag.
+1 WRITE !!,"Removing the Calculation flag.....",!
+2 FOR RMPRI=1:1:66
SET RMPRY=$PIECE($TEXT(FLG+RMPRI),";",4)
if RMPRY'>0
QUIT
Begin DoDot:1
+3 SET $PIECE(^RMPR(661.1,RMPRY,0),U,8)=""
End DoDot:1
+4 WRITE !!,"Done Removing Calculation flag!!!",!
+5 QUIT
FLG ;REMOVE calculation flag of the ff HCPCS:
+1 ;;E1038;3884
+2 ;;E1050;264
+3 ;;E1060;265
+4 ;;E1070;269
+5 ;;E1083;271
+6 ;;E1084;270
+7 ;;E1085;272
+8 ;;E1086;273
+9 ;;E1087;274
+10 ;;E1088;275
+11 ;;E1089;276
+12 ;;E1090;277
+13 ;;E1092;278
+14 ;;E1093;279
+15 ;;E1100;280
+16 ;;E1110;281
+17 ;;E1130;282
+18 ;;E1140;283
+19 ;;E1150;284
+20 ;;E1160;285
+21 ;;E1161;3885
+22 ;;E1170;286
+23 ;;E1171;287
+24 ;;E1172;288
+25 ;;E1180;289
+26 ;;E1190;290
+27 ;;E1195;291
+28 ;;E1200;292
+29 ;;E1210;293
+30 ;;E1211;294
+31 ;;E1212;295
+32 ;;E1213;296
+33 ;;E1220;297
+34 ;;E1221;298
+35 ;;E1222;299
+36 ;;E1223;300
+37 ;;E1224;301
+38 ;;E1225;302
+39 ;;E1226;303
+40 ;;E1227;304
+41 ;;E1228;305
+42 ;;E1230;306
+43 ;;E1240;307
+44 ;;E1250;308
+45 ;;E1260;309
+46 ;;E1270;310
+47 ;;E1280;311
+48 ;;E1285;312
+49 ;;E1290;313
+50 ;;E1295;314
+51 ;;E1296;315
+52 ;;E1297;316
+53 ;;E1298;317
+54 ;;K0001;339
+55 ;;K0002;340
+56 ;;K0003;341
+57 ;;K0004;342
+58 ;;K0005;343
+59 ;;K0006;344
+60 ;;K0007;345
+61 ;;K0009;347
+62 ;;K0010;348
+63 ;;K0011;349
+64 ;;K0012;350
+65 ;;K0014;352
+66 ;;END
