source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR5NOR.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.5 KB
Line 
1RMPR5NOR ;HIN/RVD-PROS INVENTORY ORDER/RECEIVE UTILITY ;2/11/98
2 ;;3.0;PROSTHETICS;**33,37,46**;Feb 09, 1996
3 D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
4 S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
5 ;
6 W @IOF
7LOC ;ask for location
8 W !!,"Ordering ITEM from Supply or Vendor....",! K DTOUT,DUOUT,DIC("B")
9 S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
10 S DIC="^RMPR(661.3,",DLAYGO=661.3,DIC(0)="AEQM"
11 S D="B",DIC("A")="Enter Pros Location: " D MIX^DIC1
12 G:$D(DTOUT)!(Y'>0)!$D(DUOUT) EXIT S (DA,RMLODA)=+Y,DIK=DIC
13 S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1)
14 I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
15 ;
16LIST ;list current HCPCS @ this Location
17 K DTOUT,DUOUT,DIC("S"),DIC("B")
18 S DIC("A")="Select HCPCS to ORDER: "
19 ;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
20 ;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) LOC
21 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)"
22 S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
23 I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." G LOC
24 S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
25 ;
26L ;list current ITEM for this HCPCS
27 K DTOUT,DUOUT,DIC("S")
28 S DA(2)=RMLODA,DA(1)=RMHCDA
29 S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
30 S DIC("A")="Enter Item to ORDER: "
31 S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
32 D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LIST S RMITDA=+Y
33 S (RMITFLG,RMHCFLG,RMAV,RMAVA,RMCO,RMBAL)=0
34 S RMIT=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,1)
35 S RMDAIT=$P(RMIT,"-",2)
36 S RMITEM=$P(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
37 S RMORD=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
38 ;
39ORDER ;order item from vendor or supply.
40 K DIR,Y S DIR(0)="661.312,31",DIR("A")="Quantity to Order" D ^DIR
41 I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G LOC
42 I X="" W $C(7),!,"Enter quantity 1 to 99999.." G ORDER
43 S RMORDER=Y K DIR,Y
44 S DIE="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
45 S DA=RMITDA,DR="31////^S X=$G(RMORDER)" D ^DIE
46 S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
47 S RMSO=$P(RM3,U,9)
48 D BAL^RMPR5NU1
49 S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
50 D FILE^DICN K DLAYGO S RMCOM="Order from supply or vendor"
51 S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^"_RMORDER_"^^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2) S DA=+Y,DIK=DIC D IX1^DIK K Y
52 W !,"*** Item ",RMITEM," was ordered...."
53 H 1 G LOC
54 ;
55REC ;receive item from supply, Vendor or Returned Item.
56 W @IOF
57 D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
58 S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
59 S X="NOW" D ^%DT S RMDAT1=Y D DD^%DT S RMDAT2=Y
60REC1 W !!,"*** Receiving Item from Supply, Vendor or Veteran...",!
61 K DTOUT,DUOUT,DIC("B")
62 S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
63 S DIC="^RMPR(661.3,",DIC(0)="AEQM"
64 S D="B",DIC("A")="Enter Receiving Location: " D MIX^DIC1
65 G:$D(DTOUT)!(Y'>0)!$D(DUOUT) EXIT S (DA,RMLODA)=+Y,DIK=DIC
66 S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1)
67 I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
68 ;
69LITEM ;list current HCPCS @ this Location
70 K DTOUT,DUOUT,DIC("S"),DIC("B")
71 S DIC("A")="Select HCPCS to RECEIVE: "
72 ;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
73 ;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) REC1
74 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)"
75 S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
76 I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." H 1 G REC1
77 S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
78 ;
79 ;list current ITEM for this HCPCS
80 K DTOUT,DUOUT,DIC("S"),DIC("B")
81 S DA(2)=RMLODA,DA(1)=RMHCDA
82 S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
83 S DIC("A")="Enter Item to RECEIVE: "
84 S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
85 D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LITEM
86 S RMITDA=+Y
87 ;S RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0),RMITEM=$P(RM1,U,1)
88 S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),RMIT=$P(RM3,U,1)
89 S RMQU=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9)
90 ;
91 ;update LOCATION.
92UPDLOC ;W ! S DIC("A")="Receiving LOCATION: ",DIC="^RMPR(661.3,",DLAYGO=661.3
93 ;
94UPDQ R !,"Quantity to Receive: ",RMQTREC:DTIME
95 G:$D(DTOUT)!$D(DUOUT)!(RMQTREC="^") MESS
96 I RMQTREC["?"!(RMQTREC'>0)!(RMQTREC>999) W $C(7),!,"Enter quantity 1 to 999.." G UPDQ
97 ;
98UPDC ;ask for total Item cost
99 K DIR,Y,DA S DIR(0)="661.312,23",DIR("A")="Total Cost of Item " D ^DIR
100 G:$D(DUOUT)!$D(DTOUT) MESS
101 I X="" W $C(7),!,"Enter Cost 0 to 999999.." G UPDC
102 S RMCOREC=Y K DIR,Y
103 S RMCOA=RMCO+RMCOREC
104 S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
105 S RMQUA=RMQU+RMQTREC
106 I RMQUA>0 S RMAVA=RMCOA/RMQUA
107 I RMQUA<1 S RMAVA=RMCOREC/RMQTREC
108 S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$J(RMAVA,0,2)
109 S RMORD=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
110 ;
111 ;update Total Item Cost and delete ordered date
112 S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,2)=RMQUA
113 S RMSO=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,9)
114 ;
115STAT D BAL^RMPR5NU1
116 S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
117 D FILE^DICN K DLAYGO S RMCOM="Received from supply or vendor"
118 S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQTREC_"^"_RMIT_"^^"_RMQTREC_"^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
119 S DA=+Y,DIK=DIC D IX1^DIK
120 W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLODA,0),U,1)," is now: ",RMQUA
121 I RMORD S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)=RMORD-RMQTREC
122 H 1 G REC1
123 ;
124MESS W !,"Nothing Received....."
125EXIT ;MAIN EXIT POINT
126 N RMPRSITE,RMPR D KILL^XUSCLEAN
127 Q
Note: See TracBrowser for help on using the repository browser.