PRCHSF1 ;WISC/DJM-UPDATES OR PLACES BOCS & AMOUNTS INTO PO FILE AFTER AMENDMENT ;2/16/95 3:42 PM
V ;;5.1;IFCAP;**120**;Oct 20, 2000;Build 27
;Per VHA Directive 2004-038, this routine should not be modified.
;AMENDED PO
;UPDATES TOTAL $ AMOUNTS
;CALLED FROM 443.6 COPY ROUTINE 'PRCHAMYB'
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 I=0 F S I=$O(^PRC(442,DA,2,I)) Q:I=""!(I'>0) S PRCHS=I,PRCHS("N")=^(PRCHS,0),PRCHS("N2")=$G(^(2)),PRCHS("NS")=+$P(PRCHS("N"),U,4) D L
S (CNT,J)=0 F S J=$O(PRCHS("A",J)) Q:J=""!(J<0) D LI2
S (PRCHS("TOT"),PRCHS("NET"),M,PRCHS)=0
S BOCSHP=$G(^PRC(442,DA,23)),PRCHS(991)=+BOCSHP_"^"_PRCHS("EST") K BOCSHP
F S M=$O(PRCHS(M)) Q:M=""!(M'>0) I M'=991 S PRCHS("TOT")=PRCHS("TOT")+$P(PRCHS(M),U,2)
S PO=PRCHPO,PRC("BBFY")=$$BBFY^PRCFFU5(PRCHPO)
N PARAM K PRCHMO S PARAM=PRCHS("CP")_"^"_PRC("FY")_"^"_PRCFA("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,UPDTN D:PRCHS("G/N")="N" NET,UPDTN,LABEL
G ^PRCHSF2
NET ;APPLY PROMPT PAY DISCNT ONLY TO NET FUNDS, & REFLECT NET AMT ON 0 NODE
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
;
UPDTN ;UPDATE ZERO NODE, CHECK MESSAGE, ELECTRONIC SIGNATURE ETC.
S PRCHS("NET")=PRCHS("NET")+PRCHS("EST"),PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST"),$P(^PRC(442,DA,0),U,6,9)="^^^"
S $P(^PRC(442,DA,0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET")
;NOW UPDATE THE 'AMOUNT CHANGED' FIELD
;PRCHTOTQ = THE TOTAL AMOUNT OF THE PO BEFORE THIS UPDATE
;PRCHTOTQ IS SET IN ROUTINE 'PRCHAMYA'
S PRCHS("TOTN")=PRCHS("TOT")-PRCHTOTQ,$P(^PRC(442,PRCHPO,6,PRCHAM,0),U,3)=PRCHS("TOTN"),MESSAGE=""
D RECODE^PRCHES6(PRCHPO,PRCHAM,.MESSAGE)
S MESS1=MESSAGE,MESSAGE=1
;PRC*5.1*120 added check (AUTOOBLG set in PRCHSWCH) to also skip record recode if EDI or All/DELIVERY ORDER auto obligated order
I $G(PRCHS("SP"))'=2,$P(^PRC(442,DA,0),U,2)'=25,$G(AUTOOBLG)'=1 D RECODE^PRCHES7(PRCHPO,PRCHAM,.MESSAGE)
I MESS1'=1!(MESSAGE'=1) W !,"An error has occurred while recoding an ESIG."
Q
LABEL ;
S (CTR,I)=0 F S I=$O(PRCHS(I)) Q:I'>0 D IT
Q
;
IT N DA S:$D(DA(1)) PRCHDA1=DA(1) S DA(1)=PRCHPO
S BOC=$P(PRCHS(I),U),AMT=$P(PRCHS(I),U,2),DA=0
IT1 ;LOOK FOR BOC
;IF FOUND
; 1, SEE IF FMS LINE NUMBER=991 & I FROM PRCHS(I)=991
; A, IF SO, ENTER AMT AND QUIT
; 2, SEE IF FMS LINE NUMBER'=991 & I '=991
; A, IF SO, ENTER AMT AND QUIT
S DA=$O(^PRC(442,DA(1),22,"B",+BOC,DA)),FLAGOK=""
I DA>0 D G:FLAGOK="" IT1 Q
.S UPDT=$G(^PRC(442,DA(1),22,DA,0)),LINO=$P(UPDT,U,3)
.I LINO=991,(I=991) S $P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
.I LINO'=991,(I'=991) S $P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
.Q
;IF YOU ARRIVED HERE & I=991 YOU NEED TO FIND THE IEN IN NODE 22
;THAT HAS AN FMS LINE NUMBER = 991.
;WHEN FOUND ENTER BOC & AMT FROM LINE IT+1 AND QUIT.
I I=991 D Q:FLAGOK=1
.S DA=0 F S DA=$O(^PRC(442,DA(1),22,DA)) Q:DA'>0 D Q:FLAGOK=1
..S UPDT=$G(^PRC(442,DA(1),22,DA,0)),LINO=$P(UPDT,U,3)
..I LINO=991 S $P(UPDT,U)=BOC,$P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
.Q
S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=+BOC K DD,DO D FILE^DICN I Y'>0 W !," ERROR " Q
N DA S DIE=DIC,DA=+Y
S LAST=LAST+1
S DR="1////^S X=AMT;2////^S X=LAST" 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)=J_U_PRCHS("A",J) K PRCHS("A",J)
Q
;
TM ;
S PRCHS("T")=0,I=0 F 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[HPRCHSF1 4192 printed Apr 09, 2024@21:01:47 Page 2
PRCHSF1 ;WISC/DJM-UPDATES OR PLACES BOCS & AMOUNTS INTO PO FILE AFTER AMENDMENT ;2/16/95 3:42 PM
V ;;5.1;IFCAP;**120**;Oct 20, 2000;Build 27
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;AMENDED PO
+3 ;UPDATES TOTAL $ AMOUNTS
+4 ;CALLED FROM 443.6 COPY ROUTINE 'PRCHAMYB'
+5 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
+6 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)
+7 SET I=0
FOR
SET I=$ORDER(^PRC(442,DA,2,I))
if I=""!(I'>0)
QUIT
SET PRCHS=I
SET PRCHS("N")=^(PRCHS,0)
SET PRCHS("N2")=$GET(^(2))
SET PRCHS("NS")=+$PIECE(PRCHS("N"),U,4)
DO L
+8 SET (CNT,J)=0
FOR
SET J=$ORDER(PRCHS("A",J))
if J=""!(J<0)
QUIT
DO LI2
+9 SET (PRCHS("TOT"),PRCHS("NET"),M,PRCHS)=0
+10 SET BOCSHP=$GET(^PRC(442,DA,23))
SET PRCHS(991)=+BOCSHP_"^"_PRCHS("EST")
KILL BOCSHP
+11 FOR
SET M=$ORDER(PRCHS(M))
if M=""!(M'>0)
QUIT
IF M'=991
SET PRCHS("TOT")=PRCHS("TOT")+$PIECE(PRCHS(M),U,2)
+12 SET PO=PRCHPO
SET PRC("BBFY")=$$BBFY^PRCFFU5(PRCHPO)
+13 NEW PARAM
KILL PRCHMO
SET PARAM=PRCHS("CP")_"^"_PRC("FY")_"^"_PRCFA("BBFY")
+14 SET PRCHMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
+15 SET PRCHS("G/N")=$PIECE(PRCHMO,U,12)
KILL PRCHMO
+16 IF $DATA(PRCHS("G/N"))
if PRCHS("G/N")="G"
DO LABEL
DO NET
DO UPDTN
if PRCHS("G/N")="N"
DO NET
DO UPDTN
DO LABEL
+17 GOTO ^PRCHSF2
NET ;APPLY PROMPT PAY DISCNT ONLY TO NET FUNDS, & REFLECT NET AMT ON 0 NODE
+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 ;
UPDTN ;UPDATE ZERO NODE, CHECK MESSAGE, ELECTRONIC SIGNATURE ETC.
+1 SET PRCHS("NET")=PRCHS("NET")+PRCHS("EST")
SET PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST")
SET $PIECE(^PRC(442,DA,0),U,6,9)="^^^"
+2 SET $PIECE(^PRC(442,DA,0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET")
+3 ;NOW UPDATE THE 'AMOUNT CHANGED' FIELD
+4 ;PRCHTOTQ = THE TOTAL AMOUNT OF THE PO BEFORE THIS UPDATE
+5 ;PRCHTOTQ IS SET IN ROUTINE 'PRCHAMYA'
+6 SET PRCHS("TOTN")=PRCHS("TOT")-PRCHTOTQ
SET $PIECE(^PRC(442,PRCHPO,6,PRCHAM,0),U,3)=PRCHS("TOTN")
SET MESSAGE=""
+7 DO RECODE^PRCHES6(PRCHPO,PRCHAM,.MESSAGE)
+8 SET MESS1=MESSAGE
SET MESSAGE=1
+9 ;PRC*5.1*120 added check (AUTOOBLG set in PRCHSWCH) to also skip record recode if EDI or All/DELIVERY ORDER auto obligated order
+10 IF $GET(PRCHS("SP"))'=2
IF $PIECE(^PRC(442,DA,0),U,2)'=25
IF $GET(AUTOOBLG)'=1
DO RECODE^PRCHES7(PRCHPO,PRCHAM,.MESSAGE)
+11 IF MESS1'=1!(MESSAGE'=1)
WRITE !,"An error has occurred while recoding an ESIG."
+12 QUIT
LABEL ;
+1 SET (CTR,I)=0
FOR
SET I=$ORDER(PRCHS(I))
if I'>0
QUIT
DO IT
+2 QUIT
+3 ;
IT NEW DA
if $DATA(DA(1))
SET PRCHDA1=DA(1)
SET DA(1)=PRCHPO
+1 SET BOC=$PIECE(PRCHS(I),U)
SET AMT=$PIECE(PRCHS(I),U,2)
SET DA=0
IT1 ;LOOK FOR BOC
+1 ;IF FOUND
+2 ; 1, SEE IF FMS LINE NUMBER=991 & I FROM PRCHS(I)=991
+3 ; A, IF SO, ENTER AMT AND QUIT
+4 ; 2, SEE IF FMS LINE NUMBER'=991 & I '=991
+5 ; A, IF SO, ENTER AMT AND QUIT
+6 SET DA=$ORDER(^PRC(442,DA(1),22,"B",+BOC,DA))
SET FLAGOK=""
+7 IF DA>0
Begin DoDot:1
+8 SET UPDT=$GET(^PRC(442,DA(1),22,DA,0))
SET LINO=$PIECE(UPDT,U,3)
+9 IF LINO=991
IF (I=991)
SET $PIECE(UPDT,U,2)=AMT
SET ^PRC(442,DA(1),22,DA,0)=UPDT
SET FLAGOK=1
QUIT
+10 IF LINO'=991
IF (I'=991)
SET $PIECE(UPDT,U,2)=AMT
SET ^PRC(442,DA(1),22,DA,0)=UPDT
SET FLAGOK=1
QUIT
+11 QUIT
End DoDot:1
if FLAGOK=""
GOTO IT1
QUIT
+12 ;IF YOU ARRIVED HERE & I=991 YOU NEED TO FIND THE IEN IN NODE 22
+13 ;THAT HAS AN FMS LINE NUMBER = 991.
+14 ;WHEN FOUND ENTER BOC & AMT FROM LINE IT+1 AND QUIT.
+15 IF I=991
Begin DoDot:1
+16 SET DA=0
FOR
SET DA=$ORDER(^PRC(442,DA(1),22,DA))
if DA'>0
QUIT
Begin DoDot:2
+17 SET UPDT=$GET(^PRC(442,DA(1),22,DA,0))
SET LINO=$PIECE(UPDT,U,3)
+18 IF LINO=991
SET $PIECE(UPDT,U)=BOC
SET $PIECE(UPDT,U,2)=AMT
SET ^PRC(442,DA(1),22,DA,0)=UPDT
SET FLAGOK=1
QUIT
End DoDot:2
if FLAGOK=1
QUIT
+19 QUIT
End DoDot:1
if FLAGOK=1
QUIT
+20 SET DIC="^PRC(442,"_DA(1)_",22,"
SET DIC(0)="L"
SET X=+BOC
KILL DD,DO
DO FILE^DICN
IF Y'>0
WRITE !," ERROR "
QUIT
+21 NEW DA
SET DIE=DIC
SET DA=+Y
+22 SET LAST=LAST+1
+23 SET DR="1////^S X=AMT;2////^S X=LAST"
DO ^DIE
KILL X,Y,DIE,DIC
+24 if $DATA(PRCHDA1)
SET DA(1)=PRCHDA1
KILL PRCHDA1
+25 QUIT
+26 ;
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)=J_U_PRCHS("A",J)
KILL PRCHS("A",J)
+1 QUIT
+2 ;
TM ;
+1 SET PRCHS("T")=0
SET I=0
FOR
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
