source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ6.m@ 737

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

initial load of WorldVistAEHR
File size: 5.1 KB
RevLine 
[613]1PRCHQ6 ;(WASH IRMFO)/LKG-RFQ SERVER UNPACKING VENDOR QUOTE ;8/6/96 20:57
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5IN ;
6 K ^TMP("DIERR",$J),^TMP($J,"PRCERR") D NOW^%DTC S PRCRCVDT=% K %,%H,%I
7 S PRCI=0 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=1 G ERR^PRCHQ6B
8 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
9 I $P(PRCX,U)'="ISM"!($P(PRCX,U,4)'="VQT") S PRCERR=2 G ERR^PRCHQ6B
10 S PRCRFQ=$P($P(PRCX,U,7)," ")
11 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=3 G ERR^PRCHQ6B
12 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="HE" S PRCERR=3 G ERR^PRCHQ6B
13 K PRC S X=$O(^PRC(444,"B",PRCRFQ,"")) I X'?1.N S PRCERR=4 G ERR^PRCHQ6B
14 S PRC("D0")=X L +^PRC(444,PRC("D0")):1200 E S PRCERR=5 G ERR^PRCHQ6B
15 I ";0;4;5;"[(";"_$P($G(^PRC(444,PRC("D0"),0)),U,8)_";") G EX^PRCHQ6B
16 S PRCVCN=$P(PRCX,U,8),PRCVCP=$P(PRCX,U,9),PRCICNT=+$P(PRCX,U,12)
17 S PRCREF=$P(PRCX,U,15),PRCEFFDT=$$JD2FMD^PRCHQ7($P(PRCX,U,16))
18 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=6 G ERR^PRCHQ6B
19 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="VE" S PRCERR=6 G ERR^PRCHQ6B
20 S PRCDB=$P(PRCX,U,2),PRCVNM=$P(PRCX,U,3)
21 S PRCDBI="DUN"_PRCDB,PRCVDA=$O(^PRC(440,"DB",PRCDBI,""))
22 I PRCVDA?1.N D
23 . S PRCVEN=PRCVDA_";PRC(440,"
24 I PRCVDA="" D G:$D(PRCERR) ERR^PRCHQ6B
25 . N DA,DIC,DIE,DR
26 . S PRCVDA=$O(^PRC(444.1,"DB",PRCDBI,""))
27 . I PRCVDA="" D Q:$D(PRCERR)
28 . . K DD,DO
29 . . S X=$P(PRCX,U,3),DIC="^PRC(444.1,",DIC(0)="LX",DLAYGO=444.1
30 . . D FILE^DICN K DIC,DLAYGO
31 . . I Y<1 S PRCERR=7 Q
32 . . S PRCVDA=+Y
33 . . S DA=PRCVDA,DIE=444.1,DR="18.3///^S X=PRCDB" D ^DIE K DA,DIE,DR
34 . S PRCVEN=PRCVDA_";PRC(444.1,"
35 . L +^PRC(444.1,PRCVDA):1200 E Q
36 . S DA=PRCVDA,DIE=444.1,DR=".01///^S X=$P(PRCX,U,3)" D ^DIE
37 . S PRCY=$E($P(PRCX,U,4),1,33) S:PRCY="" PRCY="@" S DR="1///^S X=PRCY" D ^DIE
38 . S PRCY=$E($P(PRCX,U,5),1,33) S:PRCY="" PRCY="@" S DR="2///^S X=PRCY" D ^DIE
39 . S PRCY=$E($P(PRCX,U,6),1,25) S:PRCY="" PRCY="@" S DR="3///^S X=PRCY" D ^DIE
40 . S PRCY=$E($P(PRCX,U,7),1,20) S:PRCY="" PRCY="@" S DR="4.2///^S X=PRCY" D ^DIE
41 . S PRCY=$P(PRCX,U,8)
42 . I PRCY]"" D
43 . . S PRCY=$O(^DIC(5,"C",PRCY,"")) Q:PRCY=""
44 . . S DR="4.4////^S X=PRCY" D ^DIE
45 . I PRCY="" S DR="4.4///@" D ^DIE
46 . S PRCY=$P(PRCX,U,9),PRCY=$S(PRCY="":"@",$L(PRCY)=5:PRCY,1:$E(PRCY,1,5)_"-"_$E(PRCY,6,9))
47 . S DR="4.6///^S X=PRCY" D ^DIE
48 . I PRCVCN]"" S DR="4.8///^S X=PRCVCN" D ^DIE
49 . S PRCY=$P(PRCX,U,10) S:PRCY="" PRCY="@" S DR="5///^S X=PRCY" D ^DIE
50 . S PRCY=$P(PRCX,U,11) S:PRCY="" PRCY="@" S DR="38///^S X=PRCY" D ^DIE
51 . S PRCY=$P(PRCX,U,12)
52 . I PRCY]"" D
53 . . S PRCY=$S(PRCY=21:1,PRCY="B9":2,1:"") Q:PRCY=""
54 . . S DR="8.3////^S X=PRCY" D ^DIE
55 . S PRCY=$P(PRCX,U,19)
56 . I PRCY]"" S PRCY=$S(PRCY="A6":"y",1:"n"),DR="50////^S X=PRCY" D ^DIE
57 . I $P(PRCX,U,13)=22!($P(PRCX,U,14)=23) D TYPE("M")
58 . I $P(PRCX,U,15)=24!($P(PRCX,U,16)=25) D TYPE("W")
59 . D:$P(PRCX,U,18)="A5" TYPE("V")
60 . I $D(^PRC(444.1,PRCVDA,4)),$P(PRCX,U,17)=27!($P(PRCX,U,18)="A5"&($P(PRCX,U,12)=21))!($P(PRCX,U,15)=24) D DELTNONE^PRCHQ6A
61 . D:$P(PRCX,U,17)=27 SOCIOECO("N")
62 . I $P(PRCX,U,18)="A5",$P(PRCX,U,12)=21 D SOCIOECO("Q")
63 . D:$P(PRCX,U,15)=24 SOCIOECO("W")
64 . S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) Q:PRCI=""
65 . S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) Q:$P(PRCX,U)'="RT"
66 . K DA S DA=PRCVDA,DIE=444.1
67 . S PRCY=$E($P(PRCX,U,2),1,35) S:PRCY="" PRCY="@" S DR="17.1///^S X=PRCY" D ^DIE
68 . S PRCY=$E($P(PRCX,U,3),1,35) S:PRCY="" PRCY="@" S DR="17.15///^S X=PRCY" D ^DIE
69 . S PRCY=$E($P(PRCX,U,4),1,35) S:PRCY="" PRCY="@" S DR="17.3///^S X=PRCY" D ^DIE
70 . S PRCY=$E($P(PRCX,U,5),1,35) S:PRCY="" PRCY="@" S DR="17.4///^S X=PRCY" D ^DIE
71 . S PRCY=$E($P(PRCX,U,6),1,35) S:PRCY="" PRCY="@" S DR="17.5///^S X=PRCY" D ^DIE
72 . S PRCY=$E($P(PRCX,U,7),1,30) S:PRCY="" PRCY="@" S DR="17.7///^S X=PRCY" D ^DIE
73 . S PRCY=$P(PRCX,U,8)
74 . I PRCY]"" D
75 . . S PRCY=$O(^DIC(5,"C",PRCY,"")) Q:PRCY=""
76 . . S DR="17.8////^S X=PRCY" D ^DIE
77 . I PRCY="" S DR="17.8///@" D ^DIE
78 . S PRCY=$P(PRCX,U,9),PRCY=$S(PRCY="":"@",$L(PRCY)=5:PRCY,1:$E(PRCY,1,5)_"-"_$E(PRCY,6,9))
79 . S DR="17.9///^S X=PRCY" D ^DIE
80 . L -^PRC(444.1,PRCVDA)
81 ;I PRCRCVDT'>$P($G(^PRC(444,PRC("D0"),0)),U,3) D
82 I $P($G(^PRC(444,PRC("D0"),0)),U,8)'=3 D
83 . S PRCNUM=$O(^PRC(444,PRC("D0"),8,"B",PRCVEN,""))
84 . I PRCNUM?1.N D
85 . . N DA
86 . . S DA=PRCNUM,DA(1)=PRC("D0"),DIK="^PRC(444,DA(1),8," D ^DIK K DIK
87 . . S DINUM=PRCNUM
88 K DA,DD,DO S X=PRCVEN,DA(1)=PRC("D0"),DIC="^PRC(444,DA(1),8,",DIC(0)="LX"
89 S DIC("P")=$P(^DD(444,24,0),U,2)
90 S DLAYGO=444.024 D FILE^DICN K DIC,DLAYGO,DINUM
91 I Y<1 S PRCERR=8 G ERR^PRCHQ6B
92 S PRC("D1")=+Y
93 K PRCAR S PRCIENS=PRC("D1")_","_PRC("D0")_","
94 S PRCAR(444.024,PRCIENS,3.5)=PRCDA,PRCAR(444.024,PRCIENS,3)=PRCRCVDT
95 D FILE^DIE("","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
96 G A^PRCHQ6A
97TYPE(X) ;Edit Type of Ownership multiple
98 N DA,DIC,DLAYGO
99 S DA(1)=PRCVDA,DLAYGO=444.19,DIC="^PRC(444.1,DA(1),3,",DIC(0)="LX"
100 S:'$D(^PRC(444.1,DA(1),3,0)) DIC("P")=$P(^DD(444.1,9,0),U,2)
101 D ^DIC
102 Q
103SOCIOECO(X) ;Edit Socioeconomic Group multiple
104 N DA,DIC,DLAYGO
105 S DA(1)=PRCVDA,DLAYGO=444.11,DIC="^PRC(444.1,DA(1),4,",DIC(0)="LX"
106 S:'$D(^PRC(444.1,DA(1),4,0)) DIC("P")=$P(^DD(444.1,10,0),U,2)
107 D ^DIC
108 Q
Note: See TracBrowser for help on using the repository browser.