- 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 23, 2025@18:22:32 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
