RMPR121A.m

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 ---RMPR121A   1049     printed  Apr 09, 2024@21:37:05                                                                                                                                                                                                    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