- 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 Feb 18, 2025@23:28:54 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