source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ5.m@ 1710

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

initial load of WorldVistAEHR
File size: 3.4 KB
RevLine 
[613]1PRCHQ5 ;(WASH IRMFO)/LKG-RFQ 864 Text Message Create ;9/6/96 15:00
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN ;Entry point
5 S PRCEDIT=$$EDITOR^PRCHQ1C
6 I PRCEDIT="" D EN^DDIOL("Edit mode not indicated, aborting the edit") K PRCEDIT Q
7 S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG)
8 I PRCMSG'=1 D EN^DDIOL("Electronic Signature Failed, Edit aborted") G OUT
9 S DIC="^PRC(444,",DIC(0)="AEMQ",DIC("S")="I "";2;3;4;""[("";""_$P(^(0),U,8)_"";"")"
10 S DIC("A")="Enter RFQ #: " D ^DIC K DIC I Y<1!$D(DTOUT)!$D(DUOUT) G OUT
11 S PRCDA=+Y
12 L +^PRC(444,PRCDA):3 E W !,"Someone else is editing this entry, please try later!" G OUT
13 S PRCX=$G(^PRC(444,PRCDA,1)),PRCMSGN=$P(PRCX,U,5)+1,PRCOUTN=$P(PRCX,U,6)+1
14 K DD,DO S DA(1)=PRCDA,DIC="^PRC(444,DA(1),7,",DIC(0)="L"
15 S DIC("P")=$P(^DD(444,21,0),U,2),X=PRCMSGN,DINUM=PRCMSGN,DLAYGO=444.021
16 D FILE^DICN K DIC,DINUM,DLAYGO
17 I Y<1 W !,"No entry was made.!" L -^PRC(444,PRCDA) G EX
18 S PRCDA2=+Y
19 S $P(^PRC(444,PRCDA,1),U,5,6)=PRCMSGN_U_PRCOUTN
20 K ^UTILITY("DIQ1",$J) S DA=DUZ,DIC=200,DR=".01;.135" D EN^DIQ1
21 S PRCA=^UTILITY("DIQ1",$J,200,DA,.01),PRCB=^(.135) K ^UTILITY("DIQ1",$J)
22 S DA=PRCDA2,DA(1)=PRCDA,DIE="^PRC(444,DA(1),7,"
23 S DR="1////O;4///^S X=PRCOUTN;5///NOW;6///NOW;7///^S X=PRCA" D ^DIE
24 I PRCB]"" S DR="8///^S X=PRCB" D ^DIE
25 S PRCA=$P($G(^PRC(444,PRCDA,1)),U,8) I PRCA]"" S DR="12////^S X=PRCA" D ^DIE
26 K DIE,DR,DA,PRCA,PRCB
27 I $P($G(^PRC(444,PRCDA,5,0)),U,4)>0 D
28 . N PRCX,PRCY,PRCDA3
29 . S PRCX=0,PRCDA3=0
30 . F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D
31 . . S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY=""
32 . . Q:$P(PRCY,U,2)'="e"&($P(PRCY,U,2)'="b") S PRCY=$P(PRCY,U) Q:PRCY=""
33 . . S PRCDA3=PRCDA3+1,^PRC(444,PRCDA,7,PRCDA2,3,PRCDA3,0)=PRCY
34 . . S ^PRC(444,PRCDA,7,PRCDA2,3,"B",PRCY,PRCDA3)=""
35 . S:PRCDA3>0 ^PRC(444,PRCDA,7,PRCDA2,3,0)=U_$P(^DD(444.021,11,0),U,2)_U_PRCDA3_U_PRCDA3
36DDS ;Test FORM
37 S PRCRFQ=$P($G(^PRC(444,PRCDA,0)),U)
38 I PRCEDIT="s" D G EX:$D(DTOUT)
39 . S DDSPARM="S"
40 . S DDSFILE=444,DDSFILE(1)=444.021,DA(1)=PRCDA,DA=PRCDA2,DR="[PRCHQ4]"
41 . D ^DDS
42 . K DDSCHANG,DDSPARM,DIMSG,DDSFILE,DA,DR
43 I PRCEDIT="i" D G EX:$D(DTOUT)!$D(DUOUT)
44 . N %,%H,%I
45 . K DA S DA=PRCDA2,DA(1)=PRCDA,DIE="^PRC(444,PRCDA,7,",DR="9R;10R;8R;12R;11",DR(2,444.022)=".01"
46 . D ^DIE K DIE,DR
47 . D NOW^%DTC S $P(^PRC(444,PRCDA,7,PRCDA2,0),U,10,11)=DUZ_U_%
48 I $G(DDSSAVE)=1!(PRCEDIT="i") D
49 . S DIR(0)="YA",DIR("A")="Do you wish to transmit this message to the vendors? "
50 . S DIR("B")="YES",DIR("?")="Accept default of 'YES' to transmit, enter 'No' to avoid transmitting."
51 . D ^DIR K DIR Q:Y'=1!$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
52 . K PRCERR
53 . D TRANS864^PRCHQ4A
54 . I $G(PRCERR) D EN^DDIOL("Electronic Transmission Aborted!")
55EX L:$D(PRCDA) -^PRC(444,PRCDA) K DDSSAVE,PRCERR
56OUT K PRCX,PRCMSGN,PRCOUTN,PRCDA,PRCDA2,PRCRFQ,DTOUT,DUOUT,DA,DIRUT,DIROUT,X,Y,PRCMSG,%,PRCEDIT
57 Q
58SC() ;Screen for File 440 and File 444.1 vendors
59 N PRC,PRCX,PRCZ S PRC=0,PRCX=Y_";"_$P(DIC,U,2)
60 I $D(PRCDA) D
61 . S PRCZ=$O(^PRC(444,PRCDA,5,"B",PRCX,""))
62 . I PRCZ]"",$P($G(^PRC(444,PRCDA,5,PRCZ,0)),U,2)="e" S PRC=1 Q
63 . I $P($G(^PRC(444,PRCDA,1)),U,8)="y",PRCX["PRC(440",$P($G(^PRC(440,+PRCX,3)),U,2)="Y",$P($G(^PRC(440,+PRCX,7)),U,12)]"" S PRC=1 Q
64 Q PRC
65RHLP ;Executable Help for Recipient Lookup
66 N PRCAR S PRCAR(1)="Choices are restricted to Electronic Solicited Vendors unless the RFQ's"
67 S PRCAR(2)=" transmission was Public. Vendor must be EDI and have Duns #."
68 D EN^DDIOL(.PRCAR)
69 Q
Note: See TracBrowser for help on using the repository browser.