Routine: PRCHITM5

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()

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

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

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

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)

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)

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)

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"

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)

ERR(PRCMSG) ; Error processing

 S PRCERRC=PRCERRC+1 S ^XTMP(PRCHNODE,"ERR",PRCERRC)=PRCMSG

 ;PRCHITM5

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHITM5   12363     printed  Feb 18, 2025@23:34:27                                                                                                                                                                                                   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

PRCHITM5.m