PRCH0A ;WISC/PLT-UTILITY FOR PRCH-ROUTINE ;6/28/96 09:07
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
;called from menu (purchase card menu)
EN ;Count reconciliation record
N PRCA,PRCB
N A,B,C,D,X,Y
S A=$$RECCT(DUZ) I A W !,"You have ",+A," charge(s) to be reconciled for statement ("_$P(A,"^",2)_" - "_$P(A,"^",3)_")."
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),"."
QUIT
;
RECCT(PRCA) ;prca = user ri, ef value: ^1=count reconcile records by user, ^2=earliest statement date, ^3=latest statement date (fm date)
N A,B,C,D
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)
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))
;
APPCT(PRCA) ;prca = user ri, count ready approved order by user
N A,B,C
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
QUIT A
;
;prca =^1 RI of file 440.6, ^2=Fileman date, prcb = ri of file 442
DD(PRCA,PRCB) ;ef value = ~1 dd1 segment, ~2 dd2 segment of ET
N PRCRI,PRCDD1,PRCDD2,PRCC,PRCD
N A,B,C
S PRCRI(442)=PRCB
S PRCRI(440.6)=+PRCA,PRCC=$P(^PRCH(440.6,PRCRI(440.6),0),"^",1),PRCD=$G(^(5)),PRCRI(411)=+$P(^(0),"^",8)
S PRCDD1="DD1^ET",$P(PRCDD1,"^",3)=$E(PRCC,2,12),$P(PRCDD1,"^",4)=$E($P(PRCD,"^",5),1,4)
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
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)
S $P(PRCDD1,"^",3)=$E(A,1,7)_$E(B#10000+10000,2,999)
S PRCDD2="DD2",A=$P(PRCA,"^",2),$P(PRCDD2,"^",2,4)=$E(A,4,5)_"^"_$E(A,6,7)_"^"_$E(A,2,3)
S $P(PRCDD2,"^",9)=$$EM(PRCC)
S A="" S:PRCRI(411) A=$P($G(^PRC(411,PRCRI(411),9)),"^",5,6)
S $P(PRCDD2,"^",14)=$E($P(A,"^"),1,9),$P(PRCDD2,"^",15)=$E($P(A,"^",2),1,2)
S $P(PRCDD2,"^",16)="0.00",$P(PRCDD2,"^",19)=$P(PRCDD1,"^",3)
QUIT PRCDD1_"~"_PRCDD2
;
;prca data ^1= ri of 440.6
DDA4406(PRCA) ;ev-value dda-segment (see et-dda doc)
N PRCDDA,PRCRI,PRCB,PRCC,PRCREQ
N A,B,C
S PRCDDA="DDA",PRCRI(440.6)=+PRCA
S A=^PRCH(440.6,PRCRI(440.6),0),B=^PRCH(440.6,PRCRI(440.6),5)
S C=$$DATE^PRC0C($P(A,"^",11),"I"),C=$$FUND^PRC0C($P(B,"^"),+C)
D DOCREQ^PRC0C(+C,"SPE","PRCREQ")
D PIECE("01",12,2),PIECE($E($$DATE^PRC0C($P(A,"^",11),"I"),3,4),13,2)
I $P(A,"^",11)'=$P(A,"^",12) D PIECE($E($$DATE^PRC0C($P(A,"^",12),"I"),3,4),14,2)
D PIECE($P(B,"^"),15,6),PIECE($P(A,"^",8),16,7)
D PIECE($S($G(PRCREQ("CC"))'="N":$P(B,"^",3),1:""),18,7)
D:$P(PRCDDA,"^",18)]"" PIECE("00",19,2) D PIECE($P(B,"^",2),20,9),PIECE($P(B,"^",4),21,4)
S C=$P(A,"^",14) D PIECE(C,33,15)
QUIT PRCDDA
;
;prca data ^1= ri of 442
DDA442(PRCA) ;ev-value dda-segment (see et-dda doc)
N PRCDDA,PRCACC,PRCRI,PRCB,PRCC,PRCREQ
N A,B,C
S PRCDDA="DDA",PRCRI(442)=+PRCA
S PRCB=^PRC(442,PRCRI(442),0),PRCC=$G(^(23)),B=$$DATE^PRC0C($P(^(1),"^",15),"I"),C=$$DATE^PRC0C($P(PRCC,"^",2),"I")
S PRCACC=$$ACC^PRC0C(+PRCB,+$P(PRCB,"^",3)_"^"_$E(B,3,4)_"^"_+C)
S A=$$FUND^PRC0C($P(PRCACC,"^",5),$P(PRCACC,"^",6))
D DOCREQ^PRC0C(+A,"SPE","PRCREQ")
D PIECE("01",12,2),PIECE($E($P(PRCACC,"^",6),3,4),13,2)
I $P(PRCACC,"^",6)'=$P(PRCACC,"^",7) D PIECE($E($P(PRCACC,"^",7),3,4),14,2)
D PIECE($P(PRCACC,"^",5),15,6),PIECE($P(PRCB,"-"),16,7)
;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
D PIECE($S($G(PRCREQ("CC"))'="N":$P($P(PRCB,"^",5)," "),1:""),18,7)
D:$P(PRCDDA,"^",18)]"" PIECE("00",19,2) D PIECE($P(PRCACC,"^",3),20,9)
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)
D PIECE($P(PRCACC,"^",10),22,8)
S C=$P(PRCB,"^",16) D PIECE($J(C,0,2),33,15)
QUIT PRCDDA
;
PIECE(A,B,C) ;set piece in variable PRCDDA, A-VALUE, B-PPECE #, C-LENGTH
S $P(PRCDDA,"^",B)=$E(A,1,C)
QUIT
;
EM(PRCA) ;ef valaue = E if original, M if modification; PRCA is cc-doc id
;N A,B,C
;S PRCA=$E(PRCA,1,12),C="E"
;S A=PRCA F S A=$O(^PRCH(440.6,"B",A)) QUIT:$E(A,1,12)'=PRCA!(A="") D QUIT:C="M"
;. 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
QUIT "E"
;
;prca = ri of file 442
FP(PRCA) ;ef value ^1 = if final pay, 0 if not, ^2=total payment, ^3=old p.o. status code
N A,B,C,D,E
S (A,B)=0,(C,D,E)=""
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)),"^")
QUIT A_"^"_C_"^"_D_"^"_E
;
;A=number for check, B=1 (optional) if number with check digit, 0 if not
LUHN(A,B) ;ef value ^1=1 if check digit is true, 0 if false, ^2=check digit
N C,D,E,F
S:'$D(B) B=1
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
S E=E+10\10*10-E#10
QUIT $S(B=0:1,1:$E(A,$L(A))=E)_"^"_E
;A=charge card number
CCN(A) ;ef = "*" if invalid charge card number
QUIT $S($$LUHN(A)<1!(A'?16N):"*",1:"")
;A=replaced charge card number
CCNR(A) ;ef = "*" if replaced charge card number is on in file
QUIT $S(A="":"",$D(^PRC(440.5,"B",A)):"",1:"*")
;site # in file 420
ST(A) ;ef = "*" if STATION # not in file, = "" if defined
I A="" QUIT "*"
QUIT $S($D(^PRC(420,A,0)):"",1:"*")
;
;A = replaced purchase card #, B =station #
STR(A,B) ;ef value = "#" if replaced card station # not equal B, else = nil
N C
QUIT:A="" ""
S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
S C=$G(^PRC(440.5,C,2))
QUIT $S(+$P(C,"^",3)=+B:"",1:"#")
;A=fund code
FC(A) ;ef = "*" if FUND CODE not in file, ="" if defined
I A="" QUIT "*"
QUIT $S($O(^PRCD(420.3,"B",A,0)):"",1:"*")
;A=replaced purchase card #, B = fund code
FCR(A,B) ;ef= "#" if replaced card fund code is different B, else =nil
N C,D,E
QUIT:A="" ""
S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
S D=$G(^PRC(440.5,C,50)),D=$P(C,"^",5),D=$TR(D,"*#")
I D]"" QUIT $S(D=B:"",1:"#")
S E=+$P($G(^PRC(440.5,C,2)),"^",3),C=$G(^PRC(440.5,C,0))
S D=$G(^PRC(420,+E,1,+$P(C,"^",2),5))
QUIT $S(B=$P(D,"^"):"",1:"#")
;A = acc code
ACC(A) ;ef = "*" if acc not in file, = "" if defined
I A="" QUIT "*"
QUIT $S($O(^PRCD(420.131,"B",A,0)):"",1:"*")
;A=replaced purchase card #, B = acc code
ACCR(A,B) ;ef= "#" if replaced card ACCcode is different B, else =nil
N C,D,E
QUIT:A="" ""
S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
S D=$G(^PRC(440.5,C,50)),D=$P(C,"^",6),D=$TR(D,"*#")
I D]"" QUIT $S(D=B:"",1:"#")
S E=+$P($G(^PRC(440.5,C,2)),"^",3),C=$G(^PRC(440.5,C,0))
S D=$G(^PRC(420,+E,1,+$P(C,"^",2),5)),D=+$P(D,"^",3)
QUIT $S(B=$P($G(^PRCD(420.131,D,0)),"^"):"",1:"#")
;A= cost center code
CC(A) ;ef = "*" if cost center not in file, ="" if defined
I A="" QUIT "*"
QUIT $S($D(^PRCD(420.1,A,0)):"",1:"*")
;A = replaced purchase card #, B = new purchase card cost center
CCR(A,B) ;ef value="#" if replaced card cc not equal B, else= nil
N C
QUIT:A="" ""
S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
S C=$G(^PRC(440.5,C,0))
QUIT $S($P($P(C,"^",3)," ")=B:"",1:"#")
;A = BOC code in file 420.2, B (optional) = cost center in file 420.1
BOC(A,B) ;ef = "*" if boc not in file, ="" if defined
I A="" QUIT "*"
I '$D(B) QUIT $S($D(^PRCD(420.2,A,0)):"",1:"*")
I $G(B)="" QUIT "*"
QUIT $S($D(^PRCD(420.1,B,1,A,0)):"",1:"*")
;A = replaced purchase card #, B =budget object class
BOCR(A,B) ;ef value = "#" if replaced card boc not equal B, else = nil
N C
QUIT:A="" ""
S C=$O(^PRC(440.5,"B",A,0)) I C="" QUIT ""
S C=$G(^PRC(440.5,C,0))
QUIT $S($P($P(C,"^",4)," ")=B:"",1:"#")
;A=user #, B=station #, C=fcp #
UFCP(A,B,C) ;ef value = "#" if user code is not in fcp, else = nil
QUIT $S($D(^PRC(420,"C",A,+B,+C)):"",1:"#")
;A=file #, B=field #, X=external value for vlidating
FFVV(A,B,X) ;ef= ^1=1 if valid, else =0, ^2=internal value if valid
X $P(^DD(A,B,0),"^",5,999)
QUIT $G(X)]""_"^"_$G(X)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH0A 8285 printed Oct 16, 2024@18:05:42 Page 2
PRCH0A ;WISC/PLT-UTILITY FOR PRCH-ROUTINE ;6/28/96 09:07
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
+4 ;called from menu (purchase card menu)
EN ;Count reconciliation record
+1 NEW PRCA,PRCB
+2 NEW A,B,C,D,X,Y
+3 SET A=$$RECCT(DUZ)
IF A
WRITE !,"You have ",+A," charge(s) to be reconciled for statement ("_$PIECE(A,"^",2)_" - "_$PIECE(A,"^",3)_")."
+4 SET PRCA=0
FOR
SET PRCA=$ORDER(^PRC(440.5,"MAAH",DUZ,PRCA))
if 'PRCA
QUIT
IF PRCA-DUZ
SET A=$$APPCT(PRCA)
if A
WRITE !,"You have ",A," order(s) to approve for ",$PIECE(^VA(200,PRCA,0),U),"."
+5 QUIT
+6 ;
RECCT(PRCA) ;prca = user ri, ef value: ^1=count reconcile records by user, ^2=earliest statement date, ^3=latest statement date (fm date)
+1 NEW A,B,C,D
+2 SET A=0
SET B=0
SET C=""
SET D=""
FOR
SET B=$ORDER(^PRCH(440.6,"ST","N"_PRCA_"~",B))
if 'B
QUIT
SET A=A+1
SET D=$PIECE($GET(^PRCH(440.6,B,0)),"^",6)
if C=""
SET C=$PIECE($GET(^PRCH(440.6,B,0)),"^",6)
+3 QUIT A_"^"_($EXTRACT(C,4,5)_"/"_$EXTRACT(C,6,7)_"/"_$EXTRACT(C,2,3))_"^"_($EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3))
+4 ;
APPCT(PRCA) ;prca = user ri, count ready approved order by user
+1 NEW A,B,C
+2 SET A=0
SET B=0
FOR
SET B=$ORDER(^PRC(442,"MAPP",PRCA_"~",B))
if 'B
QUIT
SET C=$PIECE(^PRC(442,B,23),"^",8)
IF C
IF $PIECE(^PRC(440.5,C,0),"^",10)=DUZ!($PIECE(^PRC(440.5,C,0),"^",9)=DUZ)
SET A=A+1
+3 QUIT A
+4 ;
+5 ;prca =^1 RI of file 440.6, ^2=Fileman date, prcb = ri of file 442
DD(PRCA,PRCB) ;ef value = ~1 dd1 segment, ~2 dd2 segment of ET
+1 NEW PRCRI,PRCDD1,PRCDD2,PRCC,PRCD
+2 NEW A,B,C
+3 SET PRCRI(442)=PRCB
+4 SET PRCRI(440.6)=+PRCA
SET PRCC=$PIECE(^PRCH(440.6,PRCRI(440.6),0),"^",1)
SET PRCD=$GET(^(5))
SET PRCRI(411)=+$PIECE(^(0),"^",8)
+5 SET PRCDD1="DD1^ET"
SET $PIECE(PRCDD1,"^",3)=$EXTRACT(PRCC,2,12)
SET $PIECE(PRCDD1,"^",4)=$EXTRACT($PIECE(PRCD,"^",5),1,4)
+6 SET A=$PIECE(PRCDD1,"^",3)
SET A=$EXTRACT(A,1,3)_$TRANSLATE($EXTRACT(A,4,7),"1234567890","ABCDEFGHIJ")_$EXTRACT(A,8,11)
SET $PIECE(PRCDD1,"^",3)=A
+7 SET B=0
LOCK +^PRC(411,PRCRI(411),60):99
IF $TEST
SET B=$GET(^PRC(411,PRCRI(411),60))+1
if B=1
SET B=1000+1
SET $PIECE(^(60),"^")=B
LOCK -^PRC(411,PRCRI(411),60)
+8 SET $PIECE(PRCDD1,"^",3)=$EXTRACT(A,1,7)_$EXTRACT(B#10000+10000,2,999)
+9 SET PRCDD2="DD2"
SET A=$PIECE(PRCA,"^",2)
SET $PIECE(PRCDD2,"^",2,4)=$EXTRACT(A,4,5)_"^"_$EXTRACT(A,6,7)_"^"_$EXTRACT(A,2,3)
+10 SET $PIECE(PRCDD2,"^",9)=$$EM(PRCC)
+11 SET A=""
if PRCRI(411)
SET A=$PIECE($GET(^PRC(411,PRCRI(411),9)),"^",5,6)
+12 SET $PIECE(PRCDD2,"^",14)=$EXTRACT($PIECE(A,"^"),1,9)
SET $PIECE(PRCDD2,"^",15)=$EXTRACT($PIECE(A,"^",2),1,2)
+13 SET $PIECE(PRCDD2,"^",16)="0.00"
SET $PIECE(PRCDD2,"^",19)=$PIECE(PRCDD1,"^",3)
+14 QUIT PRCDD1_"~"_PRCDD2
+15 ;
+16 ;prca data ^1= ri of 440.6
DDA4406(PRCA) ;ev-value dda-segment (see et-dda doc)
+1 NEW PRCDDA,PRCRI,PRCB,PRCC,PRCREQ
+2 NEW A,B,C
+3 SET PRCDDA="DDA"
SET PRCRI(440.6)=+PRCA
+4 SET A=^PRCH(440.6,PRCRI(440.6),0)
SET B=^PRCH(440.6,PRCRI(440.6),5)
+5 SET C=$$DATE^PRC0C($PIECE(A,"^",11),"I")
SET C=$$FUND^PRC0C($PIECE(B,"^"),+C)
+6 DO DOCREQ^PRC0C(+C,"SPE","PRCREQ")
+7 DO PIECE("01",12,2)
DO PIECE($EXTRACT($$DATE^PRC0C($PIECE(A,"^",11),"I"),3,4),13,2)
+8 IF $PIECE(A,"^",11)'=$PIECE(A,"^",12)
DO PIECE($EXTRACT($$DATE^PRC0C($PIECE(A,"^",12),"I"),3,4),14,2)
+9 DO PIECE($PIECE(B,"^"),15,6)
DO PIECE($PIECE(A,"^",8),16,7)
+10 DO PIECE($SELECT($GET(PRCREQ("CC"))'="N":$PIECE(B,"^",3),1:""),18,7)
+11 if $PIECE(PRCDDA,"^",18)]""
DO PIECE("00",19,2)
DO PIECE($PIECE(B,"^",2),20,9)
DO PIECE($PIECE(B,"^",4),21,4)
+12 SET C=$PIECE(A,"^",14)
DO PIECE(C,33,15)
+13 QUIT PRCDDA
+14 ;
+15 ;prca data ^1= ri of 442
DDA442(PRCA) ;ev-value dda-segment (see et-dda doc)
+1 NEW PRCDDA,PRCACC,PRCRI,PRCB,PRCC,PRCREQ
+2 NEW A,B,C
+3 SET PRCDDA="DDA"
SET PRCRI(442)=+PRCA
+4 SET PRCB=^PRC(442,PRCRI(442),0)
SET PRCC=$GET(^(23))
SET B=$$DATE^PRC0C($PIECE(^(1),"^",15),"I")
SET C=$$DATE^PRC0C($PIECE(PRCC,"^",2),"I")
+5 SET PRCACC=$$ACC^PRC0C(+PRCB,+$PIECE(PRCB,"^",3)_"^"_$EXTRACT(B,3,4)_"^"_+C)
+6 SET A=$$FUND^PRC0C($PIECE(PRCACC,"^",5),$PIECE(PRCACC,"^",6))
+7 DO DOCREQ^PRC0C(+A,"SPE","PRCREQ")
+8 DO PIECE("01",12,2)
DO PIECE($EXTRACT($PIECE(PRCACC,"^",6),3,4),13,2)
+9 IF $PIECE(PRCACC,"^",6)'=$PIECE(PRCACC,"^",7)
DO PIECE($EXTRACT($PIECE(PRCACC,"^",7),3,4),14,2)
+10 DO PIECE($PIECE(PRCACC,"^",5),15,6)
DO PIECE($PIECE(PRCB,"-"),16,7)
+11 ;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
+12 DO PIECE($SELECT($GET(PRCREQ("CC"))'="N":$PIECE($PIECE(PRCB,"^",5)," "),1:""),18,7)
+13 if $PIECE(PRCDDA,"^",18)]""
DO PIECE("00",19,2)
DO PIECE($PIECE(PRCACC,"^",3),20,9)
+14 SET A=$ORDER(^PRC(442,PRCRI(442),2,0))
IF A
SET B=^PRC(442,PRCRI(442),2,A,0)
DO PIECE($PIECE(B,"^",4),21,4)
+15 DO PIECE($PIECE(PRCACC,"^",10),22,8)
+16 SET C=$PIECE(PRCB,"^",16)
DO PIECE($JUSTIFY(C,0,2),33,15)
+17 QUIT PRCDDA
+18 ;
PIECE(A,B,C) ;set piece in variable PRCDDA, A-VALUE, B-PPECE #, C-LENGTH
+1 SET $PIECE(PRCDDA,"^",B)=$EXTRACT(A,1,C)
+2 QUIT
+3 ;
EM(PRCA) ;ef valaue = E if original, M if modification; PRCA is cc-doc id
+1 ;N A,B,C
+2 ;S PRCA=$E(PRCA,1,12),C="E"
+3 ;S A=PRCA F S A=$O(^PRCH(440.6,"B",A)) QUIT:$E(A,1,12)'=PRCA!(A="") D QUIT:C="M"
+4 ;. 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
+5 QUIT "E"
+6 ;
+7 ;prca = ri of file 442
FP(PRCA) ;ef value ^1 = if final pay, 0 if not, ^2=total payment, ^3=old p.o. status code
+1 NEW A,B,C,D,E
+2 SET (A,B)=0
SET (C,D,E)=""
+3 FOR
SET B=$ORDER(^PRCH(440.6,"PO",PRCA,B))
if 'B
QUIT
SET C=C+$PIECE(^PRCH(440.6,B,0),"^",14)
SET D=$PIECE(^(0),"^",20)
if $PIECE($GET(^(1)),"^",4)="Y"
SET A=1
if E=""
SET E=$PIECE($GET(^(6)),"^")
+4 QUIT A_"^"_C_"^"_D_"^"_E
+5 ;
+6 ;A=number for check, B=1 (optional) if number with check digit, 0 if not
LUHN(A,B) ;ef value ^1=1 if check digit is true, 0 if false, ^2=check digit
+1 NEW C,D,E,F
+2 if '$DATA(B)
SET B=1
+3 ;W !,A," ",B," ",C," ",D," ",E," ",F
SET D=1
SET E=0
FOR C=$LENGTH(A)-B:-1:1
SET F=D#2+1*$EXTRACT(A,C)
SET D=D+1
SET E=F\10+(F#10)+E
+4 SET E=E+10\10*10-E#10
+5 QUIT $SELECT(B=0:1,1:$EXTRACT(A,$LENGTH(A))=E)_"^"_E
+6 ;A=charge card number
CCN(A) ;ef = "*" if invalid charge card number
+1 QUIT $SELECT($$LUHN(A)<1!(A'?16N):"*",1:"")
+2 ;A=replaced charge card number
CCNR(A) ;ef = "*" if replaced charge card number is on in file
+1 QUIT $SELECT(A="":"",$DATA(^PRC(440.5,"B",A)):"",1:"*")
+2 ;site # in file 420
ST(A) ;ef = "*" if STATION # not in file, = "" if defined
+1 IF A=""
QUIT "*"
+2 QUIT $SELECT($DATA(^PRC(420,A,0)):"",1:"*")
+3 ;
+4 ;A = replaced purchase card #, B =station #
STR(A,B) ;ef value = "#" if replaced card station # not equal B, else = nil
+1 NEW C
+2 if A=""
QUIT ""
+3 SET C=$ORDER(^PRC(440.5,"B",A,0))
IF C=""
QUIT ""
+4 SET C=$GET(^PRC(440.5,C,2))
+5 QUIT $SELECT(+$PIECE(C,"^",3)=+B:"",1:"#")
+6 ;A=fund code
FC(A) ;ef = "*" if FUND CODE not in file, ="" if defined
+1 IF A=""
QUIT "*"
+2 QUIT $SELECT($ORDER(^PRCD(420.3,"B",A,0)):"",1:"*")
+3 ;A=replaced purchase card #, B = fund code
FCR(A,B) ;ef= "#" if replaced card fund code is different B, else =nil
+1 NEW C,D,E
+2 if A=""
QUIT ""
+3 SET C=$ORDER(^PRC(440.5,"B",A,0))
IF C=""
QUIT ""
+4 SET D=$GET(^PRC(440.5,C,50))
SET D=$PIECE(C,"^",5)
SET D=$TRANSLATE(D,"*#")
+5 IF D]""
QUIT $SELECT(D=B:"",1:"#")
+6 SET E=+$PIECE($GET(^PRC(440.5,C,2)),"^",3)
SET C=$GET(^PRC(440.5,C,0))
+7 SET D=$GET(^PRC(420,+E,1,+$PIECE(C,"^",2),5))
+8 QUIT $SELECT(B=$PIECE(D,"^"):"",1:"#")
+9 ;A = acc code
ACC(A) ;ef = "*" if acc not in file, = "" if defined
+1 IF A=""
QUIT "*"
+2 QUIT $SELECT($ORDER(^PRCD(420.131,"B",A,0)):"",1:"*")
+3 ;A=replaced purchase card #, B = acc code
ACCR(A,B) ;ef= "#" if replaced card ACCcode is different B, else =nil
+1 NEW C,D,E
+2 if A=""
QUIT ""
+3 SET C=$ORDER(^PRC(440.5,"B",A,0))
IF C=""
QUIT ""
+4 SET D=$GET(^PRC(440.5,C,50))
SET D=$PIECE(C,"^",6)
SET D=$TRANSLATE(D,"*#")
+5 IF D]""
QUIT $SELECT(D=B:"",1:"#")
+6 SET E=+$PIECE($GET(^PRC(440.5,C,2)),"^",3)
SET C=$GET(^PRC(440.5,C,0))
+7 SET D=$GET(^PRC(420,+E,1,+$PIECE(C,"^",2),5))
SET D=+$PIECE(D,"^",3)
+8 QUIT $SELECT(B=$PIECE($GET(^PRCD(420.131,D,0)),"^"):"",1:"#")
+9 ;A= cost center code
CC(A) ;ef = "*" if cost center not in file, ="" if defined
+1 IF A=""
QUIT "*"
+2 QUIT $SELECT($DATA(^PRCD(420.1,A,0)):"",1:"*")
+3 ;A = replaced purchase card #, B = new purchase card cost center
CCR(A,B) ;ef value="#" if replaced card cc not equal B, else= nil
+1 NEW C
+2 if A=""
QUIT ""
+3 SET C=$ORDER(^PRC(440.5,"B",A,0))
IF C=""
QUIT ""
+4 SET C=$GET(^PRC(440.5,C,0))
+5 QUIT $SELECT($PIECE($PIECE(C,"^",3)," ")=B:"",1:"#")
+6 ;A = BOC code in file 420.2, B (optional) = cost center in file 420.1
BOC(A,B) ;ef = "*" if boc not in file, ="" if defined
+1 IF A=""
QUIT "*"
+2 IF '$DATA(B)
QUIT $SELECT($DATA(^PRCD(420.2,A,0)):"",1:"*")
+3 IF $GET(B)=""
QUIT "*"
+4 QUIT $SELECT($DATA(^PRCD(420.1,B,1,A,0)):"",1:"*")
+5 ;A = replaced purchase card #, B =budget object class
BOCR(A,B) ;ef value = "#" if replaced card boc not equal B, else = nil
+1 NEW C
+2 if A=""
QUIT ""
+3 SET C=$ORDER(^PRC(440.5,"B",A,0))
IF C=""
QUIT ""
+4 SET C=$GET(^PRC(440.5,C,0))
+5 QUIT $SELECT($PIECE($PIECE(C,"^",4)," ")=B:"",1:"#")
+6 ;A=user #, B=station #, C=fcp #
UFCP(A,B,C) ;ef value = "#" if user code is not in fcp, else = nil
+1 QUIT $SELECT($DATA(^PRC(420,"C",A,+B,+C)):"",1:"#")
+2 ;A=file #, B=field #, X=external value for vlidating
FFVV(A,B,X) ;ef= ^1=1 if valid, else =0, ^2=internal value if valid
+1 XECUTE $PIECE(^DD(A,B,0),"^",5,999)
+2 QUIT $GET(X)]""_"^"_$GET(X)
