source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP1D.m@ 1156

PRCSP1D ;WISC/SAW/TKW-CPA REPORTS CON'T & RECALCULATE CP BALANCES IN FILE 420 ;12/1/94  9:07 AM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
ONECP ; RECAL one fcp
 N PRCSST
 S PRCSST=1 D EN1^PRCSUT Q:Y<0
 D YN^PRC0A(.X,.Y,"Submit RECALCULATE CONTROL POINT BALANCES to the TASK MANAGER","O","YES")
 QUIT:X["^"!(X="")!(Y<0)
 N PRCDUZ
 S PRCDUZ=DUZ
 I Y=0 D ENCP QUIT
 S A=$$TASK^PRC0B2("ENCP^PRCSP1D~RECALCULATE CONTROL POINT BALANCES","PRCDUZ~PRC*",1)
 I A D EN^DDIOL("RECALCULATE CONTROL POINT BALANCES HAS TASK NUMBER "_$P(A,"^"))
 QUIT
 ;
ENCP S PRC("CP")=$P(PRC("CP")," "),N0=PRC("SITE")_"-"_PRC("FY")
 N TEMP S:$D(PRC("QTR")) TEMP=PRC("QTR")
 D CPOBAL
 S:$D(TEMP) PRC("QTR")=TEMP W:'$D(ZTQUEUED) "  DONE",$C(7)
 D:$D(ZTQUEUED) MM^PRCBRCP(PRC("SITE")_"-"_$P(PRC("CP")," "))
 K Y QUIT
CPOBAL ;CALCULATE CPO BALANCES AND ENTER IN FCP FILE
 ;S N=N0_"-"_PRC("QTR")_"-"_PRC("CP"),X=0,Z=0,N1=""
 S:'$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,0)) ^(0)="^420.06A^0^0" S:'$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),1)) ^(1)="^0^0^0^0" ;S PRC("BCPB")=^(1),$P(PRC("BCPB"),U,PRC("QTR")+1)=0
 I '$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)) S ^(0)=PRC("FY")_"^^^^^^^^",$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,0),U,3)=PRC("FY"),$P(^(0),U,4)=$P(^(0),U,4)+1,^PRC(420,PRC("SITE"),1,+PRC("CP"),4,"B",PRC("FY"),PRC("FY"))=""
 S N=$$FCP^PRCB0B(PRC("SITE"),PRC("CP"),PRC("FY"),PRC("QTR"))
 S X=+N,Z=$P(N,"^",2)
 ;S N=$$PO^PRCB0B(PRC("SITE"),PRC("CP"),PRC("FY"),PRC("QTR"))
 ;S X=X+N,Z=Z+$P(N,"^",2)
 S N=$$REC^PRCB0B(PRC("SITE"),+PRC("CP"),PRC("FY"),PRC("QTR"))
 S X=X+N,Z=Z+$P(N,"^",2)
 D ICLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",1,"_(+PRC("CP"))_",")
 S $P(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0),U,(PRC("QTR")+1))=X,$P(^(0),U,(PRC("QTR")+5))=Z K N,N1,PRCSI,T,X,X1,Y,Z,Z1
 D DCLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",1,"_(+PRC("CP"))_",")
 QUIT
 ;
BAL I $P(^PRCS(410,N1,0),U,4)=1,T="A" S:'$D(^(7)) ^(7)="" S X=X+$S($P(^(7),U,6)]"":-X1,1:0),Z=Z+$S($P(^(4),U,10)]"":-Z1,1:0) G BAL1
 S:T="O"!(T="A") X1=-X1,Z1=-Z1 S X=X+X1,Z=Z+Z1
BAL1 D SCP^PRCSEZZ
 Q
SBAL ;1358 SERVICE BALANCE
 D EN3^PRCSUT G EXIT:'$D(PRC("SITE"))!(Y<0) S DIC="^PRC(442,",DIC(0)="AEQM",DIC("A")="Select PURCHASE ORDER NUMBER: "
 S DIC("S")="S PRCSZ=^(0) I +PRCSZ=PRC(""SITE""),+$P(PRCSZ,U,3)=+PRC(""CP""),$D(^PRCS(410,+$P(^(0),U,12),0)),$P(^(0),U,4)=1" D ^DIC
 G:Y<0 EX W !?5,"Service's Actual 1358 Balance: ",$J($S($D(^PRC(442,+Y,8)):+^(8),1:0),9,2)
EX K DIC,Y,PRCSZ Q
RBAL ;RECALC 1358 BALANCE
 D EN3^PRCSUT G EXIT:'$D(PRC("SITE"))!(Y<0) S DIC="^PRC(442,",DIC(0)="AEQM",DIC("A")="Select PURCHASE ORDER NUMBER: "
 S DIC("S")="S PRCSZ=^(0) I +PRCSZ=PRC(""SITE""),+$P(PRCSZ,U,3)=+PRC(""CP""),$D(^PRCS(410,+$P(^(0),U,12),0)),$P(^(0),U,4)=1" D ^DIC Q:Y<0  S PRCSPN=+Y
 S (PRCSOB,PRCSOBT,PRCSAT,PRCSATT,PRCSLQ,PRCSLQT,PRCSES,PRCSEST,PRCSAJ,PRCSAJT)=0
 S PRCSDN=0 F J=0:0 S PRCSDN=$O(^PRC(424,"AD",PRCSPN,PRCSDN)) Q:PRCSDN'>0  D LP
 S PRCSESB=PRCSOBT-(PRCSEST+PRCSAJT),PRCSATB=PRCSOBT-PRCSATT,PRCSOBB=PRCSOBT-PRCSLQT
 W !?3,"Est Bal: ",PRCSESB,!?3,"Act Bal: ",PRCSATB,!?3,"Fis Bal: ",PRCSOBB
 S ^PRC(442,PRCSPN,8)=PRCSATB_"^"_PRCSOBB_"^"_PRCSESB
 K DIC,PRCSOB,PRCSOBB,PRCSOBT,PRCSAT,PRCSATB,PRCSATT,PRCSLQ,PRCSLQT,PRCSES,PRCSESB,PRCSEST,PRCSAJ,PRCSAJT,PRCSDN,PRCSPN,PRCSREC,PRCSZ Q
LP Q:'$D(^PRC(424,PRCSDN,0))  S PRCSREC=^(0),PRCSOB=$P(PRCSREC,U,5),PRCSAT=$P(PRCSREC,U,8),PRCSLQ=$P(PRCSREC,U,9),PRCSES=$P(PRCSREC,U,10),PRCSAJ=$P(PRCSREC,U,11)
 S PRCSOBT=PRCSOBT+PRCSOB,PRCSATT=PRCSATT+PRCSAT,PRCSLQT=PRCSLQT+PRCSLQ,PRCSEST=PRCSEST+PRCSES,PRCSAJT=PRCSAJT+PRCSAJ
 Q
TOR ;TYPE OF REQUEST REPORT
 D EN1^PRCSUT G EXIT:Y<0 S PRCSAZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
 S L=0,DIC="^PRCS(410,",FLDS="[PRCSTOR]",DHD="CLASSIFICATION OF REQUEST REPORT - "_PRC("CP"),BY="+8,@.01",FR="?,"_PRCSAZ_"-0001",TO="?,"_PRCSAZ_"-9999" D EN1^DIP K BY,DIC,FR,TO,PRCSAZ Q  ;
W2 W !!,"Enter information for another report or an uparrow to return to the menu.",! Q
 I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC
EXIT K %,BY,DA,D0,DHD,DIC,FLDS,FR,H1,H2,I,IO("Q"),J,L,N,N1,N2,P,PRCSED,PRCSSD,TO,Y,ZTRTN,ZTSAVE Q