- 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 Apr 23, 2025@18:52:08 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
