- 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 Jan 18, 2025@03:03:54 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