source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ9.m@ 619

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

initial load of WorldVistAEHR
File size: 7.1 KB
Line 
1PRCHQ9 ;(WASH IRMFO)/LKG-RFQ CANCEL ; [8/31/98 11:24am]
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN ;Cancel RFQ and Transmit Cancel 840
5 K DIC S DIC="^PRC(444,",DIC(0)="AEMQ",DIC("S")="I "";1;2;3;4;""[("";""_$P(^(0),U,8)_"";"")"
6 S DIC("A")="Select RFQ to Cancel: " D ^DIC K DIC
7 G EX1:+Y<1!$D(DTOUT)!$D(DUOUT)
8 S PRCDA=+Y,PRCRFQ=$P(Y,U,2)
9 L +^PRC(444,PRCDA):5 E W !,"This RFQ entry is in use, please try later!" G EN
10 K DIR S DIR(0)="YA",DIR("A")="Do you wish to review a synopsis of this RFQ? "
11 S DIR("B")="YES",DIR("?")="Answer 'YES' if you wish to view the RFQ prior to Cancellation."
12 D ^DIR K DIR
13 I Y=1 D G:Y'=1 EX1
14 . N L,DIC,DR,FLDS,BY,FR,TO,IOP S DIC=444,BY=.01,(FR,TO)=PRCRFQ,L=0,IOP="HOME"
15 . S FLDS="[PRCHQ RFQ SYNOPSIS]" D EN1^DIP K DIC,FLDS,BY,FR,DR,L
16 . S DIR(0)="YA",DIR("A")="Is this the correct RFQ? ",DIR("B")="NO"
17 . S DIR("?")="Answer 'NO' to abort the Cancellation."
18 . D ^DIR K DIR
19 S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG) G:PRCMSG'=1 EX1
20 D NOW^%DTC S PRCDT=% K %
21 S PRCSTOLD=$P(^PRC(444,PRCDA,0),U,8)
22 G:$P($G(^PRC(444,PRCDA,1)),U,11)="" STATUS
23 S PRCX=$G(^PRC(444,PRCDA,1)),PRCMSGN=$P(PRCX,U,5)+1,PRCOUTN=$P(PRCX,U,6)+1
24 K DD,DO S DA(1)=PRCDA,DIC="^PRC(444,DA(1),7,",DIC(0)="L"
25 S DIC("P")=$P(^DD(444,21,0),U,2),X=PRCMSGN,DINUM=PRCMSGN,DLAYGO=444.021
26 D FILE^DICN K DIC,DINUM,DLAYGO
27 I Y<1 W !,"No Cancellation Message has been entered!" L -^PRC(444,PRCDA) G EX1
28 S PRCDA2=+Y
29 S $P(^PRC(444,PRCDA,1),U,5,6)=PRCMSGN_U_PRCOUTN
30 K ^UTILITY("DIQ1",$J) S DA=DUZ,DIC=200,DR=".01;.135" D EN^DIQ1
31 S PRCA=^UTILITY("DIQ1",$J,200,DA,.01),PRCB=^(.135) K ^UTILITY("DIQ1",$J)
32 S DA=PRCDA2,DA(1)=PRCDA,DIE="^PRC(444,DA(1),7,"
33 S DR="1////O;4///^S X=PRCOUTN;5///NOW;6///NOW;7///^S X=PRCA" D ^DIE
34 I PRCB]"" S DR="8///^S X=PRCB" D ^DIE
35 S PRCA=$P($G(^PRC(444,PRCDA,1)),U,8) I PRCA]"" S DR="12////^S X=PRCA" D ^DIE
36 S PRCX="** RFQ Cancellation Message **",DR="9///^S X=PRCX" D ^DIE
37 S DR="13////^S X=DUZ;13.1////^S X=PRCDT" D ^DIE
38 K DIE,DR,DA,PRCA,PRCB,PRCX,PRCMSGN,PRCOUTN
39 I $P($G(^PRC(444,PRCDA,5,0)),U,4)>0 D
40 . N PRCX,PRCY,PRCDA3
41 . S PRCX=0,PRCDA3=0
42 . F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D
43 . . S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY=""
44 . . Q:$P(PRCY,U,2)'="e"&($P(PRCY,U,2)'="b") S PRCY=$P(PRCY,U) Q:PRCY=""
45 . . S PRCDA3=PRCDA3+1,^PRC(444,PRCDA,7,PRCDA2,3,PRCDA3,0)=PRCY
46 . . S ^PRC(444,PRCDA,7,PRCDA2,3,"B",PRCY,PRCDA3)=""
47 . S:PRCDA3>0 ^PRC(444,PRCDA,7,PRCDA2,3,0)=U_$P(^DD(444.021,11,0),U,2)_U_PRCDA3_U_PRCDA3
48 S ^PRC(444,PRCDA,7,PRCDA2,2,1,0)="This is to notify you that RFQ #: "_PRCRFQ_" has "
49 S ^PRC(444,PRCDA,7,PRCDA2,2,2,0)="been cancelled."
50 S ^PRC(444,PRCDA,7,PRCDA2,2,0)="^^2^2^"_$P(PRCDT,".")
51 K DA S DA=PRCDA2,DA(1)=PRCDA,DIE="^PRC(444,DA(1),7,",DR="10Reason for Cancellation"
52 D ^DIE K DA,DIE,DR
53 K ^TMP($J,"STRING"),^TMP($J,"VE")
54 D HE^PRCHQ4 S PRCCOUNT=1
55 I $G(PRCERR) D EN^DDIOL("Electronic Transmission & Status Change Aborted!") K PRCERR,PRCCOUNT,^TMP($J,"STRING") D EX1 G EN
56 S $P(^TMP($J,"STRING",1),U,18)=$$VELST^PRCHQ4(.PRCCOUNT)
57 I $P(^TMP($J,"STRING",1),U,18)=0 D EN^DDIOL("No Vendors for Electronic Transmission - Transmission & Status Change Aborted!") K PRCCOUNT,^TMP($J,"STRING"),^TMP($J,"VE") D EX1 G EN
58 D ST^PRCHQ4(.PRCCOUNT)
59 D MI^PRCHQ4("01",.PRCCOUNT)
60 D AC^PRCHQ4(.PRCCOUNT)
61 S $P(^TMP($J,"STRING",1),U,14)=$$TX^PRCHQ4("^PRC(444,PRCDA,7,PRCDA2,2)",.PRCCOUNT)
62 D IT^PRCHQ4(.PRCCOUNT)
63 S PRCSORC=$O(^PRC(411,"B",$P(PRCRFQ,"-"),""))
64 I PRCSORC="" S PRCERR=4 D EN^DDIOL("Sending Station not in File 411")
65 I $G(PRCERR) D EN^DDIOL("Electronic Transmission & Status Change Aborted!") K PRCERR,PRCCOUNT,^TMP($J,"STRING"),^TMP($J,"VE") D EX1 G EN
66 S PRCDEST=$S($P($G(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
67 D TRANSMIT^PRCPSMCS($P(PRCRFQ,"-"),"RFQ",PRCRFQ,PRCDEST,200,1)
68 K ^TMP($J,"STRING") S XMZ=$O(PRCPXMZ(0))
69 I XMZ>0 D
70 . N PRCV
71 . S $P(^PRC(444,PRCDA,1),U,11)=PRCPXMZ(XMZ)
72 . S $P(^PRC(444,PRCDA,7,PRCDA2,1),U,3)=PRCPXMZ(XMZ)
73 . S X="MailMan Msg #: "_PRCPXMZ(XMZ)
74 . D EN^DDIOL(X)
75 . S PRCV=""
76 . F S PRCV=$O(^TMP($J,"VE",PRCV)) Q:PRCV="" D ENTER^PRCOEDI(PRCRFQ,"RFQ",PRCPXMZ(XMZ),PRCV,$P($G(^PRC(444,PRCDA,0)),U,4),PRCDA,"01")
77 K ^TMP($J,"VE")
78 K PRCCOUNT,PRCPXMZ,XMZ,X
79STATUS S DIE=444,DA=PRCDA,DR="7////0;20.7////^S X=DUZ;20.8////^S X=PRCDT"
80 D ^DIE K DIE,DR,PRCDT
81 I $P($G(^PRC(444,PRCDA,1)),U,11)]""!($P($G(^PRC(444,PRCDA,9)),U)]"") D COPY(PRCDA) G:PRCCOPY EX1
82 K PRC S PRCDA2=0,DIE="^PRC(443,"
83 F S PRCDA2=$O(^PRC(444,PRCDA,2,PRCDA2)) Q:PRCDA2'?1.N D
84 . N PRCOSTAT,PRC2237,PRCAR
85 . S DA=$P($G(^PRC(444,PRCDA,2,PRCDA2,3)),U) Q:DA=""
86 . I '$D(PRC(DA)) D
87 . . S PRCOSTAT=$P(^PRC(443,DA,0),U,7)
88 . . S:PRCOSTAT?1.N PRCOSTAT=$P(^PRCD(442.3,PRCOSTAT,0),U)
89 . . L +^PRC(443,DA):300 S DR="1.5////70" D ^DIE S PRC(DA)="" L -^PRC(433,DA)
90 . . S PRC2237=$P(^PRCS(410,DA,0),U)
91 . . S PRCAR(1)="Status of 2237 #"_PRC2237_" has been changed from"
92 . . S PRCAR(2)=" "_PRCOSTAT_" to "_$P(^PRCD(442.3,70,0),U)
93 . . D EN^DDIOL(.PRCAR)
94 K DIE,DR,PRC,PRCDA2
95 I PRCSTOLD=1,$P($G(^PRC(444,PRCDA,1)),U,11)="" D
96 . K DIR S DIR(0)="YA",DIR("A",1)="As it appears that this RFQ was never transmitted electronically,"
97 . S DIR("A")="do you wish to delete this RFQ? ",DIR("B")="YES"
98 . S DIR("?")="Enter 'YES' to delete, 'NO' to retain in the database."
99 . D ^DIR K DIR
100 . Q:Y'=1
101 . S DIK="^PRC(444,",DA=PRCDA D ^DIK K DIK,DA
102 . S X="RFQ #"_PRCRFQ_" has been deleted!" D EN^DDIOL(X)
103 L -^PRC(444,PRCDA)
104 G EN:'$D(DIRUT)&'$D(DIROUT)&'$D(DTOUT)
105EX1 L:$D(PRCDA) -^PRC(444,PRCDA) K PRCDA,PRCRFQ,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
106 K DA,DIC,PRCX,PRCMSGN,PRCOUTN,DA,DD,DO,PRCDT,PRCMSG,PRCDA2,PRCERR,PRCSTOLD,PRCCOPY,PRCSORC,PRCDEST
107 Q
108COPY(PRCDA) ;Requires PRCDA the IEN of RFQ
109 N PRCI,PRCJ,PRCK,PRCX,DIC,PRCEDIT S PRCCOPY=0
110 K DIR S DIR(0)="YA",DIR("A")="Do you wish to copy this RFQ into a new RFQ entry? "
111 S DIR("B")="NO",DIR("?")="Answer 'YES' if you wish to copy this RFQ to make changes and reissue."
112 D ^DIR K DIR
113 Q:Y'=1 S PRCCOPY=1
114 W !,"Copying this RFQ into a new entry..."
115 K ^TMP($J,"RFQ") M ^TMP($J,"RFQ")=^PRC(444,PRCDA)
116 F PRCI=6:1:9 K ^TMP($J,"RFQ",PRCI)
117 F PRCI=5,6,11:1:19 S $P(^TMP($J,"RFQ",1),U,PRCI)=""
118 S PRCI=0
119 F S PRCI=$O(^TMP($J,"RFQ",2,PRCI)) Q:+PRCI'=PRCI D
120 . Q:'$D(^TMP($J,"RFQ",2,PRCI,3))
121 . S PRCK=^TMP($J,"RFQ",2,PRCI,3)
122 . F PRCJ=3:1:9 S $P(PRCK,U,PRCJ)=""
123 . S ^TMP($J,"RFQ",2,PRCI,3)=PRCK
124 K ^TMP($J,"RFQ",2,"AG"),^TMP($J,"RFQ",2,"AJ") S $P(^TMP($J,"RFQ",0),U,8)=1
125 S PRCX=$$GETNUM^PRCHQ2($P($P(^TMP($J,"RFQ",0),U),"-",1,2))
126 I 'PRCX W !,"Unable to get new RFQ # - Please notify IRM staff" Q
127 S $P(^TMP($J,"RFQ",0),U)=PRCX,X=PRCX
128 K DIC S DIC="^PRC(444,",DIC(0)="LX",DLAYGO=444 D ^DIC K DIC,DLAYGO
129 I +Y<1 W !,"Unable to add RFQ entry - Please notify IRM staff." Q
130 S PRCDA=+Y
131 W !,"RFQ # ",$P(Y,U,2)," has been added."
132 L +^PRC(444,PRCDA):5 E W !,"Someone else is editing this RFQ entry, please try later!" Q
133 M ^PRC(444,PRCDA)=^TMP($J,"RFQ")
134 K DA S DA=PRCDA,DIK="^PRC(444," D IX1^DIK K DA,DIK
135 K ^TMP($J,"RFQ")
136 K DIR S DIR(0)="YA",DIR("A")="Do you wish to edit this new RFQ now? "
137 S DIR("B")="YES",DIR("?")="Enter 'YES' to edit now, or 'NO' to exit."
138 D ^DIR K DIR
139 Q:Y'=1
140 S PRCEDIT=$$EDITOR^PRCHQ1C
141 I PRCEDIT="" D EN^DDIOL("Edit mode not indicated, aborting the edit.") G COPYX
142 D EDIT^PRCHQ2B
143COPYX L -^PRC(444,PRCDA)
144 Q
Note: See TracBrowser for help on using the repository browser.