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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP1D 4186 printed Sep 23, 2025@19:54:14 Page 2
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
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
ONECP ; RECAL one fcp
+1 NEW PRCSST
+2 SET PRCSST=1
DO EN1^PRCSUT
if Y<0
QUIT
+3 DO YN^PRC0A(.X,.Y,"Submit RECALCULATE CONTROL POINT BALANCES to the TASK MANAGER","O","YES")
+4 if X["^"!(X="")!(Y<0)
QUIT
+5 NEW PRCDUZ
+6 SET PRCDUZ=DUZ
+7 IF Y=0
DO ENCP
QUIT
+8 SET A=$$TASK^PRC0B2("ENCP^PRCSP1D~RECALCULATE CONTROL POINT BALANCES","PRCDUZ~PRC*",1)
+9 IF A
DO EN^DDIOL("RECALCULATE CONTROL POINT BALANCES HAS TASK NUMBER "_$PIECE(A,"^"))
+10 QUIT
+11 ;
ENCP SET PRC("CP")=$PIECE(PRC("CP")," ")
SET N0=PRC("SITE")_"-"_PRC("FY")
+1 NEW TEMP
if $DATA(PRC("QTR"))
SET TEMP=PRC("QTR")
+2 DO CPOBAL
+3 if $DATA(TEMP)
SET PRC("QTR")=TEMP
if '$DATA(ZTQUEUED)
WRITE " DONE",$CHAR(7)
+4 if $DATA(ZTQUEUED)
DO MM^PRCBRCP(PRC("SITE")_"-"_$PIECE(PRC("CP")," "))
+5 KILL Y
QUIT
CPOBAL ;CALCULATE CPO BALANCES AND ENTER IN FCP FILE
+1 ;S N=N0_"-"_PRC("QTR")_"-"_PRC("CP"),X=0,Z=0,N1=""
+2 ;S PRC("BCPB")=^(1),$P(PRC("BCPB"),U,PRC("QTR")+1)=0
if '$DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,0))
SET ^(0)="^420.06A^0^0"
if '$DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),1))
SET ^(1)="^0^0^0^0"
+3 IF '$DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0))
SET ^(0)=PRC("FY")_"^^^^^^^^"
SET $PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,0),U,3)=PRC("FY")
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
SET ^PRC(420,PRC("SITE"),1,+PRC("CP"),4,"B",PRC("FY"),PRC("FY"))=""
+4 SET N=$$FCP^PRCB0B(PRC("SITE"),PRC("CP"),PRC("FY"),PRC("QTR"))
+5 SET X=+N
SET Z=$PIECE(N,"^",2)
+6 ;S N=$$PO^PRCB0B(PRC("SITE"),PRC("CP"),PRC("FY"),PRC("QTR"))
+7 ;S X=X+N,Z=Z+$P(N,"^",2)
+8 SET N=$$REC^PRCB0B(PRC("SITE"),+PRC("CP"),PRC("FY"),PRC("QTR"))
+9 SET X=X+N
SET Z=Z+$PIECE(N,"^",2)
+10 DO ICLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",1,"_(+PRC("CP"))_",")
+11 SET $PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0),U,(PRC("QTR")+1))=X
SET $PIECE(^(0),U,(PRC("QTR")+5))=Z
KILL N,N1,PRCSI,T,X,X1,Y,Z,Z1
+12 DO DCLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",1,"_(+PRC("CP"))_",")
+13 QUIT
+14 ;
BAL IF $PIECE(^PRCS(410,N1,0),U,4)=1
IF T="A"
if '$DATA(^(7))
SET ^(7)=""
SET X=X+$SELECT($PIECE(^(7),U,6)]"":-X1,1:0)
SET Z=Z+$SELECT($PIECE(^(4),U,10)]"":-Z1,1:0)
GOTO BAL1
+1 if T="O"!(T="A")
SET X1=-X1
SET Z1=-Z1
SET X=X+X1
SET Z=Z+Z1
BAL1 DO SCP^PRCSEZZ
+1 QUIT
SBAL ;1358 SERVICE BALANCE
+1 DO EN3^PRCSUT
if '$DATA(PRC("SITE"))!(Y<0)
GOTO EXIT
SET DIC="^PRC(442,"
SET DIC(0)="AEQM"
SET DIC("A")="Select PURCHASE ORDER NUMBER: "
+2 SET 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"
DO ^DIC
+3 if Y<0
GOTO EX
WRITE !?5,"Service's Actual 1358 Balance: ",$JUSTIFY($SELECT($DATA(^PRC(442,+Y,8)):+^(8),1:0),9,2)
EX KILL DIC,Y,PRCSZ
QUIT
RBAL ;RECALC 1358 BALANCE
+1 DO EN3^PRCSUT
if '$DATA(PRC("SITE"))!(Y<0)
GOTO EXIT
SET DIC="^PRC(442,"
SET DIC(0)="AEQM"
SET DIC("A")="Select PURCHASE ORDER NUMBER: "
+2 SET 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"
DO ^DIC
if Y<0
QUIT
SET PRCSPN=+Y
+3 SET (PRCSOB,PRCSOBT,PRCSAT,PRCSATT,PRCSLQ,PRCSLQT,PRCSES,PRCSEST,PRCSAJ,PRCSAJT)=0
+4 SET PRCSDN=0
FOR J=0:0
SET PRCSDN=$ORDER(^PRC(424,"AD",PRCSPN,PRCSDN))
if PRCSDN'>0
QUIT
DO LP
+5 SET PRCSESB=PRCSOBT-(PRCSEST+PRCSAJT)
SET PRCSATB=PRCSOBT-PRCSATT
SET PRCSOBB=PRCSOBT-PRCSLQT
+6 WRITE !?3,"Est Bal: ",PRCSESB,!?3,"Act Bal: ",PRCSATB,!?3,"Fis Bal: ",PRCSOBB
+7 SET ^PRC(442,PRCSPN,8)=PRCSATB_"^"_PRCSOBB_"^"_PRCSESB
+8 KILL DIC,PRCSOB,PRCSOBB,PRCSOBT,PRCSAT,PRCSATB,PRCSATT,PRCSLQ,PRCSLQT,PRCSES,PRCSESB,PRCSEST,PRCSAJ,PRCSAJT,PRCSDN,PRCSPN,PRCSREC,PRCSZ
QUIT
LP if '$DATA(^PRC(424,PRCSDN,0))
QUIT
SET PRCSREC=^(0)
SET PRCSOB=$PIECE(PRCSREC,U,5)
SET PRCSAT=$PIECE(PRCSREC,U,8)
SET PRCSLQ=$PIECE(PRCSREC,U,9)
SET PRCSES=$PIECE(PRCSREC,U,10)
SET PRCSAJ=$PIECE(PRCSREC,U,11)
+1 SET PRCSOBT=PRCSOBT+PRCSOB
SET PRCSATT=PRCSATT+PRCSAT
SET PRCSLQT=PRCSLQT+PRCSLQ
SET PRCSEST=PRCSEST+PRCSES
SET PRCSAJT=PRCSAJT+PRCSAJ
+2 QUIT
TOR ;TYPE OF REQUEST REPORT
+1 DO EN1^PRCSUT
if Y<0
GOTO EXIT
SET PRCSAZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+2 ;
SET L=0
SET DIC="^PRCS(410,"
SET FLDS="[PRCSTOR]"
SET DHD="CLASSIFICATION OF REQUEST REPORT - "_PRC("CP")
SET BY="+8,@.01"
SET FR="?,"_PRCSAZ_"-0001"
SET TO="?,"_PRCSAZ_"-9999"
DO EN1^DIP
KILL BY,DIC,FR,TO,PRCSAZ
QUIT
W2 WRITE !!,"Enter information for another report or an uparrow to return to the menu.",!
QUIT
+1 IF (IO'=IO(0))!($DATA(ZTQUEUED))
DO ^%ZISC
EXIT KILL %,BY,DA,D0,DHD,DIC,FLDS,FR,H1,H2,I,IO("Q"),J,L,N,N1,N2,P,PRCSED,PRCSSD,TO,Y,ZTRTN,ZTSAVE
QUIT
