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

BHLU.m

Go to the documentation of this file. 
  1. BHLU ; cmi/flag/maw - BHL Utilities ;  [ 04/19/2004  10:42 AM ]
  1.  ;;3.01;BHL IHS Interfaces with GIS;**2,10,11,12,13,14,15,16**;OCT 15, 2002
  1.  ;
  1.  ;this routine will have callable utilites by the BHL Package
  1.  ;
  1. DIE ;-- generic DIE call from BHL package
  1.  K DIE,DR
  1.  I BHLVAL="""""" S BHLVAL="@"
  1.  Q:BHLVAL=""  ;don't update data with a null value
  1.  S DIE=BHLFL,DR=BHLFLD_"///"_BHLVAL,DA=BHLX
  1.  D ^DIE
  1.  I $D(Y) S BHLERCD="GEN" S BHLEFL=BHLFL X BHLERR
  1.  K DIE,DR
  1.  Q
  1.  ;
  1. DIE4 ;-- generic DIE call from BHL package
  1.  K DIE,DR
  1.  I BHLVAL="""""" S BHLVAL="@"
  1.  Q:BHLVAL=""  ;don't update data with a null value
  1.  S DIE=BHLFL,DR=BHLFLD_"////"_BHLVAL,DA=BHLX
  1.  D ^DIE
  1.  I $D(Y) S BHLERCD="GEN" S BHLEFL=BHLFL X BHLERR
  1.  K DIE,DR
  1.  Q
  1.  ;
  1. DIEM ;-- generic die call for multiples
  1.  S DIE=BHLFL,DA(1)=BHLX,DA=BHLVAL,DR=BHLFLD_"///"_BHLVAL2
  1.  D ^DIE
  1.  I $D(Y) S BHLERCD="GEN",BHLEFL=BHLFL2,BHLFLD=BHLFLD X BHLERR
  1.  K DIE,DR
  1.  Q
  1.  ;
  1. DIC(BHLFL,BHLVAL) ;EP - generic dic call
  1.  S DIC=BHLFL,DIC(0)="MXZ",X=BHLVAL D ^DIC
  1.  S BHLY=+Y
  1.  Q BHLY
  1.  ;
  1. FK ;EP - kill fileman variables
  1.  K DD,DO,DIC,DIE,DR,Y,DIR
  1.  Q
  1.  ;
  1. ST(ST) ;-- transform into state  
  1.  I ST="" Q ST
  1.  S NST=$$VAL^XBDIQ1(5,ST,1)
  1.  Q NST
  1.  ;
  1. CHKPAT(BHLPT,BHLDUZ)         ;EP - lookup the patient
  1.  I '$G(BHLDUZ) S BHLDUZ=DUZ(2)
  1.  S BHLXDA=0 F  S BHLXDA=$O(^AUPNPAT("D",BHLPT,BHLXDA)) Q:'BHLXDA!($G(BHLPAT))  D
  1.  . S BHLYDA=0 F  S BHLYDA=$O(^AUPNPAT("D",BHLPT,BHLXDA,BHLYDA)) Q:'BHLYDA!($G(BHLPAT))  I BHLYDA=BHLDUZ S BHLPAT=BHLXDA
  1.  I $G(BHLPAT) Q BHLPAT
  1.  Q ""
  1.  ;
  1. CHKDOB(BHLDOBC)    ;EP - check the date of birth and sex for identifier
  1.  S BHLDOB2=$P($G(^DPT(BHLDOBC,0)),U,3)
  1.  I BHLDOB2'=BHLDOB S BHLERCD="NODOBM" X BHLERR S BHLPAT="" Q BHLPAT
  1.  S BHLSEX2=$P($G(^DPT(BHLDOBC,0)),U,2)
  1.  I BHLSEX2'=BHLSEX S BHLERCD="NOSEXM" X BHLERR S BHLPAT="" Q BHLPAT
  1.  S BHLPAT=BHLDOBC
  1.  Q BHLPAT
  1.  Q
  1.  ;
  1. CHAR ;-- set field sep and encoding characters for a message
  1.  S DIC="^INTHL7M(",DIC(0)="AEMQZ"
  1.  S DIC("A")="Set Characters for which message: "
  1.  D ^DIC
  1.  Q:Y<0
  1.  S BHL("MSG")=+Y
  1.  D CHARUP(BHL("MSG"))
  1.  Q
  1.  ;
  1. CHARUP(BHLMIEN) ;EP - update field sep and enc chars for hl7
  1.  I $P($G(^INTHL7M(BHLMIEN,0)),U)["HL" D  Q
  1.  . S ^INTHL7M(BHLMIEN,"FS")="|"
  1.  . S ^INTHL7M(BHLMIEN,"EC")="^~\&"
  1.  I $P($G(^INTHL7M(BHLMIEN,0)),U)="X1" S ^INTHL7M(BHLMIEN,"FS")="*"
  1.  Q
  1.  ;
  1. COMPILE(MSG)       ;EP - compile a message
  1.  S Y=MSG,INGALL=1 D EN^INHSGZ
  1.  Q
  1.  ;
  1. COMPILEP(NS)       ;EP - compile msgs by namespace
  1.  S BHLNDA=0 F  S BHLNDA=$O(^INTHL7M("B",BHLNDA)) Q:BHLNDA=""  D
  1.  . Q:BHLNDA'[NS
  1.  . S BHLNIEN=0 F  S BHLNIEN=$O(^INTHL7M("B",BHLNDA,BHLNIEN)) Q:'BHLNIEN  D
  1.  .. S Y=BHLNIEN,INGALL=1
  1.  .. D EN^INHSGZ
  1.  Q
  1.  ;
  1. HFS(BHLHFSN,BHLUIEN)       ;EP - saves message to host file
  1.  S Y=$$OPEN^%ZISH("D:\TEMP\",BHLHFSN_"."_BHLMSTD,"W")
  1.  U IO
  1.  I BHLMSTD="X12" D
  1.  . S BHLUDA=0 F  S BHLUDA=$O(^INTHU(BHLUIEN,3,BHLUDA)) Q:'BHLUDA  D
  1.  .. S BHLXR=$P($G(^INTHU(BHLUIEN,3,BHLUDA,0)),"|CR|")
  1.  .. I $G(BHLXR)["~" W BHLXR Q
  1.  .. W BHLXR_"~"
  1.  I BHLMSTD'="X12" D
  1.  . S BHLUDA=0 F  S BHLUDA=$O(^INTHU(BHLUIEN,3,BHLUDA)) Q:'BHLUDA  D
  1.  .. W $P($G(^INTHU(BHLUIEN,3,BHLUDA,0)),"|CR|"),!
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. HFSA(DEST,BHLHDIR,BHLHFNM) ;EP - export from this destination
  1. HFSDW ;-- callable from Data Warehouse   
  1.  F BHLJOB="FORMAT CONTROLLER","OUTPUT CONTROLLER" D
  1.  . S BHLY=$$CHK^BHLBCK(BHLJOB)
  1.  Q:'$D(^INLHDEST(DEST))
  1.  S Y=$$OPEN^%ZISH(BHLHDIR,BHLHFNM,"W")
  1.  Q:Y
  1.  S BHLH=0 F  S BHLH=$O(^INLHDEST(DEST,0,BHLH)) Q:'BHLH  D
  1.  . S BHLU=0 F  S BHLU=$O(^INLHDEST(DEST,0,BHLH,BHLU)) Q:'BHLU  D
  1.  .. D LPINTHU(BHLU)
  1.  .. K ^INLHDEST(DEST,0,BHLH,BHLU)
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. HFSRL(DEST,BHLHDIR,BHLHFNM) ;EP - export from this destination
  1.  F BHLJOB="FORMAT CONTROLLER","OUTPUT CONTROLLER" D
  1.  . S BHLY=$$CHK^BHLBCK(BHLJOB)
  1.  S Y=$$OPEN^%ZISH(BHLHDIR,BHLHFNM,"W")
  1.  Q:Y
  1.  S BHLH=0 F  S BHLH=$O(^INLHDEST(DEST,0,BHLH)) Q:'BHLH  D
  1.  . S BHLU=0 F  S BHLU=$O(^INLHDEST(DEST,0,BHLH,BHLU)) Q:'BHLU  D
  1.  .. D RLINTHU(BHLU)
  1.  .. K ^INLHDEST(DEST,0,BHLH,BHLU)
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. LPINTHU(BHLUIEN)       ;EP - loop through UIF and set to file
  1.  S BHLUDA=0 F  S BHLUDA=$O(^INTHU(BHLUIEN,3,BHLUDA)) Q:'BHLUDA  D
  1.  . U IO W $P($G(^INTHU(BHLUIEN,3,BHLUDA,0)),"|CR|"),!
  1.  Q
  1.  ;
  1. RLINTHU(BHLUIEN)       ;EP - loop through UIF and set to file for ref lab
  1.  S BHLUDA=0 F  S BHLUDA=$O(^INTHU(BHLUIEN,3,BHLUDA)) Q:'BHLUDA  D
  1.  . ;U IO W $P($G(^INTHU(BHLUIEN,3,BHLUDA,0)),"|CR|"),$C(13,10)
  1.  . ;U IO W $P($G(^INTHU(BHLUIEN,3,BHLUDA,0)),"|CR|"),$C(10) quest old
  1.  . U IO W $P($G(^INTHU(BHLUIEN,3,BHLUDA,0)),"|CR|"),!  ;quest new
  1.  Q
  1.  ;
  1. SENDFILE(FNM,SDIR,IP,PASS) ;EP - this will trigger a send via the sendto command, sendto.pl must exist
  1.  S BHLOPS=$P($G(^AUTTSITE(1,0)),U,21)
  1.  I PASS["anonymous" D  Q
  1.  . S BHLSEND="sendto -i"_$S(BHLOPS=1:" ",1:" -a ")_IP_" "_SDIR_FNM
  1.  . S X=$$JOBWAIT^%HOSTCMD(BHLSEND)
  1.  S BHLSEND="sendto -i -l "_PASS_$S(BHLOPS=1:" ",1:" -a ")_IP_" "_SDIR_FNM
  1.  ;S BHLSEND="sendto1 -u -l "_PASS_$S(BHLOPS=1:" ",1:" -a ")_IP_" "_SDIR_FNM  ;for loinc project
  1.  S X=$$JOBWAIT^%HOSTCMD(BHLSEND)
  1.  Q
  1.  ;
  1. MPORT ;EP - run the import package utility
  1.  I $O(^INXPORT(""))="" D  Q
  1.  . W !,"Global ^INXPORT missing, please restore and run MPORT^BHLU"
  1.  S BHLIT=$O(^INXPORT(""))
  1.  S BHLIST=$O(^INXPORT(BHLIT,""))
  1.  S BHLIPK=$O(^INXPORT(BHLIT,BHLIST,""))
  1.  W !,"Importing GIS "_$G(BHLIT)_" Supplement "_$G(BHLIPK)
  1.  W ", developing site "_$G(BHLIST)
  1.  D ^INMPORT
  1.  W !,"Finished Importing GIS Supplement "
  1.  K BHLIT,BHLIST,BHLIPK
  1.  Q
  1.  ;
  1. STUFFO(DEST,STOR)   ;--loop through stor and stuff into ^INTHU
  1.  D NOW^%DTC S BHLXDTM=$G(%)
  1.  S BHLXH=$H
  1.  S BHLXDEST=$O(^INRHD("B","X1 IHS "_DEST,0))
  1.  S BHLXSTAT="N"
  1.  S BHLXIO="O"
  1.  S BHLXPRIO=1
  1.  K DD,DO
  1.  S DIC="^INTHU(",DIC(0)="L",X=BHLXDTM
  1.  S DIC("DR")=".02////"_BHLXDEST_";.03////"_BHLXSTAT_";.1////"_BHLXIO
  1.  S DIC("DR")=DIC("DR")_";.16///"_BHLXPRIO
  1.  D FILE^DICN
  1.  S BHLXUIF=+Y
  1.  S BHLXDA=0 F  S BHLXDA=$O(@STOR@(BHLXDA)) Q:'BHLXDA  D
  1.  . K DIC,DD,DO
  1.  . S DIC="^INTHU("_BHLXUIF_",3,",DIC(0)="L"
  1.  . S DIC("P")=$P(^DD(4001,3,0),"",2)
  1.  . S DA(1)=BHLXUIF,X=$G(@STOR@(BHLXDA))_"|CR|"
  1.  . Q:X=""
  1.  . D FILE^DICN
  1.  K ^INTHU(BHLXUIF,3,"B")  ;don't need b index on msg multiple
  1.  S ^INLHDEST(BHLXDEST,BHLXPRIO,BHLXH,BHLXUIF)=""
  1.  Q
  1.  ;
  1. EOJ ;-- kill variables and quit
  1.  Q
  1.  ;