source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRP55.m@ 1764

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

initial load of FOIAVistA 6/30/08 version

File size: 4.7 KB
Line 
1RMPRP55 ;PHX/DWL/HNB-PRINT 10-55 ;3/17/03 13:05
2 ;;3.0;PROSTHETICS;**20,55,77**;Feb 09, 1996
3 ;
4 ; ODJ - patch 55 - 1/29/01 - replace 121 hard coded mail symbol with
5 ; call to site param. extrinsic
6 ; nois AUG-1097-32118
7 ; RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
8 ;
9 I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EXIT
10 I $D(RMPRA) G ZIS
11EN ;ENTRY POINT FOR REPRINTING A 10-55
12 D DIV4^RMPRSIT G:$D(X) EXIT
13 S DIC="^RMPR(664,",DIC(0)="AEMQ",DIC("W")="D EN2^RMPRD1"
14 S DIC("A")="Select Transaction or Patient Name: "
15 S DIC("S")="I $D(^RMPR(664,Y,1)) S R1=$O(^RMPR(664,Y,1,0)) I R1 S RX=$P(^(R1,0),U,13) S:$D(^RMPR(660,+RX,0)) RX=$P(^(0),U,13) I RX=1!(RX=10) I '$D(^RMPR(664,""AP"",RMPR(""STA""),Y))"
16 D ^DIC G:+Y<1 EXIT
17 S RMPRA=+Y,RMPRACT=1 I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM G EXIT
18 D PR^RMPR21A I %'>0 G EXIT
19 S RX=^RMPR(664,RMPRA,0)
20ZIS ;
21 I $P(^RMPR(669.9,RMPRSITE,0),U,5) S IOP="Q;"_$P(^%ZIS(1,$P(^(0),U,5),0),U,1),%ZIS="MQ" D ^%ZIS G:POP EXIT G PT
22 S %ZIS="MQ" D ^%ZIS G:POP EXIT I $D(IO("Q")) S ZTIO=ION G PT
23 U IO
24EN1 ;ADDRESS DEFINED
25 W:$E(IOST)["C" @IOF S %X="^RMPR(664,RMPRA,",%Y="R55(" D %XY^%RCR
26 S Y=DT D DD^%DT S DATE=Y,RMPRTT="" W:$D(RMPRACT) ?30,"****DUPLICATE COPY****" I $P($G(R55(4)),U,8)=1 W ?30,"***WORKING COPY***"
27 W !!!,?5,"DEPARTMENT OF VETERANS AFFAIRS" W !,?5,RMPR("NAME"),!,?5,RMPR("ADD"),!,?5,RMPR("CITY")
28ADD ;ADDRESS INFO
29 S RMPRUP=0,I=0,RMPRV=$P(^RMPR(664,RMPRA,0),U,4),RMPRV=^PRC(440,RMPRV,0),RMPRST=$P(RMPRV,U,7),RMPRST=$S(RMPRST="":"NO STATE",1:$P(^DIC(5,RMPRST,0),U,2)),RMPRDUZ="",RMPRDUZ=$P(^RMPR(664,RMPRA,0),U,9),RMPRDUZ=$P(^VA(200,RMPRDUZ,0),U,1)
30 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2)
31 S I=$O(^RMPR(664,RMPRA,1,I))
32 S RMPRI=$P(^RMPR(664,RMPRA,1,I,0),U,1)
33 S RMPRUP=$O(^RMPR(665,"C",RMPRI,RMPRDFN,RMPRUP))
34 S:RMPRUP RMPRSN=$P(^RMPR(665,RMPRDFN,5,RMPRUP,0),U,3)
35 ;Should call VADPT not look at global directly
36 S RMPRNAM=$P(^DPT(RMPRDFN,0),U,1)
37 S RMPRSSN=$P(^DPT(RMPRDFN,0),U,9)
38 S RMPRTN=$P(^RMPR(664,RMPRA,0),U,7)
39WRITE W !!!!!,?5,$P(RMPRV,U,1),?53,"In Reply Refer to:",?73,$$STA^RMPRUTIL_"-",$$ROU^RMPRUTIL(RMPRSITE),!,?5,$P(RMPRV,U,2),?53,RMPRNAM
40 W !?5,$P(RMPRV,U,6),", ",RMPRST," ",$P(RMPRV,U,8)
41 W ?53,$E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,9),!,?53,RMPRTN
42 W !!,?5,$P(RMPRV,U,1),!!,?5,"With reference to your request of ",?39,$E($P(^RMPR(664,RMPRA,0),U,1),4,5),"/",$E($P(^RMPR(664,RMPRA,0),U,1),6,7),"/",$E($P(^RMPR(664,RMPRA,0),U,1),2,3),", authority is granted to repair "
43 W !,?5,"the appliance described below for the above-named veteran."
44DESC ;ITEM,DES,COST,QTY
45 S $P(LINE,".",75)=""
46 W !!,?5,LINE,!,?23,"DESCRIPTION OF APPLIANCE OR REPAIR",!,?63,"Unit",?73,"Total",!,?5,"Item",?11,"Name",?32,"Serial Number",?55,"Qty",?63,"Price",?73,"Cost",!,?5,LINE
47 S I=0,RMPRTO=0 F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)),RMPRDFN="" G COST:I'>0 D LIST
48COST S X=RMPRTO,X2="2$",X3=9 D COMMA^%DTC
49 W !!,?5,"The total cost, not including mailing cost, will not exceed ",?RR+1,X,!!,?5,"When repairs are completed, please attach the original of this letter to"
50 W !,?5,"the original copy of your invoice covering repair charges. Your invoice,",!,?5,"in original and one copy should then be forwarded to this office for"
51 W !?5,"payment.",!!?5,"Please retain the duplicate copy of this letter for your files."
52 W !!,?5,"Sincerely,",!!!!,?5,RMPR("SIG"),", Chief",!,?5,RMPR("SBT")
53END S L=19-RMPRTT F I=1:1:L W !
54 W ?5,"Initiator: ",RMPRDUZ,?45,"REF: ",RMPRA,?64,"ADP FORM 10-55" D:$D(RMPRPRIV) ^RMPRP23
55EXIT K RMPRACT,ZTSK,RX,RMPRI,RMPRTN,RMPRDS,RMPRQT,RMPRCT,RMPRTO,RMPRUP,RR,I,DATE,DIC,RG,L,LINE,RMPRA,RMPRDFN,RMPRIS,RMPRNAM,RMPRNM,RMPRSN,RMPRSSN,RMPRST,RMPRTT,RMPRPRIV,RMPRCC,RXT,RX1
56 K RMPRV,X2,X3,RMPRDUZ,RMPRI1,RMPRIT,RMPRN,VA,VAEL,RZZZ,VAERR,Y,RMPRPRIV,RTX D ^%ZISC Q
57LIST S RR=^RMPR(664,RMPRA,1,I,0),RMPRIS=$P(RR,U,5),RMPRIS=$P(^PRCD(420.5,RMPRIS,0),U,1),RMPRI=$P(RR,U,1),RMPRI=$P(^RMPR(661,RMPRI,0),U,1),RMPRI=^PRC(441,RMPRI,0),RMPRNM=$P(RMPRI,U,2),RMPRI=$P(RMPRI,U,1)
58 S RMPRCT=$P(RR,U,3),RMPRQT=$P(RR,U,4),RMPRTO=(RMPRCT*RMPRQT)+RMPRTO,RMPRDS=$P(RR,U,2),X=RMPRCT,X2="2$",X3=9 D COMMA^%DTC S RR=$L(X),RR=79-RR W !,?5,RMPRI,?11,$E(RMPRNM,1,18),?32,$G(RMPRSN),?56,RMPRQT,?59,X,!,?11,RMPRDS
59 I $P(^RMPR(664,RMPRA,0),U,10)!($P(^(0),U,11)) S RR=$S($P(^(0),U,11):$P(^(0),U,11),1:$P(^(0),U,10)) I RR S X=RR,X2="2$",X3=9 D COMMA^%DTC S RR=$L(X),RR=79-RR W !,?32,"Shipping Charge: ",?59,X,!
60 I $D(R55(1,1,1,0)) F RTX=0:0 S RTX=$O(R55(1,1,1,RTX)) Q:RTX'>0 W !,?5,R55(1,1,1,RTX,0)
61CNTER S RMPRTT=(RMPRTT+1) K R55 Q
62PT F RG="DT","RMPRSITE","RMPRA","RMPRUP","RMPR(" S ZTSAVE(RG)="" S:$D(RMPRACT) ZTSAVE("RMPRACT")="" S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")=""
63 I $D(IO("Q")) S ZTRTN="EN1^RMPRP55",ZTDTH=$H,ZTDESC="PROSTHETICS PRINT OF 10-55",ZTIO=ION D ^%ZTLOAD
64 W !,$S($D(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST DID NOT QUEUE!>")
65 D HOME^%ZIS G EXIT
Note: See TracBrowser for help on using the repository browser.