source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCRD1.m@ 862

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

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1PRCHCRD1 ;WISC/DJM,ID/RSD-EDIT OF PR CARDS ;5/3/96 9:29 AM [5/12/98 4:21pm]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN7 ;Edit packaging multiple from file 442 to 441
5 Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,8)=X G Q
6EN8 ;Move FSC from file 442 (P.O.) to 441 (Item Master)
7 S $P(^PRC(441,+PRCHCI,0),U,3)=X G Q
8EN9 ;Move MAX.ORD.QTY.from file 442 to 441
9 Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,9)=X G Q
10EN10 ;Edit SKU from file 442 to 441
11 Q:'$D(^PRC(441,+PRCHCI,3)) S $P(^(3),U,8)=X G Q
12EN11 ;Edit UNIT CONVERSION FACTOR from file 442 to 441
13 Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,10)=X G Q
14EN12 ;Edit NATIONAL DRUG CODE from file 442 to 441
15 Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,5)=X G Q
16EN13 ;Edit BOC from file 442 to 441
17 ;Q:'$D(^PRC(441,+PRCHCI,0)) S $P(^(0),U,10)=PRCHBOC G Q
18 G Q
19LST ;ENTERED FROM LAST LINE OF "EN3^PRCHCRD"
20 D VEN
21 S PRCHCY=^PRC(441,PRCHCI,0)
22 S PRCHCNS=$P(PRCHCY,U,5) ;NATIONAL STOCK NUMBER (NSN)
23 S PRCHCSC=$P(PRCHCY,U,3) ;FEDERAL SUPPLY CLASSIFICATION (FSC)
24 S PRCHCSB=+$P(PRCHCY,U,10) ;BUDGET OBJECT CODE (BOC)
25 I PRCHCSB=0 S PRCHCSB=""
26 S PRCHCC=+$P($G(^PRC(442,DA(1),0)),U,5) ;COST CENTER
27 I PRCHCSB>0,($G(^PRCD(420.1,PRCHCC,1,PRCHCSB,0))="") S PRCHCSB=""
28 I PRCHCSB>0 S PRCHCSB=$P(^PRCD(420.2,PRCHCSB,0),U,1)
29 S PRCHCY=^PRC(441,PRCHCI,2,PRCHCV,0) ;VENDOR MULTIPLE
30 S PRCHCVS=$P(PRCHCY,U,4) ;VENDOR STOCK #
31 S PRCHCDC=$P(PRCHCY,U,5) ;NATIONAL DRUG CODE (NDC)
32 S PRCHCUC=$P(PRCHCY,U,2) S:$G(PRCHPHAM) PRCHCUC=0 ;UNIT COST
33 S PRCHCCN=$P(PRCHCY,U,3) ;CONTRACT
34 S PRCHCUP=$P(PRCHCY,U,7) ;UNIT OF PURCHASE
35 S PRCHCPK=$P(PRCHCY,U,8) ;PACKAGING MULTIPLE
36 S PRCHCMX=$P(PRCHCY,U,9) ;MAXIMUM ORDER QUANTITY
37 S PRCHSKM=$P(PRCHCY,U,10) ;UNIT CONVERSION FACTOR
38 S PRCHHM=$P(PRCHCY,U,14) ;HAZARDOUS MATERIAL
39 S PRCHCY=$G(^PRC(441,PRCHCI,3))
40 S PRCHSKU=$P(PRCHCY,U,8) ;STOCK KEEPING UNIT (SKU)
41 S PRCHFGRP=$P(PRCHCY,U,7) ;FOOD GROUP
42 S PRCHDRTY=$P(PRCHCY,U,9) ;DRUG TYPE CODE
43 S PRCHCS=" "
44 S L=1
45 F M=0:0 S M=$O(^PRC(441,PRCHCI,1,M)) Q:M'>0 S PRCHC("%X",L,0)=PRCHCS_^(M,0),L=L+1,PRCHCS="" ;DESCRIPTION
46 S:PRCHCDC]"" PRCHC("%X",L,0)=" NDC:"_PRCHCDC,L=L+1 ;ADD IF NDC
47 S PRCHC("%X",0)="^^"_L_U_L_U_DT_U ;SET UP NODE 0 OF DESCRIPTION FOR MOVE
48 S %X="PRCHC(""%X"","
49 S %Y="^PRC(442,DA(1),2,DA,1,"
50 S:PRCHCCN]"" PRCHCY=$G(^PRC(440,PRCHCV,4,PRCHCCN,0)),PRCHCCN=$S($P(PRCHCY,U,2)>DT:$P(PRCHCY,U,1),1:"") ;CONTRACT NUMBER -- FROM FILE 440
51 S PRCHC(0)=^PRC(442,DA(1),2,DA,0)
52 S PRCHC(2)=""
53 S PRCHCQ=$P(PRCHC(0),U,2) ;QUANTITY
54 S:$D(^PRC(442,DA(1),2,DA,2)) PRCHC(2)=^PRC(442,DA(1),2,DA,2)
55 S PRCHC(4)=$G(^PRC(442,DA(1),2,DA,4))
56 S $P(PRCHC(0),U,3)=PRCHCUP ;UNIT OF PURCHASE
57 S $P(PRCHC(0),U,12)=PRCHCPK ;PACKAGING MULTIPLE
58 S $P(PRCHC(0),U,14)=PRCHCMX ;MAXIMUM ORDER QUANTITY
59 S:$P(PRCHC(0),U,4)="" $P(PRCHC(0),U,4)=PRCHCSB ;BOC
60 S $P(PRCHC(0),U,9)=PRCHCUC ;ACTUAL UNIT COST
61 S $P(PRCHC(0),U,15)=PRCHCDC ;NATIONAL DRUG CODE
62 S $P(PRCHC(0),U,16)=PRCHSKU ;STOCK KEEPING UNIT
63 S $P(PRCHC(0),U,17)=PRCHSKM ;UNIT CONVERSION FACTOR
64 S $P(PRCHC(4),U,12)=PRCHFGRP ;FOOD GROUP
65 S $P(PRCHC(4),U,11)=PRCHDRTY ;DRUG TYPE CODE
66 S:PRCHCVS'="" $P(PRCHC(0),U,6)=PRCHCVS ;VENDOR STOCK NUMBER
67 S:PRCHCNS'="" $P(PRCHC(0),U,13)=PRCHCNS ;NATIONAL STOCK NUMBER
68 S $P(PRCHC(2),U,1)=PRCHCQ*PRCHCUC ;TOTAL COST
69 S $P(PRCHC(2),U,2)=PRCHCCN ;CONTRACT #
70 S $P(PRCHC(2),U,3)=PRCHCSC ;FEDERAL SUPPLY CLASSIFICATION
71 S $P(PRCHC(2),U,14)=PRCHHM ;HAZARDOUS MATERIAL
72 S ^PRC(442,DA(1),2,DA,0)=PRCHC(0)
73 S ^PRC(442,DA(1),2,DA,2)=PRCHC(2)
74 S ^PRC(442,DA(1),2,DA,4)=PRCHC(4)
75 S:PRCHCSB]"" ^PRC(442,DA(1),2,"D",+PRCHCSB,DA)=""
76 S LIN=$P(^PRC(442,DA(1),2,DA,0),U)
77 S ^PRC(442,DA(1),2,"AH",+PRCHCSB,LIN,DA)=""
78 S:PRCHCCN]"" ^PRC(442,DA(1),2,"AC",$E(PRCHCCN,1,30),DA)=""
79 K ^PRC(442,DA(1),2,DA,1)
80 D %XY^%RCR ;MOVE DESCRIPTION TO FILE 442, ITEM MULTIPLE
81 ;
82 ;Release the lock on IMF applied in routine PRCHCRD, tag LCK.
83 L -^PRC(441,PRCHCI,0)
84 L -^PRC(441,PRCHCI,2,PRCHCV)
85 G Q
86 ;
87VEN I '$D(^PRC(441,PRCHCI,2)) S ^PRC(441,PRCHCI,2,0)="^441.01P^0^0"
88 I '$D(^PRC(441,PRCHCI,2,PRCHCV,0)) S ^(0)=PRCHCV,^PRC(441,PRCHCI,2,"B",PRCHCV,PRCHCV)="",$P(^(0),U,3,4)=PRCHCV_U_($P(^PRC(441,PRCHCI,2,0),U,4)+1)
89 L +^PRC(441,PRCHCI,2,PRCHCV):5 E W !!,$C(7),?5,"Another user is editing this entry, try later." Q
90 S $P(^PRC(441,PRCHCI,0),U,4)=PRCHCV
91 Q
92Q K LIN,PRCHC,PRCHCCN,PRCHCCP,PRCHCDC,PRCHCI,PRCHCMX,PRCHCNS,PRCHCPD,PRCHCPK,PRCHCPO,PRCHCQ,PRCHCS,PRCHCSB,PRCHCSC,PRCHCUC,PRCHCUP,PRCHCV,PRCHCVS,PRCHCX,PRCHCY,PRCHSKM,PRCHSKU,PRCHFGRP,PRCHBOC
93 Q
Note: See TracBrowser for help on using the repository browser.