RMPRSTI ;HINCIO/RVD-ISSUE FROM STOCK ;11/6/00
;;3.0;PROSTHETICS;**53,62**;Feb 09, 1996
;
;RVD patch #62 - modified for PCE interface
;
S (RMPRG,RMPRF,RMENTSUS)="" D HOME^%ZIS W @IOF
I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EXIT^RMPRSTE
I $D(RMPRDFN),$D(^TMP($J,"RMPRPCE")) D LINK^RMPRS
K ^TMP($J,"RMPRPCE")
W ! D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT^RMPRSTE
VIEW ;
N RMPRBAC1,RMDES
S RMPRBAC1=1 D ^RMPRPAT K RMPRBAC1
I $D(RMPRKILL)!($D(DTOUT)) W $C(7),!,"Deleted..." G EXIT^RMPRSTE
S CK="W:$D(DUOUT) @IOF,!!!?28,$C(7),""Deleted..."" G EXIT^RMPRSTE"
S CK2="W @IOF,!!!?28,$C(7),""Deleted..."" H 2"
S CK1="W $C(7),!,""Timed-Out, Deleted..."" G EXIT^RMPRSTE"
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
S (R1(1),R1(0),R3("D"),R4("D"),R1("AM"),RMPRI("AMS"),R1("D"),RMLOC)=""
S RMLODES=""
S (RMLOCOLD,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 ^RMPRSTI
I $P(R3("D"),U,4)'=""&($D(DUOUT)) G LIST^RMPRSTE
I $D(DTOUT) X CK1 Q
I $D(DUOUT) G ^RMPRSTI
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^RMPRSTE
I $D(DTOUT) X CK1 Q
I $D(DUOUT) X CK2 G ^RMPRSTI
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^RMPRSTE
I $D(DUOUT) X CK2 G ^RMPRSTI
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:"")
;
2 S DIC(0)="AEQM",DIC=661 S:$P(R1(0),U,6) DIC("B")=$P(^RMPR(661,$P(R1(0),U,6),0),U) S DIC("A")="ITEM: "
K DIC("S") D ^DIC
I $P(R3("D"),U,6)&$D(DUOUT) G LIST^RMPRSTE
I $D(DUOUT) X CK2 G ^RMPRSTI
I $D(DTOUT) X CK1 Q
I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G 2
S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2)
;
LOC ;ask for location
S (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
K DIC,Y,X,RQUIT,DTOUT,DUOUT
S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
S:RMLOCOLD'="" DIC("B")=RMLOCOLD
S DIC="^RMPR(661.3,",DIC(0)="AEQM"
S DIC("A")="Enter Pros Location: " D MIX^DIC1
I $G(REDIT)&$D(DUOUT) G LIST^RMPRSTE
I $D(DUOUT) X CK2 G ^RMPRSTI
I $D(DTOUT) X CK1 Q
I X="" W !,"This is a mandatory field!!!",! G LOC
S RMLOC=+Y
G:'$D(^RMPR(661.3,RMLOC,0)) LOC
;
HCPCS ;HCPCS code
K DIC,RMR,RMX,RQUIT S DIC("A")="PSAS HCPCS: ",DA(1)=RMLOC,RMF=1
I $P(R1(1),U,4)&(RMLOCOLD=RMLOC) S DIC("B")=$P(R1(1),U,4)
S DIC="^RMPR(661.3,"_DA(1)_",1,",DIC(0)="AEMNZ"
S DIC("W")="S RZ=$P(^RMPR(661.3,RMLOC,1,+Y,0),U,1) I RZ W ?30,$P(^RMPR(661.1,RZ,0),U,2)"
D ^DIC
I $D(DUOUT) G LOC
I $D(DTOUT) X CK1 Q
I X="" W !,"This is a mandatory field!!!",! G HCPCS
S (RMHCNEW,RMDAHC)=$P($G(^RMPR(661.3,RMLOC,1,+Y,0)),U,1)
I $G(RMDAHC),$P(^RMPR(661.1,RMDAHC,0),U,5)'=1 D INACT G HCPCS
S RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1),RMHCDA=+Y
S RDESC=$P(^RMPR(661.1,RMDAHC,0),U,2)
;
CPT ;ask for CPT Modifier
K DIC,Y,RQUIT
S RDA=RMDAHC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660
D:$D(RMCPT) CHK^RMPRED5
W:$G(REDIT) !,"OLD CPT MODIFIER: ",$P(R1(1),U,6)
I RMHCOLD'=RMDAHC D CPT^RMPRCPTU(RDA) G:$D(DUOUT)!$D(DTOUT) LIST^RMPRSTE S $P(R1(1),U,6)=$G(RMCPT) W:$G(REDIT) !,"NEW CPT MODIFIER: ",$G(RMCPT)
I RMHCOLD'="",(RMHCOLD=RMDAHC),$G(REDIT) D
.S DIR(0)="Y",DIR("A")="Would you like to Edit CPT MODIFIER Entry ",DIR("B")="N" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
.I $G(Y) D CPT^RMPRCPTU(RDA) Q:$D(DUOUT)!$D(DUOUT) S $P(R1(1),U,6)=$G(RMCPT) W !,"NEW CPT MODIFIER: ",$G(RMCPT)
K DIR
;
;D ITEM^RMPR5NU1(REDIT,RMLOC,RMLOCOLD,RMDAHC,RMHCOLD,RMHCDA,RMIT)
;
ITEM ;ask for PSAS Item to edit.
S DA(2)=RMLOC,DA(1)=RMHCDA K DIC,RMU3,RMUBA,RQUIT
S DIC("A")="Enter PSAS Item: ",DIC(0)="AEMNQ"
I RMDAHC=RMHCOLD S DIC("B")=$G(RMIT)
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
D ^DIC
I $D(DUOUT) G LOC
I $D(DTOUT) X CK1 Q
I X="" W !,"This is a mandatory field!!!",! G ITEM
S RMITDA=+Y
S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
S RMUBA=$P(RMU3,U,2)
S (RMITDES,RMIT)=$P(RMU3,U,1)
S RMDES=RMIT K DIC("B"),DIC("S")
I RMUBA<1 D LOWBA G LOC
;
I $D(RMLOC),$D(RMHCDA),$D(RMITDA) S RMSO=$$SOURCE^RMPR5NU1
I $D(RMSO),RMSO="" D MESSO G LOC
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^RMPRSTE
I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G LOC
I $G(RMLOC),$G(RMHCDA),$G(RMITDA) S RMPRUCST=$$COST^RMPR5NU1
I '$G(RMPRUCST) D MESSI G LOC
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
;
VEN ;vendor
S $P(R1(1),U,4)=RMDAHC,$P(R1(0),U,22)=$P(^RMPR(661.1,RMDAHC,0),U,4)
S RMITNEW=RMIT D NODE2
I $D(RMLOC),$D(RMHCDA),$D(RMITDA) S DIC("B")=$$VEND^RMPR5NU1
S $P(R1(0),U,9)=DIC("B")
S DIC(0)="AEQM",DIC=440,DIC("A")="VENDOR: "
D ^DIC I $P(R3("D"),U,9)'=""&$D(DUOUT) G LIST^RMPRSTE
I $D(DTOUT) X CK1 Q
I $D(DUOUT) G LOC
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 ^RMPRSTE
;
NODE2 ;set node2 of file #660
N RMDAHC,RMITDESC
S RMDAHC=$P(R1(1),U,4)
Q:'$G(RMDAHC)
S:$D(RMIT) RMITIEN=$P(RMIT,"-",2)
I $G(RMITIEN),$G(RMDAHC) S:$D(^RMPR(661.1,RMDAHC,3,RMITIEN,0)) RMITDESC=$P(^(0),U,1)
S:$D(RMIT) $P(R1(2),U,1)=RMIT S:$D(RMITDESC) $P(R1(2),U,2)=RMITDESC
Q
;
MESSI ;print message if COST is not defined in the inventory (661.3)
S:'$D(RMIT) RMIT=""
W !!,"***ITEM COST is not defined @:"
W !," PSAS Item = ",RMIT
W !," Location = ",$P($G(^RMPR(661.3,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.3)
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 Location, 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(^RMPR(661.3,"D1",X,RMLOC)) S RX=1
I '$G(RX),$D(^RMPR(661.1,"B",X)) D EN^DDIOL("*** Only PSAS HCPCS in PIP can be issued. Please verify your Location and PSAS HCPCS!!","","!!")
K RX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSTI 7800 printed Sep 23, 2025@20:14:03 Page 2
RMPRSTI ;HINCIO/RVD-ISSUE FROM STOCK ;11/6/00
+1 ;;3.0;PROSTHETICS;**53,62**;Feb 09, 1996
+2 ;
+3 ;RVD patch #62 - modified for PCE interface
+4 ;
+5 SET (RMPRG,RMPRF,RMENTSUS)=""
DO HOME^%ZIS
WRITE @IOF
+6 IF '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT^RMPRSTE
+7 IF $DATA(RMPRDFN)
IF $DATA(^TMP($JOB,"RMPRPCE"))
DO LINK^RMPRS
+8 KILL ^TMP($JOB,"RMPRPCE")
+9 WRITE !
DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
GOTO EXIT^RMPRSTE
VIEW ;
+1 NEW RMPRBAC1,RMDES
+2 SET RMPRBAC1=1
DO ^RMPRPAT
KILL RMPRBAC1
+3 IF $DATA(RMPRKILL)!($DATA(DTOUT))
WRITE $CHAR(7),!,"Deleted..."
GOTO EXIT^RMPRSTE
+4 SET CK="W:$D(DUOUT) @IOF,!!!?28,$C(7),""Deleted..."" G EXIT^RMPRSTE"
+5 SET CK2="W @IOF,!!!?28,$C(7),""Deleted..."" H 2"
+6 SET CK1="W $C(7),!,""Timed-Out, Deleted..."" G EXIT^RMPRSTE"
+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
+3 SET (R1(1),R1(0),R3("D"),R4("D"),R1("AM"),RMPRI("AMS"),R1("D"),RMLOC)=""
+4 SET RMLODES=""
+5 SET (RMLOCOLD,RMIT,RMHCNEW,RMHCOLD,RMITDESC,RMITIEN,R1(2))=""
SET REDIT=0
+6 SET R1(0)=DT_U_RMPRDFN_U_DT
SET $PIECE(R1(0),U,10)=RMPR("STA")
SET $PIECE(R1(0),U,27)=DUZ
+7 ;
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 ^RMPRSTI
+9 IF $PIECE(R3("D"),U,4)'=""&($DATA(DUOUT))
GOTO LIST^RMPRSTE
+10 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+11 IF $DATA(DUOUT)
GOTO ^RMPRSTI
+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^RMPRSTE
+3 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+4 IF $DATA(DUOUT)
XECUTE CK2
GOTO ^RMPRSTI
+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^RMPRSTE
+2 IF $DATA(DUOUT)
XECUTE CK2
GOTO ^RMPRSTI
+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 ;
2 SET DIC(0)="AEQM"
SET DIC=661
if $PIECE(R1(0),U,6)
SET DIC("B")=$PIECE(^RMPR(661,$PIECE(R1(0),U,6),0),U)
SET DIC("A")="ITEM: "
+1 KILL DIC("S")
DO ^DIC
+2 IF $PIECE(R3("D"),U,6)&$DATA(DUOUT)
GOTO LIST^RMPRSTE
+3 IF $DATA(DUOUT)
XECUTE CK2
GOTO ^RMPRSTI
+4 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+5 IF +Y'>0
WRITE !!,?5,$CHAR(7),"This is a required response. Enter '^' to exit",!
GOTO 2
+6 SET $PIECE(R1(0),U,6)=+Y
SET $PIECE(R3("D"),U,6)=$PIECE(Y,U,2)
+7 ;
LOC ;ask for location
+1 SET (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
+2 KILL DIC,Y,X,RQUIT,DTOUT,DUOUT
+3 SET DZ="??"
SET D="B"
SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
+4 if RMLOCOLD'=""
SET DIC("B")=RMLOCOLD
+5 SET DIC="^RMPR(661.3,"
SET DIC(0)="AEQM"
+6 SET DIC("A")="Enter Pros Location: "
DO MIX^DIC1
+7 IF $GET(REDIT)&$DATA(DUOUT)
GOTO LIST^RMPRSTE
+8 IF $DATA(DUOUT)
XECUTE CK2
GOTO ^RMPRSTI
+9 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+10 IF X=""
WRITE !,"This is a mandatory field!!!",!
GOTO LOC
+11 SET RMLOC=+Y
+12 if '$DATA(^RMPR(661.3,RMLOC,0))
GOTO LOC
+13 ;
HCPCS ;HCPCS code
+1 KILL DIC,RMR,RMX,RQUIT
SET DIC("A")="PSAS HCPCS: "
SET DA(1)=RMLOC
SET RMF=1
+2 IF $PIECE(R1(1),U,4)&(RMLOCOLD=RMLOC)
SET DIC("B")=$PIECE(R1(1),U,4)
+3 SET DIC="^RMPR(661.3,"_DA(1)_",1,"
SET DIC(0)="AEMNZ"
+4 SET DIC("W")="S RZ=$P(^RMPR(661.3,RMLOC,1,+Y,0),U,1) I RZ W ?30,$P(^RMPR(661.1,RZ,0),U,2)"
+5 DO ^DIC
+6 IF $DATA(DUOUT)
GOTO LOC
+7 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+8 IF X=""
WRITE !,"This is a mandatory field!!!",!
GOTO HCPCS
+9 SET (RMHCNEW,RMDAHC)=$PIECE($GET(^RMPR(661.3,RMLOC,1,+Y,0)),U,1)
+10 IF $GET(RMDAHC)
IF $PIECE(^RMPR(661.1,RMDAHC,0),U,5)'=1
DO INACT
GOTO HCPCS
+11 SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
SET RMHCDA=+Y
+12 SET RDESC=$PIECE(^RMPR(661.1,RMDAHC,0),U,2)
+13 ;
CPT ;ask for CPT Modifier
+1 KILL DIC,Y,RQUIT
+2 SET RDA=RMDAHC_"^"_$PIECE(R1(0),U,4)_"^"_$PIECE(R1(0),U,14)_"^"_660
+3 if $DATA(RMCPT)
DO CHK^RMPRED5
+4 if $GET(REDIT)
WRITE !,"OLD CPT MODIFIER: ",$PIECE(R1(1),U,6)
+5 IF RMHCOLD'=RMDAHC
DO CPT^RMPRCPTU(RDA)
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO LIST^RMPRSTE
SET $PIECE(R1(1),U,6)=$GET(RMCPT)
if $GET(REDIT)
WRITE !,"NEW CPT MODIFIER: ",$GET(RMCPT)
+6 IF RMHCOLD'=""
IF (RMHCOLD=RMDAHC)
IF $GET(REDIT)
Begin DoDot:1
+7 SET DIR(0)="Y"
SET DIR("A")="Would you like to Edit CPT MODIFIER Entry "
SET DIR("B")="N"
DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+8 IF $GET(Y)
DO CPT^RMPRCPTU(RDA)
if $DATA(DUOUT)!$DATA(DUOUT)
QUIT
SET $PIECE(R1(1),U,6)=$GET(RMCPT)
WRITE !,"NEW CPT MODIFIER: ",$GET(RMCPT)
End DoDot:1
+9 KILL DIR
+10 ;
+11 ;D ITEM^RMPR5NU1(REDIT,RMLOC,RMLOCOLD,RMDAHC,RMHCOLD,RMHCDA,RMIT)
+12 ;
ITEM ;ask for PSAS Item to edit.
+1 SET DA(2)=RMLOC
SET DA(1)=RMHCDA
KILL DIC,RMU3,RMUBA,RQUIT
+2 SET DIC("A")="Enter PSAS Item: "
SET DIC(0)="AEMNQ"
+3 IF RMDAHC=RMHCOLD
SET DIC("B")=$GET(RMIT)
+4 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+5 DO ^DIC
+6 IF $DATA(DUOUT)
GOTO LOC
+7 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+8 IF X=""
WRITE !,"This is a mandatory field!!!",!
GOTO ITEM
+9 SET RMITDA=+Y
+10 SET RMU3=$GET(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
+11 SET RMUBA=$PIECE(RMU3,U,2)
+12 SET (RMITDES,RMIT)=$PIECE(RMU3,U,1)
+13 SET RMDES=RMIT
KILL DIC("B"),DIC("S")
+14 IF RMUBA<1
DO LOWBA
GOTO LOC
+15 ;
+16 IF $DATA(RMLOC)
IF $DATA(RMHCDA)
IF $DATA(RMITDA)
SET RMSO=$$SOURCE^RMPR5NU1
+17 IF $DATA(RMSO)
IF RMSO=""
DO MESSO
GOTO LOC
+18 if $DATA(RMSO)
SET $PIECE(R1(0),U,14)=RMSO
+19 SET $PIECE(R3("D"),U,14)=$SELECT(RMSO="C":"COMMERCIAL",RMSO="V":"VA",1:"")
+20 IF $PIECE(R1(1),U,4)'=""
IF $DATA(DUOUT)
GOTO LIST^RMPRSTE
+21 IF $GET(RMLOC)
IF '($GET(RMHCDA)&$GET(RMITDA))
WRITE !,"PSAS Item was not selected!!"
GOTO LOC
+22 IF $GET(RMLOC)
IF $GET(RMHCDA)
IF $GET(RMITDA)
SET RMPRUCST=$$COST^RMPR5NU1
+23 IF '$GET(RMPRUCST)
DO MESSI
GOTO LOC
+24 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)
+25 KILL DIC
+26 ;
VEN ;vendor
+1 SET $PIECE(R1(1),U,4)=RMDAHC
SET $PIECE(R1(0),U,22)=$PIECE(^RMPR(661.1,RMDAHC,0),U,4)
+2 SET RMITNEW=RMIT
DO NODE2
+3 IF $DATA(RMLOC)
IF $DATA(RMHCDA)
IF $DATA(RMITDA)
SET DIC("B")=$$VEND^RMPR5NU1
+4 SET $PIECE(R1(0),U,9)=DIC("B")
+5 SET DIC(0)="AEQM"
SET DIC=440
SET DIC("A")="VENDOR: "
+6 DO ^DIC
IF $PIECE(R3("D"),U,9)'=""&$DATA(DUOUT)
GOTO LIST^RMPRSTE
+7 IF $DATA(DTOUT)
XECUTE CK1
QUIT
+8 IF $DATA(DUOUT)
GOTO LOC
+9 IF +Y'>0
WRITE !!,?5,$CHAR(7),"This is a required response. Enter '^' to exit",!
GOTO VEN
+10 SET $PIECE(R1(0),U,9)=+Y
SET $PIECE(R3("D"),U,9)=$PIECE(Y,U,2)
KILL DIC,Y,X
+11 GOTO ^RMPRSTE
+12 ;
NODE2 ;set node2 of file #660
+1 NEW RMDAHC,RMITDESC
+2 SET RMDAHC=$PIECE(R1(1),U,4)
+3 if '$GET(RMDAHC)
QUIT
+4 if $DATA(RMIT)
SET RMITIEN=$PIECE(RMIT,"-",2)
+5 IF $GET(RMITIEN)
IF $GET(RMDAHC)
if $DATA(^RMPR(661.1,RMDAHC,3,RMITIEN,0))
SET RMITDESC=$PIECE(^(0),U,1)
+6 if $DATA(RMIT)
SET $PIECE(R1(2),U,1)=RMIT
if $DATA(RMITDESC)
SET $PIECE(R1(2),U,2)=RMITDESC
+7 QUIT
+8 ;
MESSI ;print message if COST is not defined in the inventory (661.3)
+1 if '$DATA(RMIT)
SET RMIT=""
+2 WRITE !!,"***ITEM COST is not defined @:"
+3 WRITE !," PSAS Item = ",RMIT
+4 WRITE !," Location = ",$PIECE($GET(^RMPR(661.3,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.3)
+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 Location, 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(^RMPR(661.3,"D1",X,RMLOC))
SET RX=1
+5 IF '$GET(RX)
IF $DATA(^RMPR(661.1,"B",X))
DO EN^DDIOL("*** Only PSAS HCPCS in PIP can be issued. Please verify your Location and PSAS HCPCS!!","","!!")
+6 KILL RX
+7 QUIT
