| 1 | PRCHAMXD ;WISC/DJM-'CHANGES' ROUTINE #4 FOR 443.6 ;12/7/95 10:39 AM
|
|---|
| 2 | V ;;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 | ;
|
|---|
| 8 | EN1 ;SAVES 'FEDERAL SUPPLY CLASSIFICATION' IN 'ITEM' MULTIPLE
|
|---|
| 9 | N FF,PRCHDA1,RECORD,Y
|
|---|
| 10 | S PRCHDA1=DA(1),RECORD=DA,FF="8;443.61:40"
|
|---|
| 11 | D SAVE(FF,PRCHDA1,RECORD)
|
|---|
| 12 | Q
|
|---|
| 13 | ;
|
|---|
| 14 | EN2 ;SAVES 'DRUG TYPE CODE' IN 'ITEM' MULTIPLE
|
|---|
| 15 | N FF,PRCHDA1,RECORD,Y
|
|---|
| 16 | S PRCHDA1=DA(1),RECORD=DA,FF="40;443.61:40"
|
|---|
| 17 | D SAVE(FF,PRCHDA1,RECORD)
|
|---|
| 18 | Q
|
|---|
| 19 | ;
|
|---|
| 20 | EN3 ;SAVES 'FOOD GROUP' IN 'ITEM' MULTIPLE
|
|---|
| 21 | N FF,PRCHDA1,RECORD,Y
|
|---|
| 22 | S PRCHDA1=DA(1),RECORD=DA,FF="41;443.61:40"
|
|---|
| 23 | D SAVE(FF,PRCHDA1,RECORD)
|
|---|
| 24 | Q
|
|---|
| 25 | ;
|
|---|
| 26 | EN4 ;SAVES 'DIETETIC CONVERSION FACTOR' IN 'ITEM' MULTIPLE
|
|---|
| 27 | N FF,PRCHDA1,RECORD,Y
|
|---|
| 28 | S PRCHDA1=DA(1),RECORD=DA,FF="42;443.61:40"
|
|---|
| 29 | D SAVE(FF,PRCHDA1,RECORD)
|
|---|
| 30 | Q
|
|---|
| 31 | ;
|
|---|
| 32 | EN5 ;SAVES 'CONTRACT #' IN 'ITEM' MULTIPLE
|
|---|
| 33 | N FF,PRCHDA1,RECORD,Y
|
|---|
| 34 | S PRCHDA1=DA(1),RECORD=DA,FF="4;443.61:40"
|
|---|
| 35 | D SAVE(FF,PRCHDA1,RECORD)
|
|---|
| 36 | Q
|
|---|
| 37 | ;
|
|---|
| 38 | EN6 ;SAVES 'BACKORDER(EDI)' IN 'ITEM' MULTIPLE
|
|---|
| 39 | N FF,PRCHDA1,RECORD,Y
|
|---|
| 40 | S PRCHDA1=DA(1),RECORD=DA,FF="36.3;443.61:40"
|
|---|
| 41 | D SAVE(FF,PRCHDA1,RECORD)
|
|---|
| 42 | Q
|
|---|
| 43 | ;
|
|---|
| 44 | EN7 ;SAVES 'SUBSTITUTE(EDI)' IN 'ITEM' MULTIPLE
|
|---|
| 45 | N FF,PRCHDA1,RECORD,Y
|
|---|
| 46 | S PRCHDA1=DA(1),RECORD=DA,FF="36.6;443.61:40"
|
|---|
| 47 | D SAVE(FF,PRCHDA1,RECORD)
|
|---|
| 48 | Q
|
|---|
| 49 | ;
|
|---|
| 50 | EN8 ;SAVES 'VENDOR' IN MAIN FILE
|
|---|
| 51 | N FF,PRCHDA1,RECORD,Y
|
|---|
| 52 | S PRCHDA1=DA,RECORD=0,FF="5;"
|
|---|
| 53 | D SAVE(FF,PRCHDA1,RECORD)
|
|---|
| 54 | Q
|
|---|
| 55 | ;
|
|---|
| 56 | SAVE(FF,PRCHDA1,RECORD) ;THIS WILL DO THE ACTUAL SAVING OF THE INFORMATION.
|
|---|
| 57 | ;'PRCHAM' IS DEFINED FROM AMENDMENT ROUTINES.
|
|---|
| 58 | ;IT IS THE 'AMENDMENT' FIELD'S RECORD NUMBER FOR THE AMENDMENT THAT
|
|---|
| 59 | ;IS BEING ENTERED.
|
|---|
| 60 | ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
|
|---|
| 61 | ;FILE 442.2 OR FILE 441.6.
|
|---|
| 62 | N PRCHDA,OLD,F2NUMBER,ALREADY,DS,DIFLD,DIP,D,D0,D1,D2,DIG,DIH,DISYS,DIU,DIV,J,L,DH,DU,DV,DW,DOV,DIOV
|
|---|
| 63 | S F2NUMBER=0,ALREADY=$O(^PRC(443.6,"C",PRCHDA1,PRCHAM,FF,RECORD,F2NUMBER,0))
|
|---|
| 64 | Q:ALREADY>0 ;CHECK IF THIS FIELD HAS ALREADY BEEN ENTERED. ONLY THE FIRST ENTRY IS NEEDED.
|
|---|
| 65 | S PRCHDA="",OLD=X
|
|---|
| 66 | N DA,X
|
|---|
| 67 | D NEXT(PRCHDA1,PRCHAM,.PRCHDA)
|
|---|
| 68 | N DIE,DC,DD,DE,DG,DI,DIEL,DK,DL,DM,DO,DP,DQ,DR
|
|---|
| 69 | S DA(2)=PRCHDA1,DA(1)=PRCHAM,DA=PRCHDA,DIE="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
|
|---|
| 70 | S DR="1////^S X=PRCHAMDA;2////^S X=FF;3///^S X=OLD;4///^S X=RECORD;7////^S X=F2NUMBER" D ^DIE
|
|---|
| 71 | Q
|
|---|
| 72 | ;
|
|---|
| 73 | NEXT(DA,DA1,DA2) ;COME HERE TO CREATE THE NEXT ENTRY IN THE 'CHANGES' MULTIPLE.
|
|---|
| 74 | ;DA2 IS RETURNED WITH THE 'CHANGES' INTERNAL RECORD NUMBER.
|
|---|
| 75 | N AA,BB,DIC,DD,DINUM,DO,X,Y
|
|---|
| 76 | 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
|
|---|
| 77 | S AA=$P(AA,U,3)
|
|---|
| 78 | FIND S AA=AA+1,BB=$G(^PRC(443.6,DA,6,DA1,3,AA,0)) I BB'="" G FIND
|
|---|
| 79 | ENTER 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
|
|---|
| 80 | S DA2=+Y Q
|
|---|
