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

PRCFARR3.m

Go to the documentation of this file.
  1. PRCFARR3 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;12/2/94 14:11
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. NX ; Setting Serial Number
  1. G:$D(SERIAL) NX1 D:FED
  1. . S SERIAL=$P(PRCFI4,U,1),$P(PRCFX,U,5)=$P(PRCFI4,U,1) ; Serial Number
  1. . S $P(PRCFX,U,6)=$P(PRCFI0,U,13) ; National Stock Number (NSN)
  1. . Q
  1. NX1 S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_"^",PRCFX="",K=1,J=1,PRCFJ=PRCFJ+1 Q
  1. RUP ; REMOVE ANY UP ARROWS FROM WORD PROCESSING FIELDS
  1. S X=$TR(X,"^") Q
  1. DIS ;TRADE DISCOUNTS SET UP LIKE LINE/ITEM
  1. G:'$O(^PRC(442,PRCFPO,3,0)) SHP S PRCFI=0
  1. DIS1 S PRCFI=$O(^PRC(442,PRCFPO,3,PRCFI)) G:'PRCFI SHP S PRCFI0=^(PRCFI,0),X=$P(PRCFI0,"^",3) D FAMT^PRCFARR S PRCFSERI=$P(PRCFI0,U,6)
  1. I "13578"[$P(PRCF1,U,7),$P(PRCF1,U,7)]"" S PRCFLITM=$P(PRCFI0,"^",1),SERIAL=$P($G(^PRC(442,PRCFPO,2,PRCFLITM,4)),U,1),PRCFSERI=PRCFSERI_"^"_SERIAL
  1. S PRCFX="8^"_PRCFSERI_"^^^^"_X_"^^^1^"
  1. S X="LESS "_$P(PRCFI0,"^",2)_$S($E($P(PRCFI0,"^",2),1)="$":"",1:" %")_" FOR "_$S($P(PRCFI0,"^",1)="Q":"QUANTITY DISCOUNT",1:"ITEMS: "_$P(PRCFI0,"^",1))
  1. S X2="" I $L(X)>33 S X2=$E(X,34,$L(X)),X=$E(X,1,33),$P(PRCFX,"^",9)=2
  1. S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_X_"^" S:X2]"" ^(0)=^(0)_X2_"^" S PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
  1. G DIS1
  1. SHP ;SHIPPING/HANDLING CHARGES SET UP LIKE LINE/ITEM
  1. S X=+$P(PRCF0,"^",13) D FAMT^PRCFARR
  1. I $D(^PRC(442,PRCFPO,22,"B",991)),'X D
  1. . S PRCFX="",PRCFSER=$P(PRCF0,"^",18)
  1. .;I "13578"[$P(PRCF1,U,7),$P(PRCF1,U,7)]"" S PRCFSER=PRCFSER_"^"
  1. . S $P(PRCFX,U,1)=8 ; Segment #
  1. . I $D(^PRC(442,PRCFPO,22,"B",991)) S $P(PRCFX,U,2)=991 ; Shp FMS Ln
  1. . S $P(PRCFX,U,3)=PRCFSER
  1. .; All assumed to be GROSS amounts:
  1. . S $P(PRCFX,U,8+FED)=X ; Total Cost
  1. . S $P(PRCFX,U,10+FED)=X ; Dollar Amount Received
  1. . S $P(PRCFX,U,11+FED)=X ; FMS Dollar Amount Received
  1. . S $P(PRCFX,U,12+FED)=1 ; Number of Descriptions
  1. . S $P(PRCFX,U,13+FED)="ESTIMATED SHIPPING &/OR HANDLING" ; Descript.
  1. . S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_U,PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
  1. .;S ^TMP("PRCFARR",$J,PRCFJ,0)="8^"_PRCFSER_"^^^^"_X_"^^^1^ESTIMATED SHIPPING &/OR HANDLING^",PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
  1. . Q
  1. COM ;#9-P.O.COMMENTS
  1. G EXIT:'$O(^PRC(442,PRCFPO,4,0))!(PRCFPR'=1) K ^UTILITY($J,"W")
  1. S DIWL=1,DIWR=64,DIWF="",PRCF=0
  1. F PRCFK=0:0 S PRCF=$O(^PRC(442,PRCFPO,4,PRCF)) Q:PRCF="" S X=^(PRCF,0) D RUP,DIWP^PRCUTL($G(DA))
  1. S J=0 F I=0:0 S I=$O(^UTILITY($J,"W",1,I)) Q:'I I $D(^(I,0)) S J=J+1
  1. S PRCFX="9^"_J S J=3 F I=0:0 S I=$O(^UTILITY($J,"W",1,I)) Q:'I I $D(^(I,0)) S X=$E(^(0),1,64) D:($L(PRCFX)+$L(X)+1)>240 NX1 S $P(PRCFX,"^",J)=X,J=J+1
  1. D:PRCFX'="" NX1
  1. EXIT ;TAKE ANY END-OF-MESSAGE INDICATOR OUT OF TEXT.
  1. F I=0:0 S I=$O(^TMP("PRCFARR",$J,I)) Q:'I I $D(^(I,0)) S X=^(0) D
  1. . F S Y=$F(X,"NNNN") Q:'Y S Z=$S((Y-5)>0:$E(X,1,(Y-5)),1:"")_"nnnn"_$E(X,Y,$L(X)),X=Z
  1. . S X=$TR(X,"~"),^TMP("PRCFARR",$J,I,0)=X
  1. . Q
  1. ;Update Document Totals:
  1. S $P(^TMP("PRCFARR",$J,5,0),U,4,5)=$S(PRCTOT<0:-PRCTOT,1:PRCTOT)_"^"_$S(FMSTOT<0:-FMSTOT,1:FMSTOT)
  1. ;PUT IN LINE/ITEM COUNTS AND END-OF MESSAGE INDICATOR.
  1. S $P(^TMP("PRCFARR",$J,1,0),"^",7)=PRCFL,PRCFJ=PRCFJ-1
  1. I PRCFJ>0 S ^TMP("PRCFARR",$J,PRCFJ,0)=^TMP("PRCFARR",$J,PRCFJ,0)_"~"
  1. K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,I,J,K,PRCF,PRCFI,PRCFI0,PRCFI2,PRCFI4,PRCFJ,PRCFL,PRCFL1,PRCFK,PRCFRN,PRCFRN0,PRCFX,PRCHFTYP,X,Y,Z
  1. EX K ^UTILITY($J),DA,DIC,P,PRCFX,PRCFPO,PRCFPR,PRCFPRD,PRCF0,PRCF1,PRCF11,PRCF12,Z1,PRCF17,PRCF18,PRCFJDN,SCD,AGYCD,X2,SERIAL,PRCFSERI,PRCFSER,PRCFLITM
  1. Q