source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYY.m@ 1354

RMPRPIYY ;HINCIO/ODJ - PIP EDIT - PROMPTS AND BARCODE ;3/8/01
 ;;3.0;PROSTHETICS;**61,132**;Feb 09, 1996;Build 13
 Q
 ; The following subroutines are for selecting Orders (661.41)
 ;
 ;***** OK - Prompt for an OK
OK(RMPRYN,RMPREXC) ;
 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
 S RMPREXC=""
 S RMPRYN="N"
 S DIR("A")="         ...OK"
 S DIR("B")="Yes"
 S DIR(0)="Y"
 D ^DIR
 I $D(DTOUT) S RMPREXC="T" G OKX
 I $D(DIROUT) S RMPREXC="P" G OKX
 I X=""!(X["^") S RMPREXC="^" G OKX
 S RMPRYN="N" S:Y RMPRYN="Y"
OKX Q
 ;
 ;***** PVEN - Prompt for an Open order
PORD(RMPRSTN,RMPRHCPC,RMPRITM,RMPR41,RMPREXC) ;
 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,DIRUT,RMPRA,RMPRGBLR,RMPRIEN1
 N RMPRMAX,RMPRLIN,RMPRGBL,RMPR41I,RMPRS,STS,RMPROCNT,RMPRIEN,RMPRD
 S (RMPRERR,RMPROCNT)=0
 S RMPREXC=""
 S RMPRMAX=15
 S RMPRLIN=0
 K RMPR41
 ;
 ; See if just 1 record - no need to list if there is
 ; Loop on open orders
 K RMPRORD,RMPRIEN1
 F STS="O","R" S RMPRD="" F  S RMPRD=$O(^RMPR(661.41,"ASSHID",RMPRSTN,STS,RMPRHCPC,RMPRITM,RMPRD)) Q:RMPRD=""  D  Q:RMPRERR
 . S RMPRIEN=""
 . F  S RMPRIEN=$O(^RMPR(661.41,"ASSHID",RMPRSTN,STS,RMPRHCPC,RMPRITM,RMPRD,RMPRIEN)) Q:RMPRIEN=""  D  Q:RMPRERR
 .. K RMPR41 S RMPR41("IEN")=RMPRIEN
 .. S RMPRERR=$$GET^RMPRPIXN(.RMPR41,)
 .. I RMPRERR S RMPRERR=99 Q
 .. I RMPR41("BALANCE QTY")<1 Q
 .. S RMPRORD(RMPRD,RMPRIEN)=STS,RMPRIEN1=RMPRIEN,RMPROCNT=RMPROCNT+1
 .. Q
 . Q
 I RMPROCNT=0 K RMPR41 G PORDX
 I RMPROCNT=1 S RMPR41("IEN")=RMPRIEN1 G PORDG
 ;
 ; Selection list of current stock records
PORDL1 S RMPRD=0
PORDL1A S RMPRD=$O(RMPRORD(RMPRD)) I RMPRD="" G:'RMPRLIN PORDX G PORDP
PORDL1B S RMPRIEN=$O(RMPRORD(RMPRD,RMPRIEN)) G:RMPRIEN="" PORDL1A
 K RMPR41,RMPR41I
 S RMPR41("IEN")=RMPRIEN
 S RMPR41I("IEN")=RMPR41("IEN")
 S RMPRERR=$$GETI^RMPRPIXN(.RMPR41I,)
 S RMPRERR=$$GET^RMPRPIXN(.RMPR41,)
 I RMPRLIN,'(RMPRLIN#RMPRMAX) D  G PORDP
 . S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
 . Q
PORDL2 S RMPRLIN=RMPRLIN+1
 I RMPRLIN=1 D PORDH
 S RMPRS=$P(RMPR41I("DATE ORDER"),".",1)
 W !,$J(RMPRLIN,2)," ",$E(RMPRS,4,5)_"/"_$E(RMPRS,6,7)_"/"_$E(RMPRS,2,3)
 W ?11,$J(RMPR41("ORDER QTY"),5,0)
 W ?18,$E(RMPR41("VENDOR"),1,30)
 I +RMPR41("RECEIVE QTY") D
 . W ?49,$J(RMPR41("RECEIVE QTY"),5,0)
 . S RMPRS=$P(RMPR41I("DATE RECEIVE"),".",1)
 . W "  ",$E(RMPRS,4,5)_"/"_$E(RMPRS,6,7)_"/"_$E(RMPRS,2,3)
 . Q
 S RMPRA(RMPRLIN)=RMPR41("IEN")
 K RMPR41,RMPR41I
 G PORDL1B
 ;
 ; Prompt for selection
PORDP S DIR(0)="FAO"
 S DIR("A")="Choose 1 - "_RMPRLIN_" : "
 D ^DIR
 I $D(DTOUT) S RMPREXC="T" G PORDX
 I $D(DIROUT) S RMPREXC="P" G PORDX
 I X="",$D(DIR("A",1)) K DIR("A",1) D PORDH G PORDL2
 I X="" S RMPREXC="^" G PORDX
 I X["^"!($D(DUOUT)) S RMPREXC="^" G PORDX
 I '$D(RMPRA(X)) D  G PORDP
 . W !,"Please select a stock order record"
 . W !,"by entering a line number in range 1 - "
 . W RMPRLIN
 . Q
 S RMPR41("IEN")=RMPRA(X)
PORDG K RMPR41I
 S RMPR41I("IEN")=RMPR41("IEN")
 S RMPRERR=$$GETI^RMPRPIXN(.RMPR41I,)
 S RMPRERR=$$GET^RMPRPIXN(.RMPR41,)
 S RMPR41("VENDOR IEN")=RMPR41I("VENDOR")
PORDX Q
PORDE() ;
 Q:$QS(RMPRGBL,1)'=661.41 1
 Q:$QS(RMPRGBL,2)'="ASSHID" 1
 Q:$QS(RMPRGBL,3)'=RMPRSTN 1
 Q:$QS(RMPRGBL,4)'="O" 1
 Q:$QS(RMPRGBL,5)'=RMPRHCPC 1
 Q:$QS(RMPRGBL,6)'=RMPRITM 1
 Q 0
PORDH W !
 W !,"Select a current stock order record, or ^ if not receiving against an order.",!
 W ?3,"Date",?13,"Qty",?18,"Vendor",?49,"Received"
 Q
 ;
 ;***** NLAB - call prompt for number of labels to print
NLAB S RMPRNLAB=RMPR6("QUANTITY")
 W ! D NLABP^RMPRPIYS(.RMPRNLAB,RMPR6("QUANTITY"),.RMPREXC)
 I RMPREXC="T" G RCX
 I RMPREXC="P" G RCNX
 I RMPREXC="^" G RCNX
 I RMPRNLAB=0 G RCNX
 ;
 ;***** SELP - call prompt for barcode print device
SELP ;
 I RMPREXC'="" G NLAB
 ;K RMPR7I
 ;S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
 S RMPRBARC=RMPR11("HCPCS")_"-"_$P(RMPR6("DATE&TIME"),".",1)_$P(RMPR6("DATE&TIME"),".",2)
 S RMPRITXT("DATE")=$E(RMPR6("DATE&TIME"),4,5)_"/"_$E(RMPR6("DATE&TIME"),6,7)_"/"_(1700+$E(RMPR6("DATE&TIME"),1,3))
 S RMPRITXT("ITEM")=RMPR11("HCPCS-ITEM")
 S RMPRITXT("ITEM DESC")=RMPR11("DESCRIPTION")
 S RMPRITXT("MASTER DESC")=RMPR11("ITEM MASTER")
 S RMPRITXT("UNIT PRICE")=RMPRUCST
 S RMPRITXT("VENDOR")=RMPRVEND("NAME")
 S RMPRITXT("LOCATION")=RMPR5("NAME")
 D PRINT^RMPRPIYS
RCNX ;K RMPR6,RMPRTVAL,RMPRQTY,RMPRUCST,RMPRBCP,RMPRQ,RMPRIOP,RMPRNLAB
 ;K RMPRBARC,RMPRITXT,RMPR41N,RMPR41,RMPRVEND
RCX Q