- PRCHCRD3 ;WISC/DJM-LINK REPETITIVE ITEM DATA TO P.O.ITEM DATA-AFTER AMENDMENT ;6/24/94 9:28 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN3 ; Move Repetitive Item data to file 442, adds FCP to file 441.
- ; Called from OTHER^PRCHAMYD.
- ;
- ; PRCHCCP=FUND CONTROL POINT
- ; PRCHCV=VENDOR
- ; PRCHCPD=P.O. DATE
- ; PRCHCI=ITEM MASTER FILE NUMBER
- ; PRCHPO=P.O. RECORD NUMBER
- ; ITEM0=ITEM NODE 0 DATA
- ; ITEM2=ITEM NODE 2 DATA
- ; ITVEN0=VENDOR NODE 0 FROM FILE 441-VENDOR MULTIPLE
- ;
- N PO0,PO1,PRCHCPD,PRCHCCP,PRCHCI,PRCHCV,PRCHCX,ITEM0,ITEM2,ITVEN0,X,Z
- S PO0=$G(^PRC(442,PRCHPO,0)),PO1=$G(^PRC(442,PRCHPO,1)),PRCHCPD=+$P(PO1,U,15),PRCHCCP=$P($P(PO0,U,3)," ",1),PRCHCV=$P(PO1,U)
- S PRCHCI=$P($G(^PRC(442,PRCHPO,2,IMF1,0)),U,5)
- ;
- S PRCHCX=PRC("SITE")_PRCHCCP D I $G(^PRC(441,PRCHCI,4,PRCHCX,1,0))="" S ^PRC(441,PRCHCI,4,PRCHCX,1,0)="^"_$P(^DD(441.03,1,0),U,2)_"^0^0"
- .I '$D(^PRC(441,PRCHCI,4)) S ^PRC(441,PRCHCI,4,0)="^"_$P(^DD(441,1,0),U,2)_"^0^0"
- .I '$D(^PRC(441,PRCHCI,4,PRCHCX,0)) S ^(0)=PRCHCX,^PRC(441,PRCHCI,4,"B",PRCHCX,PRCHCX)="",$P(^(0),U,3,4)=PRCHCX_U_($P(^PRC(441,PRCHCI,4,0),U,4)+1)
- ;
- S:'$D(^PRC(441,PRCHCI,4,PRCHCX,1,PRCHPO,0)) ^(0)=PRCHPO,^PRC(441,PRCHCI,4,PRCHCX,1,"AC",9999999-PRCHCPD,PRCHPO)="",$P(^(0),U,3,4)=PRCHPO_U_($P(^PRC(441,PRCHCI,4,PRCHCX,1,0),U,4)+1)
- ;
- I '$D(^PRC(441,PRCHCI,2)) S ^PRC(441,PRCHCI,2,0)="^"_$P(^DD(441,6,0),U,2)_"^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 I '$T Q
- S $P(^PRC(441,PRCHCI,0),U,4)=PRCHCV
- ;
- S ITEM0=$G(^PRC(442,PRCHPO,2,IMF1,0))
- S ITEM2=$G(^PRC(442,PRCHPO,2,IMF1,2))
- S ITVEN0=$G(^PRC(441,+PRCHCI,2,PRCHCV,0))
- ;
- ; UNIT OF PURCHASE
- S X=$P(ITEM0,U,3) I X]"" S $P(ITVEN0,U,7)=X
- ;
- ;ACTUAL UNIT COST and DATE OF UNIT PRICE
- S X=$P(ITEM0,U,9) I X]"" S $P(ITVEN0,U,2)=X,$P(ITVEN0,U,6)=$G(DT)
- ;
- ; NATIONAL STOCK NUMBER
- S X=$P(ITEM0,U,13) D:X]""
- .I $P(^PRC(441,+PRCHCI,0),U,5)]"" S Z=$P(^(0),U,5),Z(1)=$P(Z,"-",3,4),Z(2)=$E(Z,4)_$P(Z,"-",2)_$P(Z,"-",3)_$P(Z,"-",4) K ^PRC(441,"BB",Z,+PRCHCI) K:Z(1)]"" ^PRC(441,"BA",Z(1),+PRCHCI) K:Z(2)]"" ^PRC(441,"G",Z(2),+PRCHCI)
- .S Z(1)=$P(X,"-",3,4),Z(2)=$E(X,4)_$P(X,"-",2)_$P(X,"-",3)_$P(X,"-",4)
- .S ^PRC(441,"BB",X,+PRCHCI)="" S:Z(1)]"" ^PRC(441,"BA",Z(1),+PRCHCI)=""
- .S:Z(2)]"" ^PRC(441,"G",Z(2),+PRCHCI)=""
- .S $P(^PRC(441,+PRCHCI,0),U,5)=X
- ;
- ; VENDOR STOCK NUMBER
- S X=$P(ITEM0,U,6) D:X]""
- .I $P(ITVEN0,U,4)]"" K ^PRC(441,"D",$P(ITVEN0,U,4),+PRCHCI,PRCHCV)
- .S $P(ITVEN0,U,4)=X,^PRC(441,"D",X,+PRCHCI,PRCHCV)=""
- ;
- ; CONTRACT NUMBER
- S X=$P(ITEM2,U,2) I X]"" S X=$O(^PRC(440,PRCHCV,4,"B",X,0)) S:X>0 $P(ITVEN0,U,3)=X
- ;
- ; PACKAGING MULTIPLE
- S X=$P(ITEM0,U,12) S:X]"" $P(ITVEN0,U,8)=X
- ;
- ; FEDERAL SUPPLY CLASSIFICATION
- S X=$P(ITEM2,U,3) S:X]"" $P(^PRC(441,+PRCHCI,0),U,3)=X
- ;
- ; MAXIMUM ORDER QUANTITY
- S X=$P(ITEM0,U,14) S:X]"" $P(ITVEN0,U,9)=X
- ;
- ; STOCK KEEPING UNIT
- S X=$P(ITEM0,U,16) S:X]"" $P(^PRC(441,+PRCHCI,3),U,8)=X
- ;
- ; UNIT CONVERSION FACTOR
- S X=$P(ITEM0,U,17) S:X]"" $P(ITVEN0,U,10)=X
- ;
- ; NATIONAL DRUG CODE
- S X=$P(ITEM0,U,15) S:X]"" $P(ITVEN0,U,5)=X
- ;
- ; BOC
- ;S X=+$P(ITEM0,U,4) S:X]"" $P(^PRC(441,PRCHCI,0),U,10)=X
- ;
- ; NOW SAVE ITVEN0
- S ^PRC(441,+PRCHCI,2,PRCHCV,0)=ITVEN0
- L -^PRC(441,PRCHCI,2,PRCHCV)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCRD3 3430 printed Feb 18, 2025@23:32:38 Page 2
- PRCHCRD3 ;WISC/DJM-LINK REPETITIVE ITEM DATA TO P.O.ITEM DATA-AFTER AMENDMENT ;6/24/94 9:28 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN3 ; Move Repetitive Item data to file 442, adds FCP to file 441.
- +1 ; Called from OTHER^PRCHAMYD.
- +2 ;
- +3 ; PRCHCCP=FUND CONTROL POINT
- +4 ; PRCHCV=VENDOR
- +5 ; PRCHCPD=P.O. DATE
- +6 ; PRCHCI=ITEM MASTER FILE NUMBER
- +7 ; PRCHPO=P.O. RECORD NUMBER
- +8 ; ITEM0=ITEM NODE 0 DATA
- +9 ; ITEM2=ITEM NODE 2 DATA
- +10 ; ITVEN0=VENDOR NODE 0 FROM FILE 441-VENDOR MULTIPLE
- +11 ;
- +12 NEW PO0,PO1,PRCHCPD,PRCHCCP,PRCHCI,PRCHCV,PRCHCX,ITEM0,ITEM2,ITVEN0,X,Z
- +13 SET PO0=$GET(^PRC(442,PRCHPO,0))
- SET PO1=$GET(^PRC(442,PRCHPO,1))
- SET PRCHCPD=+$PIECE(PO1,U,15)
- SET PRCHCCP=$PIECE($PIECE(PO0,U,3)," ",1)
- SET PRCHCV=$PIECE(PO1,U)
- +14 SET PRCHCI=$PIECE($GET(^PRC(442,PRCHPO,2,IMF1,0)),U,5)
- +15 ;
- +16 SET PRCHCX=PRC("SITE")_PRCHCCP
- Begin DoDot:1
- +17 IF '$DATA(^PRC(441,PRCHCI,4))
- SET ^PRC(441,PRCHCI,4,0)="^"_$PIECE(^DD(441,1,0),U,2)_"^0^0"
- +18 IF '$DATA(^PRC(441,PRCHCI,4,PRCHCX,0))
- SET ^(0)=PRCHCX
- SET ^PRC(441,PRCHCI,4,"B",PRCHCX,PRCHCX)=""
- SET $PIECE(^(0),U,3,4)=PRCHCX_U_($PIECE(^PRC(441,PRCHCI,4,0),U,4)+1)
- End DoDot:1
- IF $GET(^PRC(441,PRCHCI,4,PRCHCX,1,0))=""
- SET ^PRC(441,PRCHCI,4,PRCHCX,1,0)="^"_$PIECE(^DD(441.03,1,0),U,2)_"^0^0"
- +19 ;
- +20 if '$DATA(^PRC(441,PRCHCI,4,PRCHCX,1,PRCHPO,0))
- SET ^(0)=PRCHPO
- SET ^PRC(441,PRCHCI,4,PRCHCX,1,"AC",9999999-PRCHCPD,PRCHPO)=""
- SET $PIECE(^(0),U,3,4)=PRCHPO_U_($PIECE(^PRC(441,PRCHCI,4,PRCHCX,1,0),U,4)+1)
- +21 ;
- +22 IF '$DATA(^PRC(441,PRCHCI,2))
- SET ^PRC(441,PRCHCI,2,0)="^"_$PIECE(^DD(441,6,0),U,2)_"^0^0"
- +23 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)
- +24 LOCK +^PRC(441,PRCHCI,2,PRCHCV):5
- IF '$TEST
- QUIT
- +25 SET $PIECE(^PRC(441,PRCHCI,0),U,4)=PRCHCV
- +26 ;
- +27 SET ITEM0=$GET(^PRC(442,PRCHPO,2,IMF1,0))
- +28 SET ITEM2=$GET(^PRC(442,PRCHPO,2,IMF1,2))
- +29 SET ITVEN0=$GET(^PRC(441,+PRCHCI,2,PRCHCV,0))
- +30 ;
- +31 ; UNIT OF PURCHASE
- +32 SET X=$PIECE(ITEM0,U,3)
- IF X]""
- SET $PIECE(ITVEN0,U,7)=X
- +33 ;
- +34 ;ACTUAL UNIT COST and DATE OF UNIT PRICE
- +35 SET X=$PIECE(ITEM0,U,9)
- IF X]""
- SET $PIECE(ITVEN0,U,2)=X
- SET $PIECE(ITVEN0,U,6)=$GET(DT)
- +36 ;
- +37 ; NATIONAL STOCK NUMBER
- +38 SET X=$PIECE(ITEM0,U,13)
- if X]""
- Begin DoDot:1
- +39 IF $PIECE(^PRC(441,+PRCHCI,0),U,5)]""
- SET Z=$PIECE(^(0),U,5)
- SET Z(1)=$PIECE(Z,"-",3,4)
- SET Z(2)=$EXTRACT(Z,4)_$PIECE(Z,"-",2)_$PIECE(Z,"-",3)_$PIECE(Z,"-",4)
- KILL ^PRC(441,"BB",Z,+PRCHCI)
- if Z(1)]""
- KILL ^PRC(441,"BA",Z(1),+PRCHCI)
- if Z(2)]""
- KILL ^PRC(441,"G",Z(2),+PRCHCI)
- +40 SET Z(1)=$PIECE(X,"-",3,4)
- SET Z(2)=$EXTRACT(X,4)_$PIECE(X,"-",2)_$PIECE(X,"-",3)_$PIECE(X,"-",4)
- +41 SET ^PRC(441,"BB",X,+PRCHCI)=""
- if Z(1)]""
- SET ^PRC(441,"BA",Z(1),+PRCHCI)=""
- +42 if Z(2)]""
- SET ^PRC(441,"G",Z(2),+PRCHCI)=""
- +43 SET $PIECE(^PRC(441,+PRCHCI,0),U,5)=X
- End DoDot:1
- +44 ;
- +45 ; VENDOR STOCK NUMBER
- +46 SET X=$PIECE(ITEM0,U,6)
- if X]""
- Begin DoDot:1
- +47 IF $PIECE(ITVEN0,U,4)]""
- KILL ^PRC(441,"D",$PIECE(ITVEN0,U,4),+PRCHCI,PRCHCV)
- +48 SET $PIECE(ITVEN0,U,4)=X
- SET ^PRC(441,"D",X,+PRCHCI,PRCHCV)=""
- End DoDot:1
- +49 ;
- +50 ; CONTRACT NUMBER
- +51 SET X=$PIECE(ITEM2,U,2)
- IF X]""
- SET X=$ORDER(^PRC(440,PRCHCV,4,"B",X,0))
- if X>0
- SET $PIECE(ITVEN0,U,3)=X
- +52 ;
- +53 ; PACKAGING MULTIPLE
- +54 SET X=$PIECE(ITEM0,U,12)
- if X]""
- SET $PIECE(ITVEN0,U,8)=X
- +55 ;
- +56 ; FEDERAL SUPPLY CLASSIFICATION
- +57 SET X=$PIECE(ITEM2,U,3)
- if X]""
- SET $PIECE(^PRC(441,+PRCHCI,0),U,3)=X
- +58 ;
- +59 ; MAXIMUM ORDER QUANTITY
- +60 SET X=$PIECE(ITEM0,U,14)
- if X]""
- SET $PIECE(ITVEN0,U,9)=X
- +61 ;
- +62 ; STOCK KEEPING UNIT
- +63 SET X=$PIECE(ITEM0,U,16)
- if X]""
- SET $PIECE(^PRC(441,+PRCHCI,3),U,8)=X
- +64 ;
- +65 ; UNIT CONVERSION FACTOR
- +66 SET X=$PIECE(ITEM0,U,17)
- if X]""
- SET $PIECE(ITVEN0,U,10)=X
- +67 ;
- +68 ; NATIONAL DRUG CODE
- +69 SET X=$PIECE(ITEM0,U,15)
- if X]""
- SET $PIECE(ITVEN0,U,5)=X
- +70 ;
- +71 ; BOC
- +72 ;S X=+$P(ITEM0,U,4) S:X]"" $P(^PRC(441,PRCHCI,0),U,10)=X
- +73 ;
- +74 ; NOW SAVE ITVEN0
- +75 SET ^PRC(441,+PRCHCI,2,PRCHCV,0)=ITVEN0
- +76 LOCK -^PRC(441,PRCHCI,2,PRCHCV)
- +77 QUIT