| 1 | RMPRPIYI ;HINCIO/RVD-ISSUE FROM STOCK ;6/16/04 08:18
|
|---|
| 2 | ;;3.0;PROSTHETICS;**61,128**;Feb 09, 1996
|
|---|
| 3 | ; RVD #61 - phase IIIa of PIP
|
|---|
| 4 | ;
|
|---|
| 5 | S RMPR699("AMIS GROUPER")=""
|
|---|
| 6 | S (RMPRG,RMPRF)="" D HOME^%ZIS W @IOF
|
|---|
| 7 | I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EXIT^RMPRPIYJ
|
|---|
| 8 | I $D(RMPRDFN),$D(^TMP($J,"RMPRPCE")) D LINK^RMPRS
|
|---|
| 9 | I $D(RMPRDFN),'$D(^TMP($J,"RMPRPCE")) G EXIT^RMPRPIYJ
|
|---|
| 10 | K ^TMP($J,"RMPRPCE")
|
|---|
| 11 | D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT^RMPRPIYJ
|
|---|
| 12 | VIEW ;
|
|---|
| 13 | N RMPRBAC1,RMDES,RMITQTY
|
|---|
| 14 | S (RSTCK,RMPRBAC1)=1 D ^RMPRPAT K RMPRBAC1
|
|---|
| 15 | I $D(RMPRKILL)!($D(DTOUT)) W $C(7),!,"Deleted..." G EXIT^RMPRPIYJ
|
|---|
| 16 | S CK="W:$D(DUOUT) @IOF,!!!?28,$C(7),""Deleted..."" G EXIT^RMPRPIYJ"
|
|---|
| 17 | S CK2="W @IOF,!!!?28,$C(7),""Deleted..."" H 2"
|
|---|
| 18 | S CK1="W $C(7),!,""Timed-Out, Deleted..."" G EXIT^RMPRPIYJ"
|
|---|
| 19 | S R3("D")=""
|
|---|
| 20 | ;
|
|---|
| 21 | RES ;ENTRY POINT TO ADD ADDITIONAL ITEMS FOR ISSUE FROM STOCK
|
|---|
| 22 | Q:$G(RMPRDFN)<1
|
|---|
| 23 | K DA,DD,DIC,PRC,X,Y,RMSO,RMQTY,RMDAHC,RMLACO,RMITDA,RMHCOLD,RMPRVEN
|
|---|
| 24 | K RMPR11IS,RMPR5SA,RMPR6SA
|
|---|
| 25 | S (R1(1),R1(0),R3("D"),R4("D"),R1("AM"),RMPRI("AMS"),R1("D"),RMLOC)=""
|
|---|
| 26 | S RMLODES=""
|
|---|
| 27 | S (RMLOCOLD,R1,RMIT,RMHCNEW,RMHCOLD,RMITDESC,RMITIEN,R1(2))="",REDIT=0
|
|---|
| 28 | S R1(0)=DT_U_RMPRDFN_U_DT,$P(R1(0),U,10)=RMPR("STA"),$P(R1(0),U,27)=DUZ
|
|---|
| 29 | ;
|
|---|
| 30 | 1 ;ENTRY POINT TO EDIT ITEM ON ISSUE FROM STOCK
|
|---|
| 31 | S (RMHCNEW,RMHCOLD)=$P(R1(1),U,4),RMLOCOLD=RMLOC,RMITOLD=RMIT
|
|---|
| 32 | K RQUIT S RMHCFLG=0
|
|---|
| 33 | W @IOF,!?30,RMPRNAM,!
|
|---|
| 34 | W:$G(REDIT) !!,"Editing a Stock Item!!!"
|
|---|
| 35 | W:'$G(REDIT) !!,"Entering a Stock Item!!!"
|
|---|
| 36 | ;
|
|---|
| 37 | TRAN ;TYPE OF TRANSACTION
|
|---|
| 38 | W !
|
|---|
| 39 | ;S DIR(0)="660,2"
|
|---|
| 40 | K DIR
|
|---|
| 41 | S:$P(R1(0),U,4)?.E&($P(R3("D"),U,4)'="") DIR("B")=$P(R3("D"),U,4)
|
|---|
| 42 | S DIR(0)="SO^I:INITIAL ISSUE;X:REPAIR;R:REPLACE;S:SPARE"
|
|---|
| 43 | S DIR("A")="TYPE OF TRANSACTION"
|
|---|
| 44 | D ^DIR
|
|---|
| 45 | I (Y=""),($P(R3("D"),U,4)="") G ^RMPRPIYI
|
|---|
| 46 | I $P(R3("D"),U,4)'=""&($D(DUOUT)) G LIST^RMPRPIYJ
|
|---|
| 47 | I $D(DTOUT) X CK1 Q
|
|---|
| 48 | I $D(DUOUT) G ^RMPRPIYI
|
|---|
| 49 | S $P(R1(0),U,4)=Y K DIR
|
|---|
| 50 | S $P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
|
|---|
| 51 | ;
|
|---|
| 52 | PCAT ;
|
|---|
| 53 | S DIR(0)="660,62" S:$P(R1("AM"),U,3)?1N.N DIR("B")=$P(R4("D"),U,3)
|
|---|
| 54 | D ^DIR I $P(R1("AM"),U,3)'=""&($D(DUOUT)) G LIST^RMPRPIYJ
|
|---|
| 55 | I $D(DTOUT) X CK1 Q
|
|---|
| 56 | I $D(DUOUT) X CK2 G ^RMPRPIYI
|
|---|
| 57 | 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
|
|---|
| 58 | I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2
|
|---|
| 59 | ;
|
|---|
| 60 | 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
|
|---|
| 61 | I $G(REDIT)&($D(DUOUT)) G LIST^RMPRPIYJ
|
|---|
| 62 | I $D(DUOUT) X CK2 G ^RMPRPIYI
|
|---|
| 63 | 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:"")
|
|---|
| 64 | ;
|
|---|
| 65 | ; prompt for and scan barcode label
|
|---|
| 66 | ; if scan is successful then all vars will be set and go to Edit prompt
|
|---|
| 67 | 2 I $G(REDIT),$D(RMPR11I) M RMPR11IS=RMPR11I,RMPR5SA=RMPR5,RMPR6SA=RMPR6
|
|---|
| 68 | W ! D SCAN^RMPRPIYS
|
|---|
| 69 | I $P(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P")) G LIST^RMPRPIYJ
|
|---|
| 70 | I (RMPREXC="^"),$G(REDIT) G LIST^RMPRPIYJ
|
|---|
| 71 | I RMPREXC="^" X CK2 G ^RMPRPIYI
|
|---|
| 72 | I RMPREXC="P" G PCAT
|
|---|
| 73 | I RMPREXC="T" X CK1 Q
|
|---|
| 74 | I RMPRBARC="",$G(REDIT) M RMPR11I=RMPR11IS,RMPR5=RMPR5SA,RMPR6=RMPR6SA G ^RMPRPIYJ
|
|---|
| 75 | I RMPRBARC="" G 2
|
|---|
| 76 | D HCPCS3^RMPRPIY1
|
|---|
| 77 | G ^RMPRPIYJ
|
|---|
| 78 | HCPCS ;HCPCS code
|
|---|
| 79 | S (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
|
|---|
| 80 | S RMPRHCPC="" I $D(RMHCPC) S RMPRHCPC=RMHCPC
|
|---|
| 81 | D HCPCS^RMPRPIY1(RMPR("STA"),RMPRHCPC,.RMPR1,.RMPR11,.RMPREXC)
|
|---|
| 82 | I RMPREXC="T" X CK1 Q
|
|---|
| 83 | I RMPREXC="P" G 2
|
|---|
| 84 | I $G(REDIT),(RMPREXC="^") G LIST^RMPRPIYJ
|
|---|
| 85 | I RMPREXC="^" X CK2 G ^RMPRPIYI
|
|---|
| 86 | W !
|
|---|
| 87 | S RMITNO=RMPR11("ITEM")
|
|---|
| 88 | S RMHCPC=RMPR1("HCPCS")
|
|---|
| 89 | S (RMHCNEW,RMDAHC,RMHCDA)=RMPR1("IEN")
|
|---|
| 90 | S RDESC=RMPR1("SHORT DESC")
|
|---|
| 91 | K RMPR11I
|
|---|
| 92 | S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
|
|---|
| 93 | I RMPR11I("ITEM MASTER IEN")="" D G 2
|
|---|
| 94 | . W !,"This item is not associated with an IFCAP Item.",!
|
|---|
| 95 | . W "Please use the Edit Inventory option before trying to issue this item."
|
|---|
| 96 | . W !
|
|---|
| 97 | . Q
|
|---|
| 98 | I '$D(^RMPR(661.7,"XSHIDS",RMPR("STA"),RMHCPC,RMITNO)) D G 2
|
|---|
| 99 | . W !,"This HCPCS-ITEM is not associated with any Location."
|
|---|
| 100 | . W !,"Please update your inventory!!.",!
|
|---|
| 101 | . W !
|
|---|
| 102 | . Q
|
|---|
| 103 | S $P(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
|
|---|
| 104 | S $P(R1(0),U,8)=$G(RMPR11("UNIT"))
|
|---|
| 105 | S $P(R3("D"),U,6)=RMPR11("ITEM MASTER")
|
|---|
| 106 | ;check for location if multiple then ask for LOCATION
|
|---|
| 107 | S RMLCNT=0
|
|---|
| 108 | 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
|
|---|
| 109 | I RMLCNT<2 G ITEM
|
|---|
| 110 | ;
|
|---|
| 111 | ASKLOC ;ask for location
|
|---|
| 112 | K DIC,Y,X,RQUIT,RMPR5
|
|---|
| 113 | S DZ="??",D="B"
|
|---|
| 114 | 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)))"
|
|---|
| 115 | S:RMLOCOLD'="" DIC("B")=RMLOCOLD
|
|---|
| 116 | S DIC="^RMPR(661.5,",DIC(0)="AEQMN"
|
|---|
| 117 | S DIC("A")="Enter Pros Location: " D MIX^DIC1
|
|---|
| 118 | I $G(REDIT)&$D(DUOUT) G LIST^RMPRPIYJ
|
|---|
| 119 | I $D(DUOUT) G 2^RMPRPIYI
|
|---|
| 120 | I $D(DTOUT) X CK1 Q
|
|---|
| 121 | I X="" W !,"This is a mandatory field!!!",! G ASKLOC
|
|---|
| 122 | S RMLOC=+Y
|
|---|
| 123 | S RMPR5("IEN")=RMLOC
|
|---|
| 124 | G:'$D(^RMPR(661.5,RMLOC,0)) ASKLOC
|
|---|
| 125 | ;
|
|---|
| 126 | ITEM ;PSAS Item details.
|
|---|
| 127 | K RMPR11I
|
|---|
| 128 | S RMCHCK=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
|
|---|
| 129 | I RMCHCK W !,"*** ERROR IN API RMPRPIX1 !!!!",! X CK1 Q
|
|---|
| 130 | S RMIT=RMPR11("HCPCS-ITEM")
|
|---|
| 131 | S $P(R1(2),U,1)=RMIT S $P(R1(2),U,2)=RMPR11("DESCRIPTION")
|
|---|
| 132 | I RMDAHC=RMHCOLD S DIR("B")=$G(RMIT)
|
|---|
| 133 | ;
|
|---|
| 134 | ;call stock record in 661.7
|
|---|
| 135 | S RMR("STATION IEN")=RMPR("STA")
|
|---|
| 136 | S RMR("LOCATION IEN")=RMLOC
|
|---|
| 137 | S RMR("HCPCS")=RMHCPC
|
|---|
| 138 | S RMR("ITEM")=RMPR11("ITEM")
|
|---|
| 139 | S RMR("VENDOR IEN")=$P(R1(0),U,9)
|
|---|
| 140 | S RMCHCK=$$STOCK^RMPRPIUE(.RMR)
|
|---|
| 141 | I RMCHCK W !,"*** ERROR IN API RMPRPIUE !!!!",! X CK1 Q
|
|---|
| 142 | S (RMITDES,RMDES)=RMIT K DIC("B"),DIC("S")
|
|---|
| 143 | S RMUBA=RMR("QOH")
|
|---|
| 144 | I RMUBA<1 D LOWBA G 2
|
|---|
| 145 | ;
|
|---|
| 146 | I $D(RMLOC),$D(RMHCDA) S RMSO=RMPR11I("SOURCE")
|
|---|
| 147 | I $D(RMSO),RMSO="" D MESSO G 2
|
|---|
| 148 | S:$D(RMSO) $P(R1(0),U,14)=RMSO
|
|---|
| 149 | S $P(R3("D"),U,14)=$S(RMSO="C":"COMMERCIAL",RMSO="V":"VA",1:"")
|
|---|
| 150 | I $P(R1(1),U,4)'="",$D(DUOUT) G LIST^RMPRPIYJ
|
|---|
| 151 | ;I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G 2
|
|---|
| 152 | I $G(RMLOC),$G(RMHCDA) S RMPRUCST=RMR("UNIT COST")
|
|---|
| 153 | I '$G(RMPRUCST) D MESSI G 2
|
|---|
| 154 | 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)
|
|---|
| 155 | K DIC
|
|---|
| 156 | ;
|
|---|
| 157 | CPT ;ask for CPT Modifier
|
|---|
| 158 | D CPT^RMPRPIYS(RMDAHC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660)
|
|---|
| 159 | I RMPREXC="T" X CK1 Q
|
|---|
| 160 | I RMPREXC="^" G 2
|
|---|
| 161 | I RMPREXC="P" G 2
|
|---|
| 162 | ;
|
|---|
| 163 | VEN ;vendor
|
|---|
| 164 | ;call routine RMPRPIYV for vendor from file 661.6.
|
|---|
| 165 | S $P(R1(1),U,4)=RMDAHC,$P(R1(0),U,22)=$P(^RMPR(661.1,RMDAHC,0),U,4)
|
|---|
| 166 | ;If there is only one vendor use it as a default.
|
|---|
| 167 | K RMPRVEN
|
|---|
| 168 | S RMERR=$$STOCK^RMPRPIUV(.RMR,.RMPRVEN)
|
|---|
| 169 | I RMERR W !,"*** ERROR IN API RMPRPIUV !!!!",! X CK1 Q
|
|---|
| 170 | I RMPRVEN=1 S DIC("B")=$O(RMPRVEN(0))
|
|---|
| 171 | I $G(REDIT) S DIC("B")=$P(R1(0),U,9)
|
|---|
| 172 | S DIC(0)="AEQM"
|
|---|
| 173 | S DIC("A")="VENDOR: ",DIC=440,DIC("S")="I $D(RMPRVEN(+Y))"
|
|---|
| 174 | D ^DIC I $P(R3("D"),U,9)'=""&$D(DUOUT) G LIST^RMPRPIYJ
|
|---|
| 175 | I $D(DTOUT) X CK1 Q
|
|---|
| 176 | I $D(DUOUT) G 2
|
|---|
| 177 | I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G VEN
|
|---|
| 178 | S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIC,Y,X
|
|---|
| 179 | G ^RMPRPIYJ
|
|---|
| 180 | ;
|
|---|
| 181 | ;
|
|---|
| 182 | MESSI ;print message if COST is not defined in the inventory (661.5)
|
|---|
| 183 | S:'$D(RMIT) RMIT=""
|
|---|
| 184 | W !!,"***ITEM COST is not define @:"
|
|---|
| 185 | W !," PSAS Item = ",RMIT
|
|---|
| 186 | W !," Location = ",$P($G(^RMPR(661.5,RMLOC,0)),U,1)
|
|---|
| 187 | W !,"***Fix your inventory or use a different PSAS ITEM!!",!!
|
|---|
| 188 | Q
|
|---|
| 189 | ;
|
|---|
| 190 | MESSO ;print message if SOURCE is not defined in the inventory (661.11)
|
|---|
| 191 | W !!,"***PSAS ITEM has no SOURCE at this location..."
|
|---|
| 192 | W !,"***Fix your inventory or use a different PSAS ITEM!!",!!
|
|---|
| 193 | Q
|
|---|
| 194 | ;
|
|---|
| 195 | INACT ;print message if HCPCS is inactive.
|
|---|
| 196 | W !!,"*** You have selected an INACTIVE HCPCS..."
|
|---|
| 197 | W !,"*** Please REMOVE this HCPCS from inventory..."
|
|---|
| 198 | W !,"*** And use a different HCPCS!!!",!
|
|---|
| 199 | Q
|
|---|
| 200 | ;
|
|---|
| 201 | LOWBA ;print message if inventory balance is low.
|
|---|
| 202 | S:'$D(RMUBA) RMUBA="" S:'$D(RMIT) RMIT=""
|
|---|
| 203 | W !!,"*** PSAS Item ",RMIT," balance is = ",RMUBA
|
|---|
| 204 | W !,"*** You are unable to use this PSAS ITEM..."
|
|---|
| 205 | W !,"*** Please use a different HCPCS or PSAS Item !!!!",!
|
|---|
| 206 | Q
|
|---|
| 207 | ;
|
|---|
| 208 | LKP ;print a message if PSAS HCPCS not in PIP or invalid HCPCS.
|
|---|
| 209 | Q:'$G(RMF)!(X=" ")
|
|---|
| 210 | S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 211 | K RX
|
|---|
| 212 | I $D(RSTCK),$D(^RMPR(661.7,"XSHIDS",RMPR("STA"),X)) S RX=1
|
|---|
| 213 | I '$D(RSTCK),$D(^RMPR(661.11,"ASHD",RMPR("STA"),X)) S RX=1
|
|---|
| 214 | 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!!","","!!")
|
|---|
| 215 | K RX
|
|---|
| 216 | Q
|
|---|
