source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29W.m@ 1700

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

initial load of FOIAVistA 6/30/08 version
File size: 5.2 KB
Line 
1RMPR29W ;PHX/JLT/HNB-DISPLAY JOB RECORD HDR AND ITEM [ 11/04/94 10:07 AM ]
2 ;;3.0;PROSTHETICS;;Feb 09, 1996
3GET(PRDA) ;INFOR FOR JOB SECTION
4 K RMPRWO
5 S DFN=$P(^RMPR(664.1,PRDA,0),U,2),SRC=$P(^(0),U,11)
6 D KVAR^VADPT,DEM^VADPT,ELIG^VADPT
7 K DIQ,TMP,TECH,^UTILITY($J,"TEXT"),^UTILITY("DIQ1",$J)
8 S DIC="^RMPR(664.1,"
9 S DA=PRDA,DR=".02;4;12;12.1;12.2;12.3;12.4;13;15;19"
10 D EN^DIQ1
11 S RI=0
12 K RCK
13 F S RI=$O(^RMPR(664.1,PRDA,2,RI)) Q:RI'>0 Q:'$D(^RMPR(664.1,PRDA,2,RI,0)) D
14 .S DA=PRDA,DIC="^RMPR(664.1,"
15 .S DR="6",DR(664.16)=".01;2;3;8;10",DA(664.16)=RI
16 .S DA660=$P(^RMPR(664.1,PRDA,2,RI,0),U,5),TYPE=$P(^(0),U,7)
17 .I +DA660 S RMPRWO=$O(^RMPR(664.2,"C",DA660,0))
18 .Q:'+$G(RMPRWO)
19 .S RMPRJOB=$P(^RMPR(664.2,RMPRWO,0),U,4)
20 .S RCK(RMPRJOB)=$$ITM1^RMPR31U(+$P(^RMPR(664.1,PRDA,2,RI,0),U))_U_DA660_U_RMPRWO_U_RI_U_TYPE
21 .D EN^DIQ1
22 I '$D(RCK) Q
23 K DR S RI=0
24 F S RI=$O(RCK(RI)) Q:RI'>0 D
25 .S DIC="^RMPR(664.2,",DR="4;5;8;9;10;11;12"
26 .S (RMPRWO,DA)=$P(RCK(RI),U,3)
27 .S DIQ(0)="IE" D EN^DIQ1 K DIQ
28 .K DR S DA=RMPRWO,RJ=0
29 .F S RJ=$O(^RMPR(664.2,DA,1,RJ)) Q:RJ'>0 D
30 ..S DIQ="TMP("_DA_",",DA(664.22)=RJ
31 ..S DR="2",DR(664.22)=".01;1;2;3;4;6;10;11"
32 ..D EN^DIQ1 K DIQ
33 ..I $P($G(^RMPR(664.2,DA,1,RJ,0)),U,11) S TMP(DA,664.22,RJ,3)="P"
34 .D WP
35 S RI=0
36 F S RI=$O(RCK(RI)) Q:RI'>0 D
37 .S RDA=$P(RCK(RI),U,2),RMPRWO=$P(RCK(RI),U,3)
38 .Q:'+RDA
39 .S DA=0
40 .F S DA=$O(^RMPR(664.3,"C",RDA,DA)) Q:DA'>0 I $D(^RMPR(664.3,DA,0)) S RMPRDT=$P(^(0),U) D
41 ..K DR S RT=0
42 ..F S RT=$O(^RMPR(664.3,DA,1,RT)) Q:RT'>0 D
43 ...S DIC="^RMPR(664.3,"
44 ...;DIQ array should start with DI
45 ...S DIQ(0)="IE",DIQ="TECH("_RMPRWO_","_RMPRDT_","
46 ...S DA(664.33)=RT,DR="3",DR(664.33)=".01;1;2"
47 ...D EN^DIQ1 K DIQ
48 Q
49 ;see internal notes
50EXIT ;common exit
51 K DA,DA660,DFN,DIRUT,DIWF,DIWL,DTOUT,PAGE,PDA,PRDA,RMPRBACK
52 K RMPRDA,RMPRDFN,RMPRDIR3,RMPRDIR7,RMPRDT,RMPRJOB
53 K RMPRWO,XRC,VADM,VAEL,TYPE,RDA,RJ,RT,RWP,RR Q
54 Q
55HDR(PRDA) ;DISPLAY JOB RECORD HEADER
56 ;
57 S PAGE=PAGE+1
58 W @IOF,!,?31,"JOB RECORD SECTION",?65,"PAGE:"
59 W ?72,PAGE,!,?19,"(To be completed by VA Shop or Clinic only)"
60 W !,"VETERAN",?25,"CLAIM #",?37,"WARD",?52,"SSN"
61 W ?64,"WORK ORDER #",!,RMPR("L")
62 W !,"|"_^UTILITY("DIQ1",$J,664.1,PRDA,.02)
63 W ?24,"|"_$P($G(VAEL(7)),U),?36,"|"_^UTILITY("DIQ1",$J,664.1,PRDA,12)
64 W ?51,"|"_$P(VADM(2),U)
65 W ?64,"|"_^UTILITY("DIQ1",$J,664.1,PRDA,4),!,RMPR("L")
66 W !,"|DATE ASSIGNED:",?16,^UTILITY("DIQ1",$J,664.1,PRDA,19)
67 W ?36,"|ASSIGNED TO: ",^UTILITY("DIQ1",$J,664.1,PRDA,15),!,RMPR("L")
68 I ^UTILITY("DIQ1",$J,664.1,PRDA,12)'="" W !,"|PHYSICIAN:",?16,^(12.1),?42,"|DIAGNOSIS:",?57,^(12.2),!,?0,"|TREATING SPEC:",?16,^(12.3),?42,"|EXT:",?57,^(12.4),!,RMPR("L")
69 Q
70 ;
71WP ;use DIWP to print REMARKS word processing field
72 ;
73 K ^UTILITY($J,"W") S RWP=0,RW=0
74 F S RW=$O(^UTILITY("DIQ1",$J,664.2,RMPRWO,12,RW)) Q:RW'>0 D
75 .S X=^(RW)
76 .S DIWF="R",DIWL=1,DIWR=79
77 .D ^DIWP
78 .S RR=0
79 .F S RR=$O(^UTILITY($J,"W",DIWL,RR)) Q:RR'>0 D
80 ..S RWP=RWP+1,^UTILITY($J,"TEXT",RMPRWO,RWP)=^(RR,0)
81 ..K ^UTILITY($J,"W")
82 Q
83HD ;print header
84 W @IOF
85 W ?10,"REQUEST AND RECEIPT FOR PROSTHETIC APPLIANCES OR SERVICES"
86 W ?70,"PAGE:",?77,PAGE,!,?34,"(Section I)"
87 W !,"VETERAN",?25,"WORK ORDER #",?44,"VENDOR",?60,"REQUESTOR"
88 W !,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,.02),1,20)
89 W ?24,"|"_^UTILITY("DIQ1",$J,664.1,RMPRDA,4)
90 W ?43,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,2),1,15),?59,"|"_$E(^(13),1,20)
91 W !,"|ORDERING STATION: ",?25,^UTILITY("DIQ1",$J,664.1,RMPRDA,.04)
92 W !,RMPR("L"),!,"|AUTHORITY: CFR 17.115",?42,"|DATE REQUIRED:"
93 W ?57,^UTILITY("DIQ1",$J,664.1,RMPRDA,.09)
94 W !,RMPR("L"),!,"|ASSIGNED TO:"
95 W ?16,^UTILITY("DIQ1",$J,664.1,RMPRDA,15),?42,"|DATE ASSIGNED:"
96 W ?57,^UTILITY("DIQ1",$J,664.1,RMPRDA,19),!,RMPR("L")
97 Q
98 ;
99HDC ;print header of mult. page
100 W @IOF
101 W ?10,"REQUEST AND RECEIPT FOR PROSTHETIC APPLIANCES OR SERVICES"
102 W ?70,"PAGE:",?77,PAGE,!,?34,"(Section I)"
103 W !,"VETERAN",?44,"VENDOR",?60,"REQUESTOR"
104 W !,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,.02),1,20)
105 W ?43,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,2),1,15)
106 W ?59,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,13),1,20),!,RMPR("L")
107 W !,"|TO: "_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,.11),1,30)
108 W ?42,"ORDERING STATION: "_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,.04),1,20),RMPR("L")
109 W !,"|AUTHORITY: CFR 17.115",?42,"|DATE REQUIRED:",?57,^(.09)
110 W !,RMPR("L")
111 Q
112 ;
113HELP ;DISPLAY HELP FOR SCREENS
114 ;
115 N RMPR90DP,RMPR90I
116 W !
117 S RMPR90DP=$P(DIR(0),U,2,999)
118 F RMPR90I=1:1:6 I $P($P(RMPR90DP,";",RMPR90I),":",1)'="" W:RMPR90I=4 ! W "("_$P($P(RMPR90DP,";",RMPR90I),":",1)_") "_$P($P(RMPR90DP,";",RMPR90I),":",2)_" "
119 W !
120 Q
121 ;
122DIS(RMPRDFN,PDA) ;GET DISABILITY CODES PASS RMPRDFN AND PDA
123 ;
124LK ;do a lookup on 2529-3 record patient/disability code
125 K DIR S DIR(0)=$S($O(^RMPR(664.1,RMPRDA,1,0)):"FO",1:"F")
126 S DIR("A")="Select 2529-3 DISABILITY CODE"
127 S DIR("?")="^D DSP^RMPR29W"
128 D ^DIR Q:$D(DTOUT)!($D(DIRUT))
129 K DIC
130 S DIC("W")="S RA=^(0) D LP^RMPRDIS"
131 S DIC("S")="I '$P(^(0),U,10)"
132 S DIC="^RMPR(665,"_RMPRDFN_",1,"
133 S DIC("P")="665.01IP",DIC(0)="EQMZ"
134 D ^DIC G:+Y'>0 LK
135 Q
136 ;
137DSP ;DISPLAY DISABILITY CODES
138 ;see internal notes 6/23/95
139 ;Q:'$D(^RMPR(664.1,PDA,1,0))
140 D LP^RMPRDIS
141 ;W !!,?5,"Select 2529-3 DISABILITY CODE",!
142 S RI=0
143 F S RI=$O(^RMPR(664.1,PDA,1,RI)) Q:RI'>0 I $D(^(RI,0)) S RT=^(0) W !,?5,$P($G(^RMPR(662,+RT,0)),U),?15,$S($P(RT,U,2)=1:"SC ",1:"NSC ")
144 K RI
145 W !
146 S (RMPRDIR7,RMPRDIR3,RMPRBACK)=1 W !! D EN^RMPRDIS
147 Q
Note: See TracBrowser for help on using the repository browser.