- 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 Feb 18, 2025@23:34:25 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
