- 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 Mar 13, 2025@21:11:02 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 ;
