source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFARR3.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.3 KB
Line 
1PRCFARR3 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;12/2/94 14:11
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4NX ; Setting Serial Number
5 G:$D(SERIAL) NX1 D:FED
6 . S SERIAL=$P(PRCFI4,U,1),$P(PRCFX,U,5)=$P(PRCFI4,U,1) ; Serial Number
7 . S $P(PRCFX,U,6)=$P(PRCFI0,U,13) ; National Stock Number (NSN)
8 . Q
9NX1 S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_"^",PRCFX="",K=1,J=1,PRCFJ=PRCFJ+1 Q
10RUP ; REMOVE ANY UP ARROWS FROM WORD PROCESSING FIELDS
11 S X=$TR(X,"^") Q
12DIS ;TRADE DISCOUNTS SET UP LIKE LINE/ITEM
13 G:'$O(^PRC(442,PRCFPO,3,0)) SHP S PRCFI=0
14DIS1 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)
15 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
16 S PRCFX="8^"_PRCFSERI_"^^^^"_X_"^^^1^"
17 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))
18 S X2="" I $L(X)>33 S X2=$E(X,34,$L(X)),X=$E(X,1,33),$P(PRCFX,"^",9)=2
19 S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_X_"^" S:X2]"" ^(0)=^(0)_X2_"^" S PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
20 G DIS1
21SHP ;SHIPPING/HANDLING CHARGES SET UP LIKE LINE/ITEM
22 S X=+$P(PRCF0,"^",13) D FAMT^PRCFARR
23 I $D(^PRC(442,PRCFPO,22,"B",991)),'X D
24 . S PRCFX="",PRCFSER=$P(PRCF0,"^",18)
25 .;I "13578"[$P(PRCF1,U,7),$P(PRCF1,U,7)]"" S PRCFSER=PRCFSER_"^"
26 . S $P(PRCFX,U,1)=8 ; Segment #
27 . I $D(^PRC(442,PRCFPO,22,"B",991)) S $P(PRCFX,U,2)=991 ; Shp FMS Ln
28 . S $P(PRCFX,U,3)=PRCFSER
29 .; All assumed to be GROSS amounts:
30 . S $P(PRCFX,U,8+FED)=X ; Total Cost
31 . S $P(PRCFX,U,10+FED)=X ; Dollar Amount Received
32 . S $P(PRCFX,U,11+FED)=X ; FMS Dollar Amount Received
33 . S $P(PRCFX,U,12+FED)=1 ; Number of Descriptions
34 . S $P(PRCFX,U,13+FED)="ESTIMATED SHIPPING &/OR HANDLING" ; Descript.
35 . S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_U,PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
36 .;S ^TMP("PRCFARR",$J,PRCFJ,0)="8^"_PRCFSER_"^^^^"_X_"^^^1^ESTIMATED SHIPPING &/OR HANDLING^",PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
37 . Q
38COM ;#9-P.O.COMMENTS
39 G EXIT:'$O(^PRC(442,PRCFPO,4,0))!(PRCFPR'=1) K ^UTILITY($J,"W")
40 S DIWL=1,DIWR=64,DIWF="",PRCF=0
41 F PRCFK=0:0 S PRCF=$O(^PRC(442,PRCFPO,4,PRCF)) Q:PRCF="" S X=^(PRCF,0) D RUP,DIWP^PRCUTL($G(DA))
42 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
43 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
44 D:PRCFX'="" NX1
45EXIT ;TAKE ANY END-OF-MESSAGE INDICATOR OUT OF TEXT.
46 F I=0:0 S I=$O(^TMP("PRCFARR",$J,I)) Q:'I I $D(^(I,0)) S X=^(0) D
47 . 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
48 . S X=$TR(X,"~"),^TMP("PRCFARR",$J,I,0)=X
49 . Q
50 ;Update Document Totals:
51 S $P(^TMP("PRCFARR",$J,5,0),U,4,5)=$S(PRCTOT<0:-PRCTOT,1:PRCTOT)_"^"_$S(FMSTOT<0:-FMSTOT,1:FMSTOT)
52 ;PUT IN LINE/ITEM COUNTS AND END-OF MESSAGE INDICATOR.
53 S $P(^TMP("PRCFARR",$J,1,0),"^",7)=PRCFL,PRCFJ=PRCFJ-1
54 I PRCFJ>0 S ^TMP("PRCFARR",$J,PRCFJ,0)=^TMP("PRCFARR",$J,PRCFJ,0)_"~"
55 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
56EX 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
57 Q
Note: See TracBrowser for help on using the repository browser.