source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRD1.m@ 1424

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

WorldVistAEHR overlayed on FOIAVistA
File size: 5.0 KB
Line 
1RMPRD1 ;PHX/HNB-DISPLAY LOOKUP ;10/19/1993 [ 06/28/94 3:17 PM ]<<= NOT VERIFIED >
2 ;;3.0;PROSTHETICS;**38**;Feb 09, 1996
3EN ;DISPLAY DATE,PATIENT,ITEM,COST FROM 660
4 S Z=^RMPR(660,+Y,0)
5 S RMPRIT=$P(Z,U,6)
6 I RMPRIT'="" S RMPRIT=$P(^RMPR(661,RMPRIT,0),U,1),RMPRIT=$P(^PRC(441,RMPRIT,0),U,2)
7 I RMPRIT="" S RMPRIT=$S($P(^RMPR(660,+Y,0),U,26)="P":"SHIPPING",$P(^RMPR(660,+Y,0),U,26)="D":"DELIVERY",1:"SHIPPING")
8 S RMPRCST="$"_$J($FN($P(Z,U,16),"T",2),8)
9 W ?36,$E(RMPRIT,1,23),?70,RMPRCST
10 K RMPRDFN,RMPRNAM,RMPRIT,RMPRCST,Z
11 Q
12EN1 ;DISPLAY DATE,REFERENCE,PATIENT FROM 664
13 Q:$G(RMPRQT)=1
14 I $G(DIC)="^RMPR(664," S Z=^RMPR(664,+Y,0),ZZ=$P(Z,U,7)
15 W:$P(Z,U,8) ?40,"Closed" W:$P(Z,U,5) ?40,"Cancelled"
16 W:$G(ZZ)'="" ?51,"REF: ",$P(ZZ,"-",3)
17 I $G(ZZ)="",$P(Z,U,15),$D(^RMPR(664.2,+$P(Z,U,15),0)) W ?40,$P(^(0),U)
18 I $D(^RMPR(664,+Y,1,0)) D
19 .S RMPRI=0
20 .;F S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0
21 .;S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1)
22 .F S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0 D
23 ..S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1) Q:$G(RMPRI1)'>0
24 ..S RMPRIT=$P(^RMPR(661,RMPRI1,0),U,1)
25 ..S RMPRN=$P(^PRC(441,RMPRIT,0),U,2)
26 ..W ?64,$E(RMPRN,1,15)
27 ..I $O(^RMPR(664,+Y,1,RMPRI)) W !
28 I '$D(^RMPR(664,+Y,1)),$P(^RMPR(664,+Y,0),U,12) W ?64,"PICKUP/DELIVERY",!
29 K ZZ Q
30EN2 ;DISPLAY NAME
31 I DIC="^RMPR(664," S Z=$P(^RMPR(664,+Y,0),U,2) I +Z W ?20,$E($P(^DPT(+Z,0),U,1),1,15) G EN1
32 Q
33EN3 ;DISPLAY LAB ORDER
34 I $P(^RMPR(664.1,+Y,0),U,13)="" D EN4 Q
35 S Z=$P(^RMPR(664.1,+Y,0),U,2)
36 I +Z W ?20,$E($P(^DPT(+Z,0),U,1),1,15),?40,$P(^RMPR(664.1,+Y,0),U,13),?57,$P(^(0),U,17) I $D(^RMPR(664.1,+Y,2)) D
37 .F RMPRI=0:0 S RMPRI=$O(^RMPR(664.1,+Y,2,RMPRI)) Q:RMPRI'>0 I $D(^(RMPRI,0)) S ZA=$P(^(0),U,1) W ?64,$E($$ITM^RMPR31U(ZA),1,15) I $O(^RMPR(664.1,+Y,2,RMPRI)) W !
38 Q
39EN4 ;DISPLAY 2529-3 REQUEST
40 S Z=^RMPR(664.1,+Y,0)
41 I +$P(Z,U,2) W ?20,$E($P(^DPT(+$P(Z,U,2),0),U,1),1,15) S RMPRSC=$P(Z,U,11),ZA=$P(^DD(664.1,2,0),U,3) W:RMPRSC'="" ?40,$E($P($P(ZA,RMPRSC_":",2),";",1),1,15)_"-"_$$STAN^RMPR31U($P(Z,U,15)) I $D(^RMPR(664.1,+Y,2)) D
42 .F RMPRI=0:0 S RMPRI=$O(^RMPR(664.1,+Y,2,RMPRI)) Q:RMPRI'>0 I $D(^(RMPRI,0)) S ZA=$P(^(0),U,1) W ?64,$E($$ITM^RMPR31U(ZA),1,15) I $O(^RMPR(664.1,+Y,2,RMPRI)) W !
43 Q
44EN5 ;Inquire to 1358 transaction
45 I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X)
46 N DIC
47 S RMPRQT=1
48 S DIC="^RMPR(664,",DIC(0)="AEQMZ" ;,DIC("W")="D EN2^RMPRD1"
49 ;S %ZIS="MQ" D ^%ZIS G:POP EXIT
50 K IOP I $E(IOST,1,1)["C-" G EN6
51 S DIC("S")="I $P(^(0),U,14)=RMPR(""STA"")"
52 D ^DIC Q:Y'>0
53 S RMPRDA=+Y
54 S %ZIS="MQ" D ^%ZIS G:POP EXIT
55 I $D(IO("Q")) D G EXIT
56 .S ZTSAVE("RMPRDA")="",ZTSAVE("RMPR(")=""
57 .S ZTSAVE("DATE(")="",ZTSAVE("RMPRSITE")=""
58 .S ZTIO=ION,ZTRTN="EN6^RMPRD1",ZTDESC="Inquire To Prosthetics 1358"
59 .D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE
60 ;ENTRY POINT FOR ACTUAL PRINTING OF 1358 INFO TO PRINTER OR SCREEN
61 ;S DIC("S")="I $P(^(0),U,14)=RMPR(""STA"")"
62 ; D ^DIC Q:Y'>0
63EN6 N RPO,RPO1 K DR
64 S DA=RMPRDA,DIQ="RPO",DR=".01:24",RMPRDA=DA
65 D EN^DIQ1
66 S DR(664.02)=".01:16"
67 S RPO1=0
68 F S RPO1=$O(^RMPR(664,DA,1,RPO1)) Q:RPO1'>0 D
69 .S DA(664.02)=RPO1
70 .D EN^DIQ1
71 ;Display
72 U IO
73 I $Y>1 W @IOF
74 W "Patient: ",RPO(664,RMPRDA,1),?40,"Vendor:",RPO(664,RMPRDA,4)
75 W !,"Request Date: ",RPO(664,RMPRDA,.01),?33,"Date Required: ",RPO(664,RMPRDA,20),?69,"Days: ",RPO(664,RMPRDA,21)
76 W !,"Form: ",RPO(664,RMPRDA,15),?33,"Initiator: ",$E(RPO(664,RMPRDA,10),1,12),?60,"Sta.: ",$E(RPO(664,RMPRDA,18),1,11)
77 I $G(RPO(664,RMPRDA,8))'="" D
78 .W !!,"Close Out Date:",RPO(664,RMPRDA,8),?40,"Closed By:",RPO(664,RMPRDA,8.5)
79 .W !,"Remarks: ",RPO(664,RMPRDA,8.1)
80 I $G(RPO(664,RMPRDA,12))'="" D
81 .W !!,"Shipping Entry: ",RPO(664,RMPRDA,13)
82 .W ?40,"Shipping Charge: ",RPO(664,RMPRDA,12)
83 I $G(RPO(664,RMPRDA,3))'="" D
84 .W !!,"Canceled Date: ",RPO(664,RMPRDA,3),?40,"Canceled By: ",RPO(664,RMPRDA,3.2)
85 .W !,"Cancelation Remarks: ",RPO(664,RMPRDA,3.1)
86 I $G(RPO(664,RMPRDA,22))'="" D
87 .W !!,"Work Order #: ",RPO(664,RMPRDA,22),?33,"Lab Tech.: ",$E(RPO(664,RMPRDA,23),1,12),?60,"Date: ",RPO(664,RMPRDA,24)
88 W !!,"Obligation #:",RPO(664,RMPRDA,.5)
89 W ?35,"C.P.:",RPO(664,RMPRDA,6)
90 W !,"Reference: ",RPO(664,RMPRDA,7)
91 W ?35,"% Discount: ",RPO(664,RMPRDA,17)
92 W ?60,"PSC Category: ",RPO(664,RMPRDA,16)
93 ;Item Mult. Display
94 S RD1=0 F S RD1=$O(^RMPR(664,DA,1,RD1)) Q:$G(RD1)'>0 D
95 .W !!,"Item:",RPO(664.02,RD1,.01)
96 .W ?34,"Qty:",RPO(664.02,RD1,3)_" "_RPO(664.02,RD1,4)
97 .W ?60,"Unit Cost :",RPO(664.02,RD1,2)
98 .W !,?2,"Actual Unit Cost: ",RPO(664.02,RD1,2)
99 .W ?34,"Source:",RPO(664.02,RD1,11)
100 .W ?60,"Serial #:",RPO(664.02,RD1,15)
101 .W !,?2,"Patient Category: ",RPO(664.02,RD1,9),?34,"Type of Transaction: ",RPO(664.02,RD1,9)
102 .W !,?2,"Special Category: ",RPO(664.02,RD1,10),?34,"Appliance/Repair: ",RPO(664.02,RD1,12)
103 .W !!,?2,"Item Remarks: ",RPO(664.02,RD1,7)
104 ;W !!,"READY TO WRITE WORD PROCESSING FIELDS"
105 S RPO1=0
106 F S RPO1=$O(RPO(664.02,RPO1)) Q:RPO1'>0 D
107 .W !,?2,"Brief Description: ",RPO(664.02,RPO1,1)
108 .W !,?2,"Extended Description:"
109 .M RPOD=RPO(664.02,RPO1,14)
110 .D EN^DDIOL(.RPOD)
111 .K RPOD
112 .W !!
113 ;end
114 N DIR
115 I $Y>11&($G(IO("Q"))<1) S DIR(0)="E" D ^DIR
116EXIT ;EXIT FROM EN5/EN6
117 K DA,RMPRDA,RMPRQT,RPO,IO("Q")
118 D ^%ZISC
Note: See TracBrowser for help on using the repository browser.