PRCHS ;SF-ISC/RSD/RHD-PLACES BOCS & AMOUNTS INTO PO FILE ;12/6/93 09:05
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;REQUIRES FOLLOWING VARIABLES: DA
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) G SP
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")=$S($D(^(2)):^(2),1:""),PRCHS("NS")=$S($P(PRCHS("N"),U,4)]"":+$P(PRCHS("N"),U,4),1:"**") D L
D LI1 G:'$D(PRCHS("AMT")) NOSUB S CNT=0,I=0 F S I=$O(PRCHS("AMT",I)) Q:I=""!(I<0)!(CNT>1) S PRCHS=0 D LI2 I $O(PRCHS("AMT",I,PRCHS)) D LI2
S:PRCHS("EST") PRCHS("EST")=PRCHS("EST")/CNT S (PRCHS,CNT)=0
F I=0:0 S PRCHS=$O(PRCHS("A",PRCHS)) Q:PRCHS="" S J=CNT#2+1,PRCHS(J)=$P(PRCHS(J),U,1)_U_($P(PRCHS(J),U,2)+PRCHS("A",PRCHS))_U_$P(PRCHS(J),U,3)_$P(PRCHS("A",PRCHS),U,2),CNT=CNT+1
F I=1:1:2 S:$D(PRCHS(I)) X=$P(PRCHS(I),U,2),$P(PRCHS(I),U,2)=(X+PRCHS("EST")*100+.5\1/100),PRCHS(I)=$S($P(PRCHS(I),U,2)'>0:"",1:PRCHS(I)) S:'$D(PRCHS(I)) PRCHS(I)=""
S PRCHS("TOT")=$P(PRCHS(1),U,2)+$P(PRCHS(2),U,2)
D TM F I=1:1:2 Q:'$P(PRCHS(I),U,2) S X=$P(PRCHS(I),U,2)-PRCHS("EST"),$P(PRCHS(I),U,2)=(X-$J(X*PRCHS("T"),0,2)+PRCHS("EST"))
I PRCHS(2)>0,PRCHS(2)<PRCHS(1) S X=PRCHS(1),PRCHS(1)=PRCHS(2),PRCHS(2)=X
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 $P(^PRC(442,DA,0),U,6,9)=$P(PRCHS(1),U,1)_U_$P(PRCHS(1),U,2)_U_$P(PRCHS(2),U,1)_U_$P(PRCHS(2),U,2),$P(^(0),U,15,16)=PRCHS("TOT")_U_($P(PRCHS(1),U,2)+$P(PRCHS(2),U,2))
I $P($G(^PRC(442,DA,12)),"^",2)]"" S PRCSIG="",X=0 D
. N PRCHMOP S PRCHMOP=$P($G(^PRC(442,DA,0)),"^",2)
. I PRCHMOP=7 D REMOVE^PRCHES5(DA),ENCODE^PRCHES5(DA,DUZ,.PRCSIG) I PRCSIG<1 W !!,"ESIG PROBLEM: ",PRCSIG H 2
. I PRCHMOP'=7 D RECODE^PRCHES5(DA,PRCSUM,.PRCSIG)
. K PRCSUM,PRCSIG
. QUIT
F I=1:1:2 S X=$P(PRCHS(I),U,3) I X]"" S X=$E(X,1,$L(X)-1) D:X[":" COL X "F J="_X_" D IT"
Q L -^PRC(442,DA) K PRCHS,I,J,CNT Q
IT I $D(^PRC(442,DA,2,J,2)) S $P(^(2),U,7)=+$P(PRCHS(I),U,1)
Q
L G:'$D(PRCHS("A",PRCHS("NS"))) LI S PRCHS("L0")=$P(PRCHS("A",PRCHS("NS")),U,2) F J=1:1 S PRCHS("L1")=$E(PRCHS("L0"),$L(PRCHS("L0"))-J) Q:PRCHS("L1")'=+PRCHS("L1")
S PRCHS("L2")=$E(PRCHS("L0"),$L(PRCHS("L0"))-J+1,$L(PRCHS("L0"))-1)+1 I PRCHS("L2")'=PRCHS S PRCHS=PRCHS("L0")_PRCHS G LI
I PRCHS("L1")=":" S PRCHS=$E(PRCHS("L0"),1,$L(PRCHS("L0"))-J)_PRCHS
E S PRCHS=$E(PRCHS("L0"),1,$L(PRCHS("L0"))-1)_":"_PRCHS
LI S:'$D(PRCHS("A",PRCHS("NS"))) PRCHS("A",PRCHS("NS"))="" S PRCHS("A",PRCHS("NS"))=PRCHS("A",PRCHS("NS"))+PRCHS("N2")-$P(PRCHS("N2"),U,6)_U_PRCHS_"," Q
LI1 S PRCHS=0 F I=0:0 S PRCHS=$O(PRCHS("A",PRCHS)) Q:PRCHS="" S:PRCHS'="**" PRCHS("AMT",(1000000000-PRCHS("A",PRCHS)),PRCHS)=""
Q
LI2 S CNT=CNT+1,PRCHS=$O(PRCHS("AMT",I,PRCHS)) Q:PRCHS="" S PRCHS(CNT)=PRCHS_U_PRCHS("A",PRCHS) K PRCHS("A",PRCHS) 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
COL F J=0:0 S J=$F(X,":",J) Q:'J S X=$E(X,1,J-1)_"1:"_$E(X,J,999),J=J+2
Q
SP S:PRCHS("SP")>1 $P(^PRC(442,DA,0),"^",5)="" S PRCHS("A","**")=""
F I=0:0 S I=$O(^PRC(442,DA,2,I)) Q:'I S $P(^(I,0),U,4)="",$P(^(2),U,7)="",PRCHS("N2")=^(2),PRCHS("A","**")=PRCHS("A","**")+PRCHS("N2")-$P(PRCHS("N2"),U,6)
NOSUB G:$O(PRCHS("A",0))'="**" Q S (PRCHS("NET"),PRCHS("TOT"))=(+$P(PRCHS("A","**"),U,1)*100+.5\1/100),PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST") D TM
I $D(PRCHS("SP")),PRCHS("SP")=2 G ENDNO
I PRCHS("T") S PRCHS("NET")=PRCHS("NET")-$J(PRCHS("NET")*PRCHS("T"),0,2)
ENDNO S PRCHS("NET")=PRCHS("NET")+PRCHS("EST"),$P(^PRC(442,DA,0),U,6,9)="^^^",$P(^(0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET") G Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHS 4004 printed Oct 16, 2024@18:11:24 Page 2
PRCHS ;SF-ISC/RSD/RHD-PLACES BOCS & AMOUNTS INTO PO FILE ;12/6/93 09:05
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;REQUIRES FOLLOWING VARIABLES: DA
+3 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
+4 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)
GOTO SP
+5 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")=$SELECT($DATA(^(2)):^(2),1:"")
SET PRCHS("NS")=$SELECT($PIECE(PRCHS("N"),U,4)]"":+$PIECE(PRCHS("N"),U,4),1:"**")
DO L
+6 DO LI1
if '$DATA(PRCHS("AMT"))
GOTO NOSUB
SET CNT=0
SET I=0
FOR
SET I=$ORDER(PRCHS("AMT",I))
if I=""!(I<0)!(CNT>1)
QUIT
SET PRCHS=0
DO LI2
IF $ORDER(PRCHS("AMT",I,PRCHS))
DO LI2
+7 if PRCHS("EST")
SET PRCHS("EST")=PRCHS("EST")/CNT
SET (PRCHS,CNT)=0
+8 FOR I=0:0
SET PRCHS=$ORDER(PRCHS("A",PRCHS))
if PRCHS=""
QUIT
SET J=CNT#2+1
SET PRCHS(J)=$PIECE(PRCHS(J),U,1)_U_($PIECE(PRCHS(J),U,2)+PRCHS("A",PRCHS))_U_$PIECE(PRCHS(J),U,3)_$PIECE(PRCHS("A",PRCHS),U,2)
SET CNT=CNT+1
+9 FOR I=1:1:2
if $DATA(PRCHS(I))
SET X=$PIECE(PRCHS(I),U,2)
SET $PIECE(PRCHS(I),U,2)=(X+PRCHS("EST")*100+.5\1/100)
SET PRCHS(I)=$SELECT($PIECE(PRCHS(I),U,2)'>0:"",1:PRCHS(I))
if '$DATA(PRCHS(I))
SET PRCHS(I)=""
+10 SET PRCHS("TOT")=$PIECE(PRCHS(1),U,2)+$PIECE(PRCHS(2),U,2)
+11 DO TM
FOR I=1:1:2
if '$PIECE(PRCHS(I),U,2)
QUIT
SET X=$PIECE(PRCHS(I),U,2)-PRCHS("EST")
SET $PIECE(PRCHS(I),U,2)=(X-$JUSTIFY(X*PRCHS("T"),0,2)+PRCHS("EST"))
+12 IF PRCHS(2)>0
IF PRCHS(2)<PRCHS(1)
SET X=PRCHS(1)
SET PRCHS(1)=PRCHS(2)
SET PRCHS(2)=X
+13 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)))
+14 SET $PIECE(^PRC(442,DA,0),U,6,9)=$PIECE(PRCHS(1),U,1)_U_$PIECE(PRCHS(1),U,2)_U_$PIECE(PRCHS(2),U,1)_U_$PIECE(PRCHS(2),U,2)
SET $PIECE(^(0),U,15,16)=PRCHS("TOT")_U_($PIECE(PRCHS(1),U,2)+$PIECE(PRCHS(2),U,2))
+15 IF $PIECE($GET(^PRC(442,DA,12)),"^",2)]""
SET PRCSIG=""
SET X=0
Begin DoDot:1
+16 NEW PRCHMOP
SET PRCHMOP=$PIECE($GET(^PRC(442,DA,0)),"^",2)
+17 IF PRCHMOP=7
DO REMOVE^PRCHES5(DA)
DO ENCODE^PRCHES5(DA,DUZ,.PRCSIG)
IF PRCSIG<1
WRITE !!,"ESIG PROBLEM: ",PRCSIG
HANG 2
+18 IF PRCHMOP'=7
DO RECODE^PRCHES5(DA,PRCSUM,.PRCSIG)
+19 KILL PRCSUM,PRCSIG
+20 QUIT
End DoDot:1
+21 FOR I=1:1:2
SET X=$PIECE(PRCHS(I),U,3)
IF X]""
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
if X["
DO COL
XECUTE "F J="_X_" D IT"
Q LOCK -^PRC(442,DA)
KILL PRCHS,I,J,CNT
QUIT
IT IF $DATA(^PRC(442,DA,2,J,2))
SET $PIECE(^(2),U,7)=+$PIECE(PRCHS(I),U,1)
+1 QUIT
L if '$DATA(PRCHS("A",PRCHS("NS")))
GOTO LI
SET PRCHS("L0")=$PIECE(PRCHS("A",PRCHS("NS")),U,2)
FOR J=1:1
SET PRCHS("L1")=$EXTRACT(PRCHS("L0"),$LENGTH(PRCHS("L0"))-J)
if PRCHS("L1")'=+PRCHS("L1")
QUIT
+1 SET PRCHS("L2")=$EXTRACT(PRCHS("L0"),$LENGTH(PRCHS("L0"))-J+1,$LENGTH(PRCHS("L0"))-1)+1
IF PRCHS("L2")'=PRCHS
SET PRCHS=PRCHS("L0")_PRCHS
GOTO LI
+2 IF PRCHS("L1")=":"
SET PRCHS=$EXTRACT(PRCHS("L0"),1,$LENGTH(PRCHS("L0"))-J)_PRCHS
+3 IF '$TEST
SET PRCHS=$EXTRACT(PRCHS("L0"),1,$LENGTH(PRCHS("L0"))-1)_":"_PRCHS
LI if '$DATA(PRCHS("A",PRCHS("NS")))
SET PRCHS("A",PRCHS("NS"))=""
SET PRCHS("A",PRCHS("NS"))=PRCHS("A",PRCHS("NS"))+PRCHS("N2")-$PIECE(PRCHS("N2"),U,6)_U_PRCHS_","
QUIT
LI1 SET PRCHS=0
FOR I=0:0
SET PRCHS=$ORDER(PRCHS("A",PRCHS))
if PRCHS=""
QUIT
if PRCHS'="**"
SET PRCHS("AMT",(1000000000-PRCHS("A",PRCHS)),PRCHS)=""
+1 QUIT
LI2 SET CNT=CNT+1
SET PRCHS=$ORDER(PRCHS("AMT",I,PRCHS))
if PRCHS=""
QUIT
SET PRCHS(CNT)=PRCHS_U_PRCHS("A",PRCHS)
KILL PRCHS("A",PRCHS)
QUIT
TM 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
+1 if $ORDER(I(0))
SET PRCHS("T")=I($ORDER(I(0)))
SET PRCHS("T")=PRCHS("T")/100
KILL I
QUIT
+2 QUIT
COL FOR J=0:0
SET J=$FIND(X,":",J)
if 'J
QUIT
SET X=$EXTRACT(X,1,J-1)_"1:"_$EXTRACT(X,J,999)
SET J=J+2
+1 QUIT
SP if PRCHS("SP")>1
SET $PIECE(^PRC(442,DA,0),"^",5)=""
SET PRCHS("A","**")=""
+1 FOR I=0:0
SET I=$ORDER(^PRC(442,DA,2,I))
if 'I
QUIT
SET $PIECE(^(I,0),U,4)=""
SET $PIECE(^(2),U,7)=""
SET PRCHS("N2")=^(2)
SET PRCHS("A","**")=PRCHS("A","**")+PRCHS("N2")-$PIECE(PRCHS("N2"),U,6)
NOSUB if $ORDER(PRCHS("A",0))'="**"
GOTO Q
SET (PRCHS("NET"),PRCHS("TOT"))=(+$PIECE(PRCHS("A","**"),U,1)*100+.5\1/100)
SET PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST")
DO TM
+1 IF $DATA(PRCHS("SP"))
IF PRCHS("SP")=2
GOTO ENDNO
+2 IF PRCHS("T")
SET PRCHS("NET")=PRCHS("NET")-$JUSTIFY(PRCHS("NET")*PRCHS("T"),0,2)
ENDNO SET PRCHS("NET")=PRCHS("NET")+PRCHS("EST")
SET $PIECE(^PRC(442,DA,0),U,6,9)="^^^"
SET $PIECE(^(0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET")
GOTO Q
