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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHSF 3582 printed Oct 16, 2024@18:11:25 Page 2
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
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;NEW PO
+3 ;TOTAL PO $ AMOUNT CALCULATIONS FOR FILE 442
+4 ;THIS ROUTINE IS CALLED FROM: PRCHNPO1
+5 ; PRCHNPO4
+6 ; PRCHNRQ
+7 ;
+8 if $PIECE(^PRC(442,DA,7),U,1)=45
QUIT
LOCK +^PRC(442,DA):1
IF '$TEST
WRITE !," P.O. is being edited by another person !",$CHAR(7)
QUIT
+9 SET U="^"
SET X=^PRC(442,DA,0)
SET PRCHS("EST")=+$PIECE(X,U,13)
SET PRCHS("CP")=+$PIECE(X,U,3)
SET PRCHS("SITE")=+X
IF $DATA(^PRC(420,PRCHS("SITE"),1,PRCHS("CP"),0))
IF $PIECE(^(0),U,12)
SET PRCHS("SP")=$PIECE(^(0),U,12)
+10 SET IL=0
FOR
SET IL=$ORDER(^PRC(442,DA,2,IL))
if IL=""!(IL'>0)
QUIT
SET PRCHS=IL
SET PRCHS("N")=^(PRCHS,0)
SET PRCHS("N2")=$GET(^(2))
SET PRCHS("NS")=+$PIECE(PRCHS("N"),U,4)
DO L
+11 SET (CNT,JL)=0
FOR
SET JL=$ORDER(PRCHS("A",JL))
if JL=""!(JL<0)
QUIT
DO LI2
+12 SET (PRCHS("TOT"),PRCHS("NET"),ML,PRCHS)=0
+13 SET BOCSHP=$GET(^PRC(442,DA,23))
SET PRCHS(991)=+BOCSHP_"^"_PRCHS("EST")
KILL BOCSHP
+14 FOR
SET ML=$ORDER(PRCHS(ML))
if ML=""!(ML'>0)
QUIT
IF ML'=991
SET PRCHS("TOT")=PRCHS("TOT")+$PIECE(PRCHS(ML),U,2)
+15 SET PO=PRCHPO
SET PRC("BBFY")=$$BBFY^PRCFFU5(PRCHPO)
+16 NEW PARAM
KILL PRCHMO
SET PARAM=PRCHS("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")
+17 SET PRCHMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
+18 SET PRCHS("G/N")=$PIECE(PRCHMO,U,12)
KILL PRCHMO
+19 IF $DATA(PRCHS("G/N"))
if PRCHS("G/N")="G"
DO LABEL
DO NET
DO UPDT
if PRCHS("G/N")="N"
DO NET
DO UPDT
DO LABEL
+20 GOTO Q
NET ;APPLY PROMPT PAY DISCOUNTS ONLY TO ZERO NODE IF FLAG="G"
+1 DO TM
SET PTM=0
FOR
SET PTM=$ORDER(PRCHS(PTM))
if (PTM="")!(PTM'>0)
QUIT
IF $PIECE(PRCHS(PTM),U,2)
IF PTM'=991
SET X=$PIECE(PRCHS(PTM),U,2)
SET $PIECE(PRCHS(PTM),U,2)=(X-$JUSTIFY(X*PRCHS("T"),0,2))
SET PRCHS("NET")=PRCHS("NET")+$PIECE(PRCHS(PTM),U,2)
+2 QUIT
+3 ;
UPDT ;UPDATE ZERO NODE,CHECK ELECTRONIC SIGNATURE ETC.
+1 IF '$DATA(PRCSUM)&($PIECE($GET(^PRC(442,DA,12)),"^",2)]"")
SET PRCSUM=$$SUM^PRCUESIG(DA_"^"_$$STRING^PRCHES5(^PRC(442,DA,0),^PRC(442,DA,1),^PRC(442,DA,12)))
+2 SET PRCHS("NET")=PRCHS("NET")+PRCHS("EST")
SET PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST")
SET $PIECE(^PRC(442,DA,0),U,6,9)="^^^"
SET $PIECE(^(0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET")
+3 IF $PIECE($GET(^PRC(442,DA,12)),"^",2)]""
SET PRCSIG=""
SET X=0
Begin DoDot:1
+4 DO RECODE^PRCHES5(DA,PRCSUM,.PRCSIG)
+5 KILL PRCSUM,PRCSIG
+6 QUIT
End DoDot:1
+7 ;
+8 ;PRC*5.1*79: update field #133 for new FPDS report to Austin: send all
+9 ;eligible purchase orders - requisitions are never required.
+10 IF $DATA(PRCHNRQ)
QUIT
+11 if $DATA(^PRC(442,DA,25))
SET $PIECE(^PRC(442,DA,25),U,17)=""
+12 IF PRCHS("TOT")>0
IF $PIECE($GET(^PRC(442,DA,9,1,0)),U,5)]""
SET $PIECE(^PRC(442,DA,25),U,17)="YES"
+13 ;End of changes for PRC*5.1*79
+14 QUIT
+15 ;
LABEL ;IF FLAG="G" THEN CALC. 22 NODE W/O PROMPT PAY. DISCOUNTS
+1 KILL NODE,^PRC(442,DA,22)
SET NODE=$GET(^PRC(442,DA,22,0))
IF NODE=""
SET ^PRC(442,DA,22,0)="^"_$PIECE(^DD(442,41,0),U,2)
+2 SET (CTR,I)=0
FOR
SET I=$ORDER(PRCHS(I))
if I'>0
QUIT
SET CTR=$SELECT(I=991:CTR,1:CTR+1)
SET CTR=$SELECT(CTR=991:992,1:CTR)
DO IT
+3 QUIT
+4 ;
Q LOCK -^PRC(442,DA)
KILL PRCHS,IL,JL,CNT,CTR,ML,PTM,DIE,BOCSHP,FMSL,LICOST,NODE,AMT
+1 QUIT
+2 ;
IT if $DATA(DA(1))
SET PRCHDA1=DA(1)
SET DA(1)=DA
+1 SET DIC="^PRC(442,"_DA(1)_",22,"
SET DIC(0)="L"
SET X=+$PIECE(PRCHS(I),U,1)
KILL DD,DO
DO FILE^DICN
IF Y'>0
WRITE !," ERROR "
QUIT
+2 NEW DA
SET FMSL=$SELECT(I=991:991,1:CTR)
SET DIE=DIC
SET DA=+Y
SET AMT=$PIECE(PRCHS(I),U,2)
SET DR="1////^S X=AMT;2////^S X=FMSL"
DO ^DIE
KILL X,Y,DIE,DIC
+3 if $DATA(PRCHDA1)
SET DA(1)=PRCHDA1
KILL PRCHDA1
+4 QUIT
+5 ;
L if '$DATA(PRCHS("A",PRCHS("NS")))
SET PRCHS("A",PRCHS("NS"))=""
SET LICOST=+$PIECE(PRCHS("N2"),U,1)
SET PRCHS("A",PRCHS("NS"))=+(PRCHS("A",PRCHS("NS")))+LICOST-$PIECE(PRCHS("N2"),U,6)
+1 QUIT
+2 ;
LI2 SET CNT=CNT+1
SET PRCHS(CNT)=JL_U_PRCHS("A",JL)
KILL PRCHS("A",JL)
+1 QUIT
+2 ;
TM ;
+1 SET PRCHS("T")=0
KILL I
FOR I=0:0
SET I=$ORDER(^PRC(442,DA,5,I))
if 'I
QUIT
SET X=^(I,0)
IF +X>0
SET I(100-X)=+X
+2 if $ORDER(I(0))
SET PRCHS("T")=I($ORDER(I(0)))
SET PRCHS("T")=PRCHS("T")/100
KILL I
QUIT
+3 QUIT
