| [613] | 1 | PRCHCRD2 ;WISC/DJM-LINK ITEM FILE DATA INTO AMMENDMENT FILE ;1/11/94 11:55 AM [5/14/98 4:58pm]
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | LST ;ENTERED FROM SET 0F 'AD' X-REF ON 'REPETITIVE (PR CARD) NO. WITHIN 'ITEM' MULTIPLE
|
|---|
| 5 | L +^PRC(441,PRCHCI,2,PRCHCV):5 E W !!,$C(7),"Another user is editing this entry, try later." G Q
|
|---|
| 6 | 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)
|
|---|
| 7 | 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)
|
|---|
| 8 | S PRCHCY=$G(^PRC(441,PRCHCI,3)),PRCHSKU=$P(PRCHCY,U,8),PRCHFGRP=$P(PRCHCY,U,7),PRCHDRTY=$P(PRCHCY,U,9)
|
|---|
| 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=""
|
|---|
| 10 | S:PRCHCDC]"" PRCHC("%X",L,0)=" NDC:"_PRCHCDC,L=L+1
|
|---|
| 11 | S PRCHC("%X",0)="^^"_L_U_L_U_DT_U,%X="PRCHC(""%X"",",%Y="^PRC(443.6,PRCHCPO,2,PRCHCIT,1,"
|
|---|
| 12 | S:PRCHCCN]"" PRCHCY=$G(^PRC(440,PRCHCV,4,PRCHCCN,0)),PRCHCCN=$S($P(PRCHCY,U,2)>DT:$P(PRCHCY,U,1),1:"")
|
|---|
| 13 | 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))
|
|---|
| 14 | 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
|
|---|
| 15 | ;S $P(PRCHC(4),U,12)=PRCHFGRP
|
|---|
| 16 | S $P(PRCHC(4),U,11)=PRCHDRTY
|
|---|
| 17 | S:PRCHCVS'="" $P(PRCHC(0),U,6)=PRCHCVS S:PRCHCNS'="" $P(PRCHC(0),U,13)=PRCHCNS
|
|---|
| 18 | 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)
|
|---|
| 19 | 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
|
|---|
| 20 | 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
|
|---|
| 21 | Q
|
|---|
| 22 | ;
|
|---|
| 23 | EN1 ;THIS ENTRY POINT IS CALLED FROM THE INPUT TRANSFORM OF THE BOC FIELD, #.01, IN THE BOC MULTIPLE, FIELD 41.
|
|---|
| 24 | 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"
|
|---|
| 25 | 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
|
|---|
| 26 | Q
|
|---|
| 27 | ;
|
|---|
| 28 | EN2 ;THIS ENTRY POINT COMES FROM THE XECUTABLE 'HELP' SECTION OF THE BOC FIELD. SEE EN1 TO LOCATE THIS FIELD.
|
|---|
| 29 | 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"
|
|---|
| 30 | 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
|
|---|
| 31 | Q
|
|---|
| 32 | ;
|
|---|
| 33 | EN5 ;FILE 443.6, REPETITIVE (PR CARD) NO. #1.5
|
|---|
| 34 | 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
|
|---|
| 35 | S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(443.6,DA(1),0)
|
|---|
| 36 | Q
|
|---|
| 37 | ;
|
|---|
