source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPFFS.m@ 1697

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1RMPRPFFS ;Hines OIFO/HNC - REMOTE PROCEDURE, LIST NPPD DATA ;9/8/03 07:23
2 ;;3.0;PROSTHETICS;**96,60**;Feb 09, 1996;Build 18
3 ;
4 ; patch 96 - HNC
5 ; -DBIA #4419 for INSUR^IBBAPI
6 ; -DBIA #3990 for ICDDX^ICDCODE
7 ; -DBIA #1997 for STATCHK^ICPTAPIU
8 ; -DBIA #3823 for read file 355.3, field .04
9 ;RESULTS passed to broker in ^TMP($J,
10 ;delimited by "^"
11 ;piece 1 = ENTRY DATE
12 ;piece 2 = PATIENT NAME
13 ;piece 3 = PSAS HCPCS with * if hcpcs has Calculation Flag
14 ;piece 4 = QTY
15 ;piece 5 = Insurance with * if more insurance info available
16 ;piece 6 = Insurance Effective Date
17 ;piece 7 = TOTAL COST
18 ;piece 8 = DESCRIPTION (ITEM, BRIEF DESCRIPTION WITH ~R~ FOR REPAIR)
19 ;piece 9 = Coding Errors
20 ;piece 10 = Insurance Holder
21 ;piece 11 = STATION
22 ;piece 12 = ICD9 Description
23 ;piece 13 = Billing Group Number
24 ;piece 14 = Subscriber ID
25 ;piece 15 = SSN
26 ;piece 16 = IEN TO FILE 660
27 ;piece 17 = HCPCS SHORT DESCRIPTION
28 ;piece 18 = ICD9 code
29 ;piece 19 = Delivery Date
30 ;piece 20 = Expiration Insurance Date
31 ;piece 21 = Hcpcs-Icd9 Flag, this routine will set field 4.9 in file 660
32 ;all records will have a 1
33 ;ICD9, 2
34 ;HCPCS, 3
35 ;Not Billable 4
36 ;
37 ;No errors, number 1.
38 ;PSAS HCPCS, Not Billable Item, number 14.
39 ;ICD9 error, number 12.
40 ;HCPCS error, number 13.
41 ;Both ICD9 and HCPCS error, number 132.
42 ;Both ICD9 error and Not Billable Item, number 142.
43 Q
44 ;
45EN(RESULT,DATE1,DATE2) ;broker entry point
46 ;
47 K ^TMP($J)
48 I '$D(DATE1)!('$D(DATE2)) G EXIT
49 S DATE=DATE1-1
50 F S DATE=$O(^RMPR(660,"B",DATE)) Q:(DATE="")!($P(DATE,".",1)>DATE2) D
51 .S RMPRB=0
52 .F S RMPRB=$O(^RMPR(660,"B",DATE,RMPRB)) Q:RMPRB="" D
53 ..Q:$P(^RMPR(660,RMPRB,0),U,15)["*"
54 ..Q:$P(^RMPR(660,RMPRB,0),U,14)'["C"
55 ..;Q:$P(^RMPR(660,RMPRB,0),U,12)=""
56 ..Q:$P($G(^RMPR(660,RMPRB,"AM")),U,3)<2
57 ..;end of filter
58 ..S PHCPCS=$P($G(^RMPR(660,RMPRB,1)),U,4)
59 ..Q:PHCPCS=""
60 ..Q:PHCPCS'>0
61 ..S HDES=$P(^RMPR(661.1,PHCPCS,0),U,2)
62 ..;code set versioning check
63 ..S RICP=""
64 ..S RICP=$P(^RMPR(661.1,PHCPCS,0),U,1)
65 ..S RICPP="",CODERR="Alert",CODEFLG=1
66 ..I RICP'="" D
67 ...I $A($E(RICP,2,2))>64 S CODERR=" Non Billable Item",CODEFLG=CODEFLG_4 Q
68 ...I $A($E(RICP,2,2))<65 S RICPP=$$STATCHK^ICPTAPIU(RICP,$P(^RMPR(660,RMPRB,0),U,1))
69 ..I RICPP'="" D
70 ...I $P(RICPP,U,1)=0 S CODERR=CODERR_" HCPCS Inactive",CODEFLG=CODEFLG_3
71 ..S TYPE=$P($G(^RMPR(660,RMPRB,0)),U,4)
72 ..I TYPE'="X" S LINE=$P(^RMPR(661.1,PHCPCS,0),U,7)
73 ..I TYPE="X" S LINE=$P(^RMPR(661.1,PHCPCS,0),U,6)
74 ..S CAL=$P(^RMPR(661.1,PHCPCS,0),U,8)
75 ..I CAL'="" S CAL="*"
76 ..S DFN=$P(^RMPR(660,RMPRB,0),U,2)
77 ..D DEM^VADPT
78 ..D SVC^VADPT
79 ..S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0)
80 ..S (RMI,HOLDER,SUBID,INSUR,INSURE,INSURG,INSURGG,INICD9D,INICD9E,RMPRDELD,RMPRIND,RMPRDEL)=""
81 ..S RMPRDELD=$P(^RMPR(660,RMPRB,0),U,12)
82 ..I RMPRDELD'="" S RMPRDEL=$E(RMPRDELD,4,5)_"/"_$E(RMPRDELD,6,7)_"/"_(($E(RMPRDELD,1,3))+1700)
83 ..S X=$$INSUR^IBBAPI(DFN,,"RBA",.RMI,"*") I $D(RMI) D
84 ...;format the RMI array
85 ...;look for primary insurance
86 ...;RMI("IBBAPI","INSUR",n,7)=1^PRIMARY
87 ...S X="" F S X=$O(RMI("IBBAPI","INSUR",X)) Q:'X D
88 ....;I $P(RMI("IBBAPI","INSUR",X,7),U,2)'="PRIMARY" Q
89 ....S INSUR=$P(RMI("IBBAPI","INSUR",X,1),U,2)
90 ....I X>1 S INSUR="*"_INSUR
91 ....S SUBID=$P(RMI("IBBAPI","INSUR",X,14),U,1)
92 ....S HOLDER=$P(RMI("IBBAPI","INSUR",X,12),U,2)
93 ....S RMPRIND=$P(RMI("IBBAPI","INSUR",X,11),U,1)
94 ....I RMPRIND'="" S RMPRIND=$E(RMPRIND,4,5)_"/"_$E(RMPRIND,6,7)_"/"_(($E(RMPRIND,1,3))+1700)
95 ....S INSURE=$P(RMI("IBBAPI","INSUR",X,10),U,1)
96 ....I INSURE'="" S INSURE=$E(INSURE,4,5)_"/"_$E(INSURE,6,7)_"/"_(($E(INSURE,1,3))+1700)
97 ....S INSURG=$P(RMI("IBBAPI","INSUR",X,8),U,1)
98 ....S INSURGG=$$GET1^DIQ(355.3,INSURG_",",.04)
99 ..I '$D(RMI) D
100 ...S INSUR="No Insurance Information"
101 ...S SUBID=""
102 ...S HOLDER=""
103 ...S INSURE=""
104 ...S INSURGG=""
105 ...S RMPRIND=""
106 ..;get icd9 data
107 ..S INICD9I=$P($G(^RMPR(660,RMPRB,10)),U,8)
108 ..I INICD9I'="" D
109 ...S INICD9=$$ICDDX^ICDCODE(INICD9I,$P(^RMPR(660,RMPRB,0),U,1))
110 ...I INICD9'="" S INICD9E=$P(INICD9,U,2),INICD9D=$P(INICD9,U,4)
111 ...I $P(INICD9,U,10)=0 S CODERR=CODERR_" ICD9 Inactive",CODEFLG=CODEFLG_2
112 ..D DATA
113 S RESULT=$NA(^TMP($J))
114 Q
115 ;
116DATA ;
117 S B=RMPRB
118 D GETS^DIQ(660,B,".01;.02;2;4.5;5;7;8;8.3;11;12;14;24;27;68","","RMXM")
119 S $P(^TMP($J,B),U,1)=$G(RMXM(660,B_",",.01))
120 ;Check for OEF/OIF
121 I RMPROEOI="<!>" S RMXM(660,B_",",.02)="<!>"_RMXM(660,B_",",.02)
122 S $P(^TMP($J,B),U,2)=$G(RMXM(660,B_",",.02))
123 S $P(^TMP($J,B),U,3)=$G(RMXM(660,B_",",4.5))_CAL
124 S $P(^TMP($J,B),U,4)=$G(RMXM(660,B_",",5))
125 ;change to insurance
126 I INSUR="" S INSUR="Incomplete Insurance Information"
127 S $P(^TMP($J,B),U,5)=INSUR
128 ;change to effective insurance date
129 S $P(^TMP($J,B),U,6)=INSURE
130 S $P(^TMP($J,B),U,7)=$G(RMXM(660,B_",",14))
131 ;patch 77 remove the " for Excel CSV
132 ;append ~R~ for repair items
133 I $G(RMXM(660,B_",",2))="REPAIR" S RMXM(660,B_",",24)="~R~"_RMXM(660,B_",",24)
134 S $P(^TMP($J,B),U,8)=$TR($G(RMXM(660,B_",",24)),"""","'")
135 ;change to coding errors
136 I CODERR="Alert" S CODERR=""
137 S $P(^TMP($J,B),U,9)=CODERR
138 ;change to holder
139 S $P(^TMP($J,B),U,10)=HOLDER
140 S $P(^TMP($J,B),U,11)=$G(RMXM(660,B_",",8))
141 ;change to ICD9 description
142 S $P(^TMP($J,B),U,12)=INICD9D
143 ;change to Billing Group
144 S $P(^TMP($J,B),U,13)=INSURGG
145 ;change to subscriber ID
146 S $P(^TMP($J,B),U,14)=SUBID
147 S $P(^TMP($J,B),U,15)=$P(VADM(2),U,2)
148 S $P(^TMP($J,B),U,16)=B
149 S $P(^TMP($J,B),U,17)=HDES
150 ;change to ICD9 code
151 S $P(^TMP($J,B),U,18)=INICD9E
152 ;add Delivery Date
153 S $P(^TMP($J,B),U,20)=RMPRDEL
154 ;add Insurance Expiration Date
155 S $P(^TMP($J,B),U,19)=RMPRIND
156 ;hcpcs-icd9 code flag
157 S $P(^TMP($J,B),U,21)=CODEFLG
158 S $P(^RMPR(660,RMPRB,1),U,11)=CODEFLG
159 S $P(^RMPR(660,RMPRB,1),U,12)=DT
160 K RMXM,VADM,CAL
161 D KVAR^VADPT
162 Q
163EXIT ;common exit point
164 N RESULTS D KILL^XUSCLEAN
165 Q
166 ;END
Note: See TracBrowser for help on using the repository browser.