- 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 Feb 19, 2025@00:03:56 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
