source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHSF.m@ 1087

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