source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH0A.m@ 736

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

initial load of FOIAVistA 6/30/08 version
File size: 7.9 KB
Line 
1PRCH0A ;WISC/PLT-UTILITY FOR PRCH-ROUTINE ;6/28/96 09:07
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 ;
6 ;called from menu (purchase card menu)
7EN ;Count reconciliation record
8 N PRCA,PRCB
9 N A,B,C,D,X,Y
10 S A=$$RECCT(DUZ) I A W !,"You have ",+A," charge(s) to be reconciled for statement ("_$P(A,"^",2)_" - "_$P(A,"^",3)_")."
11 S PRCA=0 F S PRCA=$O(^PRC(440.5,"MAAH",DUZ,PRCA)) QUIT:'PRCA I PRCA-DUZ S A=$$APPCT(PRCA) W:A !,"You have ",A," order(s) to approve for ",$P(^VA(200,PRCA,0),U),"."
12 QUIT
13 ;
14RECCT(PRCA) ;prca = user ri, ef value: ^1=count reconcile records by user, ^2=earliest statement date, ^3=latest statement date (fm date)
15 N A,B,C,D
16 S A=0,B=0,C="",D="" F S B=$O(^PRCH(440.6,"ST","N"_PRCA_"~",B)) QUIT:'B S A=A+1,D=$P($G(^PRCH(440.6,B,0)),"^",6) S:C="" C=$P($G(^PRCH(440.6,B,0)),"^",6)
17 QUIT A_"^"_($E(C,4,5)_"/"_$E(C,6,7)_"/"_$E(C,2,3))_"^"_($E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3))
18 ;
19APPCT(PRCA) ;prca = user ri, count ready approved order by user
20 N A,B,C
21 S A=0,B=0 F S B=$O(^PRC(442,"MAPP",PRCA_"~",B)) QUIT:'B S C=$P(^PRC(442,B,23),"^",8) I C,$P(^PRC(440.5,C,0),"^",10)=DUZ!($P(^PRC(440.5,C,0),"^",9)=DUZ) S A=A+1
22 QUIT A
23 ;
24 ;prca =^1 RI of file 440.6, ^2=Fileman date, prcb = ri of file 442
25DD(PRCA,PRCB) ;ef value = ~1 dd1 segment, ~2 dd2 segment of ET
26 N PRCRI,PRCDD1,PRCDD2,PRCC,PRCD
27 N A,B,C
28 S PRCRI(442)=PRCB
29 S PRCRI(440.6)=+PRCA,PRCC=$P(^PRCH(440.6,PRCRI(440.6),0),"^",1),PRCD=$G(^(5)),PRCRI(411)=+$P(^(0),"^",8)
30 S PRCDD1="DD1^ET",$P(PRCDD1,"^",3)=$E(PRCC,2,12),$P(PRCDD1,"^",4)=$E($P(PRCD,"^",5),1,4)
31 S A=$P(PRCDD1,"^",3),A=$E(A,1,3)_$TR($E(A,4,7),"1234567890","ABCDEFGHIJ")_$E(A,8,11),$P(PRCDD1,"^",3)=A
32 S B=0 L +^PRC(411,PRCRI(411),60):99 I S B=$G(^PRC(411,PRCRI(411),60))+1 S:B=1 B=1000+1 S $P(^(60),"^")=B L -^PRC(411,PRCRI(411),60)
33 S $P(PRCDD1,"^",3)=$E(A,1,7)_$E(B#10000+10000,2,999)
34 S PRCDD2="DD2",A=$P(PRCA,"^",2),$P(PRCDD2,"^",2,4)=$E(A,4,5)_"^"_$E(A,6,7)_"^"_$E(A,2,3)
35 S $P(PRCDD2,"^",9)=$$EM(PRCC)
36 S A="" S:PRCRI(411) A=$P($G(^PRC(411,PRCRI(411),9)),"^",5,6)
37 S $P(PRCDD2,"^",14)=$E($P(A,"^"),1,9),$P(PRCDD2,"^",15)=$E($P(A,"^",2),1,2)
38 S $P(PRCDD2,"^",16)="0.00",$P(PRCDD2,"^",19)=$P(PRCDD1,"^",3)
39 QUIT PRCDD1_"~"_PRCDD2
40 ;
41 ;prca data ^1= ri of 440.6
42DDA4406(PRCA) ;ev-value dda-segment (see et-dda doc)
43 N PRCDDA,PRCRI,PRCB,PRCC,PRCREQ
44 N A,B,C
45 S PRCDDA="DDA",PRCRI(440.6)=+PRCA
46 S A=^PRCH(440.6,PRCRI(440.6),0),B=^PRCH(440.6,PRCRI(440.6),5)
47 S C=$$DATE^PRC0C($P(A,"^",11),"I"),C=$$FUND^PRC0C($P(B,"^"),+C)
48 D DOCREQ^PRC0C(+C,"SPE","PRCREQ")
49 D PIECE("01",12,2),PIECE($E($$DATE^PRC0C($P(A,"^",11),"I"),3,4),13,2)
50 I $P(A,"^",11)'=$P(A,"^",12) D PIECE($E($$DATE^PRC0C($P(A,"^",12),"I"),3,4),14,2)
51 D PIECE($P(B,"^"),15,6),PIECE($P(A,"^",8),16,7)
52 D PIECE($S($G(PRCREQ("CC"))'="N":$P(B,"^",3),1:""),18,7)
53 D:$P(PRCDDA,"^",18)]"" PIECE("00",19,2) D PIECE($P(B,"^",2),20,9),PIECE($P(B,"^",4),21,4)
54 S C=$P(A,"^",14) D PIECE(C,33,15)
55 QUIT PRCDDA
56 ;
57 ;prca data ^1= ri of 442
58DDA442(PRCA) ;ev-value dda-segment (see et-dda doc)
59 N PRCDDA,PRCACC,PRCRI,PRCB,PRCC,PRCREQ
60 N A,B,C
61 S PRCDDA="DDA",PRCRI(442)=+PRCA
62 S PRCB=^PRC(442,PRCRI(442),0),PRCC=$G(^(23)),B=$$DATE^PRC0C($P(^(1),"^",15),"I"),C=$$DATE^PRC0C($P(PRCC,"^",2),"I")
63 S PRCACC=$$ACC^PRC0C(+PRCB,+$P(PRCB,"^",3)_"^"_$E(B,3,4)_"^"_+C)
64 S A=$$FUND^PRC0C($P(PRCACC,"^",5),$P(PRCACC,"^",6))
65 D DOCREQ^PRC0C(+A,"SPE","PRCREQ")
66 D PIECE("01",12,2),PIECE($E($P(PRCACC,"^",6),3,4),13,2)
67 I $P(PRCACC,"^",6)'=$P(PRCACC,"^",7) D PIECE($E($P(PRCACC,"^",7),3,4),14,2)
68 D PIECE($P(PRCACC,"^",5),15,6),PIECE($P(PRCB,"-"),16,7)
69 ;I $P(PRCC,"^",7)>99999 S A=$G(^PRC(411,$P(PRCC,"^",7),0)) D PIECE($E(A,4,5),17,2) ;substation not in oracle record
70 D PIECE($S($G(PRCREQ("CC"))'="N":$P($P(PRCB,"^",5)," "),1:""),18,7)
71 D:$P(PRCDDA,"^",18)]"" PIECE("00",19,2) D PIECE($P(PRCACC,"^",3),20,9)
72 S A=$O(^PRC(442,PRCRI(442),2,0)) I A S B=^PRC(442,PRCRI(442),2,A,0) D PIECE($P(B,"^",4),21,4)
73 D PIECE($P(PRCACC,"^",10),22,8)
74 S C=$P(PRCB,"^",16) D PIECE($J(C,0,2),33,15)
75 QUIT PRCDDA
76 ;
77PIECE(A,B,C) ;set piece in variable PRCDDA, A-VALUE, B-PPECE #, C-LENGTH
78 S $P(PRCDDA,"^",B)=$E(A,1,C)
79 QUIT
80 ;
81EM(PRCA) ;ef valaue = E if original, M if modification; PRCA is cc-doc id
82 ;N A,B,C
83 ;S PRCA=$E(PRCA,1,12),C="E"
84 ;S A=PRCA F S A=$O(^PRCH(440.6,"B",A)) QUIT:$E(A,1,12)'=PRCA!(A="") D QUIT:C="M"
85 ;. S B=0 F S B=$O(^PRCH(440.6,"B",A,B)) QUIT:'B I $P(^PRCH(440.6,B,0),"^",18) S C="M" QUIT
86 QUIT "E"
87 ;
88 ;prca = ri of file 442
89FP(PRCA) ;ef value ^1 = if final pay, 0 if not, ^2=total payment, ^3=old p.o. status code
90 N A,B,C,D,E
91 S (A,B)=0,(C,D,E)=""
92 F S B=$O(^PRCH(440.6,"PO",PRCA,B)) QUIT:'B S C=C+$P(^PRCH(440.6,B,0),"^",14),D=$P(^(0),"^",20) S:$P($G(^(1)),"^",4)="Y" A=1 S:E="" E=$P($G(^(6)),"^")
93 QUIT A_"^"_C_"^"_D_"^"_E
94 ;
95 ;A=number for check, B=1 (optional) if number with check digit, 0 if not
96LUHN(A,B) ;ef value ^1=1 if check digit is true, 0 if false, ^2=check digit
97 N C,D,E,F
98 S:'$D(B) B=1
99 S D=1,E=0 F C=$L(A)-B:-1:1 S F=D#2+1*$E(A,C),D=D+1,E=F\10+(F#10)+E ;W !,A," ",B," ",C," ",D," ",E," ",F
100 S E=E+10\10*10-E#10
101 QUIT $S(B=0:1,1:$E(A,$L(A))=E)_"^"_E
102 ;A=charge card number
103CCN(A) ;ef = "*" if invalid charge card number
104 QUIT $S($$LUHN(A)<1!(A'?16N):"*",1:"")
105 ;A=replaced charge card number
106CCNR(A) ;ef = "*" if replaced charge card number is on in file
107 QUIT $S(A="":"",$D(^PRC(440.5,"B",A)):"",1:"*")
108 ;site # in file 420
109ST(A) ;ef = "*" if STATION # not in file, = "" if defined
110 I A="" QUIT "*"
111 QUIT $S($D(^PRC(420,A,0)):"",1:"*")
112 ;
113 ;A = replaced purchase card #, B =station #
114STR(A,B) ;ef value = "#" if replaced card station # not equal B, else = nil
115 N C
116 QUIT:A="" ""
117 S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
118 S C=$G(^PRC(440.5,C,2))
119 QUIT $S(+$P(C,"^",3)=+B:"",1:"#")
120 ;A=fund code
121FC(A) ;ef = "*" if FUND CODE not in file, ="" if defined
122 I A="" QUIT "*"
123 QUIT $S($O(^PRCD(420.3,"B",A,0)):"",1:"*")
124 ;A=replaced purchase card #, B = fund code
125FCR(A,B) ;ef= "#" if replaced card fund code is different B, else =nil
126 N C,D,E
127 QUIT:A="" ""
128 S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
129 S D=$G(^PRC(440.5,C,50)),D=$P(C,"^",5),D=$TR(D,"*#")
130 I D]"" QUIT $S(D=B:"",1:"#")
131 S E=+$P($G(^PRC(440.5,C,2)),"^",3),C=$G(^PRC(440.5,C,0))
132 S D=$G(^PRC(420,+E,1,+$P(C,"^",2),5))
133 QUIT $S(B=$P(D,"^"):"",1:"#")
134 ;A = acc code
135ACC(A) ;ef = "*" if acc not in file, = "" if defined
136 I A="" QUIT "*"
137 QUIT $S($O(^PRCD(420.131,"B",A,0)):"",1:"*")
138 ;A=replaced purchase card #, B = acc code
139ACCR(A,B) ;ef= "#" if replaced card ACCcode is different B, else =nil
140 N C,D,E
141 QUIT:A="" ""
142 S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
143 S D=$G(^PRC(440.5,C,50)),D=$P(C,"^",6),D=$TR(D,"*#")
144 I D]"" QUIT $S(D=B:"",1:"#")
145 S E=+$P($G(^PRC(440.5,C,2)),"^",3),C=$G(^PRC(440.5,C,0))
146 S D=$G(^PRC(420,+E,1,+$P(C,"^",2),5)),D=+$P(D,"^",3)
147 QUIT $S(B=$P($G(^PRCD(420.131,D,0)),"^"):"",1:"#")
148 ;A= cost center code
149CC(A) ;ef = "*" if cost center not in file, ="" if defined
150 I A="" QUIT "*"
151 QUIT $S($D(^PRCD(420.1,A,0)):"",1:"*")
152 ;A = replaced purchase card #, B = new purchase card cost center
153CCR(A,B) ;ef value="#" if replaced card cc not equal B, else= nil
154 N C
155 QUIT:A="" ""
156 S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
157 S C=$G(^PRC(440.5,C,0))
158 QUIT $S($P($P(C,"^",3)," ")=B:"",1:"#")
159 ;A = BOC code in file 420.2, B (optional) = cost center in file 420.1
160BOC(A,B) ;ef = "*" if boc not in file, ="" if defined
161 I A="" QUIT "*"
162 I '$D(B) QUIT $S($D(^PRCD(420.2,A,0)):"",1:"*")
163 I $G(B)="" QUIT "*"
164 QUIT $S($D(^PRCD(420.1,B,1,A,0)):"",1:"*")
165 ;A = replaced purchase card #, B =budget object class
166BOCR(A,B) ;ef value = "#" if replaced card boc not equal B, else = nil
167 N C
168 QUIT:A="" ""
169 S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
170 S C=$G(^PRC(440.5,C,0))
171 QUIT $S($P($P(C,"^",4)," ")=B:"",1:"#")
172 ;A=user #, B=station #, C=fcp #
173UFCP(A,B,C) ;ef value = "#" if user code is not in fcp, else = nil
174 QUIT $S($D(^PRC(420,"C",A,+B,+C)):"",1:"#")
175 ;A=file #, B=field #, X=external value for vlidating
176FFVV(A,B,X) ;ef= ^1=1 if valid, else =0, ^2=internal value if valid
177 X $P(^DD(A,B,0),"^",5,999)
178 QUIT $G(X)]""_"^"_$G(X)
Note: See TracBrowser for help on using the repository browser.