PRCHCRD1 ;WISC/DJM,ID/RSD-EDIT OF PR CARDS ;5/3/96 9:29 AM [5/12/98 4:21pm]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN7 ;Edit packaging multiple from file 442 to 441
Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,8)=X G Q
EN8 ;Move FSC from file 442 (P.O.) to 441 (Item Master)
S $P(^PRC(441,+PRCHCI,0),U,3)=X G Q
EN9 ;Move MAX.ORD.QTY.from file 442 to 441
Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,9)=X G Q
EN10 ;Edit SKU from file 442 to 441
Q:'$D(^PRC(441,+PRCHCI,3)) S $P(^(3),U,8)=X G Q
EN11 ;Edit UNIT CONVERSION FACTOR from file 442 to 441
Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,10)=X G Q
EN12 ;Edit NATIONAL DRUG CODE from file 442 to 441
Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,5)=X G Q
EN13 ;Edit BOC from file 442 to 441
;Q:'$D(^PRC(441,+PRCHCI,0)) S $P(^(0),U,10)=PRCHBOC G Q
G Q
LST ;ENTERED FROM LAST LINE OF "EN3^PRCHCRD"
D VEN
S PRCHCY=^PRC(441,PRCHCI,0)
S PRCHCNS=$P(PRCHCY,U,5) ;NATIONAL STOCK NUMBER (NSN)
S PRCHCSC=$P(PRCHCY,U,3) ;FEDERAL SUPPLY CLASSIFICATION (FSC)
S PRCHCSB=+$P(PRCHCY,U,10) ;BUDGET OBJECT CODE (BOC)
I PRCHCSB=0 S PRCHCSB=""
S PRCHCC=+$P($G(^PRC(442,DA(1),0)),U,5) ;COST CENTER
I PRCHCSB>0,($G(^PRCD(420.1,PRCHCC,1,PRCHCSB,0))="") S PRCHCSB=""
I PRCHCSB>0 S PRCHCSB=$P(^PRCD(420.2,PRCHCSB,0),U,1)
S PRCHCY=^PRC(441,PRCHCI,2,PRCHCV,0) ;VENDOR MULTIPLE
S PRCHCVS=$P(PRCHCY,U,4) ;VENDOR STOCK #
S PRCHCDC=$P(PRCHCY,U,5) ;NATIONAL DRUG CODE (NDC)
S PRCHCUC=$P(PRCHCY,U,2) S:$G(PRCHPHAM) PRCHCUC=0 ;UNIT COST
S PRCHCCN=$P(PRCHCY,U,3) ;CONTRACT
S PRCHCUP=$P(PRCHCY,U,7) ;UNIT OF PURCHASE
S PRCHCPK=$P(PRCHCY,U,8) ;PACKAGING MULTIPLE
S PRCHCMX=$P(PRCHCY,U,9) ;MAXIMUM ORDER QUANTITY
S PRCHSKM=$P(PRCHCY,U,10) ;UNIT CONVERSION FACTOR
S PRCHHM=$P(PRCHCY,U,14) ;HAZARDOUS MATERIAL
S PRCHCY=$G(^PRC(441,PRCHCI,3))
S PRCHSKU=$P(PRCHCY,U,8) ;STOCK KEEPING UNIT (SKU)
S PRCHFGRP=$P(PRCHCY,U,7) ;FOOD GROUP
S PRCHDRTY=$P(PRCHCY,U,9) ;DRUG TYPE CODE
S PRCHCS=" "
S 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="" ;DESCRIPTION
S:PRCHCDC]"" PRCHC("%X",L,0)=" NDC:"_PRCHCDC,L=L+1 ;ADD IF NDC
S PRCHC("%X",0)="^^"_L_U_L_U_DT_U ;SET UP NODE 0 OF DESCRIPTION FOR MOVE
S %X="PRCHC(""%X"","
S %Y="^PRC(442,DA(1),2,DA,1,"
S:PRCHCCN]"" PRCHCY=$G(^PRC(440,PRCHCV,4,PRCHCCN,0)),PRCHCCN=$S($P(PRCHCY,U,2)>DT:$P(PRCHCY,U,1),1:"") ;CONTRACT NUMBER -- FROM FILE 440
S PRCHC(0)=^PRC(442,DA(1),2,DA,0)
S PRCHC(2)=""
S PRCHCQ=$P(PRCHC(0),U,2) ;QUANTITY
S:$D(^PRC(442,DA(1),2,DA,2)) PRCHC(2)=^PRC(442,DA(1),2,DA,2)
S PRCHC(4)=$G(^PRC(442,DA(1),2,DA,4))
S $P(PRCHC(0),U,3)=PRCHCUP ;UNIT OF PURCHASE
S $P(PRCHC(0),U,12)=PRCHCPK ;PACKAGING MULTIPLE
S $P(PRCHC(0),U,14)=PRCHCMX ;MAXIMUM ORDER QUANTITY
S:$P(PRCHC(0),U,4)="" $P(PRCHC(0),U,4)=PRCHCSB ;BOC
S $P(PRCHC(0),U,9)=PRCHCUC ;ACTUAL UNIT COST
S $P(PRCHC(0),U,15)=PRCHCDC ;NATIONAL DRUG CODE
S $P(PRCHC(0),U,16)=PRCHSKU ;STOCK KEEPING UNIT
S $P(PRCHC(0),U,17)=PRCHSKM ;UNIT CONVERSION FACTOR
S $P(PRCHC(4),U,12)=PRCHFGRP ;FOOD GROUP
S $P(PRCHC(4),U,11)=PRCHDRTY ;DRUG TYPE CODE
S:PRCHCVS'="" $P(PRCHC(0),U,6)=PRCHCVS ;VENDOR STOCK NUMBER
S:PRCHCNS'="" $P(PRCHC(0),U,13)=PRCHCNS ;NATIONAL STOCK NUMBER
S $P(PRCHC(2),U,1)=PRCHCQ*PRCHCUC ;TOTAL COST
S $P(PRCHC(2),U,2)=PRCHCCN ;CONTRACT #
S $P(PRCHC(2),U,3)=PRCHCSC ;FEDERAL SUPPLY CLASSIFICATION
S $P(PRCHC(2),U,14)=PRCHHM ;HAZARDOUS MATERIAL
S ^PRC(442,DA(1),2,DA,0)=PRCHC(0)
S ^PRC(442,DA(1),2,DA,2)=PRCHC(2)
S ^PRC(442,DA(1),2,DA,4)=PRCHC(4)
S:PRCHCSB]"" ^PRC(442,DA(1),2,"D",+PRCHCSB,DA)=""
S LIN=$P(^PRC(442,DA(1),2,DA,0),U)
S ^PRC(442,DA(1),2,"AH",+PRCHCSB,LIN,DA)=""
S:PRCHCCN]"" ^PRC(442,DA(1),2,"AC",$E(PRCHCCN,1,30),DA)=""
K ^PRC(442,DA(1),2,DA,1)
D %XY^%RCR ;MOVE DESCRIPTION TO FILE 442, ITEM MULTIPLE
;
;Release the lock on IMF applied in routine PRCHCRD, tag LCK.
L -^PRC(441,PRCHCI,0)
L -^PRC(441,PRCHCI,2,PRCHCV)
G Q
;
VEN I '$D(^PRC(441,PRCHCI,2)) S ^PRC(441,PRCHCI,2,0)="^441.01P^0^0"
I '$D(^PRC(441,PRCHCI,2,PRCHCV,0)) S ^(0)=PRCHCV,^PRC(441,PRCHCI,2,"B",PRCHCV,PRCHCV)="",$P(^(0),U,3,4)=PRCHCV_U_($P(^PRC(441,PRCHCI,2,0),U,4)+1)
L +^PRC(441,PRCHCI,2,PRCHCV):5 E W !!,$C(7),?5,"Another user is editing this entry, try later." Q
S $P(^PRC(441,PRCHCI,0),U,4)=PRCHCV
Q
Q K LIN,PRCHC,PRCHCCN,PRCHCCP,PRCHCDC,PRCHCI,PRCHCMX,PRCHCNS,PRCHCPD,PRCHCPK,PRCHCPO,PRCHCQ,PRCHCS,PRCHCSB,PRCHCSC,PRCHCUC,PRCHCUP,PRCHCV,PRCHCVS,PRCHCX,PRCHCY,PRCHSKM,PRCHSKU,PRCHFGRP,PRCHBOC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCRD1 4593 printed Oct 16, 2024@18:06:58 Page 2
PRCHCRD1 ;WISC/DJM,ID/RSD-EDIT OF PR CARDS ;5/3/96 9:29 AM [5/12/98 4:21pm]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN7 ;Edit packaging multiple from file 442 to 441
+1 if '$DATA(^PRC(441,+PRCHCI,2,PRCHCV,0))
QUIT
SET $PIECE(^(0),U,8)=X
GOTO Q
EN8 ;Move FSC from file 442 (P.O.) to 441 (Item Master)
+1 SET $PIECE(^PRC(441,+PRCHCI,0),U,3)=X
GOTO Q
EN9 ;Move MAX.ORD.QTY.from file 442 to 441
+1 if '$DATA(^PRC(441,+PRCHCI,2,PRCHCV,0))
QUIT
SET $PIECE(^(0),U,9)=X
GOTO Q
EN10 ;Edit SKU from file 442 to 441
+1 if '$DATA(^PRC(441,+PRCHCI,3))
QUIT
SET $PIECE(^(3),U,8)=X
GOTO Q
EN11 ;Edit UNIT CONVERSION FACTOR from file 442 to 441
+1 if '$DATA(^PRC(441,+PRCHCI,2,PRCHCV,0))
QUIT
SET $PIECE(^(0),U,10)=X
GOTO Q
EN12 ;Edit NATIONAL DRUG CODE from file 442 to 441
+1 if '$DATA(^PRC(441,+PRCHCI,2,PRCHCV,0))
QUIT
SET $PIECE(^(0),U,5)=X
GOTO Q
EN13 ;Edit BOC from file 442 to 441
+1 ;Q:'$D(^PRC(441,+PRCHCI,0)) S $P(^(0),U,10)=PRCHBOC G Q
+2 GOTO Q
LST ;ENTERED FROM LAST LINE OF "EN3^PRCHCRD"
+1 DO VEN
+2 SET PRCHCY=^PRC(441,PRCHCI,0)
+3 ;NATIONAL STOCK NUMBER (NSN)
SET PRCHCNS=$PIECE(PRCHCY,U,5)
+4 ;FEDERAL SUPPLY CLASSIFICATION (FSC)
SET PRCHCSC=$PIECE(PRCHCY,U,3)
+5 ;BUDGET OBJECT CODE (BOC)
SET PRCHCSB=+$PIECE(PRCHCY,U,10)
+6 IF PRCHCSB=0
SET PRCHCSB=""
+7 ;COST CENTER
SET PRCHCC=+$PIECE($GET(^PRC(442,DA(1),0)),U,5)
+8 IF PRCHCSB>0
IF ($GET(^PRCD(420.1,PRCHCC,1,PRCHCSB,0))="")
SET PRCHCSB=""
+9 IF PRCHCSB>0
SET PRCHCSB=$PIECE(^PRCD(420.2,PRCHCSB,0),U,1)
+10 ;VENDOR MULTIPLE
SET PRCHCY=^PRC(441,PRCHCI,2,PRCHCV,0)
+11 ;VENDOR STOCK #
SET PRCHCVS=$PIECE(PRCHCY,U,4)
+12 ;NATIONAL DRUG CODE (NDC)
SET PRCHCDC=$PIECE(PRCHCY,U,5)
+13 ;UNIT COST
SET PRCHCUC=$PIECE(PRCHCY,U,2)
if $GET(PRCHPHAM)
SET PRCHCUC=0
+14 ;CONTRACT
SET PRCHCCN=$PIECE(PRCHCY,U,3)
+15 ;UNIT OF PURCHASE
SET PRCHCUP=$PIECE(PRCHCY,U,7)
+16 ;PACKAGING MULTIPLE
SET PRCHCPK=$PIECE(PRCHCY,U,8)
+17 ;MAXIMUM ORDER QUANTITY
SET PRCHCMX=$PIECE(PRCHCY,U,9)
+18 ;UNIT CONVERSION FACTOR
SET PRCHSKM=$PIECE(PRCHCY,U,10)
+19 ;HAZARDOUS MATERIAL
SET PRCHHM=$PIECE(PRCHCY,U,14)
+20 SET PRCHCY=$GET(^PRC(441,PRCHCI,3))
+21 ;STOCK KEEPING UNIT (SKU)
SET PRCHSKU=$PIECE(PRCHCY,U,8)
+22 ;FOOD GROUP
SET PRCHFGRP=$PIECE(PRCHCY,U,7)
+23 ;DRUG TYPE CODE
SET PRCHDRTY=$PIECE(PRCHCY,U,9)
+24 SET PRCHCS=" "
+25 SET L=1
+26 ;DESCRIPTION
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=""
+27 ;ADD IF NDC
if PRCHCDC]""
SET PRCHC("%X",L,0)=" NDC:"_PRCHCDC
SET L=L+1
+28 ;SET UP NODE 0 OF DESCRIPTION FOR MOVE
SET PRCHC("%X",0)="^^"_L_U_L_U_DT_U
+29 SET %X="PRCHC(""%X"","
+30 SET %Y="^PRC(442,DA(1),2,DA,1,"
+31 ;CONTRACT NUMBER -- FROM FILE 440
if PRCHCCN]""
SET PRCHCY=$GET(^PRC(440,PRCHCV,4,PRCHCCN,0))
SET PRCHCCN=$SELECT($PIECE(PRCHCY,U,2)>DT:$PIECE(PRCHCY,U,1),1:"")
+32 SET PRCHC(0)=^PRC(442,DA(1),2,DA,0)
+33 SET PRCHC(2)=""
+34 ;QUANTITY
SET PRCHCQ=$PIECE(PRCHC(0),U,2)
+35 if $DATA(^PRC(442,DA(1),2,DA,2))
SET PRCHC(2)=^PRC(442,DA(1),2,DA,2)
+36 SET PRCHC(4)=$GET(^PRC(442,DA(1),2,DA,4))
+37 ;UNIT OF PURCHASE
SET $PIECE(PRCHC(0),U,3)=PRCHCUP
+38 ;PACKAGING MULTIPLE
SET $PIECE(PRCHC(0),U,12)=PRCHCPK
+39 ;MAXIMUM ORDER QUANTITY
SET $PIECE(PRCHC(0),U,14)=PRCHCMX
+40 ;BOC
if $PIECE(PRCHC(0),U,4)=""
SET $PIECE(PRCHC(0),U,4)=PRCHCSB
+41 ;ACTUAL UNIT COST
SET $PIECE(PRCHC(0),U,9)=PRCHCUC
+42 ;NATIONAL DRUG CODE
SET $PIECE(PRCHC(0),U,15)=PRCHCDC
+43 ;STOCK KEEPING UNIT
SET $PIECE(PRCHC(0),U,16)=PRCHSKU
+44 ;UNIT CONVERSION FACTOR
SET $PIECE(PRCHC(0),U,17)=PRCHSKM
+45 ;FOOD GROUP
SET $PIECE(PRCHC(4),U,12)=PRCHFGRP
+46 ;DRUG TYPE CODE
SET $PIECE(PRCHC(4),U,11)=PRCHDRTY
+47 ;VENDOR STOCK NUMBER
if PRCHCVS'=""
SET $PIECE(PRCHC(0),U,6)=PRCHCVS
+48 ;NATIONAL STOCK NUMBER
if PRCHCNS'=""
SET $PIECE(PRCHC(0),U,13)=PRCHCNS
+49 ;TOTAL COST
SET $PIECE(PRCHC(2),U,1)=PRCHCQ*PRCHCUC
+50 ;CONTRACT #
SET $PIECE(PRCHC(2),U,2)=PRCHCCN
+51 ;FEDERAL SUPPLY CLASSIFICATION
SET $PIECE(PRCHC(2),U,3)=PRCHCSC
+52 ;HAZARDOUS MATERIAL
SET $PIECE(PRCHC(2),U,14)=PRCHHM
+53 SET ^PRC(442,DA(1),2,DA,0)=PRCHC(0)
+54 SET ^PRC(442,DA(1),2,DA,2)=PRCHC(2)
+55 SET ^PRC(442,DA(1),2,DA,4)=PRCHC(4)
+56 if PRCHCSB]""
SET ^PRC(442,DA(1),2,"D",+PRCHCSB,DA)=""
+57 SET LIN=$PIECE(^PRC(442,DA(1),2,DA,0),U)
+58 SET ^PRC(442,DA(1),2,"AH",+PRCHCSB,LIN,DA)=""
+59 if PRCHCCN]""
SET ^PRC(442,DA(1),2,"AC",$EXTRACT(PRCHCCN,1,30),DA)=""
+60 KILL ^PRC(442,DA(1),2,DA,1)
+61 ;MOVE DESCRIPTION TO FILE 442, ITEM MULTIPLE
DO %XY^%RCR
+62 ;
+63 ;Release the lock on IMF applied in routine PRCHCRD, tag LCK.
+64 LOCK -^PRC(441,PRCHCI,0)
+65 LOCK -^PRC(441,PRCHCI,2,PRCHCV)
+66 GOTO Q
+67 ;
VEN IF '$DATA(^PRC(441,PRCHCI,2))
SET ^PRC(441,PRCHCI,2,0)="^441.01P^0^0"
+1 IF '$DATA(^PRC(441,PRCHCI,2,PRCHCV,0))
SET ^(0)=PRCHCV
SET ^PRC(441,PRCHCI,2,"B",PRCHCV,PRCHCV)=""
SET $PIECE(^(0),U,3,4)=PRCHCV_U_($PIECE(^PRC(441,PRCHCI,2,0),U,4)+1)
+2 LOCK +^PRC(441,PRCHCI,2,PRCHCV):5
IF '$TEST
WRITE !!,$CHAR(7),?5,"Another user is editing this entry, try later."
QUIT
+3 SET $PIECE(^PRC(441,PRCHCI,0),U,4)=PRCHCV
+4 QUIT
Q KILL LIN,PRCHC,PRCHCCN,PRCHCCP,PRCHCDC,PRCHCI,PRCHCMX,PRCHCNS,PRCHCPD,PRCHCPK,PRCHCPO,PRCHCQ,PRCHCS,PRCHCSB,PRCHCSC,PRCHCUC,PRCHCUP,PRCHCV,PRCHCVS,PRCHCX,PRCHCY,PRCHSKM,PRCHSKU,PRCHFGRP,PRCHBOC
+1 QUIT
