source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCON3.m@ 623

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

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1PRCHCON3 ;WISC/KMB CREATE PURCHASE CARD FROM TEMP REQ ;1/8/97
2 ;;5.1;IFCAP;**92**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4START ;
5SETUP ;create 442 entry
6 D ENPO^PRCHUTL I '$D(DA) S OUT=1 W !,"Unable to create 442 entry. Try later." H 3 Q
7SETUP1 ;
8 S (PRCHPO,PDA)=DA L +^PRC(442,PDA):15 E W !!,$C(7),"Another user is editing this entry, try later." K PDA Q
9 S DIE="^PRC(442,",DR="62////"_NDA_";"_"5.2///"_SERV_";"_".8///3" S:$G(FLAG)'=1 DR=DR_";"_".02///25"_";"_"48///P" D ^DIE
10 I VENDOR'="" S DR="53////"_VENDOR_";"_"5////"_VENDOR D ^DIE
11 I $G(FLAG)=1 S DR=".02///1"_";"_"47///Y"_";"_"48///D" D ^DIE
12 S $P(^PRC(442,PDA,0),"^",3)=FCP,$P(^(0),"^",5)=CCEN,$P(^(23),"^",7)=PRC("SST")
13 S DIE="^PRC(442,",DR=".03///"_SPEC_";"_".1///"_TDATE D ^DIE
14 S $P(^PRC(442,PDA,1),"^",10)=DUZ,^PRC(442,"E",CP,PDA)=""
15 ;
16 S DR="52///"_CR_";"_"56///"_DUZ_";"_"63///1"_";"_"60///"_NCOST D ^DIE
17 S $P(^PRC(442,PDA,23),U,13)=SG
18 I $G(VENDOR)'="" D SETIT
19 E W !!,"This request has no entry in the Vendor File."
20 L -^PRC(442,PDA)
21 I $G(VENDOR)="" W !,"You must edit a request with no entry in the Vendor File.",! D LOOP1 Q
22 I REM1'=+$P(PRC("CP")," ") W !,"Since the control point is changed, you must edit this request." D LOOP1 Q
23 L +^PRC(442,PDA):15 E W !!,$C(7),"Another user is editing this entry, try later." K PDA Q
24 S $P(^PRC(442,PDA,1),"^")=VENDOR,$P(^(23),"^",14)=VENDOR,$P(^(23),"^",23)=NDA,^PRC(442,"D",$E(VENDOR,1,30),PDA)=""
25 L -^PRC(442,PDA)
26 D LOOP
27 Q
28 ;
29SETIT ; set item data on 442 record
30 Q:$G(CNNT)="" F II=1:1:CNNT D
31 .S ^PRC(442,PDA,2,II,0)=AA(II)
32 .I $G(CNT) F J=1:1:CNT S ^PRC(442,PDA,2,II,1,J,0)=$G(BB(II,J))
33 .S ^PRC(442,PDA,2,II,2)=CC(II)
34 .I $G(CNT) S ^PRC(442,PDA,2,II,1,0)="^^"_CNT_"^"_CNT_"^"_TDATE_"^"
35 .S ^PRC(442,PDA,2,"B",II,II)="",^PRC(442,PDA,2,"C",II,II)=""
36 .S (PRCHCI,PRCHCII,X)=$P(AA(II),U,5) Q:PRCHCI="" S (DA(1),PRCHCPO)=PDA,DA=II,PRCHCCP=CP,PRCHCPD=TDATE,PRCHCV=VENDOR D EN3^PRCHCRD S ^PRC(442,PDA,2,"AE",PRCHCII,II)=""
37 S ^PRC(442,PDA,2,0)="^442.01IA^"_CNNT_"^"_CNNT
38 K DIE
39 Q
40LOOP ;
41 ;Correction for NOIS ISW-0599-21097
42 S PRCHSY=NDA
43 W ! D SPRMK^PRCHNPO6 W !
44 ;End NOIS correction
45 ;
46 S %=1 W !,"Edit request ",$P(^PRC(442,PDA,0),"^") D YN^DICN G:%=0 LOOP Q:%=2
47LOOP1 W @IOF S (PRCHPO,DA)=PDA,PRC("PER")=DUZ,X=1
48 L +^PRC(442,PDA):15 E W !!,$C(7),"Another user is editing this entry, try later." K PDA Q
49 D ^PRCHNPO L -^PRC(442,PDA) K PRC("PER"),X,PRCHPO
50 Q
Note: See TracBrowser for help on using the repository browser.