source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29RG.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: 8.6 KB
Line 
1RMPR29RG ;HIOFO/SPS-OWL WINDOWS PRINTER [ 12/01/05 5:39 AM ]
2 ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25
3 ;get basic info, system variables
4 ;WINDOW FAX/PRINT 2529-3 PASS RMPRA
5 ;REQUIRED VARIABLES: RMPRDA - ENTRY NUMBER IN FILE 664.1
6 ; RMPRSITE - SITE OFSTATION PROCESSING 2529-3
7 ; RMPRPTR - "WINDOWS"
8IN(RMPRA,RMPRSITE,RMPRPTR) ;
9 ;TEST ENTRY
10 D IN2
11 Q
12 K CNT,I,K,L,LCN,LNM,LSSN,LSTN,R643,RDO,RDI,RHDA,RI,RIDA,RIDES,RMPR,RMPR0
13 K RMPR21,RMPRAOF,RMPRCDT,RMPRCSZ,RMPRD,RMPRDA,RMPREXT,RMPRINM,RMPRINSN
14 K RMPRL,RMPRODT,RMPRRDT,RMPRROF,RMPRS,RMPRSOP,RMPRSTN,RMPGIP,RPHCPC
15 K RD0,RD1,RPGIP,RPSAITEM,RPSALOC,SPACE,VA,VADM,VAEL,VAPA
16PRT(RESULTS,RMPRA,RMPRSITE,RMPRPTR) ;GUI ENTRY
17IN2 I RMPRPTR'="WINDOWS" S RMPRDA=RMPRA G PRT^RMPR29R
18 K ^TMP($J,"RMPRT"),RESULTS
19 S DIC=4,DIC(0)="QZN",X=$P(^RMPR(664.1,RMPRA,0),U,15)
20 D ^DIC G:+Y'>0 EXIT
21 N RC
22 S RMPRINS=+Y,RC=0,RMPRINSN=$P(^DIC(4,RMPRINS,99),U)
23 S RMPRST=$S($D(^DIC(5,+$P(Y(0),U,2),0)):$P(^(0),U),1:"")
24 S (RMPRAD(1),RMPRAD(2),RMPRCT,RMPR9P)=""
25 I $D(^DIC(4,RMPRINS,1)) S RMPRAD(1)=$P(^(1),U,1),RMPRAD(2)=$P(^(1),U,2),RMPRCT=$P(^(1),U,3),RMPR9P=$P(^(1),U,4)
26 S DFN=$P(^RMPR(664.1,RMPRA,0),U,2) D ALL^VADPT
27 ;
28 I $P(^RMPR(664.1,RMPRA,0),U,11)="N" N RMPRFCTR D
29 .;national footwear center address in RMPRFCTR array used in print
30 .;template RMPR 25293
31 .S RMPRFCTR(1)="179TH ST & LINDEN BLVD."
32 .S RMPRFCTR(2)="ST. ALBANS, NY 11425"
33 ;
34 S RMPR0=^RMPR(664.1,RMPRA,0)
35 S RMPRRDT=$$EXTERNAL^DILFD(664.1,17,,$P(RMPR0,U,18))
36 S RMPRCDT=$$EXTERNAL^DILFD(664.1,23,,$P(RMPR0,U,26))
37 S RMPRROF=$$EXTERNAL^DILFD(664.1,13,,$P(RMPR0,U,5))
38 S RMPRAOF=$$EXTERNAL^DILFD(664.1,14,,$P(RMPR0,U,7))
39 S RMPRODT=$$EXTERNAL^DILFD(664.1,.01,,$P(RMPR0,U,1))
40 S (RMPRL,RMPRD,RMPRS)="",$P(RMPRL,"_",81)="",$P(RMPRD,"-",81)=""
41 S ^TMP($J,"RMPRT",0)=" REQUEST AND RECEIPT FOR PROSTHETIC APPLIANCES OR SERVICES "
42 S ^TMP($J,"RMPRT",1)=RMPRL
43 S ^TMP($J,"RMPRT",2)=" SECTION I"
44 S ^TMP($J,"RMPRT",3)=RMPRD
45 S RMPRSOP=$$EXTERNAL^DILFD(664.1,2,,$P(RMPR0,U,11))
46 S ^TMP($J,"RMPRT",4)="TO: | "_RMPRSOP
47 S L=$L(RMPRSOP),L=L+38,$P(RMPRS," ",80-L)=""
48 S (L,RMPRS)="",L=$L(RMPRSOP),L=L+6,$P(RMPRS," ",(45-L))=""
49 S ^TMP($J,"RMPRT",4)=^TMP($J,"RMPRT",4)_RMPRS_"1. VETERANS NAME (LAST,FIRST,M.I.)"
50 S ^TMP($J,"RMPRT",5)=" "_$$EXTERNAL^DILFD(664.1,.11,,$P(RMPR0,U,15))
51 S (L,RMPRS)="",L=$L($$EXTERNAL^DILFD(664.1,.11,,$P(RMPR0,U,15))),L=L+6,$P(RMPRS," ",(49-L))=""
52 S ^TMP($J,"RMPRT",5)=^TMP($J,"RMPRT",5)_RMPRS_VADM(1)
53 I RMPRAD(1)'="" S ^TMP($J,"RMPRT",6)=" "_$E(RMPRAD(1),1,30)
54 I RMPRAD(2)'="" S ^TMP($J,"RMPRT",7)=" "_$E(RMPRAD(2),1,30)
55 S ^TMP($J,"RMPRT",8)=" "_RMPRCT_", "_RMPRST_" "_RMPR9P
56 S ^TMP($J,"RMPRT",9)=RMPRD
57 S ^TMP($J,"RMPRT",10)="2. VETERANS ADDRESS 3. CLAIM NO. 4. SSN 5. STATION NO."
58 S LNM=$L(VADM(1)),LCN=$L(VAEL(7)),LSSN=$L(VA("PID")),LSTN=$L(RMPRINSN)
59 S (L,RMPRS)="",L=$L(VADM(1)),L=L+3,$P(RMPRS," ",(36-L))=""
60 S ^TMP($J,"RMPRT",11)=" "_VADM(1)_RMPRS_VAEL(7)
61 S (L,RMPRS)="",L=L+$L(VAEL(7)),$P(RMPRS," ",(17-L))=""
62 S ^TMP($J,"RMPRT",11)=^TMP($J,"RMPRT",11)_RMPRS_VA("PID")_" "_RMPRINSN
63 S ^TMP($J,"RMPRT",12)=" "_VAPA(1)
64 I VAPA(2)'="" S ^TMP($J,"RMPRT",13)=" "_VAPA(2)
65 I VAPA(3)'="" S ^TMP($J,"RMPRT",14)=" "_VAPA(3)
66 S RMPRCSZ=$P(VAPA(4),U,1)_","_$P(VAPA(5),U,2)_" "_VAPA(6)
67 S L=$L(RMPRCSZ),L=50-L,SPACE="",$P(SPACE," ",L)=""
68 S (L,RMPRS)="",L=L+$L(RMPRCSZ),$P(RMPRS," ",(50-L))=""
69 S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
70 S ^TMP($J,"RMPRT",CNT+1)=" "_RMPRCSZ_RMPRS_"VETERANS PHONE: "_VAPA(8)
71 S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
72 S ^TMP($J,"RMPRT",CNT+1)=RMPRD
73 S ^TMP($J,"RMPRT",CNT+2)="6. AUTHORITY FOR ISSUANCE 7. ELIGIBILITY STATUS 8. DATE REQUIRED"
74 S ^TMP($J,"RMPRT",CNT+3)=" CFR 17.115 "_$S($P(VAEL(3),U,1)=1:"SC",1:"NSC")
75 ;S ^TMP($J,"RMPRT",CNT+4)=" 9. DISABILITY CODE:"
76 S ^TMP($J,"RMPRT",CNT+5)=RMPRD
77 S ^TMP($J,"RMPRT",CNT+6)=" 10.TYPES AND QUANTITIES OF APPLIANCES AND/OR SERVICES REQUESTED"
78 S ^TMP($J,"RMPRT",CNT+7)=RMPRD
79 S ^TMP($J,"RMPRT",CNT+8)=" *UNIT *TOTAL"
80 S ^TMP($J,"RMPRT",CNT+9)=" ITEM # NOMENCLATURE QTY UNIT COST COST"
81 S ^TMP($J,"RMPRT",CNT+10)=RMPRD
82 ; Item Multiple
83 S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
84 S RI=""
85 F S RI=$O(^RMPR(664.1,RMPRA,2,RI)) Q:RI="" D
86 .Q:'$D(^RMPR(664.1,RMPRA,2,RI,0))
87 .S CNT=CNT+1
88 .S RMPR21=$G(^RMPR(664.1,RMPRA,2,RI,0))
89 .I RMPR21="" S RESULTS="1^No item multiple found"
90 .F I=1:1:11 S RMPR21(I)=""
91 .S RMPR21(1)=$P(RMPR21,U,1),RMPR21(2)=$P(RMPR21,U,2)
92 .S RMPR21(3)=$$EXTERNAL^DILFD(664.16,3,,$P(RMPR21,U,3))
93 .S RMPRINM=$$EXTERNAL^DILFD(664.16,.01,,$P(RMPR21,U)),RMPRINM=$E(RMPRINM,1,24)
94 .S RMPR21(4)=$S($P(RMPR21,U,4)>0:$P(RMPR21,U,4),1:"0.00")
95 .S RMPR21(11)=$S($P(RMPR21,U,11)>0:$P(RMPR21,U,11),1:"0.00")
96 .S (L,RMPRS)="",L=L+6,L=L+$L(RMPR21(1)),$P(RMPRS," ",(15-L))=""
97 .S ^TMP($J,"RMPRT",CNT)=" "_RMPR21(1)_RMPRS_RMPRINM
98 .S (L,RMPRS)="",L=L+$L(RMPRINM),$P(RMPRS," ",(29-L))=""
99 .S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(2)
100 .S (L,RMPRS)="",L=L+$L(RMPR21(2)),$P(RMPRS," ",(14-L))=""
101 .S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(3)
102 .S (L,RMPRS)="",L=L+$L(RMPR21(3)),$P(RMPRS," ",(8-L))=""
103 .S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(4)_RMPRS_RMPR21(11)
104 .S RMPREXT=0
105 .F S RMPREXT=$O(^RMPR(664.1,RMPRA,2,RI,1,RMPREXT)) Q:RMPREXT="" D
106 ..S CNT=CNT+1
107 ..S ^TMP($J,"RMPRT",CNT)=^RMPR(664.1,RMPRA,2,RI,1,RMPREXT,0)
108 .D HCP
109 S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
110 S ^TMP($J,"RMPRT",CNT+1)=RMPRD
111 S ^TMP($J,"RMPRT",CNT+2)="11. PROCUREMENT SOURCE: "_RMPRSOP
112 S ^TMP($J,"RMPRT",CNT+3)=RMPRD
113 S ^TMP($J,"RMPRT",CNT+4)="12. SIGNATURE AND TITLE OF 13. DATE 14. SIGNATURE AND TITLE OF 15. DATE"
114 S ^TMP($J,"RMPRT",CNT+5)=" REQUESTING OFFICIAL "_RMPRRDT_" APPROVING OFFICIAL"
115 S (L,RMPRS)="",L=+$L(RMPRROF),$P(RMPRS," ",(46-L))=""
116 S ^TMP($J,"RMPRT",CNT+6)=" "_RMPRROF_RMPRS_RMPRAOF
117 S ^TMP($J,"RMPRT",CNT+7)=RMPRD
118 S ^TMP($J,"RMPRT",CNT+8)=" SECTION III"
119 S ^TMP($J,"RMPRT",CNT+9)=RMPRL
120 S ^TMP($J,"RMPRT",CNT+10)="16. ORDER NUMBER 17. DATE OF ORDER 18. DATE ITEM RECIEVED"
121 S (L,RMPRS)="",L=$L($P(RMPR0,U,13)),$P(RMPRS," ",(30-L))=""
122 S ^TMP($J,"RMPRT",CNT+11)=" "_$P(RMPR0,U,13)_RMPRS_RMPRODT
123 S ^TMP($J,"RMPRT",CNT+12)=RMPRD
124 S ^TMP($J,"RMPRT",CNT+13)="19. DATE DELIVERED 20. SIGNATURE OF INSPECTING OFFICIAL"
125 S ^TMP($J,"RMPRT",CNT+14)=""
126 S ^TMP($J,"RMPRT",CNT+15)=RMPRD
127 S ^TMP($J,"RMPRT",CNT+16)="21. CERTIFICATE OF RECEIPT OR DELIVERY (Check One)"
128 S ^TMP($J,"RMPRT",CNT+17)=RMPRD
129 S ^TMP($J,"RMPRT",CNT+18)="[ ] I certify that I have received the items listed above"
130 S ^TMP($J,"RMPRT",CNT+19)="[ ] I certify that the above item(s) have been sent to"
131 S ^TMP($J,"RMPRT",CNT+20)=" the Veteran or the requesting field station"
132 S ^TMP($J,"RMPRT",CNT+21)=RMPRD
133 S ^TMP($J,"RMPRT",CNT+22)="22. SIGNATURE OF VETERAN OR VA OFFICIAL"
134 S ^TMP($J,"RMPRT",CNT+23)=""
135 S ^TMP($J,"RMPRT",CNT+24)=RMPRD
136 S ^TMP($J,"RMPRT",CNT+25)="23 SIGNATURE OF DESIGNATED EMPLOYEE 24. DATE 25. STATION NO."
137 S RMPRSTN="" I $D(RMPR("STA")) S RMPRSTN=$P($G(^DIC(4,+RMPR("STA"),99)),U)
138 S ^TMP($J,"RMPRT",CNT+26)=" "_RMPRCDT_" "_RMPRSTN
139 S ^TMP($J,"RMPRT",CNT+27)=RMPRD
140 S ^TMP($J,"RMPRT",CNT+28)="ADP FORM 2529-3"
141 M RESULTS=^TMP($J,"RMPRT")
142 G EXIT
143 Q
144HCP ;print HCPCS and GIP or Pros Inventory in -3.
145 Q:RI'>0
146 S RD0=RMPRA,RD1=RI
147 Q:'$D(^RMPR(664.1,RD0,2,RD1,0))
148 S R643=$G(^RMPR(664.1,RD0,2,RD1,3))
149 S RPSAITEM=$P(R643,U,3),RPSALOC=$P(R643,U,4)
150 S RPHCPC=$P($G(^RMPR(664.1,RD0,2,RD1,2)),U,1)
151 Q:'$G(RPHCPC)
152 Q:'$D(^RMPR(661.1,RPHCPC,0))
153 S RPGIP=$P($G(^RMPR(664.1,RD0,2,RD1,0)),U,13)
154 S ^TMP($J,"RMPRT",CNT+1)=" HCPCS: "_$P(^RMPR(661.1,RPHCPC,0),U,1)
155 I $G(RPSALOC),RPSAITEM'="",$D(^RMPR(661.3,RPSALOC,0)) D
156 .S RHDA=$O(^RMPR(661.3,RPSALOC,1,"B",RPHCPC,0)) Q:'$G(RHDA)
157 .S RIDA=$O(^RMPR(661.3,RPSALOC,1,RHDA,1,"B",RPSAITEM,0))
158 .S RIDES=$P($G(^RMPR(661.3,RPSALOC,1,RHDA,1,RIDA,0)),U,8)
159 .S ^TMP($J,"RMPRT",CNT+1)=^TMP($J,"RMPRT",CNT+1)_" RIDES"
160 I $G(RPSALOC) S ^TMP($J,"RMPRT",CNT+2)="*** Pros Inventory *** Location: "
161 I $G(RPSALOC) S:$D(^RMPR(661.3,RPSALOC,0)) ^TMP($J,"RMPRT",CNT+2)=^TMP($J,"RMPRT",CNT+2)_$P(^RMPR(661.3,RPSALOC,0),U,1)
162 I '$G(RPSALOC),$G(RPGIP) S ^TMP($J,"RMPRT",CNT+2)=" *** GIP ***"
163 I '$G(RPSALOC),'$G(RPGIP) S ^TMP($J,"RMPRT",CNT+2)=" *** OTHER ***"
164 Q
165EXIT ;common exit point
166 K RMPRA,RMPRSITE,RMPRPTR,RMPRINS,RMPRST,RMPRAD,DIC,DFN
167 K RA,RB,RFL,RMPRCT,RMPRI,RMPRSC,RMPRWO,RMPR9P,SRC,TO,X,Y
168 D KVAR^VADPT
169 Q
Note: See TracBrowser for help on using the repository browser.