source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCX1P1.m@ 861

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

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1PRCX1P1 ;WISC/PLT-FIX FILE 442 BBFY AND APPROPRIATION ; 10/17/95 3:10 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;QUIT ; invalid entry
5 ;
6EN ;start fix file 410/442
7 N PRCRI,PRCSITE,PRCYEAR,PRCYE,PRCQTR,PRCFCP,PRCDATE
8 N PRCA,PRCB,PRCC
9 S PRCYEAR=1996,PRCYE=96,PRCDATE=2950630
10 S PRCRI(420)=0 F S PRCRI(420)=$O(^PRC(420,PRCRI(420))) QUIT:'PRCRI(420) S PRCC="" D QUIT:PRCC=-1
11 . D EN^DDIOL("STATION # "_PRCRI(420)_" starts:")
12 . S PRCSITE=PRCRI(420)
13 . D @("AUTO"_PRCDD)
14 . QUIT
15 QUIT
16 ;
17 ;
18AUTO410 ;auto select file 410 for 1996
19 S PRCA=PRCSITE_"-"_PRCYE
20 S PRCB=PRCA F S PRCB=$O(^PRCS(410,"B",PRCB)) QUIT:PRCA-PRCB S PRCRI(410)=$O(^(PRCB,"")) D:PRCRI(410)
21 . N A,B,C,D,PRC,PRCX,PRCACC,PRCBBFY
22 . S PRC=$G(^PRCS(410,PRCRI(410),3)),PRCX=$G(^(0))
23 . S A=$$BBFY^PRCSUT($P(PRCX,"-"),$P(PRCX,"-",2),$P(PRCX,"-",4),1)
24 . S PRCACC=$$ACC^PRC0C($P(PRCX,"-"),$P(PRCX,"-",4)_"^"_$P(PRCX,"-",2)_"^"_A)
25 . S PRCBBFY=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
26 . S:$P(PRC,"^",11)'=PRCBBFY $P(PRC,"^",11)=PRCBBFY
27 . S:$P(PRC,"^",2)'=$P(PRCACC,"^",11) $P(PRC,"^",2)=$P(PRCACC,"^",11)
28 . S:$P(PRC,"^",12)'=$P(PRCACC,"^",3) $P(PRC,"^",12)=$P(PRCACC,"^",3)
29 . ;W !,"***",$P(PRCX,"^"),!,"***",$G(^PRCS(410,PRCRI(410),3)),!,"***",PRC
30 . I $G(^PRCS(410,PRCRI(410),3))'=PRC W !,$P(PRCX,"^"),!,"OLD: ",$G(^(3)),!,"NEW: ",PRC S ^(3)=PRC
31 . QUIT
32 QUIT
33 ;
34AUTO442 ;auto select file 442 for 1996
35 S PRCA=PRCDATE
36 S PRCB=PRCA F S PRCB=$O(^PRC(442,"AB",PRCB)) QUIT:'PRCB D QUIT:PRCC=-1
37 . S PRCRI(442)=0 F S PRCRI(442)=$O(^PRC(442,"AB",PRCB,PRCRI(442))) QUIT:'PRCRI(442) D:^PRC(442,PRCRI(442),0)-PRCSITE=0 442 QUIT:PRCC=-1
38 . QUIT
39 QUIT
40 ;
41410 ;display/edit substation
42 W ! D ;display
43 . N DIC,DA,DR,WIQ
44 . S DIC="^PRCS(410,",DA=PRCRI(410),DR="0;3;4;RM" D EN^DIQ
45 . QUIT
46 S PRC("SITE")=+^PRCS(410,PRCRI(410),0)
47 D EDIT^PRC0B(.X,"410;;"_PRCRI(410),"28.5;28;28.1","")
48 S PRCC=X
49 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-"))
50 QUIT
51 ;
52442 ;display/edit substation
53 W ! D ;display
54 . N DIC,DA,DR,WIQ
55 . S DIC="^PRC(442,",DA=PRCRI(442),DR="0;12;4" D EN^DIQ
56 . W " PURCHASE ORDER DATE: ",$E(PRCB,4,5),"/",$E(PRCB,6,7),"/",$E(PRCB,2,3)
57 . QUIT
58 S PRC("SITE")=+^PRC(442,PRCRI(442),0)
59 D EDIT^PRC0B(.X,"442;;"_PRCRI(442),"26;1.4","")
60 S PRCC=X
61 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-"))
62 QUIT
63 ;
64EN1 D @("MAN"_PRCDD)
65 QUIT
66 ;
67 ;
68 ;
69 ;
70MAN410 ;manual select 410 for 1996
71 S X("S")="I $P($G(^(0)),""-"",2)>95"
72 D LOOKUP^PRC0B(.X,.Y,"410","AEMOQS","Select 2237/1358 Request: ")
73 I X=""!(X["^") QUIT
74 I Y>0 S PRCRI(410)=+Y D 410
75 G MAN410
76 QUIT
77 ;
78MAN442 ;MANUAL SELECT 442 for 1996
79 S X("S")="I $P($G(^(1)),""^"",15)>2950630"
80 D LOOKUP^PRC0B(.X,.Y,"442","AEMOQS","Select Purchase Order: ")
81 I X=""!(X["^") QUIT
82 I Y>0 S PRCRI(442)=+Y,PRCB=$P($G(^PRC(442,PRCRI(442),1)),"^",15) D 442
83 G MAN442
84 ;
85GECS ;rebuild rejected mo/so doc for obligation after 9/30/95
86 N PRCRI,PRCA,PRCB,PRCA
87 S PRCRI(2100.1)=0 F S PRCRI(2100.1)=$O(^GECS(2100.1,"AS","R",PRCRI(2100.1))) QUIT:'PRCRI(2100.1) D GECS1:$G(^GECS(2100.1,PRCRI(2100.1),0))?1"MO".E!($G(^(0))?1"SO".E)
88 W !,"ALL DONE! ALL DONE!"
89 QUIT
90 ;
91GECS1 ;rebuild mo/so record
92 N PRCA,PRCB,PRC
93 N A,B,C
94 S A=^GECS(2100.1,PRCRI(2100.1),0),B=$G(^(26))
95 QUIT
Note: See TracBrowser for help on using the repository browser.