Routine: RMPR4E22

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)=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4E22   2000     printed  Apr 23, 2025@18:47:15                                                                                                                                                                                                    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

RMPR4E22.m