RMPR9DEM ;HOIFO/HNC/SPS - GUI 2319 DEM VADPT IN RESULTS ARRAY ;9/19/02 11:27
;;3.0;PROSTHETICS;**59**;Feb 09, 1996
EN(RESULTS,IEN) ;broker entry point
;translate ien 668 to DFN
;
TST ;S IEN=311
S DFN=$P($G(^RMPR(668,IEN,0)),U,2)
I DFN="" S RESULTS(999)="NOTHING TO REPORT" G EXIT
D DEM^VADPT
S RESULTS(0)=VADM(1) ;Name
S RESULTS(1)=VADM(2) ;SSN
S RESULTS(2)=VADM(3) ;Date of Birth
S RESULTS(3)=VADM(4) ;Age
S RESULTS(4)=VADM(5) ;Sex
S RESULTS(5)=VADM(6) ;Date of Death
S RESULTS(6)=VADM(8) ;Race
S RESULTS(7)=VADM(9) ;Religion
S RESULTS(8)=VADM(10) ;Marital Status
S RESULTS(9)=VA("PID") ;Primary Long ID
S RESULTS(10)=VA("BID") ;Primary Short ID
;I $G(VAERR)'="" S RESULTS(999)=VAERR
;
S DFN=$P($G(^RMPR(668,IEN,0)),U,2)
I DFN="" S RESULTS(999)="NOTHING TO REPORT" G EXIT
D ADD^VADPT
S RESULTS(12)=VAPA(1) ;First line address
S RESULTS(13)=VAPA(4) ;City
S RESULTS(14)=VAPA(5) ;State
S RESULTS(15)=VAPA(6) ;Zip
S RESULTS(16)=VAPA(7) ;County
S RESULTS(17)=VAPA(8) ;Phone
S RESULTS(18)=VAPA(11) ;Zip+4
;NOK
D OAD^VADPT
S RESULTS(19)=VAOA(9) ;NOK name
S RESULTS(20)=VAOA(1) ;NOK Address
S RESULTS(21)=VAOA(4) ;NOK CITY
S RESULTS(22)=VAOA(5) ;NOK STATE
S RESULTS(23)=VAOA(6) ;NOK ZIP
S RESULTS(24)=VAOA(8) ;NOK PHONE
S RESULTS(25)=VAOA(10) ;NOK RELATIONSHIP
; Eligibility segment
D ELIG^VADPT
S RESULTS(11)=VAEL(7) ;Claim #
S RESULTS(26)=$P(VAEL(6),U,2) ;Patient Type
S RESULTS(27)=$P(VAEL(2),U,2) ;Period of Service
S RESULTS(28)=$P(VAEL(1),U,2) ;Primary Eligibility Code
S RESULTS(29)=$S(VAEL(8)]"":$P(VAEL(8),U,2),1:"NOT VERIFIED") ;Verification?
;Monetary Benefit Info from MB^VADPT
D MB^VADPT
S RESULTS(30)="NO" I $P(VAMB(1),U)=1 S RESULTS(30)="YES",RMPRCHK=$P(VAMB(1),U,2)
S RESULTS(31)="NO" I $P(VAMB(2),U)=1 S RESULTS(31)="YES",RMPRCHK=$P(VAMB(2),U,2)
S RESULTS(32)="NO" I $P(VAMB(4),U)=1 S RESULTS(32)="YES",RMPRCHK=$P(VAMB(4),U,2)
S RESULTS(33)="NO" I $P(VAMB(7),U)=1 S RESULTS(33)="YES",RMPRCHK=$P(VAMB(7),U,2)
S RESULTS(34)=0 I $G(RMPRCHK)]"" S RESULTS(34)=$G(RMPRCHK) ;Total Annual VA Check Amount
;Prosthetics Disability Codes
S (RMPRDC,RO,FG)=0 I '$D(^RMPR(665,DFN,1)) S RESULTS(35)="None" S RO=1
K RMPRDC
I RO=0 F S:'FG RMPRDC="" S RO=$O(^RMPR(665,DFN,1,RO)) Q:RO'>0 D
.S RR=^(RO,0) S:$P(RR,U,10) FG=1 I '$P(RR,U,10) S RMPRDC=RMPRDC_$P(^RMPR(662,+RR,0),U,1)_"-"_$S($P(RR,U,3)=1:"SC",$P(RR,U,3)=2:"NSC",1:"") S FG=1
S:FG=1 RESULTS(35)=RMPRDC
;POW
D SVC^VADPT
S RESULTS(36)=$S(VASV(4)=1:"YES",1:"NO") ;POW YES/NO
;Emergency Contact
S VAOA("A")=1 D OAD^VADPT
S RESULTS(37)=VAOA(9) ;Name of Emergency Contact
S RESULTS(38)=VAOA(1) ;Street Address
S RESULTS(39)=VAOA(4) ;City
S RESULTS(40)=$P(VAOA(5),U,2) ;State
S RESULTS(41)=VAOA(6) ;Zip
S RESULTS(42)=VAOA(8) ;Home Phone
S RESULTS(43)=VAOA(10) ;Relationship
I $G(VAERR)'="" S RESULTS(999)=VAERR
;
Q
EXIT ;
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR9DEM 2930 printed Sep 23, 2025@20:09:42 Page 2
RMPR9DEM ;HOIFO/HNC/SPS - GUI 2319 DEM VADPT IN RESULTS ARRAY ;9/19/02 11:27
+1 ;;3.0;PROSTHETICS;**59**;Feb 09, 1996
EN(RESULTS,IEN) ;broker entry point
+1 ;translate ien 668 to DFN
+2 ;
TST ;S IEN=311
+1 SET DFN=$PIECE($GET(^RMPR(668,IEN,0)),U,2)
+2 IF DFN=""
SET RESULTS(999)="NOTHING TO REPORT"
GOTO EXIT
+3 DO DEM^VADPT
+4 ;Name
SET RESULTS(0)=VADM(1)
+5 ;SSN
SET RESULTS(1)=VADM(2)
+6 ;Date of Birth
SET RESULTS(2)=VADM(3)
+7 ;Age
SET RESULTS(3)=VADM(4)
+8 ;Sex
SET RESULTS(4)=VADM(5)
+9 ;Date of Death
SET RESULTS(5)=VADM(6)
+10 ;Race
SET RESULTS(6)=VADM(8)
+11 ;Religion
SET RESULTS(7)=VADM(9)
+12 ;Marital Status
SET RESULTS(8)=VADM(10)
+13 ;Primary Long ID
SET RESULTS(9)=VA("PID")
+14 ;Primary Short ID
SET RESULTS(10)=VA("BID")
+15 ;I $G(VAERR)'="" S RESULTS(999)=VAERR
+16 ;
+17 SET DFN=$PIECE($GET(^RMPR(668,IEN,0)),U,2)
+18 IF DFN=""
SET RESULTS(999)="NOTHING TO REPORT"
GOTO EXIT
+19 DO ADD^VADPT
+20 ;First line address
SET RESULTS(12)=VAPA(1)
+21 ;City
SET RESULTS(13)=VAPA(4)
+22 ;State
SET RESULTS(14)=VAPA(5)
+23 ;Zip
SET RESULTS(15)=VAPA(6)
+24 ;County
SET RESULTS(16)=VAPA(7)
+25 ;Phone
SET RESULTS(17)=VAPA(8)
+26 ;Zip+4
SET RESULTS(18)=VAPA(11)
+27 ;NOK
+28 DO OAD^VADPT
+29 ;NOK name
SET RESULTS(19)=VAOA(9)
+30 ;NOK Address
SET RESULTS(20)=VAOA(1)
+31 ;NOK CITY
SET RESULTS(21)=VAOA(4)
+32 ;NOK STATE
SET RESULTS(22)=VAOA(5)
+33 ;NOK ZIP
SET RESULTS(23)=VAOA(6)
+34 ;NOK PHONE
SET RESULTS(24)=VAOA(8)
+35 ;NOK RELATIONSHIP
SET RESULTS(25)=VAOA(10)
+36 ; Eligibility segment
+37 DO ELIG^VADPT
+38 ;Claim #
SET RESULTS(11)=VAEL(7)
+39 ;Patient Type
SET RESULTS(26)=$PIECE(VAEL(6),U,2)
+40 ;Period of Service
SET RESULTS(27)=$PIECE(VAEL(2),U,2)
+41 ;Primary Eligibility Code
SET RESULTS(28)=$PIECE(VAEL(1),U,2)
+42 ;Verification?
SET RESULTS(29)=$SELECT(VAEL(8)]"":$PIECE(VAEL(8),U,2),1:"NOT VERIFIED")
+43 ;Monetary Benefit Info from MB^VADPT
+44 DO MB^VADPT
+45 SET RESULTS(30)="NO"
IF $PIECE(VAMB(1),U)=1
SET RESULTS(30)="YES"
SET RMPRCHK=$PIECE(VAMB(1),U,2)
+46 SET RESULTS(31)="NO"
IF $PIECE(VAMB(2),U)=1
SET RESULTS(31)="YES"
SET RMPRCHK=$PIECE(VAMB(2),U,2)
+47 SET RESULTS(32)="NO"
IF $PIECE(VAMB(4),U)=1
SET RESULTS(32)="YES"
SET RMPRCHK=$PIECE(VAMB(4),U,2)
+48 SET RESULTS(33)="NO"
IF $PIECE(VAMB(7),U)=1
SET RESULTS(33)="YES"
SET RMPRCHK=$PIECE(VAMB(7),U,2)
+49 ;Total Annual VA Check Amount
SET RESULTS(34)=0
IF $GET(RMPRCHK)]""
SET RESULTS(34)=$GET(RMPRCHK)
+50 ;Prosthetics Disability Codes
+51 SET (RMPRDC,RO,FG)=0
IF '$DATA(^RMPR(665,DFN,1))
SET RESULTS(35)="None"
SET RO=1
+52 KILL RMPRDC
+53 IF RO=0
FOR
if 'FG
SET RMPRDC=""
SET RO=$ORDER(^RMPR(665,DFN,1,RO))
if RO'>0
QUIT
Begin DoDot:1
+54 SET RR=^(RO,0)
if $PIECE(RR,U,10)
SET FG=1
IF '$PIECE(RR,U,10)
SET RMPRDC=RMPRDC_$PIECE(^RMPR(662,+RR,0),U,1)_"-"_$SELECT($PIECE(RR,U,3)=1:"SC",$PIECE(RR,U,3)=2:"NSC",1:"")
SET FG=1
End DoDot:1
+55 if FG=1
SET RESULTS(35)=RMPRDC
+56 ;POW
+57 DO SVC^VADPT
+58 ;POW YES/NO
SET RESULTS(36)=$SELECT(VASV(4)=1:"YES",1:"NO")
+59 ;Emergency Contact
+60 SET VAOA("A")=1
DO OAD^VADPT
+61 ;Name of Emergency Contact
SET RESULTS(37)=VAOA(9)
+62 ;Street Address
SET RESULTS(38)=VAOA(1)
+63 ;City
SET RESULTS(39)=VAOA(4)
+64 ;State
SET RESULTS(40)=$PIECE(VAOA(5),U,2)
+65 ;Zip
SET RESULTS(41)=VAOA(6)
+66 ;Home Phone
SET RESULTS(42)=VAOA(8)
+67 ;Relationship
SET RESULTS(43)=VAOA(10)
+68 IF $GET(VAERR)'=""
SET RESULTS(999)=VAERR
+69 ;
+70 QUIT
EXIT ;
+1 QUIT
+2 ;END
