source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP1D.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1PRCSP1D ;WISC/SAW/TKW-CPA REPORTS CON'T & RECALCULATE CP BALANCES IN FILE 420 ;12/1/94 9:07 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5ONECP ; RECAL one fcp
6 N PRCSST
7 S PRCSST=1 D EN1^PRCSUT Q:Y<0
8 D YN^PRC0A(.X,.Y,"Submit RECALCULATE CONTROL POINT BALANCES to the TASK MANAGER","O","YES")
9 QUIT:X["^"!(X="")!(Y<0)
10 N PRCDUZ
11 S PRCDUZ=DUZ
12 I Y=0 D ENCP QUIT
13 S A=$$TASK^PRC0B2("ENCP^PRCSP1D~RECALCULATE CONTROL POINT BALANCES","PRCDUZ~PRC*",1)
14 I A D EN^DDIOL("RECALCULATE CONTROL POINT BALANCES HAS TASK NUMBER "_$P(A,"^"))
15 QUIT
16 ;
17ENCP S PRC("CP")=$P(PRC("CP")," "),N0=PRC("SITE")_"-"_PRC("FY")
18 N TEMP S:$D(PRC("QTR")) TEMP=PRC("QTR")
19 D CPOBAL
20 S:$D(TEMP) PRC("QTR")=TEMP W:'$D(ZTQUEUED) " DONE",$C(7)
21 D:$D(ZTQUEUED) MM^PRCBRCP(PRC("SITE")_"-"_$P(PRC("CP")," "))
22 K Y QUIT
23CPOBAL ;CALCULATE CPO BALANCES AND ENTER IN FCP FILE
24 ;S N=N0_"-"_PRC("QTR")_"-"_PRC("CP"),X=0,Z=0,N1=""
25 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
26 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"))=""
27 S N=$$FCP^PRCB0B(PRC("SITE"),PRC("CP"),PRC("FY"),PRC("QTR"))
28 S X=+N,Z=$P(N,"^",2)
29 ;S N=$$PO^PRCB0B(PRC("SITE"),PRC("CP"),PRC("FY"),PRC("QTR"))
30 ;S X=X+N,Z=Z+$P(N,"^",2)
31 S N=$$REC^PRCB0B(PRC("SITE"),+PRC("CP"),PRC("FY"),PRC("QTR"))
32 S X=X+N,Z=Z+$P(N,"^",2)
33 D ICLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",1,"_(+PRC("CP"))_",")
34 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
35 D DCLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",1,"_(+PRC("CP"))_",")
36 QUIT
37 ;
38BAL 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
39 S:T="O"!(T="A") X1=-X1,Z1=-Z1 S X=X+X1,Z=Z+Z1
40BAL1 D SCP^PRCSEZZ
41 Q
42SBAL ;1358 SERVICE BALANCE
43 D EN3^PRCSUT G EXIT:'$D(PRC("SITE"))!(Y<0) S DIC="^PRC(442,",DIC(0)="AEQM",DIC("A")="Select PURCHASE ORDER NUMBER: "
44 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
45 G:Y<0 EX W !?5,"Service's Actual 1358 Balance: ",$J($S($D(^PRC(442,+Y,8)):+^(8),1:0),9,2)
46EX K DIC,Y,PRCSZ Q
47RBAL ;RECALC 1358 BALANCE
48 D EN3^PRCSUT G EXIT:'$D(PRC("SITE"))!(Y<0) S DIC="^PRC(442,",DIC(0)="AEQM",DIC("A")="Select PURCHASE ORDER NUMBER: "
49 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
50 S (PRCSOB,PRCSOBT,PRCSAT,PRCSATT,PRCSLQ,PRCSLQT,PRCSES,PRCSEST,PRCSAJ,PRCSAJT)=0
51 S PRCSDN=0 F J=0:0 S PRCSDN=$O(^PRC(424,"AD",PRCSPN,PRCSDN)) Q:PRCSDN'>0 D LP
52 S PRCSESB=PRCSOBT-(PRCSEST+PRCSAJT),PRCSATB=PRCSOBT-PRCSATT,PRCSOBB=PRCSOBT-PRCSLQT
53 W !?3,"Est Bal: ",PRCSESB,!?3,"Act Bal: ",PRCSATB,!?3,"Fis Bal: ",PRCSOBB
54 S ^PRC(442,PRCSPN,8)=PRCSATB_"^"_PRCSOBB_"^"_PRCSESB
55 K DIC,PRCSOB,PRCSOBB,PRCSOBT,PRCSAT,PRCSATB,PRCSATT,PRCSLQ,PRCSLQT,PRCSES,PRCSESB,PRCSEST,PRCSAJ,PRCSAJT,PRCSDN,PRCSPN,PRCSREC,PRCSZ Q
56LP 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)
57 S PRCSOBT=PRCSOBT+PRCSOB,PRCSATT=PRCSATT+PRCSAT,PRCSLQT=PRCSLQT+PRCSLQ,PRCSEST=PRCSEST+PRCSES,PRCSAJT=PRCSAJT+PRCSAJ
58 Q
59TOR ;TYPE OF REQUEST REPORT
60 D EN1^PRCSUT G EXIT:Y<0 S PRCSAZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
61 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 ;
62W2 W !!,"Enter information for another report or an uparrow to return to the menu.",! Q
63 I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC
64EXIT 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
Note: See TracBrowser for help on using the repository browser.