source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFD8H.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1PRCFD8H ;WISC/LEM-FMS PV2 thru PV5 SEGMENTS ;8/10/95 12:18
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5PV2(CI,ACTION) ;BUILD 'PV2' SEGMENT
6 N DA,DOCTYPE,SEG,VENDA,VENID S DOCTYPE="" K PRCTMP
7 S DIC=421.5,(DA,CI)=+CI,DIQ="PRCTMP(",DIQ(0)="IE"
8 S DR="3;6;8;11.5;13;61.9;71;72" D EN^DIQ1
9 S DIC=440,(DA,VENDA)=+PRCTMP(421.5,CI,6,"I")
10 S DR=".06;17.3;17.4;17.5;17.6;17.7;17.8;17.9;34;35" D EN^DIQ1
11 K DIC,DIQ,DR
12 S $P(SEG,U,1)="PV2" ; Segment ID
13 S X=PRCTMP(421.5,CI,71,"I") S:X="" X=DT
14 S $P(SEG,U,2)=$E(X,4,5) ; Transaction Month
15 S $P(SEG,U,3)=$E(X,6,7) ; Transaction Day
16 S $P(SEG,U,4)=$E(X,2,3) ; Transaction Year
17 S X=PRCTMP(421.5,CI,72,"I")
18 I X'="" D ; Accounting Period
19 . S $P(SEG,U,5)=$P("04^05^06^07^08^09^10^11^12^01^02^03",U,$E(X,4,5))
20 . S $P(SEG,U,6)=$E(100+$E(X,2,3)+$S($E(X,4,5)>9:1,1:0),2,3)
21 S $P(SEG,U,9)=ACTION ; Document Action
22 S $P(SEG,U,10)="01" ; Transaction Type
23 ; Not required, per Dan Q. (AMS):
24 ;S $P(SEG,U,11)=DOCTYPE ; Document Type
25 S VENID=PRCTMP(440,VENDA,34,"I")
26 I VENID="" S VENID="MISCN" I PRCTMP(440,VENDA,.06,"I") S VENID="MISCG"
27 S $P(SEG,U,20)=VENID ; FMS Vendor ID
28 S $P(SEG,U,21)=PRCTMP(440,VENDA,35,"I") ; Alt-Addr-Ind
29 S $P(SEG,U,22)=$FN(PRCTMP(421.5,CI,13,"I")/100,"",2) ; Document Total
30 I VENID="MISCN"!(VENID="MISCG") D
31 . S $P(SEG,U,23)=$E(PRCTMP(421.5,CI,6,"E"),1,30) ; Vendor Name
32 . S $P(SEG,U,24)=PRCTMP(440,VENDA,17.3,"I") ; Vendor Address Line 1
33 . S $P(SEG,U,25)=PRCTMP(440,VENDA,17.4,"I") ; Vendor Address Line 2
34 . S $P(SEG,U,26)=$E(PRCTMP(440,VENDA,17.7,"I"),1,19) ; Vendor City
35 . S $P(SEG,U,27)=$P($G(^DIC(5,+PRCTMP(440,VENDA,17.8,"I"),0)),U,2)
36 . S $P(SEG,U,28)=$TR(PRCTMP(440,VENDA,17.9,"I"),"-") ; Vendor Zip Code
37 . Q
38 S SEG=SEG_"^~" ; Segment Delimiter
39 S ^TMP($J,"PRCPV",1)=SEG
40 Q
41PV3 ;BUILD 'PV3' SEGMENT
42 N SEG,DA,PPT,PM,TC,TOT,CONT
43 S DIC=421.5,DR="1;4;5;9;10;11.3",DA=+CI
44 S DIQ="PRCTMP(",DIQ(0)="IE" D EN^DIQ1 K DR
45 S DR=31,DR(421.531)="1;2;3;4"
46 F DA(421.531)=1,2,3 D EN^DIQ1
47 K DR,DA(421.531)
48 S PATDA=+PRCTMP(421.5,+CI,5,"I") I PATDA S DIC=442,DR=".02",DA=PATDA D EN^DIQ1
49 K DIC,DIQ,DR S DA=+CI
50 S $P(SEG,U,1)="PV3" ; Segment ID
51 S $P(SEG,U,9)=PRCF("TC") ; Transaction Code
52 ; Not required, per Dan Q. (AMS):
53 ;S $P(SEG,U,10)=PRCFTN ; Transaction Number
54 S $P(SEG,U,14)=PRCTMP(421.5,+CI,1,"E") ; Invoice/Bill Number
55 S $P(SEG,U,22)=PRCTMP(421.5,+CI,4,"I") ; Prompt Pay Type
56 S:$P(SEG,U,22)="A" $P(SEG,U,22)=" "
57 F I=1,2,3 I $D(PRCTMP(421.531,I)) D
58 . ; Discount Percent:
59 . N PCT,L S PCT=$TR($FN(PRCTMP(421.531,I,2,"I"),"",3),"."),L=$L(PCT)
60 . I PCT?1"0"."0"!(PCT="NET") S (L,PCT)=""
61 . S:L $P(SEG,U,I-1*3+23)=$E(PCT,1,L-3)_"."_$E(PCT,L-2,L)
62 . S:PRCTMP(421.531,I,3,"I")]"" $P(SEG,U,I-1*3+24)=$FN(PRCTMP(421.531,I,3,"I"),"",2) ; Discount Amount
63 . S:PCT!(+PRCTMP(421.531,I,3,"I")>0) $P(SEG,U,I-1*3+25)=+PRCTMP(421.531,I,4,"E") ; Discount Days
64 . Q
65 S ^TMP($J,"PRCPV",2)=SEG_"^~"
66 Q
67 ;
68PV4 ;BUILD 'PV4' SEGMENT
69 N SEG S SEG=""
70 S $P(SEG,U,1)="PV4" ; Segment Identifier
71 F I=1,2,3 I $G(PRCTMP(421.531,I,1,"I"))="P"!($G(PRCTMP(421.531,I,1,"I"))="X") D
72 . S $P(SEG,U,I+3)=PRCTMP(421.531,I,4,"E") ; Prox/EOM Days
73 . Q
74 ;S $P(SEG,U,14)="~" ; Segment Delimiter
75 S SEG=SEG_"^~" ; Segment Delimiter
76 I SEG'="PV4^~" S ^TMP($J,"PRCPV",3)=SEG
77 Q
78PV5 ;BUILD 'PV5' SEGMENT
79 N SEG S SEG=""
80 S $P(SEG,U,1)="PV5" ; Segment Identifier
81 ;S $P(SEG,U,4)="~" ; Segment Delimiter
82 S $P(SEG,U,2)="~" ; Segment Delimiter
83 I SEG'="PV5^~" S ^TMP($J,"PRCPV",4)=SEG
84 Q
85FAMT I 'X S X="" Q
86 I X?.N1"."2N Q
87 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)
88 ;S X=$P(X,".")_$E($P(X,".",2)_"00",1,2) Q
89 Q
Note: See TracBrowser for help on using the repository browser.