source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH1B.m@ 1150

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1PRCH1B ;WISC/PLT-PURCHASE CARD APPROVE REONCILIATION ; 03/01/96 1:27 PM
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 ;approve reconciled purchase card orders
7 N PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCQT,PRCSEL,PRCSST,PRCSTC
8 N A,B,C
9Q1 ;station
10 S PRCSST=1 D STA^PRCSUT S PRCSTC=SI G:$G(PRC("SITE"))=""!(Y<0)!(PRCSTC<1) EXIT
11 S PRCRI(420)=+PRC("SITE")
12Q2 S B="O^1:All Purchase Card Users;2:Single Purchase Card User"
13 K X,Y S Y(1)="^W ""Enter an option number 1 to 2."""
14 D SC^PRC0A(.X,.Y,"Select Number",B,"")
15 S A=Y K X,Y
16 G EXIT:A=""!(A["^")
17 S PRCOPT=+A
18 I PRCOPT=1 G AUTO
19Q3 ;select purchase card user
20 W !! S PRCDI="200;^VA(200,;"
21 S X("S")="I Y-DUZ,$D(^PRC(440.5,""MAAH"",DUZ,+Y))"
22 D LOOKUP^PRC0B(.X,.Y,PRCDI,"AEOQS","Select Purchase Card Order User: ")
23 I Y<0!(X="") S PRCQT="^" G Q2
24 K X S PRCRI(200)=+Y
25 D USER(PRCRI(200),PRCOPT)
26 D EN^DDIOL("Approving reconciliation for "_$P($G(^VA(200,PRCRI(200),0)),U)_" ends.")
27 G Q3
28AUTO ;start auto
29 S PRCRI(200)="" F S PRCRI(200)=$O(^PRC(440.5,"MAAH",DUZ,PRCRI(200))) QUIT:'PRCRI(200) D:DUZ-PRCRI(200) USER(PRCRI(200),PRCOPT) QUIT:$D(DUOUT)!($G(X)["^")
30 K DUOUT
31 D EN^DDIOL("Approving reconciliation for all purchase card users ends.")
32EXIT QUIT
33 ;
34USER(PRCA,PRCB) ;approve by user
35 N PRCRI,PRCC,PRCD,PRCOPT,PRCUSR,PRCCNT
36 N A,B,C,D,X,Y
37 S PRCRI(200)=PRCA,PRCUSR=$P($G(^VA(200,PRCA,0)),U,1),PRCOPT=PRCB
38RL W ! K ^TMP("PRCHAPP",$J,PRCRI(200))
39 S PRCRI(442)=0,PRCCNT=0
40 F S PRCRI(442)=$O(^PRC(442,"MAPP",PRCRI(200)_"~",PRCRI(442))) QUIT:'PRCRI(442) I ^PRC(442,PRCRI(442),0)-PRC("SITE")=0 S C=$P(^(23),"^",8) I C,$P(^PRC(440.5,C,0),"^",10)=DUZ!($P(^(0),"^",9)=DUZ) D DISP QUIT:X["^"!$D(DUOUT)
41 I PRCCNT=0 G USEREXT
42 S PRCSEL=""
43ACT S X(1)=$TR($J("",79)," ","_")
44 S X(2)=" Action Code: SL: Select DO: Display Order NU: Next User",X(3)=" AP: Approve RL: Relist Reconciled Orders DC: Display Charges"
45 S Y(1)="Enter an action code"
46 D FT^PRC0A(.X,.Y,"Action","",$S($G(PRCSEL)="":"SL",1:"")) QUIT:X["^"
47 S Y=$$LU
48 I Y="NU" QUIT
49 I Y="RL" G RL
50DO I Y="DO"!(Y="DC") D G DO:Y="DO"!(Y="DC"),RL
51 . N PRCOPT
52 . S PRCOPT=Y
53 . S E="O^1:5^",Y(1)="Enter one sequence # to display the purchase order"
54 . D FT^PRC0A(.X,.Y,"Select Sequence # to Display (1-"_PRCCNT_")",E,"") QUIT:X["^"!(X="")
55 . I Y'?1.N!(Y<1)!(Y>PRCCNT) D EN^DDIOL("Invalid sequence #, try again!") S Y=PRCOPT QUIT
56 . N D0 S D0=$P(^TMP("PRCHAPP",$J,PRCRI(200),+Y),"^") D ^PRCHDP1:PRCOPT="DO",DC^PRCH1A(D0):PRCOPT="DC"
57 . S Y=""
58 . QUIT
59 I Y="AP" G APP:PRCSEL]"" D EN^DDIOL("No purchase orders selected") G ACT
60 I Y'="SL" D EN^DDIOL("Invalid Action code, try again") G ACT
61Q11 S PRCSEL="",E="O^1:230^",Y(1)="Enter format: 'ALL', 'E/1,3,6-9,10' for exception, or '1,3,6-9,10' to approve"
62 D FT^PRC0A(.X,.Y,"Select Sequence #'s to approve (1-"_PRCCNT_")",E,"")
63 G USEREXT:X=""!(X["^")
64 S X=$$LU()
65 S PRCSEL=X
66 I X="ALL" G ACT
67 I X?1"E/".E S X=$E(X,3,999)
68 S Y="",C=0 F A=1:1 QUIT:$P(X,",",A,999)="" S B=$P(X,",",A) D
69 . I B?1.N,0<B,B'>PRCCNT I ","_Y_","'[(","_B_",") S C=C+1,$P(Y,",",C)=B QUIT
70 . I B?1.N1"-"1.N,$P(B,"-",2)>$P(B,"-"),0<B,B'>PRCCNT,0<$P(B,"-",2),$P(B,"-",2)'>PRCCNT I ","_Y_","'[(","_B_",") S C=C+1,$P(Y,",",C)=B QUIT
71 . QUIT
72 I Y="" W !,"Invalid selection, try again!" G Q11
73 S:PRCSEL?1"E/".E Y="E/"_Y G:PRCSEL=Y ACT
74 I X'=Y W !,"Warning: Invalid entries entered in the selection." W:Y]"" !,"The valid selection is: ",!,?3,"'",Y,"'"
75 S PRCSEL=Y G ACT
76 ;
77APP ;enter ESIG to approve
78 D ESIG^PRCUESIG(DUZ,.A)
79 I A=0!(A=3) D EN^DDIOL("Invalid Code Entered") G APP
80 I A=-1!(A=-2) D EN^DDIOL("NOT APPROVED") G USEREXT
81 I PRCSEL="ALL" D G USEREXT
82 . F PRCA=1:1:PRCCNT D APREC^PRCH1B1($P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^")) QUIT:X["^"!$D(DUOUT)
83 . QUIT
84 I PRCSEL?1"E/".E D G USEREXT
85 . S A=$E(PRCSEL,3,999) F B=1:1 QUIT:$P(A,",",B,999)="" S C=$P(A,",",B) D
86 .. I C?1.N S $P(^TMP("PRCHAPP",$J,PRCRI(200),C),"^",2)="E"
87 .. I C?1.N1"-"1.N F D=+C:1:$P(C,"-",2) S $P(^TMP("PRCHAPP",$J,PRCRI(200),D),"^",2)="E"
88 .. QUIT
89 . F PRCA=1:1:PRCCNT D:$P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^",2)'="E" APREC^PRCH1B1($P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^")) QUIT:X["^"!$D(DUOUT)
90 . QUIT
91 S A=PRCSEL F B=1:1 QUIT:$P(A,",",B,999)="" S C=$P(A,",",B) D
92 . I C?1.N S $P(^TMP("PRCHAPP",$J,PRCRI(200),C),"^",2)="A"
93 . I C?1.N1"-"1.N F D=+C:1:$P(C,"-",2) S $P(^TMP("PRCHAPP",$J,PRCRI(200),D),"^",2)="A"
94 . QUIT
95 F PRCA=1:1:PRCCNT D:$P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^",2)="A" APREC^PRCH1B1($P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^")) QUIT:X["^"!$D(DUOUT)
96USEREXT K ^TMP("PRCHAPP",$J,PRCRI(200))
97 QUIT
98 ;
99DISP ;display purchase card order
100 N A,B,C,D,E
101 S PRCCNT=PRCCNT+1,^TMP("PRCHAPP",$J,PRCRI(200),PRCCNT)=PRCRI(442)
102 I PRCCNT=1 D EN^DDIOL("Start approving purchase card orders for "_PRCUSR),EN^DDIOL("Compiling user's reconciled purchase orders..."),EN^DDIOL("Seq# IFCAP PO # Vendor $Amount Credit Card Vendor $Amount")
103 S C="442;^PRC(442,;"_PRCRI(442)
104 K A D PIECE^PRC0B(C,".01;5;92","E","A")
105 S A=$G(A(442,PRCRI(442),.01,"E"))
106 S C=$G(A(442,PRCRI(442),92,"E"))
107 S E=$E($G(A(442,PRCRI(442),5,"E")),1,20)
108 I E="SIMPLIED" S D=$O(^PRC(442,PRCRI(442),2,0)) I D S D=$O(^PRC(442,PRCRI(442),2,D,1,0)) I D S E=^(D,0)
109 S B=$$FP^PRCH0A(PRCRI(442))
110 W !,$J(PRCCNT,4)," ",$P(A,U),?18,$E(E,1,20),?36,$J(C,8,2),?48,$E($P(B,"^",4),1,20),?69,$J($P(B,"^",2),8,2),$S($P(B,"^",2)-C:"*",1:"")
111 K A
112 S X="" I PRCCNT#20=0 S E="O^1:5^",Y(1)="Enter 'RETURN' to continue for listing or '^' to quit for selection." D FT^PRC0A(.X,.Y,"Hit 'RETURN' to continue for listing or '^' to quit for selection",E,"")
113 QUIT
114 ;
115LU() ;EV - low to upper
116 QUIT $TR(Y,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.