PRCFARR2 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;6/20/95 08:46
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN S (PRCFI,PRCFL)=0,PRCFJ=8
N PRCFSWT S PRCFSWT=$P($G(^PRC(442,PRCFPO,11,0)),"^",4)
I '$D(FED) N FED S FED=0 I "13578"[$P(PRCF1,U,7),$P(PRCF1,U,7)]"" S FED=2
N BOC,IENFMS,FMSLNO,FMSAMT
ITM ;#8 ITEM NO.,QTY.ORDERED,UNIT OF PURCH.,UNIT COST,TOTAL COST,QTY.RCVD.,$ AMT.RCVD.,NO.OF DESCRIPTIONS,ITEM DESCRIPTION (MULT).
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))
;S PRCFRN=+$O(^PRC(442,PRCFPO,2,"AB",PRCFPRD,PRCFI,0)) K SERIAL
;ADDED SO ITEMS NOT RECEIVED ON A PARTIAL NOT SENT ON REPORT
K SERIAL I PRCFPR=0 G:PRCFSWT>1 ITM
G ITM:'$D(^PRC(442,PRCFPO,2,PRCFI,3,"AC",PRCFPR))
S PRCFIEN=$O(^PRC(442,PRCFPO,2,PRCFI,3,"AC",PRCFPR,""))
G ITM:PRCFIEN="" S PRCFRN0=$G(^PRC(442,PRCFPO,2,PRCFI,3,PRCFIEN,0))
S X=$P(PRCFI0,"^",2) D FAMT^PRCFARR
S Y=$P($G(^PRCD(420.5,+$P(PRCFI0,"^",3),0)),"^",1)
S Z=+$J($P(PRCFI0,"^",9),0,4) S:'$F(Z,".") Z=Z_"."
S BOC=+$P(PRCFI0,U,4),FMSLNO=""
S IENFMS=$O(^PRC(442,PRCFPO,22,"B",BOC,""))
I IENFMS]"" S FMSLNO=$P($G(^PRC(442,PRCFPO,22,IENFMS,0)),U,3)
S FMSLNO="000"_FMSLNO,FMSLNO=$E(FMSLNO,$L(FMSLNO)-2,$L(FMSLNO))
S PRCFL=PRCFL+1,PRCFX="8^"_FMSLNO_U_$P(PRCFI2,U,5)_+$P(PRCFI0,U,1)
S $P(PRCFX,U,5+FED)=X ; Quantity
S $P(PRCFX,U,6+FED)=Y ; Unit of Purchase
S $P(PRCFX,U,7+FED)=Z ; Unit Cost
S X=$P(PRCFI2,U,1) D FAMT^PRCFARR
S $P(PRCFX,U,8+FED)=X ; Total Cost
S X=$P(PRCFRN0,"^",2) D FAMT^PRCFARR
S $P(PRCFX,U,9+FED)=$S(X<0:-X,1:X) ; Quantity Received
S X=$FN($P(PRCFRN0,U,3)-$P(PRCFRN0,U,5),"",2) D FAMT^PRCFARR
S $P(PRCFX,U,10+FED)=$S(X<0:-X,1:X) ; Dollar Amt. Rec'd
S PRCTOT=PRCTOT+X
S FMSAMT=$P(PRCFRN0,U,3)-$P(PRCFRN0,U,5) S:NET FMSAMT=$FN(FMSAMT*MULT,"",2) ; Take the discount, if any.
S X=FMSAMT D FAMT^PRCFARR S $P(PRCFX,U,11+FED)=$S(X<0:-X,1:X) ; FMS Dollar Amt.
S FMSTOT=FMSTOT+X ; Accumulate Document Total
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))
F I=0:0 S I=$O(^UTILITY($J,"W",1,I)) Q:'I I $D(^(I,0)) S PRCFL1=PRCFL1+1
S:$P(PRCFI0,"^",6)]"" PRCFL1=PRCFL1+1 S:$P(PRCFI0,"^",13)]"" PRCFL1=PRCFL1+1 S:$P(PRCFI0,"^",12) PRCFL1=PRCFL1+1
S $P(PRCFX,U,12+FED)=PRCFL1
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
I $P(PRCFI0,"^",6)]"" D:($L(PRCFX)+33)>220 NX S $P(PRCFX,"^",J)="STK#: "_$E($P(PRCFI0,"^",6),1,27),J=J+1
;I $P(PRCFI0,"^",13)]"" D:($L(PRCFX)+23)>220 NX S $P(PRCFX,"^",J)="NSN: "_$P(PRCFI0,"^",13),J=J+1
I $P(PRCFI0,"^",13)]"" D:($L(PRCFX)+23)>220 NX S $P(PRCFX,"^",J)=$P(PRCFI0,"^",13),J=J+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
;I $P(PRCFI4,"^",1) D:($L(PRCFX)+14)>220 NX S $P(PRCFX,"^",J)="GSA/DLA# :"_$P(PRCFI4,"^",1),J=J+1
D:PRCFX'="" NX G ITM
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFARR2 3451 printed Dec 13, 2024@02:02:31 Page 2
PRCFARR2 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;6/20/95 08:46
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN SET (PRCFI,PRCFL)=0
SET PRCFJ=8
+1 NEW PRCFSWT
SET PRCFSWT=$PIECE($GET(^PRC(442,PRCFPO,11,0)),"^",4)
+2 IF '$DATA(FED)
NEW FED
SET FED=0
IF "13578"[$PIECE(PRCF1,U,7)
IF $PIECE(PRCF1,U,7)]""
SET FED=2
+3 NEW BOC,IENFMS,FMSLNO,FMSAMT
ITM ;#8 ITEM NO.,QTY.ORDERED,UNIT OF PURCH.,UNIT COST,TOTAL COST,QTY.RCVD.,$ AMT.RCVD.,NO.OF DESCRIPTIONS,ITEM DESCRIPTION (MULT).
+1 SET PRCFI=$ORDER(^PRC(442,PRCFPO,2,PRCFI))
if 'PRCFI
GOTO SHP^PRCFARR3
if '$DATA(^(PRCFI,0))
GOTO ITM
SET PRCFI0=^(0)
SET PRCFI2=$GET(^(2))
SET PRCFI4=$GET(^(4))
+2 ;S PRCFRN=+$O(^PRC(442,PRCFPO,2,"AB",PRCFPRD,PRCFI,0)) K SERIAL
+3 ;ADDED SO ITEMS NOT RECEIVED ON A PARTIAL NOT SENT ON REPORT
+4 KILL SERIAL
IF PRCFPR=0
if PRCFSWT>1
GOTO ITM
+5 if '$DATA(^PRC(442,PRCFPO,2,PRCFI,3,"AC",PRCFPR))
GOTO ITM
+6 SET PRCFIEN=$ORDER(^PRC(442,PRCFPO,2,PRCFI,3,"AC",PRCFPR,""))
+7 if PRCFIEN=""
GOTO ITM
SET PRCFRN0=$GET(^PRC(442,PRCFPO,2,PRCFI,3,PRCFIEN,0))
+8 SET X=$PIECE(PRCFI0,"^",2)
DO FAMT^PRCFARR
+9 SET Y=$PIECE($GET(^PRCD(420.5,+$PIECE(PRCFI0,"^",3),0)),"^",1)
+10 SET Z=+$JUSTIFY($PIECE(PRCFI0,"^",9),0,4)
if '$FIND(Z,".")
SET Z=Z_"."
+11 SET BOC=+$PIECE(PRCFI0,U,4)
SET FMSLNO=""
+12 SET IENFMS=$ORDER(^PRC(442,PRCFPO,22,"B",BOC,""))
+13 IF IENFMS]""
SET FMSLNO=$PIECE($GET(^PRC(442,PRCFPO,22,IENFMS,0)),U,3)
+14 SET FMSLNO="000"_FMSLNO
SET FMSLNO=$EXTRACT(FMSLNO,$LENGTH(FMSLNO)-2,$LENGTH(FMSLNO))
+15 SET PRCFL=PRCFL+1
SET PRCFX="8^"_FMSLNO_U_$PIECE(PRCFI2,U,5)_+$PIECE(PRCFI0,U,1)
+16 ; Quantity
SET $PIECE(PRCFX,U,5+FED)=X
+17 ; Unit of Purchase
SET $PIECE(PRCFX,U,6+FED)=Y
+18 ; Unit Cost
SET $PIECE(PRCFX,U,7+FED)=Z
+19 SET X=$PIECE(PRCFI2,U,1)
DO FAMT^PRCFARR
+20 ; Total Cost
SET $PIECE(PRCFX,U,8+FED)=X
+21 SET X=$PIECE(PRCFRN0,"^",2)
DO FAMT^PRCFARR
+22 ; Quantity Received
SET $PIECE(PRCFX,U,9+FED)=$SELECT(X<0:-X,1:X)
+23 SET X=$FNUMBER($PIECE(PRCFRN0,U,3)-$PIECE(PRCFRN0,U,5),"",2)
DO FAMT^PRCFARR
+24 ; Dollar Amt. Rec'd
SET $PIECE(PRCFX,U,10+FED)=$SELECT(X<0:-X,1:X)
+25 SET PRCTOT=PRCTOT+X
+26 ; Take the discount, if any.
SET FMSAMT=$PIECE(PRCFRN0,U,3)-$PIECE(PRCFRN0,U,5)
if NET
SET FMSAMT=$FNUMBER(FMSAMT*MULT,"",2)
+27 ; FMS Dollar Amt.
SET X=FMSAMT
DO FAMT^PRCFARR
SET $PIECE(PRCFX,U,11+FED)=$SELECT(X<0:-X,1:X)
+28 ; Accumulate Document Total
SET FMSTOT=FMSTOT+X
+29 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=33
SET DIWF=""
SET PRCFL1=0
SET PRCF=0
FOR PRCFK=0:0
SET PRCF=$ORDER(^PRC(442,PRCFPO,2,PRCFI,1,PRCF))
if 'PRCF
QUIT
SET X=^(PRCF,0)
SET X=$TRANSLATE(X,U)
DO DIWP^PRCUTL($GET(DA))
+30 FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"W",1,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET PRCFL1=PRCFL1+1
+31 if $PIECE(PRCFI0,"^",6)]""
SET PRCFL1=PRCFL1+1
if $PIECE(PRCFI0,"^",13)]""
SET PRCFL1=PRCFL1+1
if $PIECE(PRCFI0,"^",12)
SET PRCFL1=PRCFL1+1
+32 SET $PIECE(PRCFX,U,12+FED)=PRCFL1
+33 SET J=13+FED
FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"W",1,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET X=$EXTRACT(^(0),1,33)
if ($LENGTH(PRCFX)+$LENGTH(X)+1)>220
DO NX
SET $PIECE(PRCFX,"^",J)=X
SET J=J+1
+34 IF $PIECE(PRCFI0,"^",6)]""
if ($LENGTH(PRCFX)+33)>220
DO NX
SET $PIECE(PRCFX,"^",J)="STK#: "_$EXTRACT($PIECE(PRCFI0,"^",6),1,27)
SET J=J+1
+35 ;I $P(PRCFI0,"^",13)]"" D:($L(PRCFX)+23)>220 NX S $P(PRCFX,"^",J)="NSN: "_$P(PRCFI0,"^",13),J=J+1
+36 IF $PIECE(PRCFI0,"^",13)]""
if ($LENGTH(PRCFX)+23)>220
DO NX
SET $PIECE(PRCFX,"^",J)=$PIECE(PRCFI0,"^",13)
SET J=J+1
+37 IF $PIECE(PRCFI0,"^",12)
if ($LENGTH(PRCFX)+21)>220
DO NX
SET $PIECE(PRCFX,"^",J)="Items per "_$SELECT($DATA(^PRCD(420.5,+$PIECE(PRCFI0,"^",3),0)):$PIECE(^(0),"^",1),1:"")_": "_$PIECE(PRCFI0,"^",12)
SET J=J+1
+38 ;I $P(PRCFI4,"^",1) D:($L(PRCFX)+14)>220 NX S $P(PRCFX,"^",J)="GSA/DLA# :"_$P(PRCFI4,"^",1),J=J+1
+39 if PRCFX'=""
DO NX
GOTO ITM
NX ; Setting Serial Number
+1 if $DATA(SERIAL)
GOTO NX1
if FED
Begin DoDot:1
+2 ; Serial Number
SET SERIAL=$PIECE(PRCFI4,U,1)
SET $PIECE(PRCFX,U,5)=$PIECE(PRCFI4,U,1)
+3 ; National Stock Number (NSN)
SET $PIECE(PRCFX,U,6)=$PIECE(PRCFI0,U,13)
+4 QUIT
End DoDot:1
NX1 SET ^TMP("PRCFARR",$JOB,PRCFJ,0)=PRCFX_"^"
SET PRCFX=""
SET K=1
SET J=1
SET PRCFJ=PRCFJ+1
QUIT
