source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSTE.m

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

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1RMPRSTE ;HINCIO/RVD-ISSUE FROM STOCK / CONT. ;11/06/00
2 ;;3.0;PROSTHETICS;**53,62,78**;Feb 09, 1996
3 ;modified for cpt modifier
4 ;RVD patch #62 - modified for PCE interface.
5 ;TH Patch #78 - Add Date of Service/Shipment Date
6 ;Per VHA Directive 10-93-142, this routine should not be modified.
7NEX K DIR,Y,X
8 S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7)
9 S $P(R3("D"),U,16)=RMPRUCST*$P(R1(0),U,7)
10QTY K DIR,Y S DIR(0)="660,5" S:$P(R1(0),U,7) DIR("B")=$P(R1(0),U,7)
11 D ^DIR I $P(R1(0),U,7)'=""&$D(DUOUT) G LIST
12 I $D(DTOUT) X CK2 G ^RMPRSTI
13 I $D(DIRUT) G LOC^RMPRSTI
14 I $G(RMUBA),((RMUBA-Y)<0) D LOWBA^RMPRSTI G LOC^RMPRSTI
15 S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRUCST K DIR
16 ;SET DELIVERY DATE to today
17 ;
18DATE ;delivery date and date of service/shipment date is set to today's date
19 S $P(R1(0),U,12)=DT,$P(R1(1),U,8)=DT,Y=DT D DD^%DT S $P(R3("D"),U,12)=Y
20LI S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11)
21 D ^DIR I $D(DTOUT) X CK1 Q
22 G:$D(DUOUT) LIST
23 I X["^" W !,"Jumping not allowed" G LI
24 I $P(R1(0),U,11)'=""&(X="@") S $P(R1(0),U,11)="" W $C(7),!?5,"Deleted..." H 1 G LOT
25 S $P(R1(0),U,11)=X
26 ;
27LOT ;
28 ;
29 K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24)
30 D ^DIR I $D(DTOUT) X CK1 Q
31 G:$D(DUOUT) LIST
32 I X["^" W !,"Jumping not allowed" G LOT
33 I $P(R1(0),U,24)'=""&(X="@") S $P(R1(0),U,24)="" W $C(7),!?5,"Deleted..." H 1 G REMA
34 S $P(R1(0),U,24)=X
35 ;
36REMA ;
37 ;
38 K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18)
39 D ^DIR I $D(DTOUT) X CK1 Q
40 G:$D(DUOUT) LIST
41 I X["^" W !,"Jumping not allowed" G REMA
42 I $P(R1(0),U,18)'=""&(X="@") S $P(R1(0),U,18)="" W $C(7),!?5,"Deleted..." H 1 G LIST
43 S $P(R1(0),U,18)=X
44 ;
45LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA
46 S RMDAHC=$P(R1(1),U,4)
47 D NODE2^RMPRSTI
48 D:$D(RMCPT) CHK^RMPRED5
49 D ^RMPRST2
50 K DIR,RQUIT
51 S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
52 S DIR("A")="Would you like to POST/EDIT/DELETE this entry"
53 S DIR("B")="P"
54 S DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"
55 D ^DIR K DIR G:Y="P" POST G:Y="D" DEA
56 I Y="E" S REDIT=1 G 1^RMPRSTI
57 I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G ^RMPRSTI
58 ;
59DEA ;
60 K DIR
61 S DIR("A")="Are you sure you want to DELETE this entry"
62 S DIR("B")="N",DIR(0)="Y"
63 D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) X CK Q
64 I Y=1 W !!,$C(7),?50," Deleted..." H 2 K DIR G RES^RMPRSTI
65 G LIST
66 ;
67POST ;
68 ;
69 I RMPRG'="" G GGC
70 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
71 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1
72 S $P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
73GGC S $P(RMPRI("AMS"),U,1)=RMPRG,RMSER=$P(R1(0),U,11)
74 ;update inventory balance
75 I $G(RMLOC) S RMQTY=$P(R1(0),U,7) D ADD^RMPR5NU1 I $D(RQUIT) X CK Q
76 I '$D(RMLOC) X CK Q
77 S:$D(RMLOC) $P(R1(1),U,2)=RDESC,$P(R1(0),U,13)=11,$P(R1(1),U,5)=RM6612
78 ;
79 ;create 2319
80 K Y,DD,DO,DA S DIC="^RMPR(660,",DIC(0)="L",X=DT,DLAYGO=660
81 D FILE^DICN K DLAYGO
82 I Y'>0 W !,"** Error posting to 2319...entry deleted..." G RES^RMPRSTI
83 S ^RMPR(660,+Y,0)=R1(0),^(1)=R1(1),^("AM")=R1("AM"),^(2)=R1(2)
84 S $P(R1(1),U,8)=DT
85 S ^("AMS")=RMPRI("AMS")
86 I $D(RMLOC) MERGE ^RMPR(660,+Y,"DES")=^RMPR(661.1,RMDAHC,2) S $P(^RMPR(660,+Y,"DES",0),U,2)=""
87 S DIK="^RMPR(660,",(RM60,DA)=+Y D IX1^DIK K DIC
88 S ^TMP($J,"RMPRPCE",660,DA)=RMPRG_"^"_$G(RMPRDFN)
89 ;
90 W !,"Posted to 2319..." H 3
91 G RES^RMPRSTI
92 ;
93EXIT ;EXIT FOR STOCK ISSUES
94 K ^TMP($J)
95 N RMPRSITE,RMPR D KILL^XUSCLEAN
96 Q
97 ;
98ERR0 ;delete entry & print error message if posting fails.
99 ;K DIK
100 ;S DIK="^RMPR(660,",DA=RM60 D ^DIK
101 ;W !,"** Error posting to 2319...entry deleted...",!! H 3
102 ;Q
103 ;
104 ;
105INV1 I $P(R1(0),U,14)="C" S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7)
106 G QTY
Note: See TracBrowser for help on using the repository browser.