PRCFARR0 ;ISC-SF/TKW-BUILD RECEIVING REPORT FOR ELECTRONIC TRANSMISSION TO AUSTIN ;2/1/95 12:34
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ; ENTRY POINT FOR AUTOMATIC TRANSMISSION
S5 ;#5 ACCT.INFO-EST.SHIP,FOB,TOTAL AMT.(PARTIAL),TOTAL FMS AMT.,DATE RCVD.,DISCOUNT INFO,PRODUCT TYPE,LIQUIDATION CODE, FMS VENDOR ID & ALT. ADDRESS INDICATOR
S Z(1)="" N FMSTOT,PRCTOT S FMSTOT=0,PRCTOT=0 ; Initialize FMS Total Amount
I PRCFPR=1 S X=$P(PRCF0,"^",13) D FAMT S Z(1)=X,FMSTOT=FMSTOT+X,PRCTOT=PRCTOT+X
S Z=$P($P(PRCF11,"^",13),"%")
N MULT S MULT=1 I Z D
. S X=$FN(Z,"",3),MULT=1-(X/100)
. S X=$P(X,".",1)_$P(X,".",2)
. S Z=X,Z=$S(($L(Z))<5:"0"_Z,1:Z)
. Q
; values for 4th and 5th piece added in routine PRCFARR3
S PRCFX="5^"_Z(1)_"^"_$P(PRCF1,"^",6)_"^^^"
S PRCFX=PRCFX_$E(PRCF11,4,7)_$E(PRCF11,2,3)_"^"_Z_"^"
S Z=$P($P(PRCF11,"^",13),"%",2)
S PRCFX=PRCFX_$S(Z:+Z,1:"")_$S($P(Z,+Z,2)'="":"^P",1:"^")_"^^"
N I F I=1,2 I "0"[$P(Z,"%",I) S $P(PRCFX,U,9)=""
S PRCFX=PRCFX_$S(PRCFPR=1&($P(PRCF11,"^",9)="F"):"C",1:"P")_"^"
PPT ;N PPT,I S PPT="",I=0
;N PPR F S I=$O(^PRC(442,PRCFA("PODA"),5,I)) Q:+I'=I S PPR=$G(^(I,0)) D
;. Q:PPR="" I $P(PPR,U,1)="NET",$P(PPR,U,5)]"" S PPT=$P(PPR,U,5)
;. I PPT="" S PPT=$P(PPR,U,5)
;. Q
S $P(PRCFX,U,10)=$P($G(^PRC(442,PRCFA("PODA"),12)),U,15)
VC N PRCFVP,PRCFV3 S PRCFVP=+PRCF1,PRCFV3=$G(^PRC(440,PRCFVP,3))
N VC S VC=$P(PRCFV3,U,4) S:VC="" VC=$S($P($G(^PRC(440,PRCFVP,2)),U,2)]"":"MISCG",1:"MISCN")
S $P(PRCFX,U,12)=VC
I VC'?1"MISC".E S $P(PRCFX,U,13)=$P(PRCFV3,U,5)
I VC?1"MISC".E S $P(PRCFX,U,14)=$E($P($G(^PRC(440,PRCFVP,0)),U,1),1,30)
S $P(PRCFX,U,15)=$$FAP($P($G(^PRC(442,PRCFA("PODA"),11,PRCFPR,1)),U,17))
S ^TMP("PRCFARR",$J,5,0)=PRCFX_U,$P(^(0),U,16)="",PRCFX=""
G EN^PRCFARR1
FAMT I 'X S X="" Q
S X=$P(X,".")_$E($P(X,".",2)_"00",1,2) Q
FAP(X) ;Return Fiscal Accounting Period When Passed FM Date
Q:X="" X
S X=$P("04^05^06^07^08^09^10^11^12^01^02^03",U,+$E(X,4,5))_(X\10000+$S($E(X,4,5)>9:1701,1:1700))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFARR0 2074 printed Dec 13, 2024@02:02:29 Page 2
PRCFARR0 ;ISC-SF/TKW-BUILD RECEIVING REPORT FOR ELECTRONIC TRANSMISSION TO AUSTIN ;2/1/95 12:34
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ; ENTRY POINT FOR AUTOMATIC TRANSMISSION
S5 ;#5 ACCT.INFO-EST.SHIP,FOB,TOTAL AMT.(PARTIAL),TOTAL FMS AMT.,DATE RCVD.,DISCOUNT INFO,PRODUCT TYPE,LIQUIDATION CODE, FMS VENDOR ID & ALT. ADDRESS INDICATOR
+1 ; Initialize FMS Total Amount
SET Z(1)=""
NEW FMSTOT,PRCTOT
SET FMSTOT=0
SET PRCTOT=0
+2 IF PRCFPR=1
SET X=$PIECE(PRCF0,"^",13)
DO FAMT
SET Z(1)=X
SET FMSTOT=FMSTOT+X
SET PRCTOT=PRCTOT+X
+3 SET Z=$PIECE($PIECE(PRCF11,"^",13),"%")
+4 NEW MULT
SET MULT=1
IF Z
Begin DoDot:1
+5 SET X=$FNUMBER(Z,"",3)
SET MULT=1-(X/100)
+6 SET X=$PIECE(X,".",1)_$PIECE(X,".",2)
+7 SET Z=X
SET Z=$SELECT(($LENGTH(Z))<5:"0"_Z,1:Z)
+8 QUIT
End DoDot:1
+9 ; values for 4th and 5th piece added in routine PRCFARR3
+10 SET PRCFX="5^"_Z(1)_"^"_$PIECE(PRCF1,"^",6)_"^^^"
+11 SET PRCFX=PRCFX_$EXTRACT(PRCF11,4,7)_$EXTRACT(PRCF11,2,3)_"^"_Z_"^"
+12 SET Z=$PIECE($PIECE(PRCF11,"^",13),"%",2)
+13 SET PRCFX=PRCFX_$SELECT(Z:+Z,1:"")_$SELECT($PIECE(Z,+Z,2)'="":"^P",1:"^")_"^^"
+14 NEW I
FOR I=1,2
IF "0"[$PIECE(Z,"%",I)
SET $PIECE(PRCFX,U,9)=""
+15 SET PRCFX=PRCFX_$SELECT(PRCFPR=1&($PIECE(PRCF11,"^",9)="F"):"C",1:"P")_"^"
PPT ;N PPT,I S PPT="",I=0
+1 ;N PPR F S I=$O(^PRC(442,PRCFA("PODA"),5,I)) Q:+I'=I S PPR=$G(^(I,0)) D
+2 ;. Q:PPR="" I $P(PPR,U,1)="NET",$P(PPR,U,5)]"" S PPT=$P(PPR,U,5)
+3 ;. I PPT="" S PPT=$P(PPR,U,5)
+4 ;. Q
+5 SET $PIECE(PRCFX,U,10)=$PIECE($GET(^PRC(442,PRCFA("PODA"),12)),U,15)
VC NEW PRCFVP,PRCFV3
SET PRCFVP=+PRCF1
SET PRCFV3=$GET(^PRC(440,PRCFVP,3))
+1 NEW VC
SET VC=$PIECE(PRCFV3,U,4)
if VC=""
SET VC=$SELECT($PIECE($GET(^PRC(440,PRCFVP,2)),U,2)]"":"MISCG",1:"MISCN")
+2 SET $PIECE(PRCFX,U,12)=VC
+3 IF VC'?1"MISC".E
SET $PIECE(PRCFX,U,13)=$PIECE(PRCFV3,U,5)
+4 IF VC?1"MISC".E
SET $PIECE(PRCFX,U,14)=$EXTRACT($PIECE($GET(^PRC(440,PRCFVP,0)),U,1),1,30)
+5 SET $PIECE(PRCFX,U,15)=$$FAP($PIECE($GET(^PRC(442,PRCFA("PODA"),11,PRCFPR,1)),U,17))
+6 SET ^TMP("PRCFARR",$JOB,5,0)=PRCFX_U
SET $PIECE(^(0),U,16)=""
SET PRCFX=""
+7 GOTO EN^PRCFARR1
FAMT IF 'X
SET X=""
QUIT
+1 SET X=$PIECE(X,".")_$EXTRACT($PIECE(X,".",2)_"00",1,2)
QUIT
FAP(X) ;Return Fiscal Accounting Period When Passed FM Date
+1 if X=""
QUIT X
+2 SET X=$PIECE("04^05^06^07^08^09^10^11^12^01^02^03",U,+$EXTRACT(X,4,5))_(X\10000+$SELECT($EXTRACT(X,4,5)>9:1701,1:1700))
+3 QUIT X
