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