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