PRCFARR3 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;12/2/94 14:11
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
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
RUP ; REMOVE ANY UP ARROWS FROM WORD PROCESSING FIELDS
S X=$TR(X,"^") Q
DIS ;TRADE DISCOUNTS SET UP LIKE LINE/ITEM
G:'$O(^PRC(442,PRCFPO,3,0)) SHP S PRCFI=0
DIS1 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)
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
S PRCFX="8^"_PRCFSERI_"^^^^"_X_"^^^1^"
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))
S X2="" I $L(X)>33 S X2=$E(X,34,$L(X)),X=$E(X,1,33),$P(PRCFX,"^",9)=2
S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_X_"^" S:X2]"" ^(0)=^(0)_X2_"^" S PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
G DIS1
SHP ;SHIPPING/HANDLING CHARGES SET UP LIKE LINE/ITEM
S X=+$P(PRCF0,"^",13) D FAMT^PRCFARR
I $D(^PRC(442,PRCFPO,22,"B",991)),'X D
. S PRCFX="",PRCFSER=$P(PRCF0,"^",18)
.;I "13578"[$P(PRCF1,U,7),$P(PRCF1,U,7)]"" S PRCFSER=PRCFSER_"^"
. S $P(PRCFX,U,1)=8 ; Segment #
. I $D(^PRC(442,PRCFPO,22,"B",991)) S $P(PRCFX,U,2)=991 ; Shp FMS Ln
. S $P(PRCFX,U,3)=PRCFSER
.; All assumed to be GROSS amounts:
. S $P(PRCFX,U,8+FED)=X ; Total Cost
. S $P(PRCFX,U,10+FED)=X ; Dollar Amount Received
. S $P(PRCFX,U,11+FED)=X ; FMS Dollar Amount Received
. S $P(PRCFX,U,12+FED)=1 ; Number of Descriptions
. S $P(PRCFX,U,13+FED)="ESTIMATED SHIPPING &/OR HANDLING" ; Descript.
. S ^TMP("PRCFARR",$J,PRCFJ,0)=PRCFX_U,PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
.;S ^TMP("PRCFARR",$J,PRCFJ,0)="8^"_PRCFSER_"^^^^"_X_"^^^1^ESTIMATED SHIPPING &/OR HANDLING^",PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
. Q
COM ;#9-P.O.COMMENTS
G EXIT:'$O(^PRC(442,PRCFPO,4,0))!(PRCFPR'=1) K ^UTILITY($J,"W")
S DIWL=1,DIWR=64,DIWF="",PRCF=0
F PRCFK=0:0 S PRCF=$O(^PRC(442,PRCFPO,4,PRCF)) Q:PRCF="" S X=^(PRCF,0) D RUP,DIWP^PRCUTL($G(DA))
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
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
D:PRCFX'="" NX1
EXIT ;TAKE ANY END-OF-MESSAGE INDICATOR OUT OF TEXT.
F I=0:0 S I=$O(^TMP("PRCFARR",$J,I)) Q:'I I $D(^(I,0)) S X=^(0) D
. 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
. S X=$TR(X,"~"),^TMP("PRCFARR",$J,I,0)=X
. Q
;Update Document Totals:
S $P(^TMP("PRCFARR",$J,5,0),U,4,5)=$S(PRCTOT<0:-PRCTOT,1:PRCTOT)_"^"_$S(FMSTOT<0:-FMSTOT,1:FMSTOT)
;PUT IN LINE/ITEM COUNTS AND END-OF MESSAGE INDICATOR.
S $P(^TMP("PRCFARR",$J,1,0),"^",7)=PRCFL,PRCFJ=PRCFJ-1
I PRCFJ>0 S ^TMP("PRCFARR",$J,PRCFJ,0)=^TMP("PRCFARR",$J,PRCFJ,0)_"~"
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
EX 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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFARR3 3486 printed Dec 13, 2024@02:02:32 Page 2
PRCFARR3 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;12/2/94 14:11
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
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
RUP ; REMOVE ANY UP ARROWS FROM WORD PROCESSING FIELDS
+1 SET X=$TRANSLATE(X,"^")
QUIT
DIS ;TRADE DISCOUNTS SET UP LIKE LINE/ITEM
+1 if '$ORDER(^PRC(442,PRCFPO,3,0))
GOTO SHP
SET PRCFI=0
DIS1 SET PRCFI=$ORDER(^PRC(442,PRCFPO,3,PRCFI))
if 'PRCFI
GOTO SHP
SET PRCFI0=^(PRCFI,0)
SET X=$PIECE(PRCFI0,"^",3)
DO FAMT^PRCFARR
SET PRCFSERI=$PIECE(PRCFI0,U,6)
+1 IF "13578"[$PIECE(PRCF1,U,7)
IF $PIECE(PRCF1,U,7)]""
SET PRCFLITM=$PIECE(PRCFI0,"^",1)
SET SERIAL=$PIECE($GET(^PRC(442,PRCFPO,2,PRCFLITM,4)),U,1)
SET PRCFSERI=PRCFSERI_"^"_SERIAL
+2 SET PRCFX="8^"_PRCFSERI_"^^^^"_X_"^^^1^"
+3 SET X="LESS "_$PIECE(PRCFI0,"^",2)_$SELECT($EXTRACT($PIECE(PRCFI0,"^",2),1)="$":"",1:" %")_" FOR "_$SELECT($PIECE(PRCFI0,"^",1)="Q":"QUANTITY DISCOUNT",1:"ITEMS: "_$PIECE(PRCFI0,"^",1))
+4 SET X2=""
IF $LENGTH(X)>33
SET X2=$EXTRACT(X,34,$LENGTH(X))
SET X=$EXTRACT(X,1,33)
SET $PIECE(PRCFX,"^",9)=2
+5 SET ^TMP("PRCFARR",$JOB,PRCFJ,0)=PRCFX_X_"^"
if X2]""
SET ^(0)=^(0)_X2_"^"
SET PRCFJ=PRCFJ+1
SET PRCFL=PRCFL+1
+6 GOTO DIS1
SHP ;SHIPPING/HANDLING CHARGES SET UP LIKE LINE/ITEM
+1 SET X=+$PIECE(PRCF0,"^",13)
DO FAMT^PRCFARR
+2 IF $DATA(^PRC(442,PRCFPO,22,"B",991))
IF 'X
Begin DoDot:1
+3 SET PRCFX=""
SET PRCFSER=$PIECE(PRCF0,"^",18)
+4 ;I "13578"[$P(PRCF1,U,7),$P(PRCF1,U,7)]"" S PRCFSER=PRCFSER_"^"
+5 ; Segment #
SET $PIECE(PRCFX,U,1)=8
+6 ; Shp FMS Ln
IF $DATA(^PRC(442,PRCFPO,22,"B",991))
SET $PIECE(PRCFX,U,2)=991
+7 SET $PIECE(PRCFX,U,3)=PRCFSER
+8 ; All assumed to be GROSS amounts:
+9 ; Total Cost
SET $PIECE(PRCFX,U,8+FED)=X
+10 ; Dollar Amount Received
SET $PIECE(PRCFX,U,10+FED)=X
+11 ; FMS Dollar Amount Received
SET $PIECE(PRCFX,U,11+FED)=X
+12 ; Number of Descriptions
SET $PIECE(PRCFX,U,12+FED)=1
+13 ; Descript.
SET $PIECE(PRCFX,U,13+FED)="ESTIMATED SHIPPING &/OR HANDLING"
+14 SET ^TMP("PRCFARR",$JOB,PRCFJ,0)=PRCFX_U
SET PRCFJ=PRCFJ+1
SET PRCFL=PRCFL+1
+15 ;S ^TMP("PRCFARR",$J,PRCFJ,0)="8^"_PRCFSER_"^^^^"_X_"^^^1^ESTIMATED SHIPPING &/OR HANDLING^",PRCFJ=PRCFJ+1,PRCFL=PRCFL+1
+16 QUIT
End DoDot:1
COM ;#9-P.O.COMMENTS
+1 if '$ORDER(^PRC(442,PRCFPO,4,0))!(PRCFPR'=1)
GOTO EXIT
KILL ^UTILITY($JOB,"W")
+2 SET DIWL=1
SET DIWR=64
SET DIWF=""
SET PRCF=0
+3 FOR PRCFK=0:0
SET PRCF=$ORDER(^PRC(442,PRCFPO,4,PRCF))
if PRCF=""
QUIT
SET X=^(PRCF,0)
DO RUP
DO DIWP^PRCUTL($GET(DA))
+4 SET J=0
FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"W",1,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET J=J+1
+5 SET PRCFX="9^"_J
SET J=3
FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"W",1,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET X=$EXTRACT(^(0),1,64)
if ($LENGTH(PRCFX)+$LENGTH(X)+1)>240
DO NX1
SET $PIECE(PRCFX,"^",J)=X
SET J=J+1
+6 if PRCFX'=""
DO NX1
EXIT ;TAKE ANY END-OF-MESSAGE INDICATOR OUT OF TEXT.
+1 FOR I=0:0
SET I=$ORDER(^TMP("PRCFARR",$JOB,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET X=^(0)
Begin DoDot:1
+2 FOR
SET Y=$FIND(X,"NNNN")
if 'Y
QUIT
SET Z=$SELECT((Y-5)>0:$EXTRACT(X,1,(Y-5)),1:"")_"nnnn"_$EXTRACT(X,Y,$LENGTH(X))
SET X=Z
+3 SET X=$TRANSLATE(X,"~")
SET ^TMP("PRCFARR",$JOB,I,0)=X
+4 QUIT
End DoDot:1
+5 ;Update Document Totals:
+6 SET $PIECE(^TMP("PRCFARR",$JOB,5,0),U,4,5)=$SELECT(PRCTOT<0:-PRCTOT,1:PRCTOT)_"^"_$SELECT(FMSTOT<0:-FMSTOT,1:FMSTOT)
+7 ;PUT IN LINE/ITEM COUNTS AND END-OF MESSAGE INDICATOR.
+8 SET $PIECE(^TMP("PRCFARR",$JOB,1,0),"^",7)=PRCFL
SET PRCFJ=PRCFJ-1
+9 IF PRCFJ>0
SET ^TMP("PRCFARR",$JOB,PRCFJ,0)=^TMP("PRCFARR",$JOB,PRCFJ,0)_"~"
+10 KILL 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
EX KILL ^UTILITY($JOB),DA,DIC,P,PRCFX,PRCFPO,PRCFPR,PRCFPRD,PRCF0,PRCF1,PRCF11,PRCF12,Z1,PRCF17,PRCF18,PRCFJDN,SCD,AGYCD,X2,SERIAL,PRCFSERI,PRCFSER,PRCFLITM
+1 QUIT
