source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAMXA.m@ 836

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

initial load of WorldVistAEHR
File size: 4.5 KB
RevLine 
[613]1PRCHAMXA ;WISC/DJM-'CHANGES' ROUTINES FOR 443.6 ;4/15/94 2:25 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;*****************************************************************
5 ;* NOTE-The variable PRCHNORE is set at the beginning of the *
6 ;* amendment process (in PRCHMA). The subroutines in the *
7 ;* PRCHAMX* series of routines are called by cross-references *
8 ;* in files 443.6 and 441.7 to update the changes multiple in *
9 ;* in file 443.6. If, during the amendment process, you use *
10 ;* FileMan to delete or kill a field from within an input tem- *
11 ;* plate, ^DIK is called, and all cross-references for that *
12 ;* field are updated. If PRCHNORE=1, the changes multiple x-ref*
13 ;* is done, and FM variables needed in the template may be *
14 ;* changed or FM variables needed in the ^DIK may not be in *
15 ;* place. If you need to use FM to delete a field you may need *
16 ;* to kill PRCHNORE right before the call and re-set it to 1 *
17 ;* right after the call. *
18 ;*****************************************************************
19EN0 ;SAVES 'CHANGES' INFORMATION FOR 'ITEM' MULTIPLE, 'LINE ITEM NUMBER'.
20 N FF,PRCHDA1,RECORD,Y
21 S FF=".01;443.61:40",PRCHDA1=DA(1),RECORD=DA
22 D SAVE(FF,PRCHDA1,RECORD)
23 Q
24 ;
25EN1 ;SAVES 'QUANTITY'
26 N FF,PRCHDA1,RECORD,Y
27 S FF="2;443.61:40",PRCHDA1=DA(1),RECORD=DA
28 D SAVE(FF,PRCHDA1,RECORD)
29 Q
30 ;
31EN2 ;SAVES 'UNIT OF PURCHASE'
32 N FF,PRCHDA1,RECORD,Y
33 S FF="3;443.61:40",PRCHDA1=DA(1),RECORD=DA
34 D SAVE(FF,PRCHDA1,RECORD)
35 Q
36 ;
37EN3 ;SAVES 'BOC'
38 N FF,PRCHDA1,RECORD,Y
39 S FF="3.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
40 D SAVE(FF,PRCHDA1,RECORD)
41 Q
42 ;
43EN4 ;SAVES 'REPETITIVE (PR CARD) NO."
44 N FF,PRCHDA1,RECORD,Y
45 S FF="1.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
46 D SAVE(FF,PRCHDA1,RECORD)
47 Q
48 ;
49EN5 ;SAVES 'VENDOR STOCK NUMBER'
50 N FF,PRCHDA1,RECORD,Y
51 S FF="9;443.61:40",PRCHDA1=DA(1),RECORD=DA
52 D SAVE(FF,PRCHDA1,RECORD)
53 Q
54 ;
55EN6 ;SAVES 'EST. UNIT COST'
56 N FF,PRCHDA1,RECORD,Y
57 S FF="5.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
58 D SAVE(FF,PRCHDA1,RECORD)
59 Q
60 ;
61EN7 ;SAVES 'COST CENTER'
62 N FF,PRCHDA1,RECORD,Y
63 S FF="3.2;443.61:40",PRCHDA1=DA(1),RECORD=DA
64 D SAVE(FF,PRCHDA1,RECORD)
65 Q
66 ;
67EN8 ;SAVES 'ACTUAL UNIT COST'
68 N FF,PRCHDA1,RECORD,Y
69 S FF="5;443.61:40",PRCHDA1=DA(1),RECORD=DA
70 D SAVE(FF,PRCHDA1,RECORD)
71 Q
72 ;
73EN9 ;SAVES 'PACKAGING MULTIPLE'
74 N FF,PRCHDA1,RECORD,Y
75 S FF="3.1;443.61:40",PRCHDA1=DA(1),RECORD=DA
76 D SAVE(FF,PRCHDA1,RECORD)
77 Q
78 ;
79EN10 ;SAVES 'NSN'
80 N FF,PRCHDA1,RECORD,Y
81 S FF="9.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
82 D SAVE(FF,PRCHDA1,RECORD)
83 Q
84 ;
85EN11 ;SAVES 'MAXIMUM ORDER QTY'
86 N FF,PRCHDA1,RECORD,Y
87 S FF="9.6;443.61:40",PRCHDA1=DA(1),RECORD=DA
88 D SAVE(FF,PRCHDA1,RECORD)
89 Q
90 ;
91EN12 ;SAVES 'NATIONAL DRUG CODE'
92 N FF,PRCHDA1,RECORD,Y
93 S FF="9.3;443.61:40",PRCHDA1=DA(1),RECORD=DA
94 D SAVE(FF,PRCHDA1,RECORD)
95 Q
96 ;
97EN13 ;SAVES 'SKU'
98 N FF,PRCHDA1,RECORD,Y
99 S FF="9.4;443.61:40",PRCHDA1=DA(1),RECORD=DA
100 D SAVE(FF,PRCHDA1,RECORD)
101 Q
102 ;
103EN14 ;SAVES 'UNIT CONVERSION FACTOR'
104 N FF,PRCHDA1,RECORD,Y
105 S FF="9.7;443.61:40",PRCHDA1=DA(1),RECORD=DA
106 D SAVE(FF,PRCHDA1,RECORD)
107 Q
108 ;
109SAVE(FF,PRCHDA1,RECORD) ;THIS WILL DO THE ACTUAL SAVING OF THE INFORMATION.
110 ;'PRCHAM' IS DEFINED FROM AMENDMENT ROUTINES.
111 ;IT IS THE 'AMENDMENT' FIELD'S RECORD NUMBER FOR THE AMENDMENT THAT
112 ;IS BEING ENTERED.
113 ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
114 ;FILE 442.2 (P.O.) OR 441.6 (REQUISITION).
115 N PRCHDA,OLD,DIFLD,DIP,F2NUMBER,ALREADY,DS,D,D0,D1,D2,DIG,DIH,DISYS,DIU,DIV,J,L,DH,DU,DV,DW,DOV,DIOV
116 S F2NUMBER=0,ALREADY=$O(^PRC(443.6,"C",PRCHDA1,PRCHAM,FF,RECORD,F2NUMBER,0))
117 Q:ALREADY>0 ;CHECK IF THIS FIELD HAS ALREADY BEEN ENTERED. ONLY THE FIRST ENTRY IS NEEDED.
118 S PRCHDA="",OLD=X
119 N DA,X
120 D NEXT(PRCHDA1,PRCHAM,.PRCHDA)
121 N DIE,DC,DD,DE,DG,DIEL,DI,DK,DL,DM,DO,DP,DQ,DR
122 S DA(2)=PRCHDA1,DA(1)=PRCHAM,DA=PRCHDA,DIE="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
123 S DR="1////^S X=PRCHAMDA;2////^S X=FF;3///^S X=OLD;4///^S X=RECORD;7////^S X=F2NUMBER" D ^DIE
124 Q
125 ;
126NEXT(DA,DA1,DA2) ;COME HERE TO CREATE THE NEXT ENTRY IN THE 'CHANGES' MULTIPLE.
127 ;DA2 IS RETURNED WITH THE 'CHANGES' INTERNAL RECORD NUMBER.
128 N AA,BB,DIC,DD,DINUM,DO,X,Y
129 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
130 S AA=$P(AA,U,3)
131FIND S AA=AA+1,BB=$G(^PRC(443.6,DA,6,DA1,3,AA,0)) I BB'="" G FIND
132ENTER 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
133 S DA2=+Y Q
Note: See TracBrowser for help on using the repository browser.