RMPR5NTU ;HIN/RVD-PROS INVENTORY TRANS/UPDATE UTILITY ;2/11/98
;;3.0;PROSTHETICS;**33,34,37**;Feb 09, 1996
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
W @IOF
;
TRAN ;ask for Location.
S X="NOW" D ^%DT S RMDAT1=Y D DD^%DT S RMDAT=Y
K DTOUT,DUOUT,DIC("B")
W !!,"Transferring Item Quantity to Another LOCATION....."
S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
S DIC="^RMPR(661.3,",DIC(0)="AEQM"
;I $D(^RMPR(661.3,"B")) D DQ^DICQ
S D="B",DIC("A")="From Location: " D MIX^DIC1
G:Y'>0!$D(DTOUT)!$D(DUOUT) EXIT
S (RMLOFDA,RMLODA)=+Y,(RMLOC,RMLOF)=$P(^RMPR(661.3,+Y,0),U,1) K DIC("S"),DIC("B")
S DA(1)=RMLOFDA,DIC="^RMPR(661.3,"_DA(1)_",1,"
;
THCPCS ;ask for HCPCS to transfer.
S DIC("A")="Enter HCPCS to Transfer: " K DTOUT,DUOUT,DIC("S"),DIC("B")
S DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?25,$P($G(^RMPR(661.1,RZ,0)),U,2)"
S DIC="^RMPR(661.3,"_RMLODA_",1,",DA(1)=RMLODA D ^DIC
I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." G TRAN
S RMHCFDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
S DIC(0)="ANEMQ",DA(1)=RMHCFDA,DA(2)=RMLOFDA
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
;
LIST ;ask for PSAS Item to transfer.
;I $D(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,"B")) S DZ="??",D="B" D DQ^DICQ
;S DIC("B")=$O(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,"B",0))
S DIC("A")="Enter item to transfer: " D ^DIC
G:(+Y'>0)!$D(DTOUT)!$D(DUOUT) TRAN
L +^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,+Y):2
I '$T W !,"Record in use. Try again later..." G TRAN
S RMITFDA=+Y,RMIT=$P(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,+Y,0),U,1)
S RMDAFIT=$P(RMIT,"-",2)
S RM3=^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0)
S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9),RMAV=$P(RM3,U,10)
;
TRANQ ;ask for Quantity to transfer.
S RMQTY=0 R !,"Enter Quantity to transfer: ",RMQTY:DTIME
I $D(DTOUT)!($D(DUOUT))!(RMQTY="^") W !,"*** Nothing transferred ..." G EXIT
I RMQTY["?"!(RMQTY<.0001) W $C(7),!!,"Current balance is = ",RMBA W:RMBA>0 !,"Enter quantity 1 to ",RMBA," or" W " enter '^' to QUIT? " G TRANQ
I RMQTY>RMBA W !!,$C(7),"Quantity to transfer is greater than current balance.." G TRANQ
;
TRANT ;ask for forwarding Location.
S DIC("S")="I $D(^RMPR(661.3,""C"",RMDAHC,+Y)),($P(^RMPR(661.3,+Y,0),U,1)'=RMLOF)"
S DZ="??",D="B"
S DIC="^RMPR(661.3,",DIC(0)="AEQM"
S DIC("A")="Enter Receiving Location: ",DIC="^RMPR(661.3," K DIC("B")
S DIC(0)="AEQ",D="B" D MIX^DIC1
I $D(DTOUT)!($D(DUOUT)) W !,"*** Nothing transferred ..." G EXIT
G:Y'>0 TRANT
S RMLORDA=+Y
I RMLOFDA=RMLORDA W !,$C(7),"***Forwarding and Receiving Location is the same!!!!" G TRANT
;
TRANI S RMHCRDA=$O(^RMPR(661.3,RMLORDA,1,"B",RMDAHC,0))
S RMDARHC=$P(^RMPR(661.3,RMLORDA,1,RMHCRDA,0),U,1)
;ask/enter forwarding item
S DIC(0)="ANEMQ",DA(1)=RMHCRDA,DA(2)=RMLORDA K DIC("S")
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
S DIC("A")="Enter Receiving Item: " D ^DIC
G:(+Y'>0)!$D(DTOUT)!$D(DUOUT) EXIT
L +^RMPR(661.3,RMLORDA,1,RMHCRDA,1,+Y):2
I '$T W !,"Record in use. Try again later..." G TRANI
S RMITRDA=+Y,RMIT=$P(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,+Y,0),U,1)
;
S RMTO=$G(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0))
S RMBAR=$P(RMTO,U,2),RMBAR=RMBAR+RMQTY,RMCOR=RMAV*RMBAR
S RMLOR=$P(^RMPR(661.3,RMLORDA,0),U,1)
S RMFR=$G(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0))
S RMBAF=$P(RMFR,U,2),RMBAF=RMBAF-RMQTY,RMCOF=RMAV*RMBAF
W !,"Quantity ",RMQTY," was transferred from ",RMLOF," to ",RMLOR
S $P(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0),U,2)=RMBAF
S $P(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0),U,2)=RMBAR
S $P(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0),U,3)=RMCOF
S $P(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0),U,3)=RMCOR
S RMRSTA=$P($G(^RMPR(661.3,RMLORDA,0)),U,3)
;
STAT ;create transfer stat for an item
D BAL^RMPR5NU1
L -^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA)
L -^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA)
S DIC="^RMPR(661.2,",DLAYGO=661.2,X=RMDAT1,DIC(0)="L" K DD,DO
D FILE^DICN G:Y'>0 TRAN S DA=+Y
S RMMES="QTY "_RMQTY_" transferred from "_$E(RMLOF,1,8)_" to "_$E(RMLOR,1,8)
S ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMES_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLORDA_"^"_$J(RMAVA,0,2)
S DIK=DIC D IX1^DIK
I RMPR("STA")'=RMRSTA D
.S RMFSTA=RMPR("STA"),RMPR("STA")=RMRSTA D BAL^RMPR5NU1
.S DIC="^RMPR(661.2,",DLAYGO=661.2,X=RMDAT1,DIC(0)="L" K DD,DO
.D FILE^DICN G:Y'>0 TRAN S DA=+Y
.S RMMES="QTY "_RMQTY_" transferred from "_$E(RMLOF,1,8)_" to "_$E(RMLOR,1,8)
.S ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMES_"^"_$J(RMTOCO,0,2)_"^"_RMRSTA_"^"_RMLORDA_"^"_$J(RMAVA,0,2)
.S RMPR("STA")=RMFSTA
.S DIK=DIC D IX1^DIK
W !,"*** Item was transferred..."
H 1 G TRAN
;
UPD ;update current inventory item balance.
W @IOF
UPD1 W !!,"Updating Item in a Location.....",!
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
S X="NOW" D ^%DT S RMDAT1=Y D DD^%DT S RMDAT=Y K DTOUT,DUOUT,DIC("B")
S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
S DIC="^RMPR(661.3,",DIC(0)="AEQM"
;I $D(^RMPR(661.3,"B")) D DQ^DICQ
S DIC("A")="Enter Pros Location: "
D MIX^DIC1 G:(+Y'>0)!($D(DTOUT))!$D(DUOUT) EXIT S RMLODA=+Y
S RMLOC=$P(^RMPR(661.3,+Y,0),U,1)
;
HCPC S DA(1)=RMLODA,DIC="^RMPR(661.3,"_DA(1)_",1," K DTOUT,DUOUT
K DTOUT,DUOUT,DIC("S"),DIR
S DIC("A")="Select HCPCS to Update: "
S DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?25,$P($G(^RMPR(661.1,RZ,0)),U,2)"
S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." G UPD1
S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
;
ITEM ;
S DIC(0)="ANEMQ",DA(1)=RMHCDA,DA(2)=RMLODA
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
G:'$D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B")) HCPC
;I $D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B")) S DZ="??",D="B" D DQ^DICQ
S DIC("B")=$O(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",0))
S DIC("A")="Enter ITEM to Update: " D ^DIC K DIC("B")
G:(+Y'>0)!($D(DTOUT))!$D(DUOUT) HCPC S RMITDA=+Y
L +^RMPR(661.3,RMLODA,1,RMHCDA,1,+Y):2
I '$T W !,"Record in use. Try again later..." G ITEM
S RMIT=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,1)
S RMHCPC=$P(RMIT,"-",1),RMDAIT=$P(RMIT,"-",2)
S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMUNI=$P(RM3,U,4),RMSOB=$P(RM3,U,9)
S RMRORA=$P(RM3,U,6),RMDIIA=$P(RM3,U,7),RMVENA=$P(RM3,U,5)
S DA(2)=RMLODA,DA(1)=RMHCDA,DA=RMITDA
S DIE="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
S DR="29R" D ^DIE
I $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,9)="C" S DR="22R;24;25R;26;27"
E S DR="22R;24;27"
D ^DIE
S (RMAVD,RMBAD,RMCOD)=0
S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
S RMBAA=$P(RM3,U,2),RMSO=$P(RM3,U,9),RMAVA=$P(RM3,U,10)
S RMRORAA=$P(RM3,U,6),RMDIIAA=$P(RM3,U,7),RMVENAA=$P(RM3,U,5)
S RMUNIA=$P(RM3,U,4)
I RMBAA=RMBA,RMRORA=RMRORAA,RMDIIA=RMDIIAA,RMVENA=RMVENAA,RMSO=RMSOB,RMUNI=RMUNIA W !,"*** Nothing updated...." G UPD1
S:RMBA'=RMBAA RMBAD=RMBAA-RMBA S RMCOA=RMBAA*RMAVA
S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
;
STATUPD ;create UPDATE stat for an item
D BAL^RMPR5NU1
L -^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA)
S DIC="^RMPR(661.2,",DLAYGO=661.2,X=RMDAT1,DIC(0)="L" K DD,DO
D FILE^DICN G:Y'>0 UPD1 S DA=+Y
S RMMESF="QTY updated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_":"
S ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMBAD_"^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
W !,"*** Item was updated..."
S DIK=DIC D IX1^DIK
H 1 G UPD1
;
EXIT ;MAIN EXIT POINT
N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NTU 7769 printed Dec 13, 2024@02:33:18 Page 2
RMPR5NTU ;HIN/RVD-PROS INVENTORY TRANS/UPDATE UTILITY ;2/11/98
+1 ;;3.0;PROSTHETICS;**33,34,37**;Feb 09, 1996
+2 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+3 WRITE @IOF
+4 ;
TRAN ;ask for Location.
+1 SET X="NOW"
DO ^%DT
SET RMDAT1=Y
DO DD^%DT
SET RMDAT=Y
+2 KILL DTOUT,DUOUT,DIC("B")
+3 WRITE !!,"Transferring Item Quantity to Another LOCATION....."
+4 SET DZ="??"
SET D="B"
SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
+5 SET DIC="^RMPR(661.3,"
SET DIC(0)="AEQM"
+6 ;I $D(^RMPR(661.3,"B")) D DQ^DICQ
+7 SET D="B"
SET DIC("A")="From Location: "
DO MIX^DIC1
+8 if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+9 SET (RMLOFDA,RMLODA)=+Y
SET (RMLOC,RMLOF)=$PIECE(^RMPR(661.3,+Y,0),U,1)
KILL DIC("S"),DIC("B")
+10 SET DA(1)=RMLOFDA
SET DIC="^RMPR(661.3,"_DA(1)_",1,"
+11 ;
THCPCS ;ask for HCPCS to transfer.
+1 SET DIC("A")="Enter HCPCS to Transfer: "
KILL DTOUT,DUOUT,DIC("S"),DIC("B")
+2 SET DIC(0)="AEMQ"
SET DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?25,$P($G(^RMPR(661.1,RZ,0)),U,2)"
+3 SET DIC="^RMPR(661.3,"_RMLODA_",1,"
SET DA(1)=RMLODA
DO ^DIC
+4 IF +Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
WRITE !,"** No HCPCS selected..."
GOTO TRAN
+5 SET RMHCFDA=+Y
SET RMDAHC=$PIECE(^RMPR(661.3,RMLODA,1,+Y,0),U,1)
SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
+6 SET DIC(0)="ANEMQ"
SET DA(1)=RMHCFDA
SET DA(2)=RMLOFDA
+7 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+8 ;
LIST ;ask for PSAS Item to transfer.
+1 ;I $D(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,"B")) S DZ="??",D="B" D DQ^DICQ
+2 ;S DIC("B")=$O(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,"B",0))
+3 SET DIC("A")="Enter item to transfer: "
DO ^DIC
+4 if (+Y'>0)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO TRAN
+5 LOCK +^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,+Y):2
+6 IF '$TEST
WRITE !,"Record in use. Try again later..."
GOTO TRAN
+7 SET RMITFDA=+Y
SET RMIT=$PIECE(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,+Y,0),U,1)
+8 SET RMDAFIT=$PIECE(RMIT,"-",2)
+9 SET RM3=^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0)
+10 SET RMBA=$PIECE(RM3,U,2)
SET RMCO=$PIECE(RM3,U,3)
SET RMSO=$PIECE(RM3,U,9)
SET RMAV=$PIECE(RM3,U,10)
+11 ;
TRANQ ;ask for Quantity to transfer.
+1 SET RMQTY=0
READ !,"Enter Quantity to transfer: ",RMQTY:DTIME
+2 IF $DATA(DTOUT)!($DATA(DUOUT))!(RMQTY="^")
WRITE !,"*** Nothing transferred ..."
GOTO EXIT
+3 IF RMQTY["?"!(RMQTY<.0001)
WRITE $CHAR(7),!!,"Current balance is = ",RMBA
if RMBA>0
WRITE !,"Enter quantity 1 to ",RMBA," or"
WRITE " enter '^' to QUIT? "
GOTO TRANQ
+4 IF RMQTY>RMBA
WRITE !!,$CHAR(7),"Quantity to transfer is greater than current balance.."
GOTO TRANQ
+5 ;
TRANT ;ask for forwarding Location.
+1 SET DIC("S")="I $D(^RMPR(661.3,""C"",RMDAHC,+Y)),($P(^RMPR(661.3,+Y,0),U,1)'=RMLOF)"
+2 SET DZ="??"
SET D="B"
+3 SET DIC="^RMPR(661.3,"
SET DIC(0)="AEQM"
+4 SET DIC("A")="Enter Receiving Location: "
SET DIC="^RMPR(661.3,"
KILL DIC("B")
+5 SET DIC(0)="AEQ"
SET D="B"
DO MIX^DIC1
+6 IF $DATA(DTOUT)!($DATA(DUOUT))
WRITE !,"*** Nothing transferred ..."
GOTO EXIT
+7 if Y'>0
GOTO TRANT
+8 SET RMLORDA=+Y
+9 IF RMLOFDA=RMLORDA
WRITE !,$CHAR(7),"***Forwarding and Receiving Location is the same!!!!"
GOTO TRANT
+10 ;
TRANI SET RMHCRDA=$ORDER(^RMPR(661.3,RMLORDA,1,"B",RMDAHC,0))
+1 SET RMDARHC=$PIECE(^RMPR(661.3,RMLORDA,1,RMHCRDA,0),U,1)
+2 ;ask/enter forwarding item
+3 SET DIC(0)="ANEMQ"
SET DA(1)=RMHCRDA
SET DA(2)=RMLORDA
KILL DIC("S")
+4 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+5 SET DIC("A")="Enter Receiving Item: "
DO ^DIC
+6 if (+Y'>0)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+7 LOCK +^RMPR(661.3,RMLORDA,1,RMHCRDA,1,+Y):2
+8 IF '$TEST
WRITE !,"Record in use. Try again later..."
GOTO TRANI
+9 SET RMITRDA=+Y
SET RMIT=$PIECE(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,+Y,0),U,1)
+10 ;
+11 SET RMTO=$GET(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0))
+12 SET RMBAR=$PIECE(RMTO,U,2)
SET RMBAR=RMBAR+RMQTY
SET RMCOR=RMAV*RMBAR
+13 SET RMLOR=$PIECE(^RMPR(661.3,RMLORDA,0),U,1)
+14 SET RMFR=$GET(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0))
+15 SET RMBAF=$PIECE(RMFR,U,2)
SET RMBAF=RMBAF-RMQTY
SET RMCOF=RMAV*RMBAF
+16 WRITE !,"Quantity ",RMQTY," was transferred from ",RMLOF," to ",RMLOR
+17 SET $PIECE(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0),U,2)=RMBAF
+18 SET $PIECE(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0),U,2)=RMBAR
+19 SET $PIECE(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0),U,3)=RMCOF
+20 SET $PIECE(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0),U,3)=RMCOR
+21 SET RMRSTA=$PIECE($GET(^RMPR(661.3,RMLORDA,0)),U,3)
+22 ;
STAT ;create transfer stat for an item
+1 DO BAL^RMPR5NU1
+2 LOCK -^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA)
+3 LOCK -^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA)
+4 SET DIC="^RMPR(661.2,"
SET DLAYGO=661.2
SET X=RMDAT1
SET DIC(0)="L"
KILL DD,DO
+5 DO FILE^DICN
if Y'>0
GOTO TRAN
SET DA=+Y
+6 SET RMMES="QTY "_RMQTY_" transferred from "_$EXTRACT(RMLOF,1,8)_" to "_$EXTRACT(RMLOR,1,8)
+7 SET ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMES_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLORDA_"^"_$JUSTIFY(RMAVA,0,2)
+8 SET DIK=DIC
DO IX1^DIK
+9 IF RMPR("STA")'=RMRSTA
Begin DoDot:1
+10 SET RMFSTA=RMPR("STA")
SET RMPR("STA")=RMRSTA
DO BAL^RMPR5NU1
+11 SET DIC="^RMPR(661.2,"
SET DLAYGO=661.2
SET X=RMDAT1
SET DIC(0)="L"
KILL DD,DO
+12 DO FILE^DICN
if Y'>0
GOTO TRAN
SET DA=+Y
+13 SET RMMES="QTY "_RMQTY_" transferred from "_$EXTRACT(RMLOF,1,8)_" to "_$EXTRACT(RMLOR,1,8)
+14 SET ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMES_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMRSTA_"^"_RMLORDA_"^"_$JUSTIFY(RMAVA,0,2)
+15 SET RMPR("STA")=RMFSTA
+16 SET DIK=DIC
DO IX1^DIK
End DoDot:1
+17 WRITE !,"*** Item was transferred..."
+18 HANG 1
GOTO TRAN
+19 ;
UPD ;update current inventory item balance.
+1 WRITE @IOF
UPD1 WRITE !!,"Updating Item in a Location.....",!
+1 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+2 SET X="NOW"
DO ^%DT
SET RMDAT1=Y
DO DD^%DT
SET RMDAT=Y
KILL DTOUT,DUOUT,DIC("B")
+3 SET DZ="??"
SET D="B"
SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
+4 SET DIC="^RMPR(661.3,"
SET DIC(0)="AEQM"
+5 ;I $D(^RMPR(661.3,"B")) D DQ^DICQ
+6 SET DIC("A")="Enter Pros Location: "
+7 DO MIX^DIC1
if (+Y'>0)!($DATA(DTOUT))!$DATA(DUOUT)
GOTO EXIT
SET RMLODA=+Y
+8 SET RMLOC=$PIECE(^RMPR(661.3,+Y,0),U,1)
+9 ;
HCPC SET DA(1)=RMLODA
SET DIC="^RMPR(661.3,"_DA(1)_",1,"
KILL DTOUT,DUOUT
+1 KILL DTOUT,DUOUT,DIC("S"),DIR
+2 SET DIC("A")="Select HCPCS to Update: "
+3 SET DIC(0)="AEMQ"
SET DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?25,$P($G(^RMPR(661.1,RZ,0)),U,2)"
+4 SET DIC="^RMPR(661.3,"_RMLODA_",1,"
DO ^DIC
+5 IF +Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
WRITE !,"** No HCPCS selected..."
GOTO UPD1
+6 SET RMHCDA=+Y
SET RMDAHC=$PIECE(^RMPR(661.3,RMLODA,1,+Y,0),U,1)
SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
+7 ;
ITEM ;
+1 SET DIC(0)="ANEMQ"
SET DA(1)=RMHCDA
SET DA(2)=RMLODA
+2 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+3 if '$DATA(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B"))
GOTO HCPC
+4 ;I $D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B")) S DZ="??",D="B" D DQ^DICQ
+5 SET DIC("B")=$ORDER(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",0))
+6 SET DIC("A")="Enter ITEM to Update: "
DO ^DIC
KILL DIC("B")
+7 if (+Y'>0)!($DATA(DTOUT))!$DATA(DUOUT)
GOTO HCPC
SET RMITDA=+Y
+8 LOCK +^RMPR(661.3,RMLODA,1,RMHCDA,1,+Y):2
+9 IF '$TEST
WRITE !,"Record in use. Try again later..."
GOTO ITEM
+10 SET RMIT=$PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,1)
+11 SET RMHCPC=$PIECE(RMIT,"-",1)
SET RMDAIT=$PIECE(RMIT,"-",2)
+12 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
+13 SET RMBA=$PIECE(RM3,U,2)
SET RMCO=$PIECE(RM3,U,3)
SET RMUNI=$PIECE(RM3,U,4)
SET RMSOB=$PIECE(RM3,U,9)
+14 SET RMRORA=$PIECE(RM3,U,6)
SET RMDIIA=$PIECE(RM3,U,7)
SET RMVENA=$PIECE(RM3,U,5)
+15 SET DA(2)=RMLODA
SET DA(1)=RMHCDA
SET DA=RMITDA
+16 SET DIE="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+17 SET DR="29R"
DO ^DIE
+18 IF $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,9)="C"
SET DR="22R;24;25R;26;27"
+19 IF '$TEST
SET DR="22R;24;27"
+20 DO ^DIE
+21 SET (RMAVD,RMBAD,RMCOD)=0
+22 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
+23 SET RMBAA=$PIECE(RM3,U,2)
SET RMSO=$PIECE(RM3,U,9)
SET RMAVA=$PIECE(RM3,U,10)
+24 SET RMRORAA=$PIECE(RM3,U,6)
SET RMDIIAA=$PIECE(RM3,U,7)
SET RMVENAA=$PIECE(RM3,U,5)
+25 SET RMUNIA=$PIECE(RM3,U,4)
+26 IF RMBAA=RMBA
IF RMRORA=RMRORAA
IF RMDIIA=RMDIIAA
IF RMVENA=RMVENAA
IF RMSO=RMSOB
IF RMUNI=RMUNIA
WRITE !,"*** Nothing updated...."
GOTO UPD1
+27 if RMBA'=RMBAA
SET RMBAD=RMBAA-RMBA
SET RMCOA=RMBAA*RMAVA
+28 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
+29 ;
STATUPD ;create UPDATE stat for an item
+1 DO BAL^RMPR5NU1
+2 LOCK -^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA)
+3 SET DIC="^RMPR(661.2,"
SET DLAYGO=661.2
SET X=RMDAT1
SET DIC(0)="L"
KILL DD,DO
+4 DO FILE^DICN
if Y'>0
GOTO UPD1
SET DA=+Y
+5 SET RMMESF="QTY updated by "_$EXTRACT($PIECE(^VA(200,DUZ,0),U,1),1,15)_":"
+6 SET ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMBAD_"^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
+7 WRITE !,"*** Item was updated..."
+8 SET DIK=DIC
DO IX1^DIK
+9 HANG 1
GOTO UPD1
+10 ;
EXIT ;MAIN EXIT POINT
+1 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 QUIT
