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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCRD2 3213 printed Nov 22, 2024@17:16:20 Page 2
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
+1 ;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
+1 LOCK +^PRC(441,PRCHCI,2,PRCHCV):5
IF '$TEST
WRITE !!,$CHAR(7),"Another user is editing this entry, try later."
GOTO Q
+2 SET PRCHCY=$GET(^PRC(441,PRCHCI,0))
SET PRCHCNS=$PIECE(PRCHCY,U,5)
SET PRCHCSC=$PIECE(PRCHCY,U,3)
SET PRCHCSB=$PIECE(PRCHCY,U,10)
if $GET(PRCHCSB)
SET PRCHCSB=$PIECE($GET(^PRCD(420.2,PRCHCSB,0)),U,1)
+3 SET PRCHCY=$GET(^PRC(441,PRCHCI,2,PRCHCV,0))
SET PRCHCVS=$PIECE(PRCHCY,U,4)
SET PRCHCDC=$PIECE(PRCHCY,U,5)
SET PRCHCUC=$PIECE(PRCHCY,U,2)
SET PRCHCCN=$PIECE(PRCHCY,U,3)
SET PRCHCUP=$PIECE(PRCHCY,U,7)
SET PRCHCPK=$PIECE(PRCHCY,U,8)
SET PRCHCMX=$PIECE(PRCHCY,U,9)
SET PRCHSKM=$PIECE(PRCHCY,U,10)
+4 SET PRCHCY=$GET(^PRC(441,PRCHCI,3))
SET PRCHSKU=$PIECE(PRCHCY,U,8)
SET PRCHFGRP=$PIECE(PRCHCY,U,7)
SET PRCHDRTY=$PIECE(PRCHCY,U,9)
+5 SET PRCHCS=" "
SET L=1
FOR M=0:0
SET M=$ORDER(^PRC(441,PRCHCI,1,M))
if M'>0
QUIT
SET PRCHC("%X",L,0)=PRCHCS_^(M,0)
SET L=L+1
SET PRCHCS=""
+6 if PRCHCDC]""
SET PRCHC("%X",L,0)=" NDC:"_PRCHCDC
SET L=L+1
+7 SET PRCHC("%X",0)="^^"_L_U_L_U_DT_U
SET %X="PRCHC(""%X"","
SET %Y="^PRC(443.6,PRCHCPO,2,PRCHCIT,1,"
+8 if PRCHCCN]""
SET PRCHCY=$GET(^PRC(440,PRCHCV,4,PRCHCCN,0))
SET PRCHCCN=$SELECT($PIECE(PRCHCY,U,2)>DT:$PIECE(PRCHCY,U,1),1:"")
+9 SET PRCHC(0)=^PRC(443.6,DA(1),2,DA,0)
SET PRCHC(2)=""
SET PRCHCQ=$PIECE(PRCHC(0),U,2)
if $DATA(^(2))
SET PRCHC(2)=^(2)
SET PRCHC(4)=$GET(^(4))
+10 SET $PIECE(PRCHC(0),U,3)=PRCHCUP
SET $PIECE(PRCHC(0),U,12)=PRCHCPK
SET $PIECE(PRCHC(0),U,14)=PRCHCMX
if $PIECE(PRCHC(0),U,4)=""
SET $PIECE(PRCHC(0),U,4)=PRCHCSB
SET $PIECE(PRCHC(0),U,9)=PRCHCUC
SET $PIECE(PRCHC(0),U,15)=PRCHCDC
SET $PIECE(PRCHC(0),U,16)=PRCHSKU
SET $PIECE(PRCHC(0),U,17)=PRCHSKM
+11 ;S $P(PRCHC(4),U,12)=PRCHFGRP
+12 SET $PIECE(PRCHC(4),U,11)=PRCHDRTY
+13 if PRCHCVS'=""
SET $PIECE(PRCHC(0),U,6)=PRCHCVS
if PRCHCNS'=""
SET $PIECE(PRCHC(0),U,13)=PRCHCNS
+14 SET $PIECE(PRCHC(2),U,1)=PRCHCQ*PRCHCUC
SET $PIECE(PRCHC(2),U,2)=PRCHCCN
SET $PIECE(PRCHC(2),U,3)=PRCHCSC
SET ^PRC(443.6,DA(1),2,DA,0)=PRCHC(0)
SET ^(2)=PRCHC(2)
SET ^(4)=PRCHC(4)
+15 if PRCHCCN]""
SET ^PRC(443.6,DA(1),2,"AC",$EXTRACT(PRCHCCN,1,30),DA)=""
KILL ^PRC(443.6,DA(1),2,DA,1)
DO %XY^%RCR
LOCK -^PRC(441,PRCHCI,2,PRCHCV)
GOTO Q
Q KILL PRCHC,PRCHCCN,PRCHCCP,PRCHCDC,PRCHCI,PRCHCMX,PRCHCNS,PRCHCPD,PRCHCPK,PRCHCPO,PRCHCQ,PRCHCS,PRCHCSB,PRCHCSC,PRCHCUC,PRCHCUP,PRCHCV,PRCHCVS,PRCHCX,PRCHCY,PRCHSKM,PRCHSKU,PRCHFGRP
+1 QUIT
+2 ;
EN1 ;THIS ENTRY POINT IS CALLED FROM THE INPUT TRANSFORM OF THE BOC FIELD, #.01, IN THE BOC MULTIPLE, FIELD 41.
+1 KILL DD,DO
SET ZD=D
SET ZDO=$GET(DO)
SET ZDO(2)=$GET(DO(2))
SET ZDIC=$GET(DIC)
SET ZDIC(0)=$GET(DIC(0))
SET ZDIX=$GET(DIX)
SET DIC="^PRC(442,"_DA_",2,"
SET DIC(0)="AEMQZ"
SET D="D"
+2 DO IX^DIC
KILL DIC
SET X=$PIECE(Y(0),"^",4)
SET D=ZD
SET DO=ZDO
SET DO(2)=ZDO(2)
SET DIC=ZDIC
SET DIC(0)=ZDIC(0)
SET DIX=ZDIX
if X=""
KILL X
KILL Y,ZD,ZDO,ZDIC,ZDIX
+3 QUIT
+4 ;
EN2 ;THIS ENTRY POINT COMES FROM THE XECUTABLE 'HELP' SECTION OF THE BOC FIELD. SEE EN1 TO LOCATE THIS FIELD.
+1 KILL DD,DO
SET ZD=D
SET ZDO=$GET(DO)
SET ZDO(2)=$GET(DO(2))
SET ZDIC=$GET(DIC)
SET ZDIC(0)=$GET(DIC(0))
SET ZDIX=$GET(DIX)
SET X="?"
SET DIC="^PRC(442,"_DA_",2,"
SET DIC(0)="EZ"
SET D="D"
+2 DO IX^DIC
KILL DIC
if +Y>0
SET X=$PIECE(Y(0),"^",4)
SET D=ZD
SET DO=ZDO
SET DO(2)=ZDO(2)
SET DIC=ZDIC
SET DIC(0)=ZDIC(0)
SET DIX=ZDIX
KILL Y,ZD,ZDO,ZDIC,ZDIX
+3 QUIT
+4 ;
EN5 ;FILE 443.6, REPETITIVE (PR CARD) NO. #1.5
+1 IF $PIECE(^PRC(443.6,DA(1),0),U,3)=""!($PIECE(^(1),U,1)="")
WRITE !!,"Fund Control Point and Vendor must be entered before items !",$CHAR(7)
KILL X
QUIT
+2 if '$DATA(PRC("SITE"))
SET PRC("SITE")=+^PRC(443.6,DA(1),0)
+3 QUIT
+4 ;
