RMPR121A ;PHX/HNC -CREATE GUI PURCHASE CARD TRANSACTION CONT. ;3/1/2003
;;3.0;PROSTHETICS;**90,157**;Feb 09, 1996;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
;04/01/05 Note some codeing for future use such as pt address.
DELIV I RMPRY=1 D
.S RMPRDDF="1^Y"
.S DFN=$P(^RMPR(664,RMPRA,0),U,2)
.D ALL^VADPT
.S RMPRADD1=VADM(1)
.S RMPRADD2=VAPA(1)
.S RMPRCITY=VAPA(4)
.S RMPRST=VAPA(5)
.S RMPRZIP=VAPA(6)
.I RMPRZIP="" S RMPRZIP="00000"
I RMPRY=2 S RMPRDDF="2^N"
I RMPRY=3 S RMPRDDF="3^N"
I RMPRY=4 D
.S RMPRDDF="4^Y"
.S RMPRADD1=$P(^RMPR(664,RMPRA,3),U,5)
.S RMPRADD2=$P(^RMPR(664,RMPRA,3),U,6)
.S RMPRCITY=$P(^RMPR(664,RMPRA,3),U,7)
.S RMPRST=$P(^RMPR(664,RMPRA,3),U,8)_"^"_$P(^DIC(5,$P(^RMPR(664,RMPRA,3),U,8),0),U,1)
.S RMPRZIP=$P(^RMPR(664,RMPRA,3),U,9)
;deliver to other
S RMPRDELN=RMPRY(0),$P(^RMPR(664,RMPRA,3),U)=RMPRDELN
S RMPRDLVD=$P(^RMPR(664,RMPRA,3),U,2)
I RMPRY=3 S RMPRDELN=$P(^RMPR(664,RMPRA,3),U,4)
I RMPRY=4 S RMPRDELN=$P(^RMPR(664,RMPRA,3),U,4)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR121A 1049 printed Nov 22, 2024@17:41:41 Page 2
RMPR121A ;PHX/HNC -CREATE GUI PURCHASE CARD TRANSACTION CONT. ;3/1/2003
+1 ;;3.0;PROSTHETICS;**90,157**;Feb 09, 1996;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;04/01/05 Note some codeing for future use such as pt address.
DELIV IF RMPRY=1
Begin DoDot:1
+1 SET RMPRDDF="1^Y"
+2 SET DFN=$PIECE(^RMPR(664,RMPRA,0),U,2)
+3 DO ALL^VADPT
+4 SET RMPRADD1=VADM(1)
+5 SET RMPRADD2=VAPA(1)
+6 SET RMPRCITY=VAPA(4)
+7 SET RMPRST=VAPA(5)
+8 SET RMPRZIP=VAPA(6)
+9 IF RMPRZIP=""
SET RMPRZIP="00000"
End DoDot:1
+10 IF RMPRY=2
SET RMPRDDF="2^N"
+11 IF RMPRY=3
SET RMPRDDF="3^N"
+12 IF RMPRY=4
Begin DoDot:1
+13 SET RMPRDDF="4^Y"
+14 SET RMPRADD1=$PIECE(^RMPR(664,RMPRA,3),U,5)
+15 SET RMPRADD2=$PIECE(^RMPR(664,RMPRA,3),U,6)
+16 SET RMPRCITY=$PIECE(^RMPR(664,RMPRA,3),U,7)
+17 SET RMPRST=$PIECE(^RMPR(664,RMPRA,3),U,8)_"^"_$PIECE(^DIC(5,$PIECE(^RMPR(664,RMPRA,3),U,8),0),U,1)
+18 SET RMPRZIP=$PIECE(^RMPR(664,RMPRA,3),U,9)
End DoDot:1
+19 ;deliver to other
+20 SET RMPRDELN=RMPRY(0)
SET $PIECE(^RMPR(664,RMPRA,3),U)=RMPRDELN
+21 SET RMPRDLVD=$PIECE(^RMPR(664,RMPRA,3),U,2)
+22 IF RMPRY=3
SET RMPRDELN=$PIECE(^RMPR(664,RMPRA,3),U,4)
+23 IF RMPRY=4
SET RMPRDELN=$PIECE(^RMPR(664,RMPRA,3),U,4)
+24 QUIT
