67 lines
3.4 KiB
Mathematica
67 lines
3.4 KiB
Mathematica
PRCHSF ;WISC/DM/SC/SJG-PLACES BOCS & AMOUNTS INTO PO FILE ;8/19/94 10:22 AM
|
|
V ;;5.1;IFCAP;**79**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;NEW PO
|
|
;TOTAL PO $ AMOUNT CALCULATIONS FOR FILE 442
|
|
;THIS ROUTINE IS CALLED FROM: PRCHNPO1
|
|
; PRCHNPO4
|
|
; PRCHNRQ
|
|
;
|
|
Q:$P(^PRC(442,DA,7),U,1)=45 L +^PRC(442,DA):1 I '$T W !," P.O. is being edited by another person !",$C(7) Q
|
|
S U="^",X=^PRC(442,DA,0),PRCHS("EST")=+$P(X,U,13),PRCHS("CP")=+$P(X,U,3),PRCHS("SITE")=+X I $D(^PRC(420,PRCHS("SITE"),1,PRCHS("CP"),0)),$P(^(0),U,12) S PRCHS("SP")=$P(^(0),U,12)
|
|
S IL=0 F S IL=$O(^PRC(442,DA,2,IL)) Q:IL=""!(IL'>0) S PRCHS=IL,PRCHS("N")=^(PRCHS,0),PRCHS("N2")=$G(^(2)),PRCHS("NS")=+$P(PRCHS("N"),U,4) D L
|
|
S (CNT,JL)=0 F S JL=$O(PRCHS("A",JL)) Q:JL=""!(JL<0) D LI2
|
|
S (PRCHS("TOT"),PRCHS("NET"),ML,PRCHS)=0
|
|
S BOCSHP=$G(^PRC(442,DA,23)),PRCHS(991)=+BOCSHP_"^"_PRCHS("EST") K BOCSHP
|
|
F S ML=$O(PRCHS(ML)) Q:ML=""!(ML'>0) I ML'=991 S PRCHS("TOT")=PRCHS("TOT")+$P(PRCHS(ML),U,2)
|
|
S PO=PRCHPO,PRC("BBFY")=$$BBFY^PRCFFU5(PRCHPO)
|
|
N PARAM K PRCHMO S PARAM=PRCHS("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")
|
|
S PRCHMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
|
|
S PRCHS("G/N")=$P(PRCHMO,U,12) K PRCHMO
|
|
I $D(PRCHS("G/N")) D:PRCHS("G/N")="G" LABEL,NET,UPDT D:PRCHS("G/N")="N" NET,UPDT,LABEL
|
|
G Q
|
|
NET ;APPLY PROMPT PAY DISCOUNTS ONLY TO ZERO NODE IF FLAG="G"
|
|
D TM S PTM=0 F S PTM=$O(PRCHS(PTM)) Q:(PTM="")!(PTM'>0) I $P(PRCHS(PTM),U,2) I PTM'=991 S X=$P(PRCHS(PTM),U,2),$P(PRCHS(PTM),U,2)=(X-$J(X*PRCHS("T"),0,2)),PRCHS("NET")=PRCHS("NET")+$P(PRCHS(PTM),U,2)
|
|
Q
|
|
;
|
|
UPDT ;UPDATE ZERO NODE,CHECK ELECTRONIC SIGNATURE ETC.
|
|
I '$D(PRCSUM)&($P($G(^PRC(442,DA,12)),"^",2)]"") S PRCSUM=$$SUM^PRCUESIG(DA_"^"_$$STRING^PRCHES5(^PRC(442,DA,0),^PRC(442,DA,1),^PRC(442,DA,12)))
|
|
S PRCHS("NET")=PRCHS("NET")+PRCHS("EST"),PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST"),$P(^PRC(442,DA,0),U,6,9)="^^^",$P(^(0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET")
|
|
I $P($G(^PRC(442,DA,12)),"^",2)]"" S PRCSIG="",X=0 D
|
|
.D RECODE^PRCHES5(DA,PRCSUM,.PRCSIG)
|
|
.K PRCSUM,PRCSIG
|
|
.Q
|
|
;
|
|
;PRC*5.1*79: update field #133 for new FPDS report to Austin: send all
|
|
;eligible purchase orders - requisitions are never required.
|
|
I $D(PRCHNRQ) Q
|
|
S:$D(^PRC(442,DA,25)) $P(^PRC(442,DA,25),U,17)=""
|
|
I PRCHS("TOT")>0,$P($G(^PRC(442,DA,9,1,0)),U,5)]"" S $P(^PRC(442,DA,25),U,17)="YES"
|
|
;End of changes for PRC*5.1*79
|
|
Q
|
|
;
|
|
LABEL ;IF FLAG="G" THEN CALC. 22 NODE W/O PROMPT PAY. DISCOUNTS
|
|
K NODE,^PRC(442,DA,22) S NODE=$G(^PRC(442,DA,22,0)) I NODE="" S ^PRC(442,DA,22,0)="^"_$P(^DD(442,41,0),U,2)
|
|
S (CTR,I)=0 F S I=$O(PRCHS(I)) Q:I'>0 S CTR=$S(I=991:CTR,1:CTR+1),CTR=$S(CTR=991:992,1:CTR) D IT
|
|
Q
|
|
;
|
|
Q L -^PRC(442,DA) K PRCHS,IL,JL,CNT,CTR,ML,PTM,DIE,BOCSHP,FMSL,LICOST,NODE,AMT
|
|
Q
|
|
;
|
|
IT S:$D(DA(1)) PRCHDA1=DA(1) S DA(1)=DA
|
|
S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=+$P(PRCHS(I),U,1) K DD,DO D FILE^DICN I Y'>0 W !," ERROR " Q
|
|
N DA S FMSL=$S(I=991:991,1:CTR),DIE=DIC,DA=+Y,AMT=$P(PRCHS(I),U,2),DR="1////^S X=AMT;2////^S X=FMSL" D ^DIE K X,Y,DIE,DIC
|
|
S:$D(PRCHDA1) DA(1)=PRCHDA1 K PRCHDA1
|
|
Q
|
|
;
|
|
L S:'$D(PRCHS("A",PRCHS("NS"))) PRCHS("A",PRCHS("NS"))="" S LICOST=+$P(PRCHS("N2"),U,1),PRCHS("A",PRCHS("NS"))=+(PRCHS("A",PRCHS("NS")))+LICOST-$P(PRCHS("N2"),U,6)
|
|
Q
|
|
;
|
|
LI2 S CNT=CNT+1 S PRCHS(CNT)=JL_U_PRCHS("A",JL) K PRCHS("A",JL)
|
|
Q
|
|
;
|
|
TM ;
|
|
S PRCHS("T")=0 K I F I=0:0 S I=$O(^PRC(442,DA,5,I)) Q:'I S X=^(I,0) I +X>0 S I(100-X)=+X
|
|
S:$O(I(0)) PRCHS("T")=I($O(I(0))),PRCHS("T")=PRCHS("T")/100 K I Q
|
|
Q
|