source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSTL.m@ 841

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

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1RMPRSTL ;PHX/RFM,RVD-ISSUE FROM STOCK ;8/29/1994
2 ;;3.0;PROSTHETICS;**14,28,33,41**;Feb 09, 1996
3 ;modified for cpt modifier
4 ;Per VHA Directive 10-93-142, this routine should not be modified.
5NEX K DIR,Y,X I $G(RMPRGIP) G INV1
6 I $P(R1(0),U,14)="C" S DIR(0)="667.3,3",DIR("A")="UNIT COST"
7 ;DISPLAY DEFAULT UNIT COST FOR NON-GIP ISSUES
8 ;
9 I S RO=0 I $O(^PRC(441,$P(R3("D"),U,6),2,RO))'="" D
10 .Q:'$D(^PRC(441,$P(R3("D"),U,6),2,$P(R1(0),U,9),0))
11 .S (RMPRUCST,DIR("B"))=$J($P(^PRC(441,$P(R3("D"),U,6),2,$P(R1(0),U,9),0),U,2)/$S($P(^(0),U,10)]"":$P(^(0),U,10),1:1),9,2),(RMPRUCST,DIR("B"))=$$STRIP^XLFSTR(RMPRUCST," ")
12 S:+$P(R1(0),U,16) DIR("B")=$P(R1(0),U,16)/$P(R1(0),U,7)
13 I $G(RMLOC),$G(RMHCDA),$G(RMITDA) S (DIR("B"),RMPRUCST)=$P($G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0)),U,10) G:RMPRUCST>0 QTY
14 I $P(R1(0),U,14)="C" D ^DIR K DIR I +$P(R1(0),U,16)&($D(DUOUT)) G LIST
15 I $D(DUOUT) X CK Q
16 I $D(DTOUT) X CK1 Q
17 I $P(R1(0),U,14)="C" S RMPRUCST=Y S:$P(R1(0),U,16) $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7) I $D(DIRUT) X CK Q
18 I $P(R1(0),U,6)="C" S $P(R1(0),U,16)=Y,$P(R3("D"),U,16)=Y
19 I $P(R1(0),U,14)="V" S $P(R1(0),U,16)=0,RMPRUCST=0
20QTY K DIR,Y S DIR(0)="660,5" S:$P(R1(0),U,7) DIR("B")=$P(R1(0),U,7) D ^DIR I $P(R1(0),U,7)'=""&$D(DUOUT) G LIST
21 I $D(DTOUT) X CK1 Q
22 I $D(DIRUT) X CK Q
23 S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRUCST K DIR
24 ;SET DELIVERY DATE to today
25 ;
26DATE ;K DIR,Y S DIR(0)="660,10" S:$P(R3("D"),U,12)'="" DIR("B")=$P(R3("D"),U,12) D ^DIR K DIR G:X["^" LIST I $D(DTOUT) X CK1 Q
27 ;W:$P(R1(0),U,12)&(X="@") $C(7),!?5,"Deleted..." I $P(R1(0),U,12)=""&(X="@") W ?17,"??" G DATE
28 S $P(R1(0),U,12)=DT,Y=DT D DD^%DT S $P(R3("D"),U,12)=Y
29LI S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR I $D(DTOUT) X CK1 Q
30 G:$D(DUOUT) LIST
31 I X["^" W !,"Jumping not allowed" G LI
32 I $P(R1(0),U,11)'=""&(X="@") S $P(R1(0),U,11)="" W $C(7),!?5,"Deleted..." H 1 G LOT
33 S $P(R1(0),U,11)=X
34LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24) D ^DIR I $D(DTOUT) X CK1 Q
35 G:$D(DUOUT) LIST
36 I X["^" W !,"Jumping not allowed" G LOT
37 I $P(R1(0),U,24)'=""&(X="@") S $P(R1(0),U,24)="" W $C(7),!?5,"Deleted..." H 1 G REMA
38 S $P(R1(0),U,24)=X
39REMA K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18) 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
44LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA
45 I $G(RMLOC),$G(RMITDA) S RMINVF="PROS INVENTORY"
46 D:$D(RMCPT) CHK^RMPRED5
47 K DIR D ^RMPRST2
48 S DIR("A")="Do you wish to POST this entry",DIR("B")="YES",DIR(0)="Y",DIR("?")="Answer `YES` to post the transaction, `NO` to delete/edit the transaction" D ^DIR K DIR G:Y=1 POST G:Y=0 DEA I $D(DIRUT) X CK Q
49DEA S DIR("A")="Do you wish to Delete this entry",DIR("?")="Answer `YES` to delete the transaction, `NO` to edit the transaction, `^` to exit",DIR("B")="NO",DIR(0)="Y"
50 D ^DIR K DIR I Y=1 W $C(7),?50,"Deleted..." H 2 G RES^RMPRSTK
51 I Y=0 S REDIT=1 G 1^RMPRSTK
52 G:$D(DUOUT) LIST I $D(DIRUT) X CK Q
53POST I $G(RMPRGIP) S PRCP("QTY")=$P(R1(0),U,7)*-1,PRCP("TYP")="R" D ^PRCPUSA
54 I $D(PRCP("ITEM")) W !!,"Error encountered while posting to GIP. Inventory Issue did not post, Patient 10-2319 not updated!! Please check with your Application Coordinator." H 10 G RES^RMPRSTK
55 I RMPRG'="" G GGC
56 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
57 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
58GGC S $P(RMPRI("AMS"),U,1)=RMPRG,RMSER=$P(R1(0),U,11)
59 ;update inventory balance
60 S RMHCPC=$P(R1(1),U,4)
61 I $P(^RMPR(661.1,RMHCPC,0),U,9)=1&($D(RMLOC)) S RMQTY=$P(R1(0),U,7) D ADD^RMPR5NU1 I '$D(RMLOC) X CK Q
62 S:$D(RMLOC) $P(R1(1),U,2)=RDESC,$P(R1(0),U,13)=11,$P(R1(1),U,5)=RM6612
63 ;
64 ;create 2319
65 K Y,DD,DO,DA S DIC="^RMPR(660,",DIC(0)="L",X=DT,DLAYGO=660 D FILE^DICN K DLAYGO I Y'>0 W !,"** Error posting to 2319...entry deleted..." G RES^RMPRSTK
66 S ^RMPR(660,+Y,0)=R1(0),^(1)=R1(1),^("AM")=R1("AM"),^("AMS")=RMPRI("AMS") S:$G(RMPRGIP)=1 $P(^(1),U,3)=$G(RMPRIP)
67 I $D(RMLOC) MERGE ^RMPR(660,+Y,"DES")=^RMPR(661.1,RMDAHC,2) S $P(^RMPR(660,+Y,"DES",0),U,2)=""
68 S DIK="^RMPR(660,",DA=+Y D IX1^DIK K DIC
69 G RES^RMPRSTK
70 ;
71EXIT ;EXIT FOR STOCK ISSUES
72 N RMPRSITE,RMPR D KILL^XUSCLEAN
73 Q
74ERR W !,"PLEASE EDIT GIP IN YOUR SITE PARAMETER FILE!" G EXIT
75INV1 I $P(R1(0),U,14)="C" S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7)
76 G QTY
Note: See TracBrowser for help on using the repository browser.