RMPRPIYI ;HINCIO/RVD-ISSUE FROM STOCK ;6/16/04 08:18
;;3.0;PROSTHETICS;**61,128**;Feb 09, 1996
; RVD #61 - phase IIIa of PIP
;
S RMPR699("AMIS GROUPER")=""
S (RMPRG,RMPRF)="" D HOME^%ZIS W @IOF
I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EXIT^RMPRPIYJ
I $D(RMPRDFN),$D(^TMP($J,"RMPRPCE")) D LINK^RMPRS
I $D(RMPRDFN),'$D(^TMP($J,"RMPRPCE")) G EXIT^RMPRPIYJ
K ^TMP($J,"RMPRPCE")
D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT^RMPRPIYJ
VIEW ;
N RMPRBAC1,RMDES,RMITQTY
S (RSTCK,RMPRBAC1)=1 D ^RMPRPAT K RMPRBAC1
I $D(RMPRKILL)!($D(DTOUT)) W $C(7),!,"Deleted..." G EXIT^RMPRPIYJ
S CK="W:$D(DUOUT) @IOF,!!!?28,$C(7),""Deleted..."" G EXIT^RMPRPIYJ"
S CK2="W @IOF,!!!?28,$C(7),""Deleted..."" H 2"
S CK1="W $C(7),!,""Timed-Out, Deleted..."" G EXIT^RMPRPIYJ"
S R3("D")=""
;
RES ;ENTRY POINT TO ADD ADDITIONAL ITEMS FOR ISSUE FROM STOCK
Q:$G(RMPRDFN)<1
K DA,DD,DIC,PRC,X,Y,RMSO,RMQTY,RMDAHC,RMLACO,RMITDA,RMHCOLD,RMPRVEN
K RMPR11IS,RMPR5SA,RMPR6SA
S (R1(1),R1(0),R3("D"),R4("D"),R1("AM"),RMPRI("AMS"),R1("D"),RMLOC)=""
S RMLODES=""
S (RMLOCOLD,R1,RMIT,RMHCNEW,RMHCOLD,RMITDESC,RMITIEN,R1(2))="",REDIT=0
S R1(0)=DT_U_RMPRDFN_U_DT,$P(R1(0),U,10)=RMPR("STA"),$P(R1(0),U,27)=DUZ
;
1 ;ENTRY POINT TO EDIT ITEM ON ISSUE FROM STOCK
S (RMHCNEW,RMHCOLD)=$P(R1(1),U,4),RMLOCOLD=RMLOC,RMITOLD=RMIT
K RQUIT S RMHCFLG=0
W @IOF,!?30,RMPRNAM,!
W:$G(REDIT) !!,"Editing a Stock Item!!!"
W:'$G(REDIT) !!,"Entering a Stock Item!!!"
;
TRAN ;TYPE OF TRANSACTION
W !
;S DIR(0)="660,2"
K DIR
S:$P(R1(0),U,4)?.E&($P(R3("D"),U,4)'="") DIR("B")=$P(R3("D"),U,4)
S DIR(0)="SO^I:INITIAL ISSUE;X:REPAIR;R:REPLACE;S:SPARE"
S DIR("A")="TYPE OF TRANSACTION"
D ^DIR
I (Y=""),($P(R3("D"),U,4)="") G ^RMPRPIYI
I $P(R3("D"),U,4)'=""&($D(DUOUT)) G LIST^RMPRPIYJ
I $D(DTOUT) X CK1 Q
I $D(DUOUT) G ^RMPRPIYI
S $P(R1(0),U,4)=Y K DIR
S $P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
;
PCAT ;
S DIR(0)="660,62" S:$P(R1("AM"),U,3)?1N.N DIR("B")=$P(R4("D"),U,3)
D ^DIR I $P(R1("AM"),U,3)'=""&($D(DUOUT)) G LIST^RMPRPIYJ
I $D(DTOUT) X CK1 Q
I $D(DUOUT) X CK2 G ^RMPRPIYI
S $P(R1("AM"),U,3)=Y,$P(R4("D"),U,3)=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"") K DIR
I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2
;
SPE I Y=4 S DIR(0)="660,63" S:$P(R1("AM"),U,4)?1N.N DIR("B")=$P(R4("D"),U,4) D ^DIR I $D(DTOUT) X CK1 Q
I $G(REDIT)&($D(DUOUT)) G LIST^RMPRPIYJ
I $D(DUOUT) X CK2 G ^RMPRPIYI
I $P(R1("AM"),U,3)=4 S $P(R1("AM"),U,4)=Y,$P(R4("D"),U,4)=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
;
; prompt for and scan barcode label
; if scan is successful then all vars will be set and go to Edit prompt
2 I $G(REDIT),$D(RMPR11I) M RMPR11IS=RMPR11I,RMPR5SA=RMPR5,RMPR6SA=RMPR6
W ! D SCAN^RMPRPIYS
I $P(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P")) G LIST^RMPRPIYJ
I (RMPREXC="^"),$G(REDIT) G LIST^RMPRPIYJ
I RMPREXC="^" X CK2 G ^RMPRPIYI
I RMPREXC="P" G PCAT
I RMPREXC="T" X CK1 Q
I RMPRBARC="",$G(REDIT) M RMPR11I=RMPR11IS,RMPR5=RMPR5SA,RMPR6=RMPR6SA G ^RMPRPIYJ
I RMPRBARC="" G 2
D HCPCS3^RMPRPIY1
G ^RMPRPIYJ
HCPCS ;HCPCS code
S (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
S RMPRHCPC="" I $D(RMHCPC) S RMPRHCPC=RMHCPC
D HCPCS^RMPRPIY1(RMPR("STA"),RMPRHCPC,.RMPR1,.RMPR11,.RMPREXC)
I RMPREXC="T" X CK1 Q
I RMPREXC="P" G 2
I $G(REDIT),(RMPREXC="^") G LIST^RMPRPIYJ
I RMPREXC="^" X CK2 G ^RMPRPIYI
W !
S RMITNO=RMPR11("ITEM")
S RMHCPC=RMPR1("HCPCS")
S (RMHCNEW,RMDAHC,RMHCDA)=RMPR1("IEN")
S RDESC=RMPR1("SHORT DESC")
K RMPR11I
S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
I RMPR11I("ITEM MASTER IEN")="" D G 2
. W !,"This item is not associated with an IFCAP Item.",!
. W "Please use the Edit Inventory option before trying to issue this item."
. W !
. Q
I '$D(^RMPR(661.7,"XSHIDS",RMPR("STA"),RMHCPC,RMITNO)) D G 2
. W !,"This HCPCS-ITEM is not associated with any Location."
. W !,"Please update your inventory!!.",!
. W !
. Q
S $P(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
S $P(R1(0),U,8)=$G(RMPR11("UNIT"))
S $P(R3("D"),U,6)=RMPR11("ITEM MASTER")
;check for location if multiple then ask for LOCATION
S RMLCNT=0
F I=0:0 S I=$O(^RMPR(661.7,"XSLHIDS",RMPR("STA"),I)) Q:I'>0 I $D(^(I,RMHCPC)) S RMLCNT=RMLCNT+1,(RMPR5("IEN"),RMLOC)=I
I RMLCNT<2 G ITEM
;
ASKLOC ;ask for location
K DIC,Y,X,RQUIT,RMPR5
S DZ="??",D="B"
S DIC("S")="I ($P(^RMPR(661.5,+Y,0),U,2)=RMPR(""STA"")),($P(^(0),U,4)=""A""),($D(^RMPR(661.7,""XSLHIDS"",RMPR(""STA""),+Y,RMHCPC,RMITNO)))"
S:RMLOCOLD'="" DIC("B")=RMLOCOLD
S DIC="^RMPR(661.5,",DIC(0)="AEQMN"
S DIC("A")="Enter Pros Location: " D MIX^DIC1
I $G(REDIT)&$D(DUOUT) G LIST^RMPRPIYJ
I $D(DUOUT) G 2^RMPRPIYI
I $D(DTOUT) X CK1 Q
I X="" W !,"This is a mandatory field!!!",! G ASKLOC
S RMLOC=+Y
S RMPR5("IEN")=RMLOC
G:'$D(^RMPR(661.5,RMLOC,0)) ASKLOC
;
ITEM ;PSAS Item details.
K RMPR11I
S RMCHCK=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
I RMCHCK W !,"*** ERROR IN API RMPRPIX1 !!!!",! X CK1 Q
S RMIT=RMPR11("HCPCS-ITEM")
S $P(R1(2),U,1)=RMIT S $P(R1(2),U,2)=RMPR11("DESCRIPTION")
I RMDAHC=RMHCOLD S DIR("B")=$G(RMIT)
;
;call stock record in 661.7
S RMR("STATION IEN")=RMPR("STA")
S RMR("LOCATION IEN")=RMLOC
S RMR("HCPCS")=RMHCPC
S RMR("ITEM")=RMPR11("ITEM")
S RMR("VENDOR IEN")=$P(R1(0),U,9)
S RMCHCK=$$STOCK^RMPRPIUE(.RMR)
I RMCHCK W !,"*** ERROR IN API RMPRPIUE !!!!",! X CK1 Q
S (RMITDES,RMDES)=RMIT K DIC("B"),DIC("S")
S RMUBA=RMR("QOH")
I RMUBA<1 D LOWBA G 2
;
I $D(RMLOC),$D(RMHCDA) S RMSO=RMPR11I("SOURCE")
I $D(RMSO),RMSO="" D MESSO G 2
S:$D(RMSO) $P(R1(0),U,14)=RMSO
S $P(R3("D"),U,14)=$S(RMSO="C":"COMMERCIAL",RMSO="V":"VA",1:"")
I $P(R1(1),U,4)'="",$D(DUOUT) G LIST^RMPRPIYJ
;I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G 2
I $G(RMLOC),$G(RMHCDA) S RMPRUCST=RMR("UNIT COST")
I '$G(RMPRUCST) D MESSI G 2
S:$G(REDIT) $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7),$P(R3("D"),U,16)=RMPRUCST*$P(R1(0),U,7)
K DIC
;
CPT ;ask for CPT Modifier
D CPT^RMPRPIYS(RMDAHC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660)
I RMPREXC="T" X CK1 Q
I RMPREXC="^" G 2
I RMPREXC="P" G 2
;
VEN ;vendor
;call routine RMPRPIYV for vendor from file 661.6.
S $P(R1(1),U,4)=RMDAHC,$P(R1(0),U,22)=$P(^RMPR(661.1,RMDAHC,0),U,4)
;If there is only one vendor use it as a default.
K RMPRVEN
S RMERR=$$STOCK^RMPRPIUV(.RMR,.RMPRVEN)
I RMERR W !,"*** ERROR IN API RMPRPIUV !!!!",! X CK1 Q
I RMPRVEN=1 S DIC("B")=$O(RMPRVEN(0))
I $G(REDIT) S DIC("B")=$P(R1(0),U,9)
S DIC(0)="AEQM"
S DIC("A")="VENDOR: ",DIC=440,DIC("S")="I $D(RMPRVEN(+Y))"
D ^DIC I $P(R3("D"),U,9)'=""&$D(DUOUT) G LIST^RMPRPIYJ
I $D(DTOUT) X CK1 Q
I $D(DUOUT) G 2
I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G VEN
S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIC,Y,X
G ^RMPRPIYJ
;
;
MESSI ;print message if COST is not defined in the inventory (661.5)
S:'$D(RMIT) RMIT=""
W !!,"***ITEM COST is not define @:"
W !," PSAS Item = ",RMIT
W !," Location = ",$P($G(^RMPR(661.5,RMLOC,0)),U,1)
W !,"***Fix your inventory or use a different PSAS ITEM!!",!!
Q
;
MESSO ;print message if SOURCE is not defined in the inventory (661.11)
W !!,"***PSAS ITEM has no SOURCE at this location..."
W !,"***Fix your inventory or use a different PSAS ITEM!!",!!
Q
;
INACT ;print message if HCPCS is inactive.
W !!,"*** You have selected an INACTIVE HCPCS..."
W !,"*** Please REMOVE this HCPCS from inventory..."
W !,"*** And use a different HCPCS!!!",!
Q
;
LOWBA ;print message if inventory balance is low.
S:'$D(RMUBA) RMUBA="" S:'$D(RMIT) RMIT=""
W !!,"*** PSAS Item ",RMIT," balance is = ",RMUBA
W !,"*** You are unable to use this PSAS ITEM..."
W !,"*** Please use a different HCPCS or PSAS Item !!!!",!
Q
;
LKP ;print a message if PSAS HCPCS not in PIP or invalid HCPCS.
Q:'$G(RMF)!(X=" ")
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
K RX
I $D(RSTCK),$D(^RMPR(661.7,"XSHIDS",RMPR("STA"),X)) S RX=1
I '$D(RSTCK),$D(^RMPR(661.11,"ASHD",RMPR("STA"),X)) S RX=1
I '$G(RX),$D(^RMPR(661.1,"B",X)) D EN^DDIOL("*** Only PSAS HCPCS in PIP can be accessed. Please verify your Location and PSAS HCPCS!!","","!!")
K RX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYI 8371 printed Nov 22, 2024@17:47:06 Page 2
RMPRPIYI ;HINCIO/RVD-ISSUE FROM STOCK ;6/16/04 08:18
+1 ;;3.0;PROSTHETICS;**61,128**;Feb 09, 1996
+2 ; RVD #61 - phase IIIa of PIP
+3 ;
+4 SET RMPR699("AMIS GROUPER")=""
+5 SET (RMPRG,RMPRF)=""
DO HOME^%ZIS
WRITE @IOF
+6 IF '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT^RMPRPIYJ
+7 IF $DATA(RMPRDFN)
IF $DATA(^TMP($JOB,"RMPRPCE"))
DO LINK^RMPRS
+8 IF $DATA(RMPRDFN)
IF '$DATA(^TMP($JOB,"RMPRPCE"))
GOTO EXIT^RMPRPIYJ
+9 KILL ^TMP($JOB,"RMPRPCE")
+10 DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
GOTO EXIT^RMPRPIYJ
VIEW ;
+1 NEW RMPRBAC1,RMDES,RMITQTY
+2 SET (RSTCK,RMPRBAC1)=1
DO ^RMPRPAT
KILL RMPRBAC1
+3 IF $DATA(RMPRKILL)!($DATA(DTOUT))
WRITE $CHAR(7),!,"Deleted..."
GOTO EXIT^RMPRPIYJ
+4 SET CK="W:$D(DUOUT) @IOF,!!!?28,$C(7),""Deleted..."" G EXIT^RMPRPIYJ"
+5 SET CK2="W @IOF,!!!?28,$C(7),""Deleted..."" H 2"
+6 SET CK1="W $C(7),!,""Timed-Out, Deleted..."" G EXIT^RMPRPIYJ"
+7 SET R3("D")=""
+8 ;
RES ;ENTRY POINT TO ADD ADDITIONAL ITEMS FOR ISSUE FROM STOCK
+1 if $GET(RMPRDFN)<1
QUIT
+2 KILL DA,DD,DIC,PRC,X,Y,RMSO,RMQTY,RMDAHC,RMLACO,RMITDA,RMHCOLD,RMPRVEN
+3 KILL RMPR11IS,RMPR5SA,RMPR6SA
+4 SET (R1(1),R1(0),R3("D"),R4("D"),R1("AM"),RMPRI("AMS"),R1("D"),RMLOC)=""
+5 SET RMLODES=""
+6 SET (RMLOCOLD,R1,RMIT,RMHCNEW,RMHCOLD,RMITDESC,RMITIEN,R1(2))=""
SET REDIT=0
+7 SET R1(0)=DT_U_RMPRDFN_U_DT
SET $PIECE(R1(0),U,10)=RMPR("STA")
SET $PIECE(R1(0),U,27)=DUZ
+8 ;
1 ;ENTRY POINT TO EDIT ITEM ON ISSUE FROM STOCK
+1 SET (RMHCNEW,RMHCOLD)=$PIECE(R1(1),U,4)
SET RMLOCOLD=RMLOC
SET RMITOLD=RMIT
+2 KILL RQUIT
SET RMHCFLG=0
+3 WRITE @IOF,!?30,RMPRNAM,!
+4 if $GET(REDIT)
WRITE !!,"Editing a Stock Item!!!"
+5 if '$GET(REDIT)
WRITE !!,"Entering a Stock Item!!!"
+6 ;
TRAN ;TYPE OF TRANSACTION
+1 WRITE !
+2 ;S DIR(0)="660,2"
+3 KILL DIR
+4 if $PIECE(R1(0),U,4)?.E&($PIECE(R3("D"),U,4)'="")
SET DIR("B")=$PIECE(R3("D"),U,4)
+5 SET DIR(0)="SO^I:INITIAL ISSUE;X:REPAIR;R:REPLACE;S:SPARE"
+6 SET DIR("A")="TYPE OF TRANSACTION"
+7 DO ^DIR
+8 IF (Y="")
IF ($PIECE(R3("D"),U,4)="")
GOTO ^RMPRPIYI
+9 IF $PIECE(R3("D"),U,4)'=""&($DATA(DUOUT))
GOTO LIST^RMPRPIYJ
+10 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+11 IF $DATA(DUOUT)
GOTO ^RMPRPIYI
+12 SET $PIECE(R1(0),U,4)=Y
KILL DIR
+13 SET $PIECE(R3("D"),U,4)=$SELECT(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
+14 ;
PCAT ;
+1 SET DIR(0)="660,62"
if $PIECE(R1("AM"),U,3)?1N.N
SET DIR("B")=$PIECE(R4("D"),U,3)
+2 DO ^DIR
IF $PIECE(R1("AM"),U,3)'=""&($DATA(DUOUT))
GOTO LIST^RMPRPIYJ
+3 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+4 IF $DATA(DUOUT)
XECUTE CK2
GOTO ^RMPRPIYI
+5 SET $PIECE(R1("AM"),U,3)=Y
SET $PIECE(R4("D"),U,3)=$SELECT(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
KILL DIR
+6 IF Y<4
SET $PIECE(R1("AM"),U,4)=""
SET $PIECE(R4("D"),U,4)=""
GOTO 2
+7 ;
SPE IF Y=4
SET DIR(0)="660,63"
if $PIECE(R1("AM"),U,4)?1N.N
SET DIR("B")=$PIECE(R4("D"),U,4)
DO ^DIR
IF $DATA(DTOUT)
XECUTE CK1
QUIT
+1 IF $GET(REDIT)&($DATA(DUOUT))
GOTO LIST^RMPRPIYJ
+2 IF $DATA(DUOUT)
XECUTE CK2
GOTO ^RMPRPIYI
+3 IF $PIECE(R1("AM"),U,3)=4
SET $PIECE(R1("AM"),U,4)=Y
SET $PIECE(R4("D"),U,4)=$SELECT(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
+4 ;
+5 ; prompt for and scan barcode label
+6 ; if scan is successful then all vars will be set and go to Edit prompt
2 IF $GET(REDIT)
IF $DATA(RMPR11I)
MERGE RMPR11IS=RMPR11I,RMPR5SA=RMPR5,RMPR6SA=RMPR6
+1 WRITE !
DO SCAN^RMPRPIYS
+2 IF $PIECE(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P"))
GOTO LIST^RMPRPIYJ
+3 IF (RMPREXC="^")
IF $GET(REDIT)
GOTO LIST^RMPRPIYJ
+4 IF RMPREXC="^"
XECUTE CK2
GOTO ^RMPRPIYI
+5 IF RMPREXC="P"
GOTO PCAT
+6 IF RMPREXC="T"
XECUTE CK1
QUIT
+7 IF RMPRBARC=""
IF $GET(REDIT)
MERGE RMPR11I=RMPR11IS,RMPR5=RMPR5SA,RMPR6=RMPR6SA
GOTO ^RMPRPIYJ
+8 IF RMPRBARC=""
GOTO 2
+9 DO HCPCS3^RMPRPIY1
+10 GOTO ^RMPRPIYJ
HCPCS ;HCPCS code
+1 SET (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
+2 SET RMPRHCPC=""
IF $DATA(RMHCPC)
SET RMPRHCPC=RMHCPC
+3 DO HCPCS^RMPRPIY1(RMPR("STA"),RMPRHCPC,.RMPR1,.RMPR11,.RMPREXC)
+4 IF RMPREXC="T"
XECUTE CK1
QUIT
+5 IF RMPREXC="P"
GOTO 2
+6 IF $GET(REDIT)
IF (RMPREXC="^")
GOTO LIST^RMPRPIYJ
+7 IF RMPREXC="^"
XECUTE CK2
GOTO ^RMPRPIYI
+8 WRITE !
+9 SET RMITNO=RMPR11("ITEM")
+10 SET RMHCPC=RMPR1("HCPCS")
+11 SET (RMHCNEW,RMDAHC,RMHCDA)=RMPR1("IEN")
+12 SET RDESC=RMPR1("SHORT DESC")
+13 KILL RMPR11I
+14 SET RMPRERR=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
+15 IF RMPR11I("ITEM MASTER IEN")=""
Begin DoDot:1
+16 WRITE !,"This item is not associated with an IFCAP Item.",!
+17 WRITE "Please use the Edit Inventory option before trying to issue this item."
+18 WRITE !
+19 QUIT
End DoDot:1
GOTO 2
+20 IF '$DATA(^RMPR(661.7,"XSHIDS",RMPR("STA"),RMHCPC,RMITNO))
Begin DoDot:1
+21 WRITE !,"This HCPCS-ITEM is not associated with any Location."
+22 WRITE !,"Please update your inventory!!.",!
+23 WRITE !
+24 QUIT
End DoDot:1
GOTO 2
+25 SET $PIECE(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
+26 SET $PIECE(R1(0),U,8)=$GET(RMPR11("UNIT"))
+27 SET $PIECE(R3("D"),U,6)=RMPR11("ITEM MASTER")
+28 ;check for location if multiple then ask for LOCATION
+29 SET RMLCNT=0
+30 FOR I=0:0
SET I=$ORDER(^RMPR(661.7,"XSLHIDS",RMPR("STA"),I))
if I'>0
QUIT
IF $DATA(^(I,RMHCPC))
SET RMLCNT=RMLCNT+1
SET (RMPR5("IEN"),RMLOC)=I
+31 IF RMLCNT<2
GOTO ITEM
+32 ;
ASKLOC ;ask for location
+1 KILL DIC,Y,X,RQUIT,RMPR5
+2 SET DZ="??"
SET D="B"
+3 SET DIC("S")="I ($P(^RMPR(661.5,+Y,0),U,2)=RMPR(""STA"")),($P(^(0),U,4)=""A""),($D(^RMPR(661.7,""XSLHIDS"",RMPR(""STA""),+Y,RMHCPC,RMITNO)))"
+4 if RMLOCOLD'=""
SET DIC("B")=RMLOCOLD
+5 SET DIC="^RMPR(661.5,"
SET DIC(0)="AEQMN"
+6 SET DIC("A")="Enter Pros Location: "
DO MIX^DIC1
+7 IF $GET(REDIT)&$DATA(DUOUT)
GOTO LIST^RMPRPIYJ
+8 IF $DATA(DUOUT)
GOTO 2^RMPRPIYI
+9 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+10 IF X=""
WRITE !,"This is a mandatory field!!!",!
GOTO ASKLOC
+11 SET RMLOC=+Y
+12 SET RMPR5("IEN")=RMLOC
+13 if '$DATA(^RMPR(661.5,RMLOC,0))
GOTO ASKLOC
+14 ;
ITEM ;PSAS Item details.
+1 KILL RMPR11I
+2 SET RMCHCK=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
+3 IF RMCHCK
WRITE !,"*** ERROR IN API RMPRPIX1 !!!!",!
XECUTE CK1
QUIT
+4 SET RMIT=RMPR11("HCPCS-ITEM")
+5 SET $PIECE(R1(2),U,1)=RMIT
SET $PIECE(R1(2),U,2)=RMPR11("DESCRIPTION")
+6 IF RMDAHC=RMHCOLD
SET DIR("B")=$GET(RMIT)
+7 ;
+8 ;call stock record in 661.7
+9 SET RMR("STATION IEN")=RMPR("STA")
+10 SET RMR("LOCATION IEN")=RMLOC
+11 SET RMR("HCPCS")=RMHCPC
+12 SET RMR("ITEM")=RMPR11("ITEM")
+13 SET RMR("VENDOR IEN")=$PIECE(R1(0),U,9)
+14 SET RMCHCK=$$STOCK^RMPRPIUE(.RMR)
+15 IF RMCHCK
WRITE !,"*** ERROR IN API RMPRPIUE !!!!",!
XECUTE CK1
QUIT
+16 SET (RMITDES,RMDES)=RMIT
KILL DIC("B"),DIC("S")
+17 SET RMUBA=RMR("QOH")
+18 IF RMUBA<1
DO LOWBA
GOTO 2
+19 ;
+20 IF $DATA(RMLOC)
IF $DATA(RMHCDA)
SET RMSO=RMPR11I("SOURCE")
+21 IF $DATA(RMSO)
IF RMSO=""
DO MESSO
GOTO 2
+22 if $DATA(RMSO)
SET $PIECE(R1(0),U,14)=RMSO
+23 SET $PIECE(R3("D"),U,14)=$SELECT(RMSO="C":"COMMERCIAL",RMSO="V":"VA",1:"")
+24 IF $PIECE(R1(1),U,4)'=""
IF $DATA(DUOUT)
GOTO LIST^RMPRPIYJ
+25 ;I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G 2
+26 IF $GET(RMLOC)
IF $GET(RMHCDA)
SET RMPRUCST=RMR("UNIT COST")
+27 IF '$GET(RMPRUCST)
DO MESSI
GOTO 2
+28 if $GET(REDIT)
SET $PIECE(R1(0),U,16)=RMPRUCST*$PIECE(R1(0),U,7)
SET $PIECE(R3("D"),U,16)=RMPRUCST*$PIECE(R1(0),U,7)
+29 KILL DIC
+30 ;
CPT ;ask for CPT Modifier
+1 DO CPT^RMPRPIYS(RMDAHC_"^"_$PIECE(R1(0),U,4)_"^"_$PIECE(R1(0),U,14)_"^"_660)
+2 IF RMPREXC="T"
XECUTE CK1
QUIT
+3 IF RMPREXC="^"
GOTO 2
+4 IF RMPREXC="P"
GOTO 2
+5 ;
VEN ;vendor
+1 ;call routine RMPRPIYV for vendor from file 661.6.
+2 SET $PIECE(R1(1),U,4)=RMDAHC
SET $PIECE(R1(0),U,22)=$PIECE(^RMPR(661.1,RMDAHC,0),U,4)
+3 ;If there is only one vendor use it as a default.
+4 KILL RMPRVEN
+5 SET RMERR=$$STOCK^RMPRPIUV(.RMR,.RMPRVEN)
+6 IF RMERR
WRITE !,"*** ERROR IN API RMPRPIUV !!!!",!
XECUTE CK1
QUIT
+7 IF RMPRVEN=1
SET DIC("B")=$ORDER(RMPRVEN(0))
+8 IF $GET(REDIT)
SET DIC("B")=$PIECE(R1(0),U,9)
+9 SET DIC(0)="AEQM"
+10 SET DIC("A")="VENDOR: "
SET DIC=440
SET DIC("S")="I $D(RMPRVEN(+Y))"
+11 DO ^DIC
IF $PIECE(R3("D"),U,9)'=""&$DATA(DUOUT)
GOTO LIST^RMPRPIYJ
+12 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+13 IF $DATA(DUOUT)
GOTO 2
+14 IF +Y'>0
WRITE !!,?5,$CHAR(7),"This is a required response. Enter '^' to exit",!
GOTO VEN
+15 SET $PIECE(R1(0),U,9)=+Y
SET $PIECE(R3("D"),U,9)=$PIECE(Y,U,2)
KILL DIC,Y,X
+16 GOTO ^RMPRPIYJ
+17 ;
+18 ;
MESSI ;print message if COST is not defined in the inventory (661.5)
+1 if '$DATA(RMIT)
SET RMIT=""
+2 WRITE !!,"***ITEM COST is not define @:"
+3 WRITE !," PSAS Item = ",RMIT
+4 WRITE !," Location = ",$PIECE($GET(^RMPR(661.5,RMLOC,0)),U,1)
+5 WRITE !,"***Fix your inventory or use a different PSAS ITEM!!",!!
+6 QUIT
+7 ;
MESSO ;print message if SOURCE is not defined in the inventory (661.11)
+1 WRITE !!,"***PSAS ITEM has no SOURCE at this location..."
+2 WRITE !,"***Fix your inventory or use a different PSAS ITEM!!",!!
+3 QUIT
+4 ;
INACT ;print message if HCPCS is inactive.
+1 WRITE !!,"*** You have selected an INACTIVE HCPCS..."
+2 WRITE !,"*** Please REMOVE this HCPCS from inventory..."
+3 WRITE !,"*** And use a different HCPCS!!!",!
+4 QUIT
+5 ;
LOWBA ;print message if inventory balance is low.
+1 if '$DATA(RMUBA)
SET RMUBA=""
if '$DATA(RMIT)
SET RMIT=""
+2 WRITE !!,"*** PSAS Item ",RMIT," balance is = ",RMUBA
+3 WRITE !,"*** You are unable to use this PSAS ITEM..."
+4 WRITE !,"*** Please use a different HCPCS or PSAS Item !!!!",!
+5 QUIT
+6 ;
LKP ;print a message if PSAS HCPCS not in PIP or invalid HCPCS.
+1 if '$GET(RMF)!(X=" ")
QUIT
+2 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 KILL RX
+4 IF $DATA(RSTCK)
IF $DATA(^RMPR(661.7,"XSHIDS",RMPR("STA"),X))
SET RX=1
+5 IF '$DATA(RSTCK)
IF $DATA(^RMPR(661.11,"ASHD",RMPR("STA"),X))
SET RX=1
+6 IF '$GET(RX)
IF $DATA(^RMPR(661.1,"B",X))
DO EN^DDIOL("*** Only PSAS HCPCS in PIP can be accessed. Please verify your Location and PSAS HCPCS!!","","!!")
+7 KILL RX
+8 QUIT
