source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPRT.m@ 1590

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

initial load of FOIAVistA 6/30/08 version
File size: 5.6 KB
Line 
1RMPOPRT ;HINES CIO/RVD-PRINT 2319 ;7/8/02
2 ;;3.0;PROSTHETICS;**70**;Feb 09, 1996
3 ;
4 ;RVD - patch #70 - 7/8/02 - This is a copy of RMPRPRT routine.
5 ; Use only for Read Only 2319.
6 ;
7DSP ;DO PRE DISPLAY HOUSEKEEPING
8 ;VARIABLES REQUIRED:
9 ;VARIABLES SET; RMPR ARRAY - SITE SPECIFIC INFO
10 ; RMPRDFN - IEN OF PATIENT IN FILE 665
11 ; RMPRNAM - NAME OF PATIENT
12 ; RMPRSSN - SSN O PATIENT
13 ; RMPRDOB - EXTERNAL VERSION OF PATIENT'S DATE OF BIRTH
14 ; CALLED BY DSP1^RMPOPRT
15 S RMPR1APN=1
16 D DIV4^RMPRSIT G:$D(X) EXIT D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT
17DSP2 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
18 I '$D(IO("Q")) U IO G DSP1
19 K IO("Q") S ZTRTN="START^RMPOPRT",ZTDESC="PROSTHETIC PATIENT PRINT",ZTIO=ION F RG="RMPRDFN","RMPRNAM","RMPRDOB","RMPRSSN" S ZTSAVE(RG)=""
20 K RG D ^%ZTLOAD G EXIT
21DSP1 I $E(IOST)["C" S RFLG=1 D:$G(RMPOPFLG)=1 ^RMPOPAT D:$G(RMPOPFLG)'=1 ^RMPOPAT K ANS W !
22START ;DO THE ACUTAL PRINTINTG OF THE ELIGIBILITY SCREENS DATA TO THE PRINTER
23 ;VARIABLES REQUIRED: RMPRDFN - PATIENT IEN IN FILE 665
24 ; RMPRNAM - PATIENT'S NAME
25 ; RMPRSSN - PATIENT'S SSN NUMBEER
26 ; RMPRDOB - PATIENT'S DATE OF BIRTH
27 ;VARIABLES SET: RMPR($J,"DESQ",--- - ARRAY HOLDS PATIENT EYE AND
28 ; HAIR COLOR
29 ; RA("DIQ1",$J,--- - ARRAY HOLDS PATIENT MAS
30 ; R5(--- - ARRAY HOLDING PROSTHETIC DISABILITY
31 ; CODE INFORMATION
32 ;CALLED BY DSP^RMPOPRT
33 Q:$G(RMPRDFN)<1
34 S PAGE=1
35 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))=""
36 S HGT=" ",WGT=" " S:$D(^RMPR(665,RMPRDFN,10)) HGT=$P(^(10),U,1),WGT=$P(^(10),U,2)
37 S %X="^RMPR(665,"_RMPRDFN_",",%Y="R5(" D %XY^%RCR K %X,%Y S DFN=RMPRDFN
38 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
39 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:" ")
40 D HDR D ADD^VADPT W !,"Phone: ",$S($G(VAPA(8))'="":VAPA(8),1:"UNKNOWN"),!
41 S DFN=RMPRDFN D OAD^VADPT W !,"Office: ",$S(VAOA(8)'="":VAOA(8),1:"UNKNOWN"),!
42 D COMP^RMPRUTIL W !,"Permanent Address:",?40,"Temporary Address:",!,XP(1),?40,X1(1),!
43 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)
44 W:(J>4!(J1>4)) ! K J,J1,XP,X1
45 W !,"Height(IN): ",HGT," Weight(LB): ",WGT," Eyes: ",EYE," Hair: ",HAIR,!!
46 ;if you quit here than that is all that will print on the printer
47 ;is not complete 19 record.
48 ;I $D(RMPRBACK) Q
49END 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)
50 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)
51 W ?40,"Receiving Housebound Benefits? " W:VAMB(2)=0 "NO" W:$P(VAMB(2),U,1)=1 $P(VAMB(2),U,2)
52 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)
53 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 !!
54 W "MAS Disabilities: Code Disability % TOTAL%=",$S($P(VAEL(3),U,2):$P(VAEL(3),U,2),1:""),! S J=0
55 S LP=0 F I=1:1 S LP=$O(RA("DIQ1",$J,2.04,LP)) Q:LP="" D
56 .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)
57 I I=1 W !?10," NONE LISTED",!
58 W !,"Prosthetic Disability Codes:",!
59 W ?1,"Code",?10,"Elig",?40,"SC/NSC",?52,"Date",?63,!
60 S J=0 F I=1:1 S J=$O(R5(1,J)) Q:J=""!(J?.A) D DISP
61 I I=1 W !?10,"NONE LISTED",!
62 K I,LP
63 G ^RMPRPRT1
64 Q
65EXIT ;EXIT FROM PRINTING A PATIENT'S 10-2319
66 ;CALLED BY DSP^RMPOPRT AND DSP1^RMPOPRT
67 D ^%ZISC,KVAR^VADPT
68 K RDP,FG,Y,%,AN,NA,ANST,RC,DA,DIC,DIE,DIPGM,DIYS,ANS,EYE,HAIR,HGT,POP,R2,R5,WGT,X,Y,PAGE
69 D KILL^XUSCLEAN
70 K:'$D(RMPRF)&($G(RMPRBACK)=0) RMPRDFN,RMPRDOB,RMPRNAM,RMPRSSN,VADM
71 Q
72HDR ;HEADER FOR 10-2319
73 ;CALLED BY START^RMPOPRT
74 ;VARTIABLES REQUIRED:RMPRNAM - PATIENT'S NAME
75 ; RMPRSSN - PATIENT'S SSN
76 ; VAEL ARRAY - SEE PIMS TECHNICAL MANUAL
77 ; RMPRDOB - PATIENT'S DATE OF BIRTH
78 N I
79 I $Y+6>IOSL W @IOF
80 I '$D(RMPRSSN) D
81 .N DFN
82 .S DFN=RMPRDFN
83 .D DEM^VADPT
84 .S RMPRSSN=$P(VADM(2),U)
85 .S RMPRDOB=$P(VADM(3),U)
86 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")
87 W ?45,"SSN: ",$E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,9),?63,"DOB: "
88 W $E(RMPRDOB,4,5)_"-"_$E(RMPRDOB,6,7)_"-"_($E(RMPRDOB,1,3)+1700),!
89 ;
90 W "Comment: ",$S($P(R5(0),U,3)]"":$P(R5(0),U,3),1:"")
91 Q
92DISP ;DISPLAY PROSTHETIC DISABILITY CODES
93 ;CALLED BY END^RMPOPRT
94 ;VARIABLES REQUIRED R5 - A STRING ARRAY
95 ; J - AN INDEX INTO THE R5 ARRAY
96 W ?1,$P(^RMPR(662,+R5(1,J,0),0),U,1),?10
97 S R5=$P(R5(1,J,0),U,4)
98 K DIC
99 S RC=$P(R5(1,J,0),U,4)
100 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:"")
101 S RMPRSC=$P(R5(1,J,0),U,3) S RMPRSCC=$S(RMPRSC=1:"SC",RMPRSC=2:"NSC",1:"")
102 W REC W:REC'=""&(RMPRSC'="") ?41,RMPRSCC
103 K RMPRSCC,RMPRSC,RMEC,REC
104 W ?52 S Y=$P(R5(1,J,0),U,2)
105 D DD^%DT W Y,?63," ",!
106 Q
Note: See TracBrowser for help on using the repository browser.