PRCHITM5 ;OI&T/LKG - FILING DATA FROM NIF ;5/25/17 16:10
;;5.1;IFCAP;**198**;OCT 20, 2000;Build 6
;Per VA Directive 6402, this routine should not be modified.
;Integration agreements
; ICR #2051 FIND^DIC(), $$FIND1()^DIC
; ICR #2053 FILE^DIE(), UPDATE^DIE(), WP^DIE()
; ICR #2054 DT^DILF(), CLEAN^DILF
; ICR #2056 GETS^DIQ(), $$GET1^DIQ()
; ICR #10000 C^%DTC
; ICR #10103 $$DT^XLFDT
; ICR #10104 $$UP^XLFSTR()
Q
FILE(PRCTRANNBR,PRCLINE,PRCITMC) ;
N PRCCONTR,PRCIMF,PRCVEN,PRCNITM,PRCJ S PRCITMC=0
D GETVEN(.PRCVEN) I PRCVEN=0 D ERR("Vendor not resolved for ST #"_PRCTRANNBR_" Line #"_PRCLINE_".") Q
D GETITEM(.PRCIMF,.PRCNITM) I PRCIMF=0 D ERR("Item not resolved for ST #"_PRCTRANNBR_" Line #"_PRCLINE_".") Q
S PRCJ=""
F S PRCJ=$O(PRCIMF(PRCJ)) Q:PRCJ="" D
. D ITEMFILE(PRCIMF(PRCJ),PRCVEN(1),PRCNITM) S PRCITMC=PRCITMC+1
Q
;
ITEMFILE(PRCITMIEN,PRCVEND,PRCADDED) ;
N PRCARR,PRCERR,PRCNEW,PRCX,PRCVENSK S PRCVENSK=0
S PRCNEW=$S('$D(^PRC(441,PRCITMIEN,2,PRCVEND)):1,1:0) ; New vendor multiple entry
D:'PRCADDED BACKUP(PRCITMIEN)
I $G(^TMP($J,"PRCHITM3","ITEM","FSC"))=6505!($P($G(^TMP($J,"PRCHITM3","ITEM","NSN")),"-")=6505) D
. I $G(^TMP($J,"PRCHITM3","ITEM","DRUG TYPE"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_PRCITMIEN_" is missing Drug Type although FSC 6505.")
S PRCITMIEN=PRCITMIEN_","
K PRCARR,PRCERR S PRCARR(441,PRCITMIEN,53)=$$DT^XLFDT
D FILE^DIE("","PRCARR","PRCERR") K PRCARR,PRCERR
I $G(^TMP($J,"PRCHITM3","ITEM","BOC"))'="" S PRCX=^("BOC") D
. I '$D(^PRCD(420.2,PRCX,0)) D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",")_" BOC "_PRCX_" does not exist in file #420.2.") Q
. N PRCARR,PRCERR
. S PRCARR(441,PRCITMIEN,12)=PRCX
. D FILE^DIE("K","PRCARR","PRCERR")
. D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$P(PRCITMIEN,","))
I 'PRCADDED D
. S:$G(^TMP($J,"PRCHITM3","ITEM","NIF#"))'="" PRCARR(441,PRCITMIEN,51)=^("NIF#")
. S:$G(^TMP($J,"PRCHITM3","ITEM","FSC"))'="" PRCARR(441,PRCITMIEN,2)=^("FSC")
. S:$G(^TMP($J,"PRCHITM3","ITEM","SHORT DESC"))'="" PRCARR(441,PRCITMIEN,.05)=$$UP^XLFSTR(^("SHORT DESC"))
S:$G(^TMP($J,"PRCHITM3","ITEM","NSN"))'="" PRCARR(441,PRCITMIEN,5)=^("NSN")
S:$G(^TMP($J,"PRCHITM3","ITEM","MFG PART"))'="" PRCARR(441,PRCITMIEN,19)=^("MFG PART")
S:$G(^TMP($J,"PRCHITM3","ITEM","STOCK KEEPING UNIT"))'="" PRCARR(441,PRCITMIEN,21)=^("STOCK KEEPING UNIT")
S:$G(^TMP($J,"PRCHITM3","ITEM","DRUG TYPE"))'="" PRCARR(441,PRCITMIEN,22)=^("DRUG TYPE")
S:$G(^TMP($J,"PRCHITM3","ITEM","MANUFACTURER"))'="" PRCARR(441,PRCITMIEN,25)=$$UP^XLFSTR(^("MANUFACTURER"))
S:$G(^TMP($J,"PRCHITM3","ITEM","SOURCE MFG PART#"))'="" PRCARR(441,PRCITMIEN,19.1)=^("SOURCE MFG PART#")
S:$G(^TMP($J,"PRCHITM3","ITEM","NIF UPDATE DATE"))'="" PRCARR(441,PRCITMIEN,54)=$$DT2FMD(^("NIF UPDATE DATE"))
D FILE^DIE("EK","PRCARR","PRCERR")
D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$P(PRCITMIEN,",")) K PRCARR,PRCERR
I '$D(^TMP($J,"PRCHITM3","ITEM","LONG DESC")) D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",")_" is missing Long Desc.")
I $D(^TMP($J,"PRCHITM3","ITEM","LONG DESC")) D
. D WP^DIE(441,PRCITMIEN,.1,"K","^TMP($J,""PRCHITM3"",""ITEM"",""LONG DESC"")","PRCERR")
. D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$P(PRCITMIEN,","))
. K PRCARR,PRCERR
; Update supply stations
I $O(^PRCP(445,"AH",$P(PRCITMIEN,","),""))]"" D BLDSEG^PRCPHLFM(3,$P(PRCITMIEN,","),0)
D SYNONYM(PRCITMIEN)
I PRCNEW D
. N PRCIEN S PRCIEN(2)=PRCVEND
. S PRCARR(441.01,"+2,"_PRCITMIEN,.01)=PRCVEND
. S:$G(^TMP($J,"PRCHITM3","ITEM","UOP"))'="" PRCARR(441.01,"+2,"_PRCITMIEN,1.5)=^("UOP")
. S:$G(^TMP($J,"PRCHITM3","ITEM","UNIT COST"))'="" PRCARR(441.01,"+2,"_PRCITMIEN,1)=^("UNIT COST")
. S:$G(^TMP($J,"PRCHITM3","ITEM","PKG MULT"))'="" PRCARR(441.01,"+2,"_PRCITMIEN,1.6)=^("PKG MULT")
. S:$G(^TMP($J,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR"))'="" PRCARR(441.01,"+2,"_PRCITMIEN,10)=^("UNIT CONVERSION FACTOR")
. D UPDATE^DIE("E","PRCARR","PRCIEN","PRCERR")
. I $D(PRCERR) D
. . D ERR("Problem adding vendor entry to item for ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",")_".") D PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$P(PRCITMIEN,",")) S PRCVENSK=1
. . I $G(^TMP($J,"PRCHITM3","ITEM","UOP"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",")_" is missing UOP.")
. . I $G(^TMP($J,"PRCHITM3","ITEM","UNIT COST"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",")_" is missing Unit Cost.")
. . I $G(^TMP($J,"PRCHITM3","ITEM","PKG MULT"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",")_" is missing Pkg Mult.")
. . I $G(^TMP($J,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",")_" is missing Unit Conversion Factor.")
. K PRCARR,PRCERR
Q:PRCVENSK
S PRCITMIEN=PRCVEND_","_PRCITMIEN ;Changing PRCITMIEN for Vendor subfile
S:$G(^TMP($J,"PRCHITM3","ITEM","VSTOCK#"))'="" PRCARR(441.01,PRCITMIEN,3)=^("VSTOCK#")
S:$G(^TMP($J,"PRCHITM3","ITEM","NDC"))'="" PRCARR(441.01,PRCITMIEN,4)=^("NDC")
S:$G(^TMP($J,"PRCHITM3","ITEM","MIN QTY"))'="" PRCARR(441.01,PRCITMIEN,8)=^("MIN QTY")
S:$G(^TMP($J,"PRCHITM3","ITEM","MAX QTY"))'="" PRCARR(441.01,PRCITMIEN,8.5)=^("MAX QTY")
S:$G(^TMP($J,"PRCHITM3","ITEM","ORDER QTY MULTIPLE"))'="" PRCARR(441.01,PRCITMIEN,9)=^("ORDER QTY MULTIPLE")
S:$G(^TMP($J,"PRCHITM3","ITEM","SOURCE VENDOR STOCK#"))'="" PRCARR(441.01,PRCITMIEN,3.1)=^("SOURCE VENDOR STOCK#")
I 'PRCNEW D
. S:$G(^TMP($J,"PRCHITM3","ITEM","UOP"))'="" PRCARR(441.01,PRCITMIEN,1.5)=^("UOP")
. S:$G(^TMP($J,"PRCHITM3","ITEM","UNIT COST"))'="" PRCARR(441.01,PRCITMIEN,1)=^("UNIT COST")
. S:$G(^TMP($J,"PRCHITM3","ITEM","PKG MULT"))'="" PRCARR(441.01,PRCITMIEN,1.6)=^("PKG MULT")
. S:$G(^TMP($J,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR"))'="" PRCARR(441.01,PRCITMIEN,10)=^("UNIT CONVERSION FACTOR")
D FILE^DIE("EK","PRCARR","PRCERR")
D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$P(PRCITMIEN,",",2))
K PRCARR,PRCERR
I $G(^TMP($J,"PRCHITM3","ITEM","CONTRACT"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",",2)_" is missing Contract.")
I $G(^TMP($J,"PRCHITM3","ITEM","CONTRACT"))'="" S PRCX=^("CONTRACT") D
. N PRCSCRN,PRCY S PRCSCRN="I $P($G(^(0)),U,2)=""""!($P($G(^(0)),U,2)'<"_$$DT^XLFDT()_")"
. K PRCERR
. S PRCY=$$FIND1^DIC(440.03,","_PRCVEND_",","BX",PRCX,"",PRCSCRN,"PRCERR")
. I PRCY'>0 D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$P(PRCITMIEN,",",2)_": The value '"_PRCX_"' for field CONTRACT in VENDOR SUB-FIELD in file ITEM MASTER is not valid.") Q
. K PRCARR,PRCERR S PRCARR(441.01,PRCITMIEN,2)=PRCY
. D FILE^DIE("K","PRCARR","PRCERR")
. D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$P(PRCITMIEN,",",2))
. K PRCARR,PRCERR
D CLEAN^DILF
Q
;
GETVEN(PRCVEN) ;
N PRCE,PRCLX S PRCVEN=0
I $G(^TMP($J,"PRCHITM3","VEN","IEN"))'>0 D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" Vendor IEN missing or invalid.") Q
I $G(^TMP($J,"PRCHITM3","VEN","IEN"))>0 S PRCVEN=1,PRCVEN(1)=^("IEN") D
. I '$D(^PRC(440,PRCVEN(1),0)) D ERR("ST #"_PRCTRANNBR_": Vendor with Number "_PRCVEN(1)_" does not exist.") K PRCVEN(1) S PRCVEN=0 Q
. S PRCLX=$$GET1^DIQ(440,PRCVEN(1)_",",.01)
. I $$UP^XLFSTR($G(^TMP($J,"PRCHITM3","VEN","ORDER NAME")))'=PRCLX D Q
. . D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" Incoming and stored vendor names for ien "_PRCVEN(1)_" are")
. . D ERR(" different '"_$G(^TMP($J,"PRCHITM3","VEN","ORDER NAME"))_"' versus '"_PRCLX_"'.")
. . K PRCVEN(1) S PRCVEN=0
Q
;
GETITEM(PRCIMF,PRCADD) ;
N PRCNIF S PRCIMF=0,PRCADD=0
I $G(^TMP($J,"PRCHITM3","ITEM","IMFNBR"))'>0 D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF# is missing or invalid.") Q
I $G(^TMP($J,"PRCHITM3","ITEM","IMFNBR"))>0 S PRCIMF=1,PRCIMF(1)=^("IMFNBR") D
. I $G(^TMP($J,"PRCHITM3","ITEM","NIF#"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_PRCIMF(1)_" is missing NIF#.")
. I $D(^PRC(441,PRCIMF(1))) D Q
. . N PRCX,PRCY,PRCERR S PRCX=$G(^TMP($J,"PRCHITM3","ITEM","NIF#")),PRCY=$$GET1^DIQ(441,PRCIMF(1)_",",51,,,"PRCERR")
. . I PRCX'="",PRCY'="",PRCX'=PRCY D
. . . D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_": IMF #"_PRCIMF(1)_" exists but has different NIF#, "_PRCY)
. . . D ERR(" not incoming value "_PRCX_". It will be updated.")
. I '$D(^PRC(441,PRCIMF(1))) D
. . L +^PRC(441,0):15 N PRCNBROLD S PRCNBROLD=$P($G(^PRC(441,0)),U,3)
. . N PRCARR,PRCERR,PRCIENS S PRCARR(441,"+1,",.01)=PRCIMF(1)
. . S PRCARR(441,"+1,",.05)=$$UP^XLFSTR($G(^TMP($J,"PRCHITM3","ITEM","SHORT DESC")))
. . S PRCARR(441,"+1,",2)=$G(^TMP($J,"PRCHITM3","ITEM","FSC"))
. . I PRCARR(441,"+1,",2)="" S PRCARR(441,"+1,",2)=$P($G(^TMP($J,"PRCHITM3","ITEM","NSN")),"-")
. . S PRCARR(441,"+1,",51)=$G(^TMP($J,"PRCHITM3","ITEM","NIF#"))
. . D UPDATE^DIE("E","PRCARR","PRCIENS","PRCERR") S PRCADD=1
. . I $D(PRCERR) D Q
. . . D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_": Problem adding IMF entry #"_PRCIMF(1)_".") D PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
. . . I $G(^TMP($J,"PRCHITM3","ITEM","SHORT DESC"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_PRCIMF(1)_" is missing Short Desc.")
. . . I $G(^TMP($J,"PRCHITM3","ITEM","FSC"))="" D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_PRCIMF(1)_" is missing FSC.")
. . . K PRCIMF S PRCIMF=0,PRCADD=0
. . I $G(PRCIMF(1))'=$G(PRCIENS(1)) D
. . . I $G(PRCIENS(1))>0 D ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_": Item assigned IMF# "_PRCIENS(1)_" instead of requested "_(PRCIMF(1))_".")
. . . S PRCIMF(1)=$G(PRCIENS(1))
. . S $P(^PRC(441,0),U,3)=PRCNBROLD L -^PRC(441,0)
Q
;
DT2FMD(PRCDATE) ;
; Input date in YYMMDD format
; Returns date in VA FileMan date format if successful
; or null value if input invalid
N PRCARR,PRCERR,PRCOUT S PRCOUT=""
S PRCDATE=$E(PRCDATE,3,4)_"/"_$E(PRCDATE,5,6)_"/"_$E(PRCDATE,1,2)
D DT^DILF("X",PRCDATE,.PRCARR,,"PRCERR")
S:'$D(PRCERR) PRCOUT=PRCARR
Q PRCOUT
;
FMD(PRCDATE) ;
; Input external date and output VA FileMan date
N PRCARR,PRCERR,PRCOUT S PRCOUT=""
D DT^DILF("X",PRCDATE,.PRCARR,,"PRCERR")
S:'$D(PRCERR) PRCOUT=PRCARR
Q PRCOUT
;
BACKUP(PRCIEN) ;Backup Short Description and long Description
; Also add short description as Synonym if value not already present
Q:'$D(^PRC(441,PRCIEN))
N PRCARR,PRCERR,PRCX S PRCIEN=PRCIEN_","
D GETS^DIQ(441,PRCIEN,".05;51;52","","PRCARR","PRCERR")
I PRCARR(441,PRCIEN,52)="",PRCARR(441,PRCIEN,51)="" D
. S PRCARR(441,PRCIEN,52)=PRCARR(441,PRCIEN,.05),PRCX=$E(PRCARR(441,PRCIEN,.05),1,36)
. K PRCARR(441,PRCIEN,.05),PRCARR(441,PRCIEN,51),PRCERR
. D FILE^DIE("EK","PRCARR","PRCERR")
. D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
. K PRCARR,PRCERR
. I '$$FIND1^DIC(441.05,","_PRCIEN,"X",PRCX,"","","PRCERR"),'$D(PRCERR) D
. . S PRCARR(441.05,"+1,"_PRCIEN,.01)=PRCX
. . D UPDATE^DIE("E","PRCARR","","PRCERR")
. . D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
K PRCARR,PRCERR N PRCI S PRCI=$P(PRCIEN,",")
I '$P($G(^PRC(441,PRCI,0)),"^",15),$P($G(^PRC(441,PRCI,8,0)),"^",4)'>0 D
. I $P($G(^PRC(441,PRCI,1,0)),"^",4)>0 D
. . D WP^DIE(441,PRCIEN,50,"","^PRC(441,PRCI,1)","PRCERR")
. . D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
Q
;
SYNONYM(PRCIEN) ;
N PRCI S PRCI=""
F S PRCI=$O(^TMP($J,"PRCHITM3","ITEM","SYN",PRCI)) Q:PRCI="" S PRCX=^(PRCI) D
. N PRCARR,PRCERR
. I '$$FIND1^DIC(441.05,","_PRCIEN,"X",PRCX,"","","PRCERR"),'$D(PRCERR) D
. . S PRCARR(441.05,"+1,"_PRCIEN,.01)=PRCX
. . D UPDATE^DIE("E","PRCARR","","PRCERR")
. . D:$D(PRCERR) PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
Q
INITLOG(PRCTXNID) ; Initialize error log
N PRCDT,X1,X2,X,%H
S PRCERRC=0,PRCHNODE="PRCHITM3;"_PRCTXNID K ^XTMP(PRCHNODE)
; Setting up ^XTMP header node including automatic purge date
S PRCDT=$$DT^XLFDT,X1=PRCDT,X2=30 D C^%DTC S ^XTMP(PRCHNODE,0)=X_"^"_PRCDT_"^"_"NIF Item Add/Update"
Q
;
PROCERRS(PRCE,PRCT,PRCL,PRCIMF) ; Process errors in DIERR
N PRCI,PRCK,PRCM S PRCK=$P($G(PRCE("DIERR")),"^") Q:+PRCK'>0
F PRCI=1:1:PRCK S PRCM=$G(PRCE("DIERR",PRCI,"TEXT",1)) I PRCM'="" S PRCM="ST #"_PRCT_" Line #"_PRCL_$S($G(PRCIMF)>0:" IMF #"_PRCIMF,1:"")_": "_PRCM D ERR(PRCM)
Q
ERR(PRCMSG) ; Error processing
S PRCERRC=PRCERRC+1 S ^XTMP(PRCHNODE,"ERR",PRCERRC)=PRCMSG
Q
;
;PRCHITM5
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHITM5 12363 printed Nov 22, 2024@17:18:10 Page 2
PRCHITM5 ;OI&T/LKG - FILING DATA FROM NIF ;5/25/17 16:10
+1 ;;5.1;IFCAP;**198**;OCT 20, 2000;Build 6
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;Integration agreements
+4 ; ICR #2051 FIND^DIC(), $$FIND1()^DIC
+5 ; ICR #2053 FILE^DIE(), UPDATE^DIE(), WP^DIE()
+6 ; ICR #2054 DT^DILF(), CLEAN^DILF
+7 ; ICR #2056 GETS^DIQ(), $$GET1^DIQ()
+8 ; ICR #10000 C^%DTC
+9 ; ICR #10103 $$DT^XLFDT
+10 ; ICR #10104 $$UP^XLFSTR()
+11 QUIT
FILE(PRCTRANNBR,PRCLINE,PRCITMC) ;
+1 NEW PRCCONTR,PRCIMF,PRCVEN,PRCNITM,PRCJ
SET PRCITMC=0
+2 DO GETVEN(.PRCVEN)
IF PRCVEN=0
DO ERR("Vendor not resolved for ST #"_PRCTRANNBR_" Line #"_PRCLINE_".")
QUIT
+3 DO GETITEM(.PRCIMF,.PRCNITM)
IF PRCIMF=0
DO ERR("Item not resolved for ST #"_PRCTRANNBR_" Line #"_PRCLINE_".")
QUIT
+4 SET PRCJ=""
+5 FOR
SET PRCJ=$ORDER(PRCIMF(PRCJ))
if PRCJ=""
QUIT
Begin DoDot:1
+6 DO ITEMFILE(PRCIMF(PRCJ),PRCVEN(1),PRCNITM)
SET PRCITMC=PRCITMC+1
End DoDot:1
+7 QUIT
+8 ;
ITEMFILE(PRCITMIEN,PRCVEND,PRCADDED) ;
+1 NEW PRCARR,PRCERR,PRCNEW,PRCX,PRCVENSK
SET PRCVENSK=0
+2 ; New vendor multiple entry
SET PRCNEW=$SELECT('$DATA(^PRC(441,PRCITMIEN,2,PRCVEND)):1,1:0)
+3 if 'PRCADDED
DO BACKUP(PRCITMIEN)
+4 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","FSC"))=6505!($PIECE($GET(^TMP($JOB,"PRCHITM3","ITEM","NSN")),"-")=6505)
Begin DoDot:1
+5 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","DRUG TYPE"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_PRCITMIEN_" is missing Drug Type although FSC 6505.")
End DoDot:1
+6 SET PRCITMIEN=PRCITMIEN_","
+7 KILL PRCARR,PRCERR
SET PRCARR(441,PRCITMIEN,53)=$$DT^XLFDT
+8 DO FILE^DIE("","PRCARR","PRCERR")
KILL PRCARR,PRCERR
+9 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","BOC"))'=""
SET PRCX=^("BOC")
Begin DoDot:1
+10 IF '$DATA(^PRCD(420.2,PRCX,0))
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",")_" BOC "_PRCX_" does not exist in file #420.2.")
QUIT
+11 NEW PRCARR,PRCERR
+12 SET PRCARR(441,PRCITMIEN,12)=PRCX
+13 DO FILE^DIE("K","PRCARR","PRCERR")
+14 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$PIECE(PRCITMIEN,","))
End DoDot:1
+15 IF 'PRCADDED
Begin DoDot:1
+16 if $GET(^TMP($JOB,"PRCHITM3","ITEM","NIF#"))'=""
SET PRCARR(441,PRCITMIEN,51)=^("NIF#")
+17 if $GET(^TMP($JOB,"PRCHITM3","ITEM","FSC"))'=""
SET PRCARR(441,PRCITMIEN,2)=^("FSC")
+18 if $GET(^TMP($JOB,"PRCHITM3","ITEM","SHORT DESC"))'=""
SET PRCARR(441,PRCITMIEN,.05)=$$UP^XLFSTR(^("SHORT DESC"))
End DoDot:1
+19 if $GET(^TMP($JOB,"PRCHITM3","ITEM","NSN"))'=""
SET PRCARR(441,PRCITMIEN,5)=^("NSN")
+20 if $GET(^TMP($JOB,"PRCHITM3","ITEM","MFG PART"))'=""
SET PRCARR(441,PRCITMIEN,19)=^("MFG PART")
+21 if $GET(^TMP($JOB,"PRCHITM3","ITEM","STOCK KEEPING UNIT"))'=""
SET PRCARR(441,PRCITMIEN,21)=^("STOCK KEEPING UNIT")
+22 if $GET(^TMP($JOB,"PRCHITM3","ITEM","DRUG TYPE"))'=""
SET PRCARR(441,PRCITMIEN,22)=^("DRUG TYPE")
+23 if $GET(^TMP($JOB,"PRCHITM3","ITEM","MANUFACTURER"))'=""
SET PRCARR(441,PRCITMIEN,25)=$$UP^XLFSTR(^("MANUFACTURER"))
+24 if $GET(^TMP($JOB,"PRCHITM3","ITEM","SOURCE MFG PART#"))'=""
SET PRCARR(441,PRCITMIEN,19.1)=^("SOURCE MFG PART#")
+25 if $GET(^TMP($JOB,"PRCHITM3","ITEM","NIF UPDATE DATE"))'=""
SET PRCARR(441,PRCITMIEN,54)=$$DT2FMD(^("NIF UPDATE DATE"))
+26 DO FILE^DIE("EK","PRCARR","PRCERR")
+27 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$PIECE(PRCITMIEN,","))
KILL PRCARR,PRCERR
+28 IF '$DATA(^TMP($JOB,"PRCHITM3","ITEM","LONG DESC"))
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",")_" is missing Long Desc.")
+29 IF $DATA(^TMP($JOB,"PRCHITM3","ITEM","LONG DESC"))
Begin DoDot:1
+30 DO WP^DIE(441,PRCITMIEN,.1,"K","^TMP($J,""PRCHITM3"",""ITEM"",""LONG DESC"")","PRCERR")
+31 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$PIECE(PRCITMIEN,","))
+32 KILL PRCARR,PRCERR
End DoDot:1
+33 ; Update supply stations
+34 IF $ORDER(^PRCP(445,"AH",$PIECE(PRCITMIEN,","),""))]""
DO BLDSEG^PRCPHLFM(3,$PIECE(PRCITMIEN,","),0)
+35 DO SYNONYM(PRCITMIEN)
+36 IF PRCNEW
Begin DoDot:1
+37 NEW PRCIEN
SET PRCIEN(2)=PRCVEND
+38 SET PRCARR(441.01,"+2,"_PRCITMIEN,.01)=PRCVEND
+39 if $GET(^TMP($JOB,"PRCHITM3","ITEM","UOP"))'=""
SET PRCARR(441.01,"+2,"_PRCITMIEN,1.5)=^("UOP")
+40 if $GET(^TMP($JOB,"PRCHITM3","ITEM","UNIT COST"))'=""
SET PRCARR(441.01,"+2,"_PRCITMIEN,1)=^("UNIT COST")
+41 if $GET(^TMP($JOB,"PRCHITM3","ITEM","PKG MULT"))'=""
SET PRCARR(441.01,"+2,"_PRCITMIEN,1.6)=^("PKG MULT")
+42 if $GET(^TMP($JOB,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR"))'=""
SET PRCARR(441.01,"+2,"_PRCITMIEN,10)=^("UNIT CONVERSION FACTOR")
+43 DO UPDATE^DIE("E","PRCARR","PRCIEN","PRCERR")
+44 IF $DATA(PRCERR)
Begin DoDot:2
+45 DO ERR("Problem adding vendor entry to item for ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",")_".")
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$PIECE(PRCITMIEN,","))
SET PRCVENSK=1
+46 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","UOP"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",")_" is missing UOP.")
+47 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","UNIT COST"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",")_" is missing Unit Cost.")
+48 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","PKG MULT"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",")_" is missing Pkg Mult.")
+49 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",")_" is missing Unit Conversion Factor.")
End DoDot:2
+50 KILL PRCARR,PRCERR
End DoDot:1
+51 if PRCVENSK
QUIT
+52 ;Changing PRCITMIEN for Vendor subfile
SET PRCITMIEN=PRCVEND_","_PRCITMIEN
+53 if $GET(^TMP($JOB,"PRCHITM3","ITEM","VSTOCK#"))'=""
SET PRCARR(441.01,PRCITMIEN,3)=^("VSTOCK#")
+54 if $GET(^TMP($JOB,"PRCHITM3","ITEM","NDC"))'=""
SET PRCARR(441.01,PRCITMIEN,4)=^("NDC")
+55 if $GET(^TMP($JOB,"PRCHITM3","ITEM","MIN QTY"))'=""
SET PRCARR(441.01,PRCITMIEN,8)=^("MIN QTY")
+56 if $GET(^TMP($JOB,"PRCHITM3","ITEM","MAX QTY"))'=""
SET PRCARR(441.01,PRCITMIEN,8.5)=^("MAX QTY")
+57 if $GET(^TMP($JOB,"PRCHITM3","ITEM","ORDER QTY MULTIPLE"))'=""
SET PRCARR(441.01,PRCITMIEN,9)=^("ORDER QTY MULTIPLE")
+58 if $GET(^TMP($JOB,"PRCHITM3","ITEM","SOURCE VENDOR STOCK#"))'=""
SET PRCARR(441.01,PRCITMIEN,3.1)=^("SOURCE VENDOR STOCK#")
+59 IF 'PRCNEW
Begin DoDot:1
+60 if $GET(^TMP($JOB,"PRCHITM3","ITEM","UOP"))'=""
SET PRCARR(441.01,PRCITMIEN,1.5)=^("UOP")
+61 if $GET(^TMP($JOB,"PRCHITM3","ITEM","UNIT COST"))'=""
SET PRCARR(441.01,PRCITMIEN,1)=^("UNIT COST")
+62 if $GET(^TMP($JOB,"PRCHITM3","ITEM","PKG MULT"))'=""
SET PRCARR(441.01,PRCITMIEN,1.6)=^("PKG MULT")
+63 if $GET(^TMP($JOB,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR"))'=""
SET PRCARR(441.01,PRCITMIEN,10)=^("UNIT CONVERSION FACTOR")
End DoDot:1
+64 DO FILE^DIE("EK","PRCARR","PRCERR")
+65 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$PIECE(PRCITMIEN,",",2))
+66 KILL PRCARR,PRCERR
+67 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","CONTRACT"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",",2)_" is missing Contract.")
+68 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","CONTRACT"))'=""
SET PRCX=^("CONTRACT")
Begin DoDot:1
+69 NEW PRCSCRN,PRCY
SET PRCSCRN="I $P($G(^(0)),U,2)=""""!($P($G(^(0)),U,2)'<"_$$DT^XLFDT()_")"
+70 KILL PRCERR
+71 SET PRCY=$$FIND1^DIC(440.03,","_PRCVEND_",","BX",PRCX,"",PRCSCRN,"PRCERR")
+72 IF PRCY'>0
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_$PIECE(PRCITMIEN,",",2)_": The value '"_PRCX_"' for field CONTRACT in VENDOR SUB-FIELD in file ITEM MASTER is not valid.")
QUIT
+73 KILL PRCARR,PRCERR
SET PRCARR(441.01,PRCITMIEN,2)=PRCY
+74 DO FILE^DIE("K","PRCARR","PRCERR")
+75 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE,$PIECE(PRCITMIEN,",",2))
+76 KILL PRCARR,PRCERR
End DoDot:1
+77 DO CLEAN^DILF
+78 QUIT
+79 ;
GETVEN(PRCVEN) ;
+1 NEW PRCE,PRCLX
SET PRCVEN=0
+2 IF $GET(^TMP($JOB,"PRCHITM3","VEN","IEN"))'>0
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" Vendor IEN missing or invalid.")
QUIT
+3 IF $GET(^TMP($JOB,"PRCHITM3","VEN","IEN"))>0
SET PRCVEN=1
SET PRCVEN(1)=^("IEN")
Begin DoDot:1
+4 IF '$DATA(^PRC(440,PRCVEN(1),0))
DO ERR("ST #"_PRCTRANNBR_": Vendor with Number "_PRCVEN(1)_" does not exist.")
KILL PRCVEN(1)
SET PRCVEN=0
QUIT
+5 SET PRCLX=$$GET1^DIQ(440,PRCVEN(1)_",",.01)
+6 IF $$UP^XLFSTR($GET(^TMP($JOB,"PRCHITM3","VEN","ORDER NAME")))'=PRCLX
Begin DoDot:2
+7 DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" Incoming and stored vendor names for ien "_PRCVEN(1)_" are")
+8 DO ERR(" different '"_$GET(^TMP($JOB,"PRCHITM3","VEN","ORDER NAME"))_"' versus '"_PRCLX_"'.")
+9 KILL PRCVEN(1)
SET PRCVEN=0
End DoDot:2
QUIT
End DoDot:1
+10 QUIT
+11 ;
GETITEM(PRCIMF,PRCADD) ;
+1 NEW PRCNIF
SET PRCIMF=0
SET PRCADD=0
+2 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","IMFNBR"))'>0
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF# is missing or invalid.")
QUIT
+3 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","IMFNBR"))>0
SET PRCIMF=1
SET PRCIMF(1)=^("IMFNBR")
Begin DoDot:1
+4 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","NIF#"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_PRCIMF(1)_" is missing NIF#.")
+5 IF $DATA(^PRC(441,PRCIMF(1)))
Begin DoDot:2
+6 NEW PRCX,PRCY,PRCERR
SET PRCX=$GET(^TMP($JOB,"PRCHITM3","ITEM","NIF#"))
SET PRCY=$$GET1^DIQ(441,PRCIMF(1)_",",51,,,"PRCERR")
+7 IF PRCX'=""
IF PRCY'=""
IF PRCX'=PRCY
Begin DoDot:3
+8 DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_": IMF #"_PRCIMF(1)_" exists but has different NIF#, "_PRCY)
+9 DO ERR(" not incoming value "_PRCX_". It will be updated.")
End DoDot:3
End DoDot:2
QUIT
+10 IF '$DATA(^PRC(441,PRCIMF(1)))
Begin DoDot:2
+11 LOCK +^PRC(441,0):15
NEW PRCNBROLD
SET PRCNBROLD=$PIECE($GET(^PRC(441,0)),U,3)
+12 NEW PRCARR,PRCERR,PRCIENS
SET PRCARR(441,"+1,",.01)=PRCIMF(1)
+13 SET PRCARR(441,"+1,",.05)=$$UP^XLFSTR($GET(^TMP($JOB,"PRCHITM3","ITEM","SHORT DESC")))
+14 SET PRCARR(441,"+1,",2)=$GET(^TMP($JOB,"PRCHITM3","ITEM","FSC"))
+15 IF PRCARR(441,"+1,",2)=""
SET PRCARR(441,"+1,",2)=$PIECE($GET(^TMP($JOB,"PRCHITM3","ITEM","NSN")),"-")
+16 SET PRCARR(441,"+1,",51)=$GET(^TMP($JOB,"PRCHITM3","ITEM","NIF#"))
+17 DO UPDATE^DIE("E","PRCARR","PRCIENS","PRCERR")
SET PRCADD=1
+18 IF $DATA(PRCERR)
Begin DoDot:3
+19 DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_": Problem adding IMF entry #"_PRCIMF(1)_".")
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
+20 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","SHORT DESC"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_PRCIMF(1)_" is missing Short Desc.")
+21 IF $GET(^TMP($JOB,"PRCHITM3","ITEM","FSC"))=""
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_" IMF #"_PRCIMF(1)_" is missing FSC.")
+22 KILL PRCIMF
SET PRCIMF=0
SET PRCADD=0
End DoDot:3
QUIT
+23 IF $GET(PRCIMF(1))'=$GET(PRCIENS(1))
Begin DoDot:3
+24 IF $GET(PRCIENS(1))>0
DO ERR("ST #"_PRCTRANNBR_" Line #"_PRCLINE_": Item assigned IMF# "_PRCIENS(1)_" instead of requested "_(PRCIMF(1))_".")
+25 SET PRCIMF(1)=$GET(PRCIENS(1))
End DoDot:3
+26 SET $PIECE(^PRC(441,0),U,3)=PRCNBROLD
LOCK -^PRC(441,0)
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
DT2FMD(PRCDATE) ;
+1 ; Input date in YYMMDD format
+2 ; Returns date in VA FileMan date format if successful
+3 ; or null value if input invalid
+4 NEW PRCARR,PRCERR,PRCOUT
SET PRCOUT=""
+5 SET PRCDATE=$EXTRACT(PRCDATE,3,4)_"/"_$EXTRACT(PRCDATE,5,6)_"/"_$EXTRACT(PRCDATE,1,2)
+6 DO DT^DILF("X",PRCDATE,.PRCARR,,"PRCERR")
+7 if '$DATA(PRCERR)
SET PRCOUT=PRCARR
+8 QUIT PRCOUT
+9 ;
FMD(PRCDATE) ;
+1 ; Input external date and output VA FileMan date
+2 NEW PRCARR,PRCERR,PRCOUT
SET PRCOUT=""
+3 DO DT^DILF("X",PRCDATE,.PRCARR,,"PRCERR")
+4 if '$DATA(PRCERR)
SET PRCOUT=PRCARR
+5 QUIT PRCOUT
+6 ;
BACKUP(PRCIEN) ;Backup Short Description and long Description
+1 ; Also add short description as Synonym if value not already present
+2 if '$DATA(^PRC(441,PRCIEN))
QUIT
+3 NEW PRCARR,PRCERR,PRCX
SET PRCIEN=PRCIEN_","
+4 DO GETS^DIQ(441,PRCIEN,".05;51;52","","PRCARR","PRCERR")
+5 IF PRCARR(441,PRCIEN,52)=""
IF PRCARR(441,PRCIEN,51)=""
Begin DoDot:1
+6 SET PRCARR(441,PRCIEN,52)=PRCARR(441,PRCIEN,.05)
SET PRCX=$EXTRACT(PRCARR(441,PRCIEN,.05),1,36)
+7 KILL PRCARR(441,PRCIEN,.05),PRCARR(441,PRCIEN,51),PRCERR
+8 DO FILE^DIE("EK","PRCARR","PRCERR")
+9 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
+10 KILL PRCARR,PRCERR
+11 IF '$$FIND1^DIC(441.05,","_PRCIEN,"X",PRCX,"","","PRCERR")
IF '$DATA(PRCERR)
Begin DoDot:2
+12 SET PRCARR(441.05,"+1,"_PRCIEN,.01)=PRCX
+13 DO UPDATE^DIE("E","PRCARR","","PRCERR")
+14 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
End DoDot:2
End DoDot:1
+15 KILL PRCARR,PRCERR
NEW PRCI
SET PRCI=$PIECE(PRCIEN,",")
+16 IF '$PIECE($GET(^PRC(441,PRCI,0)),"^",15)
IF $PIECE($GET(^PRC(441,PRCI,8,0)),"^",4)'>0
Begin DoDot:1
+17 IF $PIECE($GET(^PRC(441,PRCI,1,0)),"^",4)>0
Begin DoDot:2
+18 DO WP^DIE(441,PRCIEN,50,"","^PRC(441,PRCI,1)","PRCERR")
+19 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
SYNONYM(PRCIEN) ;
+1 NEW PRCI
SET PRCI=""
+2 FOR
SET PRCI=$ORDER(^TMP($JOB,"PRCHITM3","ITEM","SYN",PRCI))
if PRCI=""
QUIT
SET PRCX=^(PRCI)
Begin DoDot:1
+3 NEW PRCARR,PRCERR
+4 IF '$$FIND1^DIC(441.05,","_PRCIEN,"X",PRCX,"","","PRCERR")
IF '$DATA(PRCERR)
Begin DoDot:2
+5 SET PRCARR(441.05,"+1,"_PRCIEN,.01)=PRCX
+6 DO UPDATE^DIE("E","PRCARR","","PRCERR")
+7 if $DATA(PRCERR)
DO PROCERRS(.PRCERR,PRCTRANNBR,PRCLINE)
End DoDot:2
End DoDot:1
+8 QUIT
INITLOG(PRCTXNID) ; Initialize error log
+1 NEW PRCDT,X1,X2,X,%H
+2 SET PRCERRC=0
SET PRCHNODE="PRCHITM3;"_PRCTXNID
KILL ^XTMP(PRCHNODE)
+3 ; Setting up ^XTMP header node including automatic purge date
+4 SET PRCDT=$$DT^XLFDT
SET X1=PRCDT
SET X2=30
DO C^%DTC
SET ^XTMP(PRCHNODE,0)=X_"^"_PRCDT_"^"_"NIF Item Add/Update"
+5 QUIT
+6 ;
PROCERRS(PRCE,PRCT,PRCL,PRCIMF) ; Process errors in DIERR
+1 NEW PRCI,PRCK,PRCM
SET PRCK=$PIECE($GET(PRCE("DIERR")),"^")
if +PRCK'>0
QUIT
+2 FOR PRCI=1:1:PRCK
SET PRCM=$GET(PRCE("DIERR",PRCI,"TEXT",1))
IF PRCM'=""
SET PRCM="ST #"_PRCT_" Line #"_PRCL_$SELECT($GET(PRCIMF)>0:" IMF #"_PRCIMF,1:"")_": "_PRCM
DO ERR(PRCM)
+3 QUIT
ERR(PRCMSG) ; Error processing
+1 SET PRCERRC=PRCERRC+1
SET ^XTMP(PRCHNODE,"ERR",PRCERRC)=PRCMSG
+2 QUIT
+3 ;
+4 ;PRCHITM5
