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

PRCFARR2.m

Go to the documentation of this file.
  1. PRCFARR2 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;6/20/95 08:46
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. EN S (PRCFI,PRCFL)=0,PRCFJ=8
  1. N PRCFSWT S PRCFSWT=$P($G(^PRC(442,PRCFPO,11,0)),"^",4)
  1. I '$D(FED) N FED S FED=0 I "13578"[$P(PRCF1,U,7),$P(PRCF1,U,7)]"" S FED=2
  1. N BOC,IENFMS,FMSLNO,FMSAMT
  1. ITM ;#8 ITEM NO.,QTY.ORDERED,UNIT OF PURCH.,UNIT COST,TOTAL COST,QTY.RCVD.,$ AMT.RCVD.,NO.OF DESCRIPTIONS,ITEM DESCRIPTION (MULT).
  1. 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))
  1. ;S PRCFRN=+$O(^PRC(442,PRCFPO,2,"AB",PRCFPRD,PRCFI,0)) K SERIAL
  1. ;ADDED SO ITEMS NOT RECEIVED ON A PARTIAL NOT SENT ON REPORT
  1. K SERIAL I PRCFPR=0 G:PRCFSWT>1 ITM
  1. G ITM:'$D(^PRC(442,PRCFPO,2,PRCFI,3,"AC",PRCFPR))
  1. S PRCFIEN=$O(^PRC(442,PRCFPO,2,PRCFI,3,"AC",PRCFPR,""))
  1. G ITM:PRCFIEN="" S PRCFRN0=$G(^PRC(442,PRCFPO,2,PRCFI,3,PRCFIEN,0))
  1. S X=$P(PRCFI0,"^",2) D FAMT^PRCFARR
  1. S Y=$P($G(^PRCD(420.5,+$P(PRCFI0,"^",3),0)),"^",1)
  1. S Z=+$J($P(PRCFI0,"^",9),0,4) S:'$F(Z,".") Z=Z_"."
  1. S BOC=+$P(PRCFI0,U,4),FMSLNO=""
  1. S IENFMS=$O(^PRC(442,PRCFPO,22,"B",BOC,""))
  1. I IENFMS]"" S FMSLNO=$P($G(^PRC(442,PRCFPO,22,IENFMS,0)),U,3)
  1. S FMSLNO="000"_FMSLNO,FMSLNO=$E(FMSLNO,$L(FMSLNO)-2,$L(FMSLNO))
  1. S PRCFL=PRCFL+1,PRCFX="8^"_FMSLNO_U_$P(PRCFI2,U,5)_+$P(PRCFI0,U,1)
  1. S $P(PRCFX,U,5+FED)=X ; Quantity
  1. S $P(PRCFX,U,6+FED)=Y ; Unit of Purchase
  1. S $P(PRCFX,U,7+FED)=Z ; Unit Cost
  1. S X=$P(PRCFI2,U,1) D FAMT^PRCFARR
  1. S $P(PRCFX,U,8+FED)=X ; Total Cost
  1. S X=$P(PRCFRN0,"^",2) D FAMT^PRCFARR
  1. S $P(PRCFX,U,9+FED)=$S(X<0:-X,1:X) ; Quantity Received
  1. S X=$FN($P(PRCFRN0,U,3)-$P(PRCFRN0,U,5),"",2) D FAMT^PRCFARR
  1. S $P(PRCFX,U,10+FED)=$S(X<0:-X,1:X) ; Dollar Amt. Rec'd
  1. S PRCTOT=PRCTOT+X
  1. S FMSAMT=$P(PRCFRN0,U,3)-$P(PRCFRN0,U,5) S:NET FMSAMT=$FN(FMSAMT*MULT,"",2) ; Take the discount, if any.
  1. S X=FMSAMT D FAMT^PRCFARR S $P(PRCFX,U,11+FED)=$S(X<0:-X,1:X) ; FMS Dollar Amt.
  1. S FMSTOT=FMSTOT+X ; Accumulate Document Total
  1. 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))
  1. F I=0:0 S I=$O(^UTILITY($J,"W",1,I)) Q:'I I $D(^(I,0)) S PRCFL1=PRCFL1+1
  1. S:$P(PRCFI0,"^",6)]"" PRCFL1=PRCFL1+1 S:$P(PRCFI0,"^",13)]"" PRCFL1=PRCFL1+1 S:$P(PRCFI0,"^",12) PRCFL1=PRCFL1+1
  1. S $P(PRCFX,U,12+FED)=PRCFL1
  1. 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
  1. I $P(PRCFI0,"^",6)]"" D:($L(PRCFX)+33)>220 NX S $P(PRCFX,"^",J)="STK#: "_$E($P(PRCFI0,"^",6),1,27),J=J+1
  1. ;I $P(PRCFI0,"^",13)]"" D:($L(PRCFX)+23)>220 NX S $P(PRCFX,"^",J)="NSN: "_$P(PRCFI0,"^",13),J=J+1
  1. I $P(PRCFI0,"^",13)]"" D:($L(PRCFX)+23)>220 NX S $P(PRCFX,"^",J)=$P(PRCFI0,"^",13),J=J+1
  1. 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
  1. ;I $P(PRCFI4,"^",1) D:($L(PRCFX)+14)>220 NX S $P(PRCFX,"^",J)="GSA/DLA# :"_$P(PRCFI4,"^",1),J=J+1
  1. D:PRCFX'="" NX G ITM
  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