source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH1D.m@ 1078

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1PRCH1D ;WISC/PLT-REMOVE PURCHASE CARD RECONCILIATION ;7/19/96 09:02
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6EN ;remove reconcile purchase card order
7 N PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCC,PRCE,PRCF,PRCG,PRCVAL,PRCCP,PRCR,PRCSST,PRCSTC,PRCEDRM
8 N PRCSELF,PRCCN,PRCCNT
9 N A,B,C
10Q1 ;station
11 S PRCSST=1 D STA^PRCSUT S PRCSTC=SI G:$G(PRC("SITE"))=""!(Y<0)!(PRCSTC<1) EXIT
12 S PRCRI(420)=+PRC("SITE")
13 S PRCSELF=1 I $D(^PRC(440.5,"MAA",DUZ)) D G EXIT:X=""!(X["^") S PRCSELF=Y
14 . D YN^PRC0A(.X,.Y,"Edit/Remove Reconciliation for your own purchase card orders","O","")
15 . QUIT
16 S PRCCN="" I PRCSELF=1 S PRCDUZ=DUZ G Q3
17Q21 S X("S")="I $P(^(2),U,3)=PRC(""SITE""),$P(^(0),U,9)=DUZ!($P(^(0),U,10)=DUZ)"
18 S X("W")="W "" "",$P(^(0),U,11),"" "" W:$P(^(0),U,8) $P($G(^VA(200,$P(^(0),U,8),0)),U)"
19 D LOOKUP^PRC0B(.X,.Y,"440.5;^PRC(440.5,;","AEMOQS~~G^MAA^H^D","Select Purchase Credit Card/Holder: ")
20 I X["^"!(X="")!(Y<1) G Q1
21 S PRCRI(440.5)=+Y,PRCDUZ=$P(^PRC(440.5,PRCRI(440.5),0),U,8),PRCCN=$P(^(0),U)
22Q3 ;select oracle cc-record
23 K DIRUT,PCSTAT
24 S X("S")="I ""RD""[$P(^(0),U,16),$P(^(0),U,8)=PRC(""SITE""),$P(^(0),U,4)=PRCCN&'PRCSELF!($P(^(0),U,17)="_PRCDUZ_"&PRCSELF)"
25 S X("W")="W:$X>20 ! W $P(^(0),U,1),"" "",$E($P(^(0),U,9),4,5)_""-""_$E($P(^(0),U,9),6,7)_""-""_$E($P(^(0),U,9),2,3),"" $"",$J($P(^(0),U,14),0,2) W:$D(^(6)) "" "",$P(^(6),U,1)"
26 W ! D LOOKUP^PRC0B(.X,.Y,"440.6;^PRCH(440.6,;","AEMOQS~~","Select Reconciled/Disputed C-Document/Purchase Card Order: ")
27 I Y<0!(X="") G EXIT
28 K X S PRCRI(440.6)=+Y,PRCRI(442)=$P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",1),PCSTAT=$P($G(^PRCH(440.6,PRCRI(440.6),0)),"^",16)
29 I 'PRCRI(442) D EN^DDIOL("Not reconciled yet.") G Q3
30 ;
31 ;if the charge has been reconciled warn user before starting any changes
32 I $D(PRCRI(442)),$G(PCSTAT)="R"!($G(PCSTAT)="D") D G:X="NO"!(X["^")!(X="") Q3
33 . W $C(7),!!,?25,"**** WARNING ****"
34 . S DIR("A",1)=""
35 . S DIR("A",2)="This charge is reconciled. If you 'Edit' it, another approval will be needed."
36 . S DIR("A",3)="If you 'Remove' the reconciliation, you must reconcile the charge and your "
37 . S DIR("A",4)="Approving Official will have to approve it again."
38 . S DIR("A",5)=""
39 . S DIR("A",6)="Use the action code DD (Display Document) if no change is desired."
40 . S DIR("A",7)=""
41 . S DIR("A")="Do you want to continue"
42 . S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR Q:$D(DIRUT)
43 D ACT
44 G Q3
45 ;
46 ;
47EXIT QUIT
48ACT S PRCE=^PRC(442,PRCRI(442),0),PRCCP=$P($G(^(23)),"^",16),PRCR=$P($G(^(23)),"^",15) S:PRCR="" PRCR="N"
49 S X(1)=$TR($J("",79)," ","_")
50 S X(2)=" Action Code: ED: Edit DO: Display Order ND: Next Document",X(3)=" RM: Remove DD: Display Document"
51 S Y(1)="Enter an action code"
52 D FT^PRC0A(.X,.Y,"Action","","")
53 I X["^"!(X="") QUIT
54 S Y=$$LU
55 I Y="ND" QUIT
56 I Y="DO" D G ACT
57 . N D0 S D0=PRCRI(442) D ^PRCHDP1
58 . QUIT
59 I Y="DD" D DD G ACT
60 S PRCEDRM="" I Y="ED" S PRCEDRM=1 D RC^PRCH1A1 QUIT
61 I Y'="RM" D EN^DDIOL("Invalid Action code, try again") G ACT
62 ;remove conciliation
63 S PRCA=^PRCH(440.6,PRCRI(440.6),0),PRCB=$G(^(1))
64 D E20,ET
65 S PRCA=^PRCH(440.6,PRCRI(440.6),0),PRCB=$G(^(1))
66 S PRCRI(410)=$P(^PRC(442,PRCRI(442),0),"^",12)
67 D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44///N;15////N;45///@")
68 D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18///@;19///@;46///@;41///@;42///@")
69 ;if final payment entry removed
70 I $P(PRCB,"^",4)="Y" D
71 . S PRCST=$P(PRCA,"^",20) D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///@;44///@;.5///"_PRCST)
72 . I PRCRI(410) D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_$P(PRCA,"^",19))
73 . S PRCRI=0 F S PRCRI=$O(^PRC(442,PRCRI(442),13,PRCRI)) QUIT:'PRCRI D:PRCRI ERS410^PRC0G(PRCRI_"^A")
74 . QUIT
75 S PRCC=$$FP^PRCH0A(PRCRI(442))
76 ;if last payment entry removed
77 I $P(PRCC,"^",2)="" S PRCST=$P(PRCA,"^",20) D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///@;44///@;.5///"_PRCST) G Q9
78 ;if not last payment entry removed
79 D:PRCRI(410)&PRCC
80 . N A,B
81 . S A=0,B=0 F S A=$O(^PRCH(440.6,"PO",PRCRI(442),A)) QUIT:'A S B=B+$P(^PRCH(440.6,A,0),"^",14)
82 . D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B)
83 . QUIT
84Q9 ;prompt status
85 K X
86 S X=+^PRC(442,PRCRI(442),7),X("B")=$P(^PRCD(442.3,X,0),"^")
87 S PRCVAL=",22,27,25,30,40,24,32,37,39,46,48,50,"
88 S:$O(^PRC(442,PRCRI(442),6,0)) PRCVAL=",22,27,25,26,30,31,40,23,24,29,32,34,37,38,39,44,46,47,48,49,50,51,"
89 S X("S")="N A S A=$P(^PRCD(442.3,+Y,0),U,2) I PRCVAL[("",""_A_"","")"
90 D LOOKUP^PRC0B(.X,.Y,"442.3;^PRCD(442.3,","AEMQ","AFTER Removing Change P.O. Status to: ")
91 I Y<0!(X="") D EN^DDIOL("The purchase card order status is required") G Q9
92 S PRCST=$P(^PRCD(442.3,+Y,0),"^",2)
93 D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),".5///"_PRCST)
94 QUIT
95 ;
96E20 D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20")
97 QUIT
98 ;
99ET S A=$$DDA4406^PRCH0A(PRCRI(440.6)),B=$$DDA442^PRCH0A(PRCRI(442)),$P(B,"^",17)="",PRCBOC=$P(B,"^",21),$P(B,"^",33)=$P(A,"^",33)
100 I A'=B D
101 . I $E(PRCA,13,15)>490 D EN^DDIOL("Enter ET-Document by FMS-ON LINE!") QUIT
102 . D EN^DDIOL("Generating ET-document to FMS...")
103 . D ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^2^"_PRCBOC,"")
104 . I X D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$P(X,"^"))
105 . QUIT
106 QUIT
107 ;
108 ;
109DD ;dispaly document
110 N A
111 D PIECE^PRC0B("440.6;^PRC(440.6,;"_PRCRI(440.6),".01;8;13;31;44","E","A")
112 W !,"Reconcile Doc: ",$G(A(440.6,PRCRI(440.6),.01,"E")),?32,"Purchase Date: ",$G(A(440.6,PRCRI(440.6),8,"E")),?60,"$Amount: ",$J($G(A(440.6,PRCRI(440.6),13,"E")),0,2)
113 W !,"Final Payment: ",$G(A(440.6,PRCRI(440.6),44,"E"))
114 W !,"Vendor Name: ",$G(A(440.6,PRCRI(440.6),31,"E"))
115 QUIT
116 ;
117LU() ;lower to upper
118 QUIT $TR(Y,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.