Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRPS35

RMPRPS35.m

Go to the documentation of this file. 
  1. RMPRPS35 ;HINCIO/ODJ - HCPCS Update Utilities ; 3/25/04 12:27pm
  1.  ;;3.0;PROSTHETICS;**58,69,76,77,84**,FEB 09,1996
  1.  Q
  1.  ;
  1.  ; RVD 2/12/02 patch #76  - replace a list of deactivated for 2003 HCPCS
  1.  ;
  1.  ; RVD 4/25/02 patch #69  - replace a list of deactivated HCPCS.
  1.  ;                          files (661.1 and 661.3)
  1.  ; RVD patch #77 - Convert old HCPCS to new/replacement HCPCS in PIP.
  1.  ;               - old HCPCS not included in patch #76
  1.  ;               - Remove inactive flag.
  1.  ;
  1.  ; AAC 3/26/04 - Patch 84: Convert old HCPCS to new/replacement HCPCS in PIP.
  1.  ;               Replace all CPT Codes with pointer 104840 - code A9900 begin with 1/1/04
  1.  ;               Update all Modifier codes with null
  1.  ;
  1.  ; HCPCD - Change HCPCS code in files 660, 664, 664.1, 665, 665.72
  1.  ;                                    661.2 and 661.3
  1.  ;         Only to be run if users off the system
  1.  ;         Used where the same HCPCS code has duplicate records.
  1.  ; Inputs:
  1.  ;    RMPRHPF - IEN of HCPCS to delete
  1.  ;    RMPRHPT - IEN of HCPCS to copy deleted HCPCS to
  1.  ;
  1. HCPCD(RMPRHPF,RMPRHPT) ;
  1.  N RMPRI,RMPRFDA,RMPRFME,RMPRIEN,RMPRS,RMPR65P,RMPRJ,RMPRPTP
  1.  N RMPRO1,RMPRO2,RMPRO3,RMPRO4,RMPR641P,RMPR64P,X,Y,DA
  1.  ;
  1.  ; Start with file 660 using the H x-ref.
  1.  S RMPRI=""
  1.  F  S RMPRI=$O(^RMPR(660,"H",RMPRHPF,RMPRI)) Q:RMPRI=""  D
  1.  . ;
  1.  . ; Get pointer to 665 and update HCPCS multiples
  1.  . S RMPR65P=$P($G(^RMPR(660,RMPRI,0)),"^",2)
  1.  . S RMHCIT=$P($G(^RMPR(660,RMPRI,2)),"^",1)
  1.  . I RMPR65P'="" D
  1.  .. ;
  1.  .. ; Update 665.194 multiple
  1.  .. Q:'$D(^RMPR(665,RMPR65P,0))
  1.  .. S RMPRPTP=$P(^RMPR(665,RMPR65P,0),"^",1)
  1.  .. S RMPRJ=0
  1.  .. F  S RMPRJ=$O(^RMPR(665,RMPR65P,"RMPOC",RMPRJ)) Q:'RMPRJ  D
  1.  ... Q:$P($G(^RMPR(665,RMPR65P,"RMPOC",RMPRJ,0)),"^",7)'=RMPRHPF
  1.  ... S RMPRIEN=RMPRJ_","_RMPR65P_","
  1.  ... K RMPRFDA,RMPRFME
  1.  ... S RMPRFDA(665.194,RMPRIEN,6)=RMPRHPT
  1.  ... D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  ... Q
  1.  .. ;
  1.  .. ; Update 665.723191 multiple
  1.  .. S RMPRO1=0
  1.  .. F  S RMPRO1=$O(^RMPO(665.72,RMPRO1)) Q:'+RMPRO1  D
  1.  ... S RMPRO2=0
  1.  ... F  S RMPRO2=$O(^RMPO(665.72,RMPRO1,1,RMPRO2)) Q:'+RMPRO2  D
  1.  .... S RMPRO3=0
  1.  .... F  S RMPRO3=$O(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3)) Q:'+RMPRO3  D
  1.  ..... I $D(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP)) D
  1.  ...... S RMPRO4=0
  1.  ...... F  S RMPRO4=$O(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP,1,RMPRO4)) Q:'+RMPRO4  D
  1.  ....... Q:$P($G(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP,1,RMPRO4,0)),"^",2)'=RMPRHPF
  1.  ....... S RMPRIEN=RMPRO4_","_RMPRPTP_","_RMPRO3_","_RMPRO2_","_RMPRO1_","
  1.  ....... K RMPRFME,RMPRFDA
  1.  ....... S RMPRFDA(665.723191,RMPRIEN,2)=RMPRHPT
  1.  ....... D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  ....... Q
  1.  ...... Q
  1.  ..... Q
  1.  .... Q
  1.  ... Q
  1.  .. Q
  1.  . ;
  1.  . ; Update to 664.1 and 664 HCPCS multiples
  1.  . S RMPRPTP=RMPR65P ;patient pointer
  1.  . I RMPRPTP'="" D
  1.  .. ;
  1.  .. ; Update 664.16 multiple
  1.  .. S RMPR641P=""
  1.  .. F  S RMPR641P=$O(^RMPR(664.1,"D",RMPRPTP,RMPR641P)) Q:RMPR641P=""  D 
  1.  ... S RMPRJ=0
  1.  ... F  S RMPRJ=$O(^RMPR(664.1,RMPR641P,2,RMPRJ)) Q:'+RMPRJ  D
  1.  .... Q:$P($G(^RMPR(664.1,RMPR641P,2,RMPRJ,2)),"^",1)'=RMPRHPF
  1.  .... S RMPRIEN=RMPRJ_","_RMPR641P_","
  1.  .... K RMPRFDA,RMPRFME
  1.  .... S RMPRFDA(664.16,RMPRIEN,13)=RMPRHPT
  1.  .... D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  .... Q
  1.  ... Q
  1.  .. Q
  1.  . S RMPRPTP=RMPR65P ;patient pointer same as 665 pointer
  1.  . I RMPRPTP'="" D
  1.  .. ;
  1.  .. ; Update 664.02 multiple
  1.  .. S RMPR64P=""
  1.  .. F  S RMPR64P=$O(^RMPR(664,"C",RMPRPTP,RMPR64P)) Q:RMPR64P=""  D
  1.  ... S RMPRJ=0
  1.  ... F  S RMPRJ=$O(^RMPR(664,RMPR64P,1,RMPRJ)) Q:'+RMPRJ  D
  1.  .... Q:$P($G(^RMPR(664,RMPR64P,1,RMPRJ,0)),"^",16)'=RMPRHPF
  1.  .... K RMPRFDA,RMPRFME
  1.  .... S RMPRIEN=RMPRJ_","_RMPR64P_","
  1.  .... S RMPRFDA(664.02,RMPRIEN,16)=RMPRHPT
  1.  .... D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  .... Q
  1.  ... Q
  1.  .. Q
  1.  . ;
  1.  . ; finally update the 660 file
  1.  . K RMPRFDA,RMPRFME
  1.  . S RMPRIEN=RMPRI_","
  1.  . S RMPRFDA(660,RMPRIEN,4.5)=RMPRHPT
  1.  . S RMPRFDA(660,RMPRIEN,37)=RMPRHPT_"-"_$P(RMHCIT,"-",2)
  1.  . D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  . Q
  1.  ;
  1.  ; Update PIP files 661.2 and 661.3
  1. HCPCDP S RMPRI=""
  1.  F  S RMPRI=$O(^RMPR(661.2,"D",RMPRHPF,RMPRI)) Q:RMPRI=""  D
  1.  . K RMPRFDA,RMPRFME
  1.  . S RMPRIEN=RMPRI_","
  1.  . S RMPRFDA(661.2,RMPRIEN,3)=RMPRHPT
  1.  . D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  . Q
  1.  S RMPRI=0
  1.  F  S RMPRI=$O(^RMPR(661.3,RMPRI)) Q:'+RMPRI  D
  1.  . S RMPRJ=0
  1.  . F  S RMPRJ=$O(^RMPR(661.3,RMPRI,1,RMPRJ)) Q:'+RMPRJ  D
  1.  .. Q:$P($G(^RMPR(661.3,RMPRI,1,RMPRJ,0)),"^",1)'=RMPRHPF
  1.  .. K RMPRFDA,RMPRFME
  1.  .. S RMPRIEN=RMPRJ_","_RMPRI_","
  1.  .. S RMPRFDA(661.31,RMPRIEN,.01)=RMPRHPT
  1.  .. D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  .. Q
  1.  . Q
  1.  K RMPRFDA,RMPRFME
  1.  S RMPRIEN=RMPRHPF_","
  1.  S RMPRFDA(661.1,RMPRIEN,.01)="@"
  1.  D FILE^DIE("","RMPRFDA","RMPRFME")
  1. HCPCDX Q
  1.  ;
  1.  ; ITEM - move Item records from 661.1 from old to new HCPCS
  1.  ;
  1.  ; Inputs:
  1.  ;   RMPRHPO - Old HCPCS code being replaced
  1.  ;   RMPRHPN - New HCPCS code
  1.  ;
  1. ITEM(RMPRHPO,RMPRHPN) ;
  1.  N RMPRHPOI,RMPRHPNI,RMPRJ,RMPRFDA,RMPRFME,RMPRIEN,X,Y,DA,RMPRIENA,RMPRK
  1.  N RMPRL,RMPRS,RMPRITEM,RMPRIFLG,RML,RMPRIN,RMPRIO
  1.  K ^TMP($J,"RM")
  1.  S RMPRHPOI=$O(^RMPR(661.1,"B",RMPRHPO,"")) ;old HCPCS ien
  1.  S RMPRHPNI=$O(^RMPR(661.1,"B",RMPRHPN,"")) ;new HCPCS ien
  1.  Q:'$G(RMPRHPNI)!'$G(RMPRHPOI)
  1.  G:$D(^RMPR(661.2,"D",RMPRHPNI)) ITEMX ;quit if Items already on new HCPCS and PIP.
  1.  S RMPRIFLG=0
  1.  I $P($G(^RMPR(661.1,RMPRHPOI,0)),"^",9)'="" S RMPRIFLG=1
  1.  ;
  1.  ; Loop on items and copy to new HCPCS
  1.  S RML=0
  1.  ;S RMPRIEN="+1,"_RMPRHPNI_","
  1.  S (RMPRJ,RMPRN)=0
  1.  I $D(^RMPR(661.1,RMPRHPNI,3,0)) S RMPRN=$P(^RMPR(661.1,RMPRHPNI,3,0),U,3)
  1.  S RMPRIENA=RMPRN
  1.  F  S RMPRJ=$O(^RMPR(661.1,RMPRHPOI,3,RMPRJ)) Q:'+RMPRJ  D
  1.  . K RMPRFDA,RMPRFME,DIE
  1.  . I RMPRN=0 S RMPRIENA=RMPRJ
  1.  . I RMPRN>0 S RMPRIENA=RMPRIENA+1
  1.  . S RML=RML+1
  1.  . S RMPRIEN="+"_RML_","_RMPRHPNI_","
  1.  . S RMPRFDA(661.12,RMPRIEN,.01)=$P(^RMPR(661.1,RMPRHPOI,3,RMPRJ,0),"^",1)
  1.  . I $L(RMPRFDA(661.12,RMPRIEN,.01))>30 S RMPRFDA(661.12,RMPRIEN,.01)=$E(RMPRFDA(661.12,RMPRIEN,.01),1,30)
  1.  .;don't create an entry if it's already been created.
  1.  . Q:$D(^RMPR(661.1,RMPRHPNI,3,"B",RMPRFDA(661.12,RMPRIEN,.01)))
  1.  . S ^TMP($J,"RM",RMPRJ)=RMPRIENA
  1.  . D UPDATE^DIE("","RMPRFDA","RMPRIENA","RMPRFME")
  1.  . Q
  1.  ;
  1.  ; Update 661.3 file
  1.  S RMPRJ=""
  1.  F  S RMPRJ=$O(^RMPR(661.3,"C",RMPRHPOI,RMPRJ)) Q:RMPRJ=""  D
  1.  . S RMPRK=""
  1.  . F  S RMPRK=$O(^RMPR(661.3,"C",RMPRHPOI,RMPRJ,RMPRK)) Q:RMPRK=""  D
  1.  .. S RMPRL=0
  1.  .. F  S RMPRL=$O(^RMPR(661.3,RMPRJ,1,RMPRK,1,RMPRL)) Q:'+RMPRL  D
  1.  ... S RMPRS=^RMPR(661.3,RMPRJ,1,RMPRK,1,RMPRL,0)
  1.  ... S RMPRITEM=$P(RMPRS,"^",1)
  1.  ... S RMPRIO=$P(RMPRITEM,"-",2)
  1.  ... Q:'$D(^TMP($J,"RM",RMPRIO))
  1.  ... S RMPRIN=^TMP($J,"RM",RMPRIO)
  1.  ... Q:'$G(RMPRIN)
  1.  ... S $P(RMPRITEM,"-",1)=RMPRHPN
  1.  ... S $P(RMPRITEM,"-",2)=RMPRIN
  1.  ... S RMPRIEN=RMPRL_","_RMPRK_","_RMPRJ_","
  1.  ... K RMPRFDA,RMPRFME
  1.  ... S RMPRFDA(661.312,RMPRIEN,.01)=RMPRITEM
  1.  ... D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  ... Q
  1.  .. S RMPRIEN=RMPRK_","_RMPRJ_","
  1.  .. K RMPRFDA,RMPRFME
  1.  .. S RMPRFDA(661.31,RMPRIEN,.01)=RMPRHPNI
  1.  .. D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  .. S RMPRIFLG=1
  1.  .. Q
  1.  . Q
  1.  I RMPRIFLG D
  1.  . K RMPRFDA,RMPRFME
  1.  . S RMPRIEN=RMPRHPNI_","
  1.  . S RMPRFDA(661.1,RMPRIEN,10)=1
  1.  . D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  . Q
  1.  ;
  1.  ; Update PIP files 661.2
  1.  S RMPRI=""
  1.  F  S RMPRI=$O(^RMPR(661.2,"D",RMPRHPOI,RMPRI)) Q:RMPRI=""  D
  1.  . Q:'$D(^RMPR(661.2,RMPRI,0))
  1.  . S RMHCIT=$P(^RMPR(661.2,RMPRI,0),U,9)
  1.  . K RMPRFDA,RMPRFME
  1.  . S RMPRIEN=RMPRI_","
  1.  . S RMPRFDA(661.2,RMPRIEN,3)=RMPRHPNI
  1.  . S RMPRFDA(661.2,RMPRIEN,9)=RMPRHPN_"-"_$P(RMHCIT,"-",2)
  1.  . D FILE^DIE("","RMPRFDA","RMPRFME")
  1.  . Q
  1.  ;
  1. ITEMX Q
  1.  ;
  1.  ; PATCH58 - 
  1.  ; 1 - Repoint duplicate HCPCS
  1.  ; 2 - Copy item and current inventory to new HCPCS for specified list
  1.  ; (patch 58 only)
  1. PATCH58 N RMPRA,RMPRI
  1.  I '$D(IO("Q")) D
  1.  . W !!,"Repointing specified duplicate HCPCS...",!
  1.  . Q
  1.  D HCPCD(170,133) ;E0277
  1.  I '$D(IO("Q")) D
  1.  . W !!,"Repointing complete.",!
  1.  . Q
  1.  ;
  1.  ;for next update, change RMPRA() local array to the HCPCS that need
  1.  ;to be replaced.
  1. PAT76 ; Set up array and replace HCPCS
  1.  S U="^"
  1.  I '$D(IO("Q")) D
  1.  . W !!,"Replacing the following HCPCS...",!
  1.  . Q
  1.  ;patch #58 - replacement code
  1.  ;K RMPRA
  1.  ;S RMPRA(1)="K0182^A7018"
  1.  ;S RMPRA(2)="K0269^E0572"
  1.  S RMFLG61=""
  1.  I '$D(^RMPR(661.6)),'$D(^RMPR(661.7)),'$D(^RMPR(661.9)) S RMFLG61=1 D CONV35^RMPRPS36
  1.  ;F RMI=0:0 S RMI=$O(^RMPR(661.1,"RMPR",RMI)) Q:RMI'>0  D
  1.  ;.S RMHCDA=^RMPR(661.1,"RMPR",RMI)
  1.  ;.S RMHOLD=$P(RMHCDA,U,1),RMHNEW=$P(RMHCDA,U,2)
  1.  ;.I '$D(IO("Q")) D
  1.  ;..W !,RMHOLD," with ",RMHNEW
  1.  ;.D ITEM(RMHOLD,RMHNEW)
  1.  ;.Q
  1.  I '$D(IO("Q")) D
  1.  . W !!,"HCPCS replacement complete.",!
  1.  . Q
  1.  Q
  1. CFLG ;remove calculation flag.
  1.  W !!,"Removing the Calculation flag.....",!
  1.  F RMPRI=1:1:66 S RMPRY=$P($T(FLG+RMPRI),";",4) Q:RMPRY'>0  D
  1.  .S $P(^RMPR(661.1,RMPRY,0),U,8)=""
  1.  W !!,"Done Removing Calculation flag!!!",!
  1.  Q
  1. FLG ;REMOVE calculation flag of the ff HCPCS:
  1.  ;;E1038;3884
  1.  ;;E1050;264
  1.  ;;E1060;265
  1.  ;;E1070;269
  1.  ;;E1083;271
  1.  ;;E1084;270
  1.  ;;E1085;272
  1.  ;;E1086;273
  1.  ;;E1087;274
  1.  ;;E1088;275
  1.  ;;E1089;276
  1.  ;;E1090;277
  1.  ;;E1092;278
  1.  ;;E1093;279
  1.  ;;E1100;280
  1.  ;;E1110;281
  1.  ;;E1130;282
  1.  ;;E1140;283
  1.  ;;E1150;284
  1.  ;;E1160;285
  1.  ;;E1161;3885
  1.  ;;E1170;286
  1.  ;;E1171;287
  1.  ;;E1172;288
  1.  ;;E1180;289
  1.  ;;E1190;290
  1.  ;;E1195;291
  1.  ;;E1200;292
  1.  ;;E1210;293
  1.  ;;E1211;294
  1.  ;;E1212;295
  1.  ;;E1213;296
  1.  ;;E1220;297
  1.  ;;E1221;298
  1.  ;;E1222;299
  1.  ;;E1223;300
  1.  ;;E1224;301
  1.  ;;E1225;302
  1.  ;;E1226;303
  1.  ;;E1227;304
  1.  ;;E1228;305
  1.  ;;E1230;306
  1.  ;;E1240;307
  1.  ;;E1250;308
  1.  ;;E1260;309
  1.  ;;E1270;310
  1.  ;;E1280;311
  1.  ;;E1285;312
  1.  ;;E1290;313
  1.  ;;E1295;314
  1.  ;;E1296;315
  1.  ;;E1297;316
  1.  ;;E1298;317
  1.  ;;K0001;339
  1.  ;;K0002;340
  1.  ;;K0003;341
  1.  ;;K0004;342
  1.  ;;K0005;343
  1.  ;;K0006;344
  1.  ;;K0007;345
  1.  ;;K0009;347
  1.  ;;K0010;348
  1.  ;;K0011;349
  1.  ;;K0012;350
  1.  ;;K0014;352
  1.  ;;END