- 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 Feb 18, 2025@23:32:36 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