source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPST3.m@ 1604

Last change on this file since 1604 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1RMPRPST3 ;HISC/ODJ - POST INIT FOR +AL HCPCS;8/1/00
2 ;;3.0;PROSTHETICS;**50**;Aug 01,2000
3 W !!,"Must use correct line label - review source code.",!!
4 Q
5START ;Populate the 661.1 HCPC File with additional codes
6 N I,RMPRIEN,RMPRDAT,RMPRDES
7 S U="^"
8 W !!,"Entering Additional HCPCs......."
9 F I=1:2 Q:$P($T(DAT+I),";",3)="END" D
10 . S RMPRDAT=$P($T(DAT+I),";",3)
11 . S RMPRIEN=$P(RMPRDAT,"=",1)
12 . S RMPRDAT=$P(RMPRDAT,"=",2)
13 . W !,RMPRIEN," ",RMPRDAT
14 . S RMPRDES=$P($P($T(DAT+I+1),";",3),"=",2)
15 . D UPD(RMPRIEN,RMPRDAT,RMPRDES)
16 . Q
17 W !,"Finished entering Additional HCPCs",!
18 W !,"Adding RR modifier to HCPC E0434"
19 D E0434
20 W !,"Finished adding modifier to HCPC E0434",!
21 W !,"Amending HCPC V5299"
22 D V5299
23 W !,"Finished amending V5299"
24 W !,"Finished post init",!
25 Q
26UPD(RMPRIEN,RMPRDAT,RMPRDES) ;
27 N RMPRFDA,RMPRIA
28 S RMPRIA(1)=RMPRIEN,RMPRIEN=RMPRIEN_","
29 S:'$D(^RMPR(661.1,RMPRIA(1))) RMPRIEN="+1,"
30 S RMPRFDA(661.1,RMPRIEN,.01)=$P(RMPRDAT,U,1)
31 S RMPRFDA(661.1,RMPRIEN,.02)=$P(RMPRDAT,U,2)
32 S RMPRFDA(661.1,RMPRIEN,1)=$P(RMPRDAT,U,3)
33 S RMPRFDA(661.1,RMPRIEN,2)=$P(RMPRDAT,U,4)
34 S RMPRFDA(661.1,RMPRIEN,3)=$P(RMPRDAT,U,5)
35 S RMPRFDA(661.1,RMPRIEN,5)=$P(RMPRDAT,U,6)
36 S RMPRFDA(661.1,RMPRIEN,6)=$P(RMPRDAT,U,7)
37 S RMPRFDA(661.1,RMPRIEN,9)=$P(RMPRDAT,U,8)
38 S RMPRFDA(661.1,RMPRIEN,10)=$P(RMPRDAT,U,9)
39 S RMPRFDA(661.1,RMPRIEN,11)=$P(RMPRDAT,U,10)
40 I '$D(^RMPR(661.1,RMPRIA(1))) D
41 . D UPDATE^DIE("U","RMPRFDA","RMPRIA")
42 . K RMPRFDA
43 . S RMPRIEN="+1,"_RMPRIA(1)_","
44 . K RMPRIA
45 . S RMPRFDA(661.18,RMPRIEN,.01)=RMPRDES
46 . D UPDATE^DIE("U","RMPRFDA")
47 . Q
48 E D
49 . D UPDATE^DIE("","RMPRFDA")
50 . Q
51 Q
52 ;
53 ; Add RR CPT modifier to HCPC E0434
54E0434 N IEN,HCPC,OUP
55 S HCPC="E0434"
56 S IEN=$O(^RMPR(661.1,"B",HCPC,""))_","
57 D GETS^DIQ(661.1,IEN,".03","","OUP")
58 I OUP(661.1,IEN,.03)'["RR" D
59 .S OUP(661.1,IEN,.03)=OUP(661.1,IEN,.03)_",RR"
60 .D UPDATE^DIE("","OUP")
61 Q
62 ;
63 ; HCPC V5299 change NPPD line to 600E
64V5299 N IEN,HCPC,OUP
65 S HCPC="V5299"
66 S IEN=$O(^RMPR(661.1,"B",HCPC,""))_","
67 D GETS^DIQ(661.1,IEN,"6","","OUP")
68 S OUP(661.1,IEN,6)="600 E"
69 D UPDATE^DIE("","OUP")
70 Q
71 ;
72DAT ;;table for +al HCPCs (grabbed from NPP)
73 ;;2969=A4258^LANCET DEVICE^^104352^1^^910 A
74 ;;2969=LANCET DEVICE FOR FINGER STICKS
75 ;;2970=E0747^BONE STIMULATOR^^100895^1^R 90^900 K
76 ;;2970=BONE STIMULATOR OTHER THAN SPINAL APPLICATIONS
77 ;;2971=E0748^BONE STIMULATOR-SPINAL^^104407^1^R 90^900 K
78 ;;2971=BONE STIMULATOR-SPINAL APPLICATION
79 ;;2972=E0749^BONE STIMULATOR-SURGICAL^^100896^1^^960 D
80 ;;2972=BONE STIMULATOR-SURGICALLY IMPLANTED
81 ;;END
Note: See TracBrowser for help on using the repository browser.