source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR5NTU.m@ 899

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

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1RMPR5NTU ;HIN/RVD-PROS INVENTORY TRANS/UPDATE UTILITY ;2/11/98
2 ;;3.0;PROSTHETICS;**33,34,37**;Feb 09, 1996
3 D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
4 W @IOF
5 ;
6TRAN ;ask for Location.
7 S X="NOW" D ^%DT S RMDAT1=Y D DD^%DT S RMDAT=Y
8 K DTOUT,DUOUT,DIC("B")
9 W !!,"Transferring Item Quantity to Another LOCATION....."
10 S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
11 S DIC="^RMPR(661.3,",DIC(0)="AEQM"
12 ;I $D(^RMPR(661.3,"B")) D DQ^DICQ
13 S D="B",DIC("A")="From Location: " D MIX^DIC1
14 G:Y'>0!$D(DTOUT)!$D(DUOUT) EXIT
15 S (RMLOFDA,RMLODA)=+Y,(RMLOC,RMLOF)=$P(^RMPR(661.3,+Y,0),U,1) K DIC("S"),DIC("B")
16 S DA(1)=RMLOFDA,DIC="^RMPR(661.3,"_DA(1)_",1,"
17 ;
18THCPCS ;ask for HCPCS to transfer.
19 S DIC("A")="Enter HCPCS to Transfer: " K DTOUT,DUOUT,DIC("S"),DIC("B")
20 S DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?25,$P($G(^RMPR(661.1,RZ,0)),U,2)"
21 S DIC="^RMPR(661.3,"_RMLODA_",1,",DA(1)=RMLODA D ^DIC
22 I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." G TRAN
23 S RMHCFDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
24 S DIC(0)="ANEMQ",DA(1)=RMHCFDA,DA(2)=RMLOFDA
25 S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
26 ;
27LIST ;ask for PSAS Item to transfer.
28 ;I $D(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,"B")) S DZ="??",D="B" D DQ^DICQ
29 ;S DIC("B")=$O(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,"B",0))
30 S DIC("A")="Enter item to transfer: " D ^DIC
31 G:(+Y'>0)!$D(DTOUT)!$D(DUOUT) TRAN
32 L +^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,+Y):2
33 I '$T W !,"Record in use. Try again later..." G TRAN
34 S RMITFDA=+Y,RMIT=$P(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,+Y,0),U,1)
35 S RMDAFIT=$P(RMIT,"-",2)
36 S RM3=^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0)
37 S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9),RMAV=$P(RM3,U,10)
38 ;
39TRANQ ;ask for Quantity to transfer.
40 S RMQTY=0 R !,"Enter Quantity to transfer: ",RMQTY:DTIME
41 I $D(DTOUT)!($D(DUOUT))!(RMQTY="^") W !,"*** Nothing transferred ..." G EXIT
42 I RMQTY["?"!(RMQTY<.0001) W $C(7),!!,"Current balance is = ",RMBA W:RMBA>0 !,"Enter quantity 1 to ",RMBA," or" W " enter '^' to QUIT? " G TRANQ
43 I RMQTY>RMBA W !!,$C(7),"Quantity to transfer is greater than current balance.." G TRANQ
44 ;
45TRANT ;ask for forwarding Location.
46 S DIC("S")="I $D(^RMPR(661.3,""C"",RMDAHC,+Y)),($P(^RMPR(661.3,+Y,0),U,1)'=RMLOF)"
47 S DZ="??",D="B"
48 S DIC="^RMPR(661.3,",DIC(0)="AEQM"
49 S DIC("A")="Enter Receiving Location: ",DIC="^RMPR(661.3," K DIC("B")
50 S DIC(0)="AEQ",D="B" D MIX^DIC1
51 I $D(DTOUT)!($D(DUOUT)) W !,"*** Nothing transferred ..." G EXIT
52 G:Y'>0 TRANT
53 S RMLORDA=+Y
54 I RMLOFDA=RMLORDA W !,$C(7),"***Forwarding and Receiving Location is the same!!!!" G TRANT
55 ;
56TRANI S RMHCRDA=$O(^RMPR(661.3,RMLORDA,1,"B",RMDAHC,0))
57 S RMDARHC=$P(^RMPR(661.3,RMLORDA,1,RMHCRDA,0),U,1)
58 ;ask/enter forwarding item
59 S DIC(0)="ANEMQ",DA(1)=RMHCRDA,DA(2)=RMLORDA K DIC("S")
60 S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
61 S DIC("A")="Enter Receiving Item: " D ^DIC
62 G:(+Y'>0)!$D(DTOUT)!$D(DUOUT) EXIT
63 L +^RMPR(661.3,RMLORDA,1,RMHCRDA,1,+Y):2
64 I '$T W !,"Record in use. Try again later..." G TRANI
65 S RMITRDA=+Y,RMIT=$P(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,+Y,0),U,1)
66 ;
67 S RMTO=$G(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0))
68 S RMBAR=$P(RMTO,U,2),RMBAR=RMBAR+RMQTY,RMCOR=RMAV*RMBAR
69 S RMLOR=$P(^RMPR(661.3,RMLORDA,0),U,1)
70 S RMFR=$G(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0))
71 S RMBAF=$P(RMFR,U,2),RMBAF=RMBAF-RMQTY,RMCOF=RMAV*RMBAF
72 W !,"Quantity ",RMQTY," was transferred from ",RMLOF," to ",RMLOR
73 S $P(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0),U,2)=RMBAF
74 S $P(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0),U,2)=RMBAR
75 S $P(^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA,0),U,3)=RMCOF
76 S $P(^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA,0),U,3)=RMCOR
77 S RMRSTA=$P($G(^RMPR(661.3,RMLORDA,0)),U,3)
78 ;
79STAT ;create transfer stat for an item
80 D BAL^RMPR5NU1
81 L -^RMPR(661.3,RMLORDA,1,RMHCRDA,1,RMITRDA)
82 L -^RMPR(661.3,RMLOFDA,1,RMHCFDA,1,RMITFDA)
83 S DIC="^RMPR(661.2,",DLAYGO=661.2,X=RMDAT1,DIC(0)="L" K DD,DO
84 D FILE^DICN G:Y'>0 TRAN S DA=+Y
85 S RMMES="QTY "_RMQTY_" transferred from "_$E(RMLOF,1,8)_" to "_$E(RMLOR,1,8)
86 S ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMES_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLORDA_"^"_$J(RMAVA,0,2)
87 S DIK=DIC D IX1^DIK
88 I RMPR("STA")'=RMRSTA D
89 .S RMFSTA=RMPR("STA"),RMPR("STA")=RMRSTA D BAL^RMPR5NU1
90 .S DIC="^RMPR(661.2,",DLAYGO=661.2,X=RMDAT1,DIC(0)="L" K DD,DO
91 .D FILE^DICN G:Y'>0 TRAN S DA=+Y
92 .S RMMES="QTY "_RMQTY_" transferred from "_$E(RMLOF,1,8)_" to "_$E(RMLOR,1,8)
93 .S ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMES_"^"_$J(RMTOCO,0,2)_"^"_RMRSTA_"^"_RMLORDA_"^"_$J(RMAVA,0,2)
94 .S RMPR("STA")=RMFSTA
95 .S DIK=DIC D IX1^DIK
96 W !,"*** Item was transferred..."
97 H 1 G TRAN
98 ;
99UPD ;update current inventory item balance.
100 W @IOF
101UPD1 W !!,"Updating Item in a Location.....",!
102 D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
103 S X="NOW" D ^%DT S RMDAT1=Y D DD^%DT S RMDAT=Y K DTOUT,DUOUT,DIC("B")
104 S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
105 S DIC="^RMPR(661.3,",DIC(0)="AEQM"
106 ;I $D(^RMPR(661.3,"B")) D DQ^DICQ
107 S DIC("A")="Enter Pros Location: "
108 D MIX^DIC1 G:(+Y'>0)!($D(DTOUT))!$D(DUOUT) EXIT S RMLODA=+Y
109 S RMLOC=$P(^RMPR(661.3,+Y,0),U,1)
110 ;
111HCPC S DA(1)=RMLODA,DIC="^RMPR(661.3,"_DA(1)_",1," K DTOUT,DUOUT
112 K DTOUT,DUOUT,DIC("S"),DIR
113 S DIC("A")="Select HCPCS to Update: "
114 S DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?25,$P($G(^RMPR(661.1,RZ,0)),U,2)"
115 S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
116 I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." G UPD1
117 S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
118 ;
119ITEM ;
120 S DIC(0)="ANEMQ",DA(1)=RMHCDA,DA(2)=RMLODA
121 S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
122 G:'$D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B")) HCPC
123 ;I $D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B")) S DZ="??",D="B" D DQ^DICQ
124 S DIC("B")=$O(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",0))
125 S DIC("A")="Enter ITEM to Update: " D ^DIC K DIC("B")
126 G:(+Y'>0)!($D(DTOUT))!$D(DUOUT) HCPC S RMITDA=+Y
127 L +^RMPR(661.3,RMLODA,1,RMHCDA,1,+Y):2
128 I '$T W !,"Record in use. Try again later..." G ITEM
129 S RMIT=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,1)
130 S RMHCPC=$P(RMIT,"-",1),RMDAIT=$P(RMIT,"-",2)
131 S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
132 S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMUNI=$P(RM3,U,4),RMSOB=$P(RM3,U,9)
133 S RMRORA=$P(RM3,U,6),RMDIIA=$P(RM3,U,7),RMVENA=$P(RM3,U,5)
134 S DA(2)=RMLODA,DA(1)=RMHCDA,DA=RMITDA
135 S DIE="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
136 S DR="29R" D ^DIE
137 I $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,9)="C" S DR="22R;24;25R;26;27"
138 E S DR="22R;24;27"
139 D ^DIE
140 S (RMAVD,RMBAD,RMCOD)=0
141 S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
142 S RMBAA=$P(RM3,U,2),RMSO=$P(RM3,U,9),RMAVA=$P(RM3,U,10)
143 S RMRORAA=$P(RM3,U,6),RMDIIAA=$P(RM3,U,7),RMVENAA=$P(RM3,U,5)
144 S RMUNIA=$P(RM3,U,4)
145 I RMBAA=RMBA,RMRORA=RMRORAA,RMDIIA=RMDIIAA,RMVENA=RMVENAA,RMSO=RMSOB,RMUNI=RMUNIA W !,"*** Nothing updated...." G UPD1
146 S:RMBA'=RMBAA RMBAD=RMBAA-RMBA S RMCOA=RMBAA*RMAVA
147 S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
148 ;
149STATUPD ;create UPDATE stat for an item
150 D BAL^RMPR5NU1
151 L -^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA)
152 S DIC="^RMPR(661.2,",DLAYGO=661.2,X=RMDAT1,DIC(0)="L" K DD,DO
153 D FILE^DICN G:Y'>0 UPD1 S DA=+Y
154 S RMMESF="QTY updated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_":"
155 S ^RMPR(661.2,DA,0)=RMDAT1_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMBAD_"^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
156 W !,"*** Item was updated..."
157 S DIK=DIC D IX1^DIK
158 H 1 G UPD1
159 ;
160EXIT ;MAIN EXIT POINT
161 N RMPRSITE,RMPR D KILL^XUSCLEAN
162 Q
Note: See TracBrowser for help on using the repository browser.