Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHAMXA

PRCHAMXA.m

Go to the documentation of this file. 
  1. PRCHAMXA ;WISC/DJM-'CHANGES' ROUTINES FOR 443.6 ;4/15/94  2:25 PM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;*****************************************************************
  1.  ;*  NOTE-The variable PRCHNORE is set at the beginning of the    *
  1.  ;*  amendment process (in PRCHMA).  The subroutines in the       *
  1.  ;*  PRCHAMX* series of routines are called by cross-references   *
  1.  ;*  in files 443.6 and 441.7 to update the changes multiple in   *
  1.  ;*  in file 443.6.  If, during the amendment process, you use    *
  1.  ;*  FileMan to delete or kill a field from within an input tem-  *
  1.  ;*  plate, ^DIK is called, and all cross-references for that     *
  1.  ;*  field are updated.  If PRCHNORE=1, the changes multiple x-ref*
  1.  ;*  is done, and FM variables needed in the template may be      *
  1.  ;*  changed or FM variables needed in the ^DIK may not be in     *
  1.  ;*  place.  If you need to use FM to delete a field you may need *
  1.  ;*  to kill PRCHNORE right before the call and re-set it to 1    *
  1.  ;*  right after the call.                                        *
  1.  ;*****************************************************************
  1. EN0 ;SAVES 'CHANGES' INFORMATION FOR 'ITEM' MULTIPLE, 'LINE ITEM NUMBER'.
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF=".01;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN1 ;SAVES 'QUANTITY'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="2;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN2 ;SAVES 'UNIT OF PURCHASE'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="3;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN3 ;SAVES 'BOC'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="3.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN4 ;SAVES 'REPETITIVE (PR CARD) NO."
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="1.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN5 ;SAVES 'VENDOR STOCK NUMBER'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="9;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN6 ;SAVES 'EST. UNIT COST'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="5.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN7 ;SAVES 'COST CENTER'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="3.2;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN8 ;SAVES 'ACTUAL UNIT COST'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="5;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN9 ;SAVES 'PACKAGING MULTIPLE'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="3.1;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN10 ;SAVES 'NSN'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="9.5;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN11 ;SAVES 'MAXIMUM ORDER QTY'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="9.6;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN12 ;SAVES 'NATIONAL DRUG CODE'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="9.3;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN13 ;SAVES 'SKU'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="9.4;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. EN14 ;SAVES 'UNIT CONVERSION FACTOR'
  1.  N FF,PRCHDA1,RECORD,Y
  1.  S FF="9.7;443.61:40",PRCHDA1=DA(1),RECORD=DA
  1.  D SAVE(FF,PRCHDA1,RECORD)
  1.  Q
  1.  ;
  1. SAVE(FF,PRCHDA1,RECORD) ;THIS WILL DO THE ACTUAL SAVING OF THE INFORMATION.
  1.  ;'PRCHAM' IS DEFINED FROM AMENDMENT ROUTINES.
  1.  ;IT IS THE 'AMENDMENT' FIELD'S RECORD NUMBER FOR THE AMENDMENT THAT
  1.  ;IS BEING ENTERED.
  1.  ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
  1.  ;FILE 442.2 (P.O.) OR 441.6 (REQUISITION).
  1.  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
  1.  S F2NUMBER=0,ALREADY=$O(^PRC(443.6,"C",PRCHDA1,PRCHAM,FF,RECORD,F2NUMBER,0))
  1.  Q:ALREADY>0  ;CHECK IF THIS FIELD HAS ALREADY BEEN ENTERED.  ONLY THE FIRST ENTRY IS NEEDED.
  1.  S PRCHDA="",OLD=X
  1.  N DA,X
  1.  D NEXT(PRCHDA1,PRCHAM,.PRCHDA)
  1.  N DIE,DC,DD,DE,DG,DIEL,DI,DK,DL,DM,DO,DP,DQ,DR
  1.  S DA(2)=PRCHDA1,DA(1)=PRCHAM,DA=PRCHDA,DIE="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
  1.  S DR="1////^S X=PRCHAMDA;2////^S X=FF;3///^S X=OLD;4///^S X=RECORD;7////^S X=F2NUMBER" D ^DIE
  1.  Q
  1.  ;
  1. NEXT(DA,DA1,DA2) ;COME HERE TO CREATE THE NEXT ENTRY IN THE 'CHANGES' MULTIPLE.
  1.  ;DA2 IS RETURNED WITH THE 'CHANGES' INTERNAL RECORD NUMBER.
  1.  N AA,BB,DIC,DD,DINUM,DO,X,Y
  1.  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
  1.  S AA=$P(AA,U,3)
  1. FIND S AA=AA+1,BB=$G(^PRC(443.6,DA,6,DA1,3,AA,0)) I BB'="" G FIND
  1. 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
  1.  S DA2=+Y Q