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

PRCHAMXE.m

Go to the documentation of this file.
  1. PRCHAMXE ;WISC/DJM-'CHANGES' ROUTINE #5 FOR 443.6 ;2/21/97 15:07
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;****NOTE-See PRCHAMXA for information on variable PRCHNORE and
  1. ;incidence of undefined DIK variable errors.
  1. ;
  1. ;'PRCHDA1' AND 'PRCHDA' ARE SET IN THE 'LINE ITEM' AMENDMENT
  1. ;TEMPLATE.
  1. ;'PRCHDA' IS THE SUBFILE INTERNAL ENTRY NUMBER OF THE ITEM THAT OWNS
  1. ;THE DELIVERY SCHEDULE BEING EDITED.
  1. ;'PRCHDA1' IS THE INTERNAL ENTRY NUMBER OF THE RECORD BEING AMENDED
  1. ;IN FILE 443.6. (P.O.) OR 441.6 (REQUISITION).
  1. ;
  1. EN1 ;SAVES 'ITEM' FROM FILE 441.7 CALLED FROM 'ITEM'
  1. Q
  1. N FF,RECORD,Y,OLD,F2NUMBER
  1. S FF="1;441.7",RECORD=PRCHDA,OLD=$S($P(PRCHYY,U,3)=1:0,1:X),F2NUMBER=D0
  1. D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
  1. Q
  1. ;
  1. EN2 ;SAVES 'DELIVERY DATE' FROM FILE 441.7 CALLED FROM 'ITEM'
  1. N FF,RECORD,Y,OLD,F2NUMBER
  1. S FF="2;441.7",RECORD=PRCHDA,OLD=$S($P(PRCHYY,U,3)=1:0,1:X),F2NUMBER=D0
  1. D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
  1. Q
  1. ;
  1. EN3 ;SAVES 'LOCATION FOR DELIVERY' FROM FILE 441.7 CALLED FROM 'ITEM'
  1. N FF,RECORD,Y,OLD,F2NUMBER
  1. S FF="3;441.7",RECORD=PRCHDA,OLD=$S($P(PRCHYY,U,3)=1:0,1:X),F2NUMBER=D0
  1. D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
  1. Q
  1. ;
  1. EN4 ;SAVES 'QTY TO BE DELIVERED' FROM FILE 441.7 CALLED FROM 'ITEM'
  1. N FF,RECORD,Y,OLD,F2NUMBER
  1. S FF="4;441.7",RECORD=PRCHDA,OLD=$S($P(PRCHYY,U,3)=1:0,1:X),F2NUMBER=D0
  1. D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
  1. Q
  1. ;
  1. EN5 ;SAVES 'ITEM' FROM FILE 441.7 CALLED FROM 'ITEM'
  1. Q
  1. N FF,RECORD,Y,OLD,F2NUMBER
  1. S FF="1;441.7",RECORD=PRCHDA,OLD=0,F2NUMBER=D0
  1. D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
  1. Q
  1. ;
  1. EN6 ;SAVES 'DELIVERY DATE' FROM FILE 441.7 CALLED FROM 'ITEM'
  1. N FF,RECORD,Y,OLD,F2NUMBER
  1. S FF="2;441.7",RECORD=PRCHDA,OLD=0,F2NUMBER=D0
  1. D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
  1. Q
  1. ;
  1. EN7 ;SAVES 'LOCATION FOR DELIVERY' FROM FILE 441.7 CALLED FROM 'ITEM'
  1. N FF,RECORD,Y,OLD,F2NUMBER
  1. S FF="3;441.7",RECORD=PRCHDA,OLD=0,F2NUMBER=D0
  1. D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
  1. Q
  1. ;
  1. EN8 ;SAVES 'QTY TO BE DELIVERED' FROM FILE 441.7 CALLED FROM 'ITEM'
  1. N FF,RECORD,Y,OLD,F2NUMBER
  1. S FF="4;441.7",RECORD=PRCHDA,OLD=0,F2NUMBER=D0
  1. D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
  1. Q
  1. ;
  1. SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER) ;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. ;'OLD' IS THE VALUE OF X.
  1. ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
  1. ;FILE 442.2 OR FILE 441.6.
  1. ;F2NUMBER IS THE INTERNAL ENTRY NUMBER FOR THE COPY OF THE 'DELIVERY
  1. ;SCHEDULE (ORDER)' FILE RECORD BEING EDITED. THIS IS FROM FILE 441.7
  1. N PRCHDA,ALREADY,DS,DIFLD,DIP,D,D0,D1,D2,DIG,DIH,DISYS,DIU,DIV,J,L,DH,DU,DV,DW,DOV,DIOV
  1. S 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=""
  1. N DA,X
  1. D NEXT(PRCHDA1,PRCHAM,.PRCHDA)
  1. N DIE,DC,DD,DE,DG,DI,DIEL,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