source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRC5CON1.m@ 1800

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

initial load of WorldVistAEHR

File size: 3.7 KB
RevLine 
[613]1PRC5CON1 ;WISC/PLT-PRC5CON CONTINUE ; 08/22/95 3:18 PM
2V ;;5.0;IFCAP;**27**;4/21/95
3 ;QUIT ; invalid entry
4 ;
5EN ;start station merge/convert CALM code sheet to FMS
6 N PRCRI,PRCSITE,PRCYEAR,PRCYE,PRCQTR,PRCFCP,PRCDATE
7 N PRCA,PRCB,PRCC
8 S PRCYEAR=1996,PRCYE=96,PRCDATE=2950930
9 S PRCRI(420)=0 F S PRCRI(420)=$O(^PRC(420,PRCRI(420))) QUIT:'PRCRI(420) S PRCC="" D QUIT:PRCC=-1
10 . D EN^DDIOL("STATION # "_PRCRI(420)_" starts:")
11 . S PRCSITE=PRCRI(420)
12 . D @("AUTO"_PRCDD)
13 . QUIT
14 I PRCC=-1 W !! F I=1:1:4 W "ABORTED BY '^'! "
15 E W !! F I=1:1:5 W "ALL DONE! "
16 QUIT
17 ;
18 ;
19AUTO410 ;auto select file 410 for 1996
20 S PRCA=PRCSITE_"-"_PRCYE
21 S PRCB=PRCA F S PRCB=$O(^PRCS(410,"B",PRCB)) QUIT:PRCA-PRCB S PRCRI(410)=$O(^(PRCB,"")) D:PRCRI(410) 410 QUIT:PRCC=-1
22 QUIT
23 ;
24AUTO442 ;auto select file 442 for 1996
25 S PRCA=PRCDATE
26 S PRCB=PRCA F S PRCB=$O(^PRC(442,"AB",PRCB)) QUIT:'PRCB D QUIT:PRCC=-1
27 . 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
28 . QUIT
29 QUIT
30 ;
31410 ;display/edit substation
32 W ! D ;display
33 . N DIC,DA,DR,WIQ
34 . S DIC="^PRCS(410,",DA=PRCRI(410),DR="0;4;RM" D EN^DIQ
35 . QUIT
36 S PRC("SITE")=+^PRCS(410,PRCRI(410),0)
37 D EDIT^PRC0B(.X,"410;;"_PRCRI(410),"448","")
38 S PRCC=X
39 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-"))
40 QUIT
41 ;
42442 ;display/edit substation
43 W ! D ;display
44 . N DIC,DA,DR,WIQ
45 . S DIC="^PRC(442,",DA=PRCRI(442),DR="0;12;4" D EN^DIQ
46 . W " PURCHASE ORDER DATE: ",$E(PRCB,4,5),"/",$E(PRCB,6,7),"/",$E(PRCB,2,3)
47 . QUIT
48 S PRC("SITE")=+^PRC(442,PRCRI(442),0)
49 D EDIT^PRC0B(.X,"442;;"_PRCRI(442),"31","")
50 S PRCC=X
51 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-"))
52 QUIT
53 ;
54EN1 D @("MAN"_PRCDD)
55 QUIT
56 ;
57ACCRUE ;enter accrue for 1996 txn if method of processing is certified invoice
58 N PRCRI,PRCSITE,PRCYEAR,PRCYE,PRCQTR,PRCFCP,PRCDATE
59 N PRCA,PRCB,PRCC
60 S PRCYEAR=1996,PRCYE=96,PRCDATE=2950930
61 S PRCRI(420)=0 F S PRCRI(420)=$O(^PRC(420,PRCRI(420))) QUIT:'PRCRI(420) S PRCC="" D QUIT:PRCC=-1
62 . D EN^DDIOL("STATION # "_PRCRI(420)_" starts:")
63 . S PRCSITE=PRCRI(420)
64 . D ACC58 QUIT:PRCC=-1 D ACCPO
65 . QUIT
66 I PRCC=-1 W !! F I=1:1:4 W "ABORTED BY '^'! "
67 E W !! F I=1:1:5 W "ALL DONE! "
68 QUIT
69 ;
70ACC58 ;ACCURE FOR 1358
71 S PRCA=PRCSITE_"-"_PRCYE,PRCB=PRCA
72 F S PRCB=$O(^PRCS(410,"B",PRCB)) QUIT:PRCA-PRCB S PRCRI(410)=$O(^(PRCB,"")) I PRCRI(410) D QUIT:PRCC=-1
73 . N PRCB
74 . I $P(^PRCS(410,PRCRI(410),0),"^",4)=1,$P($G(^(4)),"^",10)]"" S PRCRI(442)=$P($G(^(10)),"^",3) I PRCRI(442) I $O(^PRC(442,PRCRI(442),10,0)) S PRCB=$P($G(^PRC(442,PRCRI(442),1)),"^",15) D ACC442
75 . QUIT
76 QUIT
77 ;
78 ;
79ACCPO S PRCA=PRCDATE
80 S PRCB=PRCA F S PRCB=$O(^PRC(442,"AB",PRCB)) QUIT:'PRCB D QUIT:PRCC=-1
81 . 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&($P(^(0),"^",2)=2)&($P($G(^(12)),"^",2)]"") ACC442 QUIT:PRCC=-1
82 . QUIT
83 QUIT
84 ;
85ACC442 ;enter accrue flag and ending contract date if certified
86 W ! D ;display
87 . N DIC,DA,DR,WIQ
88 . S DIC="^PRC(442,",DA=PRCRI(442),DR="0;12;4" D EN^DIQ
89 . W " PURCHASE ORDER DATE: " W:PRCB]"" $E(PRCB,4,5),"/",$E(PRCB,6,7),"/",$E(PRCB,2,3)
90 . QUIT
91 S PRC("SITE")=+^PRC(442,PRCRI(442),0)
92 D EDIT^PRC0B(.X,"442;;"_PRCRI(442),"30;29","")
93 S PRCC=X
94 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-"))
95 QUIT
96 ;
97MAN410 ;manual select 410 for 1996
98 S X("S")="I $P($G(^(0)),""-"",2)>95"
99 D LOOKUP^PRC0B(.X,.Y,"410","AEMOQS","Select 2237/1358 Request: ")
100 I X=""!(X["^") QUIT
101 I Y>0 S PRCRI(410)=+Y D 410
102 G MAN410
103 QUIT
104 ;
105MAN442 ;MANUAL SELECT 442 for 1996
106 S X("S")="I $P($G(^(1)),""^"",15)>2950930"
107 D LOOKUP^PRC0B(.X,.Y,"442","AEMOQS","Select Purchase Order: ")
108 I X=""!(X["^") QUIT
109 I Y>0 S PRCRI(442)=+Y,PRCB=$P($G(^PRC(442,PRCRI(442),1)),"^",15) D 442
110 G MAN442
111 ;
Note: See TracBrowser for help on using the repository browser.