| 1 | PRCSEZZ ;SF-ISC/LJP-NEW PRCSES - UPDATE SCP BALANCES ;4-3-94/15:55
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | TRANK Q:X']"" S Z(X)=-X G A
|
|---|
| 5 | TRANS Q:X']"" S Z(X)=X
|
|---|
| 6 | A D EN Q:'$D(Z) G:Z("TT")="" EX
|
|---|
| 7 | I Z("TT")="A" S Z(X)=-Z(X)
|
|---|
| 8 | 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
|
|---|
| 9 | 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
|
|---|
| 10 | ;
|
|---|
| 11 | Q
|
|---|
| 12 | 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)
|
|---|
| 13 | 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
|
|---|
| 14 | S Z("QT")=$P(Z,"-",3) S:$D(CURQTR) Z("QT")=CURQTR
|
|---|
| 15 | 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
|
|---|
| 16 | ;
|
|---|
| 17 | S:'$D(^PRC(420,Z("ST"),1,Z("CP"),4,0)) ^(0)="^420.06A^^"
|
|---|
| 18 | 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"))=""
|
|---|
| 19 | S Z("CPB")=^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)
|
|---|
| 20 | S:'$D(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1)) ^(1)="^0^0^0^0" S Z("SCPB")=^(1)
|
|---|
| 21 | 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)
|
|---|
| 22 | S Z("SAMT")=^PRCS(410.4,Z("SCP"),1,Z("FY"),0)
|
|---|
| 23 | Q
|
|---|
| 24 | 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")
|
|---|
| 25 | EX K Z Q
|
|---|
| 26 | SCP Q:'$D(^PRCS(410,N1,12,0)) S N2="",X2=0
|
|---|
| 27 | 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
|
|---|
| 28 | EX1 K N2,X2,PRCSJ,PRC("SCP"),PRC("BSCPB"),PRC("SCPB") Q
|
|---|
| 29 | 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"
|
|---|
| 30 | I T="A" S X=-X,Z=-Z
|
|---|
| 31 | 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
|
|---|
| 32 | 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
|
|---|
| 33 | 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
|
|---|
