- 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 Apr 23, 2025@18:47:48 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
