source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSPC.m@ 1005

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

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1PRCSPC ;WISC/KMB-PURCHASE CARD UPDATE CP FILES ;2/17/98 @ 1:02 PM
2 ;;5.1;IFCAP;**35**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; quit if entry point not used
5 Q
6 ;
7COMM(DA,SDATE) ; set committed balance for PC order with no 2237
8 Q:DA']""
9 N AMT,FCP,FY,NODE,QT,STR,X S NODE=$G(^PRC(442,DA,0)) Q:NODE=""
10 S CDA=$P(NODE,"^",12)
11 S STA=+$P(NODE," -"),AMT=$P(NODE,"^",16),FCP=$P(NODE,"^",3),FCP=$P(FCP," ")
12 I CDA'="" D UPDATE
13 D NOW^%DTC
14 S FY=$E(X,2,3)
15 S QT=$E(X,4,5)
16 S QT=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",+QT)
17 S:QT=1 FY=$E(($E(X,1,3)+1),2,3)
18 S STR=STA_"^"_FCP_"^"_FY_"^"_QT_"^"_AMT
19 D EBAL^PRCSEZ(STR,"C")
20 Q
21 ;
22UPDATE ;
23 Q:CDA']""
24 N I,X,MESSAGE,STRING,TDA
25 Q:'$D(^PRCS(410,CDA,4)) S NODE(0)=^PRCS(410,CDA,0)
26 S TDA=DA,DA=CDA,X=$P(^PRCS(410,CDA,4),"^",8) D TRANK^PRCSES
27 S DA=TDA D NOW^%DTC S $P(^PRCS(410,CDA,4),"^",4)=X
28 S $P(^PRCS(410,CDA,9),"^",2)=SDATE
29 F I=1,8 S $P(^PRCS(410,CDA,4),"^",I)=AMT
30 D ERS410^PRC0G(CDA_"^A")
31 S MESSAGE="" D ENCODE^PRCSC2(CDA,DUZ,.MESSAGE)
32 I MESSAGE<1 W !,"Contact your Site manager for an electronic signature code" Q
33 Q
34 ;
35LOOK ; lookup for purchase card orders
36 Q:'$D(DA)
37 S (PRCHCDNO,PRCHXXX)=$P($G(^PRC(442,DA,23)),"^",8)
38 N TIMES,START,END,EN,STA,FIN,REM,ORIG,A1,A2,AA,ERROR,FLAG,VALUE,VALUE1,COUNT,TEMP,I,J,STR,XXZ
39 S FLAG=0
40 D ARR
41 S VALUE1=+$P($G(^PRC(442,DA,23)),"^",8)
42 I VALUE1=0,COUNT=1 S VALUE1=$P(AA(DUZ,1),"^",3),FLAG=1
43 W !,"PURCHASE CARD NAME: ",$P($G(^PRC(440.5,VALUE1,0)),"^",11),$S(VALUE1=0:"",1:"//") R XXZ:DTIME
44 I XXZ="",VALUE1'=0 W " ",$P($G(^PRC(440.5,VALUE1,0)),"^",11) S XXZ=FLAG D SET Q:$G(ERROR)="" G LOOK
45 I XXZ=" ",VALUE1'=0 W " ",$P($G(^PRC(440.5,VALUE1,0)),"^",11) S XXZ=FLAG D SET Q:$G(ERROR)="" G LOOK
46 ;
47 ; Allow user to get out gracefully.
48 I XXZ="" S X=XXZ W !!,?5,"No card selected...",$C(7) Q
49 I XXZ["^" S X=XXZ W !!,?5,"Card selection interrupted...",$C(7) Q
50 I XXZ["?",'$D(AA(DUZ,1)) W !,"You are not a purchase card holder." Q
51 S VALUE="" I XXZ["?" D I VALUE="" W "??" G LOOK
52 .D LOOK1
53 .I XXZ=""!(XXZ["^") S VALUE="" Q
54 .I '$D(AA(DUZ,XXZ)) S VALUE="" Q
55 .W " ",$P(AA(DUZ,XXZ),"^",2)
56 .D SET S:$G(ERROR)'="" VALUE=""
57 Q:VALUE=1
58 ;
59TESTL ;
60 I XXZ?1.6N D I VALUE="" W "??" G LOOK
61 .D LOOK1
62 .I XXZ=""!(XXZ["^") S VALUE="" Q
63 .I '$D(J(XXZ)) S VALUE="" Q
64 .W " ",$P(AA(DUZ,XXZ),"^",2)
65 .D SET S:$G(ERROR)'="" VALUE=""
66 Q:VALUE=1
67 D LOOK1
68 I VALUE'=1 W " ??" G LOOK
69 I (XXZ["^")!(XXZ="") W " ??" G LOOK
70 I '$D(J(XXZ)) W "??" G LOOK
71 W " ",$P(AA(DUZ,XXZ),"^",2) D SET I $G(ERROR)'="" G LOOK
72 Q
73 ;
74SET I XXZ=0 S ERROR=1 Q
75 S TEMP=$P(AA(DUZ,XXZ),"^",3)
76 S VALUE=1
77 I $P($G(^PRC(440.5,TEMP,2)),U,2)="Y" W ?50,"Inactive Purchase Card.",! S ERROR=1,VALUE="" K TEMP Q
78 S PRCHXXX=TEMP
79 Q
80 ;
81 ; Prevent use of card if it is inactive, or the approving official is
82 ; missing, or the card has expired.
83ARR S (COUNT,I)=0 F S I=$O(^PRC(440.5,"C",DUZ,I)) Q:I="" D
84 .Q:$P($G(^PRC(440.5,I,2)),U,2)="Y"!($P($G(^PRC(440.5,I,0)),"^",9)="")
85 .I $P(^PRC(440.5,I,2),U,4)]"" Q:$P($G(^PRC(440.5,I,2)),U,4)<DT
86 .S COUNT=COUNT+1,STR=$P($G(^PRC(440.5,I,0)),"^",1),STR1=$P($G(^PRC(440.5,I,0)),"^",11)
87 .I I=+$P($G(^PRC(442,DA,23)),"^",8) S FLAG=COUNT
88 .S AA(DUZ,COUNT)=STR_"^"_STR1_"^"_I
89 S REM=COUNT#20,END=COUNT-REM,TIMES=END/20
90 Q
91 ;
92LOOK1 ;
93 K J S OUT="" S ORIG=XXZ S:ORIG["?" ORIG="" S:TIMES=0 TIMES=1
94 N BB,VAL,ZZ I ORIG'="" S VAL=0 F ZZ=1:1:COUNT D
95 .I $P(AA(DUZ,ZZ),"^",2)[ORIG S VAL=VAL+1,BB=ZZ
96 I $G(VAL)=1 S J(BB)=1,VALUE=1,XXZ=BB,OUT=1 Q
97 S STA=0 F J=1:1:TIMES Q:$G(OUT)=1 D Q:$G(OUT)=1
98 .S START=1+((J-1)*20),EN=J*20 S:COUNT<20 EN=COUNT
99 .F I=START:1:EN I $P(AA(DUZ,I),"^",2)[ORIG S J(I)=1,VALUE=1 W !,I,?5,$P(AA(DUZ,I),"^",2)
100 .F I=START:1:EN I $G(J(I))=1 S FIN=I I STA=0 S STA=I
101 .I $G(VALUE)=1 W !,"CHOOSE ",STA,"-",FIN,": " R XXZ:DTIME I '$T S OUT=1
102 .I XXZ'="",XXZ>COUNT S OUT=1
103 .I XXZ'="",XXZ'>EN S OUT=1
104 Q:$G(OUT)=1
105 I COUNT<20 Q
106 K J S VALUE="" F I=END+1:1:COUNT I $P(AA(DUZ,I),"^",2)[ORIG S J(I)=1,VALUE=1 W !,I,?5,$P(AA(DUZ,I),"^",2)
107 F I=END+1:1:COUNT I $G(J(I))=1 S FIN=I
108 I $G(VALUE)=1 W !,"CHOOSE ",STA,"-",FIN,": " R XXZ:DTIME I XXZ'=""!'$T S OUT=1
109 Q
110 ;
111REF ;Stop users atempting to enter a past date and clean up the P.O. DATE
112 ;field and its cross reference, "AB".
113 S PRCHX=@"^DD(442,.1,1,1,2)" X PRCHX K PRCHX
114 S $P(^PRC(442,DA,1),"^",15)=""
115 Q
Note: See TracBrowser for help on using the repository browser.