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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFD8H 3714 printed Dec 13, 2024@02:02:42 Page 2
PRCFD8H ;WISC/LEM-FMS PV2 thru PV5 SEGMENTS ;8/10/95 12:18
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
PV2(CI,ACTION) ;BUILD 'PV2' SEGMENT
+1 NEW DA,DOCTYPE,SEG,VENDA,VENID
SET DOCTYPE=""
KILL PRCTMP
+2 SET DIC=421.5
SET (DA,CI)=+CI
SET DIQ="PRCTMP("
SET DIQ(0)="IE"
+3 SET DR="3;6;8;11.5;13;61.9;71;72"
DO EN^DIQ1
+4 SET DIC=440
SET (DA,VENDA)=+PRCTMP(421.5,CI,6,"I")
+5 SET DR=".06;17.3;17.4;17.5;17.6;17.7;17.8;17.9;34;35"
DO EN^DIQ1
+6 KILL DIC,DIQ,DR
+7 ; Segment ID
SET $PIECE(SEG,U,1)="PV2"
+8 SET X=PRCTMP(421.5,CI,71,"I")
if X=""
SET X=DT
+9 ; Transaction Month
SET $PIECE(SEG,U,2)=$EXTRACT(X,4,5)
+10 ; Transaction Day
SET $PIECE(SEG,U,3)=$EXTRACT(X,6,7)
+11 ; Transaction Year
SET $PIECE(SEG,U,4)=$EXTRACT(X,2,3)
+12 SET X=PRCTMP(421.5,CI,72,"I")
+13 ; Accounting Period
IF X'=""
Begin DoDot:1
+14 SET $PIECE(SEG,U,5)=$PIECE("04^05^06^07^08^09^10^11^12^01^02^03",U,$EXTRACT(X,4,5))
+15 SET $PIECE(SEG,U,6)=$EXTRACT(100+$EXTRACT(X,2,3)+$SELECT($EXTRACT(X,4,5)>9:1,1:0),2,3)
End DoDot:1
+16 ; Document Action
SET $PIECE(SEG,U,9)=ACTION
+17 ; Transaction Type
SET $PIECE(SEG,U,10)="01"
+18 ; Not required, per Dan Q. (AMS):
+19 ;S $P(SEG,U,11)=DOCTYPE ; Document Type
+20 SET VENID=PRCTMP(440,VENDA,34,"I")
+21 IF VENID=""
SET VENID="MISCN"
IF PRCTMP(440,VENDA,.06,"I")
SET VENID="MISCG"
+22 ; FMS Vendor ID
SET $PIECE(SEG,U,20)=VENID
+23 ; Alt-Addr-Ind
SET $PIECE(SEG,U,21)=PRCTMP(440,VENDA,35,"I")
+24 ; Document Total
SET $PIECE(SEG,U,22)=$FNUMBER(PRCTMP(421.5,CI,13,"I")/100,"",2)
+25 IF VENID="MISCN"!(VENID="MISCG")
Begin DoDot:1
+26 ; Vendor Name
SET $PIECE(SEG,U,23)=$EXTRACT(PRCTMP(421.5,CI,6,"E"),1,30)
+27 ; Vendor Address Line 1
SET $PIECE(SEG,U,24)=PRCTMP(440,VENDA,17.3,"I")
+28 ; Vendor Address Line 2
SET $PIECE(SEG,U,25)=PRCTMP(440,VENDA,17.4,"I")
+29 ; Vendor City
SET $PIECE(SEG,U,26)=$EXTRACT(PRCTMP(440,VENDA,17.7,"I"),1,19)
+30 SET $PIECE(SEG,U,27)=$PIECE($GET(^DIC(5,+PRCTMP(440,VENDA,17.8,"I"),0)),U,2)
+31 ; Vendor Zip Code
SET $PIECE(SEG,U,28)=$TRANSLATE(PRCTMP(440,VENDA,17.9,"I"),"-")
+32 QUIT
End DoDot:1
+33 ; Segment Delimiter
SET SEG=SEG_"^~"
+34 SET ^TMP($JOB,"PRCPV",1)=SEG
+35 QUIT
PV3 ;BUILD 'PV3' SEGMENT
+1 NEW SEG,DA,PPT,PM,TC,TOT,CONT
+2 SET DIC=421.5
SET DR="1;4;5;9;10;11.3"
SET DA=+CI
+3 SET DIQ="PRCTMP("
SET DIQ(0)="IE"
DO EN^DIQ1
KILL DR
+4 SET DR=31
SET DR(421.531)="1;2;3;4"
+5 FOR DA(421.531)=1,2,3
DO EN^DIQ1
+6 KILL DR,DA(421.531)
+7 SET PATDA=+PRCTMP(421.5,+CI,5,"I")
IF PATDA
SET DIC=442
SET DR=".02"
SET DA=PATDA
DO EN^DIQ1
+8 KILL DIC,DIQ,DR
SET DA=+CI
+9 ; Segment ID
SET $PIECE(SEG,U,1)="PV3"
+10 ; Transaction Code
SET $PIECE(SEG,U,9)=PRCF("TC")
+11 ; Not required, per Dan Q. (AMS):
+12 ;S $P(SEG,U,10)=PRCFTN ; Transaction Number
+13 ; Invoice/Bill Number
SET $PIECE(SEG,U,14)=PRCTMP(421.5,+CI,1,"E")
+14 ; Prompt Pay Type
SET $PIECE(SEG,U,22)=PRCTMP(421.5,+CI,4,"I")
+15 if $PIECE(SEG,U,22)="A"
SET $PIECE(SEG,U,22)=" "
+16 FOR I=1,2,3
IF $DATA(PRCTMP(421.531,I))
Begin DoDot:1
+17 ; Discount Percent:
+18 NEW PCT,L
SET PCT=$TRANSLATE($FNUMBER(PRCTMP(421.531,I,2,"I"),"",3),".")
SET L=$LENGTH(PCT)
+19 IF PCT?1"0"."0"!(PCT="NET")
SET (L,PCT)=""
+20 if L
SET $PIECE(SEG,U,I-1*3+23)=$EXTRACT(PCT,1,L-3)_"."_$EXTRACT(PCT,L-2,L)
+21 ; Discount Amount
if PRCTMP(421.531,I,3,"I")]""
SET $PIECE(SEG,U,I-1*3+24)=$FNUMBER(PRCTMP(421.531,I,3,"I"),"",2)
+22 ; Discount Days
if PCT!(+PRCTMP(421.531,I,3,"I")>0)
SET $PIECE(SEG,U,I-1*3+25)=+PRCTMP(421.531,I,4,"E")
+23 QUIT
End DoDot:1
+24 SET ^TMP($JOB,"PRCPV",2)=SEG_"^~"
+25 QUIT
+26 ;
PV4 ;BUILD 'PV4' SEGMENT
+1 NEW SEG
SET SEG=""
+2 ; Segment Identifier
SET $PIECE(SEG,U,1)="PV4"
+3 FOR I=1,2,3
IF $GET(PRCTMP(421.531,I,1,"I"))="P"!($GET(PRCTMP(421.531,I,1,"I"))="X")
Begin DoDot:1
+4 ; Prox/EOM Days
SET $PIECE(SEG,U,I+3)=PRCTMP(421.531,I,4,"E")
+5 QUIT
End DoDot:1
+6 ;S $P(SEG,U,14)="~" ; Segment Delimiter
+7 ; Segment Delimiter
SET SEG=SEG_"^~"
+8 IF SEG'="PV4^~"
SET ^TMP($JOB,"PRCPV",3)=SEG
+9 QUIT
PV5 ;BUILD 'PV5' SEGMENT
+1 NEW SEG
SET SEG=""
+2 ; Segment Identifier
SET $PIECE(SEG,U,1)="PV5"
+3 ;S $P(SEG,U,4)="~" ; Segment Delimiter
+4 ; Segment Delimiter
SET $PIECE(SEG,U,2)="~"
+5 IF SEG'="PV5^~"
SET ^TMP($JOB,"PRCPV",4)=SEG
+6 QUIT
FAMT IF 'X
SET X=""
QUIT
+1 IF X?.N1"."2N
QUIT
+2 NEW L,Y,Z
SET L=$LENGTH(X)
SET Y=$EXTRACT(X,L-1,L)_"00"
SET Z=$EXTRACT(X,1,L-2)
SET X=Z_"."_$EXTRACT(Y,1,2)
+3 ;S X=$P(X,".")_$E($P(X,".",2)_"00",1,2) Q
+4 QUIT
