PRCHITM4 ;OI&T/LKG - READING 832 TXN IN E-MAIL ;10/27/17 12:44
;;5.1;IFCAP;**198**;OCT 20, 2000;Build 6
;Per VA Directive 6402, this routine should not be modified.
;Integration agreements
; ICR #2171: $$STA^XUAF4()
; ICR #2541: $$KSP^XUPARAM()
; ICR #4440: $$PROD^XUPROD()
; ICR #10070: ^XMD
; ICR #10072: REMSBMSG^XMAIC
Q
IN N XMER,XMRG,PRCTXN,PRCTXNTYPE,PRCHNODE,PRCERRC,PRCLCTR,PRCIUPD,PRCITC S PRCLCTR=0,PRCIUPD=0
N PRCSTN S PRCSTN=$$STA^XUAF4($$KSP^XUPARAM("INST"))
F X XMREC Q:XMER<0!($E(XMRG,1,4)="ISA^")
I XMER<0 G END
S PRCTXN=$P(XMRG,"^",14) D INITLOG^PRCHITM5(PRCTXN)
N PRCISITE S PRCISITE=$P($P($P(XMRG,"^",9),"~",2)," ") S:PRCISITE="" PRCISITE="not specified"
I PRCISITE'="ALL",PRCISITE'=PRCSTN D G END
. D ERR^PRCHITM5("*** Wrong receiving station; Import aborted ***")
. D ERR^PRCHITM5("832 Txn ICN "_PRCTXN_" for station "_PRCISITE_" was sent to "_PRCSTN_".")
F X XMREC Q:XMER<0 D Q:XMER<0
. I $E(XMRG,1,3)="ST^" D PROCTXN
I XMER<0 G END
END ;
I $D(PRCHNODE) D
. ; send message if errors
. I $D(^XTMP(PRCHNODE,"ERR")) D
. . N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
. . S XMSUB="Stn "_PRCSTN_" Errors for NIF/IFCAP 832 Txn ICN "_$P(PRCHNODE,";",2)
. . S XMDUZ=.5,XMTEXT="^XTMP(PRCHNODE,""ERR"","
. . S XMY("G.ISM")="" S:$$PROD^XUPROD() XMY("VHANIFMO@domain.ext")=""
. . D ^XMD
. ; If no errors then delete ^XTMP("PRCHNODE") nodes when done
. I '$D(^XTMP(PRCHNODE,"ERR")) K ^XTMP(PRCHNODE)
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")="" S:$$PROD^XUPROD() XMY("VHANIFMO@domain.ext")=""
. D ^XMD
; delete MailMan message from server basket
I $D(XMZ) S XMSER="S."_XQSOP D REMSBMSG^XMA1C
K ^TMP($J,"PRCHITM3")
Q
;
PROCTXN ;
S PRCTXNTYPE=$P(XMRG,"^",2) N PRCTRANS S PRCTRANS=$P(XMRG,"^",3)
I PRCTXNTYPE'=832 D ERR^PRCHITM5("Trans #"_PRCTRANS_" is not X.12 832 type.") Q
K ^TMP($J,"PRCHITM3")
F X XMREC Q:XMER<0!($E(XMRG,1,3)="SE^") D Q:XMER<0
. D:$E(XMRG,1,4)="REF^" REF
. D:$E(XMRG,1,3)="N1^" N1
. I $E(XMRG,1,4)="LIN^" D LIN S PRCLCTR=PRCLCTR+1
Q
REF ;Process REF segments
I $P(XMRG,"^",4)="IEN",$P(XMRG,"^",3)'="" S ^TMP($J,"PRCHITM3","VEN","IEN")=$P(XMRG,"^",3)
E D ERR^PRCHITM5("Erroneous vendor '"_$P(XMRG,"^",4)_"' REF segment for ST #"_PRCTRANS_".")
Q
N1 ;
N PRCL,PRCM S PRCM=0
Q:$P(XMRG,"^",3)="" N PRCTYPE,PRCVALUE
S PRCTYPE=$P(XMRG,"^",5),PRCVALUE=$P(XMRG,"^",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(XMRG,"^",2),PRCREFCT=0
K ^TMP($J,"PRCHITM3","ITEM")
S:$P(XMRG,"^",4)'="" ^TMP($J,"PRCHITM3","ITEM","NIF#")=$P(XMRG,"^",4)
S:$P(XMRG,"^",6)'="" ^TMP($J,"PRCHITM3","ITEM","FSC")=$P(XMRG,"^",6)
S:$P(XMRG,"^",8)'="" ^TMP($J,"PRCHITM3","ITEM","NSN")=$P(XMRG,"^",8)
S:$P(XMRG,"^",10)'="" ^TMP($J,"PRCHITM3","ITEM","MFG PART")=$P(XMRG,"^",10)
S:$P(XMRG,"^",12)'="" ^TMP($J,"PRCHITM3","ITEM","VSTOCK#")=$P(XMRG,"^",12)
S:$P(XMRG,"^",14)'="" ^TMP($J,"PRCHITM3","ITEM","NDC")=$P(XMRG,"^",14)
S:$P(XMRG,"^",18)'="" ^TMP($J,"PRCHITM3","ITEM","BOC")=$P(XMRG,"^",18)
S:$P(XMRG,"^",20)'="" ^TMP($J,"PRCHITM3","ITEM","DRUG TYPE")=$P(XMRG,"^",20)
S:$P(XMRG,"^",22)'="" ^TMP($J,"PRCHITM3","ITEM","MANUFACTURER")=$P(XMRG,"^",22)
S:$P(XMRG,"^",24)'="" ^TMP($J,"PRCHITM3","ITEM","SOURCE MFG PART#")=$P(XMRG,"^",24)
S:$P(XMRG,"^",26)'="" ^TMP($J,"PRCHITM3","ITEM","SOURCE VENDOR STOCK#")=$P(XMRG,"^",26)
F X XMREC Q:XMER<0 D Q:$E(XMRG,1,4)="G55^"
. D:$E(XMRG,1,4)="SLN^" SLN
. D:$E(XMRG,1,4)="DTM^" DTM
. D:$E(XMRG,1,4)="REF^" IREF
. D:$E(XMRG,1,4)="CTB^" CTB
. D:$E(XMRG,1,4)="PID^" PID
. D:$E(XMRG,1,4)="PKG^" PKG
. D:$E(XMRG,1,4)="PO4^" PO4
. D:$E(XMRG,1,4)="G55^" G55
D FILE^PRCHITM5(PRCTRANS,PRCLIN,.PRCITC) S PRCIUPD=PRCIUPD+PRCITC
Q
SLN ;
S:$P(XMRG,"^",6)'="" ^TMP($J,"PRCHITM3","ITEM","UOP")=$P(XMRG,"^",6)
S:$P(XMRG,"^",7)'="" ^TMP($J,"PRCHITM3","ITEM","UNIT COST")=$P(XMRG,"^",7)
S:$P(XMRG,"^",11)'="" ^TMP($J,"PRCHITM3","ITEM","CONTRACT")=$P(XMRG,"^",11)
Q
IREF ;
S:$P(XMRG,"^",4)'="" PRCREFCT=PRCREFCT+1,^TMP($J,"PRCHITM3","ITEM","SYN",PRCREFCT)=$P(XMRG,"^",4)
Q
DTM ;
I $P(XMRG,"^",3)'="",$P(XMRG,"^",2)=167 S ^TMP($J,"PRCHITM3","ITEM","NIF UPDATE DATE")=$P(XMRG,"^",3)
Q
CTB ;
N PRCCODE,PRCVALUE S PRCCODE=$P(XMRG,"^",4),PRCVALUE=$P(XMRG,"^",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(XMRG,"^",6)'="" ^TMP($J,"PRCHITM3","ITEM","LONG DESC",PRCLNCT)=$P(XMRG,"^",6)
Q
PKG ;
S:$P(XMRG,"^",5)'="" ^TMP($J,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR")=$P(XMRG,"^",5)
S:$P(XMRG,"^",6)'="" ^TMP($J,"PRCHITM3","ITEM","SHORT DESC")=$P(XMRG,"^",6)
Q
PO4 ;
S:$P(XMRG,"^",2)'="" ^TMP($J,"PRCHITM3","ITEM","PKG MULT")=$P(XMRG,"^",2)
Q
G55 ;
S:$P(XMRG,"^",3)'="" ^TMP($J,"PRCHITM3","ITEM","IMFNBR")=$P(XMRG,"^",3)
S:$P(XMRG,"^",5)'="" ^TMP($J,"PRCHITM3","ITEM","STOCK KEEPING UNIT")=$P(XMRG,"^",5)
Q
;
;PRCHITM4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHITM4 5487 printed Apr 09, 2024@21:07:23 Page 2
PRCHITM4 ;OI&T/LKG - READING 832 TXN IN E-MAIL ;10/27/17 12:44
+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 #2171: $$STA^XUAF4()
+5 ; ICR #2541: $$KSP^XUPARAM()
+6 ; ICR #4440: $$PROD^XUPROD()
+7 ; ICR #10070: ^XMD
+8 ; ICR #10072: REMSBMSG^XMAIC
+9 QUIT
IN NEW XMER,XMRG,PRCTXN,PRCTXNTYPE,PRCHNODE,PRCERRC,PRCLCTR,PRCIUPD,PRCITC
SET PRCLCTR=0
SET PRCIUPD=0
+1 NEW PRCSTN
SET PRCSTN=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+2 FOR
XECUTE XMREC
if XMER<0!($EXTRACT(XMRG,1,4)="ISA^")
QUIT
+3 IF XMER<0
GOTO END
+4 SET PRCTXN=$PIECE(XMRG,"^",14)
DO INITLOG^PRCHITM5(PRCTXN)
+5 NEW PRCISITE
SET PRCISITE=$PIECE($PIECE($PIECE(XMRG,"^",9),"~",2)," ")
if PRCISITE=""
SET PRCISITE="not specified"
+6 IF PRCISITE'="ALL"
IF PRCISITE'=PRCSTN
Begin DoDot:1
+7 DO ERR^PRCHITM5("*** Wrong receiving station; Import aborted ***")
+8 DO ERR^PRCHITM5("832 Txn ICN "_PRCTXN_" for station "_PRCISITE_" was sent to "_PRCSTN_".")
End DoDot:1
GOTO END
+9 FOR
XECUTE XMREC
if XMER<0
QUIT
Begin DoDot:1
+10 IF $EXTRACT(XMRG,1,3)="ST^"
DO PROCTXN
End DoDot:1
if XMER<0
QUIT
+11 IF XMER<0
GOTO END
END ;
+1 IF $DATA(PRCHNODE)
Begin DoDot:1
+2 ; send message if errors
+3 IF $DATA(^XTMP(PRCHNODE,"ERR"))
Begin DoDot:2
+4 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
+5 SET XMSUB="Stn "_PRCSTN_" Errors for NIF/IFCAP 832 Txn ICN "_$PIECE(PRCHNODE,";",2)
+6 SET XMDUZ=.5
SET XMTEXT="^XTMP(PRCHNODE,""ERR"","
+7 SET XMY("G.ISM")=""
if $$PROD^XUPROD()
SET XMY("VHANIFMO@domain.ext")=""
+8 DO ^XMD
End DoDot:2
+9 ; If no errors then delete ^XTMP("PRCHNODE") nodes when done
+10 IF '$DATA(^XTMP(PRCHNODE,"ERR"))
KILL ^XTMP(PRCHNODE)
End DoDot:1
+11 IF $DATA(PRCHNODE)
Begin DoDot:1
+12 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCARR
+13 SET XMSUB="Stn "_PRCSTN_" Statistics NIF/IFCAP 832 Txn ICN "_$PIECE(PRCHNODE,";",2)
+14 SET PRCARR(1)="Transaction Item Lines Processed: "_PRCLCTR
SET PRCARR(2)="Item Master File Entries Updated: "_PRCIUPD
+15 SET XMDUZ=.5
SET XMTEXT="PRCARR("
SET XMY("G.ISM")=""
if $$PROD^XUPROD()
SET XMY("VHANIFMO@domain.ext")=""
+16 DO ^XMD
End DoDot:1
+17 ; delete MailMan message from server basket
+18 IF $DATA(XMZ)
SET XMSER="S."_XQSOP
DO REMSBMSG^XMA1C
+19 KILL ^TMP($JOB,"PRCHITM3")
+20 QUIT
+21 ;
PROCTXN ;
+1 SET PRCTXNTYPE=$PIECE(XMRG,"^",2)
NEW PRCTRANS
SET PRCTRANS=$PIECE(XMRG,"^",3)
+2 IF PRCTXNTYPE'=832
DO ERR^PRCHITM5("Trans #"_PRCTRANS_" is not X.12 832 type.")
QUIT
+3 KILL ^TMP($JOB,"PRCHITM3")
+4 FOR
XECUTE XMREC
if XMER<0!($EXTRACT(XMRG,1,3)="SE^")
QUIT
Begin DoDot:1
+5 if $EXTRACT(XMRG,1,4)="REF^"
DO REF
+6 if $EXTRACT(XMRG,1,3)="N1^"
DO N1
+7 IF $EXTRACT(XMRG,1,4)="LIN^"
DO LIN
SET PRCLCTR=PRCLCTR+1
End DoDot:1
if XMER<0
QUIT
+8 QUIT
REF ;Process REF segments
+1 IF $PIECE(XMRG,"^",4)="IEN"
IF $PIECE(XMRG,"^",3)'=""
SET ^TMP($JOB,"PRCHITM3","VEN","IEN")=$PIECE(XMRG,"^",3)
+2 IF '$TEST
DO ERR^PRCHITM5("Erroneous vendor '"_$PIECE(XMRG,"^",4)_"' REF segment for ST #"_PRCTRANS_".")
+3 QUIT
N1 ;
+1 NEW PRCL,PRCM
SET PRCM=0
+2 if $PIECE(XMRG,"^",3)=""
QUIT
NEW PRCTYPE,PRCVALUE
+3 SET PRCTYPE=$PIECE(XMRG,"^",5)
SET PRCVALUE=$PIECE(XMRG,"^",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(XMRG,"^",2)
SET PRCREFCT=0
+2 KILL ^TMP($JOB,"PRCHITM3","ITEM")
+3 if $PIECE(XMRG,"^",4)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","NIF#")=$PIECE(XMRG,"^",4)
+4 if $PIECE(XMRG,"^",6)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","FSC")=$PIECE(XMRG,"^",6)
+5 if $PIECE(XMRG,"^",8)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","NSN")=$PIECE(XMRG,"^",8)
+6 if $PIECE(XMRG,"^",10)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","MFG PART")=$PIECE(XMRG,"^",10)
+7 if $PIECE(XMRG,"^",12)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","VSTOCK#")=$PIECE(XMRG,"^",12)
+8 if $PIECE(XMRG,"^",14)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","NDC")=$PIECE(XMRG,"^",14)
+9 if $PIECE(XMRG,"^",18)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","BOC")=$PIECE(XMRG,"^",18)
+10 if $PIECE(XMRG,"^",20)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","DRUG TYPE")=$PIECE(XMRG,"^",20)
+11 if $PIECE(XMRG,"^",22)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","MANUFACTURER")=$PIECE(XMRG,"^",22)
+12 if $PIECE(XMRG,"^",24)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","SOURCE MFG PART#")=$PIECE(XMRG,"^",24)
+13 if $PIECE(XMRG,"^",26)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","SOURCE VENDOR STOCK#")=$PIECE(XMRG,"^",26)
+14 FOR
XECUTE XMREC
if XMER<0
QUIT
Begin DoDot:1
+15 if $EXTRACT(XMRG,1,4)="SLN^"
DO SLN
+16 if $EXTRACT(XMRG,1,4)="DTM^"
DO DTM
+17 if $EXTRACT(XMRG,1,4)="REF^"
DO IREF
+18 if $EXTRACT(XMRG,1,4)="CTB^"
DO CTB
+19 if $EXTRACT(XMRG,1,4)="PID^"
DO PID
+20 if $EXTRACT(XMRG,1,4)="PKG^"
DO PKG
+21 if $EXTRACT(XMRG,1,4)="PO4^"
DO PO4
+22 if $EXTRACT(XMRG,1,4)="G55^"
DO G55
End DoDot:1
if $EXTRACT(XMRG,1,4)="G55^"
QUIT
+23 DO FILE^PRCHITM5(PRCTRANS,PRCLIN,.PRCITC)
SET PRCIUPD=PRCIUPD+PRCITC
+24 QUIT
SLN ;
+1 if $PIECE(XMRG,"^",6)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","UOP")=$PIECE(XMRG,"^",6)
+2 if $PIECE(XMRG,"^",7)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","UNIT COST")=$PIECE(XMRG,"^",7)
+3 if $PIECE(XMRG,"^",11)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","CONTRACT")=$PIECE(XMRG,"^",11)
+4 QUIT
IREF ;
+1 if $PIECE(XMRG,"^",4)'=""
SET PRCREFCT=PRCREFCT+1
SET ^TMP($JOB,"PRCHITM3","ITEM","SYN",PRCREFCT)=$PIECE(XMRG,"^",4)
+2 QUIT
DTM ;
+1 IF $PIECE(XMRG,"^",3)'=""
IF $PIECE(XMRG,"^",2)=167
SET ^TMP($JOB,"PRCHITM3","ITEM","NIF UPDATE DATE")=$PIECE(XMRG,"^",3)
+2 QUIT
CTB ;
+1 NEW PRCCODE,PRCVALUE
SET PRCCODE=$PIECE(XMRG,"^",4)
SET PRCVALUE=$PIECE(XMRG,"^",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(XMRG,"^",6)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","LONG DESC",PRCLNCT)=$PIECE(XMRG,"^",6)
+3 QUIT
PKG ;
+1 if $PIECE(XMRG,"^",5)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","UNIT CONVERSION FACTOR")=$PIECE(XMRG,"^",5)
+2 if $PIECE(XMRG,"^",6)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","SHORT DESC")=$PIECE(XMRG,"^",6)
+3 QUIT
PO4 ;
+1 if $PIECE(XMRG,"^",2)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","PKG MULT")=$PIECE(XMRG,"^",2)
+2 QUIT
G55 ;
+1 if $PIECE(XMRG,"^",3)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","IMFNBR")=$PIECE(XMRG,"^",3)
+2 if $PIECE(XMRG,"^",5)'=""
SET ^TMP($JOB,"PRCHITM3","ITEM","STOCK KEEPING UNIT")=$PIECE(XMRG,"^",5)
+3 QUIT
+4 ;
+5 ;PRCHITM4
