Routine: RMPR29LD

RMPR29LD ;HIN/RVD-CANCEL LAB ISSUE FROM STOCK;5/27/1998

 ;;3.0;PROSTHETICS;**33**;Feb 09, 1996

 ;Per VHA Directive 10-93-142, this routine should not be modified.

ASK ;get patient to cancel

 D DIV4^RMPRSIT G:$D(X) EXIT

 K ^TMP($J),DR,DIC,RMPRDA S REDIT=1

 S DIC="^RMPR(664.1,",DIC(0)="AEQM",DR=".01"

 S DIC("S")="S RCHECK=$O(^RMPR(664.1,+Y,2,0)) I $P(^RMPR(664.1,+Y,0),U,17)=""C"",$D(^RMPR(664.1,+Y,2,RCHECK,3))",DIC("W")="D EN3^RMPRD1"

 D ^DIC K DIC G:+Y'>0 EXIT S RMPRDA=+Y I $G(RMPRDA)'>0 Q

 L +^RMPR(664.1,RMPRDA,0):1

 I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT

 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2)

 D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT

 D HOME^%ZIS D GET^RMPR29W(RMPRDA)

 S (PAGE,MC,LC,TMC,TLC,TSH)=0 D HDR^RMPR29W(RMPRDA) S RI=$O(RCK(0)),(RJ,RTHD)=0

ITD D ITM^RMPR293 S RMPRWO=$P(RCK(RI),U,3)

TCH G:'$D(TECH(RMPRWO))!($O(TECH(RMPRWO,0))'>0) MU S RTCD=$O(TECH(RMPRWO,0))

 S RTC=$O(TECH(RMPRWO,RTCD,664.33,0)) I RTC D TDSP^RMPR293 G TCH

MU I $D(TMP(RMPRWO,664.22)) S RJ=$O(TMP(RMPRWO,664.22,0)) I RJ D MDSP^RMPR293 G MU

 S SCH=^UTILITY("DIQ1",$J,664.2,RMPRWO,4,"E") I +SCH S:^UTILITY("DIQ1",$J,664.2,RMPRWO,5,"E") SCH=^("E") S TSH=TSH+SCH W !,?37,"SHIPPING CHARGE: ",?70,$J(SCH,10,2)

 S RR=1

EXT S RW=$O(^UTILITY($J,"TEXT",RMPRWO,0)) I RW D WDSP^RMPR293 G EXT

 W !,RMPR("L")

 K DIR S DIR(0)="Y",DIR("A")="Would you like to CANCEL this Entry",DIR("B")="NO"

 D ^DIR G:$D(DTOUT)!($D(DUOUT)) EXIT G:Y=0!(Y<0) EXIT

 F RL=0:0 S RL=$O(^RMPR(664.1,RMPRDA,2,RL)) Q:RL'>0  Q:$G(RMEXIT)  D DEL

 I $P(^RMPR(664.1,RMPRDA,0),U,13)'="",'$D(RMEXIT) S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""D""" D ^DIE W !,$C(7),"Marked 2529-3 As Deleted..."

 H 2 G EXIT

GIP ;

 S PRCP("QTY")=RMQTY,PRCP("ITEM")=$P($G(^RMPR(661,RMITEM,0)),U,1),PRCP("I")=RMGIP D ^PRCPUSA

 I $D(PRCP("ITEM")) W !,"Error encountered while posting to GIP.",!,"CANCEL ABORTED!!!" S RMEXIT=1 Q

 S RMITEMS=$P(^PRC(441,$P($G(^RMPR(661,RMITEM,0)),U,1),0),U,2)

 W !,"Item: ",RMITEMS

 W !,"Quantity: ",RMQTY," Returned to GIP!!!"

LOC ;

 I $D(RMIT),RMIT="" W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q

 S RMITEMS=$P($G(^RMPR(661.1,RMHS,3,$P(RMIT,"-",2),0)),U,1)

 W !!,"Item: ",RMITEMS

 W !,"Quantity: ",RMQTY," Returned to Prosthetics Inventory!!!"

 D STAT ;updates the Prosthetics Inventory statistics

DEL ;delete status 2529-3

 ;delete entry in the 2319 record and mark entry in 664.1 as deleted

 S RM2=$G(^RMPR(664.1,RMPRDA,2,RL,0)),RMTYPS=$P(RM2,U,7)

 S RMQTY=$P(RM2,U,2),RM660=$P(RM2,U,5)

 S RMUNCO=$P(RM2,U,4),RMITEM=$P(RM2,U,1),RMGIP=$P(RM2,U,13)

 S RM23=$G(^RMPR(664.1,RMPRDA,2,RL,3))

 S (RMDAHC,RMHS)=$P($G(^RMPR(664.1,RMPRDA,2,RL,2)),U,1)

 S RMSO=$P(RM23,U,1),RMLOC=$P(RM23,U,4),RMIT=$P(RM23,U,3)

 D:$G(RMLOC) LOC D:$G(RMGIP) GIP

 Q:$G(RMEXIT)

 S DA=$P(^RMPR(664.1,RMPRDA,2,RL,0),U,5) Q:DA=""

 S DIK="^RMPR(660," D ^DIK

 W !,"Patient 2319 has been deleted" K DA,DIK

STAT ;

 S:$D(^RMPR(661.3,RMLOC)) RMHCDA=$O(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))

 I '$G(RMHCDA) W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q

 S:$D(^RMPR(661.3,RMLOC,1,RMHCDA)) RMITDA=$O(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))

 I '$G(RMITDA) W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q

 S RBAL=0 D

 .S RMBA=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2),RBAL=RMBA+RMQTY

 .S RAV=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10),RAVA=$G(RAV)*(-1)

 .S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RBAL

 .S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,12)=RMQTY

 D BAL^RMPR5NU1

 S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO

 D FILE^DICN K DLAYGO S RMCOM="Returned from LAB STOCK ISSUE"

 S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMHS_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^"_RMQTY_"^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_RAVA

 S DA=+Y,DIK=DIC D IX1^DIK

 W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLOC,0),U,1)," is now: ",RMTOBA

EXIT ;COMMON EXIT POINT

 N RMPRSITE,RMPR D KILL^XUSCLEAN

 K ^UTILITY($J)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29LD   4110     printed  Mar 13, 2025@21:37:03                                                                                                                                                                                                    Page 2

RMPR29LD  ;HIN/RVD-CANCEL LAB ISSUE FROM STOCK;5/27/1998

 +1       ;;3.0;PROSTHETICS;**33**;Feb 09, 1996

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

ASK       ;get patient to cancel

 +1        DO DIV4^RMPRSIT

           if $DATA(X)

               GOTO EXIT

 +2        KILL ^TMP($JOB),DR,DIC,RMPRDA

           SET REDIT=1

 +3        SET DIC="^RMPR(664.1,"

           SET DIC(0)="AEQM"

           SET DR=".01"

 +4        SET DIC("S")="S RCHECK=$O(^RMPR(664.1,+Y,2,0)) I $P(^RMPR(664.1,+Y,0),U,17)=""C"",$D(^RMPR(664.1,+Y,2,RCHECK,3))"

           SET DIC("W")="D EN3^RMPRD1"

 +5        DO ^DIC

           KILL DIC

           if +Y'>0

               GOTO EXIT

           SET RMPRDA=+Y

           IF $GET(RMPRDA)'>0

               QUIT

 +6        LOCK +^RMPR(664.1,RMPRDA,0):1

 +7        IF '$TEST

               WRITE $CHAR(7),!!,?5,"Someone is already editing this entry"

               GOTO EXIT

 +8        SET RMPRDFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)

 +9        DO IN5^VADPT

           SET VAINDT=$PIECE($GET(VAIP(3)),U)

           DO INP^VADPT

 +10       DO HOME^%ZIS

           DO GET^RMPR29W(RMPRDA)

 +11       SET (PAGE,MC,LC,TMC,TLC,TSH)=0

           DO HDR^RMPR29W(RMPRDA)

           SET RI=$ORDER(RCK(0))

           SET (RJ,RTHD)=0

ITD        DO ITM^RMPR293

           SET RMPRWO=$PIECE(RCK(RI),U,3)

TCH        if '$DATA(TECH(RMPRWO))!($ORDER(TECH(RMPRWO,0))'>0)

               GOTO MU

           SET RTCD=$ORDER(TECH(RMPRWO,0))

 +1        SET RTC=$ORDER(TECH(RMPRWO,RTCD,664.33,0))

           IF RTC

               DO TDSP^RMPR293

               GOTO TCH

MU         IF $DATA(TMP(RMPRWO,664.22))

               SET RJ=$ORDER(TMP(RMPRWO,664.22,0))

               IF RJ

                   DO MDSP^RMPR293

                   GOTO MU

 +1        SET SCH=^UTILITY("DIQ1",$JOB,664.2,RMPRWO,4,"E")

           IF +SCH

               if ^UTILITY("DIQ1",$JOB,664.2,RMPRWO,5,"E")

                   SET SCH=^("E")

               SET TSH=TSH+SCH

               WRITE !,?37,"SHIPPING CHARGE: ",?70,$JUSTIFY(SCH,10,2)

 +2        SET RR=1

EXT        SET RW=$ORDER(^UTILITY($JOB,"TEXT",RMPRWO,0))

           IF RW

               DO WDSP^RMPR293

               GOTO EXT

 +1        WRITE !,RMPR("L")

 +2        KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="Would you like to CANCEL this Entry"

           SET DIR("B")="NO"

 +3        DO ^DIR

           if $DATA(DTOUT)!($DATA(DUOUT))

               GOTO EXIT

           if Y=0!(Y<0)

               GOTO EXIT

 +4        FOR RL=0:0

               SET RL=$ORDER(^RMPR(664.1,RMPRDA,2,RL))

               if RL'>0

                   QUIT

               if $GET(RMEXIT)

                   QUIT

               DO DEL

 +5        IF $PIECE(^RMPR(664.1,RMPRDA,0),U,13)'=""

               IF '$DATA(RMEXIT)

                   SET DIE="^RMPR(664.1,"

                   SET DA=RMPRDA

                   SET DR="16///^S X=""D"""

                   DO ^DIE

                   WRITE !,$CHAR(7),"Marked 2529-3 As Deleted..."

 +6        HANG 2

           GOTO EXIT

 +7       ;

GIP       ;

 +1        SET PRCP("QTY")=RMQTY

           SET PRCP("ITEM")=$PIECE($GET(^RMPR(661,RMITEM,0)),U,1)

           SET PRCP("I")=RMGIP

           DO ^PRCPUSA

 +2        IF $DATA(PRCP("ITEM"))

               WRITE !,"Error encountered while posting to GIP.",!,"CANCEL ABORTED!!!"

               SET RMEXIT=1

               QUIT

 +3        SET RMITEMS=$PIECE(^PRC(441,$PIECE($GET(^RMPR(661,RMITEM,0)),U,1),0),U,2)

 +4        WRITE !,"Item: ",RMITEMS

 +5        WRITE !,"Quantity: ",RMQTY," Returned to GIP!!!"

 +6        QUIT

LOC       ;

 +1        IF $DATA(RMIT)

               IF RMIT=""

                   WRITE !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!"

                   QUIT

 +2        SET RMITEMS=$PIECE($GET(^RMPR(661.1,RMHS,3,$PIECE(RMIT,"-",2),0)),U,1)

 +3        WRITE !!,"Item: ",RMITEMS

 +4        WRITE !,"Quantity: ",RMQTY," Returned to Prosthetics Inventory!!!"

 +5       ;updates the Prosthetics Inventory statistics

           DO STAT

 +6        QUIT

 +7       ;

DEL       ;delete status 2529-3

 +1       ;delete entry in the 2319 record and mark entry in 664.1 as deleted

 +2        SET RM2=$GET(^RMPR(664.1,RMPRDA,2,RL,0))

           SET RMTYPS=$PIECE(RM2,U,7)

 +3        SET RMQTY=$PIECE(RM2,U,2)

           SET RM660=$PIECE(RM2,U,5)

 +4        SET RMUNCO=$PIECE(RM2,U,4)

           SET RMITEM=$PIECE(RM2,U,1)

           SET RMGIP=$PIECE(RM2,U,13)

 +5        SET RM23=$GET(^RMPR(664.1,RMPRDA,2,RL,3))

 +6        SET (RMDAHC,RMHS)=$PIECE($GET(^RMPR(664.1,RMPRDA,2,RL,2)),U,1)

 +7        SET RMSO=$PIECE(RM23,U,1)

           SET RMLOC=$PIECE(RM23,U,4)

           SET RMIT=$PIECE(RM23,U,3)

 +8        if $GET(RMLOC)

               DO LOC

           if $GET(RMGIP)

               DO GIP

 +9        if $GET(RMEXIT)

               QUIT

 +10       SET DA=$PIECE(^RMPR(664.1,RMPRDA,2,RL,0),U,5)

           if DA=""

               QUIT

 +11       SET DIK="^RMPR(660,"

           DO ^DIK

 +12       WRITE !,"Patient 2319 has been deleted"

           KILL DA,DIK

 +13       QUIT

 +14      ;

STAT      ;

 +1        if $DATA(^RMPR(661.3,RMLOC))

               SET RMHCDA=$ORDER(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))

 +2        IF '$GET(RMHCDA)

               WRITE !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!"

               QUIT

 +3        if $DATA(^RMPR(661.3,RMLOC,1,RMHCDA))

               SET RMITDA=$ORDER(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))

 +4        IF '$GET(RMITDA)

               WRITE !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!"

               QUIT

 +5        SET RBAL=0

           Begin DoDot:1

 +6            SET RMBA=$PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)

               SET RBAL=RMBA+RMQTY

 +7            SET RAV=$PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10)

               SET RAVA=$GET(RAV)*(-1)

 +8            SET $PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RBAL

 +9            SET $PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,12)=RMQTY

           End DoDot:1

 +10       DO BAL^RMPR5NU1

 +11       SET X=DT

           SET DIC(0)="AEQL"

           SET DLAYGO=661.2

           SET DIC="^RMPR(661.2,"

           KILL DD,DO

 +12       DO FILE^DICN

           KILL DLAYGO

           SET RMCOM="Returned from LAB STOCK ISSUE"

 +13       SET ^RMPR(661.2,+Y,0)=DT_"^^^"_RMHS_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^"_RMQTY_"^"_RMTOBA_"^"_RMCOM_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_RAVA

 +14       SET DA=+Y

           SET DIK=DIC

           DO IX1^DIK

 +15       WRITE !,"****Current Balance @ Location ",$PIECE(^RMPR(661.3,RMLOC,0),U,1)," is now: ",RMTOBA

 +16       QUIT

 +17      ;

EXIT      ;COMMON EXIT POINT

 +1        NEW RMPRSITE,RMPR

           DO KILL^XUSCLEAN

 +2        KILL ^UTILITY($JOB)

 +3        QUIT

RMPR29LD.m