PRCHITM ;WOIFO/LKG-ITEM UPDATE FROM NIF ;11/15/04 13:02
V ;;5.1;IFCAP;**63,121,145**;Oct 20, 2000;Build 3
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
EN ;Entry for server invoked filer
S PRCERRC=0
; loading ^XTMP with 888 transaction from MailMan message
F X XMREC Q:XMER<0!($E(XMRG,1,4)="ISA^")
I XMER<0 G EXIT
S PRCTXN=$P(XMRG,U,14)
S PRCHNODE="PRCHITM;"_PRCTXN K ^XTMP(PRCHNODE)
; set up ^XTMP header node including automated purge date
S DT=$$DT^XLFDT,X1=DT,X2=10 D C^%DTC S ^XTMP(PRCHNODE,0)=X_"^"_DT_"^"_"NIF ITEM UPDATE"
S PRCSUB=1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
F X XMREC Q:XMER<0!($E(XMRG,1,4)="IEA^") D
. S PRCSUB=PRCSUB+1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
I XMER<0 D ERR("IEA segment is missing.") G EXIT
S PRCSUB=PRCSUB+1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
; processing data
RESTART ;Restart filer with data from ^XTMP global
S PRCX=$G(^XTMP(PRCHNODE,1,1)) I $P(PRCX,U)'="ISA" D ERR("ISA segment is missing.") G EXIT
S PRCY=$P(PRCX,U,7) I $TR(PRCY," ")'="36001200NIF" D ERR("Interchange Sender ID '"_PRCY_"' is invalid.") G EXIT
S PRCY=$P(PRCX,U,9) I $TR(PRCY," ")'="IFCAPNIF" D ERR("Interchange Receiver ID '"_PRCY_"' is invalid.") G EXIT
S PRCX=$G(^XTMP(PRCHNODE,1,2)) I $P(PRCX,U)'="ST" D ERR("ST segment is missing.") G EXIT
I $P(PRCX,U,2)'="888" D ERR("Transaction is not the 888.") G EXIT
S PRCX=$G(^XTMP(PRCHNODE,1,3)) I $P(PRCX,U)'="N1" D ERR("N1 segment is missing.") G EXIT
I $P(PRCX,U,3)'="NIF" D ERR("Source is not the National Item File database.") G EXIT
S Y=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99) I $P(PRCX,U,5)'=Y D ERR("Intended recipient station is "_$P(PRCX,U,5)_", not "_Y_".") G EXIT
I $P(PRCX,U,7)'="KA" D ERR("Intended recipient application is not IFCAP's ITEM MASTER file.") G EXIT
S PRCSUB=6 I $P($G(^XTMP(PRCHNODE,1,PRCSUB)),U)'="G39" D ERR("Item characteristics node 'G39' is missing.") G EXIT
PROCITM ;Process items
S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB))
I $P(PRCX,U,24)'="ZZ" D ERR("The G39 segment for NIF Item #"_$P(PRCX,U,25)_" is defective.") G EXIT
S PRCIEN=$P(PRCX,U,4),PRCNIF=$P(PRCX,U,25)
I PRCNIF?1.N D
. I PRCIEN?1.N D
. . ; updating IMF entry specified by IMF Number in G39 segment
. . I '$$FIND1^DIC(441,"","XQ","`"_PRCIEN,"","","PRCE") D ERR("Item Master Number "_PRCIEN_" does not exist.") Q
. . K PRCE I $$GET1^DIQ(441,PRCIEN_",",16,"I","","PRCE") D ERR("Item Master Number "_PRCIEN_" is inactive, so it will not be updated.") Q
. . S PRCLOCK=0 F PRCI=1:1:20 L +^PRC(441,PRCIEN):30 I $T S PRCLOCK=1 Q
. . I 'PRCLOCK D ERR("Filer was unable to lock Item Master Number "_PRCIEN_"/NIF Item #"_PRCNIF_".") Q
. . ; filing NIF Item #
. . K PRCRR,PRCE S PRCRR(441,PRCIEN_",",51)=PRCNIF D FILE^DIE("E","PRCRR","PRCE")
. . I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCIEN_": "_PRCE("DIERR",1,"TEXT",PRCY))
. . K PRCRR,PRCE
. . S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB))
. . I PRCSUB="" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") L -^PRC(441,PRCIEN) Q
. . D DESC(PRCIEN,1) L -^PRC(441,PRCIEN)
. . I $O(^PRCP(445,"AH",PRCIEN,""))]"" D BLDSEG^PRCPHLFM(3,PRCIEN,0) ;update supply stations
. I PRCIEN'?1.N D
. . ; updating all IMF entries with specified NIF Item Number
. . K PRCE,PRCRR
. . D FIND^DIC(441,"","@","XQ",PRCNIF,"","I","","","PRCRR","PRCE")
. . I '$D(PRCRR("DILIST",2)) D ERR("No entry was found with NIF Item #"_PRCNIF_".") Q
. . S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)),PRCZ=PRCSUB
. . I PRCSUB="" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") Q
. . K PRCL M PRCL=PRCRR("DILIST",2) ; save list of iens
. . S PRCCTR=0 F S PRCCTR=$O(PRCL(PRCCTR)) Q:PRCCTR="" D
. . . S PRCIEN=PRCL(PRCCTR)
. . . K PRCE I $$GET1^DIQ(441,PRCIEN_",",16,"I","","PRCE") D ERR("Item Master Number "_PRCIEN_" is inactive, so it will not be updated.") Q
. . . S PRCLOCK=0 F PRCI=1:1:20 L +^PRC(441,PRCIEN):30 I $T S PRCLOCK=1 Q
. . . I 'PRCLOCK D ERR("Filer was unable to lock Item Master Number "_PRCIEN_"/NIF Item #"_PRCNIF_".") Q
. . . S PRCSUB=PRCZ D DESC(PRCIEN,0) L -^PRC(441,PRCIEN)
. . . I $O(^PRCP(445,"AH",PRCIEN,""))]"" D BLDSEG^PRCPHLFM(3,PRCIEN,0) ;update supply stations
. . K PRCRR,PRCE,PRCL,PRCZ
I PRCNIF'?1.N D ERR("NIF Item Number is missing for Item Master Number "_PRCIEN_".")
NEXT F S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)) Q:PRCSUB="" S PRCX=$G(^(PRCSUB)) Q:"^G39^SE^"[("^"_$P(PRCX,U)_"^")
G PROCITM:$P(PRCX,U)="G39"
EXIT I $D(PRCHNODE) D
. ; send message if errors
. I $D(^XTMP(PRCHNODE,"ERR")) D
. . N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
. . S XMSUB="Item Filing Errors for Interchange Control: "_PRCTXN
. . S XMDUZ=.5,XMTEXT="^XTMP(PRCHNODE,""ERR"","
. . S XMY("VHANIFMO@domain.ext")="",XMY("G.ISM")=""
. . D ^XMD
. ; if no errors delete ^XTMP nodes when done
. I '$D(^XTMP(PRCHNODE,"ERR")) K ^XTMP(PRCHNODE)
K PRCCTR,PRCE,PRCERRC,PRCI,PRCIEN,PRCL,PRCLOCK,PRCNIF,PRCHNODE,PRCRR,PRCSUB,PRCTXN,PRCX,PRCY,PRCZ,XMPOS,X,X1,X2,XMER,XMREC,XMRG,Y
; delete MailMan message from server basket
I $D(XMZ) S XMSER="S."_XQSOP D REMSBMSG^XMA1C
Q
DESC(PRCDA,PRCFLG) ;File Short and Extended Descriptions
N PRCDES
S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB))
I $P(PRCX,U)'="G69" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") Q
S X=$P(PRCX,U,2) X ^%ZOSF("UPPERCASE") S PRCDES=Y
I PRCDES'="" D
. ; file NIF version of short description, but first save off
. I PRCFLG,$L($P($G(^PRC(441,PRCDA,9)),"^"))=0 D I $D(PRCE("DIERR")) K PRCE,PRCRR Q
. . N PRCDESO S PRCDESO=$P($G(^PRC(441,PRCDA,0)),"^",2)
. . K PRCRR,PRCE S PRCRR(441,PRCDA_",",52)=PRCDESO
. . D FILE^DIE("E","PRCRR","PRCE")
. . I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
. . I $D(PRCE("DIERR")) K PRCRR Q
. . K PRCRR,PRCERR S PRCDESO=$E(PRCDESO,1,36)
. . I '$$FIND1^DIC(441.05,","_PRCDA_",","X",PRCDESO,"","","PRCE") D
. . . S PRCRR(441.05,"+1,"_PRCDA_",",.01)=PRCDESO D UPDATE^DIE("E","PRCRR","","PRCERR")
. . . I $D(PRCERR("DIERR")) S PRCY=0 F S PRCY=$O(PRCERR("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCERR("DIERR",1,"TEXT",PRCY))
. . . K PRCRR,PRCERR
. K PRCRR,PRCE S PRCRR(441,PRCDA_",",.05)=PRCDES D FILE^DIE("E","PRCRR","PRCE")
. I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
. K PRCRR,PRCE
; save off prior description during first NIF import
; if save fails, don't overwrite existing description with NIF extended description
I PRCFLG,$P($G(^PRC(441,PRCDA,8,0)),U,4)'>0 D I $D(PRCE("DIERR")) K PRCE Q
. K PRCE D WP^DIE(441,PRCDA_",",50,"","^PRC(441,PRCDA,1)","PRCE")
. I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
; extract extended description
S PRCI=0 K PRCY
F S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)) Q:PRCSUB="" S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB)) Q:$P(PRCX,U)'="G69" D
. S PRCI=PRCI+1,PRCY(PRCI)=$P($G(^XTMP(PRCHNODE,1,PRCSUB)),U,2)
I PRCI'>0 D ERR("No extended description exists for NIF Item Number "_PRCNIF_".")
I PRCI D
. ; file NIF extended description in description field
. K PRCE D WP^DIE(441,PRCDA_",",.1,"","PRCY","PRCE")
. K PRCY
. I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
. K PRCE
S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB),-1)
Q
ERR(PRCMSG) ;Error processing
S PRCERRC=PRCERRC+1 S ^XTMP(PRCHNODE,"ERR",PRCERRC)=PRCMSG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHITM 7758 printed Dec 13, 2024@02:08 Page 2
PRCHITM ;WOIFO/LKG-ITEM UPDATE FROM NIF ;11/15/04 13:02
V ;;5.1;IFCAP;**63,121,145**;Oct 20, 2000;Build 3
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
EN ;Entry for server invoked filer
+1 SET PRCERRC=0
+2 ; loading ^XTMP with 888 transaction from MailMan message
+3 FOR
XECUTE XMREC
if XMER<0!($EXTRACT(XMRG,1,4)="ISA^")
QUIT
+4 IF XMER<0
GOTO EXIT
+5 SET PRCTXN=$PIECE(XMRG,U,14)
+6 SET PRCHNODE="PRCHITM;"_PRCTXN
KILL ^XTMP(PRCHNODE)
+7 ; set up ^XTMP header node including automated purge date
+8 SET DT=$$DT^XLFDT
SET X1=DT
SET X2=10
DO C^%DTC
SET ^XTMP(PRCHNODE,0)=X_"^"_DT_"^"_"NIF ITEM UPDATE"
+9 SET PRCSUB=1
SET ^XTMP(PRCHNODE,1,PRCSUB)=XMRG
+10 FOR
XECUTE XMREC
if XMER<0!($EXTRACT(XMRG,1,4)="IEA^")
QUIT
Begin DoDot:1
+11 SET PRCSUB=PRCSUB+1
SET ^XTMP(PRCHNODE,1,PRCSUB)=XMRG
End DoDot:1
+12 IF XMER<0
DO ERR("IEA segment is missing.")
GOTO EXIT
+13 SET PRCSUB=PRCSUB+1
SET ^XTMP(PRCHNODE,1,PRCSUB)=XMRG
+14 ; processing data
RESTART ;Restart filer with data from ^XTMP global
+1 SET PRCX=$GET(^XTMP(PRCHNODE,1,1))
IF $PIECE(PRCX,U)'="ISA"
DO ERR("ISA segment is missing.")
GOTO EXIT
+2 SET PRCY=$PIECE(PRCX,U,7)
IF $TRANSLATE(PRCY," ")'="36001200NIF"
DO ERR("Interchange Sender ID '"_PRCY_"' is invalid.")
GOTO EXIT
+3 SET PRCY=$PIECE(PRCX,U,9)
IF $TRANSLATE(PRCY," ")'="IFCAPNIF"
DO ERR("Interchange Receiver ID '"_PRCY_"' is invalid.")
GOTO EXIT
+4 SET PRCX=$GET(^XTMP(PRCHNODE,1,2))
IF $PIECE(PRCX,U)'="ST"
DO ERR("ST segment is missing.")
GOTO EXIT
+5 IF $PIECE(PRCX,U,2)'="888"
DO ERR("Transaction is not the 888.")
GOTO EXIT
+6 SET PRCX=$GET(^XTMP(PRCHNODE,1,3))
IF $PIECE(PRCX,U)'="N1"
DO ERR("N1 segment is missing.")
GOTO EXIT
+7 IF $PIECE(PRCX,U,3)'="NIF"
DO ERR("Source is not the National Item File database.")
GOTO EXIT
+8 SET Y=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
IF $PIECE(PRCX,U,5)'=Y
DO ERR("Intended recipient station is "_$PIECE(PRCX,U,5)_", not "_Y_".")
GOTO EXIT
+9 IF $PIECE(PRCX,U,7)'="KA"
DO ERR("Intended recipient application is not IFCAP's ITEM MASTER file.")
GOTO EXIT
+10 SET PRCSUB=6
IF $PIECE($GET(^XTMP(PRCHNODE,1,PRCSUB)),U)'="G39"
DO ERR("Item characteristics node 'G39' is missing.")
GOTO EXIT
PROCITM ;Process items
+1 SET PRCX=$GET(^XTMP(PRCHNODE,1,PRCSUB))
+2 IF $PIECE(PRCX,U,24)'="ZZ"
DO ERR("The G39 segment for NIF Item #"_$PIECE(PRCX,U,25)_" is defective.")
GOTO EXIT
+3 SET PRCIEN=$PIECE(PRCX,U,4)
SET PRCNIF=$PIECE(PRCX,U,25)
+4 IF PRCNIF?1.N
Begin DoDot:1
+5 IF PRCIEN?1.N
Begin DoDot:2
+6 ; updating IMF entry specified by IMF Number in G39 segment
+7 IF '$$FIND1^DIC(441,"","XQ","`"_PRCIEN,"","","PRCE")
DO ERR("Item Master Number "_PRCIEN_" does not exist.")
QUIT
+8 KILL PRCE
IF $$GET1^DIQ(441,PRCIEN_",",16,"I","","PRCE")
DO ERR("Item Master Number "_PRCIEN_" is inactive, so it will not be updated.")
QUIT
+9 SET PRCLOCK=0
FOR PRCI=1:1:20
LOCK +^PRC(441,PRCIEN):30
IF $TEST
SET PRCLOCK=1
QUIT
+10 IF 'PRCLOCK
DO ERR("Filer was unable to lock Item Master Number "_PRCIEN_"/NIF Item #"_PRCNIF_".")
QUIT
+11 ; filing NIF Item #
+12 KILL PRCRR,PRCE
SET PRCRR(441,PRCIEN_",",51)=PRCNIF
DO FILE^DIE("E","PRCRR","PRCE")
+13 IF $DATA(PRCE("DIERR"))
SET PRCY=0
FOR
SET PRCY=$ORDER(PRCE("DIERR",1,"TEXT",PRCY))
if PRCY'>0
QUIT
DO ERR("Item Master Number "_PRCIEN_": "_PRCE("DIERR",1,"TEXT",PRCY))
+14 KILL PRCRR,PRCE
+15 SET PRCSUB=$ORDER(^XTMP(PRCHNODE,1,PRCSUB))
+16 IF PRCSUB=""
DO ERR("No descriptions exist for NIF Item Number "_PRCNIF_".")
LOCK -^PRC(441,PRCIEN)
QUIT
+17 DO DESC(PRCIEN,1)
LOCK -^PRC(441,PRCIEN)
+18 ;update supply stations
IF $ORDER(^PRCP(445,"AH",PRCIEN,""))]""
DO BLDSEG^PRCPHLFM(3,PRCIEN,0)
End DoDot:2
+19 IF PRCIEN'?1.N
Begin DoDot:2
+20 ; updating all IMF entries with specified NIF Item Number
+21 KILL PRCE,PRCRR
+22 DO FIND^DIC(441,"","@","XQ",PRCNIF,"","I","","","PRCRR","PRCE")
+23 IF '$DATA(PRCRR("DILIST",2))
DO ERR("No entry was found with NIF Item #"_PRCNIF_".")
QUIT
+24 SET PRCSUB=$ORDER(^XTMP(PRCHNODE,1,PRCSUB))
SET PRCZ=PRCSUB
+25 IF PRCSUB=""
DO ERR("No descriptions exist for NIF Item Number "_PRCNIF_".")
QUIT
+26 ; save list of iens
KILL PRCL
MERGE PRCL=PRCRR("DILIST",2)
+27 SET PRCCTR=0
FOR
SET PRCCTR=$ORDER(PRCL(PRCCTR))
if PRCCTR=""
QUIT
Begin DoDot:3
+28 SET PRCIEN=PRCL(PRCCTR)
+29 KILL PRCE
IF $$GET1^DIQ(441,PRCIEN_",",16,"I","","PRCE")
DO ERR("Item Master Number "_PRCIEN_" is inactive, so it will not be updated.")
QUIT
+30 SET PRCLOCK=0
FOR PRCI=1:1:20
LOCK +^PRC(441,PRCIEN):30
IF $TEST
SET PRCLOCK=1
QUIT
+31 IF 'PRCLOCK
DO ERR("Filer was unable to lock Item Master Number "_PRCIEN_"/NIF Item #"_PRCNIF_".")
QUIT
+32 SET PRCSUB=PRCZ
DO DESC(PRCIEN,0)
LOCK -^PRC(441,PRCIEN)
+33 ;update supply stations
IF $ORDER(^PRCP(445,"AH",PRCIEN,""))]""
DO BLDSEG^PRCPHLFM(3,PRCIEN,0)
End DoDot:3
+34 KILL PRCRR,PRCE,PRCL,PRCZ
End DoDot:2
End DoDot:1
+35 IF PRCNIF'?1.N
DO ERR("NIF Item Number is missing for Item Master Number "_PRCIEN_".")
NEXT FOR
SET PRCSUB=$ORDER(^XTMP(PRCHNODE,1,PRCSUB))
if PRCSUB=""
QUIT
SET PRCX=$GET(^(PRCSUB))
if "^G39^SE^"[("^"_$PIECE(PRCX,U)_"^")
QUIT
+1 if $PIECE(PRCX,U)="G39"
GOTO PROCITM
EXIT IF $DATA(PRCHNODE)
Begin DoDot:1
+1 ; send message if errors
+2 IF $DATA(^XTMP(PRCHNODE,"ERR"))
Begin DoDot:2
+3 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
+4 SET XMSUB="Item Filing Errors for Interchange Control: "_PRCTXN
+5 SET XMDUZ=.5
SET XMTEXT="^XTMP(PRCHNODE,""ERR"","
+6 SET XMY("VHANIFMO@domain.ext")=""
SET XMY("G.ISM")=""
+7 DO ^XMD
End DoDot:2
+8 ; if no errors delete ^XTMP nodes when done
+9 IF '$DATA(^XTMP(PRCHNODE,"ERR"))
KILL ^XTMP(PRCHNODE)
End DoDot:1
+10 KILL PRCCTR,PRCE,PRCERRC,PRCI,PRCIEN,PRCL,PRCLOCK,PRCNIF,PRCHNODE,PRCRR,PRCSUB,PRCTXN,PRCX,PRCY,PRCZ,XMPOS,X,X1,X2,XMER,XMREC,XMRG,Y
+11 ; delete MailMan message from server basket
+12 IF $DATA(XMZ)
SET XMSER="S."_XQSOP
DO REMSBMSG^XMA1C
+13 QUIT
DESC(PRCDA,PRCFLG) ;File Short and Extended Descriptions
+1 NEW PRCDES
+2 SET PRCX=$GET(^XTMP(PRCHNODE,1,PRCSUB))
+3 IF $PIECE(PRCX,U)'="G69"
DO ERR("No descriptions exist for NIF Item Number "_PRCNIF_".")
QUIT
+4 SET X=$PIECE(PRCX,U,2)
XECUTE ^%ZOSF("UPPERCASE")
SET PRCDES=Y
+5 IF PRCDES'=""
Begin DoDot:1
+6 ; file NIF version of short description, but first save off
+7 IF PRCFLG
IF $LENGTH($PIECE($GET(^PRC(441,PRCDA,9)),"^"))=0
Begin DoDot:2
+8 NEW PRCDESO
SET PRCDESO=$PIECE($GET(^PRC(441,PRCDA,0)),"^",2)
+9 KILL PRCRR,PRCE
SET PRCRR(441,PRCDA_",",52)=PRCDESO
+10 DO FILE^DIE("E","PRCRR","PRCE")
+11 IF $DATA(PRCE("DIERR"))
SET PRCY=0
FOR
SET PRCY=$ORDER(PRCE("DIERR",1,"TEXT",PRCY))
if PRCY'>0
QUIT
DO ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
+12 IF $DATA(PRCE("DIERR"))
KILL PRCRR
QUIT
+13 KILL PRCRR,PRCERR
SET PRCDESO=$EXTRACT(PRCDESO,1,36)
+14 IF '$$FIND1^DIC(441.05,","_PRCDA_",","X",PRCDESO,"","","PRCE")
Begin DoDot:3
+15 SET PRCRR(441.05,"+1,"_PRCDA_",",.01)=PRCDESO
DO UPDATE^DIE("E","PRCRR","","PRCERR")
+16 IF $DATA(PRCERR("DIERR"))
SET PRCY=0
FOR
SET PRCY=$ORDER(PRCERR("DIERR",1,"TEXT",PRCY))
if PRCY'>0
QUIT
DO ERR("Item Master Number "_PRCDA_": "_PRCERR("DIERR",1,"TEXT",PRCY))
+17 KILL PRCRR,PRCERR
End DoDot:3
End DoDot:2
IF $DATA(PRCE("DIERR"))
KILL PRCE,PRCRR
QUIT
+18 KILL PRCRR,PRCE
SET PRCRR(441,PRCDA_",",.05)=PRCDES
DO FILE^DIE("E","PRCRR","PRCE")
+19 IF $DATA(PRCE("DIERR"))
SET PRCY=0
FOR
SET PRCY=$ORDER(PRCE("DIERR",1,"TEXT",PRCY))
if PRCY'>0
QUIT
DO ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
+20 KILL PRCRR,PRCE
End DoDot:1
+21 ; save off prior description during first NIF import
+22 ; if save fails, don't overwrite existing description with NIF extended description
+23 IF PRCFLG
IF $PIECE($GET(^PRC(441,PRCDA,8,0)),U,4)'>0
Begin DoDot:1
+24 KILL PRCE
DO WP^DIE(441,PRCDA_",",50,"","^PRC(441,PRCDA,1)","PRCE")
+25 IF $DATA(PRCE("DIERR"))
SET PRCY=0
FOR
SET PRCY=$ORDER(PRCE("DIERR",1,"TEXT",PRCY))
if PRCY'>0
QUIT
DO ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
End DoDot:1
IF $DATA(PRCE("DIERR"))
KILL PRCE
QUIT
+26 ; extract extended description
+27 SET PRCI=0
KILL PRCY
+28 FOR
SET PRCSUB=$ORDER(^XTMP(PRCHNODE,1,PRCSUB))
if PRCSUB=""
QUIT
SET PRCX=$GET(^XTMP(PRCHNODE,1,PRCSUB))
if $PIECE(PRCX,U)'="G69"
QUIT
Begin DoDot:1
+29 SET PRCI=PRCI+1
SET PRCY(PRCI)=$PIECE($GET(^XTMP(PRCHNODE,1,PRCSUB)),U,2)
End DoDot:1
+30 IF PRCI'>0
DO ERR("No extended description exists for NIF Item Number "_PRCNIF_".")
+31 IF PRCI
Begin DoDot:1
+32 ; file NIF extended description in description field
+33 KILL PRCE
DO WP^DIE(441,PRCDA_",",.1,"","PRCY","PRCE")
+34 KILL PRCY
+35 IF $DATA(PRCE("DIERR"))
SET PRCY=0
FOR
SET PRCY=$ORDER(PRCE("DIERR",1,"TEXT",PRCY))
if PRCY'>0
QUIT
DO ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
+36 KILL PRCE
End DoDot:1
+37 SET PRCSUB=$ORDER(^XTMP(PRCHNODE,1,PRCSUB),-1)
+38 QUIT
ERR(PRCMSG) ;Error processing
+1 SET PRCERRC=PRCERRC+1
SET ^XTMP(PRCHNODE,"ERR",PRCERRC)=PRCMSG
+2 QUIT
