source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPAT3.m@ 767

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1RMPRPAT3 ;HINES-CIOFO/HNC,RVD - Detail Display Patient 10-2319 Transaction ;11/03/04
2 ;;3.0;PROSTHETICS;**3,12,25,28,32,41,69,92,99,90**;Feb 09, 1996
3 ;
4 ; RVD 4/30/02 patch #69 - add ICD-9 CODE and description in the display.
5 ; add HCPCS and Short Description.
6 ; AAC 08/03/04 Patch 92 - Code Set Versioning (CSV)
7 ;Used API=ICDDX^ICDCODE to replace direct calls to global ICD9(80).
8 ;
9 ;expect ANS,IT(ANS)
10 ; +IT(ANS)=ien of file 660
11 ;expect variables from GETPAT^RMPRUTIL
12 ; RMPRSSNE (external form of SSN)
13 ; RMPRNAM (name of patient)
14 ; RMPRDOB
15 ;display detailed record
16PRINT ;called from RMPRPAT2
17 ;get 2319 transaction
18 ;
19 N DIC,DIQ,DR,DA,RMPRV,RMPRDA,RV
20 S DIC=660,DIQ="R19",DR=".01:96",DIQ(0)="EN"
21 S (RMPRDA,DA)=+IT(ANS)
22 D EN^DIQ1
23 S DIQ="R19",DR=72,DIQ(0)="I" D EN^DIQ1
24 ;get vendor info
25 S DA=$P(^RMPR(660,RMPRDA,0),U,9)
26 I DA D
27 .S DIC=440,DIQ="RV",DR=".01:6",DIQ(0)="EN"
28 .S (RMPRV,DA)=$P(^RMPR(660,RMPRDA,0),U,9)
29 .D EN^DIQ1
30 ;
31 ;array defined for record in following format:
32 ;R19(filenumber,ien,field,E)=external form of data
33 ;RV(filenumber,ien,field,E)=external form of data
34 ;example:
35 ;R19(660,100,.01,"E")=APR 27, 1995
36 ;R19(660,100,.02,"E")=FUDGE,CHOCOLATE
37 ;RV(440,131,.01,"E")=ORTHOTIC LAB
38 ;
39 D HDR
40 W !,"TYPE OF FORM: ",$G(R19(660,RMPRDA,11,"E"))
41 W ?25,"INITIATOR: ",$G(R19(660,RMPRDA,27,"E"))
42 W ?55,"DATE: ",$G(R19(660,RMPRDA,1,"E"))
43 ;historical/original item
44 ;W !,"ITEM DESCRIPTION: ",$G(R19(660,RMPRDA,89,"E"))
45 W !,"DELIVER TO: ",$G(R19(660,RMPRDA,25,"E"))
46 W !,"TYPE TRANS: ",$G(R19(660,RMPRDA,2,"E"))
47 W ?30,"QTY: ",$G(R19(660,RMPRDA,5,"E"))
48 W:$G(R19(660,RMPRDA,29,"E")) ?40,"INVENTORY POINT: ",R19(660,RMPRDA,29,"E"),!
49 W ?40,"SOURCE: ",$G(R19(660,RMPRDA,12,"E"))
50 ;vendor tracking number
51 I $G(R19(660,RMPRDA,11,"E"))="VISA" D
52 .W !,"VENDOR TRACKING: ",$G(R19(660,RMPRDA,4.2,"E"))
53 .W ?38,"BANK AUTHORIZATION: ",$G(R19(660,RMPRDA,4.3,"E"))
54 W !,"VENDOR: ",?15,$G(R19(660,RMPRDA,7,"E"))
55 I $D(RV) D
56 .W !,"VENDOR PHONE: ",?15,$G(RV(440,RMPRV,5,"E"))
57 .W !?15,$G(RV(440,RMPRV,1,"E"))
58 .W !?15,$G(RV(440,RMPRV,4.2,"E")),","
59 .W ?$X+3,$G(RV(440,RMPRV,4.4,"E")),?$X+5,$G(RV(440,RMPRV,4.6,"E"))
60 W !,"DELIVERY DATE: "
61 I $D(R19(660,RMPRDA,10,"E")) W R19(660,RMPRDA,10,"E")
62 W !
63 I '$P(IT(AN),U,3) D
64 .W "TOTAL COST: "
65 .I $G(R19(660,RMPRDA,14,"E"))'="" W "$"_$J(R19(660,RMPRDA,14,"E"),2)
66 .I $G(R19(660,RMPRDA,14,"E"))="" W $S($G(R19(660,RMPRDA,6,"E"))'="":"$"_$J(R19(660,RMPRDA,6,"E"),2),$G(R19(660,RMPRDA,48,"E"))'="":"$"_$J(R19(660,RMPRDA,48,"E"),2),1:"")
67 W ?30,"OBL: ",$G(R19(660,RMPRDA,23,"E"))
68 ;
69 ;lab data
70 I $D(^RMPR(660,RMPRDA,"LB")) D
71 .N DIC,DIQ,DR,L19,DA
72 .S (DA,RMPRLA)=$P(^RMPR(660,RMPRDA,"LB"),U,10)
73 .Q:DA=""
74 .S DIC=664.1,DIQ="L19",DR="15",DIQ(0)="E"
75 .D EN^DIQ1
76 .W !,"WORK ORDER: ",$G(R19(660,RMPRDA,71,"E"))
77 .W ?40,"RECEIVING STATION: ",$G(R19(660,RMPRDA,70,"E"))
78 .W !,"TECHNICIAN: ",$G(L19(664.1,RMPRLA,15,"E"))
79 .W !,"TOTAL LABOR HOURS: ",$G(R19(660,RMPRDA,45,"E"))
80 .W ?40,"TOTAL LABOR COST: ",$G(R19(660,RMPRDA,46,"E"))
81 .W !,"TOTAL MATERIAL COST: ",$G(R19(660,RMPRDA,47,"E"))
82 .W ?40,"TOTAL LAB COST: ",$G(R19(660,RMPRDA,48,"E"))
83 .W !,"COMPLETION DATE: ",$G(R19(660,RMPRDA,50,"E"))
84 .W ?40,"LAB REMARKS: ",$G(R19(660,RMPRDA,51,"E"))
85 W !,"REMARKS: ",?15,$G(R19(660,RMPRDA,16,"E"))
86 I $G(R19(660,RMPRDA,17.5,"E")) W ?40,"RETURN STATUS: ",R19(660,RMPRDA,17.5,"E")
87 ;
88 ;historical data
89 I $G(R19(660,RMPRDA,15,"E"))["*" D
90 .;include records that have been merged
91 .W !!,"HISTORICAL DATA",!
92 .Q:'$D(R19(660,RMPRDA,89))
93 .W !,?15,"ITEM: ",$G(R19(660,RMPRDA,89,"E"))
94 .W !,?15,"STATION: ",$G(R19(660,RMPRDA,90,"E"))
95 .W !,?15,"VENDOR: ",$G(R19(660,RMPRDA,91,"E"))," PHONE: ",$G(R19(660,RMPRDA,92,"E"))
96 .W !,?23,$G(R19(660,RMPRDA,93,"E")),!,?23,$G(R19(660,RMPRDA,94,"E"))
97 .W " ",$G(R19(660,RMPRDA,95,"E"))," ",$G(R19(660,RMPRDA,96,"E"))
98 ;put in lab display here fields 45,46,47,48 and 51
99 ;lab amis
100 I $G(R19(660,RMPRDA,73,"E")) D
101 .W ?40,"ORTHOTICS LAB CODE: "
102 .W $S($D(R19(660,RMPRDA,74,"E")):R19(660,RMPRDA,74,"E"),$D(R19(660,RMPRDA,75,"E")):R19(660,RMPRDA,75,"E"),1:"")
103 .W !?40,"RESTORATIONS LAB CODE: "
104 .W $S($D(R19(660,RMPRDA,76,"E")):R19(660,RMPRDA,76,"E"),$D(R19(660,RMPRDA,77,"E")):R19(660,RMPRDA,77,"E"),1:"")
105 ;purchasing and issue from stock amis
106 W !,"DISABILITY SERVED: ",$G(R19(660,RMPRDA,62,"E"))
107 ;appliance/item information
108 ;historical/original item
109 W !,"ITEM DESCRIPTION: ",$G(R19(660,RMPRDA,89,"E"))
110 ;check for item description changes
111 I $G(R19(660,RMPRDA,89,"E"))'=$G(R19(660,RMPRDA,4,"E")) W !,"*** See Above For Original Item Description ***"
112 W !,"APPLIANCE: ",$G(R19(660,RMPRDA,4,"E"))
113 W !,"CONTRACT #: ",$G(R19(660,RMPRDA,38.7,"E"))
114 W !,"EXCLUDED/WAIVER: ",$G(R19(660,RMPRDA,38.1,"E"))
115 W !,"PSAS HCPCS: ",$G(R19(660,RMPRDA,4.5,"E"))
116 I $P($G(^RMPR(660,RMPRDA,1)),U,4) W ?22,$P($G(^RMPR(661.1,$P(^RMPR(660,RMPRDA,1),U,4),0)),U,2)
117 ;added by #69
118 ;
119 ; PATCH 92 - Code Set Versioning (CSV) changes below
120 ; AAC - 08/03/04
121 ;
122 S (RMPRICD,RMPRIC9,RMPRCOD,RMPRDAT)="" S RMPRERR=0
123 S RMPRDAT=$P($G(^RMPR(660,RMPRDA,0)),U,1)
124 I $D(^RMPR(660,RMPRDA,10)) S RMPRIC9=$P(^RMPR(660,RMPRDA,10),U,8)
125 I RMPRIC9'="" D
126 .S RMPRICD=$$ICDDX^ICDCODE(RMPRIC9,RMPRDAT)
127 .S RMPRERR=$P(RMPRICD,U,1)
128 .I RMPRERR<0 W !,"ICD-9 Message: ",$P(RMPRICD,U,2)
129 W !,"ICD-9 Code: "
130 I $G(RMPRICD)'="" W $P(RMPRICD,U,2),?19,$E($P(RMPRICD,U,4),1,55) I $P(RMPRICD,U,10)'>0 W " ","** Inactive ** Date: " S Y=$P(RMPRICD,U,12) D DD^%DT W Y
131 ;
132 ; End of Patch 92
133 ;
134 W !,"CPT MODIFIER: ",$G(R19(660,RMPRDA,4.7,"E"))
135 W !,"DESCRIPTION: ",$G(R19(660,RMPRDA,24,"E"))
136 W !,"EXTENDED DESCRIPTION: ",!
137 I $D(R19(660,RMPRDA,28)) D G:$D(DUOUT)!$D(DTOUT) EX1
138 .N R28
139 .;command part of new standards
140 .MERGE R28=R19(660,RMPRDA,28)
141 .I $P($G(^RMPR(660,RMPRDA,"DES",0)),U,3)>1 N DIR S DIR(0)="E" D ^DIR Q:$D(DUOUT)!$D(DTOUT) D HDR W !,"EXTENDED DESCRIPTION: ",!
142 .D EN^DDIOL(.R28)
143 ;NPPD key items consolidated, example L5300 limb order
144 I $P(IT(AN),U,3) W !!,"*** Return For DETAIL REPORT ***" N DIR S DIR(0)="E" D ^DIR G:$D(DUOUT)!$D(DTOUT) EX1 W @IOF D HDR,^RMPRPAT7
145 ;display work order if it is a 2529-3 form
146 ;must pass ien to file 664.1 NOT 664.2
147 I $G(R19(660,RMPRDA,72,"I"))'="" D G EX1
148 .S DIR(0)="E" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
149 .S RMPRBCK=RMPRDA
150 .N DIC
151 .S RMPRDA=R19(660,RMPRBCK,72,"I")
152 .D DISP^RMPR293(RMPRDA)
153 .S RMPRDA=RMPRBCK K RMPRBCK
154 ;return from work order
155 G EXIT
156 ;
157HDR ;display heading
158 W @IOF,RMPRNAM,?30," SSN: "
159 W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10),?50
160 W $G(R19(660,RMPRDA,8,"E")),?70,"DOB: "
161 W $S(RMPRDOB:$E(RMPRDOB,4,5)_"-"_$E(RMPRDOB,6,7)_"-"_(1700+$E(RMPRDOB,1,3)),1:"Unknown")
162 W !?20,"APPLIANCE/REPAIR LINE ITEM DETAIL ",?70,"<4-",ANS,">",!
163 Q
164EXIT ;common exit point
165 I $Y>(IOSL-4) F W ! Q:$Y>(IOSL-3)
166 N DIR S DIR(0)="E" D ^DIR
167 ;duout,dtout is evaluated in dis+1^rmprpat2
168EX1 ;back out through that point to clean up
169 K R19,RV,RMPRICD,RMPRIC9,RMPRICD,RMPRIC9,MSGICD,RMPRCOD,RMPRERR,RMPRDAT,Y W @IOF
170 Q
171 ;end
Note: See TracBrowser for help on using the repository browser.