RMPR5NOR ;HIN/RVD-PROS INVENTORY ORDER/RECEIVE UTILITY ;2/11/98
;;3.0;PROSTHETICS;**33,37,46**;Feb 09, 1996
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
;
W @IOF
LOC ;ask for location
W !!,"Ordering ITEM from Supply or Vendor....",! 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)="AEQM"
S D="B",DIC("A")="Enter Pros Location: " D MIX^DIC1
G:$D(DTOUT)!(Y'>0)!$D(DUOUT) EXIT S (DA,RMLODA)=+Y,DIK=DIC
S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1)
I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
;
LIST ;list current HCPCS @ this Location
K DTOUT,DUOUT,DIC("S"),DIC("B")
S DIC("A")="Select HCPCS to ORDER: "
;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) LOC
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 LOC
S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
;
L ;list current ITEM for this HCPCS
K DTOUT,DUOUT,DIC("S")
S DA(2)=RMLODA,DA(1)=RMHCDA
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
S DIC("A")="Enter Item to ORDER: "
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LIST S RMITDA=+Y
S (RMITFLG,RMHCFLG,RMAV,RMAVA,RMCO,RMBAL)=0
S RMIT=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,1)
S RMDAIT=$P(RMIT,"-",2)
S RMITEM=$P(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
S RMORD=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
;
ORDER ;order item from vendor or supply.
K DIR,Y S DIR(0)="661.312,31",DIR("A")="Quantity to Order" D ^DIR
I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G LOC
I X="" W $C(7),!,"Enter quantity 1 to 99999.." G ORDER
S RMORDER=Y K DIR,Y
S DIE="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
S DA=RMITDA,DR="31////^S X=$G(RMORDER)" D ^DIE
S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
S RMSO=$P(RM3,U,9)
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="Order from supply or vendor"
S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^"_RMORDER_"^^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2) S DA=+Y,DIK=DIC D IX1^DIK K Y
W !,"*** Item ",RMITEM," was ordered...."
H 1 G LOC
;
REC ;receive item from supply, Vendor or Returned Item.
W @IOF
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
S X="NOW" D ^%DT S RMDAT1=Y D DD^%DT S RMDAT2=Y
REC1 W !!,"*** Receiving Item from Supply, Vendor or Veteran...",!
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 Receiving Location: " D MIX^DIC1
G:$D(DTOUT)!(Y'>0)!$D(DUOUT) EXIT S (DA,RMLODA)=+Y,DIK=DIC
S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1)
I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
;
LITEM ;list current HCPCS @ this Location
K DTOUT,DUOUT,DIC("S"),DIC("B")
S DIC("A")="Select HCPCS to RECEIVE: "
;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) REC1
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..." H 1 G REC1
S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
;
;list current ITEM for this HCPCS
K DTOUT,DUOUT,DIC("S"),DIC("B")
S DA(2)=RMLODA,DA(1)=RMHCDA
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
S DIC("A")="Enter Item to RECEIVE: "
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LITEM
S RMITDA=+Y
;S RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0),RMITEM=$P(RM1,U,1)
S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),RMIT=$P(RM3,U,1)
S RMQU=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9)
;
;update LOCATION.
UPDLOC ;W ! S DIC("A")="Receiving LOCATION: ",DIC="^RMPR(661.3,",DLAYGO=661.3
;
UPDQ R !,"Quantity to Receive: ",RMQTREC:DTIME
G:$D(DTOUT)!$D(DUOUT)!(RMQTREC="^") MESS
I RMQTREC["?"!(RMQTREC'>0)!(RMQTREC>999) W $C(7),!,"Enter quantity 1 to 999.." G UPDQ
;
UPDC ;ask for total Item cost
K DIR,Y,DA S DIR(0)="661.312,23",DIR("A")="Total Cost of Item " D ^DIR
G:$D(DUOUT)!$D(DTOUT) MESS
I X="" W $C(7),!,"Enter Cost 0 to 999999.." G UPDC
S RMCOREC=Y K DIR,Y
S RMCOA=RMCO+RMCOREC
S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
S RMQUA=RMQU+RMQTREC
I RMQUA>0 S RMAVA=RMCOA/RMQUA
I RMQUA<1 S RMAVA=RMCOREC/RMQTREC
S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$J(RMAVA,0,2)
S RMORD=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
;
;update Total Item Cost and delete ordered date
S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,2)=RMQUA
S RMSO=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,9)
;
STAT 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="Received from supply or vendor"
S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQTREC_"^"_RMIT_"^^"_RMQTREC_"^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
S DA=+Y,DIK=DIC D IX1^DIK
W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLODA,0),U,1)," is now: ",RMQUA
I RMORD S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)=RMORD-RMQTREC
H 1 G REC1
;
MESS W !,"Nothing Received....."
EXIT ;MAIN EXIT POINT
N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NOR 5794 printed Dec 13, 2024@02:33:16 Page 2
RMPR5NOR ;HIN/RVD-PROS INVENTORY ORDER/RECEIVE UTILITY ;2/11/98
+1 ;;3.0;PROSTHETICS;**33,37,46**;Feb 09, 1996
+2 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+3 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+4 ;
+5 WRITE @IOF
LOC ;ask for location
+1 WRITE !!,"Ordering ITEM from Supply or Vendor....",!
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)="AEQM"
+4 SET D="B"
SET DIC("A")="Enter Pros Location: "
DO MIX^DIC1
+5 if $DATA(DTOUT)!(Y'>0)!$DATA(DUOUT)
GOTO EXIT
SET (DA,RMLODA)=+Y
SET DIK=DIC
+6 SET RMLOC=$PIECE(^RMPR(661.3,RMLODA,0),U,1)
+7 IF $PIECE(^RMPR(661.3,DA,0),U,3)=""
SET $PIECE(^(0),U,3)=RMPR("STA")
DO IX1^DIK
+8 ;
LIST ;list current HCPCS @ this Location
+1 KILL DTOUT,DUOUT,DIC("S"),DIC("B")
+2 SET DIC("A")="Select HCPCS to ORDER: "
+3 ;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
+4 ;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) LOC
+5 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)"
+6 SET DIC="^RMPR(661.3,"_RMLODA_",1,"
DO ^DIC
+7 IF +Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
WRITE !,"** No HCPCS selected..."
GOTO LOC
+8 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)
+9 ;
L ;list current ITEM for this HCPCS
+1 KILL DTOUT,DUOUT,DIC("S")
+2 SET DA(2)=RMLODA
SET DA(1)=RMHCDA
+3 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+4 SET DIC("A")="Enter Item to ORDER: "
+5 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
SET DIC(0)="AEMNQ"
+6 DO ^DIC
if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
GOTO LIST
SET RMITDA=+Y
+7 SET (RMITFLG,RMHCFLG,RMAV,RMAVA,RMCO,RMBAL)=0
+8 SET RMIT=$PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,1)
+9 SET RMDAIT=$PIECE(RMIT,"-",2)
+10 SET RMITEM=$PIECE(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
+11 SET RMORD=$PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
+12 ;
ORDER ;order item from vendor or supply.
+1 KILL DIR,Y
SET DIR(0)="661.312,31"
SET DIR("A")="Quantity to Order"
DO ^DIR
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
WRITE !,"*** Item was not ordered...."
HANG 1
GOTO LOC
+3 IF X=""
WRITE $CHAR(7),!,"Enter quantity 1 to 99999.."
GOTO ORDER
+4 SET RMORDER=Y
KILL DIR,Y
+5 SET DIE="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+6 SET DA=RMITDA
SET DR="31////^S X=$G(RMORDER)"
DO ^DIE
+7 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
+8 SET RMSO=$PIECE(RM3,U,9)
+9 DO BAL^RMPR5NU1
+10 SET X=DT
SET DIC(0)="AEQL"
SET DLAYGO=661.2
SET DIC="^RMPR(661.2,"
KILL DD,DO
+11 DO FILE^DICN
KILL DLAYGO
SET RMCOM="Order from supply or vendor"
+12 SET ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^"_RMORDER_"^^"_RMTOBA_"^"_RMCOM_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
SET DA=+Y
SET DIK=DIC
DO IX1^DIK
KILL Y
+13 WRITE !,"*** Item ",RMITEM," was ordered...."
+14 HANG 1
GOTO LOC
+15 ;
REC ;receive item from supply, Vendor or Returned Item.
+1 WRITE @IOF
+2 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+3 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+4 SET X="NOW"
DO ^%DT
SET RMDAT1=Y
DO DD^%DT
SET RMDAT2=Y
REC1 WRITE !!,"*** Receiving Item from Supply, Vendor or Veteran...",!
+1 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 Receiving Location: "
DO MIX^DIC1
+5 if $DATA(DTOUT)!(Y'>0)!$DATA(DUOUT)
GOTO EXIT
SET (DA,RMLODA)=+Y
SET DIK=DIC
+6 SET RMLOC=$PIECE(^RMPR(661.3,RMLODA,0),U,1)
+7 IF $PIECE(^RMPR(661.3,DA,0),U,3)=""
SET $PIECE(^(0),U,3)=RMPR("STA")
DO IX1^DIK
+8 ;
LITEM ;list current HCPCS @ this Location
+1 KILL DTOUT,DUOUT,DIC("S"),DIC("B")
+2 SET DIC("A")="Select HCPCS to RECEIVE: "
+3 ;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
+4 ;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) REC1
+5 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)"
+6 SET DIC="^RMPR(661.3,"_RMLODA_",1,"
DO ^DIC
+7 IF +Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
WRITE !,"** No HCPCS selected..."
HANG 1
GOTO REC1
+8 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)
+9 ;
+10 ;list current ITEM for this HCPCS
+11 KILL DTOUT,DUOUT,DIC("S"),DIC("B")
+12 SET DA(2)=RMLODA
SET DA(1)=RMHCDA
+13 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+14 SET DIC("A")="Enter Item to RECEIVE: "
+15 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
SET DIC(0)="AEMNQ"
+16 DO ^DIC
if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
GOTO LITEM
+17 SET RMITDA=+Y
+18 ;S RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0),RMITEM=$P(RM1,U,1)
+19 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
SET RMIT=$PIECE(RM3,U,1)
+20 SET RMQU=$PIECE(RM3,U,2)
SET RMCO=$PIECE(RM3,U,3)
SET RMSO=$PIECE(RM3,U,9)
+21 ;
+22 ;update LOCATION.
UPDLOC ;W ! S DIC("A")="Receiving LOCATION: ",DIC="^RMPR(661.3,",DLAYGO=661.3
+1 ;
UPDQ READ !,"Quantity to Receive: ",RMQTREC:DTIME
+1 if $DATA(DTOUT)!$DATA(DUOUT)!(RMQTREC="^")
GOTO MESS
+2 IF RMQTREC["?"!(RMQTREC'>0)!(RMQTREC>999)
WRITE $CHAR(7),!,"Enter quantity 1 to 999.."
GOTO UPDQ
+3 ;
UPDC ;ask for total Item cost
+1 KILL DIR,Y,DA
SET DIR(0)="661.312,23"
SET DIR("A")="Total Cost of Item "
DO ^DIR
+2 if $DATA(DUOUT)!$DATA(DTOUT)
GOTO MESS
+3 IF X=""
WRITE $CHAR(7),!,"Enter Cost 0 to 999999.."
GOTO UPDC
+4 SET RMCOREC=Y
KILL DIR,Y
+5 SET RMCOA=RMCO+RMCOREC
+6 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
+7 SET RMQUA=RMQU+RMQTREC
+8 IF RMQUA>0
SET RMAVA=RMCOA/RMQUA
+9 IF RMQUA<1
SET RMAVA=RMCOREC/RMQTREC
+10 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$JUSTIFY(RMAVA,0,2)
+11 SET RMORD=$PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
+12 ;
+13 ;update Total Item Cost and delete ordered date
+14 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,2)=RMQUA
+15 SET RMSO=$PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,9)
+16 ;
STAT DO BAL^RMPR5NU1
+1 SET X=DT
SET DIC(0)="AEQL"
SET DLAYGO=661.2
SET DIC="^RMPR(661.2,"
KILL DD,DO
+2 DO FILE^DICN
KILL DLAYGO
SET RMCOM="Received from supply or vendor"
+3 SET ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQTREC_"^"_RMIT_"^^"_RMQTREC_"^"_RMTOBA_"^"_RMCOM_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
+4 SET DA=+Y
SET DIK=DIC
DO IX1^DIK
+5 WRITE !,"****Current Balance @ Location ",$PIECE(^RMPR(661.3,RMLODA,0),U,1)," is now: ",RMQUA
+6 IF RMORD
SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)=RMORD-RMQTREC
+7 HANG 1
GOTO REC1
+8 ;
MESS WRITE !,"Nothing Received....."
EXIT ;MAIN EXIT POINT
+1 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 QUIT
