90 lines
3.5 KiB
Mathematica
90 lines
3.5 KiB
Mathematica
PRCFD8H ;WISC/LEM-FMS PV2 thru PV5 SEGMENTS ;8/10/95 12:18
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
PV2(CI,ACTION) ;BUILD 'PV2' SEGMENT
|
|
N DA,DOCTYPE,SEG,VENDA,VENID S DOCTYPE="" K PRCTMP
|
|
S DIC=421.5,(DA,CI)=+CI,DIQ="PRCTMP(",DIQ(0)="IE"
|
|
S DR="3;6;8;11.5;13;61.9;71;72" D EN^DIQ1
|
|
S DIC=440,(DA,VENDA)=+PRCTMP(421.5,CI,6,"I")
|
|
S DR=".06;17.3;17.4;17.5;17.6;17.7;17.8;17.9;34;35" D EN^DIQ1
|
|
K DIC,DIQ,DR
|
|
S $P(SEG,U,1)="PV2" ; Segment ID
|
|
S X=PRCTMP(421.5,CI,71,"I") S:X="" X=DT
|
|
S $P(SEG,U,2)=$E(X,4,5) ; Transaction Month
|
|
S $P(SEG,U,3)=$E(X,6,7) ; Transaction Day
|
|
S $P(SEG,U,4)=$E(X,2,3) ; Transaction Year
|
|
S X=PRCTMP(421.5,CI,72,"I")
|
|
I X'="" D ; Accounting Period
|
|
. S $P(SEG,U,5)=$P("04^05^06^07^08^09^10^11^12^01^02^03",U,$E(X,4,5))
|
|
. S $P(SEG,U,6)=$E(100+$E(X,2,3)+$S($E(X,4,5)>9:1,1:0),2,3)
|
|
S $P(SEG,U,9)=ACTION ; Document Action
|
|
S $P(SEG,U,10)="01" ; Transaction Type
|
|
; Not required, per Dan Q. (AMS):
|
|
;S $P(SEG,U,11)=DOCTYPE ; Document Type
|
|
S VENID=PRCTMP(440,VENDA,34,"I")
|
|
I VENID="" S VENID="MISCN" I PRCTMP(440,VENDA,.06,"I") S VENID="MISCG"
|
|
S $P(SEG,U,20)=VENID ; FMS Vendor ID
|
|
S $P(SEG,U,21)=PRCTMP(440,VENDA,35,"I") ; Alt-Addr-Ind
|
|
S $P(SEG,U,22)=$FN(PRCTMP(421.5,CI,13,"I")/100,"",2) ; Document Total
|
|
I VENID="MISCN"!(VENID="MISCG") D
|
|
. S $P(SEG,U,23)=$E(PRCTMP(421.5,CI,6,"E"),1,30) ; Vendor Name
|
|
. S $P(SEG,U,24)=PRCTMP(440,VENDA,17.3,"I") ; Vendor Address Line 1
|
|
. S $P(SEG,U,25)=PRCTMP(440,VENDA,17.4,"I") ; Vendor Address Line 2
|
|
. S $P(SEG,U,26)=$E(PRCTMP(440,VENDA,17.7,"I"),1,19) ; Vendor City
|
|
. S $P(SEG,U,27)=$P($G(^DIC(5,+PRCTMP(440,VENDA,17.8,"I"),0)),U,2)
|
|
. S $P(SEG,U,28)=$TR(PRCTMP(440,VENDA,17.9,"I"),"-") ; Vendor Zip Code
|
|
. Q
|
|
S SEG=SEG_"^~" ; Segment Delimiter
|
|
S ^TMP($J,"PRCPV",1)=SEG
|
|
Q
|
|
PV3 ;BUILD 'PV3' SEGMENT
|
|
N SEG,DA,PPT,PM,TC,TOT,CONT
|
|
S DIC=421.5,DR="1;4;5;9;10;11.3",DA=+CI
|
|
S DIQ="PRCTMP(",DIQ(0)="IE" D EN^DIQ1 K DR
|
|
S DR=31,DR(421.531)="1;2;3;4"
|
|
F DA(421.531)=1,2,3 D EN^DIQ1
|
|
K DR,DA(421.531)
|
|
S PATDA=+PRCTMP(421.5,+CI,5,"I") I PATDA S DIC=442,DR=".02",DA=PATDA D EN^DIQ1
|
|
K DIC,DIQ,DR S DA=+CI
|
|
S $P(SEG,U,1)="PV3" ; Segment ID
|
|
S $P(SEG,U,9)=PRCF("TC") ; Transaction Code
|
|
; Not required, per Dan Q. (AMS):
|
|
;S $P(SEG,U,10)=PRCFTN ; Transaction Number
|
|
S $P(SEG,U,14)=PRCTMP(421.5,+CI,1,"E") ; Invoice/Bill Number
|
|
S $P(SEG,U,22)=PRCTMP(421.5,+CI,4,"I") ; Prompt Pay Type
|
|
S:$P(SEG,U,22)="A" $P(SEG,U,22)=" "
|
|
F I=1,2,3 I $D(PRCTMP(421.531,I)) D
|
|
. ; Discount Percent:
|
|
. N PCT,L S PCT=$TR($FN(PRCTMP(421.531,I,2,"I"),"",3),"."),L=$L(PCT)
|
|
. I PCT?1"0"."0"!(PCT="NET") S (L,PCT)=""
|
|
. S:L $P(SEG,U,I-1*3+23)=$E(PCT,1,L-3)_"."_$E(PCT,L-2,L)
|
|
. S:PRCTMP(421.531,I,3,"I")]"" $P(SEG,U,I-1*3+24)=$FN(PRCTMP(421.531,I,3,"I"),"",2) ; Discount Amount
|
|
. S:PCT!(+PRCTMP(421.531,I,3,"I")>0) $P(SEG,U,I-1*3+25)=+PRCTMP(421.531,I,4,"E") ; Discount Days
|
|
. Q
|
|
S ^TMP($J,"PRCPV",2)=SEG_"^~"
|
|
Q
|
|
;
|
|
PV4 ;BUILD 'PV4' SEGMENT
|
|
N SEG S SEG=""
|
|
S $P(SEG,U,1)="PV4" ; Segment Identifier
|
|
F I=1,2,3 I $G(PRCTMP(421.531,I,1,"I"))="P"!($G(PRCTMP(421.531,I,1,"I"))="X") D
|
|
. S $P(SEG,U,I+3)=PRCTMP(421.531,I,4,"E") ; Prox/EOM Days
|
|
. Q
|
|
;S $P(SEG,U,14)="~" ; Segment Delimiter
|
|
S SEG=SEG_"^~" ; Segment Delimiter
|
|
I SEG'="PV4^~" S ^TMP($J,"PRCPV",3)=SEG
|
|
Q
|
|
PV5 ;BUILD 'PV5' SEGMENT
|
|
N SEG S SEG=""
|
|
S $P(SEG,U,1)="PV5" ; Segment Identifier
|
|
;S $P(SEG,U,4)="~" ; Segment Delimiter
|
|
S $P(SEG,U,2)="~" ; Segment Delimiter
|
|
I SEG'="PV5^~" S ^TMP($J,"PRCPV",4)=SEG
|
|
Q
|
|
FAMT I 'X S X="" Q
|
|
I X?.N1"."2N Q
|
|
N L,Y,Z S L=$L(X),Y=$E(X,L-1,L)_"00",Z=$E(X,1,L-2),X=Z_"."_$E(Y,1,2)
|
|
;S X=$P(X,".")_$E($P(X,".",2)_"00",1,2) Q
|
|
Q
|