source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYT.m@ 1274

Last change on this file since 1274 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1RMPRPIYT ;HINCIO/ODJ - TR - Transfer Items ;3/8/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ;***** TR - Replaces TR option in old PIP (RMPR5NTU)
6 ; Callable from VISTA menu, no vars required other than
7 ; global VISTA vars (DUZ, etc)
8TR N RMPRERR,RMPRSTN,RMPREXC,RMPR5F,RMPR5T,RMPR1,RMPR11,RMPR,RMPRQTY
9 N RMPRVI,RMPRVO,RMPRVNDR,RMPROVAL,RMPRLCN,RMPR6,RMPR7
10 ;
11 ;***** STN - Prompt for Station
12STN S RMPROVAL=$G(RMPRSTN("IEN"))
13 W @IOF S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
14 I RMPRERR G TRX
15 I RMPREXC'="" G TRX
16 I RMPROVAL'=RMPRSTN("IEN") K RMPR1,RMPR11
17 ;
18 ;***** HCPCS - prompt for HCPCS and Item
19HCPCS W !!,"Transfer item quantity to another location.",!
20HCPCS2 D HCPCS^RMPRPIY7(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
21 I RMPREXC="T" G TRX
22 I RMPREXC="P" G STN
23 I RMPREXC="^" D G TRX
24 . W !,"** No HCPCS selected." H 1
25 . Q
26 ;I $G(RMPR11("IEN"))'="" D G QTY
27HCPCS3 D ITEM^RMPRPIYP(RMPRSTN("IEN"),RMPR1("HCPCS"),.RMPR11,.RMPREXC)
28 I RMPREXC="T" G TRX
29 I RMPREXC="P"!(RMPREXC="^") G HCPCS
30 S RMPR11("STATION")=RMPRSTN("IEN")
31 S RMPR11("STATION IEN")=RMPRSTN("IEN")
32 ;
33 ; display selected HCPCS and item and continue
34HCPCS4 W !!,"HCPCS: "_$G(RMPR1("HCPCS"))_" "_$G(RMPR1("SHORT DESC"))
35 W !!,"IFCAP Item: ",$G(RMPR11("ITEM MASTER"))
36 W !!,"PIP Item desc.: ",$G(RMPR11("DESCRIPTION"))
37 ;
38 ;***** CURST - call prompt for current stock record
39CURST S RMPRLCN=""
40 D PVEN^RMPRPIYR(RMPRSTN("IEN"),.RMPRLCN,RMPR11("HCPCS"),RMPR11("ITEM"),.RMPR6,.RMPR7,.RMPREXC)
41 I RMPREXC="T" G TRX
42 I RMPREXC="P" W ! G HCPCS2
43 I RMPREXC="^" G HCPCS
44 S RMPR5F("IEN")=RMPRLCN
45 S RMPRERR=$$GET^RMPRPIX5(.RMPR5F)
46 S RMPR5F("STATION IEN")=RMPRSTN("IEN")
47 S RMPR5T("STATION IEN")=RMPRSTN("IEN")
48 S RMPR5F("STATION")=RMPRSTN("IEN")
49 W !
50 ;
51 ;***** QTY - Prompt for Quantity
52QTY S RMPRERR=$$QTY^RMPRPIYU(.RMPRQTY,.RMPREXC,.RMPR5F,.RMPR11)
53 I RMPREXC="T" G TRX
54 I RMPREXC="^" G HCPCS
55 I RMPREXC="P" G CURST
56 ;
57 ;***** TLOCN - Prompt for 'TO' Location
58TLOCN D LOCNM^RMPRPIYU(RMPRSTN("IEN"),.RMPR5T,.RMPREXC)
59 I RMPREXC="^" G HCPCS
60 I RMPREXC="T" D G TRX
61 . W !,"*** Nothing transferred."
62 . H 1
63 . Q
64 I RMPREXC="P" G QTY
65 S RMPR5T("STATION")=RMPRSTN("IEN")
66 I RMPR5F("IEN")=RMPR5T("IEN") D G TLOCN
67 . W !
68 . W "*** Forwarding and Receiving Location is the same!!!!"
69 . Q
70 ;
71 ;***** TRANS - Now create a transfer transaction
72TRANS S RMPR11("STATION")=RMPRSTN("IEN")
73 S RMPR("QUANTITY")=RMPRQTY
74 S RMPR("USER")=$G(DUZ)
75 S RMPR("IEN")=$G(RMPR5T("IEN"))
76 S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
77 S RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
78 I RMPRERR=1 G HCPCS
79 S RMPR("VENDOR IEN")=RMPR6("VENDOR IEN")
80 S RMPR5F("UNIT")=RMPR7I("UNIT")
81 S RMPR5T("UNIT")=RMPR7I("UNIT")
82 S RMPRERR=$$TRNF^RMPRPIUT(.RMPR,.RMPR5F,.RMPR5T,.RMPR11)
83 I RMPRERR=1 D G QTY
84 . W !
85 . W "Quantity to transfer is greater than current balance: "
86 . W RMPR("QOH")
87 . Q
88 I RMPRERR D G TRX
89 . W !
90 . W "There were problems with the transfer, please contact support"
91 . H 3
92 . Q
93 W !
94 W "QTY "_RMPRQTY_" transferred from "_RMPR5F("NAME")_" to "_RMPR5T("NAME")
95 H 1
96 K RMPR5F,RMPR5T,RMPRQTY,RMPR,RMPR6,RMPR7
97 G HCPCS
98TRX D KILL^XUSCLEAN
99 Q
Note: See TracBrowser for help on using the repository browser.