Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHITM3

PRCHITM3.m

Go to the documentation of this file.
PRCHITM3 ;OI&T/LKG - READING 832 TXN IN HOST FILE ;10/27/17  12:42
 ;;5.1;IFCAP;**198**;OCT 20, 2000;Build 6
 ;Per VA Directive 6402, this routine should not be modified.
 ;Integration agreements
 ; ICR #2320:  CLOSE^%ZISH(),$$DEFDIR^%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")=$$DEFDIR^%ZISH()
 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
 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 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("PRCLLYFIN") 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