PRCSEZZ ;SF-ISC/LJP-NEW PRCSES - UPDATE SCP BALANCES ;4-3-94/15:55
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
TRANK Q:X']"" S Z(X)=-X G A
TRANS Q:X']"" S Z(X)=X
A D EN Q:'$D(Z) G:Z("TT")="" EX
I Z("TT")="A" S Z(X)=-Z(X)
I Z("TT")="O" S $P(Z("SCPB"),U,Z("SPC"))=$P(Z("SCPB"),U,Z("SPC"))-Z(X),$P(Z("SAMT"),U,Z("SPC"))=$P(Z("SAMT"),U,Z("SPC"))-Z(X) G ST
I Z("TT")'="O" S $P(Z("SCPB"),U,Z("SPC"))=$P(Z("SCPB"),U,Z("SPC"))+Z(X),$P(Z("SAMT"),U,Z("SPC"))=$P(Z("SAMT"),U,Z("SPC"))+Z(X) G ST
;
Q
EN G:'$D(DA(1)) EX G:'$D(^PRCS(410,DA(1),0)) EX S Z=^(0) G:'+Z EX G:'$D(^(7)) EX S Z(7)=^(7),Z("SER")=$P(Z(7),U,6)
G:'$D(^PRCS(410,DA(1),12,0)) EX G:'$D(^PRCS(410,DA(1),12,DA,0)) EX S Z("SCP")=+^(0) G:'$D(^PRCS(410.4,Z("SCP"),0)) EX
S Z("QT")=$P(Z,"-",3) S:$D(CURQTR) Z("QT")=CURQTR
S Z("ST")=+Z,Z("CP")=+$P(Z,"-",4),Z("FY")=$P(Z,"-",2),Z("AMT")=X,Z("TT")=$P(Z,U,2),Z("SPC")=Z("QT")+1
;
S:'$D(^PRC(420,Z("ST"),1,Z("CP"),4,0)) ^(0)="^420.06A^^"
I '$D(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)) S ^(0)=Z("FY")_"^0^0^0^0^0^0^0^0",$P(^(0),U,3,4)=Z("FY")_U_($P(^PRC(420,Z("ST"),1,Z("CP"),4,0),U,4)+1),^PRC(420,Z("ST"),1,Z("CP"),4,"B",Z("FY"),Z("FY"))=""
S Z("CPB")=^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)
S:'$D(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1)) ^(1)="^0^0^0^0" S Z("SCPB")=^(1)
S:'$D(^PRCS(410.4,Z("SCP"),1,0)) ^(0)="^410.42A^^" I '$D(^PRCS(410.4,Z("SCP"),1,Z("FY"),0)) S ^(0)=Z("FY")_"^0^0^0^0",$P(^(0),U,3,4)=Z("FY")_U_($P(^PRC(420,Z("ST"),1,Z("CP"),4,0),U,4)+1)
S Z("SAMT")=^PRCS(410.4,Z("SCP"),1,Z("FY"),0)
Q
ST S ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)=Z("CPB"),^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1)=Z("SCPB"),^PRCS(410.4,Z("SCP"),1,Z("FY"),0)=Z("SAMT")
EX K Z Q
SCP Q:'$D(^PRCS(410,N1,12,0)) S N2="",X2=0
F PRCSJ=1:1 S N2=$O(^PRCS(410,N1,12,N2)) Q:N2'>0 Q:'$D(^(N2,0)) S X2=$P(^(0),U,2),PRC("SCP")=+^(0) D 1
EX1 K N2,X2,PRCSJ,PRC("SCP"),PRC("BSCPB"),PRC("SCPB") Q
1 S:'$D(^PRCS(410.4,PRC("SCP"),1,0)) ^(0)="^410.42A^^" S:'$D(^PRCS(410.4,PRC("SCP"),1,PRC("FY"),0)) ^(0)=PRC("FY")_"^0^0^0^0"
I T="A" S X=-X,Z=-Z
I T="O" S $P(PRC("SCPB"),U,PRC("SPC"))=$P(PRC("SCPB"),U,PRC("SPC"))-X2,$P(PRC("BSCPB"),U,Z("SPC"))=$P(PRC("BSCPB"),U,Z("SPC"))-X2
I T'="O" S $P(PRC("SCPB"),U,PRC("SPC"))=$P(PRC("SCPB"),U,PRC("SPC"))+X2,$P(PRC("BSCPB"),U,Z("SPC"))=$P(PRC("BSCPB"),U,Z("SPC"))+X2
S ^PRCS(410.4,PRC("SCP"),1,PRC("FY"),0)=PRC("SCPB"),^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),1)=PRC("BSCPB") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSEZZ 2495 printed Oct 16, 2024@18:18:31 Page 2
PRCSEZZ ;SF-ISC/LJP-NEW PRCSES - UPDATE SCP BALANCES ;4-3-94/15:55
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
TRANK if X']""
QUIT
SET Z(X)=-X
GOTO A
TRANS if X']""
QUIT
SET Z(X)=X
A DO EN
if '$DATA(Z)
QUIT
if Z("TT")=""
GOTO EX
+1 IF Z("TT")="A"
SET Z(X)=-Z(X)
+2 IF Z("TT")="O"
SET $PIECE(Z("SCPB"),U,Z("SPC"))=$PIECE(Z("SCPB"),U,Z("SPC"))-Z(X)
SET $PIECE(Z("SAMT"),U,Z("SPC"))=$PIECE(Z("SAMT"),U,Z("SPC"))-Z(X)
GOTO ST
+3 IF Z("TT")'="O"
SET $PIECE(Z("SCPB"),U,Z("SPC"))=$PIECE(Z("SCPB"),U,Z("SPC"))+Z(X)
SET $PIECE(Z("SAMT"),U,Z("SPC"))=$PIECE(Z("SAMT"),U,Z("SPC"))+Z(X)
GOTO ST
+4 ;
+5 QUIT
EN if '$DATA(DA(1))
GOTO EX
if '$DATA(^PRCS(410,DA(1),0))
GOTO EX
SET Z=^(0)
if '+Z
GOTO EX
if '$DATA(^(7))
GOTO EX
SET Z(7)=^(7)
SET Z("SER")=$PIECE(Z(7),U,6)
+1 if '$DATA(^PRCS(410,DA(1),12,0))
GOTO EX
if '$DATA(^PRCS(410,DA(1),12,DA,0))
GOTO EX
SET Z("SCP")=+^(0)
if '$DATA(^PRCS(410.4,Z("SCP"),0))
GOTO EX
+2 SET Z("QT")=$PIECE(Z,"-",3)
if $DATA(CURQTR)
SET Z("QT")=CURQTR
+3 SET Z("ST")=+Z
SET Z("CP")=+$PIECE(Z,"-",4)
SET Z("FY")=$PIECE(Z,"-",2)
SET Z("AMT")=X
SET Z("TT")=$PIECE(Z,U,2)
SET Z("SPC")=Z("QT")+1
+4 ;
+5 if '$DATA(^PRC(420,Z("ST"),1,Z("CP"),4,0))
SET ^(0)="^420.06A^^"
+6 IF '$DATA(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0))
SET ^(0)=Z("FY")_"^0^0^0^0^0^0^0^0"
SET $PIECE(^(0),U,3,4)=Z("FY")_U_($PIECE(^PRC(420,Z("ST"),1,Z("CP"),4,0),U,4)+1)
SET ^PRC(420,Z("ST"),1,Z("CP"),4,"B",Z("FY"),Z("FY"))=""
+7 SET Z("CPB")=^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)
+8 if '$DATA(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1))
SET ^(1)="^0^0^0^0"
SET Z("SCPB")=^(1)
+9 if '$DATA(^PRCS(410.4,Z("SCP"),1,0))
SET ^(0)="^410.42A^^"
IF '$DATA(^PRCS(410.4,Z("SCP"),1,Z("FY"),0))
SET ^(0)=Z("FY")_"^0^0^0^0"
SET $PIECE(^(0),U,3,4)=Z("FY")_U_($PIECE(^PRC(420,Z("ST"),1,Z("CP"),4,0),U,4)+1)
+10 SET Z("SAMT")=^PRCS(410.4,Z("SCP"),1,Z("FY"),0)
+11 QUIT
ST SET ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)=Z("CPB")
SET ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1)=Z("SCPB")
SET ^PRCS(410.4,Z("SCP"),1,Z("FY"),0)=Z("SAMT")
EX KILL Z
QUIT
SCP if '$DATA(^PRCS(410,N1,12,0))
QUIT
SET N2=""
SET X2=0
+1 FOR PRCSJ=1:1
SET N2=$ORDER(^PRCS(410,N1,12,N2))
if N2'>0
QUIT
if '$DATA(^(N2,0))
QUIT
SET X2=$PIECE(^(0),U,2)
SET PRC("SCP")=+^(0)
DO 1
EX1 KILL N2,X2,PRCSJ,PRC("SCP"),PRC("BSCPB"),PRC("SCPB")
QUIT
1 if '$DATA(^PRCS(410.4,PRC("SCP"),1,0))
SET ^(0)="^410.42A^^"
if '$DATA(^PRCS(410.4,PRC("SCP"),1,PRC("FY"),0))
SET ^(0)=PRC("FY")_"^0^0^0^0"
+1 IF T="A"
SET X=-X
SET Z=-Z
+2 IF T="O"
SET $PIECE(PRC("SCPB"),U,PRC("SPC"))=$PIECE(PRC("SCPB"),U,PRC("SPC"))-X2
SET $PIECE(PRC("BSCPB"),U,Z("SPC"))=$PIECE(PRC("BSCPB"),U,Z("SPC"))-X2
+3 IF T'="O"
SET $PIECE(PRC("SCPB"),U,PRC("SPC"))=$PIECE(PRC("SCPB"),U,PRC("SPC"))+X2
SET $PIECE(PRC("BSCPB"),U,Z("SPC"))=$PIECE(PRC("BSCPB"),U,Z("SPC"))+X2
+4 SET ^PRCS(410.4,PRC("SCP"),1,PRC("FY"),0)=PRC("SCPB")
SET ^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),1)=PRC("BSCPB")
QUIT
