- 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"))
- W @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 W !!,"Print Bar code Labels for current inventory...",!
- 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
- . W !,"** 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 W !!,"HCPCS: "_RMPR1("HCPCS")_" "_RMPR1("SHORT DESC")
- W !!,"IFCAP Item: ",RMPR11("ITEM MASTER")
- W !!,"PIP Item desc.: ",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
- . W !,"This item is not currently in stock.",!!
- . 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")
- W ! 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 W ! D ^%ZIS G:POP PRINTX
- I $G(IOST)'["P-ZEBRA" D
- . W !!,"** WARNING - This is NOT a Zebra Bar Code Printer!!",!!
- 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 W:$D(ZTSK) !,"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
- 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 W "Type in the number of bar code labels you want to print for the",!
- W "inventory item you have selected.",!
- 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
- 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 W "If you have access to a bar code scanner, use it to scan the item bar code now.",!
- W "Don't press the [Enter] key as the scanner should do this automatically.",!
- W "If the scanner cannot read the bar code, type in the character sequence",!
- W "immediately below the bar code.",!
- ;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,"-")="" W !,"** 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) W !,"** 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"))="" W !,"*** 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
- . 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
- ;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 W !,"A problem has occurred with the scan, please try again.",!
- 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
- W:$G(REDIT) !,"OLD CPT MODIFIER: ",$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)
- 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
- ..D CPT^RMPRCPTU(RDA)
- ..I $D(DUOUT) S RMPREXC="^"
- ..I $D(DTOUT) S RMPREXC="T"
- ..W:RMCPT=$P(R1(1),U,6) !!,"***Based on the information given above, CPT modifier string has not changed!!!",!
- ..W:RMCPT'=$P(R1(1),U,6) !,"NEW CPT MODIFIER: ",$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[HRMPRPIYS 9929 printed Feb 19, 2025@00:03:43 Page 2
- 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 WRITE @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 WRITE !!,"Print Bar code Labels for current inventory...",!
- 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 WRITE !,"** 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 WRITE !!,"HCPCS: "_RMPR1("HCPCS")_" "_RMPR1("SHORT DESC")
- +1 WRITE !!,"IFCAP Item: ",RMPR11("ITEM MASTER")
- +2 WRITE !!,"PIP Item desc.: ",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 WRITE !,"This item is not currently in stock.",!!
- +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 WRITE !
- 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
- WRITE !
- DO ^%ZIS
- if POP
- GOTO PRINTX
- +2 IF $GET(IOST)'["P-ZEBRA"
- Begin DoDot:1
- +3 WRITE !!,"** WARNING - This is NOT a Zebra Bar Code Printer!!",!!
- 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)
- WRITE !,"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
- +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 WRITE "Type in the number of bar code labels you want to print for the",!
- +1 WRITE "inventory item you have selected.",!
- +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
- +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 WRITE "If you have access to a bar code scanner, use it to scan the item bar code now.",!
- +1 WRITE "Don't press the [Enter] key as the scanner should do this automatically.",!
- +2 WRITE "If the scanner cannot read the bar code, type in the character sequence",!
- +3 WRITE "immediately below the bar code.",!
- +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,"-")=""
- WRITE !,"** 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)
- WRITE !,"** 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"))=""
- WRITE !,"*** 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 WRITE !,"This item is not associated with an IFCAP Item.",!
- +45 WRITE "Please use the Edit Inventory option before trying to issue this item."
- +46 WRITE !
- +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 WRITE !,"A problem has occurred with the scan, please try again.",!
- +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)
- WRITE !,"OLD CPT MODIFIER: ",$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)
- WRITE !,"NEW CPT MODIFIER: ",$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
- 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)
- WRITE !!,"***Based on the information given above, CPT modifier string has not changed!!!",!
- +18 if RMCPT'=$PIECE(R1(1),U,6)
- WRITE !,"NEW CPT MODIFIER: ",$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")