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