source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR5NU1.m@ 1700

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1RMPR5NU1 ;HIN/RVD-INVENTORY UPDATE UTILITY ;3/24/1998
2 ;;3.0;PROSTHETICS;**33,37,53**;Feb 09, 1996
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ADD ;add a new inventory stock record
5 K Y,DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN K DLAYGO S (RM6612,DA)=+Y
6 Q:'$D(RMLOC)
7 D UPD Q:$D(RQUIT)
8 S ^RMPR(661.2,DA,0)=DT_"^"_RMPRDFN_"^"_RMSO_"^"_RMDAHC_"^^"_RMSER_"^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^^"_RMTOBA_"^^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_$J(RMAVA,0,2)
9 S:$D(RMLAB) ^RMPR(661.2,DA,1)=RMTIME_"^"_$J(RMLACO,0,2)
10 S DIK="^RMPR(661.2," D IX1^DIK
11 Q
12 ;
13EDIT ;update the current balance.
14 S RMITEM=$O(^RMPR(661.1,"G",RMITEM,0))
15 Q:'$D(^RMPR(661.1,RMITEM,3))
16 D UPD
17 S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN G:Y'>0 EXIT S DA=+Y K DLAYGO,DIC,DIC(0),X
18 S RMMES="Issue from Stock was updated: ("
19 S ^RMPR(661.2,DA,0)=DT_"^^^^^^^"_RMQTY_"^"_RMITEM_"^^^"_RMBAL_"^"_RMMES_"^"_RMTOCO
20 S DIK="^RMPR(661.2," D IX1^DIK
21 Q
22 ;
23UPD ;update item current balance in 661.3
24 S RMAVCO=0
25 S RM3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
26 S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMAVCO=$P(RM3,U,10)
27 S RMBA=RMBA-RMQTY S RMCO=RMBA*RMAVCO
28 S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RMBA
29 S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,3)=RMCO
30 ;
31BAL ;get total cost of the same HCPCS and ITEM @ the same station.
32 S RS=RMPR("STA"),(RMTOBA,RMTOCO,RMAVA)=0
33 F RLO=0:0 S RLO=$O(^RMPR(661.3,"E",RS,RLO)) Q:RLO'>0 I $D(^RMPR(661.3,RLO,1,"B",RMDAHC)) S RHC=$O(^RMPR(661.3,RLO,1,"B",RMDAHC,0)) S RIT=$O(^RMPR(661.3,RLO,1,RHC,1,"B",RMIT,0)) D
34 .Q:'RIT
35 .S RENT=$G(^RMPR(661.3,RLO,1,RHC,1,RIT,0))
36 .S RMBAA=$P(RENT,U,2),RMCOA=$P(RENT,U,3),RMAVA=$P(RENT,U,10),RMSOA=$P(RENT,U,9)
37 .S RMTOBA=RMTOBA+RMBAA,RMTOCO=RMTOCO+RMCOA
38 S:RMTOBA RMAVA=RMTOCO/RMTOBA
39 Q
40 ;
41 ;RE = EDIT FLAG
42 ;RL =location
43 ;RH = hcpcs IEN (NEW)
44 ;RHO = hcpcs IEN (OLD)
45 ;RMLOC,RDESC,RMHCDA = variables created
46 ;
47ITEMLOC(RE,RL,RH,RHO) ;ASK for an Item Location.
48 ;
49 N X,Y,DIC,RMLOCC,RMHCC,RMHCC,RMHC,RMLO1,RMLLF,RMLCOUNT,DA
50 I '$D(^RMPR(661.3,"C",RH)) K RMLOC Q
51 S RMLLF=0,RMLOCC=0
52 S RMHCC=$P(^RMPR(661.1,RH,3,0),U,4) S:RMHCC=1 RMLLF=1
53 S RDESC=$P(^RMPR(661.1,RH,0),U,2)
54 S RMHC=$P(^RMPR(661.1,RH,0),U,1)
55 K Y,DIC("B")
56 ;
57LODIC S DIC("S")="I $D(^RMPR(661.3,+Y,1,""B"",RH)),$P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
58 S DIC("A")="Enter Inventory LOCATION: "
59 I $G(RE)&(RH=RHO) S DIC("B")=$P(^RMPR(661.3,RL,0),U,1)
60 S DIC="^RMPR(661.3,",DIC(0)="AENMQ"
61 D ^DIC K DIC
62 I $D(DUOUT)!$D(DTOUT)!$D(DIRUT) S RQUIT=1 Q
63 I +Y'>0 G LODIC
64 S RL=+Y
65 ;
66LOCPROC ;jump here if only one location
67 S RMLOC=RL
68 S RMHCDA=$O(^RMPR(661.3,RL,1,"B",RH,0))
69 Q
70 ;
71 ;RE = edit flag
72 ;RL = location NEW
73 ;RO = location old
74 ;RC = HCPCS entry in 661.3
75 ;RH = HCPCS NEW
76 ;RHO = HCPCS OLD
77 ;RI = PSAS-item#
78 ;RMDES,RMIT,RMITDA,RMITDES variables created
79ITEM(RE,RL,RO,RH,RHO,RC,RI) ;ask for PSAS ITEM
80 N Y,X,DIC,RMIIF,RMDAHC,RMHCPC,RMHC,RMUBA,RMU3,DA
81 ;
82ITDIC ;
83 I $G(RE)&(RL=RO)&(RH=RHO) S DIC("B")=$G(RI)
84 ;S DIC("S")="I $D(^RMPR(661.3,RL,1,RC,1,""B"",Y))"
85 S DA(2)=RL,DA(1)=RC
86 S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
87 S DIC(0)="AEMNQ",DIC("A")="Enter PSAS Item: " D ^DIC K DIC
88 I $D(DUOUT)!$D(DTOUT) S RQUIT=1 Q
89 I +Y'>0 G ITDIC
90 S RMITDA=+Y,(RMITDES,RMIT)=$P(^RMPR(661.3,RL,1,RC,1,+Y,0),U,1)
91 S RMU3=$G(^RMPR(661.3,RL,1,RC,1,RMITDA,0))
92 S RMDES=RMIT K DIC("B"),DIC("S")
93 S RMUBA=$P(RMU3,U,2)
94 I RMUBA<1 W !,$C(7),"*** ITEM BALANCE is LOW @ this Pros Location......",!,"*** Please ORDER the Item or UPDATE the Inventory Balance."
95 Q
96 ;
97DSP ;display HCPCS @ a LOCATION
98 K ^TMP($J) S (RCNT,RMPRI,REND)=0
99 S RMPRI=0 F S RMPRI=$O(^RMPR(661.3,RMLODA,1,RMPRI)) Q:RMPRI'>0 D
100 .S RMPRI1=$P(^RMPR(661.3,RMLODA,1,RMPRI,0),U,1),RMPRIT=$P(^RMPR(661.1,RMPRI1,0),U,1),^TMP($J,RMPRIT)=$P(^RMPR(661.1,RMPRI1,0),U,2)
101 I $D(^TMP($J)) W !,"List of HCPCS at location: ",RMLOC S RI="" F S RI=$O(^TMP($J,RI)) Q:RI=""!(REND) D
102 .S RCNT=RCNT+1
103 .I RCNT>16 R !,"Enter <RETURN> for more or ^ to STOP listing",RANS:DTIME S:$D(DTOUT)!$D(DUOUT)!(RANS="^") REND=1 S RCNT=0
104 .W !,RI,?12,^TMP($J,RI)
105LDIC I RFL S X="?",DIC=661.1,DIC(0)="EQM",DIC("W")="W "" "",$P(^RMPR(661.1,+Y,0),U,2) I $P(^RMPR(661.1,+Y,0),U,5)=0 W "" **Inactive HCPCS**""" D ^DIC K RFL
106 K ^TMP($J),RANS,RCNT,REND,RI,RMPRI,RMPRI1,RMPRIT
107 Q
108 ;
109VEND() ;
110 N RMU3
111 S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
112 S Y=$P(RMU3,U,5)
113 Q Y
114 ;
115 ;
116BALA() ;
117 N RMU3
118 S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
119 S Y=$P(RMU3,U,3)
120 Q Y
121 ;
122COST() ;
123 N RMU3
124 S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
125 S Y=$P(RMU3,U,10)
126 Q Y
127 ;
128SOURCE() ;
129 N RMU3
130 S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
131 S Y=$P(RMU3,U,9)
132 Q Y
133 ;
134CONV ;convert utility for Inventory Location field. (in CAPS)
135 S RJ=0,RMDAT=X,X=""
136PROC S RJ=RJ+1 Q:RJ>$L(RMDAT) S RA=$E(RMDAT,RJ,RJ),RB=$A(RA) D:(RB>96)&(RB<123) ST S:(RB<97)!(RB>123) RMC=RA S X=X_RMC G PROC
137ST S RC=RB-32,RMC=$C(RC)
138 Q
139 ;
140EXIT ;EXIT FOR INVENTORY UPDATE UTILITY
141 K DLAYGO,DUOUT,DTOUT,DIE,DIC,DA,DR,RMQTY,RMIEN,RMSO,RMLOC,RMBAL,RMPRIEN,RMITEM
142 Q
143NDX ;reindex the 'D1' cross-reference of file 661.3
144 S DIK(1)=".01^D1"
145 W !!,"Reindexing 'D1' cross reference of file #661.3...",!
146 F RI=0:0 S RI=$O(^RMPR(661.3,RI)) Q:RI'>0 F RJ=0:0 S RJ=$O(^RMPR(661.3,RI,1,RJ)) Q:RJ'>0 D
147 .F RK=0:0 S RK=$O(^RMPR(661.3,RI,1,RJ,1,RK)) Q:RK'>0 I $D(^(RK,0)) D
148 ..S DA(2)=RI,DA(1)=RJ,DA=RK,DIK="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
149 ..D EN1^DIK
150 K RI,RJ,RK,DIK,DA
151 Q
Note: See TracBrowser for help on using the repository browser.