Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCH0A

PRCH0A.m

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