source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFARR2.m@ 1111

Last change on this file since 1111 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1PRCFARR2 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;6/20/95 08:46
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN S (PRCFI,PRCFL)=0,PRCFJ=8
5 N PRCFSWT S PRCFSWT=$P($G(^PRC(442,PRCFPO,11,0)),"^",4)
6 I '$D(FED) N FED S FED=0 I "13578"[$P(PRCF1,U,7),$P(PRCF1,U,7)]"" S FED=2
7 N BOC,IENFMS,FMSLNO,FMSAMT
8ITM ;#8 ITEM NO.,QTY.ORDERED,UNIT OF PURCH.,UNIT COST,TOTAL COST,QTY.RCVD.,$ AMT.RCVD.,NO.OF DESCRIPTIONS,ITEM DESCRIPTION (MULT).
9 S PRCFI=$O(^PRC(442,PRCFPO,2,PRCFI)) G SHP^PRCFARR3:'PRCFI,ITM:'$D(^(PRCFI,0)) S PRCFI0=^(0),PRCFI2=$G(^(2)),PRCFI4=$G(^(4))
10 ;S PRCFRN=+$O(^PRC(442,PRCFPO,2,"AB",PRCFPRD,PRCFI,0)) K SERIAL
11 ;ADDED SO ITEMS NOT RECEIVED ON A PARTIAL NOT SENT ON REPORT
12 K SERIAL I PRCFPR=0 G:PRCFSWT>1 ITM
13 G ITM:'$D(^PRC(442,PRCFPO,2,PRCFI,3,"AC",PRCFPR))
14 S PRCFIEN=$O(^PRC(442,PRCFPO,2,PRCFI,3,"AC",PRCFPR,""))
15 G ITM:PRCFIEN="" S PRCFRN0=$G(^PRC(442,PRCFPO,2,PRCFI,3,PRCFIEN,0))
16 S X=$P(PRCFI0,"^",2) D FAMT^PRCFARR
17 S Y=$P($G(^PRCD(420.5,+$P(PRCFI0,"^",3),0)),"^",1)
18 S Z=+$J($P(PRCFI0,"^",9),0,4) S:'$F(Z,".") Z=Z_"."
19 S BOC=+$P(PRCFI0,U,4),FMSLNO=""
20 S IENFMS=$O(^PRC(442,PRCFPO,22,"B",BOC,""))
21 I IENFMS]"" S FMSLNO=$P($G(^PRC(442,PRCFPO,22,IENFMS,0)),U,3)
22 S FMSLNO="000"_FMSLNO,FMSLNO=$E(FMSLNO,$L(FMSLNO)-2,$L(FMSLNO))
23 S PRCFL=PRCFL+1,PRCFX="8^"_FMSLNO_U_$P(PRCFI2,U,5)_+$P(PRCFI0,U,1)
24 S $P(PRCFX,U,5+FED)=X ; Quantity
25 S $P(PRCFX,U,6+FED)=Y ; Unit of Purchase
26 S $P(PRCFX,U,7+FED)=Z ; Unit Cost
27 S X=$P(PRCFI2,U,1) D FAMT^PRCFARR
28 S $P(PRCFX,U,8+FED)=X ; Total Cost
29 S X=$P(PRCFRN0,"^",2) D FAMT^PRCFARR
30 S $P(PRCFX,U,9+FED)=$S(X<0:-X,1:X) ; Quantity Received
31 S X=$FN($P(PRCFRN0,U,3)-$P(PRCFRN0,U,5),"",2) D FAMT^PRCFARR
32 S $P(PRCFX,U,10+FED)=$S(X<0:-X,1:X) ; Dollar Amt. Rec'd
33 S PRCTOT=PRCTOT+X
34 S FMSAMT=$P(PRCFRN0,U,3)-$P(PRCFRN0,U,5) S:NET FMSAMT=$FN(FMSAMT*MULT,"",2) ; Take the discount, if any.
35 S X=FMSAMT D FAMT^PRCFARR S $P(PRCFX,U,11+FED)=$S(X<0:-X,1:X) ; FMS Dollar Amt.
36 S FMSTOT=FMSTOT+X ; Accumulate Document Total
37 K ^UTILITY($J,"W") S DIWL=1,DIWR=33,DIWF="",PRCFL1=0,PRCF=0 F PRCFK=0:0 S PRCF=$O(^PRC(442,PRCFPO,2,PRCFI,1,PRCF)) Q:'PRCF S X=^(PRCF,0),X=$TR(X,U) D DIWP^PRCUTL($G(DA))
38 F I=0:0 S I=$O(^UTILITY($J,"W",1,I)) Q:'I I $D(^(I,0)) S PRCFL1=PRCFL1+1
39 S:$P(PRCFI0,"^",6)]"" PRCFL1=PRCFL1+1 S:$P(PRCFI0,"^",13)]"" PRCFL1=PRCFL1+1 S:$P(PRCFI0,"^",12) PRCFL1=PRCFL1+1
40 S $P(PRCFX,U,12+FED)=PRCFL1
41 S J=13+FED F I=0:0 S I=$O(^UTILITY($J,"W",1,I)) Q:'I I $D(^(I,0)) S X=$E(^(0),1,33) D:($L(PRCFX)+$L(X)+1)>220 NX S $P(PRCFX,"^",J)=X,J=J+1
42 I $P(PRCFI0,"^",6)]"" D:($L(PRCFX)+33)>220 NX S $P(PRCFX,"^",J)="STK#: "_$E($P(PRCFI0,"^",6),1,27),J=J+1
43 ;I $P(PRCFI0,"^",13)]"" D:($L(PRCFX)+23)>220 NX S $P(PRCFX,"^",J)="NSN: "_$P(PRCFI0,"^",13),J=J+1
44 I $P(PRCFI0,"^",13)]"" D:($L(PRCFX)+23)>220 NX S $P(PRCFX,"^",J)=$P(PRCFI0,"^",13),J=J+1
45 I $P(PRCFI0,"^",12) D:($L(PRCFX)+21)>220 NX S $P(PRCFX,"^",J)="Items per "_$S($D(^PRCD(420.5,+$P(PRCFI0,"^",3),0)):$P(^(0),"^",1),1:"")_": "_$P(PRCFI0,"^",12),J=J+1
46 ;I $P(PRCFI4,"^",1) D:($L(PRCFX)+14)>220 NX S $P(PRCFX,"^",J)="GSA/DLA# :"_$P(PRCFI4,"^",1),J=J+1
47 D:PRCFX'="" NX G ITM
48NX ; Setting Serial Number
49 G:$D(SERIAL) NX1 D:FED
50 . S SERIAL=$P(PRCFI4,U,1),$P(PRCFX,U,5)=$P(PRCFI4,U,1) ; Serial Number
51 . S $P(PRCFX,U,6)=$P(PRCFI0,U,13) ; National Stock Number (NSN)
52 . Q
53NX1 S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_"^",PRCFX="",K=1,J=1,PRCFJ=PRCFJ+1 Q
Note: See TracBrowser for help on using the repository browser.