source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFDA1.m@ 1141

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1PRCFDA1 ;WISC@ALTOONA/CTB-PROCESS PAYMENT TO FMS ;6/8/94 2:17 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 I $D(PRC("SITE")),PRC("SITE")]"",$D(^PRC(411,PRC("SITE"),0)) S PRC("PARAM")=^(0)
5 F I=0,1,2 S P(I)=$G(^PRCF(421.5,PRCF("CIDA"),I))
6 S PRCFX(1,"~")="FMS PAYMENT VOUCHER",PRCFX(1.5,"Invoice ID#: ~?48")=$P(P(0),"^")
7 S X=$P(P(0),"^",27),DD=421.5,F=.6 D ^PRCFU1 S PRCFX(2,"Certification Required? ~!!")=$S(%:Y,1:"")
8 ;S PRCFX(3,"Document Locator Number: ~?38")=$P(P(0),"^",2)
9 S PRCFX(4,"Invoice Number: ")=$P(P(0),"^",3)
10 S Y=$P(P(0),"^",4) D D^PRCFQ S PRCFX(5,"Date of Invoice: ~?38")=Y
11 S Y=$P(P(0),"^",5) D D^PRCFQ S PRCFX(5.5,"Date Invoice Received: ")=Y
12 S Y=$P(P(0),"^",21) D D^PRCFQ S PRCFX(5.7,"Date Goods/Services Received: ~?48")=Y
13 S X=$P(P(0),"^",6),DD=421.5,F=4 D ^PRCFU1 S PRCFX(5.8,"Invoice Type: ~!")=$S(%:Y,1:"")
14 S XX=$P(P(0),"^",8),PRCFX(6,"Vendor: ~!!")=$S(+XX=0:"",'$D(^PRC(440,XX,0))#2:"",1:$P(^(0),"^")) K XX
15 S PRCFX(7,"FMS Vendor ID#: ~!")=$P(P(0),"^",10)
16 ;S PRCFX(8,"Vendor Stub Name: ")=$P(P(0),"^",9)
17 S PRCFX(9,"Total Payment: $ ~!!")=$J($P(P(0),"^",15)/100,0,2)
18 S PRCFX(10,"Shipping: $ ")=$J($P(P(0),"^",14)/100,0,2)
19 S PRCFX(11,"Discount %: ~!")=$S(+$P(P(0),"^",11)=0:"NET "_$P(P(1),"^",10),1:+$P(P(0),"^",11)_"% "_$P(P(0),"^",12)_" Days, NET "_$P(P(1),"^",10))
20 S:$P(P(0),"^",26)]"" PRCFX(11.5,"Discount Amount: ")=$J($P(P(0),"^",26),0,2)
21 ;S X=$P(P(0),"^",23),DD=421.5,F=20 D ^PRCFU1 S PRCFX(19,"Interest Indicator: ~!!")=$S(%:Y,1:"")
22 ;S X=$P(P(0),"^",22),DD=421.5,F=19 D ^PRCFU1 S PRCFX(20,"Money Management Status: ")=$S(%:Y,1:"")
23 S X=$P(P(0),"^",16),DD=421.5,F=14 D ^PRCFU1 S PRCFX(14,"Liquidation Code: ~!")=$S(%:Y,1:"")
24 S PRCFX(15,"BOC #1: ~!")=$P(P(0),"^",17) S PRCFX(16,"Liquidation Amt #1: $ ~?38")=$J($P(P(0),"^",19)/100,0,2)
25 S PRCFX(17,"BOC #2: ~!")=$P(P(0),"^",18) S PRCFX(18,"Liquidation Amt #2: $ ~?38")=$J($P(P(0),"^",20)/100,0,2)
26 D ^PRCFSCR S %A="Are you ready to release this invoice to FMS",%B="",%=1 D ^PRCFYN
27 I %'=1 S X=" <Action Terminated>*" D MSG^PRCFQ G OUT
28 S PRCFA("TTF")="900.00",PRCFASYS="CAP" D TT^PRCFAC
29 I %'=1 S X="Unable to select CAPPS transaction type 900.00. Please try again." D MSG^PRCFQ G OUT
30 I ^PRCF(421.5,PRCF("CIDA"),2),$P($P(^(2),"^",3),"-",2)]"" S PRCFA("REF")=$P($P(^(2),"^",3),"-",2)
31 D NEWCS^PRCFAC I '$D(DA) S X="No new FMS document created - Files inaccessible at this time.*" D MSG^PRCFQ G OUT
32 S X="Transferring invoice data to CAPPS transmittal document.*" D MSG^PRCFQ
33 K F,T F I=0,1,2 S F(I)=$S($D(^PRCF(421.5,PRCF("CIDA"),I)):^(I),1:"")
34 F I=0,1,6,100 S T(I)=$S($D(^PRCF(423,PRCFA("CSDA"),I)):^(I),1:"")
35 S $P(T(100),"^",1,6)="C^"_$P(F(0),"^",2,6)
36 S $P(T(100),"^",11,16)=$P(F(0),"^",11,16)
37 S $P(T(100),"^",17,23)=$P(F(0),"^",17,23)
38 F I=16,17,18 S $P(T(100),"^",I+12)=$P(F(1),"^",I)
39 S $P(T(1),"^",18)=$P(F(0),"^",9),$P(T(6),"^",7)=$P(F(0),"^",10),$P(T(100),"^",27)=$P(F(0),"^",26)
40 S $P(T(1),"^",8)=$P(F(0),"^",17),$P(T(1),"^",10)=$P(F(0),"^",18)
41 S $P(T(100),"^",26)=$P(F(2),"^",2),$P(T(1),"^",16)="~"
42 F I=0,1,6,100 S ^PRCF(423,PRCFA("CSDA"),I)=T(I)
43 K F,T S PRCF("OUT")=""
44 S PRCFA("PAYMENT")="" D ^PRCFACXM K PRCFA("PAYMENT")
45 I $D(PRCFDEL)!$D(PRCFA("CSHOLD")) S X="Transmittal document was "_$S($D(PRCFDEL):"DELETED",1:"NOT TRANSMITTED")_". All further action on this invoice is suspended.*"
46 I D MSG^PRCFQ K PRCFDEL,PRCFA("CSHOLD") S X=$P(^PRCF(421.5,PRCF("CIDA"),2),"^") I 1
47 E D
48 .S DA=PRCF("CIDA"),MESSAGE=""
49 .D REMOVE^PRCFDES2(DA),ENCODE^PRCFDES2(DA,DUZ,.MESSAGE)
50 .K MESSAGE S X=20
51 .Q
52 K PRCF("OUT") D STATUS^PRCFDE1
53X D OUT^PRCFDE K PRCFASYS G ^PRCFDA
54OUT D OUT^PRCFDE K PRCFASYS Q
Note: See TracBrowser for help on using the repository browser.