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

RMPRPRT ;PHX/HNB-PRINT 2319 ;3/18/03  09:04
 ;;3.0;PROSTHETICS;**7,50,77,105**;Feb 09, 1996
 ;
 ; ODJ - Patch 50 - 7/7/00 - NOIS SFC-0300-62501
 ;                           Put N I statement in HDR subroutine
 ;                           because it can get killed here and 
 ;                           calling routines are still using it
 ; RVD 3/18/03 patch #77 - remove the ability of adding pt under
 ;                         option print 2319.
 ;
DSP ;DO PRE DISPLAY HOUSEKEEPING
 ;VARIABLES REQUIRED:
 ;VARIABLES SET; RMPR ARRAY - SITE SPECIFIC INFO
 ;               RMPRDFN - IEN OF PATIENT IN FILE 665
 ;               RMPRNAM - NAME OF PATIENT
 ;               RMPRSSN - SSN O PATIENT
 ;               RMPRDOB - EXTERNAL VERSION OF PATIENT'S DATE OF BIRTH
 ; CALLED BY DSP1^RMPRPRT
 D DIV4^RMPRSIT G:$D(X) EXIT
 K RMPRDFN,RMPRSSN,RMPRSSNE,RMPRDOB,DIC,Y
 S DIC="^RMPR(665,",DIC(0)="AEMQ"
 S DIC("A")="Select PROSTHETIC PATIENT: " D ^DIC K DIC Q:$G(Y)'>0
 S:+Y>0 (RMPRDFN,DFN)=+Y D DEM^VADPT,ELIG^VADPT
 S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
 S RMPRDOB=$P(VADM(3),U),RMPRSSNE=VA("PID")
 S RMPRCNUM=VAEL(7)
 I +VADM(6) S RMPRDOD=$P(VADM(6),U) W !!,$C(7),"PATIENT IS DECEASED. DATE OF DEATH WAS ",$P(VADM(6),U,2)
 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
 K RMPRDOD D KVAR^VADPT
 G:'$D(RMPRDFN) EXIT
DSP2 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
 I '$D(IO("Q")) U IO G DSP1
 K IO("Q") S ZTRTN="START^RMPRPRT",ZTDESC="PROSTHETIC PATIENT PRINT",ZTIO=ION F RG="RMPRDFN","RMPRNAM","RMPRDOB","RMPRSSN" S ZTSAVE(RG)=""
 K RG D ^%ZTLOAD G EXIT
DSP1 I $E(IOST)["C" S RFLG=1 D ^RMPRPAT K ANS W ! ;G DSP2
START ;DO THE ACUTAL PRINTINTG OF THE ELIGIBILITY SCREENS DATA TO THE PRINTER
 ;VARIABLES REQUIRED: RMPRDFN - PATIENT IEN IN FILE 665
 ;                    RMPRNAM - PATIENT'S NAME
 ;                    RMPRSSN - PATIENT'S SSN NUMBEER
 ;                    RMPRDOB - PATIENT'S DATE OF BIRTH
 ;VARIABLES SET:      RMPR($J,"DESQ",--- - ARRAY  HOLDS PATIENT EYE AND
 ;                                         HAIR COLOR
 ;                    RA("DIQ1",$J,--- - ARRAY  HOLDS PATIENT MAS 
 ;                    R5(---  - ARRAY HOLDING PROSTHETIC  DISABILITY
 ;                              CODE INFORMATION
 ;CALLED BY DSP^RMPRPRT      
 Q:$G(RMPRDFN)<1
 S PAGE=1
 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))=""
 S HGT=" ",WGT=" " S:$D(^RMPR(665,RMPRDFN,10)) HGT=$P(^(10),U,1),WGT=$P(^(10),U,2)
 S %X="^RMPR(665,"_RMPRDFN_",",%Y="R5(" D %XY^%RCR K %X,%Y S DFN=RMPRDFN
 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
 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:" ")
 D HDR D ADD^VADPT W !,"Phone: ",$S($G(VAPA(8))'="":VAPA(8),1:"UNKNOWN"),!
 S DFN=RMPRDFN D OAD^VADPT W !,"Office: ",$S(VAOA(8)'="":VAOA(8),1:"UNKNOWN"),!
 D COMP^RMPRUTIL W !,"Permanent Address:",?40,"Temporary Address:",!,XP(1),?40,X1(1),!
 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)
 W:(J>4!(J1>4)) ! K J,J1,XP,X1
 W !,"Height(IN): ",HGT,"  Weight(LB): ",WGT,"  Eyes: ",EYE,"  Hair: ",HAIR,!!
 ;if you quit here than that is all that will print on the printer
 ;is not complete 19 record.
 ;I $D(RMPRBACK) Q
END 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)
 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)
 W ?40,"Receiving Housebound Benefits? " W:VAMB(2)=0 "NO" W:$P(VAMB(2),U,1)=1 $P(VAMB(2),U,2)
 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)
 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 !!
 W "MAS Disabilities: Code  Disability                           %  TOTAL%=",$S($P(VAEL(3),U,2):$P(VAEL(3),U,2),1:""),! S J=0
 S LP=0 F I=1:1 S LP=$O(RA("DIQ1",$J,2.04,LP)) Q:LP=""  D
 .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)
 I I=1 W !?10," NONE LISTED",!
 W !,"Prosthetic Disability Codes:",!
 W ?1,"Code",?10,"Elig",?40,"SC/NSC",?52,"Date",?63,!
 S J=0 F I=1:1 S J=$O(R5(1,J)) Q:J=""!(J?.A)  D DISP
 I I=1 W !?10,"NONE LISTED",!
 K I,LP
 G ^RMPRPRT1
 Q
EXIT ;EXIT FROM PRINTING A PATIENT'S 10-2319
 ;CALLED BY DSP^RMPRPRT AND DSP1^RMPRPRT
 D ^%ZISC,KVAR^VADPT
 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
 K:'$D(RMPRF)&($G(RMPRBACK)=0) RMPRDFN,RMPRDOB,RMPRNAM,RMPRSSN,VADM
 Q
HDR ;HEADER FOR 10-2319
 ;CALLED BY START^RMPRPRT
 ;VARTIABLES REQUIRED:RMPRNAM - PATIENT'S NAME
 ;                    RMPRSSN - PATIENT'S SSN
 ;                    VAEL ARRAY - SEE PIMS TECHNICAL MANUAL
 ;                    RMPRDOB - PATIENT'S DATE OF BIRTH
 N I
 I $Y+6>IOSL W @IOF
 I '$D(RMPRSSN) D
 .N DFN
 .S DFN=RMPRDFN
 .D DEM^VADPT
 .S RMPRSSN=$P(VADM(2),U)
 .S RMPRDOB=$P(VADM(3),U)
 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")
 W ?45,"SSN: ",$E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,9),?63,"DOB: "
 W $E(RMPRDOB,4,5)_"-"_$E(RMPRDOB,6,7)_"-"_($E(RMPRDOB,1,3)+1700),!
 ;
 W "Comment: ",$S($P(R5(0),U,3)]"":$P(R5(0),U,3),1:"")
 Q
DISP ;DISPLAY PROSTHETIC DISABILITY CODES
 ;CALLED BY END^RMPRPRT
 ;VARIABLES REQUIRED R5 - A STRING ARRAY
 ;                    J - AN INDEX INTO THE R5 ARRAY
 W ?1,$P(^RMPR(662,+R5(1,J,0),0),U,1),?10
 S R5=$P(R5(1,J,0),U,4)
 K DIC
 S RC=$P(R5(1,J,0),U,4)
 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:"")
 S RMPRSC=$P(R5(1,J,0),U,3) S RMPRSCC=$S(RMPRSC=1:"SC",RMPRSC=2:"NSC",1:"")
 W REC W:REC'=""&(RMPRSC'="") ?41,RMPRSCC
 K RMPRSCC,RMPRSC,RMEC,REC
 W ?52 S Y=$P(R5(1,J,0),U,2)
 D DD^%DT W Y,?63," ",!
 Q