source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFDIC.m@ 701

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1PRCFDIC ;WISC/LEM-LOOK UP INVOICES BY P.O. OR VENDOR ;8/18/94 14:20
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4PO ; LOOK UP INVOICES BY P.O.
5 K DA,DR,X,Y
6 ;S PRCF("PO")=$G(X) Q:X=""
7PO1 S X=$G(PRCF("PO")) Q:X=""
8 N MULT,VIEW S MULT=0,I="" I $D(^PRCF(421.5,"D",X)) D
9 . F S I=$O(^PRCF(421.5,"D",X,I)) Q:I="" S MULT=MULT+1 Q:MULT>1
10 . Q
11 N DIC,D S DIC="^PRCF(421.5,",DIC(0)="EZ",D="D"
12 S X=$P(X,"-",1,2)
13 D IX^DIC Q:Y<0 S VIEW=+Y
14 I VIEW=$G(PRCF("CIDA")) S X=" ("_+Y_" - THIS Invoice.)*" D MSG^PRCFQ
15 I VIEW D VIEW G PO1:MULT>1
16 Q
17VENDOR ; LOOK UP INVOICES BY VENDOR
18 S X=$G(PRCF("VENDA")) Q:X=""
19 N MULT,VIEW S MULT=0,I="" I $D(^PRCF(421.5,"C",X)) D
20 . F S I=$O(^PRCF(421.5,"C",X,I)) Q:I="" S MULT=MULT+1 Q:MULT>1
21 . Q
22 N DIC S DIC="^PRCF(421.5,",DIC(0)="EZ",D="C"
23 D IX^DIC Q:Y<0 S VIEW=+Y
24 I VIEW=$G(PRCF("CIDA")) S X=" ("_+Y_" - THIS Invoice.)*" D MSG^PRCFQ
25 I VIEW D VIEW G VENDOR:MULT>1
26 Q
27VIEW ;VIEW INDIVIDUAL CERTIFIED INVOICE
28 S (FR,TO)=$P(Y,"^",2),L=0,BY="@.01;",FLDS="[CAPTIONED]",IOP="HOME"
29 D WAIT^PRCFYN,EN1^DIP
30OUTV K DIC,DA,DR,X,Y
31 Q
32DUP ; Look for Duplicate Invoice(s)
33 K PRCF("DUP") S PRCF("DUP")=0 Q:'$G(PRCF("CIDA"))
34 Q:'$G(PRCF("VENDA")) Q:'$D(^PRCF(421.5,"C",PRCF("VENDA")))
35 S PRCF("INVNO")=$P($G(^PRCF(421.5,PRCF("CIDA"),0)),U,3)
36 Q:PRCF("INVNO")=""
37 N X S X="Checking for duplicate invoices . . .*" D MSG^PRCFQ
38 N I S I="" F S I=$O(^PRCF(421.5,"C",PRCF("VENDA"),I)) Q:I="" D
39 . Q:I=PRCF("CIDA")
40 . I PRCF("INVNO")=$P($G(^PRCF(421.5,I,0)),U,3) D
41 . . S PRCF("DUP")=PRCF("DUP")+1
42 . . N CIDNO S CIDNO=$P($G(^PRCF(421.5,I,0)),U,1)
43 . . S PRCF("DUP",CIDNO)=""
44 . . Q
45 . Q
46 I PRCF("DUP")=0 N X S X="none found.*" D MSG^PRCFQ Q
47 S X="WARNING! Identical invoices numbers for this vendor were found in the following Tracking ID#s:*"
48 D MSG^PRCFQ S I="" F S I=$O(PRCF("DUP",I)) Q:I="" W !?10,I
49 W !! S X="Please review these records and check for duplicate invoices.*"
50 D MSG^PRCFQ
51 Q
52PPT ; Load Prompt Payment Terms from File 442
53 Q:'$G(PRCF("CIDA")) Q:'$G(PRCF("PODA"))
54 Q:$D(^PRCF(421.5,PRCF("CIDA"),6)) Q:'$D(^PRC(442,PRCF("PODA"),5,1,0))
55 N PPT S PPT=$G(^PRC(442,PRCF("PODA"),5,1,0))
56 N PCT,DAYS S PCT=$P(PPT,U,1),DAYS=$P(PPT,U,2)
57 S ^PRCF(421.5,PRCF("CIDA"),6,0)="^421.531A^1^1"
58 S ^PRCF(421.5,PRCF("CIDA"),6,1,0)="1^^"_PCT_"^^"_DAYS
59 S ^PRCF(421.5,PRCF("CIDA"),6,"B",1,1)=""
60 Q
61INPUT N X0 S X0=$TR(X,"net","NET")
62 I X]"",$E("NET",1,$L(X0))=X0 S X=0 Q
63 ; Native FileMan Input Transform follows:
64 K:+X'=X!(X>99.999)!(X<0)!(X?.E1"."4N.N) X
65 Q
66OUTPUT I Y?1"0"."."."0" S Y="NET"
67 Q
68 N DA S DA(1)=$G(PRCF("CIDA")) Q:DA(1)=""
69 N NODE S NODE=$G(^PRCF(421.5,DA(1),5,0))
70 I NODE="" S ^PRCF(421.5,DA(1),5,0)=U_$P(^DD(421.5,41,0),U,2)
71 N CTR,I S (CTR,I)=0 F S I=$O(PRCFD(I)) Q:I'>0 D
72 . S CTR=$S(I=991:CTR,1:CTR+1),CTR=$S(CTR=991:992,1:CTR)
73 . N DIC S DIC="^PRCF(421.5,"_DA(1)_",5,",DIC(0)="L"
74 . S X=$P(PRCFD(I),U,1),AMT=+$P(PRCFD(I),U,2)
75 . K DD,DO D FILE^DICN I Y'>0 W "ERROR" Q
76 . N DIE S DIE=DIC,DA=+Y,FMSL=$S(I=991:991,1:CTR)
77 . N DR S DR="1////^S X=AMT;2////^S X=FMSL" D ^DIE
78 . Q
79 Q
80DISC ; COMPUTE FMS LINE LIQ AMT FROM TOTAL AMT & DISCOUNT TERMS
81 ; INPUT: PRCF("CIDA") - IEN FOR PAYMENT/INVOICE TRACKING RECORD
82 ; PRCFA("LAMT") - FMS LINE AMOUNT FOR THIS INVOICE
83 ; OUTPUT: PRCFA("LIQ") - FMS COMPUTED LIQUIDATION AMOUNT
84 Q:'$D(PRCF("CIDA"))!'$D(PRCFA("LAMT"))
85 N I,DISC,HIGHDISC S (HIGHDISC,I)=0
86 F S I=$O(^PRCF(421.5,PRCF("CIDA"),6,I)) Q:+I'=I D
87 . S DISC=+$P($G(^PRCF(421.5,PRCF("CIDA"),6,I,0)),U,3)
88 . I DISC>HIGHDISC S HIGHDISC=DISC
89 . Q
90 S PRCFA("LIQ")=$FN(1-(HIGHDISC/100)*PRCFA("LAMT"),"",2)
91 Q
92SUM ;
93 ; INPUT: PRCF("CIDA") - IEN FOR PAYMENT/INVOICE TRACKING RECORD
94 ; PRCFA("CAMT") - TOTAL INVOICE AMOUNT CERTIFIED FOR PAYMENT
95 ; OUTPUT: OK - 1 IF SUM OF LINE AMOUNTS = TOTAL AMOUNT CERTIFIED
96 ; - 0 IF AMOUNTS NOT EQUAL
97 Q:'$D(PRCF("CIDA"))!'$D(PRCF("CAMT"))
98 N I,LAMT S (I,OK,PRCF("TAMT"))=0
99 F S I=$O(^PRCF(421.5,PRCF("CIDA"),5,I)) Q:+I'=I D
100 . S LAMT=+$P($G(^PRCF(421.5,PRCF("CIDA"),5,I,0)),U,2)
101 . S PRCF("TAMT")=PRCF("TAMT")+LAMT
102 . Q
103 I PRCF("CAMT")/100=PRCF("TAMT") S OK=1
104 Q
105SCREEN ; CHECK BOC
106 I $G(X) I $D(PRCFX("SA",X))
107 Q
108LOOKUP(X,PARTIAL) ; X = STA-PAT # - LOOKUP returns next available PARTIAL #.
109 N DIC S DIC="^PRCF(421.9,",DIC(0)="O" K DD,DO D ^DIC
110 I Y<0 D FILE^DICN
111 I +Y,$P(Y,U,3)=1 S PARTIAL="01",$P(^PRCF(421.9,+Y,0),U,2)="01" Q
112 S P=$P($G(^PRCF(421.9,+Y,0)),U,2),P=P+1
113 S P="00"_P,P=$E(P,$L(P)-1,$L(P))
114 S PARTIAL=P,$P(^PRCF(421.9,+Y,0),U,2)=P
115 Q
Note: See TracBrowser for help on using the repository browser.