source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAMXG.m

PRCHAMXG ;WISC/DJM-'CHANGES' ROUTINE #7 FOR 443.6 ;1/5/95  8:28 AM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;****NOTE-See PRCHAMXA for information on variable PRCHNORE and
 ;incidence or undefined DIK variable errors.
 ;
EN1 ;SAVES 'FEDERAL SUPPLY CLASSIFICATION' IN 'ITEM' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="8;443.61:40"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN2 ;SAVES 'DRUG TYPE CODE' IN 'ITEM' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="40;443.61:40"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN3 ;SAVES 'FOOD GROUP' IN 'ITEM' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="41;443.61:40"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN4 ;SAVES 'DIETETIC CONVERSION FACTOR' IN 'ITEM' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="42;443.61:40"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN5 ;SAVES 'CONTRACT #' IN 'ITEM' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="4;443.61:40"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN6 ;SAVES 'BACKORDER(EDI)' IN 'ITEM' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="36.3;443.61:40"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN7 ;SAVES 'SUBSTITUTE(EDI)' IN 'ITEM' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="36.6;443.61:40"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN8 ;SAVES 'CHANGES' INFORMATION FOR 'PROMPT PAYMENT TERMS' MULTIPLE, 'PROMPT PAYMENT PERCENT'
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF=".01;443.66:9.2"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN9 ;SAVES 'DISCOUNT ITEM' IN 'DISCOUNT' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF=".01;443.63:14"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN10 ;SAVES 'PERCENT/DOLLAR AMOUNT' IN 'DISCOUNT' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="1;443.63:14"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN11 ;SAVES 'ADMINISTRATIVE CERTIFICATIONS'
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF=".01;443.624:24"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
EN12 ;SAVES 'DESCRIPTION' MULTIPLE WITHIN 'ITEM' MULTIPLE
 N FF,PRCHDA1,RECORD,Y
 S PRCHDA1=DA(1),RECORD=DA,FF="1;443.61;40"
 D SAVE(FF,PRCHDA1,RECORD)
 Q
 ;
SAVE(FF,PRCHDA1,RECORD) ;THIS WILL DO THE ACTUAL SAVING OF THE INFORMATION.
 ;'PRCHAM' IS DEFINED FROM AMENDMENT ROUTINES.
 ;IT IS THE 'AMENDMENT' FIELD'S RECORD NUMBER FOR THE AMENDMENT THAT
 ;IS BEING ENTERED.
 ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
 ;FILE 442.2 OR FILE 441.6.
 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
 S F2NUMBER=0,ALREADY=$O(^PRC(443.6,"C",PRCHDA1,PRCHAM,FF,RECORD,F2NUMBER,0))
 Q:ALREADY>0  ;CHECK IF THIS FIELD HAS ALREADY BEEN ENTERED.  ONLY THE FIRST ENTRY IS NEEDED.
 S PRCHDA="",OLD=0
 N DA,X
 D NEXT(PRCHDA1,PRCHAM,.PRCHDA)
 N DIE,DC,DD,DE,DG,DI,DIEL,DK,DL,DM,DO,DP,DQ,DR
 S DA(2)=PRCHDA1,DA(1)=PRCHAM,DA=PRCHDA,DIE="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
 S DR="1////^S X=PRCHAMDA;2////^S X=FF;3///^S X=OLD;4///^S X=RECORD;7////^S X=F2NUMBER" D ^DIE
 Q
 ;
NEXT(DA,DA1,DA2) ;COME HERE TO CREATE THE NEXT ENTRY IN THE 'CHANGES' MULTIPLE.
 ;DA2 IS RETURNED WITH THE 'CHANGES' INTERNAL RECORD NUMBER.
 N AA,BB,DIC,DD,DINUM,DO,X,Y
 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
 S AA=$P(AA,U,3)
FIND S AA=AA+1,BB=$G(^PRC(443.6,DA,6,DA1,3,AA,0)) I BB'="" G FIND
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
 S DA2=+Y Q