217 lines
8.0 KiB
Mathematica
217 lines
8.0 KiB
Mathematica
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
|