PRCHCRD2 ;WISC/DJM-LINK ITEM FILE DATA INTO AMMENDMENT FILE ;1/11/94  11:55 AM [5/14/98 4:58pm]
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
LST ;ENTERED FROM SET 0F 'AD' X-REF ON 'REPETITIVE (PR CARD) NO. WITHIN 'ITEM' MULTIPLE
 L +^PRC(441,PRCHCI,2,PRCHCV):5 E  W !!,$C(7),"Another user is editing this entry, try later." G Q
 S PRCHCY=$G(^PRC(441,PRCHCI,0)),PRCHCNS=$P(PRCHCY,U,5),PRCHCSC=$P(PRCHCY,U,3),PRCHCSB=$P(PRCHCY,U,10) S:$G(PRCHCSB) PRCHCSB=$P($G(^PRCD(420.2,PRCHCSB,0)),U,1)
 S PRCHCY=$G(^PRC(441,PRCHCI,2,PRCHCV,0)),PRCHCVS=$P(PRCHCY,U,4),PRCHCDC=$P(PRCHCY,U,5),PRCHCUC=$P(PRCHCY,U,2),PRCHCCN=$P(PRCHCY,U,3),PRCHCUP=$P(PRCHCY,U,7),PRCHCPK=$P(PRCHCY,U,8),PRCHCMX=$P(PRCHCY,U,9),PRCHSKM=$P(PRCHCY,U,10)
 S PRCHCY=$G(^PRC(441,PRCHCI,3)),PRCHSKU=$P(PRCHCY,U,8),PRCHFGRP=$P(PRCHCY,U,7),PRCHDRTY=$P(PRCHCY,U,9)
 S PRCHCS=" ",L=1 F M=0:0 S M=$O(^PRC(441,PRCHCI,1,M)) Q:M'>0  S PRCHC("%X",L,0)=PRCHCS_^(M,0),L=L+1,PRCHCS=""
 S:PRCHCDC]"" PRCHC("%X",L,0)=" NDC:"_PRCHCDC,L=L+1
 S PRCHC("%X",0)="^^"_L_U_L_U_DT_U,%X="PRCHC(""%X"",",%Y="^PRC(443.6,PRCHCPO,2,PRCHCIT,1,"
 S:PRCHCCN]"" PRCHCY=$G(^PRC(440,PRCHCV,4,PRCHCCN,0)),PRCHCCN=$S($P(PRCHCY,U,2)>DT:$P(PRCHCY,U,1),1:"")
 S PRCHC(0)=^PRC(443.6,DA(1),2,DA,0),PRCHC(2)="",PRCHCQ=$P(PRCHC(0),U,2) S:$D(^(2)) PRCHC(2)=^(2) S PRCHC(4)=$G(^(4))
 S $P(PRCHC(0),U,3)=PRCHCUP,$P(PRCHC(0),U,12)=PRCHCPK,$P(PRCHC(0),U,14)=PRCHCMX S:$P(PRCHC(0),U,4)="" $P(PRCHC(0),U,4)=PRCHCSB S $P(PRCHC(0),U,9)=PRCHCUC,$P(PRCHC(0),U,15)=PRCHCDC,$P(PRCHC(0),U,16)=PRCHSKU,$P(PRCHC(0),U,17)=PRCHSKM
 ;S $P(PRCHC(4),U,12)=PRCHFGRP
 S $P(PRCHC(4),U,11)=PRCHDRTY
 S:PRCHCVS'="" $P(PRCHC(0),U,6)=PRCHCVS S:PRCHCNS'="" $P(PRCHC(0),U,13)=PRCHCNS
 S $P(PRCHC(2),U,1)=PRCHCQ*PRCHCUC,$P(PRCHC(2),U,2)=PRCHCCN,$P(PRCHC(2),U,3)=PRCHCSC,^PRC(443.6,DA(1),2,DA,0)=PRCHC(0),^(2)=PRCHC(2),^(4)=PRCHC(4)
 S:PRCHCCN]"" ^PRC(443.6,DA(1),2,"AC",$E(PRCHCCN,1,30),DA)="" K ^PRC(443.6,DA(1),2,DA,1) D %XY^%RCR L -^PRC(441,PRCHCI,2,PRCHCV) G Q
Q K PRCHC,PRCHCCN,PRCHCCP,PRCHCDC,PRCHCI,PRCHCMX,PRCHCNS,PRCHCPD,PRCHCPK,PRCHCPO,PRCHCQ,PRCHCS,PRCHCSB,PRCHCSC,PRCHCUC,PRCHCUP,PRCHCV,PRCHCVS,PRCHCX,PRCHCY,PRCHSKM,PRCHSKU,PRCHFGRP
 Q
 ;
EN1 ;THIS ENTRY POINT IS CALLED FROM THE INPUT TRANSFORM OF THE BOC FIELD, #.01, IN THE BOC MULTIPLE, FIELD 41.
 K DD,DO S ZD=D,ZDO=$G(DO),ZDO(2)=$G(DO(2)),ZDIC=$G(DIC),ZDIC(0)=$G(DIC(0)),ZDIX=$G(DIX),DIC="^PRC(442,"_DA_",2,",DIC(0)="AEMQZ",D="D"
 D IX^DIC K DIC S X=$P(Y(0),"^",4),D=ZD,DO=ZDO,DO(2)=ZDO(2),DIC=ZDIC,DIC(0)=ZDIC(0),DIX=ZDIX K:X="" X K Y,ZD,ZDO,ZDIC,ZDIX
 Q
 ;
EN2 ;THIS ENTRY POINT COMES FROM THE XECUTABLE 'HELP' SECTION OF THE BOC FIELD.  SEE EN1 TO LOCATE THIS FIELD.
 K DD,DO S ZD=D,ZDO=$G(DO),ZDO(2)=$G(DO(2)),ZDIC=$G(DIC),ZDIC(0)=$G(DIC(0)),ZDIX=$G(DIX),X="?",DIC="^PRC(442,"_DA_",2,",DIC(0)="EZ",D="D"
 D IX^DIC K DIC S:+Y>0 X=$P(Y(0),"^",4) S D=ZD,DO=ZDO,DO(2)=ZDO(2),DIC=ZDIC,DIC(0)=ZDIC(0),DIX=ZDIX K Y,ZD,ZDO,ZDIC,ZDIX
 Q
 ;
EN5 ;FILE 443.6, REPETITIVE (PR CARD) NO. #1.5
 I $P(^PRC(443.6,DA(1),0),U,3)=""!($P(^(1),U,1)="") W !!,"Fund Control Point and Vendor must be entered before items !",$C(7) K X Q
 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(443.6,DA(1),0)
 Q
 ;