RMPRRET9 ;PHX/RFM-RETURN ITEMS FROM FILE 667.1 ;8/29/1994
;;3.0;PROSTHETICS;;Feb 09, 1996
EN K DIC S DIC=667.1,DIC(0)="AEQMZ",DIC("A")="Select ITEM: " D ^DIC G:Y<0 EXIT S RMPRITEM=+Y
EN1 K DIR S DIR(0)="660.1,3",DIR("A")="QTY",DIR("B")=1 D ^DIR G:$$CK EXIT I X="" W !,"Enter `^` to exit" G EN1
S RMPRQTY=X
K DIR S DIR(0)="660.1,4",DIR("A")="UNIT COST",DIR("B")=0 D ^DIR G:$$CK EXIT S (RMPRCOST,RMPRCST)=X
RETU K DIR S DIR(0)="660.1,13",DIR("A")="RETURNED STATUS",DIR("B")="RETURNED" D ^DIR G:$$CK EXIT I X="" W !,"Enter the Returned Status or `^` to exit" G RETU
S RMPRSTAT=+Y
SER K DIR S DIR(0)="660.1,5R",DIR("A")="SERIAL NO." D ^DIR G:$$CK EXIT S RMPRSER=X
K DIR S DIR(0)="660.1,10",DIR("B")="TODAY" D ^DIR G:$$CK!(Y<0) EXIT S RMPRDRET=+Y
POS ;D WAIT^DICD H 1
K DD,DO S DIC="^RMPR(660.1,",DIC(0)="L",X=DT,DLAYGO=660.1 D FILE^DICN K DLAYGO G:Y<0 EXIT
S IEN=+Y,^RMPR(660.1,IEN,0)=DT_U_DFN_U_U_RMPRQTY_U_RMPRCST_U_$G(RMPRSER)_"^^^"_2_"^^"_RMPRDRET_"^^^"_RMPRSTAT_U_RMPR("STA"),$P(^(0),U,21)=RMPRITEM,DIK=DIC,DA=IEN D IX1^DIK
G EXIT
CK() Q $D(DUOUT)!($D(DTOUT))
EDT ;EDIT RETURNED/CONDEMNED ITEMS
D DIV4^RMPRSIT G:$D(X) EXIT S DIC("S")="I $P(^(0),U,15)=RMPR(""STA""),'$P(^(0),U,10),$P(^(0),U,11)",DLAYGO=660.1
S DIC="^RMPR(660.1,",DIC(0)="AEQMZ",DIC("W")="D DSP^RMPRRET9",DIC("A")="Select PATIENT: " D ^DIC G:+Y'>0 EXIT
L +^RMPR(660.1,+Y,0):1 I '$T W !!,$C(7),?5,"Someone else is Editing this entry" G EXIT
S ZA=+Y,ZA(1)=^RMPR(660.1,+Y,0),DA=+Y S DR=".01;5;@3;10R;I $P(^RMPR(660.1,DA,0),U,11)>$P(ZA(1),U) W !,$C(7),""Date of Return cannot be greater than the Posting Date"" S Y=""@3""",DIE=DIC D ^DIE G:$D(DTOUT)!($D(Y(0))) EX
I '$D(DA) S:$D(^RMPR(660,+$P(ZA(1),U,16),0)) $P(^RMPR(660,+$P(ZA(1),U,16),0),U,20)="" S:$D(^RMPR(667.3,+$P(ZA(1),U,22),0)) $P(^RMPR(667.3,$P(ZA(1),U,22),0),U,12)="" D:$P(ZA(1),U,12) INV G EX
I $G(^RMPR(660,+$P(^RMPR(660.1,+ZA,0),U,16),0))'="" S $P(^RMPR(660,$P(^RMPR(660.1,ZA,0),U,16),0),U,11)=$P(^RMPR(660.1,ZA,0),U,6)
EX L -^RMPR(660.1,ZA,0) G EXIT
DSP S ZA=^RMPR(660.1,+Y,0) W ?15,$S($P(ZA,U,3):$P(^PRC(441,$P(^RMPR(661,$P(ZA,U,3),0),U,1),0),U,2),1:$S($D(^RMPR(667.1,+$P(ZA,U,21),0)):$P(^(0),U,1),1:" "))," ",$P(ZA,U,6)," ",$E($P(^DPT($P(ZA,U,2),0),U,1),1,30) W ! Q
INV ;UPDATE INVENTORY
I '$P(^RMPR(669.9,RMPRSITE,0),U,3) Q
S PRCPPRIV=1 K PRCP("ITEM") S PRCP("QTY")=-1*$P(ZA(1),U,4),PRCP("ITEM")=$S($P(ZA(1),U,3):$S($D(^RMPR(661,+$P(ZA(1),U,3),0)):$P(^(0),U),1:0),1:0),PRCP("TYP")="A" I PRCP("ITEM") S PRCP("I")=$P(ZA(1),U,12) D ^PRCPUSA
I $D(PRCP("ITEM")) W !,$C(7),7,"Error encountered while posting this item to GIP. Please",!,"post this item manually.",!
Q
EXIT N RMPR,RMPRSITE D KILL^XUSCLEAN Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRRET9 2681 printed Dec 13, 2024@02:37:38 Page 2
RMPRRET9 ;PHX/RFM-RETURN ITEMS FROM FILE 667.1 ;8/29/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
EN KILL DIC
SET DIC=667.1
SET DIC(0)="AEQMZ"
SET DIC("A")="Select ITEM: "
DO ^DIC
if Y<0
GOTO EXIT
SET RMPRITEM=+Y
EN1 KILL DIR
SET DIR(0)="660.1,3"
SET DIR("A")="QTY"
SET DIR("B")=1
DO ^DIR
if $$CK
GOTO EXIT
IF X=""
WRITE !,"Enter `^` to exit"
GOTO EN1
+1 SET RMPRQTY=X
+2 KILL DIR
SET DIR(0)="660.1,4"
SET DIR("A")="UNIT COST"
SET DIR("B")=0
DO ^DIR
if $$CK
GOTO EXIT
SET (RMPRCOST,RMPRCST)=X
RETU KILL DIR
SET DIR(0)="660.1,13"
SET DIR("A")="RETURNED STATUS"
SET DIR("B")="RETURNED"
DO ^DIR
if $$CK
GOTO EXIT
IF X=""
WRITE !,"Enter the Returned Status or `^` to exit"
GOTO RETU
+1 SET RMPRSTAT=+Y
SER KILL DIR
SET DIR(0)="660.1,5R"
SET DIR("A")="SERIAL NO."
DO ^DIR
if $$CK
GOTO EXIT
SET RMPRSER=X
+1 KILL DIR
SET DIR(0)="660.1,10"
SET DIR("B")="TODAY"
DO ^DIR
if $$CK!(Y<0)
GOTO EXIT
SET RMPRDRET=+Y
POS ;D WAIT^DICD H 1
+1 KILL DD,DO
SET DIC="^RMPR(660.1,"
SET DIC(0)="L"
SET X=DT
SET DLAYGO=660.1
DO FILE^DICN
KILL DLAYGO
if Y<0
GOTO EXIT
+2 SET IEN=+Y
SET ^RMPR(660.1,IEN,0)=DT_U_DFN_U_U_RMPRQTY_U_RMPRCST_U_$GET(RMPRSER)_"^^^"_2_"^^"_RMPRDRET_"^^^"_RMPRSTAT_U_RMPR("STA")
SET $PIECE(^(0),U,21)=RMPRITEM
SET DIK=DIC
SET DA=IEN
DO IX1^DIK
+3 GOTO EXIT
CK() QUIT $DATA(DUOUT)!($DATA(DTOUT))
EDT ;EDIT RETURNED/CONDEMNED ITEMS
+1 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
SET DIC("S")="I $P(^(0),U,15)=RMPR(""STA""),'$P(^(0),U,10),$P(^(0),U,11)"
SET DLAYGO=660.1
+2 SET DIC="^RMPR(660.1,"
SET DIC(0)="AEQMZ"
SET DIC("W")="D DSP^RMPRRET9"
SET DIC("A")="Select PATIENT: "
DO ^DIC
if +Y'>0
GOTO EXIT
+3 LOCK +^RMPR(660.1,+Y,0):1
IF '$TEST
WRITE !!,$CHAR(7),?5,"Someone else is Editing this entry"
GOTO EXIT
+4 SET ZA=+Y
SET ZA(1)=^RMPR(660.1,+Y,0)
SET DA=+Y
SET DR=".01;5;@3;10R;I $P(^RMPR(660.1,DA,0),U,11)>$P(ZA(1),U) W !,$C(7),""Date of Return cannot be greater than the Posting Date"" S Y=""@3"""
SET DIE=DIC
DO ^DIE
if $DATA(DTOUT)!($DATA(Y(0)))
GOTO EX
+5 IF '$DATA(DA)
if $DATA(^RMPR(660,+$PIECE(ZA(1),U,16),0))
SET $PIECE(^RMPR(660,+$PIECE(ZA(1),U,16),0),U,20)=""
if $DATA(^RMPR(667.3,+$PIECE(ZA(1),U,22),0))
SET $PIECE(^RMPR(667.3,$PIECE(ZA(1),U,22),0),U,12)=""
if $PIECE(ZA(1),U,12)
DO INV
GOTO EX
+6 IF $GET(^RMPR(660,+$PIECE(^RMPR(660.1,+ZA,0),U,16),0))'=""
SET $PIECE(^RMPR(660,$PIECE(^RMPR(660.1,ZA,0),U,16),0),U,11)=$PIECE(^RMPR(660.1,ZA,0),U,6)
EX LOCK -^RMPR(660.1,ZA,0)
GOTO EXIT
DSP SET ZA=^RMPR(660.1,+Y,0)
WRITE ?15,$SELECT($PIECE(ZA,U,3):$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(ZA,U,3),0),U,1),0),U,2),1:$SELECT($DATA(^RMPR(667.1,+$PIECE(ZA,U,21),0)):$PIECE(^(0),U,1),1:" "))," ",$PIECE(ZA,U,6)," ",$EXTRACT($PIECE(^DPT($PIECE(ZA,U,2),0),U,1),1,30
)
WRITE !
QUIT
INV ;UPDATE INVENTORY
+1 IF '$PIECE(^RMPR(669.9,RMPRSITE,0),U,3)
QUIT
+2 SET PRCPPRIV=1
KILL PRCP("ITEM")
SET PRCP("QTY")=-1*$PIECE(ZA(1),U,4)
SET PRCP("ITEM")=$SELECT($PIECE(ZA(1),U,3):$SELECT($DATA(^RMPR(661,+$PIECE(ZA(1),U,3),0)):$PIECE(^(0),U),1:0),1:0)
SET PRCP("TYP")="A"
IF PRCP("ITEM")
SET PRCP("I")=$PIECE(ZA(1),U,12)
DO ^PRCPUSA
+3 IF $DATA(PRCP("ITEM"))
WRITE !,$CHAR(7),7,"Error encountered while posting this item to GIP. Please",!,"post this item manually.",!
+4 QUIT
EXIT NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
QUIT
