RMPR5NEE ;HIN/RVD-PROS INVENTORY EDIT UTILITY ;2/11/98
;;3.0;PROSTHETICS;**33,37**;Feb 09, 1996
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
;S RMKEY=$O(^DIC(19.1,"B","RMPRMANAGER",0))
S X="NOW" D ^%DT
LOC ;ask for Location.
W @IOF,!!,"Editing an Inventory Item in a Location.....",! 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"
S D="B",DIC("A")="Enter Pros Location: " D MIX^DIC1
G:$D(DTOUT)!$D(DUOUT)!(Y'>0) EXIT S (DA,RMLODA)=+Y
L +^RMPR(661.3,RMLODA):2
I '$T W !,"Record in use. Try again later..." G LOC
S RML=$P(^RMPR(661.3,RMLODA,0),U,1)
S DIE=DIC,DR=".01" D ^DIE K DIE,DR
G:$D(Y)!'$D(^RMPR(661.3,RMLODA,0)) LOC
S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1),DIK=DIC W:RML'=RMLOC !,"Location has been edited from '"_RML_"' to '"_RMLOC_"' !!!"
I $P(^RMPR(661.3,RMLODA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
L -^RMPR(661.3,RMLODA)
;
LIST ;list current HCPCS @ this Location
K DIC("S"),RMR,RMX S DIC("A")="Select HCPCS to EDIT: ",DA(1)=RMLODA
S DIC="^RMPR(661.3,"_DA(1)_",1,",DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?15,$P(^RMPR(661.1,RZ,0),U,2)"
D ^DIC I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." H 1 G LOC
S RMDAHC=$P($G(^RMPR(661.3,RMLODA,1,+Y,0)),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1),RMHCDA=+Y
S DA(2)=RMLODA,DA(1)=RMHCDA K DIC
ITEM ;ask for PSAS Item to to edit.
S DIC("A")="Enter PSAS Item to Edit: ",DIC(0)="AEMNQ"
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
D ^DIC
G:Y'>0!$D(DTOUT)!$D(DUOUT) LOC
L +^RMPR(661.3,RMLODA,1,RMHCDA,1,+Y):2
I '$T W !,"Record in use. Try again later..." G LOC
;
;for item in 661.3
S (DA,RMITDA)=+Y,RDIC3=DIC K DIC("B")
S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),RMIT=$P(RM3,U,1),RMDAIT=$P(RMIT,"-",2)
S RMITEM=$P(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
S RMQU=$P(RM3,U,2),RMCO=$P(RM3,U,3) S:'RMQU RMQU=0 S:'RMCO RMCO=0
;
UPD ;updates item in 661.3
S (RMAVA,RMQUD,RMCOD)=0,DIE=RDIC3
S DR="29;22R;23R~TOTAL COST OF QUANTITY;24;25R;26;27"
D ^DIE
S RM3A=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
S RMQUA=$P(RM3A,U,2),RMCOA=$P(RM3A,U,3),RMAVA=$P(RM3A,U,10),RMSO=$P(RM3A,U,9)
I RMQUA=RMQU,RMCOA=RMCO G LOC
I (RMSO="C")&(RMCOA<.0001) G LIST
I RMSO="C" S:RMAVA<1&RMQUA>0 RMAVA=RMCOA/RMQUA
I RMCO'=RMCOA S RMCOD=RMCOA-RMCO
I RMQU'=RMQUA S RMQUD=RMQUA-RMQU
I RMQUD,'RMCOD S RMCOA=RMAVA*RMQUA
I 'RMQUD,RMCOD S:RMQUA>0 RMAVA=RMCOA/RMQUA
I RMQUD,RMCOD S:RMQUA>0 RMAVA=RMCOA/RMQUA
S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,8)=RMITEM
S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$J(RMAVA,0,2)
;
STAT ;create an item statistics for this event.
G:RMQU=RMQUA&(RMCO=RMCOA) LIST
D BAL^RMPR5NU1
L -^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA)
K DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN
G:$D(DTOUT)!(Y'>0) LIST S DA=+Y
S RMMESF="Edited by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": ("
S RMMESF=RMMESF_$S(RMQUD>0:"+"_RMQUD_")",1:RMQUD_")")
S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQUD_"^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2) S DIK=DIC D IX1^DIK
W !!,"** Item ",RMITEM," was ",RMMESF," @ Location ",RMLOC
H 2 G LIST
;
DEL ;delete a location
S DIR(0)="Y",DIR("B")="N"
W !,"This will DELETE all HCPCS and ITEMS under this LOCATION..."
S DIR("A")="Are you sure you want to DELETE this LOCATION (Y/N) "
D ^DIR I $D(DTOUT)!$D(DUOUT) S RMX=RMR("B") S:Y="^" RMEXIT=1 Q
L +^RMPR(661.3,RMLODA):2
I '$T W !,"Record in use. Try again later..." S RMEXIT=1 Q
I Y>0 S DIK="^RMPR(661.3,",DA=RMLODA D ^DIK W:'$D(^RMPR(661.3,RMLODA,0)) !,"Location is deleted!!!!" H 2 K DIR,DIK,X
Q
;
EXIT ;MAIN EXIT POINT
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NEE 3872 printed Dec 13, 2024@02:33:15 Page 2
RMPR5NEE ;HIN/RVD-PROS INVENTORY EDIT UTILITY ;2/11/98
+1 ;;3.0;PROSTHETICS;**33,37**;Feb 09, 1996
+2 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+3 ;S RMKEY=$O(^DIC(19.1,"B","RMPRMANAGER",0))
+4 SET X="NOW"
DO ^%DT
LOC ;ask for Location.
+1 WRITE @IOF,!!,"Editing an Inventory Item in a Location.....",!
KILL DTOUT,DUOUT,DIC("B")
+2 SET DZ="??"
SET D="B"
SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
+3 SET DIC="^RMPR(661.3,"
SET DIC(0)="AEQM"
+4 SET D="B"
SET DIC("A")="Enter Pros Location: "
DO MIX^DIC1
+5 if $DATA(DTOUT)!$DATA(DUOUT)!(Y'>0)
GOTO EXIT
SET (DA,RMLODA)=+Y
+6 LOCK +^RMPR(661.3,RMLODA):2
+7 IF '$TEST
WRITE !,"Record in use. Try again later..."
GOTO LOC
+8 SET RML=$PIECE(^RMPR(661.3,RMLODA,0),U,1)
+9 SET DIE=DIC
SET DR=".01"
DO ^DIE
KILL DIE,DR
+10 if $DATA(Y)!'$DATA(^RMPR(661.3,RMLODA,0))
GOTO LOC
+11 SET RMLOC=$PIECE(^RMPR(661.3,RMLODA,0),U,1)
SET DIK=DIC
if RML'=RMLOC
WRITE !,"Location has been edited from '"_RML_"' to '"_RMLOC_"' !!!"
+12 IF $PIECE(^RMPR(661.3,RMLODA,0),U,3)=""
SET $PIECE(^(0),U,3)=RMPR("STA")
DO IX1^DIK
+13 LOCK -^RMPR(661.3,RMLODA)
+14 ;
LIST ;list current HCPCS @ this Location
+1 KILL DIC("S"),RMR,RMX
SET DIC("A")="Select HCPCS to EDIT: "
SET DA(1)=RMLODA
+2 SET DIC="^RMPR(661.3,"_DA(1)_",1,"
SET DIC(0)="AEMQ"
SET DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?15,$P(^RMPR(661.1,RZ,0),U,2)"
+3 DO ^DIC
IF +Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
WRITE !,"** No HCPCS selected..."
HANG 1
GOTO LOC
+4 SET RMDAHC=$PIECE($GET(^RMPR(661.3,RMLODA,1,+Y,0)),U,1)
SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
SET RMHCDA=+Y
+5 SET DA(2)=RMLODA
SET DA(1)=RMHCDA
KILL DIC
ITEM ;ask for PSAS Item to to edit.
+1 SET DIC("A")="Enter PSAS Item to Edit: "
SET DIC(0)="AEMNQ"
+2 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+3 DO ^DIC
+4 if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
GOTO LOC
+5 LOCK +^RMPR(661.3,RMLODA,1,RMHCDA,1,+Y):2
+6 IF '$TEST
WRITE !,"Record in use. Try again later..."
GOTO LOC
+7 ;
+8 ;for item in 661.3
+9 SET (DA,RMITDA)=+Y
SET RDIC3=DIC
KILL DIC("B")
+10 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
SET RMIT=$PIECE(RM3,U,1)
SET RMDAIT=$PIECE(RMIT,"-",2)
+11 SET RMITEM=$PIECE(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
+12 SET RMQU=$PIECE(RM3,U,2)
SET RMCO=$PIECE(RM3,U,3)
if 'RMQU
SET RMQU=0
if 'RMCO
SET RMCO=0
+13 ;
UPD ;updates item in 661.3
+1 SET (RMAVA,RMQUD,RMCOD)=0
SET DIE=RDIC3
+2 SET DR="29;22R;23R~TOTAL COST OF QUANTITY;24;25R;26;27"
+3 DO ^DIE
+4 SET RM3A=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
+5 SET RMQUA=$PIECE(RM3A,U,2)
SET RMCOA=$PIECE(RM3A,U,3)
SET RMAVA=$PIECE(RM3A,U,10)
SET RMSO=$PIECE(RM3A,U,9)
+6 IF RMQUA=RMQU
IF RMCOA=RMCO
GOTO LOC
+7 IF (RMSO="C")&(RMCOA<.0001)
GOTO LIST
+8 IF RMSO="C"
if RMAVA<1&RMQUA>0
SET RMAVA=RMCOA/RMQUA
+9 IF RMCO'=RMCOA
SET RMCOD=RMCOA-RMCO
+10 IF RMQU'=RMQUA
SET RMQUD=RMQUA-RMQU
+11 IF RMQUD
IF 'RMCOD
SET RMCOA=RMAVA*RMQUA
+12 IF 'RMQUD
IF RMCOD
if RMQUA>0
SET RMAVA=RMCOA/RMQUA
+13 IF RMQUD
IF RMCOD
if RMQUA>0
SET RMAVA=RMCOA/RMQUA
+14 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
+15 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,8)=RMITEM
+16 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$JUSTIFY(RMAVA,0,2)
+17 ;
STAT ;create an item statistics for this event.
+1 if RMQU=RMQUA&(RMCO=RMCOA)
GOTO LIST
+2 DO BAL^RMPR5NU1
+3 LOCK -^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA)
+4 KILL DD,DO
SET DIC="^RMPR(661.2,"
SET DIC(0)="L"
SET X=DT
SET DLAYGO=661.2
DO FILE^DICN
+5 if $DATA(DTOUT)!(Y'>0)
GOTO LIST
SET DA=+Y
+6 SET RMMESF="Edited by "_$EXTRACT($PIECE(^VA(200,DUZ,0),U,1),1,15)_": ("
+7 SET RMMESF=RMMESF_$SELECT(RMQUD>0:"+"_RMQUD_")",1:RMQUD_")")
+8 SET ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQUD_"^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
SET DIK=DIC
DO IX1^DIK
+9 WRITE !!,"** Item ",RMITEM," was ",RMMESF," @ Location ",RMLOC
+10 HANG 2
GOTO LIST
+11 ;
DEL ;delete a location
+1 SET DIR(0)="Y"
SET DIR("B")="N"
+2 WRITE !,"This will DELETE all HCPCS and ITEMS under this LOCATION..."
+3 SET DIR("A")="Are you sure you want to DELETE this LOCATION (Y/N) "
+4 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET RMX=RMR("B")
if Y="^"
SET RMEXIT=1
QUIT
+5 LOCK +^RMPR(661.3,RMLODA):2
+6 IF '$TEST
WRITE !,"Record in use. Try again later..."
SET RMEXIT=1
QUIT
+7 IF Y>0
SET DIK="^RMPR(661.3,"
SET DA=RMLODA
DO ^DIK
if '$DATA(^RMPR(661.3,RMLODA,0))
WRITE !,"Location is deleted!!!!"
HANG 2
KILL DIR,DIK,X
+8 QUIT
+9 ;
EXIT ;MAIN EXIT POINT
+1 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+2 QUIT
