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

PRCHITM6.m

Go to the documentation of this file.
PRCHITM6 ;OI&T/LKG - LOAD MANUFACTURER ENTRIES FROM HOST FILE ;12/20/21  22:15
 ;;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.",DIR("B")="NIFMFGFILE.TXT"
 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:$P(PRCX,"^",1,2)="HDR^MANUFACTURER LIST"  Q:$$STATUS^%ZISH
 I $P(PRCX,"^",1,2)'="HDR^MANUFACTURER LIST" U IO(0) D EN^DDIOL("*** Wrong file: Not for Manufacturer Load.","","!!?10") S PRCFATAL=1 D CLOSE^%ZISH("PRCLFIN") G END
 U IO(0) W !
 K DIR S DIR(0)="YA",DIR("A")="Do you want to queue the manufacturer 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^PRCHITM6",ZTDESC="Manufacturer File (#440.4) 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 PRCLINES,PRCSTN S PRCSTN=$$STA^XUAF4($$KSP^XUPARAM("INST")),PRCLINES=0
 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="IFCAP Manufacturer File 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:$P(PRCX,"^",1,2)="HDR^MANUFACTURER LIST"  Q:$$STATUS^%ZISH
 I '$$STATUS^%ZISH D
 . S PRCTXN=$P(PRCX,"^",5) D INITLOG(PRCTXN)
 . F PRCI=1:1 R PRCX:DTIME Q:$$STATUS^%ZISH!($P(PRCX,"^")="***END OF FILE***")  D
 . . I $P(PRCX,"^")="REC" D
 . . . N PRCARR,PRCDUNS,PRCERR,PRCIEN,PRCNAME,PRCSTATUS S PRCIEN(1)=$P(PRCX,"^",2),PRCNAME=$P(PRCX,"^",3),PRCDUNS=$P(PRCX,"^",4),PRCSTATUS=$P(PRCX,"^",5)
 . . . S PRCLINES=PRCLINES+1
 . . . I +PRCIEN(1)'=PRCIEN(1)!(PRCIEN(1)'>0) S PRCERR("DIERR")=1,PRCERR("DIERR",1,"TEXT",1)="The value '"_PRCIEN(1)_"' for field ID NUMBER in file MANUFACTURER is not valid." D LOGERR(.PRCERR,PRCIEN(1)) Q
 . . . I '$D(^PRC(440.4,PRCIEN(1))) D  Q
 . . . . S PRCARR(440.4,"+1,",.001)=PRCIEN(1),PRCARR(440.4,"+1,",.01)=PRCNAME
 . . . . S:PRCDUNS'="" PRCARR(440.4,"+1,",.5)=PRCDUNS
 . . . . S:PRCSTATUS="I" PRCARR(440.4,"+1,",1)="INACTIVE"
 . . . . I ";A;I;"'[(";"_PRCSTATUS_";") S PRCARR(440.4,"+1,",1)=PRCSTATUS
 . . . . D UPDATE^DIE("EK","PRCARR","PRCIEN","PRCERR")
 . . . . D:$D(PRCERR) LOGERR(.PRCERR,PRCIEN(1))
 . . . . S:'$D(PRCERR) PRCLCTR=PRCLCTR+1
 . . . S PRCARR(440.4,PRCIEN(1)_",",.01)=PRCNAME
 . . . S:PRCDUNS'="" PRCARR(440.4,PRCIEN(1)_",",.5)=PRCDUNS
 . . . S:PRCSTATUS'="" PRCARR(440.4,PRCIEN(1)_",",1)=$S(PRCSTATUS="I":"INACTIVE",PRCSTATUS="A":"@",1:PRCSTATUS)
 . . . D FILE^DIE("EK","PRCARR","PRCERR")
 . . . D:$D(PRCERR) LOGERR(.PRCERR,PRCIEN(1))
 . . . S:'$D(PRCERR) PRCIUPD=PRCIUPD+1
 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,PRCTXN,PRCK,PRCC,PRCSTN)
 . . . K PRCARR S PRCJ=0
 . I $D(PRCARR) S PRCK=PRCK+1 D SEND(.PRCARR,PRCTXN,PRCK,PRCC,PRCSTN)
 I $D(PRCHNODE) D
 . N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCARR
 . S XMSUB="Stn "_PRCSTN_" Statistics Manufacturer Load File "_PRCTXN
 . S PRCARR(1)="Number of Manufacturer records: "_PRCLINES
 . S PRCARR(2)="Number of file entries successfully created: "_PRCLCTR,PRCARR(3)="Number of file entries successfully 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 PRCLFDIR,PRCLFFILE
 Q
INITLOG(PRCTXNID) ; Initialize error log
 N PRCDT,X1,X2,X,%H
 S PRCERRC=0,PRCHNODE="PRCHITM6;"_PRCTXNID K ^XTMP(PRCHNODE)
 ; Setting up ^XTMP header node including automatic purge date
 S PRCDT=$$DT^XLFDT,X1=PRCDT,X2=30 D C^%DTC S ^XTMP(PRCHNODE,0)=X_"^"_PRCDT_"^"_"IFCAP MANUFACTURER LOAD"
 Q
LOGERR(PRCE,PRCID) ; Record errors
 N PRCI,PRCK,PRCM S PRCK=$P($G(PRCERR("DIERR")),"^") Q:+PRCK'>0
 F PRCI=1:1:PRCK D
 . S PRCM=$G(PRCE("DIERR",PRCI,"TEXT",1)) I PRCM'="" S PRCM="ID Number:"_PRCID_": "_PRCM
 . S PRCERRC=PRCERRC+1 S ^XTMP(PRCHNODE,"ERR",PRCERRC)=PRCM
 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 Manufacturer Load File "_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
 ;
 ;PRCHITM6