source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29LS.m@ 623

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1RMPR29LS ;HIN/RVD-LAB STOCK ISSUE SET UTILITY ;11/05/98
2 ;;3.0;PROSTHETICS;**33,37**;Feb 09,1996
3ST ;set data in 2529-3 file
4 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),DA=RMPRDA,DIE="^RMPR(664.1,"
5 S DR=".03////^S X=$G(RMPR(""STA""));.04////^S X=$G(RMPR(""STA""));.09///^S X=$G(DT);2///O;.11////^S X=$G(RMPR(""STA""))"
6 D ^DIE D:$D(Y)!($D(DTOUT)) CHK^RMPR29LU
7 Q
8SG ;set 2529-3 global
9 S $P(^RMPR(664.1,RMPRDA,0),U,13)=$G(RMPRWO)
10 S $P(^RMPR(664.1,RMPRDA,0),U,5)=DUZ,$P(^(0),U,18)=DT D ^RMPR29LA
11 I $G(RMPRWO)'="" W !!,?5,"Assigned Work Order Number: ",RMPRWO D
12 .S RMWO=$O(^RMPR(664.2,"B",RMPRWO,0))
13 .F I=0:0 S I=$O(^RMPR(664.1,RMPRDA,2,I)) Q:I'>0 S RM0=$G(^RMPR(664.1,RMPRDA,2,I,0)) D
14 ..S RMITEM=$P(RM0,U,1),RMQTY=$P(RM0,U,2),RMCO=$P(RM0,U,4),RMUNI=$P(RM0,U,3)
15 ..S RM660=$P(RM0,U,5)
16 ..Q:'RMWO S DA(1)=RMWO,DIC="^RMPR(664.2,"_DA(1)_",1,",X=RMITEM,DIC("P")="664.22PA"
17 ..K DD,DO I '$D(^RMPR(664.2,RMWO,1,"B",RMITEM)) S DIC(0)="L",DLAYGO=664.2 D FILE^DICN
18 ..S RMIDA=$O(^RMPR(664.2,RMWO,1,"B",RMITEM,0))
19 ..S ^RMPR(664.2,RMWO,1,RMIDA,0)=RMITEM_"^"_RMQTY_"^"_RMCO_"^^^"_RMUNI_"^^^^^^"_RM660_"^"_RMPRDA
20 ..S DA=RMIDA,DIK=DIC D IX1^DIK K DA,DD,DO
21 S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///S" D ^DIE
22 Q
23 ;
24GD ;Display work order
25 D DIS^RMPR29W(RMPRDFN,RMPRDA) I Y'>0 S RMFLG=1 Q
26 K DR,DA,DIC,DIE S DIC="^RMPR(664.1,"_RMPRDA_",1,"
27 S DIC("P")="664.15PA",DA(1)=RMPRDA
28 S DIC(0)="EQMZL",X=Y(0,0),ELG=$P(Y(0),U,3) D ^DIC Q:+Y'>0
29 S DIE=DIC,DA(1)=RMPRDA,DA=+Y K DIC
30 S DR="1///^S X=ELG;.01;1" D ^DIE D:$D(DTOUT)!($D(Y)) CHK^RMPR29LU
31 K DR,DIE
32 Q
33 ;
34INV S DIC="^PRCP(445,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" S:$D(RMGIP) DIC("B")=RMGIP
35 D ^DIC I Y<0!$D(DTOUT)!$D(DUOUT) S RMEXIT=1 Q
36 S (PRCP("I"),RMGIP)=+Y,PRCP("ITEM")=RMITEMS
37 S PRCP("TYP")="R"
38INVITEM I $D(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)) G GIP
39 W !!,"*** ITEM IS NOT IN GIP, UNABLE TO ISSUE THIS ITEM ......."
40 S DA(1)=RMPRDA,DA=RMIDA,DIK="^RMPR(664.1,"_DA(1)_",2," D ^DIK
41 K ^RMPR(664.1,RMPRDA,2,RMIDA)
42 S RDEL=1 Q
43GIP ;gip on
44 S RMINVF="GIP"
45V I +$P($G(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,12),$D(^PRC(440,+$P(^(0),U,12),0)) S DIC("B")=+$P($G(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,12)
46 Q
47 ;
48SET S DIE(0)="AEQM",DA(1)=RMPRDA,DA=RMIDA,DIE="^RMPR(664.1,"_RMPRDA_",2,"
49 S DR="2///^S X=$G(RMQTYS);4///^S X=$G(RMCOS);12///^S X=$G(RMSER);8///^S X=$G(RMTYPS);9///^S X=$G(RMCATS);10///^S X=$G(RMSPES);16///^S X=$G(RMIT);14///^S X=$G(RMSOR);13///^S X=$G(RMHS)"
50 D ^DIE G:$D(DTOUT)!$D(DUOUT) EXIT
51 ;S RM0=$G(^RMPR(664.1,RMPRDA,2,DA,0)),RMQTY=$P(RM0,U,2),RMCO=$P(RM0,U,4)
52 S:$G(RMQTY) RMTOCO=RMQTY*RMCOS,DR="11///^S X=$G(RMTOCO)" D ^DIE
53 S:$G(RMLOC) $P(^RMPR(664.1,RMPRDA,2,DA,3),U,4)=$G(RMLOC),$P(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=""
54 S:$G(RMGIP) $P(^RMPR(664.1,RMPRDA,2,DA,3),U,4)="",$P(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=RMGIP
55 S:$G(RMVEN) $P(^RMPR(664.1,RMPRDA,2,DA,3),U,2)=$G(RMVEN)
56 Q
57 ;
58EXIT ;common exit
59 Q
Note: See TracBrowser for help on using the repository browser.