source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCBCS.m@ 1046

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

initial load of WorldVistAEHR
File size: 5.5 KB
Line 
1PRCBCS ;WISC@ALTOONA/CTB-WIRMFO/REW-CREATE CODE SHEETS FROM RELEASED TRX ; [7/1/98 3:00pm]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N A,PRCF
5 K ^PRCF(421,"AN"),^TMP("PRCB",$J,"BCS"),^TMP("PRCB",$J,"TRDA"),^TMP("PRCB",$J,"CODE") S PRCF("X")="BQ" D ^PRCFSITE Q:'%
6 S X=PRC("QTR"),X(1)="This option will now generate FMS documents for "_X_$S(X=1:"st",X=2:"nd",X=3:"rd",1:"th")_" Quarter, FY "_PRC("FY")
7 S X(2)="released transactions which have not previously been coded."
8Q1 S Y(1)="Enter a date you want to send documents to FMS in format: MM/DD/YY"
9 S A=$$DT^PRC0B2("T","E"),A=$P(A,"^",5)
10 D DT^PRC0A(.X,.Y,"FMS Transaction Date","O",A)
11 QUIT:X["^"!(X="")
12 I Y#100=0 W " Enter precise date!" G Q1
13 S Y=$$DT^PRC0B2(Y,"I")
14 W " (",$P(Y,"^",5),")"
15 ;S A=$$DATE^PRC0C($P(Y,"^",5),"E")
16 ;I PRC("FY")'=$E(A,3,4)!(PRC("QTR")'=$P(A,"^",2)) D EN^DDIOL("The FMS Transaction Date should be in the entered fiscal year and quarter.") G Q1
17 S PRCF("TDATE")=+Y,PRCF("ACCTP")=$P($$DT^PRC0B2($E(Y,1,5)_"00","I"),"^",5)
18Q2 S Y(1)="Enter a calendar (not fiscal year) accounting period in format: MM/YY."
19 S Y(2)="NOTE: a closed FMS accounting period will cause documents to be rejected."
20 D DT^PRC0A(.X,.Y,"Accounting Period (MM/YY)","O",PRCF("ACCTP"))
21 I X=""!(X["^") G Q1
22 G Q2:Y<0
23 I Y#100'=0 W " Enter month/year only!" G Q2
24 S Y=$$DT^PRC0B2(Y,"I")
25 W " (",$P(Y,"^",5),")"
26 ;S A=$$DATE^PRC0C($P(Y,"^",5),"E")
27 ;I PRC("FY")'=$E(A,3,4)!(PRC("QTR")'=$P(A,"^",2)) D EN^DDIOL("The Accounting Period should be in the entered fiscal year and quarter.") G Q2
28 S PRCF("ACCTP")=$P(Y,"^",5),X=$$DATE^PRC0C(+Y,"I")
29 S PRCF("ACCTF")=$P(X,"^",9)_$E(X,3,4)_"^"_PRCF("ACCTP")
30Q9 D YN^PRC0A(.X,.Y,"Ready to generate FMS documents","O","YES")
31 QUIT:X["^"!(X="")
32 G:Y<1 Q1
33 ;S ZTDESC="CREATE BUDGET CODE SHEETS",ZTRTN="DQ^PRCBCS",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="",ZTSAVE("DUZ*")="" D ^PRCFQ
34 D DQ
35 K PRCF,PRCF("TDATE"),PRCFA Q
36 ;
37DQ I $D(ZTQUEUED) D:0 KILL^%ZTLOAD S ZTREQ="@" ; REW ? for Patch 97
38 ;D:$D(ZTQUEUED) KILL^%ZTLOAD ; original line
39 S X="BATCH/TRANSMIT" D LOCK^PRCFALCK Q:'%
40 K ^TMP("PRCB",$J,"BCS"),^TMP("PRCB",$J,"TRDA")
41 S DA=0 F I=1:1 S DA=$O(^PRCF(421,"AL",PRCF("SIFY"),2,DA)) Q:'DA D ADD
42 ;D DA=0:0 S DA=$O(^TMP("PRCB",$J,"TRDA",DA)) Q:'DA I $D(^PRCF(421,DA,0)) S $P(^(4),"^",PRC("QTR"))=1
43 ;K ^TMP("PRCB",$J,"TRDA")
44 S PRC("FYF")=0 F S PRC("FYF")=$O(^TMP("PRCB",$J,"BCS",PRC("SITE"),PRC("FYF"))) Q:'PRC("FYF") S AMT=+^(PRC("FYF")),X="",PRCFID="" D:AMT'=0 D EPRN
45 . N A,B
46 . S PRC("CP")=$P(PRC("FYF"),"~"),PRC("BBFY")=$P(PRC("FYF"),"~",2),PRC("CPT")=$P(PRC("FYF"),"~",3)
47 . S PRC("FC")=PRCF("TDATE")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_PRC("SITE")_"^"_PRC("CP")_"^"_AMT_"^"_PRC("BBFY")_"^"_PRC("CPT"),PRC("AMT")=AMT
48 . S $P(PRC("FC"),"^",9)=PRCF("ACCTF")
49 . I PRC("CPT")="" D SA^PRCB8A(.X,PRC("FC")) S PRCFID=$P(X,"^",2) QUIT
50 . S PRCA=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
51 . S PRCB=$$ACC^PRC0C(PRC("SITE"),PRC("CPT")_"^"_PRC("FY")_"^"_PRC("BBFY"))
52 . I $P(PRCA,"^",9)=$P(PRCB,"^",9)&($P(PRCA,"^",2)=$P(PRCB,"^",2)) D QUIT
53 .. S C=$$FMSACC^PRC0D(PRC("SITE"),PRCA),C=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_C_""",",0)
54 .. I 'C S $P(PRC("FC"),"^",6)=0 D SA^PRCB8A(.X,PRC("FC"))
55 .. S C=$$FMSACC^PRC0D(PRC("SITE"),PRCB),C=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_C_""",",0)
56 .. I 'C S $P(PRC("FC"),"^",6)=0 D SA^PRCB8A(.X,$P(PRC("FC"),"^",1,4)_"^"_PRC("CPT")_"^"_$P(PRC("FC"),"^",6,999))
57 .. S $P(PRC("FC"),"^",6)=-PRC("AMT") D ST^PRCB8A1(.X,PRC("FC")) S PRCFID=$P(X,"^",2)
58 .. QUIT
59 . D SA^PRCB8A(.X,PRC("FC"))
60 . S $P(PRC("FC"),"^",6)=-PRC("AMT") D AT^PRCB8A2(.X,PRC("FC"))
61 . S PRCFID=$P(X,"^",2),$P(PRC("FC"),"^",5)=PRC("CPT") D SA^PRCB8A(.X,PRC("FC"))
62 . QUIT
63 ;
64 ;
65 ;S FR="",TO="",IOP=ION,DIC="^PRCF(421,",L=0,BY=$S($G(PRC("PRCOLD")):"[PRCB GENERATE CODE SHEETS]",1:".6,1,.01")
66 K IOP S (FR,TO)="",DIC="^PRCF(421,",L=0,BY="+1;S2,.01"
67 S FLDS=".01,1,6,&"_(PRC("QTR")+6),BY(0)="^PRCF(421,""AN"",",L(0)=2
68 ; REW <<<<<<< This code eliminate uses of BY-with-a-template with BY(0) per Forum msg 19270200
69 ;S (FR,TO)=1,IOP=ION,DIC="^PRCF(421,",L=0,BY="NUMBER",FLDS=".01"
70DIP ;S:$G(^PRCHREW) ^PRCHREW($H,1)=$G(ZTQUEUED)_U_$J
71 D EN1^DIP
72 ;S:$G(^PRCHREW) ^PRCHREW($H,2)=$G(ZTSTAT) ; Documenting call to and return from DIP
73 ;
74 ;
75BACK K ^TMP("PRCB",$J,"BCS") S X="BATCH/TRANSMIT" D UNLOCK^PRCFALCK
76 ;S:$G(^PRCHREW) ^PRCHREW($H,3)="" ; <<<<< REW Documenting return from UNLOCK
77 QUIT
78 ;
79ERR W !,"Unable to create code sheet for Station: "_PRC("SITE")_", Control Point: "_PRC("CP")_", FY: "_PRC("FY"),", Quarter: "_PRC("QTR")_"." Q
80 ;
81EPRN ;set printing flag/FMS id in file 410
82 N A,B,C
83 S A="" F S A=$O(^TMP("PRCB",$J,"BCS",PRC("SITE"),PRC("FYF"),A)) Q:'A D
84 . F C=1,2 S B=$P(A,"~",C) I B,$D(^PRCF(421,B,0)) S $P(^(4),"^",PRC("QTR"))=1,D=$P(^(4),"^",6+PRC("QTR")) S:D $P(^PRCS(410,D,4),"^",5)=PRCFID
85 . QUIT
86 QUIT
87 ;
88ADD ;ADD AMOUNT INTO SCRATCH GLOBAL
89 N A
90 QUIT:'$D(^PRCF(421,DA,0)) S X=^(0) QUIT:'$P(X,"^",23)!+$P($G(^(4)),U,PRC("QTR"))
91 I +$P(X,U,PRC("QTR")+6)'=0,$P(X,U,20)=2,$P(^PRC(420,PRC("SITE"),1,+$P(X,U,2),0),U,12)<3 D S ^PRCF(421,"AN",1,DA)="",$P(^PRCF(421,DA,0),"^",19)=1
92 . ;S ^TMP("PRCB",$J,"TRDA",DA)=""
93 . S Y=+$P(X,"^",2)_"~"_$P($$DATE^PRC0C($P(X,"^",23),"I"),"^",3),AMT=$P(X,"^",PRC("QTR")+6)
94 . I $P(X,"^",22) QUIT:AMT>0 S $P(Y,"~",3)=+$P($G(^PRCF(421,$P(X,"^",22),0)),"^",2)
95 . S:'$D(^TMP("PRCB",$J,"BCS",PRC("SITE"),Y)) ^(Y)=0
96 . S ^TMP("PRCB",$J,"BCS",PRC("SITE"),Y)=^TMP("PRCB",$J,"BCS",PRC("SITE"),Y)+$P(X,"^",PRC("QTR")+6)
97 . S ^TMP("PRCB",$J,"BCS",PRC("SITE"),Y,DA_"~"_$P(X,"^",22))=""
98 . QUIT
99 QUIT
Note: See TracBrowser for help on using the repository browser.