RMPRSTL.m

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 ---RMPRSTL   6131     printed  Mar 13, 2025@21:42:48                                                                                                                                                                                                     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