RMPV0RMPRPIYS ; OIT/JDA - Adapted from RMPRPIYS; Dec 01, 2024@21:44:42
;;1.0;PROSTHETICS VISION 4 SIGHT II;**2**;Jan 31, 2025;Build 38
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Reference to CHK^RMPRED5 supported by ICR #6545
; Reference to HPACT^RMPRPIX1 supported by ICR #7116
; Reference to GET^RMPRPIX1 supported by ICR #7116
; Reference to ETOI^RMPRPIX1 supported by ICR #7116
; Reference to ^RMPR(661.1, supported by ICR #6506
; Reference to GET^RMPRPIX6 supported by ICR #7118
; Reference to VNDIEN^RMPRPIX6 supported by ICR #7118
; Reference to CPT^RMPRCPTU supported by ICR #7543
;
RMPRPIYS ;HINCIO/ODJ - RC - PIP Receive Stock ;10/8/02 13:11
;;3.0;PROSTHETICS;**61,108,128,161**;Feb 09, 1996;Build 2
Q
;
;***** PB - Print Bar Code labels
; RMPR INV BAR CODE
; Callable from VISTA menu, no vars required other than
; global VISTA vars (DUZ, etc)
;
PB N RMPRERR,RMPRSTN,RMPRLCN,RMPREXC,RMPR1,RMPR11,RMPROVAL,RMPRNLAB
N RMPR6,RMPR7,RMPR7I,RMPRBARC,RMPRITXT,RMPRBCP,RMPRQ,RMPRIOP
;
;***** STN - prompt for Site/Station
STN S RMPROVAL=$G(RMPRSTN("IEN"))
D WRITEIND^RMPVIO("@IOF") S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
I RMPRERR G PBX
I RMPREXC'="" G PBX
I RMPROVAL'=RMPRSTN("IEN") K RMPR1,RMPR11
;
;***** HCPCS - prompt for HCPCS and Item
HCPCS D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("Print Bar code Labels for current inventory..."),WRITECTL^RMPVIO("!")
HCPCS2 D HCPCS^RMPRPIY7(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
I RMPREXC="T" G PBX
I RMPREXC="P" G STN
I RMPREXC="^" D G PBX
. D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("** No HCPCS selected...") H 1
. Q
I $G(RMPR11("IEN"))'="" G HCPCS3A
HCPCS3 D ITEM^RMPRPIYP(RMPRSTN("IEN"),RMPR1("HCPCS"),.RMPR11,.RMPREXC)
I RMPREXC="T" G PBX
I RMPREXC="P"!(RMPREXC="^") G HCPCS
HCPCS3A S RMPR11("STATION")=RMPRSTN("IEN")
S RMPR11("STATION IEN")=RMPRSTN("IEN")
;
; display selected HCPCS and item and continue
HCPCS4 D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("HCPCS: "_RMPR1("HCPCS")_" "_RMPR1("SHORT DESC"))
D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("IFCAP Item: "),WRITE^RMPVIO(RMPR11("ITEM MASTER"))
D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("PIP Item desc.: "),WRITE^RMPVIO(RMPR11("DESCRIPTION"))
;
;***** CURST - call prompt for current stock record
CURST S RMPRLCN=""
D PVEN^RMPRPIYR(RMPRSTN("IEN"),.RMPRLCN,RMPR11("HCPCS"),RMPR11("ITEM"),.RMPR6,.RMPR7,.RMPREXC)
I RMPREXC="T" G PBX
I RMPREXC="P" G HCPCS3
I RMPREXC="^" G HCPCS
I '+$G(RMPR7("QUANTITY")) D G HCPCS2
. D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("This item is not currently in stock."),WRITECTL^RMPVIO("!!")
. Q
K RMPR7I
S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
S RMPRBARC=RMPR11("HCPCS")_"-"_$P(RMPR7I("DATE&TIME"),".",1)_$P(RMPR7I("DATE&TIME"),".",2)
S RMPRITXT("DATE")=$E(RMPR7I("DATE&TIME"),4,5)_"/"_$E(RMPR7I("DATE&TIME"),6,7)_"/"_(1700+$E(RMPR7I("DATE&TIME"),1,3))
S RMPRITXT("ITEM")=RMPR11("HCPCS-ITEM")
S RMPRITXT("MASTER DESC")=RMPR11("ITEM MASTER")
S RMPRITXT("ITEM DESC")=RMPR11("DESCRIPTION")
S RMPRITXT("UNIT PRICE")=+$J(RMPR7("VALUE")/RMPR7("QUANTITY"),0,2)
S RMPRITXT("VENDOR")=RMPR6("VENDOR")
S RMPRITXT("LOCATION")=RMPR7("LOCATION")
;
;***** NLAB - call prompt for number of labels to print
NLAB S RMPRNLAB=RMPR7("QUANTITY")
D WRITECTL^RMPVIO("!") D NLABP(.RMPRNLAB,RMPR7("QUANTITY"),.RMPREXC)
I RMPREXC="T" G PBX
I RMPREXC="P" G HCPCS
I RMPREXC="^" G HCPCS
;
;***** SELP - call prompt for bar code print device
SELP D PRINT G HCPCS
G HCPCS
PBX D KILL^XUSCLEAN
Q
;
;***** PRINT - print bar code labels
; requires RMPRNLAB (number of labels) and
; RMPRBCP (bar code printer name) to be set
; RMPRBARC (bar code to print)
; RMPRIOP (the device to open)
PRINT I '$D(RMPRNLAB) S RMPRNLAB=1
;allows queing of bar code labels
SELD S %ZIS("A")="Select Bar Code Printer: "
S %ZIS="QM" K IOP D WRITECTL^RMPVIO("!") D ^%ZIS G:POP PRINTX
I $G(IOST)'["P-ZEBRA" D
. D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("** WARNING - This is NOT a Zebra Bar Code Printer!!"),WRITECTL^RMPVIO("!!")
I '$D(IO("Q")) U IO G PNOW
K IO("Q") S ZTDESC="PRINT BAR CODE LABELS",ZTRTN="PNOW^RMPRPIYS"
S ZTIO=ION,ZTSAVE("RMPRBARC")="",ZTSAVE("RMPRITXT(")=""
S ZTSAVE("RMPRNLAB")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPRSTN(")=""
D ^%ZTLOAD D:$D(ZTSK) WRITECTL^RMPVIO("!"),WRITE^RMPVIO("REQUEST QUEUED!") H 2 G PRINTC
;
PNOW ;jump here if not queued.
D ZPLII^RMPRPI11(RMPRBARC,.RMPRITXT,RMPRNLAB)
S IONOFF=1
PRINTC D ^%ZISC K IONOFF
PRINTX Q
;
;***** NLABP - Number of labels prompt
NLABP(RMPRNLAB,RMPRMAX,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
S RMPRNLAB=$G(RMPRNLAB)
S RMPRERR=0
S DIR(0)="NAO^1:"_RMPRMAX_":0"
S DIR("A")="Number of Labels to print: "
S:RMPRNLAB'="" DIR("B")=RMPRNLAB
S DIR("??")="^D NLABPH2^RMPRPIYS"
D %DIR^RMPVFM
I $D(DTOUT) S RMPREXC="T" G NLABPX
I $D(DIROUT) S RMPREXC="P" G NLABPX
I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G NLABPX
S RMPREXC=""
S RMPRNLAB=+Y
NLABPX Q
NLABPH2 D WRITE^RMPVIO("Type in the number of bar code labels you want to print for the"),WRITECTL^RMPVIO("!")
D WRITE^RMPVIO("inventory item you have selected."),WRITECTL^RMPVIO("!")
Q
;
;***** BARC - bar code prompt
BARC(RMPRBARC,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
S RMPRBARC=""
S RMPREXC=""
S RMPRERR=0
S DIR(0)="FAO"
S DIR("A")="Scan in item bar code: "
S DIR("?")="^D BARCH^RMPRPIYS"
BARC1 D %DIR^RMPVFM
I $D(DTOUT) S RMPREXC="T" G BARCX
I $D(DIROUT) S RMPREXC="P" G BARCX
I X["^"!($D(DUOUT)) S RMPREXC="^" G BARCX
I X="",$G(REDIT) G BARCX
I X="" G BARC1
S RMPRBARC=X
BARCX Q
BARCH D WRITE^RMPVIO("If you have access to a bar code scanner, use it to scan the item bar code now."),WRITECTL^RMPVIO("!")
D WRITE^RMPVIO("Don't press the [Enter] key as the scanner should do this automatically."),WRITECTL^RMPVIO("!")
D WRITE^RMPVIO("If the scanner cannot read the bar code, type in the character sequence"),WRITECTL^RMPVIO("!")
D WRITE^RMPVIO("immediately below the bar code."),WRITECTL^RMPVIO("!")
;W "If there is no bar code or you prefer to enter the transaction manually",!
;W "leave this prompt blank.",!
Q
;
;***** SCAN - scan bar code and set up stock issue vars.
; (to be called by RMPRPIYI (too big))
SCAN K RMPR7,RMPR7I,RMPR1,RMPR1I,RMPR11,RMPR11I,RMPR6,RMDAHC,RMITQTY
SCAN1 D BARC(.RMPRBARC,.RMPREXC)
I RMPREXC'="" S RMPRBARC="" G SCANX
I RMPRBARC="" G SCANX
;*161 added check to insure barcode scan or manual entry was valid HCPCS item entry
I $P(RMPRBARC,"-")="" D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("** No HCPCS Selected due to null HCPCS entered...") G SCAN
S RMPRBARC=$$UPCASE(RMPRBARC)
;
; If we get a good bar code then populate all the fields and go
; straight to the Post/Edit prompt
K RMPR7
S (RMPR7("STATION"),RMPRSTN)=RMPR("STA")
S RMPR7("HCPCS")=$P(RMPRBARC,"-",1)
S RMDAHC=$O(^RMPR(661.1,"B",RMPR7("HCPCS"),0))
I $G(RMDAHC),$D(^RMPR(661.1,RMDAHC,0)),($P(^RMPR(661.1,RMDAHC,0),U,5)'=1) S RMDAHC=$P(^RMPR(661.1,RMDAHC,0),U,3)
I '$G(RMDAHC) D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("** No HCPCS Selected or Unable to Select Inactive HCPCS...") G SCAN
S RMPR7("DATE&TIME")=$E($P(RMPRBARC,"-",2),1,7)_"."_$E($P(RMPRBARC,"-",2),8,$L(RMPRBARC))
;
; look up current stock record with bar coded key fields
S RMPRERR=$$SCAN^RMPRPIUA(.RMPR7,.RMPREXC)
I $G(RMPR7("IEN"))="" D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("*** The Item scanned is not available, please update your inventory !!!") G SCAN1
I RMPRERR D SCANE G SCAN1
S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
I RMPRERR D SCANE G SCAN1
S R1("DATE&TIME")=$G(RMPR7I("DATE&TIME"))
S $P(R1(0),U,8)=$G(RMPR7I("UNIT"))
;
; set vars. for HCPCS
K RMPR1,RMPR1I
S RMPR1("HCPCS")=RMPR7("HCPCS")
S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
I RMPRERR D SCANE G SCAN1
S RMPRERR=$$HPETOI^RMPRPIX1(.RMPR1,.RMPR1I)
I RMPRERR D SCANE G SCAN1
;
; set vars. for Item
K RMPR11,RMPR11I
S RMPR11("STATION")=RMPR("STA")
S RMPR11("HCPCS")=RMPR7("HCPCS")
S RMPR11("ITEM")=RMPR7("ITEM")
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
I RMPRERR D SCANE G SCAN1
S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
I RMPRERR D SCANE G SCAN1
I RMPR11I("ITEM MASTER IEN")="" D G SCAN1
. D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("This item is not associated with an IFCAP Item."),WRITECTL^RMPVIO("!")
. D WRITE^RMPVIO("Please use the Edit Inventory option before trying to issue this item.")
. D WRITECTL^RMPVIO("!")
. Q
;S RMDAHC=RMPR1("IEN")
D CPT(RMDAHC_"^"_$P(R1(0),U,4)_"^"_RMPR11I("SOURCE")_"^660")
I RMPREXC="T" G SCANX
I RMPREXC'="" G SCAN1
;
; get Vendor
S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
S RMPR6("HCPCS")=RMPR7("HCPCS")
S RMPR6("SEQUENCE")=RMPR7("SEQUENCE")
S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
I RMPRERR D SCANE G SCAN1
S RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
I RMPRERR D SCANE G SCAN1
S $P(R1(0),U,9)=RMPR6("VENDOR IEN")
S $P(R3("D"),U,9)=RMPR6("VENDOR")
;
; set vars for issue
S RMCPTC=""
I $G(RMDAHC),$D(^RMPR(661.1,RMDAHC,0)) S RMCPTC=$P(^RMPR(661.1,RMDAHC,0),U,4)
S $P(R1(1),U,4)=RMDAHC
S $P(R1(0),U,22)=$G(RMCPTC)
S $P(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
S (RMHCNEW,RMHCDA)=RMDAHC
S RMITDA=RMPR11("IEN")
S RMHCPC=RMPR11("HCPCS")
S RMIT=RMPR11("HCPCS-ITEM")
S RDESC=RMPR1("SHORT DESC")
S $P(R3("D"),U,14)=RMPR11("SOURCE")
S RMSO=RMPR11I("SOURCE")
S $P(R1(0),U,14)=RMSO
S $P(R3("D"),U,6)=RMPR11("ITEM MASTER")
S $P(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
S $P(R1(2),U,1)=RMIT
S $P(R1(2),U,2)=RMPR11("DESCRIPTION")
S RMLOC=RMPR7I("LOCATION"),RMUBA=0,RMPR11("ITEM")=$P(RMIT,"-",2)
S RMPR11("LOCATION")=RMLOC,RMPR11("STATION")=RMPRSTN
I '$G(RMPR11("LOCATION")) S RMUBA=RMPR7("QUANTITY")
S:'$G(RMUBA) RMUBA=$$BAL^RMPRPIX7(.RMPR11)
S RMITQTY=RMPR7("QUANTITY")
K RMPR5
S RMPR5("IEN")=RMLOC
S RMPRUCST=RMPR7("VALUE")/RMPR7("QUANTITY")
S $P(R1(0),U,16)=$J(RMPRUCST,0,2)
S $P(R3("D"),U,16)=$J(RMPRUCST,0,2)
S $P(R1(0),U,7)=1 ;qty.
S $P(R1(0),U,11)="" ;serial num
S $P(R1(0),U,24)="" ;lot num
S $P(R1(0),U,18)="" ;remarks
SCANX Q
SCANE D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("A problem has occurred with the scan, please try again."),WRITECTL^RMPVIO("!")
Q
;
;***** CPT - prompt for CPT modifier
; (extension of RMPRPIYI and to be used only by that routine)
CPT(RDA) ;
N DIC,Y,RQUIT,X,DA,DIR,DUOUT,DTOUT
N RMPR1,RMPR11,RMPR11I,RMPR7,RMPR7I
S RMPREXC=""
D:$D(RMCPT) CHK^RMPRED5
D:$G(REDIT) WRITECTL^RMPVIO("!"),WRITE^RMPVIO("OLD CPT MODIFIER: "),WRITE^RMPVIO($P(R1(1),U,6))
I RMHCOLD'=RMDAHC D CPT^RMPRCPTU(RDA)
I $D(DUOUT) S RMPREXC="^" G CPTX
I $D(DTOUT) S RMPREXC="T" G CPTX
S $P(R1(1),U,6)=$G(RMCPT)
D:$G(REDIT) WRITECTL^RMPVIO("!"),WRITE^RMPVIO("NEW CPT MODIFIER: "),WRITE^RMPVIO($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^RMPVFM Q:$D(DTOUT)!$D(DUOUT)
. I $G(Y) D
.. D CPT^RMPRCPTU(RDA)
.. I $D(DUOUT) S RMPREXC="^"
.. I $D(DTOUT) S RMPREXC="T"
.. D:RMCPT=$P(R1(1),U,6) WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("***Based on the information given above, CPT modifier string has not changed!!!"),WRITECTL^RMPVIO("!")
.. D:RMCPT'=$P(R1(1),U,6) WRITECTL^RMPVIO("!"),WRITE^RMPVIO("NEW CPT MODIFIER: "),WRITE^RMPVIO($G(RMCPT))
.. S $P(R1(1),U,6)=$G(RMCPT)
CPTX Q
UPCASE(RMPRSTR) ;
Q $TR(RMPRSTR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPV0RMPRPIYS 11650 printed May 25, 2026@12:50:59 Page 2
RMPV0RMPRPIYS ; OIT/JDA - Adapted from RMPRPIYS; Dec 01, 2024@21:44:42
+1 ;;1.0;PROSTHETICS VISION 4 SIGHT II;**2**;Jan 31, 2025;Build 38
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Reference to CHK^RMPRED5 supported by ICR #6545
+5 ; Reference to HPACT^RMPRPIX1 supported by ICR #7116
+6 ; Reference to GET^RMPRPIX1 supported by ICR #7116
+7 ; Reference to ETOI^RMPRPIX1 supported by ICR #7116
+8 ; Reference to ^RMPR(661.1, supported by ICR #6506
+9 ; Reference to GET^RMPRPIX6 supported by ICR #7118
+10 ; Reference to VNDIEN^RMPRPIX6 supported by ICR #7118
+11 ; Reference to CPT^RMPRCPTU supported by ICR #7543
+12 ;
RMPRPIYS ;HINCIO/ODJ - RC - PIP Receive Stock ;10/8/02 13:11
+1 ;;3.0;PROSTHETICS;**61,108,128,161**;Feb 09, 1996;Build 2
+2 QUIT
+3 ;
+4 ;***** PB - Print Bar Code labels
+5 ; RMPR INV BAR CODE
+6 ; Callable from VISTA menu, no vars required other than
+7 ; global VISTA vars (DUZ, etc)
+8 ;
PB NEW RMPRERR,RMPRSTN,RMPRLCN,RMPREXC,RMPR1,RMPR11,RMPROVAL,RMPRNLAB
+1 NEW RMPR6,RMPR7,RMPR7I,RMPRBARC,RMPRITXT,RMPRBCP,RMPRQ,RMPRIOP
+2 ;
+3 ;***** STN - prompt for Site/Station
STN SET RMPROVAL=$GET(RMPRSTN("IEN"))
+1 DO WRITEIND^RMPVIO("@IOF")
SET RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
+2 IF RMPRERR
GOTO PBX
+3 IF RMPREXC'=""
GOTO PBX
+4 IF RMPROVAL'=RMPRSTN("IEN")
KILL RMPR1,RMPR11
+5 ;
+6 ;***** HCPCS - prompt for HCPCS and Item
HCPCS DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("Print Bar code Labels for current inventory...")
DO WRITECTL^RMPVIO("!")
HCPCS2 DO HCPCS^RMPRPIY7(RMPRSTN("IEN"),$GET(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
+1 IF RMPREXC="T"
GOTO PBX
+2 IF RMPREXC="P"
GOTO STN
+3 IF RMPREXC="^"
Begin DoDot:1
+4 DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("** No HCPCS selected...")
HANG 1
+5 QUIT
End DoDot:1
GOTO PBX
+6 IF $GET(RMPR11("IEN"))'=""
GOTO HCPCS3A
HCPCS3 DO ITEM^RMPRPIYP(RMPRSTN("IEN"),RMPR1("HCPCS"),.RMPR11,.RMPREXC)
+1 IF RMPREXC="T"
GOTO PBX
+2 IF RMPREXC="P"!(RMPREXC="^")
GOTO HCPCS
HCPCS3A SET RMPR11("STATION")=RMPRSTN("IEN")
+1 SET RMPR11("STATION IEN")=RMPRSTN("IEN")
+2 ;
+3 ; display selected HCPCS and item and continue
HCPCS4 DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("HCPCS: "_RMPR1("HCPCS")_" "_RMPR1("SHORT DESC"))
+1 DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("IFCAP Item: ")
DO WRITE^RMPVIO(RMPR11("ITEM MASTER"))
+2 DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("PIP Item desc.: ")
DO WRITE^RMPVIO(RMPR11("DESCRIPTION"))
+3 ;
+4 ;***** CURST - call prompt for current stock record
CURST SET RMPRLCN=""
+1 DO PVEN^RMPRPIYR(RMPRSTN("IEN"),.RMPRLCN,RMPR11("HCPCS"),RMPR11("ITEM"),.RMPR6,.RMPR7,.RMPREXC)
+2 IF RMPREXC="T"
GOTO PBX
+3 IF RMPREXC="P"
GOTO HCPCS3
+4 IF RMPREXC="^"
GOTO HCPCS
+5 IF '+$GET(RMPR7("QUANTITY"))
Begin DoDot:1
+6 DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("This item is not currently in stock.")
DO WRITECTL^RMPVIO("!!")
+7 QUIT
End DoDot:1
GOTO HCPCS2
+8 KILL RMPR7I
+9 SET RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
+10 SET RMPRBARC=RMPR11("HCPCS")_"-"_$PIECE(RMPR7I("DATE&TIME"),".",1)_$PIECE(RMPR7I("DATE&TIME"),".",2)
+11 SET RMPRITXT("DATE")=$EXTRACT(RMPR7I("DATE&TIME"),4,5)_"/"_$EXTRACT(RMPR7I("DATE&TIME"),6,7)_"/"_(1700+$EXTRACT(RMPR7I("DATE&TIME"),1,3))
+12 SET RMPRITXT("ITEM")=RMPR11("HCPCS-ITEM")
+13 SET RMPRITXT("MASTER DESC")=RMPR11("ITEM MASTER")
+14 SET RMPRITXT("ITEM DESC")=RMPR11("DESCRIPTION")
+15 SET RMPRITXT("UNIT PRICE")=+$JUSTIFY(RMPR7("VALUE")/RMPR7("QUANTITY"),0,2)
+16 SET RMPRITXT("VENDOR")=RMPR6("VENDOR")
+17 SET RMPRITXT("LOCATION")=RMPR7("LOCATION")
+18 ;
+19 ;***** NLAB - call prompt for number of labels to print
NLAB SET RMPRNLAB=RMPR7("QUANTITY")
+1 DO WRITECTL^RMPVIO("!")
DO NLABP(.RMPRNLAB,RMPR7("QUANTITY"),.RMPREXC)
+2 IF RMPREXC="T"
GOTO PBX
+3 IF RMPREXC="P"
GOTO HCPCS
+4 IF RMPREXC="^"
GOTO HCPCS
+5 ;
+6 ;***** SELP - call prompt for bar code print device
SELP DO PRINT
GOTO HCPCS
+1 GOTO HCPCS
PBX DO KILL^XUSCLEAN
+1 QUIT
+2 ;
+3 ;***** PRINT - print bar code labels
+4 ; requires RMPRNLAB (number of labels) and
+5 ; RMPRBCP (bar code printer name) to be set
+6 ; RMPRBARC (bar code to print)
+7 ; RMPRIOP (the device to open)
PRINT IF '$DATA(RMPRNLAB)
SET RMPRNLAB=1
+1 ;allows queing of bar code labels
SELD SET %ZIS("A")="Select Bar Code Printer: "
+1 SET %ZIS="QM"
KILL IOP
DO WRITECTL^RMPVIO("!")
DO ^%ZIS
if POP
GOTO PRINTX
+2 IF $GET(IOST)'["P-ZEBRA"
Begin DoDot:1
+3 DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("** WARNING - This is NOT a Zebra Bar Code Printer!!")
DO WRITECTL^RMPVIO("!!")
End DoDot:1
+4 IF '$DATA(IO("Q"))
USE IO
GOTO PNOW
+5 KILL IO("Q")
SET ZTDESC="PRINT BAR CODE LABELS"
SET ZTRTN="PNOW^RMPRPIYS"
+6 SET ZTIO=ION
SET ZTSAVE("RMPRBARC")=""
SET ZTSAVE("RMPRITXT(")=""
+7 SET ZTSAVE("RMPRNLAB")=""
SET ZTSAVE("RMPR(")=""
SET ZTSAVE("RMPRSTN(")=""
+8 DO ^%ZTLOAD
if $DATA(ZTSK)
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("REQUEST QUEUED!")
HANG 2
GOTO PRINTC
+9 ;
PNOW ;jump here if not queued.
+1 DO ZPLII^RMPRPI11(RMPRBARC,.RMPRITXT,RMPRNLAB)
+2 SET IONOFF=1
PRINTC DO ^%ZISC
KILL IONOFF
PRINTX QUIT
+1 ;
+2 ;***** NLABP - Number of labels prompt
NLABP(RMPRNLAB,RMPRMAX,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
+2 SET RMPRNLAB=$GET(RMPRNLAB)
+3 SET RMPRERR=0
+4 SET DIR(0)="NAO^1:"_RMPRMAX_":0"
+5 SET DIR("A")="Number of Labels to print: "
+6 if RMPRNLAB'=""
SET DIR("B")=RMPRNLAB
+7 SET DIR("??")="^D NLABPH2^RMPRPIYS"
+8 DO %DIR^RMPVFM
+9 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO NLABPX
+10 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO NLABPX
+11 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO NLABPX
+12 SET RMPREXC=""
+13 SET RMPRNLAB=+Y
NLABPX QUIT
NLABPH2 DO WRITE^RMPVIO("Type in the number of bar code labels you want to print for the")
DO WRITECTL^RMPVIO("!")
+1 DO WRITE^RMPVIO("inventory item you have selected.")
DO WRITECTL^RMPVIO("!")
+2 QUIT
+3 ;
+4 ;***** BARC - bar code prompt
BARC(RMPRBARC,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
+2 SET RMPRBARC=""
+3 SET RMPREXC=""
+4 SET RMPRERR=0
+5 SET DIR(0)="FAO"
+6 SET DIR("A")="Scan in item bar code: "
+7 SET DIR("?")="^D BARCH^RMPRPIYS"
BARC1 DO %DIR^RMPVFM
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO BARCX
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO BARCX
+3 IF X["^"!($DATA(DUOUT))
SET RMPREXC="^"
GOTO BARCX
+4 IF X=""
IF $GET(REDIT)
GOTO BARCX
+5 IF X=""
GOTO BARC1
+6 SET RMPRBARC=X
BARCX QUIT
BARCH DO WRITE^RMPVIO("If you have access to a bar code scanner, use it to scan the item bar code now.")
DO WRITECTL^RMPVIO("!")
+1 DO WRITE^RMPVIO("Don't press the [Enter] key as the scanner should do this automatically.")
DO WRITECTL^RMPVIO("!")
+2 DO WRITE^RMPVIO("If the scanner cannot read the bar code, type in the character sequence")
DO WRITECTL^RMPVIO("!")
+3 DO WRITE^RMPVIO("immediately below the bar code.")
DO WRITECTL^RMPVIO("!")
+4 ;W "If there is no bar code or you prefer to enter the transaction manually",!
+5 ;W "leave this prompt blank.",!
+6 QUIT
+7 ;
+8 ;***** SCAN - scan bar code and set up stock issue vars.
+9 ; (to be called by RMPRPIYI (too big))
SCAN KILL RMPR7,RMPR7I,RMPR1,RMPR1I,RMPR11,RMPR11I,RMPR6,RMDAHC,RMITQTY
SCAN1 DO BARC(.RMPRBARC,.RMPREXC)
+1 IF RMPREXC'=""
SET RMPRBARC=""
GOTO SCANX
+2 IF RMPRBARC=""
GOTO SCANX
+3 ;*161 added check to insure barcode scan or manual entry was valid HCPCS item entry
+4 IF $PIECE(RMPRBARC,"-")=""
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("** No HCPCS Selected due to null HCPCS entered...")
GOTO SCAN
+5 SET RMPRBARC=$$UPCASE(RMPRBARC)
+6 ;
+7 ; If we get a good bar code then populate all the fields and go
+8 ; straight to the Post/Edit prompt
+9 KILL RMPR7
+10 SET (RMPR7("STATION"),RMPRSTN)=RMPR("STA")
+11 SET RMPR7("HCPCS")=$PIECE(RMPRBARC,"-",1)
+12 SET RMDAHC=$ORDER(^RMPR(661.1,"B",RMPR7("HCPCS"),0))
+13 IF $GET(RMDAHC)
IF $DATA(^RMPR(661.1,RMDAHC,0))
IF ($PIECE(^RMPR(661.1,RMDAHC,0),U,5)'=1)
SET RMDAHC=$PIECE(^RMPR(661.1,RMDAHC,0),U,3)
+14 IF '$GET(RMDAHC)
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("** No HCPCS Selected or Unable to Select Inactive HCPCS...")
GOTO SCAN
+15 SET RMPR7("DATE&TIME")=$EXTRACT($PIECE(RMPRBARC,"-",2),1,7)_"."_$EXTRACT($PIECE(RMPRBARC,"-",2),8,$LENGTH(RMPRBARC))
+16 ;
+17 ; look up current stock record with bar coded key fields
+18 SET RMPRERR=$$SCAN^RMPRPIUA(.RMPR7,.RMPREXC)
+19 IF $GET(RMPR7("IEN"))=""
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("*** The Item scanned is not available, please update your inventory !!!")
GOTO SCAN1
+20 IF RMPRERR
DO SCANE
GOTO SCAN1
+21 SET RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
+22 IF RMPRERR
DO SCANE
GOTO SCAN1
+23 SET R1("DATE&TIME")=$GET(RMPR7I("DATE&TIME"))
+24 SET $PIECE(R1(0),U,8)=$GET(RMPR7I("UNIT"))
+25 ;
+26 ; set vars. for HCPCS
+27 KILL RMPR1,RMPR1I
+28 SET RMPR1("HCPCS")=RMPR7("HCPCS")
+29 SET RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
+30 IF RMPRERR
DO SCANE
GOTO SCAN1
+31 SET RMPRERR=$$HPETOI^RMPRPIX1(.RMPR1,.RMPR1I)
+32 IF RMPRERR
DO SCANE
GOTO SCAN1
+33 ;
+34 ; set vars. for Item
+35 KILL RMPR11,RMPR11I
+36 SET RMPR11("STATION")=RMPR("STA")
+37 SET RMPR11("HCPCS")=RMPR7("HCPCS")
+38 SET RMPR11("ITEM")=RMPR7("ITEM")
+39 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+40 IF RMPRERR
DO SCANE
GOTO SCAN1
+41 SET RMPRERR=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
+42 IF RMPRERR
DO SCANE
GOTO SCAN1
+43 IF RMPR11I("ITEM MASTER IEN")=""
Begin DoDot:1
+44 DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("This item is not associated with an IFCAP Item.")
DO WRITECTL^RMPVIO("!")
+45 DO WRITE^RMPVIO("Please use the Edit Inventory option before trying to issue this item.")
+46 DO WRITECTL^RMPVIO("!")
+47 QUIT
End DoDot:1
GOTO SCAN1
+48 ;S RMDAHC=RMPR1("IEN")
+49 DO CPT(RMDAHC_"^"_$PIECE(R1(0),U,4)_"^"_RMPR11I("SOURCE")_"^660")
+50 IF RMPREXC="T"
GOTO SCANX
+51 IF RMPREXC'=""
GOTO SCAN1
+52 ;
+53 ; get Vendor
+54 SET RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
+55 SET RMPR6("HCPCS")=RMPR7("HCPCS")
+56 SET RMPR6("SEQUENCE")=RMPR7("SEQUENCE")
+57 SET RMPRERR=$$GET^RMPRPIX6(.RMPR6)
+58 IF RMPRERR
DO SCANE
GOTO SCAN1
+59 SET RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
+60 IF RMPRERR
DO SCANE
GOTO SCAN1
+61 SET $PIECE(R1(0),U,9)=RMPR6("VENDOR IEN")
+62 SET $PIECE(R3("D"),U,9)=RMPR6("VENDOR")
+63 ;
+64 ; set vars for issue
+65 SET RMCPTC=""
+66 IF $GET(RMDAHC)
IF $DATA(^RMPR(661.1,RMDAHC,0))
SET RMCPTC=$PIECE(^RMPR(661.1,RMDAHC,0),U,4)
+67 SET $PIECE(R1(1),U,4)=RMDAHC
+68 SET $PIECE(R1(0),U,22)=$GET(RMCPTC)
+69 SET $PIECE(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
+70 SET (RMHCNEW,RMHCDA)=RMDAHC
+71 SET RMITDA=RMPR11("IEN")
+72 SET RMHCPC=RMPR11("HCPCS")
+73 SET RMIT=RMPR11("HCPCS-ITEM")
+74 SET RDESC=RMPR1("SHORT DESC")
+75 SET $PIECE(R3("D"),U,14)=RMPR11("SOURCE")
+76 SET RMSO=RMPR11I("SOURCE")
+77 SET $PIECE(R1(0),U,14)=RMSO
+78 SET $PIECE(R3("D"),U,6)=RMPR11("ITEM MASTER")
+79 SET $PIECE(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
+80 SET $PIECE(R1(2),U,1)=RMIT
+81 SET $PIECE(R1(2),U,2)=RMPR11("DESCRIPTION")
+82 SET RMLOC=RMPR7I("LOCATION")
SET RMUBA=0
SET RMPR11("ITEM")=$PIECE(RMIT,"-",2)
+83 SET RMPR11("LOCATION")=RMLOC
SET RMPR11("STATION")=RMPRSTN
+84 IF '$GET(RMPR11("LOCATION"))
SET RMUBA=RMPR7("QUANTITY")
+85 if '$GET(RMUBA)
SET RMUBA=$$BAL^RMPRPIX7(.RMPR11)
+86 SET RMITQTY=RMPR7("QUANTITY")
+87 KILL RMPR5
+88 SET RMPR5("IEN")=RMLOC
+89 SET RMPRUCST=RMPR7("VALUE")/RMPR7("QUANTITY")
+90 SET $PIECE(R1(0),U,16)=$JUSTIFY(RMPRUCST,0,2)
+91 SET $PIECE(R3("D"),U,16)=$JUSTIFY(RMPRUCST,0,2)
+92 ;qty.
SET $PIECE(R1(0),U,7)=1
+93 ;serial num
SET $PIECE(R1(0),U,11)=""
+94 ;lot num
SET $PIECE(R1(0),U,24)=""
+95 ;remarks
SET $PIECE(R1(0),U,18)=""
SCANX QUIT
SCANE DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("A problem has occurred with the scan, please try again.")
DO WRITECTL^RMPVIO("!")
+1 QUIT
+2 ;
+3 ;***** CPT - prompt for CPT modifier
+4 ; (extension of RMPRPIYI and to be used only by that routine)
CPT(RDA) ;
+1 NEW DIC,Y,RQUIT,X,DA,DIR,DUOUT,DTOUT
+2 NEW RMPR1,RMPR11,RMPR11I,RMPR7,RMPR7I
+3 SET RMPREXC=""
+4 if $DATA(RMCPT)
DO CHK^RMPRED5
+5 if $GET(REDIT)
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("OLD CPT MODIFIER: ")
DO WRITE^RMPVIO($PIECE(R1(1),U,6))
+6 IF RMHCOLD'=RMDAHC
DO CPT^RMPRCPTU(RDA)
+7 IF $DATA(DUOUT)
SET RMPREXC="^"
GOTO CPTX
+8 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO CPTX
+9 SET $PIECE(R1(1),U,6)=$GET(RMCPT)
+10 if $GET(REDIT)
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("NEW CPT MODIFIER: ")
DO WRITE^RMPVIO($GET(RMCPT))
+11 IF RMHCOLD'=""
IF (RMHCOLD=RMDAHC)
IF $GET(REDIT)
Begin DoDot:1
+12 SET DIR(0)="Y"
SET DIR("A")="Would you like to Edit CPT MODIFIER Entry "
SET DIR("B")="N"
DO %DIR^RMPVFM
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+13 IF $GET(Y)
Begin DoDot:2
+14 DO CPT^RMPRCPTU(RDA)
+15 IF $DATA(DUOUT)
SET RMPREXC="^"
+16 IF $DATA(DTOUT)
SET RMPREXC="T"
+17 if RMCPT=$PIECE(R1(1),U,6)
DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("***Based on the information given above, CPT modifier string has not changed!!!")
DO WRITECTL^RMPVIO("!")
+18 if RMCPT'=$PIECE(R1(1),U,6)
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("NEW CPT MODIFIER: ")
DO WRITE^RMPVIO($GET(RMCPT))
+19 SET $PIECE(R1(1),U,6)=$GET(RMCPT)
End DoDot:2
End DoDot:1
CPTX QUIT
UPCASE(RMPRSTR) ;
+1 QUIT $TRANSLATE(RMPRSTR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
