RMPRSTL ;PHX/RFM,RVD-ISSUE FROM STOCK ;8/29/1994
;;3.0;PROSTHETICS;**14,28,33,41,178**;Feb 09, 1996;Build 14
;modified for cpt modifier
;p178 JAH/CEP OIFO updates for GIP and Point of Use Supply Stations
; DBIA #6374
;Per VHA Directive 10-93-142, this routine should not be modified.
NEX K DIR,Y,X I $G(RMPRGIP) G INV1
I $P(R1(0),U,14)="C" S DIR(0)="667.3,3",DIR("A")="UNIT COST"
;DISPLAY DEFAULT UNIT COST FOR NON-GIP ISSUES
;
I S RO=0 I $O(^PRC(441,$P(R3("D"),U,6),2,RO))'="" D
.Q:'$D(^PRC(441,$P(R3("D"),U,6),2,$P(R1(0),U,9),0))
.S (RMPRUCST,DIR("B"))=$J($P(^PRC(441,$P(R3("D"),U,6),2,$P(R1(0),U,9),0),U,2)/$S($P(^(0),U,10)]"":$P(^(0),U,10),1:1),9,2),(RMPRUCST,DIR("B"))=$$STRIP^XLFSTR(RMPRUCST," ")
S:+$P(R1(0),U,16) DIR("B")=$P(R1(0),U,16)/$P(R1(0),U,7)
I $G(RMLOC),$G(RMHCDA),$G(RMITDA) S (DIR("B"),RMPRUCST)=$P($G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0)),U,10) G:RMPRUCST>0 QTY
I $P(R1(0),U,14)="C" D ^DIR K DIR I +$P(R1(0),U,16)&($D(DUOUT)) G LIST
I $D(DUOUT) X CK Q
I $D(DTOUT) X CK1 Q
I $P(R1(0),U,14)="C" S RMPRUCST=Y S:$P(R1(0),U,16) $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7) I $D(DIRUT) X CK Q
I $P(R1(0),U,6)="C" S $P(R1(0),U,16)=Y,$P(R3("D"),U,16)=Y
I $P(R1(0),U,14)="V" S $P(R1(0),U,16)=0,RMPRUCST=0
QTY K DIR,Y S DIR(0)="660,5" S:$P(R1(0),U,7) DIR("B")=$P(R1(0),U,7) D ^DIR I $P(R1(0),U,7)'=""&$D(DUOUT) G LIST
I $D(DTOUT) X CK1 Q
I $D(DIRUT) X CK Q
S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRUCST K DIR
;SET DELIVERY DATE to today
;
DATE ;K DIR,Y S DIR(0)="660,10" S:$P(R3("D"),U,12)'="" DIR("B")=$P(R3("D"),U,12) D ^DIR K DIR G:X["^" LIST I $D(DTOUT) X CK1 Q
;W:$P(R1(0),U,12)&(X="@") $C(7),!?5,"Deleted..." I $P(R1(0),U,12)=""&(X="@") W ?17,"??" G DATE
S $P(R1(0),U,12)=DT,Y=DT D DD^%DT S $P(R3("D"),U,12)=Y
LI S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR I $D(DTOUT) X CK1 Q
G:$D(DUOUT) LIST
I X["^" W !,"Jumping not allowed" G LI
I $P(R1(0),U,11)'=""&(X="@") S $P(R1(0),U,11)="" W $C(7),!?5,"Deleted..." H 1 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 I $D(DTOUT) X CK1 Q
G:$D(DUOUT) LIST
I X["^" W !,"Jumping not allowed" G LOT
I $P(R1(0),U,24)'=""&(X="@") S $P(R1(0),U,24)="" W $C(7),!?5,"Deleted..." H 1 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 I $D(DTOUT) X CK1 Q
G:$D(DUOUT) LIST
I X["^" W !,"Jumping not allowed" G REMA
I $P(R1(0),U,18)'=""&(X="@") S $P(R1(0),U,18)="" W $C(7),!?5,"Deleted..." H 1 G LIST
S $P(R1(0),U,18)=X
LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA
I $G(RMLOC),$G(RMITDA) S RMINVF="PROS INVENTORY"
D:$D(RMCPT) CHK^RMPRED5
K DIR D ^RMPRST2
S DIR("A")="Do you wish to POST this entry",DIR("B")="YES",DIR(0)="Y",DIR("?")="Answer `YES` to post the transaction, `NO` to delete/edit the transaction" D ^DIR K DIR G:Y=1 POST G:Y=0 DEA I $D(DIRUT) X CK Q
DEA S DIR("A")="Do you wish to Delete this entry",DIR("?")="Answer `YES` to delete the transaction, `NO` to edit the transaction, `^` to exit",DIR("B")="NO",DIR(0)="Y"
D ^DIR K DIR I Y=1 W $C(7),?50,"Deleted..." H 2 G RES^RMPRSTK
I Y=0 S REDIT=1 G 1^RMPRSTK
G:$D(DUOUT) LIST I $D(DIRUT) X CK Q
;
; Patch 178 Use PIP for inventory--OR--Update Inventory in GIP --OR--if Inventory
; Point is linked to a POU cabinet, then do not call the GIP API to update inventory,
; since POU sends HL7 to update the inventory.
;
; PRCPUSA DBIA #10085--Routine: PRCPUSA
;
POST ;
I $G(RMPRGIP),'$$POU(PRCP("I")) D I $D(PRCP("ITEM")) D ERR1 N A S A=$$ASK^RMPRSTK(1) G RES^RMPRSTK
. S PRCP("QTY")=$P(R1(0),U,7)*-1,PRCP("TYP")="R" D ^PRCPUSA
;
I RMPRG'="" G GGC
L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
GGC S $P(RMPRI("AMS"),U,1)=RMPRG,RMSER=$P(R1(0),U,11)
;update inventory balance
S RMHCPC=$P(R1(1),U,4)
I $P(^RMPR(661.1,RMHCPC,0),U,9)=1&($D(RMLOC)) S RMQTY=$P(R1(0),U,7) D ADD^RMPR5NU1 I '$D(RMLOC) X CK Q
S:$D(RMLOC) $P(R1(1),U,2)=RDESC,$P(R1(0),U,13)=11,$P(R1(1),U,5)=RM6612
;
;create 2319
K Y,DD,DO,DA S DIC="^RMPR(660,",DIC(0)="L",X=DT,DLAYGO=660 D FILE^DICN K DLAYGO I Y'>0 W !,"** Error posting to 2319...entry deleted..." G RES^RMPRSTK
S ^RMPR(660,+Y,0)=R1(0),^(1)=R1(1),^("AM")=R1("AM"),^("AMS")=RMPRI("AMS") S:$G(RMPRGIP)=1 $P(^(1),U,3)=$G(RMPRIP)
;
; This sets up data for the AMIS Grouper Field in 668. ^TMP is
; checked later and will be later if appropriate.
;
S ^TMP($J,"RMPRPCE",660,+Y)=RMPRI("AMS")
;
I $D(RMLOC) MERGE ^RMPR(660,+Y,"DES")=^RMPR(661.1,RMDAHC,2) S $P(^RMPR(660,+Y,"DES",0),U,2)=""
S DIK="^RMPR(660,",DA=+Y D IX1^DIK K DIC
G RES^RMPRSTK
;
EXIT ;EXIT FOR STOCK ISSUES
K ^TMP($J,"RMRP CAUTION")
N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
ERR1 ;
W !!,"Error encountered while posting to GIP. Inventory Issue did not post"
W !,"Patient 10-2319 not updated!! Please check with your Application Coordinator."
Q
ERR W !,"PLEASE EDIT GIP IN YOUR SITE PARAMETER FILE!" G EXIT
INV1 I $P(R1(0),U,14)="C" S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7)
G QTY
POU(INVPIEN) ; Return true if POU, false otherwise
; DBIA 6374 to read IFCAP GIP files
;JAH p178--check IFCAP Generic Inventory Package (GIP)
; to determine if a Point of Use (POU) Automated Supply Cabinet is
; linked to the secondary inventory point.
; SSPROPTR- supply station provider pointer
; SSPROID - supply station provider ID
;
; Test Loop to Run through Inventory Point File to see if any are linked to POU Cab
; This tests this function
;
; S X=0 F S X=$O(^PRCP(445,X)) Q:X'>0 S Y=$$POU^RMPRSTL(X) W !,$S(Y=0:"NON-",1:""),"POU"
;
; $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" supply cabinet linked to inventory point
;
N POU S POU=0
;
N SSPROPTR S SSPROPTR=$$GET1^DIQ(445,INVPIEN,22,"I")
;
; Unit test code:
; N SPRONAM S SSPRONAM=$$GET1^DIQ(445,INVPIEN,22) W !,"Point of Use Automated Supply: ",SSPRONAM
;
Q:SSPROPTR'>0 POU
;
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSTL 6131 printed Oct 16, 2024@18:38:33 Page 2
RMPRSTL ;PHX/RFM,RVD-ISSUE FROM STOCK ;8/29/1994
+1 ;;3.0;PROSTHETICS;**14,28,33,41,178**;Feb 09, 1996;Build 14
+2 ;modified for cpt modifier
+3 ;p178 JAH/CEP OIFO updates for GIP and Point of Use Supply Stations
+4 ; DBIA #6374
+5 ;Per VHA Directive 10-93-142, this routine should not be modified.
NEX KILL DIR,Y,X
IF $GET(RMPRGIP)
GOTO INV1
+1 IF $PIECE(R1(0),U,14)="C"
SET DIR(0)="667.3,3"
SET DIR("A")="UNIT COST"
+2 ;DISPLAY DEFAULT UNIT COST FOR NON-GIP ISSUES
+3 ;
+4 IF $TEST
SET RO=0
IF $ORDER(^PRC(441,$PIECE(R3("D"),U,6),2,RO))'=""
Begin DoDot:1
+5 if '$DATA(^PRC(441,$PIECE(R3("D"),U,6),2,$PIECE(R1(0),U,9),0))
QUIT
+6 SET (RMPRUCST,DIR("B"))=$JUSTIFY($PIECE(^PRC(441,$PIECE(R3("D"),U,6),2,$PIECE(R1(0),U,9),0),U,2)/$SELECT($PIECE(^(0),U,10)]"":$PIECE(^(0),U,10),1:1),9,2)
SET (RMPRUCST,DIR("B"))=$$STRIP^XLFSTR(RMPRUCST," ")
End DoDot:1
+7 if +$PIECE(R1(0),U,16)
SET DIR("B")=$PIECE(R1(0),U,16)/$PIECE(R1(0),U,7)
+8 IF $GET(RMLOC)
IF $GET(RMHCDA)
IF $GET(RMITDA)
SET (DIR("B"),RMPRUCST)=$PIECE($GET(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0)),U,10)
if RMPRUCST>0
GOTO QTY
+9 IF $PIECE(R1(0),U,14)="C"
DO ^DIR
KILL DIR
IF +$PIECE(R1(0),U,16)&($DATA(DUOUT))
GOTO LIST
+10 IF $DATA(DUOUT)
XECUTE CK
QUIT
+11 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+12 IF $PIECE(R1(0),U,14)="C"
SET RMPRUCST=Y
if $PIECE(R1(0),U,16)
SET $PIECE(R1(0),U,16)=RMPRUCST*$PIECE(R1(0),U,7)
IF $DATA(DIRUT)
XECUTE CK
QUIT
+13 IF $PIECE(R1(0),U,6)="C"
SET $PIECE(R1(0),U,16)=Y
SET $PIECE(R3("D"),U,16)=Y
+14 IF $PIECE(R1(0),U,14)="V"
SET $PIECE(R1(0),U,16)=0
SET RMPRUCST=0
QTY KILL DIR,Y
SET DIR(0)="660,5"
if $PIECE(R1(0),U,7)
SET DIR("B")=$PIECE(R1(0),U,7)
DO ^DIR
IF $PIECE(R1(0),U,7)'=""&$DATA(DUOUT)
GOTO LIST
+1 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+2 IF $DATA(DIRUT)
XECUTE CK
QUIT
+3 SET $PIECE(R1(0),U,7)=Y
SET $PIECE(R1(0),U,16)=Y*RMPRUCST
KILL DIR
+4 ;SET DELIVERY DATE to today
+5 ;
DATE ;K DIR,Y S DIR(0)="660,10" S:$P(R3("D"),U,12)'="" DIR("B")=$P(R3("D"),U,12) D ^DIR K DIR G:X["^" LIST I $D(DTOUT) X CK1 Q
+1 ;W:$P(R1(0),U,12)&(X="@") $C(7),!?5,"Deleted..." I $P(R1(0),U,12)=""&(X="@") W ?17,"??" G DATE
+2 SET $PIECE(R1(0),U,12)=DT
SET Y=DT
DO DD^%DT
SET $PIECE(R3("D"),U,12)=Y
LI SET DIR(0)="660,9"
if $PIECE(R1(0),U,11)'=""
SET DIR("B")=$PIECE(R1(0),U,11)
DO ^DIR
IF $DATA(DTOUT)
XECUTE CK1
QUIT
+1 if $DATA(DUOUT)
GOTO LIST
+2 IF X["^"
WRITE !,"Jumping not allowed"
GOTO LI
+3 IF $PIECE(R1(0),U,11)'=""&(X="@")
SET $PIECE(R1(0),U,11)=""
WRITE $CHAR(7),!?5,"Deleted..."
HANG 1
GOTO LOT
+4 SET $PIECE(R1(0),U,11)=X
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(DTOUT)
XECUTE CK1
QUIT
+1 if $DATA(DUOUT)
GOTO LIST
+2 IF X["^"
WRITE !,"Jumping not allowed"
GOTO LOT
+3 IF $PIECE(R1(0),U,24)'=""&(X="@")
SET $PIECE(R1(0),U,24)=""
WRITE $CHAR(7),!?5,"Deleted..."
HANG 1
GOTO REMA
+4 SET $PIECE(R1(0),U,24)=X
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(DTOUT)
XECUTE CK1
QUIT
+1 if $DATA(DUOUT)
GOTO LIST
+2 IF X["^"
WRITE !,"Jumping not allowed"
GOTO REMA
+3 IF $PIECE(R1(0),U,18)'=""&(X="@")
SET $PIECE(R1(0),U,18)=""
WRITE $CHAR(7),!?5,"Deleted..."
HANG 1
GOTO LIST
+4 SET $PIECE(R1(0),U,18)=X
LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA
+1 IF $GET(RMLOC)
IF $GET(RMITDA)
SET RMINVF="PROS INVENTORY"
+2 if $DATA(RMCPT)
DO CHK^RMPRED5
+3 KILL DIR
DO ^RMPRST2
+4 SET DIR("A")="Do you wish to POST this entry"
SET DIR("B")="YES"
SET DIR(0)="Y"
SET DIR("?")="Answer `YES` to post the transaction, `NO` to delete/edit the transaction"
DO ^DIR
KILL DIR
if Y=1
GOTO POST
if Y=0
GOTO DEA
IF $DATA(DIRUT)
XECUTE CK
QUIT
DEA SET DIR("A")="Do you wish to Delete this entry"
SET DIR("?")="Answer `YES` to delete the transaction, `NO` to edit the transaction, `^` to exit"
SET DIR("B")="NO"
SET DIR(0)="Y"
+1 DO ^DIR
KILL DIR
IF Y=1
WRITE $CHAR(7),?50,"Deleted..."
HANG 2
GOTO RES^RMPRSTK
+2 IF Y=0
SET REDIT=1
GOTO 1^RMPRSTK
+3 if $DATA(DUOUT)
GOTO LIST
IF $DATA(DIRUT)
XECUTE CK
QUIT
+4 ;
+5 ; Patch 178 Use PIP for inventory--OR--Update Inventory in GIP --OR--if Inventory
+6 ; Point is linked to a POU cabinet, then do not call the GIP API to update inventory,
+7 ; since POU sends HL7 to update the inventory.
+8 ;
+9 ; PRCPUSA DBIA #10085--Routine: PRCPUSA
+10 ;
POST ;
+1 IF $GET(RMPRGIP)
IF '$$POU(PRCP("I"))
Begin DoDot:1
+2 SET PRCP("QTY")=$PIECE(R1(0),U,7)*-1
SET PRCP("TYP")="R"
DO ^PRCPUSA
End DoDot:1
IF $DATA(PRCP("ITEM"))
DO ERR1
NEW A
SET A=$$ASK^RMPRSTK(1)
GOTO RES^RMPRSTK
+3 ;
+4 IF RMPRG'=""
GOTO GGC
+5 LOCK +^RMPR(669.9,RMPRSITE,0):999
IF $TEST=0
SET RMPRG=DT_99
GOTO GGC
+6 SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
SET RMPRG=RMPRG-1
SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG
LOCK -^RMPR(669.9,RMPRSITE,0)
GGC SET $PIECE(RMPRI("AMS"),U,1)=RMPRG
SET RMSER=$PIECE(R1(0),U,11)
+1 ;update inventory balance
+2 SET RMHCPC=$PIECE(R1(1),U,4)
+3 IF $PIECE(^RMPR(661.1,RMHCPC,0),U,9)=1&($DATA(RMLOC))
SET RMQTY=$PIECE(R1(0),U,7)
DO ADD^RMPR5NU1
IF '$DATA(RMLOC)
XECUTE CK
QUIT
+4 if $DATA(RMLOC)
SET $PIECE(R1(1),U,2)=RDESC
SET $PIECE(R1(0),U,13)=11
SET $PIECE(R1(1),U,5)=RM6612
+5 ;
+6 ;create 2319
+7 KILL Y,DD,DO,DA
SET DIC="^RMPR(660,"
SET DIC(0)="L"
SET X=DT
SET DLAYGO=660
DO FILE^DICN
KILL DLAYGO
IF Y'>0
WRITE !,"** Error posting to 2319...entry deleted..."
GOTO RES^RMPRSTK
+8 SET ^RMPR(660,+Y,0)=R1(0)
SET ^(1)=R1(1)
SET ^("AM")=R1("AM")
SET ^("AMS")=RMPRI("AMS")
if $GET(RMPRGIP)=1
SET $PIECE(^(1),U,3)=$GET(RMPRIP)
+9 ;
+10 ; This sets up data for the AMIS Grouper Field in 668. ^TMP is
+11 ; checked later and will be later if appropriate.
+12 ;
+13 SET ^TMP($JOB,"RMPRPCE",660,+Y)=RMPRI("AMS")
+14 ;
+15 IF $DATA(RMLOC)
MERGE ^RMPR(660,+Y,"DES")=^RMPR(661.1,RMDAHC,2)
SET $PIECE(^RMPR(660,+Y,"DES",0),U,2)=""
+16 SET DIK="^RMPR(660,"
SET DA=+Y
DO IX1^DIK
KILL DIC
+17 GOTO RES^RMPRSTK
+18 ;
EXIT ;EXIT FOR STOCK ISSUES
+1 KILL ^TMP($JOB,"RMRP CAUTION")
+2 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+3 QUIT
ERR1 ;
+1 WRITE !!,"Error encountered while posting to GIP. Inventory Issue did not post"
+2 WRITE !,"Patient 10-2319 not updated!! Please check with your Application Coordinator."
+3 QUIT
ERR WRITE !,"PLEASE EDIT GIP IN YOUR SITE PARAMETER FILE!"
GOTO EXIT
INV1 IF $PIECE(R1(0),U,14)="C"
SET $PIECE(R1(0),U,16)=RMPRUCST*$PIECE(R1(0),U,7)
+1 GOTO QTY
POU(INVPIEN) ; Return true if POU, false otherwise
+1 ; DBIA 6374 to read IFCAP GIP files
+2 ;JAH p178--check IFCAP Generic Inventory Package (GIP)
+3 ; to determine if a Point of Use (POU) Automated Supply Cabinet is
+4 ; linked to the secondary inventory point.
+5 ; SSPROPTR- supply station provider pointer
+6 ; SSPROID - supply station provider ID
+7 ;
+8 ; Test Loop to Run through Inventory Point File to see if any are linked to POU Cab
+9 ; This tests this function
+10 ;
+11 ; S X=0 F S X=$O(^PRCP(445,X)) Q:X'>0 S Y=$$POU^RMPRSTL(X) W !,$S(Y=0:"NON-",1:""),"POU"
+12 ;
+13 ; $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" supply cabinet linked to inventory point
+14 ;
+15 NEW POU
SET POU=0
+16 ;
+17 NEW SSPROPTR
SET SSPROPTR=$$GET1^DIQ(445,INVPIEN,22,"I")
+18 ;
+19 ; Unit test code:
+20 ; N SPRONAM S SSPRONAM=$$GET1^DIQ(445,INVPIEN,22) W !,"Point of Use Automated Supply: ",SSPRONAM
+21 ;
+22 if SSPROPTR'>0
QUIT POU
+23 ;
+24 QUIT 1
