source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCS0B.m@ 1141

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1PRCS0B ;WISC/PLT-UTILITY FOR PRCS-ROUTINE ; 12/19/94 1:53 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 ;
6 ;PRCA data ^1=buyer station #, ^2=seller station #
7 ;PRCB data ^1=buyer fcp #, ^2=seller fcp #
8 ;PRCC= file 410 ri of buyer's issue book request
9 ;PRCD data ^1=buyer's price, ^2=seller's price
10IB(PRCA,PRCB,PRCC,PRCD) ;post buyer's issue book request
11 N PRC,PRCRI,PRCE,PRCF,PRCG,PRCH,PRCIS
12 N A,B,C
13 QUIT:$D(^PRCS(410,PRCC,0))#10=0 S PRCE=^(0),PRCRI("410A")=$P($G(^(445)),"^",4)
14 S PRCRI(410)=PRCC,A=$P(PRCE,"^"),PRCG=A
15 S PRC("SITE")=$P(A,"-"),PRC("FY")=$P(A,"-",2),PRC("QTR")=$P(A,"-",3),PRC("CP")=$P(A,"-",4)
16 D ICLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
17 S PRCE=$G(^PRCS(410,PRCRI(410),4)),PRCIS=$P($G(^(445)),"^")
18 I $P(PRCE,"^",5)="" D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"24////"_PRCIS)
19 D:$P(PRCE,"^")'=$P(PRCD,"^")
20 . D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_$P(PRCD,"^"))
21 . QUIT
22 D:$P(PRCE,"^",3)'=$P(PRCD,"^")!($P(PRCE,"^",10)="")
23 . D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"22////"_$P(PRCD,"^"))
24 . D ENCODE^PRCSC2(PRCRI(410),DUZ)
25 . D ERS410^PRC0G(PRCRI(410)_"^O")
26 . QUIT
27 I PRCRI("410A"),$D(^PRCS(410,PRCRI("410A"),0))#10=0 S PRCRI("410A")=""
28 I 'PRCRI("410A") D G:'PRCRI("410A") EXIT
29 . S PRC("SITE")=$P(^PRC(420,+$P(PRCA,"^",2),0),"^")
30 . S PRC("CP")=$P(^PRC(420,+PRC("SITE"),1,+$P(PRCB,"^",2),0)," ")
31 . S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
32 . S X=$P(Z,"-",1,2)_"-"_$P(Z,"-",4)
33 . D EN1^PRCSUT3 QUIT:X="" S PRCH=X
34 . S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
35 . S X=PRCH D EN2^PRCSUT3 QUIT:Y<1
36 . S PRCRI("410A")=+Y
37 . D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI("410A"),"1////A;3////5;40////^S X=DUZ;26///^S X=""T"";447////"_PRCC_";28.5///^S X="_PRC("BBFY"))
38 . S PRCF="410;^PRCS(410,;"_PRCRI("410A")_";60"
39 . S PRCF=PRCF_"~410.05;^PRCS(410,"_PRCRI("410A")_",""CO"","
40 . S X="Seller's adjustment for issue book request "_PRCG
41 . D ADD^PRC0B1(.X,.Y,PRCF)
42 . D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"447////"_PRCRI("410A"))
43 . QUIT
44 D DCLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
45 ;edit seller adjustment entry inf file 410
46 S PRCRI(410)=PRCRI("410A")
47 S PRCE=^PRCS(410,PRCRI(410),0),A=$P(PRCE,"^",1),PRC("BBFY")=$P($G(^(3)),"^",11)
48 S PRC("SITE")=$P(A,"-"),PRC("FY")=$P(A,"-",2),PRC("QTR")=$P(A,"-",3),PRC("CP")=$P(A,"-",4)
49 D ICLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
50 S PRCE=$G(^PRCS(410,PRCRI(410),4))
51 I $P(PRCE,"^",5)="" D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"23///^S X=""T"";24////"_PRCIS),ERS410^PRC0G(PRCRI(410)_"^O")
52 D:$P(PRCE,"^",6)'=$P(PRCD,"^",2)
53 . D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_(-$P(PRCD,"^",2)))
54 . S $P(^PRCS(410,PRCRI(410),4),"^",8)=$P(PRCD,"^",2)
55 D:$P(PRCE,"^",3)'=$P(PRCD,"^",2)
56 . D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"22////"_(-$P(PRCD,"^",2)))
57 D DCLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
58EXIT QUIT
59 ;
Note: See TracBrowser for help on using the repository browser.