RMPOPRT ;HINES CIO/RVD-PRINT 2319 ;7/8/02
;;3.0;PROSTHETICS;**70**;Feb 09, 1996
;
;RVD - patch #70 - 7/8/02 - This is a copy of RMPRPRT routine.
; Use only for Read Only 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^RMPOPRT
S RMPR1APN=1
D DIV4^RMPRSIT G:$D(X) EXIT D GETPAT^RMPRUTIL 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^RMPOPRT",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:$G(RMPOPFLG)=1 ^RMPOPAT D:$G(RMPOPFLG)'=1 ^RMPOPAT K ANS W !
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^RMPOPRT
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^RMPOPRT AND DSP1^RMPOPRT
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
D KILL^XUSCLEAN
K:'$D(RMPRF)&($G(RMPRBACK)=0) RMPRDFN,RMPRDOB,RMPRNAM,RMPRSSN,VADM
Q
HDR ;HEADER FOR 10-2319
;CALLED BY START^RMPOPRT
;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^RMPOPRT
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOPRT 5888 printed Oct 16, 2024@18:32:01 Page 2
RMPOPRT ;HINES CIO/RVD-PRINT 2319 ;7/8/02
+1 ;;3.0;PROSTHETICS;**70**;Feb 09, 1996
+2 ;
+3 ;RVD - patch #70 - 7/8/02 - This is a copy of RMPRPRT routine.
+4 ; Use only for Read Only 2319.
+5 ;
DSP ;DO PRE DISPLAY HOUSEKEEPING
+1 ;VARIABLES REQUIRED:
+2 ;VARIABLES SET; RMPR ARRAY - SITE SPECIFIC INFO
+3 ; RMPRDFN - IEN OF PATIENT IN FILE 665
+4 ; RMPRNAM - NAME OF PATIENT
+5 ; RMPRSSN - SSN O PATIENT
+6 ; RMPRDOB - EXTERNAL VERSION OF PATIENT'S DATE OF BIRTH
+7 ; CALLED BY DSP1^RMPOPRT
+8 SET RMPR1APN=1
+9 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
GOTO EXIT
DSP2 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT
+1 IF '$DATA(IO("Q"))
USE IO
GOTO DSP1
+2 KILL IO("Q")
SET ZTRTN="START^RMPOPRT"
SET ZTDESC="PROSTHETIC PATIENT PRINT"
SET ZTIO=ION
FOR RG="RMPRDFN","RMPRNAM","RMPRDOB","RMPRSSN"
SET ZTSAVE(RG)=""
+3 KILL RG
DO ^%ZTLOAD
GOTO EXIT
DSP1 IF $EXTRACT(IOST)["C"
SET RFLG=1
if $GET(RMPOPFLG)=1
DO ^RMPOPAT
if $GET(RMPOPFLG)'=1
DO ^RMPOPAT
KILL ANS
WRITE !
START ;DO THE ACUTAL PRINTINTG OF THE ELIGIBILITY SCREENS DATA TO THE PRINTER
+1 ;VARIABLES REQUIRED: RMPRDFN - PATIENT IEN IN FILE 665
+2 ; RMPRNAM - PATIENT'S NAME
+3 ; RMPRSSN - PATIENT'S SSN NUMBEER
+4 ; RMPRDOB - PATIENT'S DATE OF BIRTH
+5 ;VARIABLES SET: RMPR($J,"DESQ",--- - ARRAY HOLDS PATIENT EYE AND
+6 ; HAIR COLOR
+7 ; RA("DIQ1",$J,--- - ARRAY HOLDS PATIENT MAS
+8 ; R5(--- - ARRAY HOLDING PROSTHETIC DISABILITY
+9 ; CODE INFORMATION
+10 ;CALLED BY DSP^RMPOPRT
+11 if $GET(RMPRDFN)<1
QUIT
+12 SET PAGE=1
+13 KILL DIQ,DIC
SET DIC=2
SET DA=RMPRDFN
SET DR=.3721
SET DR(2.04)=".01;2;3"
SET DIQ="RA(""DIQ1"",$J,"
FOR LP=1:1
SET DA(2.04)=LP
DO EN^DIQ1
if $GET(RA("DIQ1",$JOB,2.04,LP,.01))=""
QUIT
+14 SET HGT=" "
SET WGT=" "
if $DATA(^RMPR(665,RMPRDFN,10))
SET HGT=$PIECE(^(10),U,1)
SET WGT=$PIECE(^(10),U,2)
+15 SET %X="^RMPR(665,"_RMPRDFN_","
SET %Y="R5("
DO %XY^%RCR
KILL %X,%Y
SET DFN=RMPRDFN
+16 KILL DIQ,DIC
SET DIC="^RMPR(665,"
SET DR="22;23"
SET DA=RMPRDFN
SET DIQ="RMPR($J,""DESC"","
SET DIQ(0)="E"
DO EN^DIQ1
KILL DIC,DIQ,DR
+17 SET HAIR=$SELECT($GET(RMPR($JOB,"DESC",665,RMPRDFN,23,"E"))'="":RMPR($JOB,"DESC",665,RMPRDFN,23,"E"),1:" ")
SET EYE=$SELECT($GET(RMPR($JOB,"DESC",665,RMPRDFN,22,"E"))'="":RMPR($JOB,"DESC",665,RMPRDFN,22,"E"),1:" ")
+18 DO HDR
DO ADD^VADPT
WRITE !,"Phone: ",$SELECT($GET(VAPA(8))'="":VAPA(8),1:"UNKNOWN"),!
+19 SET DFN=RMPRDFN
DO OAD^VADPT
WRITE !,"Office: ",$SELECT(VAOA(8)'="":VAOA(8),1:"UNKNOWN"),!
+20 DO COMP^RMPRUTIL
WRITE !,"Permanent Address:",?40,"Temporary Address:",!,XP(1),?40,X1(1),!
+21 if J>2
WRITE XP(2)
if J1>2
WRITE ?40,X1(2)
if (J>2!(J1>2))
WRITE !
if J>3
WRITE XP(3)
if J1>3
WRITE ?40,X1(3)
if (J>3!(J1>3))
WRITE !
if J>4
WRITE XP(4)
if J1>4
WRITE ?40,X1(4)
+22 if (J>4!(J1>4))
WRITE !
KILL J,J1,XP,X1
+23 WRITE !,"Height(IN): ",HGT," Weight(LB): ",WGT," Eyes: ",EYE," Hair: ",HAIR,!!
+24 ;if you quit here than that is all that will print on the printer
+25 ;is not complete 19 record.
+26 ;I $D(RMPRBACK) Q
END DO ELIG^VADPT
WRITE !!,"Patient Type: ",$PIECE(VAEL(6),U,2),?40,"Period of Service: ",$PIECE(VAEL(2),U,2),!,"Primary Eligibility Code:",?40,"Status: ",$PIECE(VAEL(9),U,2),!,$PIECE(VAEL(1),U,2)
+1 WRITE ?40,"Eligibility Status: ",$EXTRACT($PIECE(VAEL(8),U,2),1,19)
DO MB^VADPT
WRITE !!,"Receiving A&A Benefits? "
if VAMB(1)=0
WRITE "NO"
if $PIECE(VAMB(1),U,1)=1
WRITE $PIECE(VAMB(1),U,2)
+2 WRITE ?40,"Receiving Housebound Benefits? "
if VAMB(2)=0
WRITE "NO"
if $PIECE(VAMB(2),U,1)=1
WRITE $PIECE(VAMB(2),U,2)
+3 WRITE !,"Receiving Social Security? "
if VAMB(3)=0
WRITE "NO"
if $PIECE(VAMB(3),U,1)=1
WRITE $PIECE(VAMB(3),U,2)
WRITE ?40,"Receiving VA Pension? "
if VAMB(4)=0
WRITE "NO"
if $PIECE(VAMB(4),U,1)=1
WRITE $PIECE(VAMB(4),U,2)
+4 WRITE !,"Receiving Military Retirement? "
if VAMB(5)=0
WRITE "NO"
if $PIECE(VAMB(5),U,1)=1
WRITE $PIECE(VAMB(5),U,2)
WRITE ?40,"Receiving VA Disability? "
if VAMB(7)=0
WRITE "NO"
if $PIECE(VAMB(7),U,1)=1
WRITE $PIECE(VAMB(7),U,2)
WRITE !!
+5 WRITE "MAS Disabilities: Code Disability % TOTAL%=",$SELECT($PIECE(VAEL(3),U,2):$PIECE(VAEL(3),U,2),1:""),!
SET J=0
+6 SET LP=0
FOR I=1:1
SET LP=$ORDER(RA("DIQ1",$JOB,2.04,LP))
if LP=""
QUIT
Begin DoDot:1
+7 WRITE !,?21,RA("DIQ1",$JOB,2.04,LP,.01),?60,RA("DIQ1",$JOB,2.04,LP,2),?70,RA("DIQ1",$JOB,2.04,LP,3)
End DoDot:1
+8 IF I=1
WRITE !?10," NONE LISTED",!
+9 WRITE !,"Prosthetic Disability Codes:",!
+10 WRITE ?1,"Code",?10,"Elig",?40,"SC/NSC",?52,"Date",?63,!
+11 SET J=0
FOR I=1:1
SET J=$ORDER(R5(1,J))
if J=""!(J?.A)
QUIT
DO DISP
+12 IF I=1
WRITE !?10,"NONE LISTED",!
+13 KILL I,LP
+14 GOTO ^RMPRPRT1
+15 QUIT
EXIT ;EXIT FROM PRINTING A PATIENT'S 10-2319
+1 ;CALLED BY DSP^RMPOPRT AND DSP1^RMPOPRT
+2 DO ^%ZISC
DO KVAR^VADPT
+3 KILL RDP,FG,Y,%,AN,NA,ANST,RC,DA,DIC,DIE,DIPGM,DIYS,ANS,EYE,HAIR,HGT,POP,R2,R5,WGT,X,Y,PAGE
+4 DO KILL^XUSCLEAN
+5 if '$DATA(RMPRF)&($GET(RMPRBACK)=0)
KILL RMPRDFN,RMPRDOB,RMPRNAM,RMPRSSN,VADM
+6 QUIT
HDR ;HEADER FOR 10-2319
+1 ;CALLED BY START^RMPOPRT
+2 ;VARTIABLES REQUIRED:RMPRNAM - PATIENT'S NAME
+3 ; RMPRSSN - PATIENT'S SSN
+4 ; VAEL ARRAY - SEE PIMS TECHNICAL MANUAL
+5 ; RMPRDOB - PATIENT'S DATE OF BIRTH
+6 NEW I
+7 IF $Y+6>IOSL
WRITE @IOF
+8 IF '$DATA(RMPRSSN)
Begin DoDot:1
+9 NEW DFN
+10 SET DFN=RMPRDFN
+11 DO DEM^VADPT
+12 SET RMPRSSN=$PIECE(VADM(2),U)
+13 SET RMPRDOB=$PIECE(VADM(3),U)
End DoDot:1
+14 WRITE !!,?23,"10-2319 PROSTHETICS VETERAN RECORD",!,$EXTRACT(RMPRNAM,1,25),?27,"C#: "
SET DFN=RMPRDFN
DO ELIG^VADPT
WRITE $SELECT(VAEL(7)'="":VAEL(7),1:"UNKNOWN")
+15 WRITE ?45,"SSN: ",$EXTRACT(RMPRSSN,1,3)_"-"_$EXTRACT(RMPRSSN,4,5)_"-"_$EXTRACT(RMPRSSN,6,9),?63,"DOB: "
+16 WRITE $EXTRACT(RMPRDOB,4,5)_"-"_$EXTRACT(RMPRDOB,6,7)_"-"_($EXTRACT(RMPRDOB,1,3)+1700),!
+17 ;
+18 WRITE "Comment: ",$SELECT($PIECE(R5(0),U,3)]"":$PIECE(R5(0),U,3),1:"")
+19 QUIT
DISP ;DISPLAY PROSTHETIC DISABILITY CODES
+1 ;CALLED BY END^RMPOPRT
+2 ;VARIABLES REQUIRED R5 - A STRING ARRAY
+3 ; J - AN INDEX INTO THE R5 ARRAY
+4 WRITE ?1,$PIECE(^RMPR(662,+R5(1,J,0),0),U,1),?10
+5 SET R5=$PIECE(R5(1,J,0),U,4)
+6 KILL DIC
+7 SET RC=$PIECE(R5(1,J,0),U,4)
+8 SET REC=$SELECT(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:"")
+9 SET RMPRSC=$PIECE(R5(1,J,0),U,3)
SET RMPRSCC=$SELECT(RMPRSC=1:"SC",RMPRSC=2:"NSC",1:"")
+10 WRITE REC
if REC'=""&(RMPRSC'="")
WRITE ?41,RMPRSCC
+11 KILL RMPRSCC,RMPRSC,RMEC,REC
+12 WRITE ?52
SET Y=$PIECE(R5(1,J,0),U,2)
+13 DO DD^%DT
WRITE Y,?63," ",!
+14 QUIT
