source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSEZZ.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.4 KB
RevLine 
[613]1PRCSEZZ ;SF-ISC/LJP-NEW PRCSES - UPDATE SCP BALANCES ;4-3-94/15:55
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4TRANK Q:X']"" S Z(X)=-X G A
5TRANS Q:X']"" S Z(X)=X
6A 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
12EN 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
24ST 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")
25EX K Z Q
26SCP 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
28EX1 K N2,X2,PRCSJ,PRC("SCP"),PRC("BSCPB"),PRC("SCPB") Q
291 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
Note: See TracBrowser for help on using the repository browser.