PRCHCON3 ;WISC/KMB CREATE PURCHASE CARD FROM TEMP REQ ;1/8/97
;;5.1;IFCAP;**92**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
SETUP ;create 442 entry
D ENPO^PRCHUTL I '$D(DA) S OUT=1 W !,"Unable to create 442 entry. Try later." H 3 Q
SETUP1 ;
S (PRCHPO,PDA)=DA L +^PRC(442,PDA):15 E W !!,$C(7),"Another user is editing this entry, try later." K PDA Q
S DIE="^PRC(442,",DR="62////"_NDA_";"_"5.2///"_SERV_";"_".8///3" S:$G(FLAG)'=1 DR=DR_";"_".02///25"_";"_"48///P" D ^DIE
I VENDOR'="" S DR="53////"_VENDOR_";"_"5////"_VENDOR D ^DIE
I $G(FLAG)=1 S DR=".02///1"_";"_"47///Y"_";"_"48///D" D ^DIE
S $P(^PRC(442,PDA,0),"^",3)=FCP,$P(^(0),"^",5)=CCEN,$P(^(23),"^",7)=PRC("SST")
S DIE="^PRC(442,",DR=".03///"_SPEC_";"_".1///"_TDATE D ^DIE
S $P(^PRC(442,PDA,1),"^",10)=DUZ,^PRC(442,"E",CP,PDA)=""
;
S DR="52///"_CR_";"_"56///"_DUZ_";"_"63///1"_";"_"60///"_NCOST D ^DIE
S $P(^PRC(442,PDA,23),U,13)=SG
I $G(VENDOR)'="" D SETIT
E W !!,"This request has no entry in the Vendor File."
L -^PRC(442,PDA)
I $G(VENDOR)="" W !,"You must edit a request with no entry in the Vendor File.",! D LOOP1 Q
I REM1'=+$P(PRC("CP")," ") W !,"Since the control point is changed, you must edit this request." D LOOP1 Q
L +^PRC(442,PDA):15 E W !!,$C(7),"Another user is editing this entry, try later." K PDA Q
S $P(^PRC(442,PDA,1),"^")=VENDOR,$P(^(23),"^",14)=VENDOR,$P(^(23),"^",23)=NDA,^PRC(442,"D",$E(VENDOR,1,30),PDA)=""
L -^PRC(442,PDA)
D LOOP
Q
;
SETIT ; set item data on 442 record
Q:$G(CNNT)="" F II=1:1:CNNT D
.S ^PRC(442,PDA,2,II,0)=AA(II)
.I $G(CNT) F J=1:1:CNT S ^PRC(442,PDA,2,II,1,J,0)=$G(BB(II,J))
.S ^PRC(442,PDA,2,II,2)=CC(II)
.I $G(CNT) S ^PRC(442,PDA,2,II,1,0)="^^"_CNT_"^"_CNT_"^"_TDATE_"^"
.S ^PRC(442,PDA,2,"B",II,II)="",^PRC(442,PDA,2,"C",II,II)=""
.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)=""
S ^PRC(442,PDA,2,0)="^442.01IA^"_CNNT_"^"_CNNT
K DIE
Q
LOOP ;
;Correction for NOIS ISW-0599-21097
S PRCHSY=NDA
W ! D SPRMK^PRCHNPO6 W !
;End NOIS correction
;
S %=1 W !,"Edit request ",$P(^PRC(442,PDA,0),"^") D YN^DICN G:%=0 LOOP Q:%=2
LOOP1 W @IOF S (PRCHPO,DA)=PDA,PRC("PER")=DUZ,X=1
L +^PRC(442,PDA):15 E W !!,$C(7),"Another user is editing this entry, try later." K PDA Q
D ^PRCHNPO L -^PRC(442,PDA) K PRC("PER"),X,PRCHPO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCON3 2479 printed Dec 13, 2024@02:06:10 Page 2
PRCHCON3 ;WISC/KMB CREATE PURCHASE CARD FROM TEMP REQ ;1/8/97
+1 ;;5.1;IFCAP;**92**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
SETUP ;create 442 entry
+1 DO ENPO^PRCHUTL
IF '$DATA(DA)
SET OUT=1
WRITE !,"Unable to create 442 entry. Try later."
HANG 3
QUIT
SETUP1 ;
+1 SET (PRCHPO,PDA)=DA
LOCK +^PRC(442,PDA):15
IF '$TEST
WRITE !!,$CHAR(7),"Another user is editing this entry, try later."
KILL PDA
QUIT
+2 SET DIE="^PRC(442,"
SET DR="62////"_NDA_";"_"5.2///"_SERV_";"_".8///3"
if $GET(FLAG)'=1
SET DR=DR_";"_".02///25"_";"_"48///P"
DO ^DIE
+3 IF VENDOR'=""
SET DR="53////"_VENDOR_";"_"5////"_VENDOR
DO ^DIE
+4 IF $GET(FLAG)=1
SET DR=".02///1"_";"_"47///Y"_";"_"48///D"
DO ^DIE
+5 SET $PIECE(^PRC(442,PDA,0),"^",3)=FCP
SET $PIECE(^(0),"^",5)=CCEN
SET $PIECE(^(23),"^",7)=PRC("SST")
+6 SET DIE="^PRC(442,"
SET DR=".03///"_SPEC_";"_".1///"_TDATE
DO ^DIE
+7 SET $PIECE(^PRC(442,PDA,1),"^",10)=DUZ
SET ^PRC(442,"E",CP,PDA)=""
+8 ;
+9 SET DR="52///"_CR_";"_"56///"_DUZ_";"_"63///1"_";"_"60///"_NCOST
DO ^DIE
+10 SET $PIECE(^PRC(442,PDA,23),U,13)=SG
+11 IF $GET(VENDOR)'=""
DO SETIT
+12 IF '$TEST
WRITE !!,"This request has no entry in the Vendor File."
+13 LOCK -^PRC(442,PDA)
+14 IF $GET(VENDOR)=""
WRITE !,"You must edit a request with no entry in the Vendor File.",!
DO LOOP1
QUIT
+15 IF REM1'=+$PIECE(PRC("CP")," ")
WRITE !,"Since the control point is changed, you must edit this request."
DO LOOP1
QUIT
+16 LOCK +^PRC(442,PDA):15
IF '$TEST
WRITE !!,$CHAR(7),"Another user is editing this entry, try later."
KILL PDA
QUIT
+17 SET $PIECE(^PRC(442,PDA,1),"^")=VENDOR
SET $PIECE(^(23),"^",14)=VENDOR
SET $PIECE(^(23),"^",23)=NDA
SET ^PRC(442,"D",$EXTRACT(VENDOR,1,30),PDA)=""
+18 LOCK -^PRC(442,PDA)
+19 DO LOOP
+20 QUIT
+21 ;
SETIT ; set item data on 442 record
+1 if $GET(CNNT)=""
QUIT
FOR II=1:1:CNNT
Begin DoDot:1
+2 SET ^PRC(442,PDA,2,II,0)=AA(II)
+3 IF $GET(CNT)
FOR J=1:1:CNT
SET ^PRC(442,PDA,2,II,1,J,0)=$GET(BB(II,J))
+4 SET ^PRC(442,PDA,2,II,2)=CC(II)
+5 IF $GET(CNT)
SET ^PRC(442,PDA,2,II,1,0)="^^"_CNT_"^"_CNT_"^"_TDATE_"^"
+6 SET ^PRC(442,PDA,2,"B",II,II)=""
SET ^PRC(442,PDA,2,"C",II,II)=""
+7 SET (PRCHCI,PRCHCII,X)=$PIECE(AA(II),U,5)
if PRCHCI=""
QUIT
SET (DA(1),PRCHCPO)=PDA
SET DA=II
SET PRCHCCP=CP
SET PRCHCPD=TDATE
SET PRCHCV=VENDOR
DO EN3^PRCHCRD
SET ^PRC(442,PDA,2,"AE",PRCHCII,II)=""
End DoDot:1
+8 SET ^PRC(442,PDA,2,0)="^442.01IA^"_CNNT_"^"_CNNT
+9 KILL DIE
+10 QUIT
LOOP ;
+1 ;Correction for NOIS ISW-0599-21097
+2 SET PRCHSY=NDA
+3 WRITE !
DO SPRMK^PRCHNPO6
WRITE !
+4 ;End NOIS correction
+5 ;
+6 SET %=1
WRITE !,"Edit request ",$PIECE(^PRC(442,PDA,0),"^")
DO YN^DICN
if %=0
GOTO LOOP
if %=2
QUIT
LOOP1 WRITE @IOF
SET (PRCHPO,DA)=PDA
SET PRC("PER")=DUZ
SET X=1
+1 LOCK +^PRC(442,PDA):15
IF '$TEST
WRITE !!,$CHAR(7),"Another user is editing this entry, try later."
KILL PDA
QUIT
+2 DO ^PRCHNPO
LOCK -^PRC(442,PDA)
KILL PRC("PER"),X,PRCHPO
+3 QUIT
