source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAMXF.m@ 1806

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

initial load of WorldVistAEHR
File size: 3.6 KB
Line 
1PRCHAMXF ;WISC/DJM-'CHANGES' ROUTINE #6 FOR 443.6 ;4/15/94 2:32 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;****NOTE-See PRCHAMXA for information on variable PRCHNORE and
6 ;incidence of undefined DIK variable errors.
7 ;
8EN0 ;SAVES 'CHANGES' INFORMATION FOR 'ITEM' MULTIPLE, 'LINE ITEM NUMBER'.
9 N FF,PRCHDA1,RECORD,Y
10 S FF=".01;443.61:40",PRCHDA1=DA(1),RECORD=DA
11 D SAVE(FF,PRCHDA1,RECORD)
12 Q
13 ;
14EN1 ;SAVES 'QUANTITY'
15 N FF,PRCHDA1,RECORD,Y
16 S FF="2;443.61:40",PRCHDA1=DA(1),RECORD=DA
17 D SAVE(FF,PRCHDA1,RECORD)
18 Q
19 ;
20EN2 ;SAVES 'UNIT OF PURCHASE'
21 N FF,PRCHDA1,RECORD,Y
22 S FF="3;443.61:40",PRCHDA1=DA(1),RECORD=DA
23 D SAVE(FF,PRCHDA1,RECORD)
24 Q
25 ;
26EN3 ;SAVES 'BOC'
27 N FF,PRCHDA1,RECORD,Y
28 S FF="3.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
29 D SAVE(FF,PRCHDA1,RECORD)
30 Q
31 ;
32EN4 ;SAVES 'REPETITIVE (PR CARD) NO."
33 N FF,PRCHDA1,RECORD,Y
34 S FF="1.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
35 D SAVE(FF,PRCHDA1,RECORD)
36 Q
37 ;
38EN5 ;SAVES 'VENDOR STOCK NUMBER'
39 N FF,PRCHDA1,RECORD,Y
40 S FF="9;443.61:40",PRCHDA1=DA(1),RECORD=DA
41 D SAVE(FF,PRCHDA1,RECORD)
42 Q
43 ;
44EN6 ;SAVES 'EST. UNIT COST'
45 N FF,PRCHDA1,RECORD,Y
46 S FF="5.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
47 D SAVE(FF,PRCHDA1,RECORD)
48 Q
49 ;
50EN7 ;SAVES 'COST CENTER'
51 N FF,PRCHDA1,RECORD,Y
52 S FF="3.2;443.61:40",PRCHDA1=DA(1),RECORD=DA
53 D SAVE(FF,PRCHDA1,RECORD)
54 Q
55 ;
56EN8 ;SAVES 'ACTUAL UNIT COST'
57 N FF,PRCHDA1,RECORD,Y
58 S FF="5;443.61:40",PRCHDA1=DA(1),RECORD=DA
59 D SAVE(FF,PRCHDA1,RECORD)
60 Q
61 ;
62EN9 ;SAVES 'PACKAGING MULTIPLE'
63 N FF,PRCHDA1,RECORD,Y
64 S FF="3.1;443.61:40",PRCHDA1=DA(1),RECORD=DA
65 D SAVE(FF,PRCHDA1,RECORD)
66 Q
67 ;
68EN10 ;SAVES 'NSN'
69 N FF,PRCHDA1,RECORD,Y
70 S FF="9.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
71 D SAVE(FF,PRCHDA1,RECORD)
72 Q
73 ;
74EN11 ;SAVES 'MAXIMUM ORDER QTY'
75 N FF,PRCHDA1,RECORD,Y
76 S FF="9.6;443.61:40",PRCHDA1=DA(1),RECORD=DA
77 D SAVE(FF,PRCHDA1,RECORD)
78 Q
79 ;
80EN12 ;SAVES 'NATIONAL DRUG CODE'
81 N FF,PRCHDA1,RECORD,Y
82 S FF="9.3;443.61:40",PRCHDA1=DA(1),RECORD=DA
83 D SAVE(FF,PRCHDA1,RECORD)
84 Q
85 ;
86EN13 ;SAVES 'SKU'
87 N FF,PRCHDA1,RECORD,Y
88 S FF="9.4;443.61:40",PRCHDA1=DA(1),RECORD=DA
89 D SAVE(FF,PRCHDA1,RECORD)
90 Q
91 ;
92EN14 ;SAVES 'UNIT CONVERSION FACTOR'
93 N FF,PRCHDA1,RECORD,Y
94 S FF="9.7;443.61:40",PRCHDA1=DA(1),RECORD=DA
95 D SAVE(FF,PRCHDA1,RECORD)
96 Q
97 ;
98SAVE(FF,PRCHDA1,RECORD) ;THIS WILL DO THE ACTUAL SAVING OF THE INFORMATION.
99 ;'PRCHAM' IS DEFINED FROM AMENDMENT ROUTINES.
100 ;IT IS THE 'AMENDMENT' FIELD'S RECORD NUMBER FOR THE AMENDMENT THAT
101 ;IS BEING ENTERED.
102 ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
103 ;FILE 442.2 (P.O.) OR 441.6 (REQUISITION).
104 N DIFLD,DIP,PRCHDA,OLD,F2NUMBER,ALREADY,DS,D,D0,D1,D2,DIG,DIH,DISYS,DIU,DIV,J,L,DH,DU,DV,DW,DOV,DIOV
105 S F2NUMBER=0,ALREADY=$O(^PRC(443.6,"C",PRCHDA1,PRCHAM,FF,RECORD,F2NUMBER,0))
106 Q:ALREADY>0 ;CHECK IF THIS FIELD HAS ALREADY BEEN ENTERED. ONLY THE FIRST ENTRY IS NEEDED.
107 S PRCHDA="",OLD=0
108 N DA,X
109 D NEXT(PRCHDA1,PRCHAM,.PRCHDA)
110 N DIE,DC,DD,DE,DG,DIEL,DI,DK,DL,DM,DO,DP,DQ,DR
111 S DA(2)=PRCHDA1,DA(1)=PRCHAM,DA=PRCHDA,DIE="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
112 S DR="1////^S X=PRCHAMDA;2////^S X=FF;3///^S X=OLD;4///^S X=RECORD;7////^S X=F2NUMBER" D ^DIE
113 Q
114 ;
115NEXT(DA,DA1,DA2) ;COME HERE TO CREATE THE NEXT ENTRY IN THE 'CHANGES' MULTIPLE.
116 ;DA2 IS RETURNED WITH THE 'CHANGES' INTERNAL RECORD NUMBER.
117 N AA,BB,DIC,DD,DINUM,DO,X,Y
118 S AA=$G(^PRC(443.6,DA,6,DA1,3,0)) I AA="" S AA=1,^PRC(443.6,DA,6,DA1,3,0)="^"_$P(^DD(443.67,14,0),"^",2) G ENTER
119 S AA=$P(AA,U,3)
120FIND S AA=AA+1,BB=$G(^PRC(443.6,DA,6,DA1,3,AA,0)) I BB'="" G FIND
121ENTER K DD,DO S DA(2)=DA,DA(1)=DA1,DIC="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L",(DINUM,X)=AA D FILE^DICN G:+Y'>0 FIND
122 S DA2=+Y Q
Note: See TracBrowser for help on using the repository browser.