source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPRT.m@ 868

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

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1RMPRPRT ;PHX/HNB-PRINT 2319 ;3/18/03 09:04
2 ;;3.0;PROSTHETICS;**7,50,77,105**;Feb 09, 1996
3 ;
4 ; ODJ - Patch 50 - 7/7/00 - NOIS SFC-0300-62501
5 ; Put N I statement in HDR subroutine
6 ; because it can get killed here and
7 ; calling routines are still using it
8 ; RVD 3/18/03 patch #77 - remove the ability of adding pt under
9 ; option print 2319.
10 ;
11DSP ;DO PRE DISPLAY HOUSEKEEPING
12 ;VARIABLES REQUIRED:
13 ;VARIABLES SET; RMPR ARRAY - SITE SPECIFIC INFO
14 ; RMPRDFN - IEN OF PATIENT IN FILE 665
15 ; RMPRNAM - NAME OF PATIENT
16 ; RMPRSSN - SSN O PATIENT
17 ; RMPRDOB - EXTERNAL VERSION OF PATIENT'S DATE OF BIRTH
18 ; CALLED BY DSP1^RMPRPRT
19 D DIV4^RMPRSIT G:$D(X) EXIT
20 K RMPRDFN,RMPRSSN,RMPRSSNE,RMPRDOB,DIC,Y
21 S DIC="^RMPR(665,",DIC(0)="AEMQ"
22 S DIC("A")="Select PROSTHETIC PATIENT: " D ^DIC K DIC Q:$G(Y)'>0
23 S:+Y>0 (RMPRDFN,DFN)=+Y D DEM^VADPT,ELIG^VADPT
24 S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
25 S RMPRDOB=$P(VADM(3),U),RMPRSSNE=VA("PID")
26 S RMPRCNUM=VAEL(7)
27 I +VADM(6) S RMPRDOD=$P(VADM(6),U) W !!,$C(7),"PATIENT IS DECEASED. DATE OF DEATH WAS ",$P(VADM(6),U,2)
28 I $D(RMPRDOD) S DIR(0)="Y",DIR("A")="Would you Like to continue Processing this Patient",DIR("B")="NO" D ^DIR K DIR I +Y=0 K RMPRDFN
29 K RMPRDOD D KVAR^VADPT
30 G:'$D(RMPRDFN) EXIT
31DSP2 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
32 I '$D(IO("Q")) U IO G DSP1
33 K IO("Q") S ZTRTN="START^RMPRPRT",ZTDESC="PROSTHETIC PATIENT PRINT",ZTIO=ION F RG="RMPRDFN","RMPRNAM","RMPRDOB","RMPRSSN" S ZTSAVE(RG)=""
34 K RG D ^%ZTLOAD G EXIT
35DSP1 I $E(IOST)["C" S RFLG=1 D ^RMPRPAT K ANS W ! ;G DSP2
36START ;DO THE ACUTAL PRINTINTG OF THE ELIGIBILITY SCREENS DATA TO THE PRINTER
37 ;VARIABLES REQUIRED: RMPRDFN - PATIENT IEN IN FILE 665
38 ; RMPRNAM - PATIENT'S NAME
39 ; RMPRSSN - PATIENT'S SSN NUMBEER
40 ; RMPRDOB - PATIENT'S DATE OF BIRTH
41 ;VARIABLES SET: RMPR($J,"DESQ",--- - ARRAY HOLDS PATIENT EYE AND
42 ; HAIR COLOR
43 ; RA("DIQ1",$J,--- - ARRAY HOLDS PATIENT MAS
44 ; R5(--- - ARRAY HOLDING PROSTHETIC DISABILITY
45 ; CODE INFORMATION
46 ;CALLED BY DSP^RMPRPRT
47 Q:$G(RMPRDFN)<1
48 S PAGE=1
49 K DIQ,DIC S DIC=2,DA=RMPRDFN,DR=.3721,DR(2.04)=".01;2;3",DIQ="RA(""DIQ1"",$J," F LP=1:1 S DA(2.04)=LP D EN^DIQ1 Q:$G(RA("DIQ1",$J,2.04,LP,.01))=""
50 S HGT=" ",WGT=" " S:$D(^RMPR(665,RMPRDFN,10)) HGT=$P(^(10),U,1),WGT=$P(^(10),U,2)
51 S %X="^RMPR(665,"_RMPRDFN_",",%Y="R5(" D %XY^%RCR K %X,%Y S DFN=RMPRDFN
52 K DIQ,DIC S DIC="^RMPR(665,",DR="22;23",DA=RMPRDFN,DIQ="RMPR($J,""DESC"",",DIQ(0)="E" D EN^DIQ1 K DIC,DIQ,DR
53 S HAIR=$S($G(RMPR($J,"DESC",665,RMPRDFN,23,"E"))'="":RMPR($J,"DESC",665,RMPRDFN,23,"E"),1:" "),EYE=$S($G(RMPR($J,"DESC",665,RMPRDFN,22,"E"))'="":RMPR($J,"DESC",665,RMPRDFN,22,"E"),1:" ")
54 D HDR D ADD^VADPT W !,"Phone: ",$S($G(VAPA(8))'="":VAPA(8),1:"UNKNOWN"),!
55 S DFN=RMPRDFN D OAD^VADPT W !,"Office: ",$S(VAOA(8)'="":VAOA(8),1:"UNKNOWN"),!
56 D COMP^RMPRUTIL W !,"Permanent Address:",?40,"Temporary Address:",!,XP(1),?40,X1(1),!
57 W:J>2 XP(2) W:J1>2 ?40,X1(2) W:(J>2!(J1>2)) ! W:J>3 XP(3) W:J1>3 ?40,X1(3) W:(J>3!(J1>3)) ! W:J>4 XP(4) W:J1>4 ?40,X1(4)
58 W:(J>4!(J1>4)) ! K J,J1,XP,X1
59 W !,"Height(IN): ",HGT," Weight(LB): ",WGT," Eyes: ",EYE," Hair: ",HAIR,!!
60 ;if you quit here than that is all that will print on the printer
61 ;is not complete 19 record.
62 ;I $D(RMPRBACK) Q
63END D ELIG^VADPT W !!,"Patient Type: ",$P(VAEL(6),U,2),?40,"Period of Service: ",$P(VAEL(2),U,2),!,"Primary Eligibility Code:",?40,"Status: ",$P(VAEL(9),U,2),!,$P(VAEL(1),U,2)
64 W ?40,"Eligibility Status: ",$E($P(VAEL(8),U,2),1,19) D MB^VADPT W !!,"Receiving A&A Benefits? " W:VAMB(1)=0 "NO" W:$P(VAMB(1),U,1)=1 $P(VAMB(1),U,2)
65 W ?40,"Receiving Housebound Benefits? " W:VAMB(2)=0 "NO" W:$P(VAMB(2),U,1)=1 $P(VAMB(2),U,2)
66 W !,"Receiving Social Security? " W:VAMB(3)=0 "NO" W:$P(VAMB(3),U,1)=1 $P(VAMB(3),U,2) W ?40,"Receiving VA Pension? " W:VAMB(4)=0 "NO" W:$P(VAMB(4),U,1)=1 $P(VAMB(4),U,2)
67 W !,"Receiving Military Retirement? " W:VAMB(5)=0 "NO" W:$P(VAMB(5),U,1)=1 $P(VAMB(5),U,2) W ?40,"Receiving VA Disability? " W:VAMB(7)=0 "NO" W:$P(VAMB(7),U,1)=1 $P(VAMB(7),U,2) W !!
68 W "MAS Disabilities: Code Disability % TOTAL%=",$S($P(VAEL(3),U,2):$P(VAEL(3),U,2),1:""),! S J=0
69 S LP=0 F I=1:1 S LP=$O(RA("DIQ1",$J,2.04,LP)) Q:LP="" D
70 .W !,?21,RA("DIQ1",$J,2.04,LP,.01),?60,RA("DIQ1",$J,2.04,LP,2),?70,RA("DIQ1",$J,2.04,LP,3)
71 I I=1 W !?10," NONE LISTED",!
72 W !,"Prosthetic Disability Codes:",!
73 W ?1,"Code",?10,"Elig",?40,"SC/NSC",?52,"Date",?63,!
74 S J=0 F I=1:1 S J=$O(R5(1,J)) Q:J=""!(J?.A) D DISP
75 I I=1 W !?10,"NONE LISTED",!
76 K I,LP
77 G ^RMPRPRT1
78 Q
79EXIT ;EXIT FROM PRINTING A PATIENT'S 10-2319
80 ;CALLED BY DSP^RMPRPRT AND DSP1^RMPRPRT
81 D ^%ZISC,KVAR^VADPT
82 K RDP,FG,Y,%,AN,NA,ANST,RC,DA,DIC,DIE,DIPGM,DIYS,ANS,EYE,HAIR,HGT,POP,R2,R5,WGT,X,Y,PAGE,RMPRSSNE,RMPRAA68
83 K:'$D(RMPRF)&($G(RMPRBACK)=0) RMPRDFN,RMPRDOB,RMPRNAM,RMPRSSN,VADM
84 Q
85HDR ;HEADER FOR 10-2319
86 ;CALLED BY START^RMPRPRT
87 ;VARTIABLES REQUIRED:RMPRNAM - PATIENT'S NAME
88 ; RMPRSSN - PATIENT'S SSN
89 ; VAEL ARRAY - SEE PIMS TECHNICAL MANUAL
90 ; RMPRDOB - PATIENT'S DATE OF BIRTH
91 N I
92 I $Y+6>IOSL W @IOF
93 I '$D(RMPRSSN) D
94 .N DFN
95 .S DFN=RMPRDFN
96 .D DEM^VADPT
97 .S RMPRSSN=$P(VADM(2),U)
98 .S RMPRDOB=$P(VADM(3),U)
99 W !!,?23,"10-2319 PROSTHETICS VETERAN RECORD",!,$E(RMPRNAM,1,25),?27,"C#: " S DFN=RMPRDFN D ELIG^VADPT W $S(VAEL(7)'="":VAEL(7),1:"UNKNOWN")
100 W ?45,"SSN: ",$E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,9),?63,"DOB: "
101 W $E(RMPRDOB,4,5)_"-"_$E(RMPRDOB,6,7)_"-"_($E(RMPRDOB,1,3)+1700),!
102 ;
103 W "Comment: ",$S($P(R5(0),U,3)]"":$P(R5(0),U,3),1:"")
104 Q
105DISP ;DISPLAY PROSTHETIC DISABILITY CODES
106 ;CALLED BY END^RMPRPRT
107 ;VARIABLES REQUIRED R5 - A STRING ARRAY
108 ; J - AN INDEX INTO THE R5 ARRAY
109 W ?1,$P(^RMPR(662,+R5(1,J,0),0),U,1),?10
110 S R5=$P(R5(1,J,0),U,4)
111 K DIC
112 S RC=$P(R5(1,J,0),U,4)
113 S REC=$S(RC=1:"SC Vietnam",RC=2:"All Other Service-Connected",RC=3:"NSC A&A",RC=4:"Others Eligible",RC=5:"V.I.S.T.",RC=6:"Voc Rehab.",RC=7:"PHC",RC=8:"Inpatient",RC=9:"Employee",RC=10:"Prima Facia",1:"")
114 S RMPRSC=$P(R5(1,J,0),U,3) S RMPRSCC=$S(RMPRSC=1:"SC",RMPRSC=2:"NSC",1:"")
115 W REC W:REC'=""&(RMPRSC'="") ?41,RMPRSCC
116 K RMPRSCC,RMPRSC,RMEC,REC
117 W ?52 S Y=$P(R5(1,J,0),U,2)
118 D DD^%DT W Y,?63," ",!
119 Q
Note: See TracBrowser for help on using the repository browser.