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

ACHSEOB8.m

Go to the documentation of this file. 
  1. ACHSEOB8 ; IHS/ITSC/TPF/PMF - AREA WRITE EOBR FILES FOR FACILITIES (1/2) ;  
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,19,21,22,25**;JUN 11, 2001;Build 43
  1.  ;
  1.  I '$O(^ACHSEOBR(0)) W *7,!!,"NO DATA EXISTS TO EXPORT TO FACILITIES.",!! S ACHSIO=IO D RTRN^ACHS G END
  1.  I $D(^ACHSEOBR("RUN")) U IO(0) W !!?5,*7,"FACILITY FILES HAVE ALREADY BEEN EXPORTED -- JOB CANCELLED" D RTRN^ACHS G END
  1.  S ACHSFLG=0,ACHSMSM=^%ZOSF("OS")["MSM"
  1.  I '$D(^ACHSAOP(DUZ(2),16,0)) S ^ACHSAOP(DUZ(2),16,0)=$$ZEROTH^ACHS(9002079.016,1)
  1.  W !,"Checking EOBR destinations...",!
  1.  S ACHS="0"
  1.  K DUOUT
  1.  D WAIT^DICD,DCHK
  1.  I '$D(DUOUT) G A
  1.  W !!,$$C^XBFUNC("You can use the 'Area Office Parameters' option to add a destination to"),!,$$C^XBFUNC("FACILITIES RECEIVING EOBR DATA.")
  1.  S Y=$$DIR^XBDIR("Y","Want to Continue with Incomplete EOBR Destination Information","N","","","",1)
  1.  I Y=1 G A
  1.  I $D(DUOUT)!(Y'=1) D END G K
  1. A ;
  1.  D HOME^%ZIS
  1.  S ACHSEOBD=$P(^ACHSAOP(DUZ(2),2),U,11)
  1.  S ACHSPFAC="",ACHSMDIA="F"
  1.  F  S ACHSPFAC=$O(^ACHSAOP(DUZ(2),16,"B",ACHSPFAC)) Q:ACHSPFAC=""!(ACHSFLG)  D SEQ,CDATA,START:ACHSFAC
  1. K ;
  1.  K ACHSFAC,ACHSFLG,ACHSMDIA,ACHSMSG,ACHSMSM,ACHSPFAC,ACHSEOBX,ACHSFACN,ACHSMCNT,ACHSR,ACHSRR,ACHSZRCT
  1.  S ACHSIO=IO
  1.  D RTRN^ACHS
  1.  Q
  1.  ;
  1. SEQ ; Load Seq Numbers for facility & file suffix name.
  1.  ;ACHS*3.1*22 SET FILE EXTENTION WITH ICD IF PROCESSING THE ICD9 FILE
  1.  ;S ACHSAOSQ=$P(^ACHSAOP(DUZ(2),2),U,9),ACHSEBSQ=+$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)+1
  1.  S ACHSAOSQ=$S(ACHSAOSQ["ICD":"ICD",1:$P(^ACHSAOP(DUZ(2),2),U,9)),ACHSEBSQ=+$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)+1
  1.  Q
  1.  ;
  1. CDATA ; Check if there is data to send to the facility.
  1.  S ACHSFACN=""
  1.  S:$D(^AUTTLOC(ACHSPFAC)) ACHSFACN=$P(^AUTTLOC(ACHSPFAC,0),U,10)
  1.  S ACHSFAC=""
  1.  F  S ACHSFAC=$O(^ACHSAOP(DUZ(2),16,"C",ACHSPFAC,ACHSFAC)) Q:ACHSFAC=""  Q:$D(^ACHSEOBR(ACHSFAC))
  1.  Q
  1.  ;
  1. START ;
  1.  U IO(0)
  1.  W !!,"Copying EOBR data for ",$P(^DIC(4,ACHSPFAC,0),U,1),!," to host file.",!
  1.  D HFS
  1.  Q
  1.  ;
  1. HFS ;
  1.  U IO(0)
  1.  W !!,"Host File Being Created",*7
  1.  F  Q:$L(ACHSAOSQ)=3  S ACHSAOSQ="0"_ACHSAOSQ
  1.  S ACHSZFN="EB"_ACHSFACN_"."_ACHSAOSQ
  1.  ;ACHS*3.1*21 3 NEW LINES COM OUT 4TH
  1.  S ACHSEPTH=$$AOP^ACHS(3,3)
  1.  I ACHSEPTH="" S ACHSEPTH=$$EX^ACHS
  1.  I $$OPEN^%ZISH(ACHSEPTH,ACHSZFN,"W") S ACHSEMSG="M10" D ERROR^ACHSTCK1 G CLOSE
  1.  ;I $$OPEN^%ZISH($$EX^ACHS,ACHSZFN,"W") S ACHSEMSG="M10" D ERROR^ACHSTCK1 G CLOSE
  1.  U IO(0)
  1.  ;ACHS*3.1*18 PATCH FOR FT DEF;ACHS*3.1*21 CHANGED $$EX^ACHS TO ACHSEPTH IN ELSE LINE
  1.  I $$ASF^ACHS(DUZ(2))=808301 W !,"Please Standby - Copying Data to Host File ",$$IM^ACHS,ACHSZFN,!
  1.  E  W !,"Please Standby - Copying Data to Host File ",ACHSEPTH,ACHSZFN,!
  1.  D SAVE
  1.  S $P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)=ACHSEBSQ,$P(^(0),U,2)=DT
  1.  I ACHSAOSQ="ICD" S $P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,6)="Y"   ;ACHS*3.1*22
  1.  ;ACHS*3.1*19 2 NEW LINES FOR S UTE
  1.  I $$ASF^ACHS(DUZ(2))=252611,$$MV^%ZISH($$EX^ACHS,ACHSZFN,$$IM^ACHS,ACHSZFN) W !,"Moved files to import directory"
  1.  G:$$ASF^ACHS(DUZ(2))=252611 CLOSE
  1.  ;G:$$ASF^ACHS(DUZ(2))="000000" SEND  ;ACHS*3.1*21 ADDED FOR TUC NO LONGER NEEDED FOR LEGACY SYSTEMS
  1.  G:$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,5)="N" CLOSE  ;ACHS*3.1*21
  1.  I $$OS^ACHS=1,'$L($P($G(^AUTTLOC(ACHSPFAC,1)),U,1)) D  G CLOSE:'$L($P($G(^AUTTLOC(ACHSPFAC,1)),U,1))
  1.  . N DA,DIE,DR
  1.  . W *7,!!?10,"System-ID Missing from Location File for ",$P(^DIC(4,ACHSPFAC,0),U)
  1.  . W !?10,"So the file can be sent, please enter the system ID, now:"
  1.  . S DIE="^AUTTLOC(",DR=.29,DA=ACHSPFAC
  1.  . D ^DIE
  1.  . I $L($P($G(^AUTTLOC(ACHSPFAC,1)),U,1)) W !?10,"Thank you."
  1.  . E  W !?10,"Well....you can STILL send it, manually."
  1.  . D RTRN^ACHS
  1.  .Q
  1. SEND ;ACHS*3.1*21 ADDED FOR TUC LEGACY SYS
  1.  S ACHSSYS="",X=$P(^AUTTLOC(ACHSPFAC,0),U,10)
  1.  S ACHSSYS=$S(X="000111":"161.223.1.95",X="000111":"161.223.2.85",X="000200":"161.223.4.200",1:$P($G(^AUTTLOC(ACHSPFAC,1)),U,1))
  1.  ;ACHS*3.1.*21 CHANGED NEXT LINE TO ACHSEPTH AND CHANGED $P($G(^AUTTLOC(ACHSPFAC,1)),U,1)) TO ACHSSYS
  1.  ;ACHS*3.1*25 ADDED TO CHECK FOR ZISH PARAMETER
  1.  S ACHSZPAR=""
  1.  I $D(^%ZIB(9888888.93,"B",ACHSSYS)) D
  1.  .S X="",X=$O(^%ZIB(9888888.93,"B",ACHSSYS,X))
  1.  .S ACHSZPAR=$P(^%ZIB(9888888.93,X,0),U,6)_" "_$P(^%ZIB(9888888.93,X,0),U,3)_":"_$P(^%ZIB(9888888.93,X,0),U,4)
  1.  ;S Y=$$SEND^%ZISH("/dir/","fl","mach","ftpsend param")
  1.  ;I $$SEND^%ZISH(ACHSEPTH,ACHSZFN,ACHSSYS),$$OS^ACHS=1 W *7,!!?10,"$$SEND^%ZISH() of ",ACHSEPTH,ACHSZFN," to ",ACHSSYS," failed -- Notify Supervisor",! G CLOSE
  1.  I $$SEND^%ZISH(ACHSEPTH,ACHSZFN,ACHSSYS,ACHSZPAR),$$OS^ACHS=1 W *7,!!?10,"$$SEND^%ZISH() of ",ACHSEPTH,ACHSZFN," to ",ACHSSYS," failed -- Notify Supervisor",! G CLOSE
  1.  ; NOTE:  Above has to check OS because the Unix SEND returns 0 if
  1.  ;        successful, and the DOS SEND returns a positive integer if
  1.  ;        successful.   GTH 06-24-96.
  1.  W !!,"Export file ",ACHSZFN," queued up to be sent to ",$P($G(^AUTTLOC(ACHSPFAC,1)),U),"...",!
  1. CLOSE ;EP.
  1.  D ^%ZISC
  1.  I ACHSFLG S ACHSIO=IO I ACHSMDIA'="F" D RTRN^ACHS
  1.  S ^ACHSEOBR("RUN")=$$HTFM^XLFDT($H)_"^"_DUZ
  1. END ;
  1.  K %MT,ACHS,ACHSFAC,R,ACHSRCTR,X1,X2,ACHSZPAR
  1.  Q
  1.  ;
  1. SAVE ;EP.
  1.  D WAIT^DICD
  1.  U IO(0)
  1.  W !
  1.  S ACHSFAC="",ACHSZRCT=0
  1.  U IO
  1.  W "$$"_ACHSEOBD_" "_ACHSEBSQ,! ;W:IOPAR'["V" !
  1.  I +$P(^ACHSAOP(DUZ(2),2),U,10)'<+$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,3) D EXPMSG I 1
  1.  E  W "$$",! ;W:IOPAR'["V" !
  1.  U IO
  1.  F  S ACHSFAC=$O(^ACHSAOP(DUZ(2),16,"C",ACHSPFAC,ACHSFAC)) Q:ACHSFAC=""  D
  1.  . F ACHSCTR=0:0 S ACHSCTR=$O(^ACHSEOBR(ACHSFAC,ACHSCTR)) Q:'ACHSCTR  W ^(ACHSCTR),! D
  1.  .. I $E(^ACHSEOBR(ACHSFAC,ACHSCTR),19)="A" D ADD^ACHSAOPO($TR($E(^(ACHSCTR),52,63),"-"),"EOBR",^(ACHSCTR))
  1.  .. S ACHSZRCT=ACHSZRCT+1
  1.  .. I ACHSZRCT#50=0 U IO(0) W $J(ACHSZRCT,8) U IO
  1.  ..Q
  1.  .Q
  1.  W "**"_DT ;W:IOPAR'["V" !
  1.  U IO(0)
  1.  Q
  1.  ;
  1. EXPMSG ;
  1.  S (ACHSR,ACHSRR,ACHSMCNT)=0
  1. EXP1 ;
  1.  S ACHSR=$O(^ACHSEOBM(ACHSR))
  1.  G EXPEND:+ACHSR=0
  1.  S ACHSRR=0
  1. EXP2 ;
  1.  S ACHSRR=$O(^ACHSEOBM(ACHSR,1,ACHSRR))
  1.  G EXP1:+ACHSRR=0
  1.  S ACHSMCNT=ACHSMCNT+1,ACHSEOBX=$E("000",1,3-$L(ACHSMCNT))_ACHSMCNT_$P(^ACHSEOBM(ACHSR,0),U,1)_^ACHSEOBM(ACHSR,1,ACHSRR,0)
  1.  U IO
  1.  W ACHSEOBX
  1.  W:IOPAR'["V" !
  1.  G EXP2
  1.  ;
  1. EXPEND ;
  1.  U IO
  1.  W "$$"
  1.  W:IOPAR'["V" !
  1.  U IO(0)
  1.  W !?10,"EOBR Messages Copied to Output Media",!
  1.  S $P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,3)=DT
  1.  Q
  1.  ;
  1. DCHK ;Check Destinations of EOBRs.
  1.  S ACHS=$O(^ACHSEOBR(ACHS))
  1.  Q:+ACHS=0!(ACHS="ER")
  1.  I $D(^ACHSAOP(DUZ(2),16,"D",ACHS)) G DCHK
  1.  W *7,!,"Destination not on file for ",$P(^DIC(4,ACHS,0),U,1)
  1.  S DUOUT=""
  1.  G DCHK
  1.  ;