RMPRPIYF ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/2/02 07:27
;;3.0;PROSTHETICS;**61,117,139,154**;Feb 09, 1996;Build 6
; RVD #61 - phase III of PIP enhancement.
;
;Per VHA Directive 10-93-142, this routine should not be modified.
COST ;
S RMACNT=RMPRCOST*$P(R1(0),U,7),$P(R3("D"),U,16)=RMACNT,$P(R1(0),U,16)=RMACNT
;
DATE S:$P(R1(1),U,8) DIR("B")=$P(R1("D"),U,8) S DIR("A")="DATE OF SERVICE",DIR(0)="660,39" D ^DIR K DIR
G:X["^" CO^RMPRPIYE G:$D(DTOUT) EXIT I $P(R1(1),U,8)&(X="@") W !,"This field is mandatory!!!",! G DATE
I X="" W !,"This field is mandatory!!!",! G DATE
S $P(R1(1),U,8)=Y,Y=$P(R1(1),U,8) D DD^%DT S $P(R1("D"),U,8)=Y
;
REQ S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR G:$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT
I X["^" W !,"Jumping not allowed!" G REQ
I $P(R1(0),U,11)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,11)="" G LOT
S $P(R1(0),U,11)=X
;
LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24) D ^DIR G:$D(DUOUT) CO^RMPRPIYE
I X["^" W !,"Jumping not allowed!" G LOT
I $P(R1(0),U,24)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,24)="" G REMA
S $P(R1(0),U,24)=X
;
REMA K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18) D ^DIR G:$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT
I X["^" W !,"Jumping not allowed!" G REMA
I $P(R1(0),U,18)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,18)="" G CC
S $P(R1(0),U,18)=X
CC G CO^RMPRPIYE
;
POST ;POSTS EDITED TRANSACTION TO 660
W !,"Posting...."
K RMPR60,RMDTTIM,RMPR63
S RMPR60("IEN")=RMPRIEN,RMFLG=0
;RMPR60 -array of data fields for 660 file record.
D SET60^RMPRPIYE
;get 661.6 & 661.63 patient issue
S (RMPR6("IEN"),RMIEN6)=$P(R1(1),U,5)
I $G(RMIEN6),$D(^RMPR(661.6,RMIEN6,0)) D
.S RMDAT6=$G(^RMPR(661.6,RMIEN6,0))
.S RMIEN63=$O(^RMPR(661.63,"B",RMIEN6,0))
.I $G(RMIEN63),$D(^RMPR(661.63,RMIEN63,0)) D
..S RMDAT63=$G(^RMPR(661.63,RMIEN63,0)),RMPR63("IEN")=RMIEN63
..S (RMPRRET("DATE&TIME"),RMDTTIM)=$P(RMDAT63,U,6)
..S RMPRRET("QUANTITY")=$P(RMDAT63,U,12)
..S RMPRRET("HCPCS")=$P(RMDAT63,U,4)
..S RMPRRET("STATION")=$P(RMDAT63,U,7)
..S RMPRRET("ITEM")=$P(RMDAT63,U,5)
..S RMPRRET("VALUE")=$P(RMDAT63,U,10)
..S RMPRRET("UNIT")=$P(RMDAT63,U,11)
..S RMPRRET("VENDOR")=$P(RMDAT63,U,9)
..S RMPRRET("LOCATION")=$P(RMDAT63,U,8)
;only update 660 if no label scan and quantity the same.
I '$D(RMPR7I),($P(R1BCK(0),U,7)=RMPR60("QUANTITY")) D UP660 G PCE
;set update flags: 1=new item/diff barcode 2=only quantity changed.
I $G(RMDTTIM),$D(RMPR7I("DATE&TIME")),RMDTTIM'=RMPR7I("DATE&TIME") S RMFLG=1
I '$G(RMDTTIM),$D(RMPR7I("DATE&TIME")) S RMFLG=1
I $P(R1BCK(0),U,7)'=RMPR60("QUANTITY"),'$G(RMFLG) S RMFLG=2
;
API ;call API for 660, 661.7, 661.6, 661.63, 661.9
;
;file #660, 661.6, 661.7, 661.63, 661.9
I RMFLG=1 D UPDATE
I RMFLG=2 D QUAN
D UP660
I $G(RMPRERR) W !!,"*** ERROR in 2319 UPDATE, Please notify your IRM..IEN = ",$G(RMPR60("IEN")),!! H 3
;
PCE ;update PCE data
;
;end posting (edit 2319)
G EXIT
;
DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK
;** MOVED TO RMPRPIFD DUE TO SIZE CONSTRAINTS
G DEL1^RMPRPIFD
EXIT ;KILL VARIABLES AND EXIT ROUTINE
I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN)
K ^TMP($J) N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
;
UP660 ;update 660
S RMPR60("IEN")=RMPRIEN
S RMPRERR=0
S RMPRERR=$$UPD^RMPRPIX2(.RMPR60,.RMPR11I)
I $G(RMPRERR) W !,"*** Error in API RMPRPIX2, ERROR = ",RMPRERR,!,"*** Please inform your IRM !!",!
Q
;
UPDATE ;update the new entries AND delete old data
S RMNEWHC=RMPR11I("HCPCS")
S RMNEWIT=RMPR11I("ITEM")
I $G(RMPR6("IEN")) S RMPR60("IEN")=RMPR6("IEN") D
.S RMPRERR=$$UPD^RMPRPIX6(.RMPR60,.RMPR11I)
.I $G(RMPR63("IEN")) S RMPRERR=$$UPALL^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I)
.I '$G(RMPR63("IEN")) S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I)
I '$G(RMPR6("IEN")) D
.S RMPRERR=$$CRE^RMPRPIX6(.RMPR60,.RMPR11I)
.S (RMPR60("IEN6"),RMPR6("IEN"))=$G(RMPR60("IEN"))
.S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I)
;create a return stock record
S RMPR11I("HCPCS")=$G(RMPRRET("HCPCS"))
S RMPR11I("ITEM")=$G(RMPRRET("ITEM"))
S RMPRRET("SEQUENCE")=1
S RMPRRET("TRAN TYPE")=8
S RMPRRET("COMMENT")="STOCK ISSUE EDIT"
S RMPRRET("USER")=$G(DUZ)
I '$D(RMPRRET("QUANTITY")) S RMPRRET("QUANTITY")=RMPR60("QUANTITY")
I '$D(RMPRRET("VALUE")) S RMPRRET("VALUE")=RMPR60("COST")
I '$D(RMPRRET("UNIT")) S RMPRRET("UNIT")=RMPR60("UNIT")
I '$D(RMPRRET("VENDOR")) S RMPRRET("VENDOR")=RMPR60("VENDOR IEN")
I '$D(RMPRRET("LOCATION")) S RMPRRET("LOCATION")=$G(RMLO1)
I $D(RMPR11I) D I $G(RMPRERR) Q
.S RMPRERR=$$CRE^RMPRPIX6(.RMPRRET,.RMPR11I)
;return/update 661.7
D BACK Q:$G(RMPRERR)
S RMPR11I("HCPCS")=$G(RMNEWHC)
S RMPR11I("ITEM")=$G(RMNEWIT)
S RMPR7I("QUANTITY")=RMPR60("QUANTITY")
S RMPR7I("VALUE")=RMPR60("COST")
;update or create 661.7 entry
D UP7
S RMPR9("QUANTITY")=RMPR60("QUANTITY")
S RMPR9("VALUE")=RMPR60("COST")
;return 661.9 entry
I $D(RMDTTIM) D D UP9
.S RMPR11I("HCPCS")=RMPRRET("HCPCS")
.S RMPR11I("ITEM")=RMPRRET("ITEM")
.S RMPR9("QUANTITY")=$P(R1BCK(0),U,7)
.S RMPR9("VALUE")=$P(R1BCK(0),U,16)
;deduct the new HCPCS in 661.9
S RMPR11I("HCPCS")=RMNEWHC
S RMPR11I("ITEM")=RMPR60("ITEM")
S RMPR9("QUANTITY")=0-RMPR60("QUANTITY")
S RMPR9("VALUE")=0-RMPR60("COST")
D UP9
Q
;
BACK ; Bring back ITEM into current stock.
D NOW^%DTC
S (RMPR7R("STATION"),RMST1)=RMPR11I("STATION")
S (RMPR7R("HCPCS"),RMHC1)=RMPR11I("HCPCS")
S (RMPR7R("ITEM"),RMIT1)=RMPR11I("ITEM")
S (RMPR7R("LOCATION"),RMLO1)=RMPRRET("LOCATION")
S RMPR7R("VENDOR")=RMPRRET("VENDOR")
S RMPR7R("DATE&TIME")=% S:$G(RMPRRET("DATE&TIME"))'="" RMPR7R("DATE&TIME")=RMPRRET("DATE&TIME")
S RMPR7R("SEQUENCE")=1
S RMPR7R("QUANTITY")=RMPRRET("QUANTITY")
S RMPR7R("VALUE")=RMPRRET("VALUE")
S RMPR7R("UNIT")=$G(RMPRRET("UNIT"))
I $G(RMDTTIM),$D(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM)) D I RMPRERR S RMPRERR=71 Q
.S RMPR7R("IEN")=$O(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM,1,0))
.I '$G(RMPR7R("IEN")) S RMPRERR=1 Q
.S RMDA7=$G(^RMPR(661.7,RMPR7R("IEN"),0))
.S RMDAVAL=$P(RMDA7,U,8),RMDAQUA=$P(RMDA7,U,7)
.S RMPR7R("QUANTITY")=RMPR7R("QUANTITY")+RMDAQUA
.S RMPR7R("VALUE")=RMPR7R("VALUE")+RMDAVAL
.S RMPR7R("DATE&TIME")=RMDTTIM
.S RMPRERR=$$UPD^RMPRPIX7(.RMPR7R,.RMPR11I)
I $G(RMDTTIM),'$D(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM)) D
.S RMPR7R("DATE&TIME")=RMDTTIM
.S RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I)
I '$G(RMDTTIM) S RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I)
Q
;
UP6 ;now update file 661.6
S RMPR6("IEN")=$G(RMIEN6)
S RMPR6("QUANTITY")=$G(RMPR60("QUANTITY"))
S RMPR6("VALUE")=$G(RMPR60("COST"))
S RMPRERR=$$UPD^RMPRPIX6(.RMPR6,.RMPR11I)
Q
;
;
UP63 ;update file 661.63
S RMPR6("IEN")=$G(RMIEN6)
S RMPR6("LOCATION")=$G(RMPR5("IEN"))
S RMPR6("VENDOR")=$G(RMPR60("VENDOR IEN"))
S RMPR63("IEN")=$G(RMIEN63)
S RMPRERR=$$UPD^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I)
Q
;
UP7 ;file #661.7,deduct quantity
Q:'$G(RMPR11I("STATION"))
S RMPR7I("STATION IEN")=RMPR11I("STATION")
S RMPR7I("LOCATION IEN")=$G(RMPR5("IEN"))
S RMPR7I("HCPCS")=RMPR11I("HCPCS")
S RMPR7I("ITEM")=RMPR11I("ITEM")
S:$G(RMPRRET("DATE&TIME")) RMPR7I("DATE&TIME")=RMPRRET("DATE&TIME")
S RMPR7I("ISSUED QTY")=$G(RMPR7I("QUANTITY"))
S RMPR7I("ISSUED VALUE")=$G(RMPR7I("VALUE"))
S RMPRERR=$$FIFO^RMPRPIUB(.RMPR7I)
Q
UP9 ;file 661.9
D NOW^%DTC
S RMPR9("STA")=RMPR11I("STATION")
S RMPR9("HCP")=RMPR11I("HCPCS")
S RMPR9("ITE")=RMPR11I("ITEM")
S RMPR9("RDT")=$P(%,".",1)
S RMPR9("TQTY")=RMPR9("QUANTITY")
S RMPR9("TCST")=RMPR9("VALUE")
S RMPERR=$$UPCR^RMPRPIXJ(.RMPR9)
Q
;
QUAN ;only update quantity
;quit if not in PIP
Q:'$G(RMIEN6)!'$D(RMDTTIM)!'$D(RMPRRET)
S RMPR11I("STATION")=RMPRRET("STATION")
S RMPR11I("HCPCS")=RMPRRET("HCPCS")
S RMPR11I("ITEM")=RMPRRET("ITEM")
S RMPR5("IEN")=RMPRRET("LOCATION")
D UP6,UP63
I RMPR60("QUANTITY")>($P(R1BCK(0),U,7)) D D UP7,UP9
.S RMPR7I("QUANTITY")=RMPR60("QUANTITY")-($P(R1BCK(0),U,7))
.S RMPR7I("VALUE")=RMPR60("COST")-($P(R1BCK(0),U,16))
.S RMPR9("QUANTITY")=0-($G(RMPR60("QUANTITY"))-$P(R1BCK(0),U,7))
.S RMPR9("VALUE")=0-($G(RMPR60("COST"))-$P(R1BCK(0),U,16))
I RMPR60("QUANTITY")<($P(R1BCK(0),U,7)) D D BACK,UP9
.S RMPR9("QUANTITY")=$P(R1BCK(0),U,7)-$G(RMPR60("QUANTITY"))
.S RMPRRET("QUANTITY")=$P(R1BCK(0),U,7)-$G(RMPR60("QUANTITY"))
.S RMPR9("VALUE")=$P(R1BCK(0),U,16)-$G(RMPR60("COST"))
.S RMPRRET("VALUE")=$P(R1BCK(0),U,16)-$G(RMPR60("COST"))
Q
;
ERR W !!,"Error encountered while posting to PIP. Patient 10-2319 not deleted!! Please check with your Application Coordinator." H 5 G EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYF 8784 printed Sep 23, 2025@20:13:13 Page 2
RMPRPIYF ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/2/02 07:27
+1 ;;3.0;PROSTHETICS;**61,117,139,154**;Feb 09, 1996;Build 6
+2 ; RVD #61 - phase III of PIP enhancement.
+3 ;
+4 ;Per VHA Directive 10-93-142, this routine should not be modified.
COST ;
+1 SET RMACNT=RMPRCOST*$PIECE(R1(0),U,7)
SET $PIECE(R3("D"),U,16)=RMACNT
SET $PIECE(R1(0),U,16)=RMACNT
+2 ;
DATE if $PIECE(R1(1),U,8)
SET DIR("B")=$PIECE(R1("D"),U,8)
SET DIR("A")="DATE OF SERVICE"
SET DIR(0)="660,39"
DO ^DIR
KILL DIR
+1 if X["^"
GOTO CO^RMPRPIYE
if $DATA(DTOUT)
GOTO EXIT
IF $PIECE(R1(1),U,8)&(X="@")
WRITE !,"This field is mandatory!!!",!
GOTO DATE
+2 IF X=""
WRITE !,"This field is mandatory!!!",!
GOTO DATE
+3 SET $PIECE(R1(1),U,8)=Y
SET Y=$PIECE(R1(1),U,8)
DO DD^%DT
SET $PIECE(R1("D"),U,8)=Y
+4 ;
REQ SET DIR(0)="660,9"
if $PIECE(R1(0),U,11)'=""
SET DIR("B")=$PIECE(R1(0),U,11)
DO ^DIR
if $DATA(DUOUT)
GOTO CO^RMPRPIYE
if $DATA(DTOUT)
GOTO EXIT
+1 IF X["^"
WRITE !,"Jumping not allowed!"
GOTO REQ
+2 IF $PIECE(R1(0),U,11)'=""&(X="@")
WRITE !?5,"Deleted..."
HANG 1
SET $PIECE(R1(0),U,11)=""
GOTO LOT
+3 SET $PIECE(R1(0),U,11)=X
+4 ;
LOT KILL DIR
SET DIR(0)="660,21"
if $PIECE(R1(0),U,24)'=""
SET DIR("B")=$PIECE(R1(0),U,24)
DO ^DIR
if $DATA(DUOUT)
GOTO CO^RMPRPIYE
+1 IF X["^"
WRITE !,"Jumping not allowed!"
GOTO LOT
+2 IF $PIECE(R1(0),U,24)'=""&(X="@")
WRITE !?5,"Deleted..."
HANG 1
SET $PIECE(R1(0),U,24)=""
GOTO REMA
+3 SET $PIECE(R1(0),U,24)=X
+4 ;
REMA KILL DIR
SET DIR(0)="660,16"
if $PIECE(R1(0),U,18)'=""
SET DIR("B")=$PIECE(R1(0),U,18)
DO ^DIR
if $DATA(DUOUT)
GOTO CO^RMPRPIYE
if $DATA(DTOUT)
GOTO EXIT
+1 IF X["^"
WRITE !,"Jumping not allowed!"
GOTO REMA
+2 IF $PIECE(R1(0),U,18)'=""&(X="@")
WRITE !?5,"Deleted..."
HANG 1
SET $PIECE(R1(0),U,18)=""
GOTO CC
+3 SET $PIECE(R1(0),U,18)=X
CC GOTO CO^RMPRPIYE
+1 ;
POST ;POSTS EDITED TRANSACTION TO 660
+1 WRITE !,"Posting...."
+2 KILL RMPR60,RMDTTIM,RMPR63
+3 SET RMPR60("IEN")=RMPRIEN
SET RMFLG=0
+4 ;RMPR60 -array of data fields for 660 file record.
+5 DO SET60^RMPRPIYE
+6 ;get 661.6 & 661.63 patient issue
+7 SET (RMPR6("IEN"),RMIEN6)=$PIECE(R1(1),U,5)
+8 IF $GET(RMIEN6)
IF $DATA(^RMPR(661.6,RMIEN6,0))
Begin DoDot:1
+9 SET RMDAT6=$GET(^RMPR(661.6,RMIEN6,0))
+10 SET RMIEN63=$ORDER(^RMPR(661.63,"B",RMIEN6,0))
+11 IF $GET(RMIEN63)
IF $DATA(^RMPR(661.63,RMIEN63,0))
Begin DoDot:2
+12 SET RMDAT63=$GET(^RMPR(661.63,RMIEN63,0))
SET RMPR63("IEN")=RMIEN63
+13 SET (RMPRRET("DATE&TIME"),RMDTTIM)=$PIECE(RMDAT63,U,6)
+14 SET RMPRRET("QUANTITY")=$PIECE(RMDAT63,U,12)
+15 SET RMPRRET("HCPCS")=$PIECE(RMDAT63,U,4)
+16 SET RMPRRET("STATION")=$PIECE(RMDAT63,U,7)
+17 SET RMPRRET("ITEM")=$PIECE(RMDAT63,U,5)
+18 SET RMPRRET("VALUE")=$PIECE(RMDAT63,U,10)
+19 SET RMPRRET("UNIT")=$PIECE(RMDAT63,U,11)
+20 SET RMPRRET("VENDOR")=$PIECE(RMDAT63,U,9)
+21 SET RMPRRET("LOCATION")=$PIECE(RMDAT63,U,8)
End DoDot:2
End DoDot:1
+22 ;only update 660 if no label scan and quantity the same.
+23 IF '$DATA(RMPR7I)
IF ($PIECE(R1BCK(0),U,7)=RMPR60("QUANTITY"))
DO UP660
GOTO PCE
+24 ;set update flags: 1=new item/diff barcode 2=only quantity changed.
+25 IF $GET(RMDTTIM)
IF $DATA(RMPR7I("DATE&TIME"))
IF RMDTTIM'=RMPR7I("DATE&TIME")
SET RMFLG=1
+26 IF '$GET(RMDTTIM)
IF $DATA(RMPR7I("DATE&TIME"))
SET RMFLG=1
+27 IF $PIECE(R1BCK(0),U,7)'=RMPR60("QUANTITY")
IF '$GET(RMFLG)
SET RMFLG=2
+28 ;
API ;call API for 660, 661.7, 661.6, 661.63, 661.9
+1 ;
+2 ;file #660, 661.6, 661.7, 661.63, 661.9
+3 IF RMFLG=1
DO UPDATE
+4 IF RMFLG=2
DO QUAN
+5 DO UP660
+6 IF $GET(RMPRERR)
WRITE !!,"*** ERROR in 2319 UPDATE, Please notify your IRM..IEN = ",$GET(RMPR60("IEN")),!!
HANG 3
+7 ;
PCE ;update PCE data
+1 ;
+2 ;end posting (edit 2319)
+3 GOTO EXIT
+4 ;
DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK
+1 ;** MOVED TO RMPRPIFD DUE TO SIZE CONSTRAINTS
+2 GOTO DEL1^RMPRPIFD
EXIT ;KILL VARIABLES AND EXIT ROUTINE
+1 IF $GET(RMPRIEN)
IF $DATA(^RMPR(660,RMPRIEN))
LOCK -^RMPR(660,RMPRIEN)
+2 KILL ^TMP($JOB)
NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+3 QUIT
+4 ;
UP660 ;update 660
+1 SET RMPR60("IEN")=RMPRIEN
+2 SET RMPRERR=0
+3 SET RMPRERR=$$UPD^RMPRPIX2(.RMPR60,.RMPR11I)
+4 IF $GET(RMPRERR)
WRITE !,"*** Error in API RMPRPIX2, ERROR = ",RMPRERR,!,"*** Please inform your IRM !!",!
+5 QUIT
+6 ;
UPDATE ;update the new entries AND delete old data
+1 SET RMNEWHC=RMPR11I("HCPCS")
+2 SET RMNEWIT=RMPR11I("ITEM")
+3 IF $GET(RMPR6("IEN"))
SET RMPR60("IEN")=RMPR6("IEN")
Begin DoDot:1
+4 SET RMPRERR=$$UPD^RMPRPIX6(.RMPR60,.RMPR11I)
+5 IF $GET(RMPR63("IEN"))
SET RMPRERR=$$UPALL^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I)
+6 IF '$GET(RMPR63("IEN"))
SET RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I)
End DoDot:1
+7 IF '$GET(RMPR6("IEN"))
Begin DoDot:1
+8 SET RMPRERR=$$CRE^RMPRPIX6(.RMPR60,.RMPR11I)
+9 SET (RMPR60("IEN6"),RMPR6("IEN"))=$GET(RMPR60("IEN"))
+10 SET RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I)
End DoDot:1
+11 ;create a return stock record
+12 SET RMPR11I("HCPCS")=$GET(RMPRRET("HCPCS"))
+13 SET RMPR11I("ITEM")=$GET(RMPRRET("ITEM"))
+14 SET RMPRRET("SEQUENCE")=1
+15 SET RMPRRET("TRAN TYPE")=8
+16 SET RMPRRET("COMMENT")="STOCK ISSUE EDIT"
+17 SET RMPRRET("USER")=$GET(DUZ)
+18 IF '$DATA(RMPRRET("QUANTITY"))
SET RMPRRET("QUANTITY")=RMPR60("QUANTITY")
+19 IF '$DATA(RMPRRET("VALUE"))
SET RMPRRET("VALUE")=RMPR60("COST")
+20 IF '$DATA(RMPRRET("UNIT"))
SET RMPRRET("UNIT")=RMPR60("UNIT")
+21 IF '$DATA(RMPRRET("VENDOR"))
SET RMPRRET("VENDOR")=RMPR60("VENDOR IEN")
+22 IF '$DATA(RMPRRET("LOCATION"))
SET RMPRRET("LOCATION")=$GET(RMLO1)
+23 IF $DATA(RMPR11I)
Begin DoDot:1
+24 SET RMPRERR=$$CRE^RMPRPIX6(.RMPRRET,.RMPR11I)
End DoDot:1
IF $GET(RMPRERR)
QUIT
+25 ;return/update 661.7
+26 DO BACK
if $GET(RMPRERR)
QUIT
+27 SET RMPR11I("HCPCS")=$GET(RMNEWHC)
+28 SET RMPR11I("ITEM")=$GET(RMNEWIT)
+29 SET RMPR7I("QUANTITY")=RMPR60("QUANTITY")
+30 SET RMPR7I("VALUE")=RMPR60("COST")
+31 ;update or create 661.7 entry
+32 DO UP7
+33 SET RMPR9("QUANTITY")=RMPR60("QUANTITY")
+34 SET RMPR9("VALUE")=RMPR60("COST")
+35 ;return 661.9 entry
+36 IF $DATA(RMDTTIM)
Begin DoDot:1
+37 SET RMPR11I("HCPCS")=RMPRRET("HCPCS")
+38 SET RMPR11I("ITEM")=RMPRRET("ITEM")
+39 SET RMPR9("QUANTITY")=$PIECE(R1BCK(0),U,7)
+40 SET RMPR9("VALUE")=$PIECE(R1BCK(0),U,16)
End DoDot:1
DO UP9
+41 ;deduct the new HCPCS in 661.9
+42 SET RMPR11I("HCPCS")=RMNEWHC
+43 SET RMPR11I("ITEM")=RMPR60("ITEM")
+44 SET RMPR9("QUANTITY")=0-RMPR60("QUANTITY")
+45 SET RMPR9("VALUE")=0-RMPR60("COST")
+46 DO UP9
+47 QUIT
+48 ;
BACK ; Bring back ITEM into current stock.
+1 DO NOW^%DTC
+2 SET (RMPR7R("STATION"),RMST1)=RMPR11I("STATION")
+3 SET (RMPR7R("HCPCS"),RMHC1)=RMPR11I("HCPCS")
+4 SET (RMPR7R("ITEM"),RMIT1)=RMPR11I("ITEM")
+5 SET (RMPR7R("LOCATION"),RMLO1)=RMPRRET("LOCATION")
+6 SET RMPR7R("VENDOR")=RMPRRET("VENDOR")
+7 SET RMPR7R("DATE&TIME")=%
if $GET(RMPRRET("DATE&TIME"))'=""
SET RMPR7R("DATE&TIME")=RMPRRET("DATE&TIME")
+8 SET RMPR7R("SEQUENCE")=1
+9 SET RMPR7R("QUANTITY")=RMPRRET("QUANTITY")
+10 SET RMPR7R("VALUE")=RMPRRET("VALUE")
+11 SET RMPR7R("UNIT")=$GET(RMPRRET("UNIT"))
+12 IF $GET(RMDTTIM)
IF $DATA(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM))
Begin DoDot:1
+13 SET RMPR7R("IEN")=$ORDER(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM,1,0))
+14 IF '$GET(RMPR7R("IEN"))
SET RMPRERR=1
QUIT
+15 SET RMDA7=$GET(^RMPR(661.7,RMPR7R("IEN"),0))
+16 SET RMDAVAL=$PIECE(RMDA7,U,8)
SET RMDAQUA=$PIECE(RMDA7,U,7)
+17 SET RMPR7R("QUANTITY")=RMPR7R("QUANTITY")+RMDAQUA
+18 SET RMPR7R("VALUE")=RMPR7R("VALUE")+RMDAVAL
+19 SET RMPR7R("DATE&TIME")=RMDTTIM
+20 SET RMPRERR=$$UPD^RMPRPIX7(.RMPR7R,.RMPR11I)
End DoDot:1
IF RMPRERR
SET RMPRERR=71
QUIT
+21 IF $GET(RMDTTIM)
IF '$DATA(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM))
Begin DoDot:1
+22 SET RMPR7R("DATE&TIME")=RMDTTIM
+23 SET RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I)
End DoDot:1
+24 IF '$GET(RMDTTIM)
SET RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I)
+25 QUIT
+26 ;
UP6 ;now update file 661.6
+1 SET RMPR6("IEN")=$GET(RMIEN6)
+2 SET RMPR6("QUANTITY")=$GET(RMPR60("QUANTITY"))
+3 SET RMPR6("VALUE")=$GET(RMPR60("COST"))
+4 SET RMPRERR=$$UPD^RMPRPIX6(.RMPR6,.RMPR11I)
+5 QUIT
+6 ;
+7 ;
UP63 ;update file 661.63
+1 SET RMPR6("IEN")=$GET(RMIEN6)
+2 SET RMPR6("LOCATION")=$GET(RMPR5("IEN"))
+3 SET RMPR6("VENDOR")=$GET(RMPR60("VENDOR IEN"))
+4 SET RMPR63("IEN")=$GET(RMIEN63)
+5 SET RMPRERR=$$UPD^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I)
+6 QUIT
+7 ;
UP7 ;file #661.7,deduct quantity
+1 if '$GET(RMPR11I("STATION"))
QUIT
+2 SET RMPR7I("STATION IEN")=RMPR11I("STATION")
+3 SET RMPR7I("LOCATION IEN")=$GET(RMPR5("IEN"))
+4 SET RMPR7I("HCPCS")=RMPR11I("HCPCS")
+5 SET RMPR7I("ITEM")=RMPR11I("ITEM")
+6 if $GET(RMPRRET("DATE&TIME"))
SET RMPR7I("DATE&TIME")=RMPRRET("DATE&TIME")
+7 SET RMPR7I("ISSUED QTY")=$GET(RMPR7I("QUANTITY"))
+8 SET RMPR7I("ISSUED VALUE")=$GET(RMPR7I("VALUE"))
+9 SET RMPRERR=$$FIFO^RMPRPIUB(.RMPR7I)
+10 QUIT
UP9 ;file 661.9
+1 DO NOW^%DTC
+2 SET RMPR9("STA")=RMPR11I("STATION")
+3 SET RMPR9("HCP")=RMPR11I("HCPCS")
+4 SET RMPR9("ITE")=RMPR11I("ITEM")
+5 SET RMPR9("RDT")=$PIECE(%,".",1)
+6 SET RMPR9("TQTY")=RMPR9("QUANTITY")
+7 SET RMPR9("TCST")=RMPR9("VALUE")
+8 SET RMPERR=$$UPCR^RMPRPIXJ(.RMPR9)
+9 QUIT
+10 ;
QUAN ;only update quantity
+1 ;quit if not in PIP
+2 if '$GET(RMIEN6)!'$DATA(RMDTTIM)!'$DATA(RMPRRET)
QUIT
+3 SET RMPR11I("STATION")=RMPRRET("STATION")
+4 SET RMPR11I("HCPCS")=RMPRRET("HCPCS")
+5 SET RMPR11I("ITEM")=RMPRRET("ITEM")
+6 SET RMPR5("IEN")=RMPRRET("LOCATION")
+7 DO UP6
DO UP63
+8 IF RMPR60("QUANTITY")>($PIECE(R1BCK(0),U,7))
Begin DoDot:1
+9 SET RMPR7I("QUANTITY")=RMPR60("QUANTITY")-($PIECE(R1BCK(0),U,7))
+10 SET RMPR7I("VALUE")=RMPR60("COST")-($PIECE(R1BCK(0),U,16))
+11 SET RMPR9("QUANTITY")=0-($GET(RMPR60("QUANTITY"))-$PIECE(R1BCK(0),U,7))
+12 SET RMPR9("VALUE")=0-($GET(RMPR60("COST"))-$PIECE(R1BCK(0),U,16))
End DoDot:1
DO UP7
DO UP9
+13 IF RMPR60("QUANTITY")<($PIECE(R1BCK(0),U,7))
Begin DoDot:1
+14 SET RMPR9("QUANTITY")=$PIECE(R1BCK(0),U,7)-$GET(RMPR60("QUANTITY"))
+15 SET RMPRRET("QUANTITY")=$PIECE(R1BCK(0),U,7)-$GET(RMPR60("QUANTITY"))
+16 SET RMPR9("VALUE")=$PIECE(R1BCK(0),U,16)-$GET(RMPR60("COST"))
+17 SET RMPRRET("VALUE")=$PIECE(R1BCK(0),U,16)-$GET(RMPR60("COST"))
End DoDot:1
DO BACK
DO UP9
+18 QUIT
+19 ;
ERR WRITE !!,"Error encountered while posting to PIP. Patient 10-2319 not deleted!! Please check with your Application Coordinator."
HANG 5
GOTO EXIT
