RMPR5NAE ;HIN/RVD-PROS INVENTORY ADD UTILITY ;2/11/98
;;3.0;PROSTHETICS;**33,37,55**;Feb 09, 1996
;
;RVD patch #55 - fix the locking problem and don't allow
; Fileman to use the number entered as an
; PSAS/ITEM name
;
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
S X="NOW" D ^%DT
LOC ;add location.
W @IOF,!!,"Adding Item to 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,",DLAYGO=661.3,DIC(0)="AEQL"
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,+Y,0):2
I '$T W !,"Record in use. Try again later..." H 3 G LOC
S RMLOC=$P(^RMPR(661.3,+Y,0),U,1),DIK=DIC
I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
L -^RMPR(661.3,RMLODA,0)
;
LIST ;list current HCPCS @ this Location
K DIR,DIC("S") S DIR(0)="FO",DIR("A")="Select HCPCS to ADD ",DIR("?")="^S RFL=1 D DSP^RMPR5NU1"
S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) LOC
S DIC(0)="EMNZ",DIC("S")="I $P(^RMPR(661.1,+Y,0),U,5)=1"
S DIC=661.1,DIC(0)="ENMZ" D ^DIC G:$D(DTOUT)!$D(DUOUT) LOC
G:Y="^" LOC
I +Y'>0 W !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..." G LIST
S RMDAHC=+Y,RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
S (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
S DIC(0)="AEMQ",DA(1)=RMDAHC K DIC("S")
ITEM ;ask for PSAS Item to add
S DIC("A")="Enter Item to Add: "
S DIC("B")=$O(^RMPR(661.1,RMDAHC,3,"B",0))
S DIC="^RMPR(661.1,"_DA(1)_",3,",RDIC1=DIC
S $P(^RMPR(661.1,DA(1),3,0),U,2)="661.12"
S DIC(0)="ALEMQ",DLAYGO=661.1 D ^DIC
G:Y'>0!$D(DTOUT)!$D(DUOUT) LIST S (DA,RMDAIT)=+Y K DIC("B"),DLAYGO
S DIE=DIC,DR=".01R" D ^DIE
G:'$D(^RMPR(661.1,RMDAHC,3,RMDAIT,0)) LIST
S RM1=$G(^RMPR(661.1,RMDAHC,3,RMDAIT,0)) G:RM1="" LIST
S RMAV=$P(RM1,U,2),RMTOBA=$P(RM1,U,3),RMTOCO=$P(RM1,U,4)
S $P(^RMPR(661.1,RMDAHC,0),U,9)=1
S RMITEM=$P(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
S RMIT=RMHCPC_"-"_RMDAIT,RMHC=RMDAHC
;
;for HCPCS in 661.3
K DIC("A") S DA(1)=RMLODA
I '$D(^RMPR(661.3,RMLODA,1,"B",RMDAHC)) S X=RMDAHC D
.S $P(^RMPR(661.3,RMLODA,1,0),U,2)="661.31"
.K DD,DO S DIC="^RMPR(661.3,"_DA(1)_",1,",DIC(0)="L",DLAYGO=661.3
.D FILE^DICN Q:Y=-1
S RMHCDA=$O(^RMPR(661.3,RMLODA,1,"B",RMDAHC,0))
G:'RMHCDA EXIT
;
;for item in 661.3
S DA(2)=RMLODA,DA(1)=RMHCDA
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",RDIC3=DIC
I '$D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",RMIT)) S X=RMIT D
.S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,0),U,2)="661.312I"
.K DD,DO S DLAYGO=661.3,DIC(0)="L" D FILE^DICN Q:Y=-1
S (DA,RMITDA)=$O(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",RMIT,0))
G:'RMITDA EXIT
L +^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA):2
I '$T W !!,"Record in use. Try again later..." H 3 G LOC
S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
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
S DIE=RDIC3,DR="29R",DIE("NO^")="BACK" D ^DIE
S DR="22R;23R~TOTAL COST OF QUANTITY;24;25R;26;27"
S DR=DR_";28//^S X=RMITEM" 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 (RMSO="C")&(RMCOA<.0001) G LOC
I RMSO="C" S:(RMAVA<1)&($G(RMQUA)) 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) LOC
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) LOC S DA=+Y
S RMMESF="Added/Updated 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 1 G LIST
;
EXIT ;MAIN EXIT POINT
N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NAE 4462 printed Dec 13, 2024@02:33:14 Page 2
RMPR5NAE ;HIN/RVD-PROS INVENTORY ADD UTILITY ;2/11/98
+1 ;;3.0;PROSTHETICS;**33,37,55**;Feb 09, 1996
+2 ;
+3 ;RVD patch #55 - fix the locking problem and don't allow
+4 ; Fileman to use the number entered as an
+5 ; PSAS/ITEM name
+6 ;
+7 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+8 SET X="NOW"
DO ^%DT
LOC ;add location.
+1 WRITE @IOF,!!,"Adding Item to 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 DLAYGO=661.3
SET DIC(0)="AEQL"
+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,+Y,0):2
+7 IF '$TEST
WRITE !,"Record in use. Try again later..."
HANG 3
GOTO LOC
+8 SET RMLOC=$PIECE(^RMPR(661.3,+Y,0),U,1)
SET DIK=DIC
+9 IF $PIECE(^RMPR(661.3,DA,0),U,3)=""
SET $PIECE(^(0),U,3)=RMPR("STA")
DO IX1^DIK
+10 LOCK -^RMPR(661.3,RMLODA,0)
+11 ;
LIST ;list current HCPCS @ this Location
+1 KILL DIR,DIC("S")
SET DIR(0)="FO"
SET DIR("A")="Select HCPCS to ADD "
SET DIR("?")="^S RFL=1 D DSP^RMPR5NU1"
+2 SET DIR="^RMPR(661.1,"
DO ^DIR
if (Y="^")!(Y="")!$DATA(DTOUT)!$DATA(DUOUT)
GOTO LOC
+3 SET DIC(0)="EMNZ"
SET DIC("S")="I $P(^RMPR(661.1,+Y,0),U,5)=1"
+4 SET DIC=661.1
SET DIC(0)="ENMZ"
DO ^DIC
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO LOC
+5 if Y="^"
GOTO LOC
+6 IF +Y'>0
WRITE !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..."
GOTO LIST
+7 SET RMDAHC=+Y
SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
+8 SET (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
+9 SET DIC(0)="AEMQ"
SET DA(1)=RMDAHC
KILL DIC("S")
ITEM ;ask for PSAS Item to add
+1 SET DIC("A")="Enter Item to Add: "
+2 SET DIC("B")=$ORDER(^RMPR(661.1,RMDAHC,3,"B",0))
+3 SET DIC="^RMPR(661.1,"_DA(1)_",3,"
SET RDIC1=DIC
+4 SET $PIECE(^RMPR(661.1,DA(1),3,0),U,2)="661.12"
+5 SET DIC(0)="ALEMQ"
SET DLAYGO=661.1
DO ^DIC
+6 if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
GOTO LIST
SET (DA,RMDAIT)=+Y
KILL DIC("B"),DLAYGO
+7 SET DIE=DIC
SET DR=".01R"
DO ^DIE
+8 if '$DATA(^RMPR(661.1,RMDAHC,3,RMDAIT,0))
GOTO LIST
+9 SET RM1=$GET(^RMPR(661.1,RMDAHC,3,RMDAIT,0))
if RM1=""
GOTO LIST
+10 SET RMAV=$PIECE(RM1,U,2)
SET RMTOBA=$PIECE(RM1,U,3)
SET RMTOCO=$PIECE(RM1,U,4)
+11 SET $PIECE(^RMPR(661.1,RMDAHC,0),U,9)=1
+12 SET RMITEM=$PIECE(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
+13 SET RMIT=RMHCPC_"-"_RMDAIT
SET RMHC=RMDAHC
+14 ;
+15 ;for HCPCS in 661.3
+16 KILL DIC("A")
SET DA(1)=RMLODA
+17 IF '$DATA(^RMPR(661.3,RMLODA,1,"B",RMDAHC))
SET X=RMDAHC
Begin DoDot:1
+18 SET $PIECE(^RMPR(661.3,RMLODA,1,0),U,2)="661.31"
+19 KILL DD,DO
SET DIC="^RMPR(661.3,"_DA(1)_",1,"
SET DIC(0)="L"
SET DLAYGO=661.3
+20 DO FILE^DICN
if Y=-1
QUIT
End DoDot:1
+21 SET RMHCDA=$ORDER(^RMPR(661.3,RMLODA,1,"B",RMDAHC,0))
+22 if 'RMHCDA
GOTO EXIT
+23 ;
+24 ;for item in 661.3
+25 SET DA(2)=RMLODA
SET DA(1)=RMHCDA
+26 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
SET RDIC3=DIC
+27 IF '$DATA(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",RMIT))
SET X=RMIT
Begin DoDot:1
+28 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,0),U,2)="661.312I"
+29 KILL DD,DO
SET DLAYGO=661.3
SET DIC(0)="L"
DO FILE^DICN
if Y=-1
QUIT
End DoDot:1
+30 SET (DA,RMITDA)=$ORDER(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",RMIT,0))
+31 if 'RMITDA
GOTO EXIT
+32 LOCK +^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA):2
+33 IF '$TEST
WRITE !!,"Record in use. Try again later..."
HANG 3
GOTO LOC
+34 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
+35 SET RMQU=$PIECE(RM3,U,2)
SET RMCO=$PIECE(RM3,U,3)
if 'RMQU
SET RMQU=0
if 'RMCO
SET RMCO=0
+36 ;
UPD ;updates item in 661.3
+1 SET (RMAVA,RMQUD,RMCOD)=0
+2 SET DIE=RDIC3
SET DR="29R"
SET DIE("NO^")="BACK"
DO ^DIE
+3 SET DR="22R;23R~TOTAL COST OF QUANTITY;24;25R;26;27"
+4 SET DR=DR_";28//^S X=RMITEM"
DO ^DIE
+5 SET RM3A=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
+6 SET RMQUA=$PIECE(RM3A,U,2)
SET RMCOA=$PIECE(RM3A,U,3)
SET RMAVA=$PIECE(RM3A,U,10)
SET RMSO=$PIECE(RM3A,U,9)
+7 IF (RMSO="C")&(RMCOA<.0001)
GOTO LOC
+8 IF RMSO="C"
if (RMAVA<1)&($GET(RMQUA))
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 LOC
+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 LOC
SET DA=+Y
+6 SET RMMESF="Added/Updated 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 1
GOTO LIST
+11 ;
EXIT ;MAIN EXIT POINT
+1 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 QUIT
