RMPR4E22 ;PHX/HNB - PURCHASE CARD MODULE CLOSE-OUT ;3/1/1996
;;3.0;PROSTHETICS;**3**;Feb 09, 1996
;AMIS,660
S R2=^RMPR(664,RMPRA,1,R1,0),RMPRBD=$P(R2,U,2)
L +^RMPR(660,RMPRAR,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" Q
S R2=^RMPR(664,RMPRA,1,R1,0)
S RMPRTO=$P(R2,U,7) S:RMPRTO=""!(RMPRTO<0) RMPRTO=$P(R2,U,3)
S $P(^RMPR(660,RMPRAR,0),U,16)=RMPRTO*$P(R2,U,4)
S $P(^RMPR(660,RMPRAR,0),U,4)=$P(^RMPR(664,RMPRA,1,R1,0),U,9),$P(^RMPR(660,RMPRAR,"AM"),U,3)=$P(^RMPR(664,RMPRA,1,R1,0),U,10),$P(^RMPR(660,RMPRAR,"AM"),U,4)=$P(^RMPR(664,RMPRA,1,R1,0),U,11)
S $P(^RMPR(660,RMPRAR,0),U,7)=$P(^RMPR(664,RMPRA,1,R1,0),U,4)
S $P(^RMPR(660,RMPRAR,1),U,2)=RMPRBD K RMPRBD
S $P(^RMPR(660,RMPRAR,0),U,12)=RMPR("DDT"),$P(^(0),U,11)=RMPRSER
;item remarks
S RMPRCC=$P(^RMPR(664,RMPRA,1,R1,0),U,8)
;close remarks added to item remarks
S RMPRCC=$S(RMPRCC'="":RMPRCC_" "_$P($G(^RMPR(664,RMPRA,2)),U,3),1:$P($G(^RMPR(664,RMPRA,2)),U,3))
S $P(^RMPR(660,RMPRAR,0),U,18)=RMPRCC
;bank authorization
I $D(^RMPR(664,RMPRA,4)) S $P(^RMPR(660,RMPRAR,4),U,2)=$P(^RMPR(664,RMPRA,4),U,2)
;vendor tracking number
I $D(^RMPR(664,RMPRA,1,R1,4)) S $P(^RMPR(660,RMPRAR,4),U,1)=$P(^RMPR(664,RMPRA,1,R1,4),U,1)
S $P(^RMPR(660,RMPRAR,0),U,15)=$S($P(^RMPR(664,RMPRA,1,R1,0),U,6)="N":"*",1:"")
L -^RMPR(660,RMPRAR,0)
S DA=RMPRAR,DIK="^RMPR(660," D IX1^DIK W !,"Updated "_$P(R1,U,1)_" 10-2319 record for this Veteran"
I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) S DIC="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO,DIC(0)="LZ",R660=^RMPR(660,RMPRAR,0),RMPRTRN=$P(^(1),U,1),X=$P(R660,U,6) D FILE^DICN I +Y>0 D
.S $P(^RMPR(664.2,RMPRWO,1,+Y,0),U,2)=$P(R660,U,7),$P(^(0),U,3)=$J($P(R660,U,16)/$P(R660,U,7),0,2),$P(^(0),U,6)=$P(R660,U,9),$P(^(0),U,7)=$P(R660,U,8),$P(^(0),U,8)=RMPRSER
.S $P(^RMPR(664.2,RMPRWO,1,+Y,0),U,10)=RMPRTRN,$P(^(0),U,4)=$P(R660,U,14),$P(^(0),U,11)=RMPRA,$P(^(0),U,12)=RMPRAR S DIK=DIC,DA(1)=RMPRWO,DA=+Y D IX1^DIK
.S ^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4E22 2000 printed Nov 22, 2024@17:42:46 Page 2
RMPR4E22 ;PHX/HNB - PURCHASE CARD MODULE CLOSE-OUT ;3/1/1996
+1 ;;3.0;PROSTHETICS;**3**;Feb 09, 1996
+2 ;AMIS,660
+3 SET R2=^RMPR(664,RMPRA,1,R1,0)
SET RMPRBD=$PIECE(R2,U,2)
+4 LOCK +^RMPR(660,RMPRAR,0):1
IF $TEST=0
WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"
QUIT
+5 SET R2=^RMPR(664,RMPRA,1,R1,0)
+6 SET RMPRTO=$PIECE(R2,U,7)
if RMPRTO=""!(RMPRTO<0)
SET RMPRTO=$PIECE(R2,U,3)
+7 SET $PIECE(^RMPR(660,RMPRAR,0),U,16)=RMPRTO*$PIECE(R2,U,4)
+8 SET $PIECE(^RMPR(660,RMPRAR,0),U,4)=$PIECE(^RMPR(664,RMPRA,1,R1,0),U,9)
SET $PIECE(^RMPR(660,RMPRAR,"AM"),U,3)=$PIECE(^RMPR(664,RMPRA,1,R1,0),U,10)
SET $PIECE(^RMPR(660,RMPRAR,"AM"),U,4)=$PIECE(^RMPR(664,RMPRA,1,R1,0),U,11)
+9 SET $PIECE(^RMPR(660,RMPRAR,0),U,7)=$PIECE(^RMPR(664,RMPRA,1,R1,0),U,4)
+10 SET $PIECE(^RMPR(660,RMPRAR,1),U,2)=RMPRBD
KILL RMPRBD
+11 SET $PIECE(^RMPR(660,RMPRAR,0),U,12)=RMPR("DDT")
SET $PIECE(^(0),U,11)=RMPRSER
+12 ;item remarks
+13 SET RMPRCC=$PIECE(^RMPR(664,RMPRA,1,R1,0),U,8)
+14 ;close remarks added to item remarks
+15 SET RMPRCC=$SELECT(RMPRCC'="":RMPRCC_" "_$PIECE($GET(^RMPR(664,RMPRA,2)),U,3),1:$PIECE($GET(^RMPR(664,RMPRA,2)),U,3))
+16 SET $PIECE(^RMPR(660,RMPRAR,0),U,18)=RMPRCC
+17 ;bank authorization
+18 IF $DATA(^RMPR(664,RMPRA,4))
SET $PIECE(^RMPR(660,RMPRAR,4),U,2)=$PIECE(^RMPR(664,RMPRA,4),U,2)
+19 ;vendor tracking number
+20 IF $DATA(^RMPR(664,RMPRA,1,R1,4))
SET $PIECE(^RMPR(660,RMPRAR,4),U,1)=$PIECE(^RMPR(664,RMPRA,1,R1,4),U,1)
+21 SET $PIECE(^RMPR(660,RMPRAR,0),U,15)=$SELECT($PIECE(^RMPR(664,RMPRA,1,R1,0),U,6)="N":"*",1:"")
+22 LOCK -^RMPR(660,RMPRAR,0)
+23 SET DA=RMPRAR
SET DIK="^RMPR(660,"
DO IX1^DIK
WRITE !,"Updated "_$PIECE(R1,U,1)_" 10-2319 record for this Veteran"
+24 IF $DATA(RMPRWO)
IF $DATA(^RMPR(664.2,+RMPRWO,0))
SET DIC="^RMPR(664.2,"_RMPRWO_",1,"
SET DA(1)=RMPRWO
SET DIC(0)="LZ"
SET R660=^RMPR(660,RMPRAR,0)
SET RMPRTRN=$PIECE(^(1),U,1)
SET X=$PIECE(R660,U,6)
DO FILE^DICN
IF +Y>0
Begin DoDot:1
+25 SET $PIECE(^RMPR(664.2,RMPRWO,1,+Y,0),U,2)=$PIECE(R660,U,7)
SET $PIECE(^(0),U,3)=$JUSTIFY($PIECE(R660,U,16)/$PIECE(R660,U,7),0,2)
SET $PIECE(^(0),U,6)=$PIECE(R660,U,9)
SET $PIECE(^(0),U,7)=$PIECE(R660,U,8)
SET $PIECE(^(0),U,8)=RMPRSER
+26 SET $PIECE(^RMPR(664.2,RMPRWO,1,+Y,0),U,10)=RMPRTRN
SET $PIECE(^(0),U,4)=$PIECE(R660,U,14)
SET $PIECE(^(0),U,11)=RMPRA
SET $PIECE(^(0),U,12)=RMPRAR
SET DIK=DIC
SET DA(1)=RMPRWO
SET DA=+Y
DO IX1^DIK
+27 SET ^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)=""
End DoDot:1
+28 QUIT
