RMPRPS34 ;HISC/RVD/HNC -Check 661.1 and Save Inventory flag ;9/2/04 12:13
;;3.0;PROSTHETICS;**34,39,48,58,64,69,76,84,91,154**;FEB 09,1996;Build 6
;RVD patch #76 - 2003 HCPCS update
; replace inactive CPT Code in #660, starting 1/1/03
;
;AAC Patch #84 - 2004 HCPCS Update
; Replace all CPT Codes with pointer 104840 - code A9900 1/1/04
; Update all Modifier codes with null
;
;HNC Patch #91 - 2004 HCPCS Update - 6/2004
; Convert R10 to R10 A
Q
EN ;entry point
S U="^",RMEXIT=0
;Check on 2907, shipping and null 2804 (patch 48)
;Check on 2972, shipping and null 2973 (patch 58)
;Check on 3475, shipping and null 3476 (patch 69)
;Check on 3915 for patch 84.
;check for the last entry and next available entry.
;
;Patch 76
;Wheelchair HCPCS not grouped together prior to calculation flag update.
;hnc/April 2003
;Wheelchair HCPCS list under HLST
;
S RM661=$P($G(^RMPR(661.1,0)),U,3) D:RM661'=3915!($D(^RMPR(661.1,3916))) G:$G(RMEXIT) EXIT
. W !,"*********************************************************"
. W !,"* Your RMPR(661.1 global is CORRUPTED, DO NOT INSTALL *"
. W !,"* the new RMPR(661.1 global. Please, contact *"
. W !,"* National IRM Help Desk at 1-888-596-4357 for HELP!!!! *"
. W !,"*********************************************************",!
. H 1 S RMEXIT=1
. Q
;
; Continue with post init...
SAVE W !,"Saving Inventory Data ...."
K RM0
K ^RMPR("INV")
S BDC=0
F S BDC=$O(^RMPR(661.1,BDC)) Q:'+BDC D
. S RM0=$P(^RMPR(661.1,BDC,0),U,9)
. Q:RM0=""
. S ^RMPR("INV",BDC)=1
. Q
W !,"Done Saving Inventory Data, please load the ^RMPR(661.1) global now"
W !,"File RMPR_3_84.GBL",!
K RM661,RMEXIT,RM0,BDC
Q
;
RESET W !,"Start Reset of the Inventory flag...."
S U="^"
S BDC=0
F S BDC=$O(^RMPR("INV",BDC)) Q:BDC'>0 D
. S $P(^RMPR(661.1,BDC,0),U,9)=1
. Q
W !!,"End Reset of the Inventory flag.",!
;
; Patch 58 - call utilities to merge duplicate HCPCS and replace
; DVG specified old HCPCS with new HCPCS
; ********** Remove or update this call for the next HCPCS update
;D PATCH58^RMPRPS35
; Patch 69 - replace specified deactivated HCPCS with new HCPCS.
;
;conversion for site with patch #61
I $D(^RMPR(661.6)),$D(^RMPR(661.7)),$D(^RMPR(661.9)) D CONV^RMPRPS36
;conversion for site without patch #61
I '$D(^RMPR(661.6)),'$D(^RMPR(661.7)),'$D(^RMPR(661.9)) D PAT76^RMPRPS35
;
UPCPT ;update Inactive CPT code starting 4/1/02
W !,"Start Converting Inactive CPT code....",!
K RMUPD
S U="^"
F ROI=3031231:0 S ROI=$O(^RMPR(660,"B",ROI)) Q:ROI'>0 F ROJ=0:0 S ROJ=$O(^RMPR(660,"B",ROI,ROJ)) Q:ROJ'>0 S RM0=$G(^RMPR(660,ROJ,0)) D
.S RMCPI=$P(RM0,U,22)
.Q:'$G(RMCPI)
.S RM60=ROJ
.S RMCPT="104840"
.S RMUPD(660,RM60_",",4.1)=RMCPT
.D FILE^DIE("","RMUPD","")
K RMUPD,ROI,ROJ,RMCPT,RMCPI,RM0,RM60
W !,"Done Converting Inactive CPT code....",!
;
DUP ;repoint duplicate HCPCS (660, 664, 664.1, 665, 661.2, 661.3
;and delete from file 661.1
;D HCPCD^RMPRPS35(113,952)
;convert amis grouper for entries w/ wheelchair hcpcs.
;D WHUP
;
KILLB ;kill & set 'B' cross reference in 661.1.
K ^RMPR(661.1,"B"),DIK
S DIK="^RMPR(661.1,",DIK(1)=".01^B" D ENALL^DIK
;
;
KILLC ;kill & set 'C' cross reference in 661.1.
K ^RMPR(661.1,"C"),DIK
S DIK="^RMPR(661.1,",DIK(1)=".02^C" D ENALL^DIK
;
KILLE ;kill & set 'E' cross reference in 661.1.
K ^RMPR(661.1,"E"),DIK
; Line below commented out for Patch 84 - Multi-index Lookup for "A9900"
; S DIK="^RMPR(661.1,",DIK(1)="2^E" D ENALL^DIK K DIK
;
W !,"Done with Installation of Patch RMPR*3*84"
;
EXIT ;EXIT
K ^RMPR("INV"),^RMPR(661.1,"RMPR"),I,RMEXIT,RM661,BDC
Q
; Patch 64 Fixes to HCPCS file
PAT64 N RMPR,RMPRFME,RMPRI,RMPR11,I
;
; Change NPPD NEW CODE
S RMPR11("D5924")=""
S RMPR11("D5934")=""
S RMPR11("L8500")=""
S RMPR11("L8501")=""
S RMPR11("L8614")=""
S RMPR11("L8619")=""
S I="" F S I=$O(RMPR11(I)) Q:I="" D
.S RMPRI=$O(^RMPR(661.1,"B",I,""))
.Q:RMPRI=""
.S RMPRI=RMPRI_","
.S RMPR(661.1,RMPRI,6)="960 A"
.D FILE^DIE("","RMPR","RMPRFME")
.W !,"HCPCS ",I," updated"
W !!,"Done HCPCS update!!!"
W !!,"Start Reindexing the 'B' cross reference of file #661.1 ..."
K ^RMPR(661.1,"B")
S DIK="^RMPR(661.1,",DIK(1)=".01^B" D ENALL^DIK
W !!,"Done Reindexing file #661.1!!!",!!
PAT64X Q
WHUP ;Wheelchair Update Record with new Grouper Number
;
Q ;DO NOT RUN
N RMPRI,RMPR,RMPRFME,RMPRY,RMPRPH,RMPRPHE,RMPRPHL,RMPRG,RMPRSTN,RMPRSITE
;loop H xref PSAS HCPCS
S RMPRPH=0
F S RMPRPH=$O(^RMPR(660,"H",RMPRPH)) Q:RMPRPH'>0 D
.S RMPRPHE=$P($G(^RMPR(661.1,RMPRPH,0)),U,1)
.;RMPRPHE external psas hcpcs file 660
.Q:RMPRPHE=""
.S RMPRI=""
.F RMPRI=1:1:58 S RMPRY=$P($T(HLST+RMPRI),";",3) D
..Q:RMPRY=""
..;RMPRY is wheelchair hcpcs
..Q:RMPRY'=RMPRPHE
..;hcpcs to update records
..S RMPRPHL=0
..F S RMPRPHL=$O(^RMPR(660,"H",RMPRPH,RMPRPHL)) Q:RMPRPHL'>0 D
...;record level
...;need site param and grouper number
...;field 8 station p4 translate to 699.9 rmprsite
...Q:'$D(^RMPR(660,RMPRPHL,0))
...S RMPRSTN=$P(^RMPR(660,RMPRPHL,0),U,10)
...Q:RMPRSTN=""
...S RMPRSITE=0
...S RMPRSITE=$O(^RMPR(669.9,"C",RMPRSTN,RMPRSITE))
...Q:RMPRSITE=""
...L +^RMPR(669.9,RMPRSITE,0):9999 I $T=0 S RMPRG=8822
...S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
...S RMPRPHLL=RMPRPHL_","
...S RMPR(660,RMPRPHLL,68)=RMPRG
...D FILE^DIE("","RMPR","RMPRFME")
Q
KILLNDS ;
F L=0:0 S PD=$O(^RMPR(661.1,L)) W !,PD," ",L Q:L=""
Q
P91 ;Patch 91
S RMPRI=""
F RMPRI=1:1:56 S RMPRY=$P($T(HLST+RMPRI),";",3) D
.S $P(^RMPR(661.1,RMPRY,0),U,6)="R10 A"
S $P(^RMPR(661.1,2763,0),U,6)="R10 B"
S $P(^RMPR(661.1,2770,0),U,6)="R10 B"
S $P(^RMPR(661.1,2864,0),U,7)="960 D"
W !,"ALL DONE"
K RMPRI,RMPRY
Q
HLST ;Wheelchair IEN to update to R10 A
;;245
;;246
;;249
;;252
;;254
;;340
;;341
;;342
;;344
;;346
;;348
;;351
;;354
;;359
;;360
;;363
;;364
;;365
;;366
;;367
;;368
;;369
;;370
;;371
;;372
;;373
;;374
;;386
;;387
;;392
;;393
;;395
;;396
;;400
;;401
;;417
;;418
;;426
;;427
;;438
;;439
;;445
;;447
;;453
;;2095
;;2096
;;2097
;;2099
;;2100
;;2101
;;2102
;;2103
;;2104
;;2790
;;2791
;;3591
;end
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPS34 6489 printed Apr 09, 2024@21:34:59 Page 2
RMPRPS34 ;HISC/RVD/HNC -Check 661.1 and Save Inventory flag ;9/2/04 12:13
+1 ;;3.0;PROSTHETICS;**34,39,48,58,64,69,76,84,91,154**;FEB 09,1996;Build 6
+2 ;RVD patch #76 - 2003 HCPCS update
+3 ; replace inactive CPT Code in #660, starting 1/1/03
+4 ;
+5 ;AAC Patch #84 - 2004 HCPCS Update
+6 ; Replace all CPT Codes with pointer 104840 - code A9900 1/1/04
+7 ; Update all Modifier codes with null
+8 ;
+9 ;HNC Patch #91 - 2004 HCPCS Update - 6/2004
+10 ; Convert R10 to R10 A
+11 QUIT
EN ;entry point
+1 SET U="^"
SET RMEXIT=0
+2 ;Check on 2907, shipping and null 2804 (patch 48)
+3 ;Check on 2972, shipping and null 2973 (patch 58)
+4 ;Check on 3475, shipping and null 3476 (patch 69)
+5 ;Check on 3915 for patch 84.
+6 ;check for the last entry and next available entry.
+7 ;
+8 ;Patch 76
+9 ;Wheelchair HCPCS not grouped together prior to calculation flag update.
+10 ;hnc/April 2003
+11 ;Wheelchair HCPCS list under HLST
+12 ;
+13 SET RM661=$PIECE($GET(^RMPR(661.1,0)),U,3)
if RM661'=3915!($DATA(^RMPR(661.1,3916)))
Begin DoDot:1
+14 WRITE !,"*********************************************************"
+15 WRITE !,"* Your RMPR(661.1 global is CORRUPTED, DO NOT INSTALL *"
+16 WRITE !,"* the new RMPR(661.1 global. Please, contact *"
+17 WRITE !,"* National IRM Help Desk at 1-888-596-4357 for HELP!!!! *"
+18 WRITE !,"*********************************************************",!
+19 HANG 1
SET RMEXIT=1
+20 QUIT
End DoDot:1
if $GET(RMEXIT)
GOTO EXIT
+21 ;
+22 ; Continue with post init...
SAVE WRITE !,"Saving Inventory Data ...."
+1 KILL RM0
+2 KILL ^RMPR("INV")
+3 SET BDC=0
+4 FOR
SET BDC=$ORDER(^RMPR(661.1,BDC))
if '+BDC
QUIT
Begin DoDot:1
+5 SET RM0=$PIECE(^RMPR(661.1,BDC,0),U,9)
+6 if RM0=""
QUIT
+7 SET ^RMPR("INV",BDC)=1
+8 QUIT
End DoDot:1
+9 WRITE !,"Done Saving Inventory Data, please load the ^RMPR(661.1) global now"
+10 WRITE !,"File RMPR_3_84.GBL",!
+11 KILL RM661,RMEXIT,RM0,BDC
+12 QUIT
+13 ;
RESET WRITE !,"Start Reset of the Inventory flag...."
+1 SET U="^"
+2 SET BDC=0
+3 FOR
SET BDC=$ORDER(^RMPR("INV",BDC))
if BDC'>0
QUIT
Begin DoDot:1
+4 SET $PIECE(^RMPR(661.1,BDC,0),U,9)=1
+5 QUIT
End DoDot:1
+6 WRITE !!,"End Reset of the Inventory flag.",!
+7 ;
+8 ; Patch 58 - call utilities to merge duplicate HCPCS and replace
+9 ; DVG specified old HCPCS with new HCPCS
+10 ; ********** Remove or update this call for the next HCPCS update
+11 ;D PATCH58^RMPRPS35
+12 ; Patch 69 - replace specified deactivated HCPCS with new HCPCS.
+13 ;
+14 ;conversion for site with patch #61
+15 IF $DATA(^RMPR(661.6))
IF $DATA(^RMPR(661.7))
IF $DATA(^RMPR(661.9))
DO CONV^RMPRPS36
+16 ;conversion for site without patch #61
+17 IF '$DATA(^RMPR(661.6))
IF '$DATA(^RMPR(661.7))
IF '$DATA(^RMPR(661.9))
DO PAT76^RMPRPS35
+18 ;
UPCPT ;update Inactive CPT code starting 4/1/02
+1 WRITE !,"Start Converting Inactive CPT code....",!
+2 KILL RMUPD
+3 SET U="^"
+4 FOR ROI=3031231:0
SET ROI=$ORDER(^RMPR(660,"B",ROI))
if ROI'>0
QUIT
FOR ROJ=0:0
SET ROJ=$ORDER(^RMPR(660,"B",ROI,ROJ))
if ROJ'>0
QUIT
SET RM0=$GET(^RMPR(660,ROJ,0))
Begin DoDot:1
+5 SET RMCPI=$PIECE(RM0,U,22)
+6 if '$GET(RMCPI)
QUIT
+7 SET RM60=ROJ
+8 SET RMCPT="104840"
+9 SET RMUPD(660,RM60_",",4.1)=RMCPT
+10 DO FILE^DIE("","RMUPD","")
End DoDot:1
+11 KILL RMUPD,ROI,ROJ,RMCPT,RMCPI,RM0,RM60
+12 WRITE !,"Done Converting Inactive CPT code....",!
+13 ;
DUP ;repoint duplicate HCPCS (660, 664, 664.1, 665, 661.2, 661.3
+1 ;and delete from file 661.1
+2 ;D HCPCD^RMPRPS35(113,952)
+3 ;convert amis grouper for entries w/ wheelchair hcpcs.
+4 ;D WHUP
+5 ;
KILLB ;kill & set 'B' cross reference in 661.1.
+1 KILL ^RMPR(661.1,"B"),DIK
+2 SET DIK="^RMPR(661.1,"
SET DIK(1)=".01^B"
DO ENALL^DIK
+3 ;
+4 ;
KILLC ;kill & set 'C' cross reference in 661.1.
+1 KILL ^RMPR(661.1,"C"),DIK
+2 SET DIK="^RMPR(661.1,"
SET DIK(1)=".02^C"
DO ENALL^DIK
+3 ;
KILLE ;kill & set 'E' cross reference in 661.1.
+1 KILL ^RMPR(661.1,"E"),DIK
+2 ; Line below commented out for Patch 84 - Multi-index Lookup for "A9900"
+3 ; S DIK="^RMPR(661.1,",DIK(1)="2^E" D ENALL^DIK K DIK
+4 ;
+5 WRITE !,"Done with Installation of Patch RMPR*3*84"
+6 ;
EXIT ;EXIT
+1 KILL ^RMPR("INV"),^RMPR(661.1,"RMPR"),I,RMEXIT,RM661,BDC
+2 QUIT
+3 ; Patch 64 Fixes to HCPCS file
PAT64 NEW RMPR,RMPRFME,RMPRI,RMPR11,I
+1 ;
+2 ; Change NPPD NEW CODE
+3 SET RMPR11("D5924")=""
+4 SET RMPR11("D5934")=""
+5 SET RMPR11("L8500")=""
+6 SET RMPR11("L8501")=""
+7 SET RMPR11("L8614")=""
+8 SET RMPR11("L8619")=""
+9 SET I=""
FOR
SET I=$ORDER(RMPR11(I))
if I=""
QUIT
Begin DoDot:1
+10 SET RMPRI=$ORDER(^RMPR(661.1,"B",I,""))
+11 if RMPRI=""
QUIT
+12 SET RMPRI=RMPRI_","
+13 SET RMPR(661.1,RMPRI,6)="960 A"
+14 DO FILE^DIE("","RMPR","RMPRFME")
+15 WRITE !,"HCPCS ",I," updated"
End DoDot:1
+16 WRITE !!,"Done HCPCS update!!!"
+17 WRITE !!,"Start Reindexing the 'B' cross reference of file #661.1 ..."
+18 KILL ^RMPR(661.1,"B")
+19 SET DIK="^RMPR(661.1,"
SET DIK(1)=".01^B"
DO ENALL^DIK
+20 WRITE !!,"Done Reindexing file #661.1!!!",!!
PAT64X QUIT
WHUP ;Wheelchair Update Record with new Grouper Number
+1 ;
+2 ;DO NOT RUN
QUIT
+3 NEW RMPRI,RMPR,RMPRFME,RMPRY,RMPRPH,RMPRPHE,RMPRPHL,RMPRG,RMPRSTN,RMPRSITE
+4 ;loop H xref PSAS HCPCS
+5 SET RMPRPH=0
+6 FOR
SET RMPRPH=$ORDER(^RMPR(660,"H",RMPRPH))
if RMPRPH'>0
QUIT
Begin DoDot:1
+7 SET RMPRPHE=$PIECE($GET(^RMPR(661.1,RMPRPH,0)),U,1)
+8 ;RMPRPHE external psas hcpcs file 660
+9 if RMPRPHE=""
QUIT
+10 SET RMPRI=""
+11 FOR RMPRI=1:1:58
SET RMPRY=$PIECE($TEXT(HLST+RMPRI),";",3)
Begin DoDot:2
+12 if RMPRY=""
QUIT
+13 ;RMPRY is wheelchair hcpcs
+14 if RMPRY'=RMPRPHE
QUIT
+15 ;hcpcs to update records
+16 SET RMPRPHL=0
+17 FOR
SET RMPRPHL=$ORDER(^RMPR(660,"H",RMPRPH,RMPRPHL))
if RMPRPHL'>0
QUIT
Begin DoDot:3
+18 ;record level
+19 ;need site param and grouper number
+20 ;field 8 station p4 translate to 699.9 rmprsite
+21 if '$DATA(^RMPR(660,RMPRPHL,0))
QUIT
+22 SET RMPRSTN=$PIECE(^RMPR(660,RMPRPHL,0),U,10)
+23 if RMPRSTN=""
QUIT
+24 SET RMPRSITE=0
+25 SET RMPRSITE=$ORDER(^RMPR(669.9,"C",RMPRSTN,RMPRSITE))
+26 if RMPRSITE=""
QUIT
+27 LOCK +^RMPR(669.9,RMPRSITE,0):9999
IF $TEST=0
SET RMPRG=8822
+28 SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
SET RMPRG=RMPRG-1
SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG
LOCK -^RMPR(669.9,RMPRSITE,0)
+29 SET RMPRPHLL=RMPRPHL_","
+30 SET RMPR(660,RMPRPHLL,68)=RMPRG
+31 DO FILE^DIE("","RMPR","RMPRFME")
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
KILLNDS ;
+1 FOR L=0:0
SET PD=$ORDER(^RMPR(661.1,L))
WRITE !,PD," ",L
if L=""
QUIT
+2 QUIT
P91 ;Patch 91
+1 SET RMPRI=""
+2 FOR RMPRI=1:1:56
SET RMPRY=$PIECE($TEXT(HLST+RMPRI),";",3)
Begin DoDot:1
+3 SET $PIECE(^RMPR(661.1,RMPRY,0),U,6)="R10 A"
End DoDot:1
+4 SET $PIECE(^RMPR(661.1,2763,0),U,6)="R10 B"
+5 SET $PIECE(^RMPR(661.1,2770,0),U,6)="R10 B"
+6 SET $PIECE(^RMPR(661.1,2864,0),U,7)="960 D"
+7 WRITE !,"ALL DONE"
+8 KILL RMPRI,RMPRY
+9 QUIT
HLST ;Wheelchair IEN to update to R10 A
+1 ;;245
+2 ;;246
+3 ;;249
+4 ;;252
+5 ;;254
+6 ;;340
+7 ;;341
+8 ;;342
+9 ;;344
+10 ;;346
+11 ;;348
+12 ;;351
+13 ;;354
+14 ;;359
+15 ;;360
+16 ;;363
+17 ;;364
+18 ;;365
+19 ;;366
+20 ;;367
+21 ;;368
+22 ;;369
+23 ;;370
+24 ;;371
+25 ;;372
+26 ;;373
+27 ;;374
+28 ;;386
+29 ;;387
+30 ;;392
+31 ;;393
+32 ;;395
+33 ;;396
+34 ;;400
+35 ;;401
+36 ;;417
+37 ;;418
+38 ;;426
+39 ;;427
+40 ;;438
+41 ;;439
+42 ;;445
+43 ;;447
+44 ;;453
+45 ;;2095
+46 ;;2096
+47 ;;2097
+48 ;;2099
+49 ;;2100
+50 ;;2101
+51 ;;2102
+52 ;;2103
+53 ;;2104
+54 ;;2790
+55 ;;2791
+56 ;;3591
+57 ;end
