| 1 | PRCHCON3 ;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.
|
|---|
| 4 | START ;
|
|---|
| 5 | SETUP ;create 442 entry
|
|---|
| 6 | D ENPO^PRCHUTL I '$D(DA) S OUT=1 W !,"Unable to create 442 entry. Try later." H 3 Q
|
|---|
| 7 | SETUP1 ;
|
|---|
| 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 | ;
|
|---|
| 29 | SETIT ; 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
|
|---|
| 40 | LOOP ;
|
|---|
| 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
|
|---|
| 47 | LOOP1 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
|
|---|
