- PRCHAMXE ;WISC/DJM-'CHANGES' ROUTINE #5 FOR 443.6 ;2/21/97 15:07
- 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 of undefined DIK variable errors.
- ;
- ;'PRCHDA1' AND 'PRCHDA' ARE SET IN THE 'LINE ITEM' AMENDMENT
- ;TEMPLATE.
- ;'PRCHDA' IS THE SUBFILE INTERNAL ENTRY NUMBER OF THE ITEM THAT OWNS
- ;THE DELIVERY SCHEDULE BEING EDITED.
- ;'PRCHDA1' IS THE INTERNAL ENTRY NUMBER OF THE RECORD BEING AMENDED
- ;IN FILE 443.6. (P.O.) OR 441.6 (REQUISITION).
- ;
- EN1 ;SAVES 'ITEM' FROM FILE 441.7 CALLED FROM 'ITEM'
- Q
- N FF,RECORD,Y,OLD,F2NUMBER
- S FF="1;441.7",RECORD=PRCHDA,OLD=$S($P(PRCHYY,U,3)=1:0,1:X),F2NUMBER=D0
- D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- Q
- ;
- EN2 ;SAVES 'DELIVERY DATE' FROM FILE 441.7 CALLED FROM 'ITEM'
- N FF,RECORD,Y,OLD,F2NUMBER
- S FF="2;441.7",RECORD=PRCHDA,OLD=$S($P(PRCHYY,U,3)=1:0,1:X),F2NUMBER=D0
- D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- Q
- ;
- EN3 ;SAVES 'LOCATION FOR DELIVERY' FROM FILE 441.7 CALLED FROM 'ITEM'
- N FF,RECORD,Y,OLD,F2NUMBER
- S FF="3;441.7",RECORD=PRCHDA,OLD=$S($P(PRCHYY,U,3)=1:0,1:X),F2NUMBER=D0
- D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- Q
- ;
- EN4 ;SAVES 'QTY TO BE DELIVERED' FROM FILE 441.7 CALLED FROM 'ITEM'
- N FF,RECORD,Y,OLD,F2NUMBER
- S FF="4;441.7",RECORD=PRCHDA,OLD=$S($P(PRCHYY,U,3)=1:0,1:X),F2NUMBER=D0
- D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- Q
- ;
- EN5 ;SAVES 'ITEM' FROM FILE 441.7 CALLED FROM 'ITEM'
- Q
- N FF,RECORD,Y,OLD,F2NUMBER
- S FF="1;441.7",RECORD=PRCHDA,OLD=0,F2NUMBER=D0
- D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- Q
- ;
- EN6 ;SAVES 'DELIVERY DATE' FROM FILE 441.7 CALLED FROM 'ITEM'
- N FF,RECORD,Y,OLD,F2NUMBER
- S FF="2;441.7",RECORD=PRCHDA,OLD=0,F2NUMBER=D0
- D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- Q
- ;
- EN7 ;SAVES 'LOCATION FOR DELIVERY' FROM FILE 441.7 CALLED FROM 'ITEM'
- N FF,RECORD,Y,OLD,F2NUMBER
- S FF="3;441.7",RECORD=PRCHDA,OLD=0,F2NUMBER=D0
- D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- Q
- ;
- EN8 ;SAVES 'QTY TO BE DELIVERED' FROM FILE 441.7 CALLED FROM 'ITEM'
- N FF,RECORD,Y,OLD,F2NUMBER
- S FF="4;441.7",RECORD=PRCHDA,OLD=0,F2NUMBER=D0
- D SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- Q
- ;
- SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER) ;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.
- ;'OLD' IS THE VALUE OF X.
- ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
- ;FILE 442.2 OR FILE 441.6.
- ;F2NUMBER IS THE INTERNAL ENTRY NUMBER FOR THE COPY OF THE 'DELIVERY
- ;SCHEDULE (ORDER)' FILE RECORD BEING EDITED. THIS IS FROM FILE 441.7
- N PRCHDA,ALREADY,DS,DIFLD,DIP,D,D0,D1,D2,DIG,DIH,DISYS,DIU,DIV,J,L,DH,DU,DV,DW,DOV,DIOV
- S 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=""
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAMXE 3791 printed Jan 18, 2025@03:07:02 Page 2
- PRCHAMXE ;WISC/DJM-'CHANGES' ROUTINE #5 FOR 443.6 ;2/21/97 15:07
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- +3 ;****NOTE-See PRCHAMXA for information on variable PRCHNORE and
- +4 ;incidence of undefined DIK variable errors.
- +5 ;
- +6 ;'PRCHDA1' AND 'PRCHDA' ARE SET IN THE 'LINE ITEM' AMENDMENT
- +7 ;TEMPLATE.
- +8 ;'PRCHDA' IS THE SUBFILE INTERNAL ENTRY NUMBER OF THE ITEM THAT OWNS
- +9 ;THE DELIVERY SCHEDULE BEING EDITED.
- +10 ;'PRCHDA1' IS THE INTERNAL ENTRY NUMBER OF THE RECORD BEING AMENDED
- +11 ;IN FILE 443.6. (P.O.) OR 441.6 (REQUISITION).
- +12 ;
- EN1 ;SAVES 'ITEM' FROM FILE 441.7 CALLED FROM 'ITEM'
- +1 QUIT
- +2 NEW FF,RECORD,Y,OLD,F2NUMBER
- +3 SET FF="1;441.7"
- SET RECORD=PRCHDA
- SET OLD=$SELECT($PIECE(PRCHYY,U,3)=1:0,1:X)
- SET F2NUMBER=D0
- +4 DO SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- +5 QUIT
- +6 ;
- EN2 ;SAVES 'DELIVERY DATE' FROM FILE 441.7 CALLED FROM 'ITEM'
- +1 NEW FF,RECORD,Y,OLD,F2NUMBER
- +2 SET FF="2;441.7"
- SET RECORD=PRCHDA
- SET OLD=$SELECT($PIECE(PRCHYY,U,3)=1:0,1:X)
- SET F2NUMBER=D0
- +3 DO SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- +4 QUIT
- +5 ;
- EN3 ;SAVES 'LOCATION FOR DELIVERY' FROM FILE 441.7 CALLED FROM 'ITEM'
- +1 NEW FF,RECORD,Y,OLD,F2NUMBER
- +2 SET FF="3;441.7"
- SET RECORD=PRCHDA
- SET OLD=$SELECT($PIECE(PRCHYY,U,3)=1:0,1:X)
- SET F2NUMBER=D0
- +3 DO SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- +4 QUIT
- +5 ;
- EN4 ;SAVES 'QTY TO BE DELIVERED' FROM FILE 441.7 CALLED FROM 'ITEM'
- +1 NEW FF,RECORD,Y,OLD,F2NUMBER
- +2 SET FF="4;441.7"
- SET RECORD=PRCHDA
- SET OLD=$SELECT($PIECE(PRCHYY,U,3)=1:0,1:X)
- SET F2NUMBER=D0
- +3 DO SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- +4 QUIT
- +5 ;
- EN5 ;SAVES 'ITEM' FROM FILE 441.7 CALLED FROM 'ITEM'
- +1 QUIT
- +2 NEW FF,RECORD,Y,OLD,F2NUMBER
- +3 SET FF="1;441.7"
- SET RECORD=PRCHDA
- SET OLD=0
- SET F2NUMBER=D0
- +4 DO SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- +5 QUIT
- +6 ;
- EN6 ;SAVES 'DELIVERY DATE' FROM FILE 441.7 CALLED FROM 'ITEM'
- +1 NEW FF,RECORD,Y,OLD,F2NUMBER
- +2 SET FF="2;441.7"
- SET RECORD=PRCHDA
- SET OLD=0
- SET F2NUMBER=D0
- +3 DO SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- +4 QUIT
- +5 ;
- EN7 ;SAVES 'LOCATION FOR DELIVERY' FROM FILE 441.7 CALLED FROM 'ITEM'
- +1 NEW FF,RECORD,Y,OLD,F2NUMBER
- +2 SET FF="3;441.7"
- SET RECORD=PRCHDA
- SET OLD=0
- SET F2NUMBER=D0
- +3 DO SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- +4 QUIT
- +5 ;
- EN8 ;SAVES 'QTY TO BE DELIVERED' FROM FILE 441.7 CALLED FROM 'ITEM'
- +1 NEW FF,RECORD,Y,OLD,F2NUMBER
- +2 SET FF="4;441.7"
- SET RECORD=PRCHDA
- SET OLD=0
- SET F2NUMBER=D0
- +3 DO SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER)
- +4 QUIT
- +5 ;
- SAVE(FF,PRCHDA1,RECORD,OLD,F2NUMBER) ;THIS WILL DO THE ACTUAL SAVING OF THE INFORMATION.
- +1 ;'PRCHAM' IS DEFINED FROM AMENDMENT ROUTINES.
- +2 ;IT IS THE 'AMENDMENT' FIELD'S RECORD NUMBER FOR THE AMENDMENT THAT
- +3 ;IS BEING ENTERED.
- +4 ;'OLD' IS THE VALUE OF X.
- +5 ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
- +6 ;FILE 442.2 OR FILE 441.6.
- +7 ;F2NUMBER IS THE INTERNAL ENTRY NUMBER FOR THE COPY OF THE 'DELIVERY
- +8 ;SCHEDULE (ORDER)' FILE RECORD BEING EDITED. THIS IS FROM FILE 441.7
- +9 NEW PRCHDA,ALREADY,DS,DIFLD,DIP,D,D0,D1,D2,DIG,DIH,DISYS,DIU,DIV,J,L,DH,DU,DV,DW,DOV,DIOV
- +10 SET ALREADY=$ORDER(^PRC(443.6,"C",PRCHDA1,PRCHAM,FF,RECORD,F2NUMBER,0))
- +11 ;CHECK IF THIS FIELD HAS ALREADY BEEN ENTERED. ONLY THE FIRST ENTRY IS NEEDED.
- if ALREADY>0
- QUIT
- +12 SET PRCHDA=""
- +13 NEW DA,X
- +14 DO NEXT(PRCHDA1,PRCHAM,.PRCHDA)
- +15 NEW DIE,DC,DD,DE,DG,DI,DIEL,DK,DL,DM,DO,DP,DQ,DR
- +16 SET DA(2)=PRCHDA1
- SET DA(1)=PRCHAM
- SET DA=PRCHDA
- SET DIE="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
- +17 SET DR="1////^S X=PRCHAMDA;2////^S X=FF;3///^S X=OLD;4///^S X=RECORD;7////^S X=F2NUMBER"
- DO ^DIE
- +18 QUIT
- +19 ;
- 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.
- +2 NEW AA,BB,DIC,DD,DINUM,DO,X,Y
- +3 SET AA=$GET(^PRC(443.6,DA,6,DA1,3,0))
- IF AA=""
- SET AA=1
- SET ^PRC(443.6,DA,6,DA1,3,0)="^"_$PIECE(^DD(443.67,14,0),"^",2)
- GOTO ENTER
- +4 SET AA=$PIECE(AA,U,3)
- FIND SET AA=AA+1
- SET BB=$GET(^PRC(443.6,DA,6,DA1,3,AA,0))
- IF BB'=""
- GOTO FIND
- ENTER KILL DD,DO
- SET DA(2)=DA
- SET DA(1)=DA1
- SET DIC="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
- SET DIC(0)="L"
- SET (DINUM,X)=AA
- DO FILE^DICN
- if +Y'>0
- GOTO FIND
- +1 SET DA2=+Y
- QUIT