PRCHITM3 ;OI&T/LKG - READING 832 TXN IN HOST FILE ;12/20/21 22:14
;;5.1;IFCAP;**198,226**;OCT 20, 2000;Build 2
;Per VA Directive 6402, this routine should not be modified.
;Integration agreements
; ICR #2320: CLOSE^%ZISH(),$$LIST^%ZISH(),OPEN^%ZISH(),$$STATUS^%ZISH()
; ICR #2171: $$STA^XUAF4()
; ICR #2541: $$KSP^XUPARAM()
; ICR #4440: $$PROD^XUPROD()
; ICR #10026: ^DIR
; ICR #10070: ^XMD
; ICR #10142: EN^DDIOL()
ST ;Entry point
N DIR,DTOUT,DUOUT,DIROUT,DIRUT,POP,X,Y,PRCI,PRCLFARR,PRCLFDIR,PRCLFF,PRCLFFIL,PRCLFIN,PRCFATAL S PRCFATAL=0
N ZTSK,ZTSAVE,ZTDTM,ZTRTN,ZTDESC,ZTIO,PRCX
GETDIR S DIR(0)="FA^1:75",DIR("A")="Enter the file's directory: ",DIR("B")="/srv/vista/patches/.NIF/"
S DIR("?",1)="Enter name of the directory containing the file.",DIR("?")=" Directory value is up to 75 characters in the format for the operating system."
D ^DIR I $D(DIRUT) S PRCFATAL=1 G END
S PRCLFDIR=Y
K DIR S DIR(0)="FA^1:50^K:X'?1.46ANP1"".""3A X",DIR("A")="Enter file name: ",DIR("?",1)="Enter the name of file with extension that you wish to process."
S DIR("?")="File name up to 50 characters, without directory."
D ^DIR I $D(DIRUT) S PRCFATAL=1 G END
S PRCLFFIL=Y K DIR
S PRCLFF(PRCLFFIL)="",PRCX=$$LIST^%ZISH(PRCLFDIR,"PRCLFF","PRCLFARR")
K PRCLFF,PRCLFARR
I 'PRCX W !,"File not found!" G GETDIR
D OPEN^%ZISH("PRCLFIN",PRCLFDIR,PRCLFFIL,"R",)
I POP W !,"Unable to open file "_PRCLFDIR_PRCLFFIL_"." S PRCFATAL=1 G END
U IO
F PRCI=1:1 R PRCX:DTIME Q:$E(PRCX,1,4)="ISA^" Q:$$STATUS^%ZISH!($P(PRCX,"^")="***END OF FILE***")
I $E(PRCX,1,4)'="ISA^" U IO(0) D EN^DDIOL("*** ISA segment is missing. ***","","!!?10") S PRCFATAL=1 D CLOSE^%ZISH("PRCLFIN") G END
U IO(0) W !
N PRCISITE,PRCRSITE S PRCISITE=$P($P($P(PRCX,"^",9),"~",2)," "),PRCRSITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))
S:PRCISITE="" PRCISITE="not specified"
I PRCISITE'="ALL",PRCISITE'=PRCRSITE D G END
. N PRCMSG S PRCMSG(1)="*** Wrong receiving station; Import aborted ***"
. S PRCMSG(2)="832 Txn ICN "_$P(PRCX,"^",14)_" for station "_PRCISITE_" was sent to "_PRCRSITE_"."
. D EN^DDIOL(.PRCMSG)
. S PRCFATAL=1 D CLOSE^%ZISH("PRCLFIN")
K DIR S DIR(0)="YA",DIR("A")="Do you want to queue the item load? ",DIR("B")="YES"
S DIR("?")="Enter 'YES' to run in background or 'NO' to run in foreground."
D ^DIR I $D(DIRUT) S PRCFATAL=1 D CLOSE^%ZISH("PRCLFIN") G END
I Y D G END
. D CLOSE^%ZISH("PRCLFIN")
. S ZTRTN="RUN^PRCHITM3",ZTDESC="NIF/IFCAP Item Load",ZTIO=""
. S ZTSAVE("PRCLFDIR")="",ZTSAVE("PRCLFFIL")="",ZTSAVE("DUZ")="",ZTSAVE("DTIME")=""
. D ^%ZTLOAD W !,"Task #=",$G(ZTSK)
U IO
;
RUN ;
N POP,X,Y,PRCI,PRCJ,PRCK,PRCLFIN,PRCLFARR I $D(ZTQUEUED) N PRCX
N PRCTXN,PRCHNODE,PRCERRC,PRCLCTR,PRCIUPD,PRCITC,PRCFATAL S PRCLCTR=0,PRCIUPD=0,PRCFATAL=0
N PRCSTN S PRCSTN=$$STA^XUAF4($$KSP^XUPARAM("INST"))
I $D(ZTQUEUED) D G:POP END
. D OPEN^%ZISH("PRCLFIN",PRCLFDIR,PRCLFFIL,"R",,"P-OTHER")
. I POP D Q
. . N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
. . S XMSUB="NIF/IFCAP Item Load Failure",XMDUZ=.5,XMY("G.ISM")="",XMY(DUZ)=""
. . S PRCARR(1)="Unable to open host file "_PRCLFDIR_PRCLFFIL,XMTEXT="PRCARR("
. . D ^XMD
. U IO
. F PRCI=1:1 R PRCX:DTIME Q:$E(PRCX,1,4)="ISA^" Q:$$STATUS^%ZISH
I '$$STATUS^%ZISH D
. S PRCTXN=$P(PRCX,"^",14) D INITLOG^PRCHITM5(PRCTXN)
. F PRCI=1:1 R PRCX:DTIME Q:$$STATUS^%ZISH!($E(PRCX,1,4)="IEA^") D Q:$$STATUS^%ZISH
. . I $E(PRCX,1,3)="ST^" D PROCTXN
D CLOSE^%ZISH("PRCLFIN")
I $D(PRCHNODE),$D(^XTMP(PRCHNODE,"ERR")) D
. N PRCARR,PRCC,PRCI,PRCJ,PRCK,PRCL S PRCC=0,PRCI=0,PRCJ=0,PRCK=0,PRCL=120
. F S PRCI=$O(^XTMP(PRCHNODE,"ERR",PRCI)) Q:PRCI="" S PRCC=PRCC+1
. S PRCC=PRCC\PRCL+$S(PRCC#PRCL>0:1,1:0),PRCI=0
. F S PRCI=$O(^XTMP(PRCHNODE,"ERR",PRCI)) Q:PRCI="" D
. . S PRCJ=PRCJ+1,PRCARR(PRCJ)=^XTMP(PRCHNODE,"ERR",PRCI)
. . I PRCJ=PRCL D
. . . S PRCK=PRCK+1 D SEND(.PRCARR,$P(PRCHNODE,";",2),PRCK,PRCC,PRCSTN)
. . . K PRCARR S PRCJ=0
. I $D(PRCARR) S PRCK=PRCK+1 D SEND(.PRCARR,$P(PRCHNODE,";",2),PRCK,PRCC,PRCSTN)
I $D(PRCHNODE) D
. N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCARR
. S XMSUB="Stn "_PRCSTN_" Statistics NIF/IFCAP 832 Txn ICN "_$P(PRCHNODE,";",2)
. S PRCARR(1)="Transaction Item Lines Processed: "_PRCLCTR,PRCARR(2)="Item Master File Entries Updated: "_PRCIUPD
. S XMDUZ=.5,XMTEXT="PRCARR(",XMY("G.ISM")="",XMY(DUZ)=""
. S:$$PROD^XUPROD() XMY("VHANIFMO@domain.ext")=""
. D ^XMD
;
END ;
S:$D(ZTQUEUED) ZTREQ="@"
W:'$D(ZTQUEUED) !!,$S(PRCFATAL:"<LOAD ABORTED>",1:"<DONE>")
K ^TMP($J,"PRCHITM3") K PRCLFDIR,PRCLFFILE
Q
;
PROCTXN ;
K ^TMP($J,"PRCHITM3") N PRCTRANS,PRCTXNTYPE S PRCTRANS=$P(PRCX,"^",3),PRCTXNTYPE=$P(PRCX,"^",2)
I PRCTXNTYPE'=832 D ERR^PRCHITM5("Trans #"_PRCTRANS_" is not X.12 832 type.") Q
F PRCJ=1:1 R PRCX:DTIME Q:$E(PRCX,1,3)="SE^"!$$STATUS^%ZISH D Q:$$STATUS^%ZISH
. D:$E(PRCX,1,4)="REF^" REF
. D:$E(PRCX,1,3)="N1^" N1
. I $E(PRCX,1,4)="LIN^" D LIN S PRCLCTR=PRCLCTR+1 I '$D(ZTQUEUED),PRCLCTR#25=0 U IO(0) W:$X>60 ! W $J(PRCLCTR,6) U IO
Q
REF ;Process REF segments
I $P(PRCX,"^",4)="IEN",$P(PRCX,"^",3)'="" S ^TMP($J,"PRCHITM3","VEN","IEN")=$P(PRCX,"^",3)
E D ERR^PRCHITM5("Erroneous vendor '"_$P(PRCX,"^",4)_"' REF segment for ST #"_PRCTRANS_".")
Q
N1 ;
N PRCL,PRCM S PRCM=0
Q:$P(PRCX,"^",3)="" N PRCTYPE,PRCVALUE
S PRCTYPE=$P(PRCX,"^",5),PRCVALUE=$P(PRCX,"^",3)
I PRCTYPE="ORDER" S ^TMP($J,"PRCHITM3","VEN","ORDER NAME")=PRCVALUE
E D ERR^PRCHITM5("Erroneous vendor '"_PRCTYPE_"' N1 segment for ST #"_PRCTRANS_".")
Q
LIN ;Process Item Lines
N PRCLNCT,PRCLIN,PRCREFCT S PRCLNCT=0,PRCLIN=$P(PRCX,"^",2),PRCREFCT=0
K ^TMP($J,"PRCHITM3","ITEM")
S:$P(PRCX,"^",4)'="" ^TMP($J,"PRCHITM3","ITEM","NIF#")=$P(PRCX,"^",4)
S:$P(PRCX,"^",6)'="" ^TMP($J,"PRCHITM3","ITEM","FSC")=$P(PRCX,"^",6)
S:$P(PRCX,"^",8)'="" ^TMP($J,"PRCHITM3","ITEM","NSN")=$P(PRCX,"^",8)
S:$P(PRCX,"^",10)'="" ^TMP($J,"PRCHITM3","ITEM","MFG PART")=$P(PRCX,"^",10)
S:$P(PRCX,"^",12)'="" ^TMP($J,"PRCHITM3","ITEM","VSTOCK#")=$P(PRCX,"^",12)
S:$P(PRCX,"^",14)'="" ^TMP($J,"PRCHITM3","ITEM","NDC")=$P(PRCX,"^",14)
S:$P(PRCX,"^",18)'="" ^TMP($J,"PRCHITM3","ITEM","BOC")=$P(PRCX,"^",18)
S:$P(PRCX,"^",20)'="" ^TMP($J,"PRCHITM3","ITEM","DRUG TYPE")=$P(PRCX,"^",20)
S:$P(PRCX,"^",22)'="" ^TMP($J,"PRCHITM3","ITEM","MANUFACTURER")=$P(PRCX,"^",22)
S:$P(PRCX,"^",24)'="" ^TMP($J,"PRCHITM3","ITEM","SOURCE MFG PART#")=$P(PRCX,"^",24)
S:$P(PRCX,"^",26)'="" ^TMP($J,"PRCHITM3","ITEM","SOURCE VENDOR STOCK#")=$P(PRCX,"^",26)
F PRCK=1:1 R PRCX:DTIME Q:$$STATUS^%ZISH D Q:$E(PRCX,1,4)="G55^"
. D:$E(PRCX,1,4)="SLN^" SLN
. D:$E(PRCX,1,4)="DTM^" DTM
. D:$E(PRCX,1,4)="REF^" IREF
. D:$E(PRCX,1,4)="CTB^" CTB
. D:$E(PRCX,1,4)="PID^" PID
. D:$E(PRCX,1,4)="PKG^" PKG
. D:$E(PRCX,1,4)="PO4^" PO4
. D:$E(PRCX,1,4)="G55^" G55
D FILE^PRCHITM5(PRCTRANS,PRCLIN,.PRCITC) S PRCIUPD=PRCIUPD+PRCITC
Q
SLN ;
S:$P(PRCX,"^",6)'="" ^TMP($J,"PRCHITM3","ITEM","UOP")=$P(PRCX,"^",6)
S:$P(PRCX,"^",7)'="" ^TMP($J,"PRCHITM3","ITEM","UNIT COST")=$P(PRCX,"^",7)
S:$P(PRCX,"^",11)'="" ^TMP($J,"PRCHITM3","ITEM","CONTRACT")=$P(PRCX,"^",11)
Q
DTM ;
I $P(PRCX,"^",3)'="",$P(PRCX,"^",2)=167 S ^TMP($J,"PRCHITM3","ITEM","NIF UPDATE DATE")=$P(PRCX,"^",3)
Q
IREF ;
S:$P(PRCX,"^",4)'="" PRCREFCT=PRCREFCT+1,^TMP($J,"PRCHITM3","ITEM","SYN",PRCREFCT)=$P(PRCX,"^",4)
Q
CTB ;
N PRCCODE,PRCVALUE S PRCCODE=$P(PRCX,"^",4),PRCVALUE=$P(PRCX,"^",5)
I PRCCODE=57 S ^TMP($J,"PRCHITM3","ITEM","MIN QTY")=PRCVALUE
E I PRCCODE=70 S ^TMP($J,"PRCHITM3","ITEM","MAX QTY")=PRCVALUE
E I PRCCODE="AP" S ^TMP($J,"PRCHITM3","ITEM","ORDER QTY MULTIPLE")=PRCVALUE
Q
PID ;
S PRCLNCT=PRCLNCT+1
S:$P(PRCX,"^",6)'="" ^TMP($J,"PRCHITM3","ITEM","LONG DESC",PRCLNCT)=$P(PRCX,"^",6)
Q
PKG ;
S:$P(PRCX,"^",5)'="" ^TMP($J,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR")=$P(PRCX,"^",5)
S:$P(PRCX,"^",6)'="" ^TMP($J,"PRCHITM3","ITEM","SHORT DESC")=$P(PRCX,"^",6)
Q
PO4 ;
S:$P(PRCX,"^",2)'="" ^TMP($J,"PRCHITM3","ITEM","PKG MULT")=$P(PRCX,"^",2)
Q
G55 ;
S:$P(PRCX,"^",3)'="" ^TMP($J,"PRCHITM3","ITEM","IMFNBR")=$P(PRCX,"^",3)
S:$P(PRCX,"^",5)'="" ^TMP($J,"PRCHITM3","ITEM","STOCK KEEPING UNIT")=$P(PRCX,"^",5)
S PRCX="G55^"
Q
;
; Send e-mails with error messages
SEND(PRCA,PRCB,PRCC,PRCD,PRCE) ;
N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
S XMSUB="Stn "_PRCE_" Errors NIF/IFCAP 832 Txn ICN "_PRCB_" Msg #"_PRCC_" of "_PRCD
S XMDUZ=.5,XMTEXT="PRCA(",XMY("G.ISM")="",XMY(DUZ)=""
S:$$PROD^XUPROD() XMY("VHANIFMO@domain.ext")=""
D ^XMD
Q
;
;PRCHITM3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHITM3 8565 printed Nov 22, 2024@17:18:08 Page 2
PRCHITM3 ;OI&T/LKG - READING 832 TXN IN HOST FILE ;12/20/21 22:14
+1 ;;5.1;IFCAP;**198,226**;OCT 20, 2000;Build 2
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;Integration agreements
+4 ; ICR #2320: CLOSE^%ZISH(),$$LIST^%ZISH(),OPEN^%ZISH(),$$STATUS^%ZISH()
+5 ; ICR #2171: $$STA^XUAF4()
+6 ; ICR #2541: $$KSP^XUPARAM()
+7 ; ICR #4440: $$PROD^XUPROD()
+8 ; ICR #10026: ^DIR
+9 ; ICR #10070: ^XMD
+10 ; ICR #10142: EN^DDIOL()
ST ;Entry point
+1 NEW DIR,DTOUT,DUOUT,DIROUT,DIRUT,POP,X,Y,PRCI,PRCLFARR,PRCLFDIR,PRCLFF,PRCLFFIL,PRCLFIN,PRCFATAL
SET PRCFATAL=0
+2 NEW ZTSK,ZTSAVE,ZTDTM,ZTRTN,ZTDESC,ZTIO,PRCX
GETDIR SET DIR(0)="FA^1:75"
SET DIR("A")="Enter the file's directory: "
SET DIR("B")="/srv/vista/patches/.NIF/"
+1 SET DIR("?",1)="Enter name of the directory containing the file."
SET DIR("?")=" Directory value is up to 75 characters in the format for the operating system."
+2 DO ^DIR
IF $DATA(DIRUT)
SET PRCFATAL=1
GOTO END
+3 SET PRCLFDIR=Y
+4 KILL DIR
SET DIR(0)="FA^1:50^K:X'?1.46ANP1"".""3A X"
SET DIR("A")="Enter file name: "
SET DIR("?",1)="Enter the name of file with extension that you wish to process."
+5 SET DIR("?")="File name up to 50 characters, without directory."
+6 DO ^DIR
IF $DATA(DIRUT)
SET PRCFATAL=1
GOTO END
+7 SET PRCLFFIL=Y
KILL DIR
+8 SET PRCLFF(PRCLFFIL)=""
SET PRCX=$$LIST^%ZISH(PRCLFDIR,"PRCLFF","PRCLFARR")
+9 KILL PRCLFF,PRCLFARR
+10 IF 'PRCX
WRITE !,"File not found!"
GOTO GETDIR
+11 DO OPEN^%ZISH("PRCLFIN",PRCLFDIR,PRCLFFIL,"R",)
+12 IF POP
WRITE !,"Unable to open file "_PRCLFDIR_PRCLFFIL_"."
SET PRCFATAL=1
GOTO END
+13 USE IO
+14 FOR PRCI=1:1
READ PRCX:DTIME
if $EXTRACT(PRCX,1,4)="ISA^"
QUIT
if $$STATUS^%ZISH!($PIECE(PRCX,"^")="***END OF FILE***")
QUIT
+15 IF $EXTRACT(PRCX,1,4)'="ISA^"
USE IO(0)
DO EN^DDIOL("*** ISA segment is missing. ***","","!!?10")
SET PRCFATAL=1
DO CLOSE^%ZISH("PRCLFIN")
GOTO END
+16 USE IO(0)
WRITE !
+17 NEW PRCISITE,PRCRSITE
SET PRCISITE=$PIECE($PIECE($PIECE(PRCX,"^",9),"~",2)," ")
SET PRCRSITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+18 if PRCISITE=""
SET PRCISITE="not specified"
+19 IF PRCISITE'="ALL"
IF PRCISITE'=PRCRSITE
Begin DoDot:1
+20 NEW PRCMSG
SET PRCMSG(1)="*** Wrong receiving station; Import aborted ***"
+21 SET PRCMSG(2)="832 Txn ICN "_$PIECE(PRCX,"^",14)_" for station "_PRCISITE_" was sent to "_PRCRSITE_"."
+22 DO EN^DDIOL(.PRCMSG)
+23 SET PRCFATAL=1
DO CLOSE^%ZISH("PRCLFIN")
End DoDot:1
GOTO END
+24 KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Do you want to queue the item load? "
SET DIR("B")="YES"
+25 SET DIR("?")="Enter 'YES' to run in background or 'NO' to run in foreground."
+26 DO ^DIR
IF $DATA(DIRUT)
SET PRCFATAL=1
DO CLOSE^%ZISH("PRCLFIN")
GOTO END
+27 IF Y
Begin DoDot:1
+28 DO CLOSE^%ZISH("PRCLFIN")
+29 SET ZTRTN="RUN^PRCHITM3"
SET ZTDESC="NIF/IFCAP Item Load"
SET ZTIO=""
+30 SET ZTSAVE("PRCLFDIR")=""
SET ZTSAVE("PRCLFFIL")=""
SET ZTSAVE("DUZ")=""
SET ZTSAVE("DTIME")=""
+31 DO ^%ZTLOAD
WRITE !,"Task #=",$GET(ZTSK)
End DoDot:1
GOTO END
+32 USE IO
+33 ;
RUN ;
+1 NEW POP,X,Y,PRCI,PRCJ,PRCK,PRCLFIN,PRCLFARR
IF $DATA(ZTQUEUED)
NEW PRCX
+2 NEW PRCTXN,PRCHNODE,PRCERRC,PRCLCTR,PRCIUPD,PRCITC,PRCFATAL
SET PRCLCTR=0
SET PRCIUPD=0
SET PRCFATAL=0
+3 NEW PRCSTN
SET PRCSTN=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+4 IF $DATA(ZTQUEUED)
Begin DoDot:1
+5 DO OPEN^%ZISH("PRCLFIN",PRCLFDIR,PRCLFFIL,"R",,"P-OTHER")
+6 IF POP
Begin DoDot:2
+7 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
+8 SET XMSUB="NIF/IFCAP Item Load Failure"
SET XMDUZ=.5
SET XMY("G.ISM")=""
SET XMY(DUZ)=""
+9 SET PRCARR(1)="Unable to open host file "_PRCLFDIR_PRCLFFIL
SET XMTEXT="PRCARR("
+10 DO ^XMD
End DoDot:2
QUIT
+11 USE IO
+12 FOR PRCI=1:1
READ PRCX:DTIME
if $EXTRACT(PRCX,1,4)="ISA^"
QUIT
if $$STATUS^%ZISH
QUIT
End DoDot:1
if POP
GOTO END
+13 IF '$$STATUS^%ZISH
Begin DoDot:1
+14 SET PRCTXN=$PIECE(PRCX,"^",14)
DO INITLOG^PRCHITM5(PRCTXN)
+15 FOR PRCI=1:1
READ PRCX:DTIME
if $$STATUS^%ZISH!($EXTRACT(PRCX,1,4)="IEA^")
QUIT
Begin DoDot:2
+16 IF $EXTRACT(PRCX,1,3)="ST^"
DO PROCTXN
End DoDot:2
if $$STATUS^%ZISH
QUIT
End DoDot:1
+17 DO CLOSE^%ZISH("PRCLFIN")
+18 IF $DATA(PRCHNODE)
IF $DATA(^XTMP(PRCHNODE,"ERR"))
Begin DoDot:1
+19 NEW PRCARR,PRCC,PRCI,PRCJ,PRCK,PRCL
SET PRCC=0
SET PRCI=0
SET PRCJ=0
SET PRCK=0
SET PRCL=120
+20 FOR
SET PRCI=$ORDER(^XTMP(PRCHNODE,"ERR",PRCI))
if PRCI=""
QUIT
SET PRCC=PRCC+1
+21 SET PRCC=PRCC\PRCL+$SELECT(PRCC#PRCL>0:1,1:0)
SET PRCI=0
+22 FOR
SET PRCI=$ORDER(^XTMP(PRCHNODE,"ERR",PRCI))
if PRCI=""
QUIT
Begin DoDot:2
+23 SET PRCJ=PRCJ+1
SET PRCARR(PRCJ)=^XTMP(PRCHNODE,"ERR",PRCI)
+24 IF PRCJ=PRCL
Begin DoDot:3
+25 SET PRCK=PRCK+1
DO SEND(.PRCARR,$PIECE(PRCHNODE,";",2),PRCK,PRCC,PRCSTN)
+26 KILL PRCARR
SET PRCJ=0
End DoDot:3
End DoDot:2
+27 IF $DATA(PRCARR)
SET PRCK=PRCK+1
DO SEND(.PRCARR,$PIECE(PRCHNODE,";",2),PRCK,PRCC,PRCSTN)
End DoDot:1
+28 IF $DATA(PRCHNODE)
Begin DoDot:1
+29 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCARR
+30 SET XMSUB="Stn "_PRCSTN_" Statistics NIF/IFCAP 832 Txn ICN "_$PIECE(PRCHNODE,";",2)
+31 SET PRCARR(1)="Transaction Item Lines Processed: "_PRCLCTR
SET PRCARR(2)="Item Master File Entries Updated: "_PRCIUPD
+32 SET XMDUZ=.5
SET XMTEXT="PRCARR("
SET XMY("G.ISM")=""
SET XMY(DUZ)=""
+33 if $$PROD^XUPROD()
SET XMY("VHANIFMO@domain.ext")=""
+34 DO ^XMD
End DoDot:1
+35 ;
END ;
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 if '$DATA(ZTQUEUED)
WRITE !!,$SELECT(PRCFATAL:"<LOAD ABORTED>",1:"<DONE>")
+3 KILL ^TMP($JOB,"PRCHITM3")
KILL PRCLFDIR,PRCLFFILE
+4 QUIT
+5 ;
PROCTXN ;
+1 KILL ^TMP($JOB,"PRCHITM3")
NEW PRCTRANS,PRCTXNTYPE
SET PRCTRANS=$PIECE(PRCX,"^",3)
SET PRCTXNTYPE=$PIECE(PRCX,"^",2)
+2 IF PRCTXNTYPE'=832
DO ERR^PRCHITM5("Trans #"_PRCTRANS_" is not X.12 832 type.")
QUIT
+3 FOR PRCJ=1:1
READ PRCX:DTIME
if $EXTRACT(PRCX,1,3)="SE^"!$$STATUS^%ZISH
QUIT
Begin DoDot:1
+4 if $EXTRACT(PRCX,1,4)="REF^"
DO REF
+5 if $EXTRACT(PRCX,1,3)="N1^"
DO N1
+6 IF $EXTRACT(PRCX,1,4)="LIN^"
DO LIN
SET PRCLCTR=PRCLCTR+1
IF '$DATA(ZTQUEUED)
IF PRCLCTR#25=0
USE IO(0)
if $X>60
WRITE !
WRITE $JUSTIFY(PRCLCTR,6)
USE IO
End DoDot:1
if $$STATUS^%ZISH
QUIT
+7 QUIT
REF ;Process REF segments
+1 IF $PIECE(PRCX,"^",4)="IEN"
IF $PIECE(PRCX,"^",3)'=""
SET ^TMP($JOB,"PRCHITM3","VEN","IEN")=$PIECE(PRCX,"^",3)
+2 IF '$TEST
DO ERR^PRCHITM5("Erroneous vendor '"_$PIECE(PRCX,"^",4)_"' REF segment for ST #"_PRCTRANS_".")
+3 QUIT
N1 ;
+1 NEW PRCL,PRCM
SET PRCM=0
+2 if $PIECE(PRCX,"^",3)=""
QUIT
NEW PRCTYPE,PRCVALUE
+3 SET PRCTYPE=$PIECE(PRCX,"^",5)
SET PRCVALUE=$PIECE(PRCX,"^",3)
+4 IF PRCTYPE="ORDER"
SET ^TMP($JOB,"PRCHITM3","VEN","ORDER NAME")=PRCVALUE
+5 IF '$TEST
DO ERR^PRCHITM5("Erroneous vendor '"_PRCTYPE_"' N1 segment for ST #"_PRCTRANS_".")
+6 QUIT
LIN ;Process Item Lines
+1 NEW PRCLNCT,PRCLIN,PRCREFCT
SET PRCLNCT=0
SET PRCLIN=$PIECE(PRCX,"^",2)
SET PRCREFCT=0
+2 KILL ^TMP($JOB,"PRCHITM3","ITEM")
+3 if $PIECE(PRCX,"^",4)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","NIF#")=$PIECE(PRCX,"^",4)
+4 if $PIECE(PRCX,"^",6)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","FSC")=$PIECE(PRCX,"^",6)
+5 if $PIECE(PRCX,"^",8)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","NSN")=$PIECE(PRCX,"^",8)
+6 if $PIECE(PRCX,"^",10)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","MFG PART")=$PIECE(PRCX,"^",10)
+7 if $PIECE(PRCX,"^",12)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","VSTOCK#")=$PIECE(PRCX,"^",12)
+8 if $PIECE(PRCX,"^",14)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","NDC")=$PIECE(PRCX,"^",14)
+9 if $PIECE(PRCX,"^",18)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","BOC")=$PIECE(PRCX,"^",18)
+10 if $PIECE(PRCX,"^",20)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","DRUG TYPE")=$PIECE(PRCX,"^",20)
+11 if $PIECE(PRCX,"^",22)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","MANUFACTURER")=$PIECE(PRCX,"^",22)
+12 if $PIECE(PRCX,"^",24)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","SOURCE MFG PART#")=$PIECE(PRCX,"^",24)
+13 if $PIECE(PRCX,"^",26)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","SOURCE VENDOR STOCK#")=$PIECE(PRCX,"^",26)
+14 FOR PRCK=1:1
READ PRCX:DTIME
if $$STATUS^%ZISH
QUIT
Begin DoDot:1
+15 if $EXTRACT(PRCX,1,4)="SLN^"
DO SLN
+16 if $EXTRACT(PRCX,1,4)="DTM^"
DO DTM
+17 if $EXTRACT(PRCX,1,4)="REF^"
DO IREF
+18 if $EXTRACT(PRCX,1,4)="CTB^"
DO CTB
+19 if $EXTRACT(PRCX,1,4)="PID^"
DO PID
+20 if $EXTRACT(PRCX,1,4)="PKG^"
DO PKG
+21 if $EXTRACT(PRCX,1,4)="PO4^"
DO PO4
+22 if $EXTRACT(PRCX,1,4)="G55^"
DO G55
End DoDot:1
if $EXTRACT(PRCX,1,4)="G55^"
QUIT
+23 DO FILE^PRCHITM5(PRCTRANS,PRCLIN,.PRCITC)
SET PRCIUPD=PRCIUPD+PRCITC
+24 QUIT
SLN ;
+1 if $PIECE(PRCX,"^",6)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","UOP")=$PIECE(PRCX,"^",6)
+2 if $PIECE(PRCX,"^",7)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","UNIT COST")=$PIECE(PRCX,"^",7)
+3 if $PIECE(PRCX,"^",11)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","CONTRACT")=$PIECE(PRCX,"^",11)
+4 QUIT
DTM ;
+1 IF $PIECE(PRCX,"^",3)'=""
IF $PIECE(PRCX,"^",2)=167
SET ^TMP($JOB,"PRCHITM3","ITEM","NIF UPDATE DATE")=$PIECE(PRCX,"^",3)
+2 QUIT
IREF ;
+1 if $PIECE(PRCX,"^",4)'=""
SET PRCREFCT=PRCREFCT+1
SET ^TMP($JOB,"PRCHITM3","ITEM","SYN",PRCREFCT)=$PIECE(PRCX,"^",4)
+2 QUIT
CTB ;
+1 NEW PRCCODE,PRCVALUE
SET PRCCODE=$PIECE(PRCX,"^",4)
SET PRCVALUE=$PIECE(PRCX,"^",5)
+2 IF PRCCODE=57
SET ^TMP($JOB,"PRCHITM3","ITEM","MIN QTY")=PRCVALUE
+3 IF '$TEST
IF PRCCODE=70
SET ^TMP($JOB,"PRCHITM3","ITEM","MAX QTY")=PRCVALUE
+4 IF '$TEST
IF PRCCODE="AP"
SET ^TMP($JOB,"PRCHITM3","ITEM","ORDER QTY MULTIPLE")=PRCVALUE
+5 QUIT
PID ;
+1 SET PRCLNCT=PRCLNCT+1
+2 if $PIECE(PRCX,"^",6)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","LONG DESC",PRCLNCT)=$PIECE(PRCX,"^",6)
+3 QUIT
PKG ;
+1 if $PIECE(PRCX,"^",5)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR")=$PIECE(PRCX,"^",5)
+2 if $PIECE(PRCX,"^",6)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","SHORT DESC")=$PIECE(PRCX,"^",6)
+3 QUIT
PO4 ;
+1 if $PIECE(PRCX,"^",2)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","PKG MULT")=$PIECE(PRCX,"^",2)
+2 QUIT
G55 ;
+1 if $PIECE(PRCX,"^",3)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","IMFNBR")=$PIECE(PRCX,"^",3)
+2 if $PIECE(PRCX,"^",5)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","STOCK KEEPING UNIT")=$PIECE(PRCX,"^",5)
+3 SET PRCX="G55^"
+4 QUIT
+5 ;
+6 ; Send e-mails with error messages
SEND(PRCA,PRCB,PRCC,PRCD,PRCE) ;
+1 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
+2 SET XMSUB="Stn "_PRCE_" Errors NIF/IFCAP 832 Txn ICN "_PRCB_" Msg #"_PRCC_" of "_PRCD
+3 SET XMDUZ=.5
SET XMTEXT="PRCA("
SET XMY("G.ISM")=""
SET XMY(DUZ)=""
+4 if $$PROD^XUPROD()
SET XMY("VHANIFMO@domain.ext")=""
+5 DO ^XMD
+6 QUIT
+7 ;
+8 ;PRCHITM3
