- 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 Jan 18, 2025@03:11:51 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