source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9S4E.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1RMPR9S4E ;HOIFO/SPS-GUI 2319 Extended Display Transaction screen 4 ;12/17/02 09:35
2 ;;3.0;PROSTHETICS;**59,92,99,90,75**;Feb 09, 1996;Build 25
3 ;
4 ; (IEN)=ien of file 660
5 ;
6 ;AAC Patch 92 08/04/04 - Code Set Versioning (CSV)
7 ;Used API=ICDDX^ICDCODE to replace direct calls to global ICD9(80)
8 ;
9 ;
10 ;display detailed record
11A1(IEN) G A2
12EN(RESULTS,IEN) ;Broker
13A2 ;
14 I +IEN'>0 S RESULTS(0)="NOTHING TO REPORT" G EXIT
15 I '$D(^RMPR(660,IEN)) S RESULTS(0)="NOTHING TO REPORT" G EXIT
16 N DIC,DIQ,DR,DA,RMPRV,RMPRDA,RV
17 S DIC=660,DIQ="R19",DR=".01:96",DIQ(0)="EN"
18 S (RMPRDA,DA)=(IEN)
19 D EN^DIQ1
20 S DIQ="R19",DR=72,DIQ(0)="I" D EN^DIQ1
21 ;get vendor info
22 S DA=$P(^RMPR(660,RMPRDA,0),U,9)
23 I DA D
24 .S DIC=440,DIQ="RV",DR=".01:6",DIQ(0)="EN"
25 .S (RMPRV,DA)=$P(^RMPR(660,RMPRDA,0),U,9)
26 .D EN^DIQ1
27 ;
28 ;array defined for record in following format:
29 ;R19(filenumber,ien,field,E)=external form of data
30 ;RV(filenumber,ien,field,E)=external form of data
31 ;example:
32 ;R19(660,100,.01,"E")=APR 27, 1995
33 ;R19(660,100,.02,"E")=NAME,PATIENT
34 ;RV(440,131,.01,"E")=ORTHOTIC LAB
35 S RMPRDFN=$P(^RMPR(660,RMPRDA,0),U,2)
36 S RMPRNAM=$P(^DPT(RMPRDFN,0),U),RMPRSSN=$P(^(0),U,9),RMPRDOB=$P(^(0),U,3)
37 ;
38 D HDR
39 ; "TYPE OF FORM: ",
40 S RESULTS(5)=$G(R19(660,RMPRDA,11,"E"))
41 ; "INITIATOR: ",
42 S RESULTS(6)=$G(R19(660,RMPRDA,27,"E"))
43 ; "DATE: ",
44 S RESULTS(7)=$G(R19(660,RMPRDA,1,"E"))
45 ; "DELIVER TO: ",
46 S RESULTS(8)=$G(R19(660,RMPRDA,25,"E"))
47 ; "TYPE TRANS: ",
48 S RESULTS(9)=$G(R19(660,RMPRDA,2,"E"))
49 ; "QTY: ",
50 S RESULTS(10)=$G(R19(660,RMPRDA,5,"E"))
51 ; "INVENTORY POINT: "
52 S RESULTS(11)=$G(R19(660,RMPRDA,29,"E"))
53 ; "SOURCE: ",
54 S RESULTS(12)=$G(R19(660,RMPRDA,12,"E"))
55 ;vendor tracking number
56 S (RESULTS(13),RESULTS(14))=""
57 I $G(R19(660,RMPRDA,11,"E"))="VISA" D
58 .; "VENDOR TRACKING: ",
59 .S RESULTS(13)=$G(R19(660,RMPRDA,4.2,"E"))
60 .; "BANK AUTHORIZATION: ",
61 .S RESULTS(14)=$G(R19(660,RMPRDA,38.7,"E"))
62 ; "VENDOR: ",
63 S RESULTS(15)=$G(R19(660,RMPRDA,7,"E"))
64 ; VENDOR PHONE AND ADDRESS INFO
65 F I=16:1:20 S RESULTS(I)=""
66 I $D(RV) D
67 .; "VENDOR PHONE: and Address ",
68 .S RESULTS(16)=$G(RV(440,RMPRV,5,"E"))
69 .S RESULTS(17)=$G(RV(440,RMPRV,1,"E"))
70 .S RESULTS(18)=$G(RV(440,RMPRV,4.2,"E"))
71 .S RESULTS(19)=$G(RV(440,RMPRV,4.4,"E"))
72 .S RESULTS(20)=$G(RV(440,RMPRV,4.6,"E"))
73 ; "DELIVERY DATE: "
74 S RESULTS(21)=$G(R19(660,RMPRDA,10,"E"))
75 ; "TOTAL COST: "
76 S RESULTS(22)=0.00
77 I $G(R19(660,RMPRDA,14,"E"))'="" S RESULTS(22)="$"_$FN(R19(660,RMPRDA,14,"E"),"T",2)
78 I $G(R19(660,RMPRDA,14,"E"))="" S RESULTS(22)=$S($G(R19(660,RMPRDA,6,"E"))'="":"$"_$FN(R19(660,RMPRDA,6,"E"),"T",2),$G(R19(660,RMPRDA,48,"E"))'="":"$"_$FN(R19(660,RMPRDA,48,"E"),"T",2),1:"")
79 ; "OBL: ",
80 S RESULTS(23)=$G(R19(660,RMPRDA,23,"E"))
81 ;
82 ;lab data
83 F I=24:1:32 S RESULTS(I)=""
84 I $D(^RMPR(660,RMPRDA,"LB")) D
85 .N DIC,DIQ,DR,L19,DA
86 .S (DA,RMPRLA)=$P(^RMPR(660,RMPRDA,"LB"),U,10)
87 .Q:DA=""
88 .S DIC=664.1,DIQ="L19",DR="15",DIQ(0)="E"
89 .D EN^DIQ1
90 .; "WORK ORDER: ",
91 .S RESULTS(24)=$G(R19(660,RMPRDA,71,"E"))
92 .I $P(^RMPR(660,RMPRDA,"AM"),U,2)=1 S RESULTS(24)=$G(R19(660,RMPRDA,72.5,"E"))
93 .I $P(^RMPR(660,RMPRDA,"LB"),U,14)=1 S RESULTS(24)=$G(R19(660,RMPRDA,72.5,"E"))
94 .; "RECEIVING STATION: ",
95 .S RESULTS(25)=$G(R19(660,RMPRDA,70,"E"))
96 .; "TECHNICIAN: ",
97 .S RESULTS(26)=$G(L19(664.1,RMPRLA,15,"E"))
98 .; "TOTAL LABOR HOURS: ",
99 .S RESULTS(27)=$G(R19(660,RMPRDA,45,"E"))
100 .; "TOTAL LABOR COST: ",
101 .S RESULTS(28)=$G(R19(660,RMPRDA,46,"E"))
102 .; "TOTAL MATERIAL COST: ",
103 .S RESULTS(29)=$G(R19(660,RMPRDA,47,"E"))
104 .; "TOTAL LAB COST: ",
105 .S RESULTS(30)=$G(R19(660,RMPRDA,48,"E"))
106 .; "COMPLETION DATE: ",
107 .S RESULTS(31)=$G(R19(660,RMPRDA,50,"E"))
108 .; "LAB REMARKS: ",
109 .S RESULTS(32)=$G(R19(660,RMPRDA,51,"E"))
110 ; "REMARKS: ",
111 S RESULTS(33)=$G(R19(660,RMPRDA,16,"E"))
112 ; "RETURN STATUS: ",
113 S RESULTS(34)=$G(R19(660,RMPRDA,17.5,"E"))
114 ;
115 ; CoreFLS Data used to be/and same as historical data
116 F I=35:1:42 S RESULTS(I)=""
117 I $G(R19(660,RMPRDA,15,"E"))["*" D
118 .;include records that have been merged
119 .; "COREFLS/HISTORICAL DATA",!
120 .Q:'$D(R19(660,RMPRDA,89))
121 .; "ITEM: ",
122 .S RESULTS(35)=$G(R19(660,RMPRDA,89,"E"))
123 .; "STATION: ",
124 .S RESULTS(36)=$G(R19(660,RMPRDA,90,"E"))
125 .; "VENDOR: ",
126 .S RESULTS(37)=$G(R19(660,RMPRDA,91,"E"))
127 .; " PHONE: ",
128 .S RESULTS(38)=$G(R19(660,RMPRDA,92,"E"))
129 .; " STREET
130 .S RESULTS(39)=$G(R19(660,RMPRDA,93,"E"))
131 .; CITY
132 .S RESULTS(40)=$G(R19(660,RMPRDA,94,"E"))
133 .; STATE
134 .S RESULTS(41)=$G(R19(660,RMPRDA,95,"E"))
135 .; ZIP
136 .S RESULTS(42)=$G(R19(660,RMPRDA,96,"E"))
137 ;put in lab display here fields 45,46,47,48 and 51
138 ;lab amis
139 F I=43:1:44 S RESULTS(I)=""
140 I $G(R19(660,RMPRDA,73,"E")) D
141 .; "ORTHOTICS LAB CODE: "
142 .S RESULTS(43)=$S($D(R19(660,RMPRDA,74,"E")):R19(660,RMPRDA,74,"E"),$D(R19(660,RMPRDA,75,"E")):R19(660,RMPRDA,75,"E"),1:"")
143 .; "RESTORATIONS LAB CODE: "
144 .S RESULTS(44)=$S($D(R19(660,RMPRDA,76,"E")):R19(660,RMPRDA,76,"E"),$D(R19(660,RMPRDA,77,"E")):R19(660,RMPRDA,77,"E"),1:"")
145 ;purchasing and issue from stock amis
146 ; "DISABILITY SERVED: ",
147 S RESULTS(45)=$G(R19(660,RMPRDA,62,"E"))
148 ;appliance/item information
149 ; "APPLIANCE: ",
150 ;S RESULTS(46)=$G(R19(660,RMPRDA,4,"E"))
151 S RESULTS(46)=$G(R19(660,RMPRDA,89,"E"))
152 ; "PSAS HCPCS: ",
153 S RESULTS(47)=$G(R19(660,RMPRDA,4.5,"E"))
154 ; "PSAS HCPCS DESC.
155 S RESULTS(48)=""
156 I $P($G(^RMPR(660,RMPRDA,1)),U,4) S RESULTS(48)=$P($G(^RMPR(661.1,$P(^RMPR(660,RMPRDA,1),U,4),0)),U,2)
157 ;added by #69
158 ;
159 ; Patch 92 - Code Set Versioning (CSV) changes below inserted afer the line above for #69
160 ; AAC - 08/04/04
161 ;
162 S (RMPRICD,RMPRIC0,RMPRCOD,RMPRIC9,RESULTS(49))="" S RMPRERR=0
163 S RMPRDAT=$G(R19(660,RMPRDA,.01,"E"))
164 I $D(^RMPR(660,RMPRDA,10)) S RMPRIC9=$P(^RMPR(660,RMPRDA,10),U,8)
165 I RMPRIC9'="" D
166 .S RMPRICD=$$ICDDX^ICDCODE(RMPRIC9,RMPRDAT)
167 .S RMPRERR=$P(RMPRICD,U,1)
168 .I RMPRERR<0 S RESULTS(49)=$P(RMPRICD,U,2)
169ZZ ;
170 I RMPRERR>0 S RESULTS(49)=$P(RMPRICD,U,2)_" "_$E($P(RMPRICD,U,4),1,55) I $P(RMPRICD,U,10)'>0 S RESULTS(49)=RESULTS(49)_" "_"** Inactive ** Date: " S Y=$P(RMPRICD,U,12) D DD^%DT S RESULTS(49)=RESULTS(49)_" "_Y
171 ; "ICD-9 Code: ",
172 ; S RESULTS(49)=RMPRICC_" "_$E($G(^ICD9(RMPRIC9,1)),1,55)
173 ;
174 ; End Patch 92
175 ;
176 ; "CPT MODIFIER: ",
177 S RESULTS(50)=$G(R19(660,RMPRDA,38.1,"E"))
178 ; "DESCRIPTION: ",
179 S RESULTS(51)=$G(R19(660,RMPRDA,24,"E"))
180 ; ,"EXTENDED DESCRIPTION: ",!
181 N R28
182 I $D(R19(660,RMPRDA,28)) D
183 .;command part of new standards
184 .MERGE R28=R19(660,RMPRDA,28)
185 S LN=0,CNT=52
186 F S LN=$O(R28(LN)) Q:LN'>0 D
187 .S RESULTS(CNT)=R28(LN)
188 .S CNT=CNT+1
189 G EXIT
190 ;
191HDR ;display heading
192 S RESULTS(1)=RMPRNAM
193 ; " SSN: "
194 S RESULTS(2)=$E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10)
195 S RESULTS(3)=$G(R19(660,RMPRDA,8,"E"))
196 ; "DOB: "
197 S RESULTS(4)=$S(RMPRDOB:$E(RMPRDOB,4,5)_"-"_$E(RMPRDOB,6,7)_"-"_(1700+$E(RMPRDOB,1,3)),1:"Unknown")
198 Q
199EXIT ;common exit point
200 I '$D(RESULTS) S RESULTS(0)="NOTHING TO REPORT"
201 K R19,RV,RMPRICC,RMPRICD,RMPRIC9,RMPRCOD,RMPRDAT,RMPRERR,RMPRIC0,Y
202 Q
203 ;end
Note: See TracBrowser for help on using the repository browser.