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

XUMF04H.m

Go to the documentation of this file. 
  1. XUMF04H ;BP/RAM - INSTITUTION Handler ;May 03, 2022@07:45:35
  1.  ;;8.0;KERNEL;**549,678,698,723,735,769,662**;Jul 10, 1995;Build 49
  1.  ;;Per VA Directive 6402, this routine should not be modified
  1.  ; This routine handles Institution Master File HL7 messages.
  1.  ;
  1. MAIN ; -- entry point
  1.  ;
  1.  Q:$$KSP^XUPARAM("INST")=12000
  1.  ;
  1.  N X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,KEY,VALUE,ROOT,HLSCS,CDSYS,TEXT,ID
  1.  ;
  1.  D INIT,PROCESS,REPLY,EXIT
  1.  ;
  1.  Q
  1.  ;
  1. INIT ; -- initialize
  1.  ;
  1.  S ERROR=0,IEN=""
  1.  S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
  1.  ;
  1.  Q
  1.  ;
  1. PROCESS ; -- pull message text
  1.  ;
  1.  F  X HLNEXT Q:HLQUIT'>0  D
  1.  .Q:$P(HLNODE,HLFS)=""
  1.  .D @($P(HLNODE,HLFS))
  1.  ;
  1.  Q
  1.  ;
  1. MSH ; -- MSH segment
  1.  ;
  1.  Q
  1.  ;
  1. MSA ; -- MSA segment
  1.  ;
  1.  Q
  1.  ;
  1. QRD ; -- QRD segment
  1.  ;
  1.  Q
  1.  ;
  1. MFI ; -- MFI segment
  1.  ;
  1.  Q
  1.  ;
  1. MFE ; -- MFE segment
  1.  ;
  1.  S KEY=$P(HLNODE,HLFS,5)
  1.  ;
  1.  S ID=$P(KEY,HLCS)
  1.  S TEXT=$P(KEY,HLCS,2)
  1.  S CDSYS=$P(KEY,HLCS,3)
  1.  ;
  1.  I CDSYS="VASTANUM" D  Q
  1.  .S IEN=$O(^DIC(4,"D",ID,0)) Q:IEN
  1.  .S IEN=$O(^DIC(4,"B",TEXT,0))
  1.  ;
  1.  I CDSYS="NPI" D  Q
  1.  .S IEN=$O(^DIC(4,"ANPI",ID,0)) Q:IEN
  1.  .S IEN=$O(^DIC(4,"B",TEXT,0))
  1.  I CDSYS="DMIS" D  Q
  1.  .S IEN=$O(^DIC(4,"XUMFIDX","DMIS",ID,0)) Q:IEN
  1.  .S IEN=$O(^DIC(4,"B",TEXT,0))
  1.  ;
  1.  Q
  1.  ;
  1. ZIN ; -- VHA Institution segment
  1.  ;
  1.  W "."
  1.  ;
  1.  N NAME,FACTYP,OFNME,INACTIVE,STATE,VISN,PARENT,STREET,STREET2,CITY,ZIP
  1.  N STRT1,STRT2,CITY1,STATE1,STANUM,BILLNAME,IEN1,IENS,ERR,ERROR1
  1.  N ZIP1,AGENCY,NPIDT,NPISTAT,NPI,TAX,TAXPC,TAXSTAT,MAMMO,CLIA,DMIS,XXXX
  1.  N LOCTZONE,COUNTRY,TZONEX,CERNER
  1.  ;
  1.  D PARSE^XUMFXHL7("HLNODE","XXXX")
  1.  ;
  1.  S STANUM=XXXX(2)
  1.  ;
  1.  I $G(STANUM),CDSYS'="VASTANUM" Q
  1.  ;
  1.  S XUMF=1,ERROR1=""
  1.  ;
  1.  S NAME=XXXX(1)
  1.  S FACTYP=$P(XXXX(4),"~",1)
  1.  S OFNME=XXXX(5)
  1.  S INACTIVE=XXXX(6)
  1.  S STATE=XXXX(7)
  1.  S VISN=XXXX(8)
  1.  S:VISN'="" VISN=$O(^DIC(4,"B",VISN,0)) ;p698
  1.  S PARENT=XXXX(9)
  1.  S:PARENT'="" PARENT=$O(^DIC(4,"D",PARENT,0)) ;p698
  1.  S STREET=$P(XXXX(14),"~",1)
  1.  S STREET2=$P(XXXX(14),"~",2)
  1.  S CITY=$P(XXXX(14),"~",3)
  1.  S ZIP=$P(XXXX(14),"~",5)
  1.  S COUNTRY=$P(XXXX(14),"~",6)
  1.  S STRT1=$P(XXXX(15),"~",1)
  1.  S STRT2=$P(XXXX(15),"~",2)
  1.  S CITY1=$P(XXXX(15),"~",3)
  1.  S STATE1=$P(XXXX(15),"~",4)
  1.  S ZIP1=$P(XXXX(15),"~",5)
  1.  S AGENCY=$P(XXXX(16),"~")
  1.  S NPI=XXXX(17)
  1.  S NPISTAT=XXXX(18)
  1.  I NPISTAT="ACTIVE" S NPISTAT=1 ;p698
  1.  I NPISTAT="INACTIVE" S NPISTAT=0 ;698
  1.  S NPIDT=$$FMDATE^HLFNC(XXXX(19))
  1.  S TAX=XXXX(20)
  1.  S TAXSTAT=XXXX(21)
  1.  S TAXPC=XXXX(22)
  1.  S CLIA=XXXX(23)
  1.  S MAMMO=XXXX(24)
  1.  S DMIS=XXXX(25)
  1.  S BILLNAME=XXXX(26)
  1.  S LOCTZONE=XXXX(27)
  1.  S TZONEX=XXXX(28)
  1.  S CERNER=$G(XXXX(29)) ;p723
  1.  ;
  1.  ; -- new entry
  1.  I 'IEN D  Q:'IEN
  1.  .N X,Y S X=NAME
  1.  .K DIC S DIC=4,DIC(0)="F"
  1.  .D FILE^DICN K DIC
  1.  .S IEN=$S(Y="-1":0,1:+Y)
  1.  ;
  1.  S IENS=IEN_","
  1.  ;
  1.  K FDA
  1.  S FDA(4,IENS,.01)=NAME
  1.  S FDA(4,IENS,13)=FACTYP
  1.  S FDA(4,IENS,1.01)=STREET
  1.  S FDA(4,IENS,1.02)=STREET2
  1.  S FDA(4,IENS,1.03)=CITY
  1.  S FDA(4,IENS,1.04)=ZIP
  1.  S FDA(4,IENS,.02)=STATE
  1.  ;
  1.  ; -- check for changes to physical address
  1.  D PADDCK
  1.  ;
  1.  S FDA(4,IENS,4.01)=STRT1
  1.  S FDA(4,IENS,4.02)=STRT2
  1.  S FDA(4,IENS,4.03)=CITY1
  1.  S FDA(4,IENS,4.04)=STATE1
  1.  S FDA(4,IENS,4.05)=ZIP1
  1.  S FDA(4,IENS,11)="National"
  1.  S FDA(4,IENS,100)=OFNME
  1.  S FDA(4,IENS,101)=INACTIVE
  1.  S FDA(4,IENS,102)=CERNER ;p723
  1.  S FDA(4,IENS,95)=AGENCY
  1.  S FDA(4,IENS,99)=STANUM
  1.  S FDA(4,IENS,200)=BILLNAME
  1.  S FDA(4,IENS,800)=LOCTZONE
  1.  S FDA(4,IENS,801)=COUNTRY
  1.  S FDA(4,IENS,802)=TZONEX
  1.  D FILE^DIE("E","FDA","ERR")
  1.  I $D(ERR) D
  1.  .D EM("error updating ZIN",.ERR)
  1.  .K ERR
  1.  ;
  1.  I $G(VISN)'="" D
  1.  .K FDA
  1.  .S IENS="?+1,"_IEN_","
  1.  .S FDAIEN(1)=1
  1.  .S FDA(4.014,IENS,.01)=1
  1.  .S FDA(4.014,IENS,1)=VISN
  1.  .D UPDATE^DIE("","FDA","FDAIEN","ERR")
  1.  I $D(ERR) D
  1.  .D EM("error updating VISN",.ERR)
  1.  .K ERR
  1.  ;
  1.  I $G(PARENT) D
  1.  .S IENS="?+1,"_IEN_","
  1.  .S FDAIEN(1)=2
  1.  .S FDA(4.014,IENS,.01)=2
  1.  .S FDA(4.014,IENS,1)=PARENT
  1.  .D UPDATE^DIE("","FDA","FDAIEN","ERR")
  1.  I $D(ERR) D
  1.  .D EM("error updating PARENT",.ERR)
  1.  .K ERR
  1.  ;
  1.  I $G(NPIDT)'="",NPI'="" D
  1.  .K FDA
  1.  .S IENS="?+2,"_IEN_","
  1.  .S FDA(4.042,IENS,.01)=NPIDT
  1.  .S FDA(4.042,IENS,.02)=NPISTAT
  1.  .S FDA(4.042,IENS,.03)=NPI
  1.  .D UPDATE^DIE("","FDA",,"ERR")
  1.  I $D(ERR) D
  1.  .D EM("error updating NPI",.ERR)
  1.  .K ERR
  1.  ;
  1.  I $G(NPIDT)'="",NPI="" D
  1.  . N XUIENEFF S XUIENEFF=$O(^DIC(4,IEN,"NPISTATUS","B",NPIDT,0))
  1.  . I XUIENEFF>0 N DIK,DA S DA(1)=IEN,DA=XUIENEFF,DIK="^DIC(4,"_DA(1)_",""NPISTATUS""," D ^DIK
  1.  ;
  1.  I $G(TAX)'="",TAXSTAT'="" D
  1.  .K FDA,ROOT,IDX
  1.  .N IENS
  1.  .S IENS="?+2,"_IEN_","
  1.  .S FDA(4.043,IENS,.01)=$O(^USC(8932.1,"G",TAX,0))
  1.  .S FDA(4.043,IENS,.02)=$S(TAXPC="YES":1,1:0)
  1.  .S FDA(4.043,IENS,.03)=$S(TAXSTAT="ACTIVE":"A",1:"I")
  1.  .D UPDATE^DIE("","FDA",,"ERR")
  1.  I $D(ERR) D
  1.  .D EM("error updating TAXANOMY",.ERR)
  1.  .K ERR
  1.  ;
  1.  I $G(TAX)'="",TAXSTAT="" D
  1.  . N TAX1 S TAX1=$O(^USC(8932.1,"G",TAX,0))
  1.  . I TAX1'>0 Q
  1.  . N XUIENTAX S XUIENTAX=$O(^DIC(4,IEN,"TAXONOMY","B",TAX1,0))
  1.  . I XUIENTAX>0 N DIK,DA S DA(1)=IEN,DA=XUIENTAX,DIK="^DIC(4,"_DA(1)_",""TAXONOMY""," D ^DIK
  1.  ;
  1.  I $G(CLIA)'="" D
  1.  .S IENS="?+2,"_IEN_","
  1.  .K FDA
  1.  .S FDA(4.9999,IENS,.01)="CLIA"
  1.  .S FDA(4.9999,IENS,.02)=CLIA
  1.  .D UPDATE^DIE("E","FDA",,"ERR")
  1.  I $D(ERR) D
  1.  .D EM("error updating CLIA",.ERR)
  1.  .K ERR
  1.  ;
  1.  I $G(MAMMO)'="" D
  1.  .S IENS="?+2,"_IEN_","
  1.  .K FDA
  1.  .S FDA(4.9999,IENS,.01)="MAMMO"
  1.  .S FDA(4.9999,IENS,.02)=MAMMO
  1.  .D UPDATE^DIE("E","FDA",,"ERR")
  1.  I $D(ERR) D
  1.  .D EM("error updating MAMMO",.ERR)
  1.  .K ERR
  1.  ;
  1.  I $G(DMIS)'="" D
  1.  .S IENS="?+2,"_IEN_","
  1.  .K FDA
  1.  .S FDA(4.9999,IENS,.01)="DMIS"
  1.  .S FDA(4.9999,IENS,.02)=DMIS
  1.  .D UPDATE^DIE("E","FDA",,"ERR")
  1.  I $D(ERR) D
  1.  .D EM("error updating DMIS",.ERR)
  1.  .K ERR
  1.  ;
  1.  Q
  1.  ;
  1. PADDCK ; -- check for changes to physical address
  1.  ;
  1.  N XSTREET,XSTREET2,XCITY,XZIP,XSTATE
  1.  N XHPADD,XIENS S XHPADD=0
  1.  ;
  1.  ; -- retrieve current physical address fields
  1.  S XSTREET=$$GET1^DIQ(4,IENS,1.01)
  1.  S XSTREET2=$$GET1^DIQ(4,IENS,1.02)
  1.  S XCITY=$$GET1^DIQ(4,IENS,1.03)
  1.  S XZIP=$$GET1^DIQ(4,IENS,1.04)
  1.  S XSTATE=$$GET1^DIQ(4,IENS,.02)
  1.  ;
  1.  ; -- compare against fields in master file update
  1.  I STREET'=XSTREET S XHPADD=1
  1.  I STREET2'=XSTREET2 S XHPADD=1
  1.  I CITY'=XCITY S XHPADD=1
  1.  I ZIP'=XZIP S XHPADD=1
  1.  I STATE'=XSTATE S XHPADD=1
  1.  ;
  1.  ; -- if differences, create historical address array
  1.  I XHPADD D
  1.  . K XUADD,XUEFFDT
  1.  . S XUEFFDT(1)=DT
  1.  . S XIENS="+1,"_IENS
  1.  . S XUADD(4.999,XIENS,.01)=XUEFFDT(1)
  1.  . S XUADD(4.999,XIENS,1)=XSTREET
  1.  . S XUADD(4.999,XIENS,1.1)=XSTREET2
  1.  . S XUADD(4.999,XIENS,1.2)=XCITY
  1.  . S XUADD(4.999,XIENS,1.3)=XSTATE
  1.  . S XUADD(4.999,XIENS,1.4)=XZIP
  1.  . D UPDATE^DIE("E","XUADD","XUEFFDT")
  1.  . K XUADD,XUEFFDT
  1.  K XSTREET,XSTREET2,XCITY,XZIP,XSTATE,XHPADD,XIENS
  1.  Q
  1.  ;
  1. REPLY ; -- master file response
  1.  ;
  1.  Q:HL("MTN")="MFR"
  1.  Q:HL("MTN")="MFK"
  1.  Q:HL("MTN")="ACK"
  1.  S HLFS=$G(HLFS)
  1.  S HL("MID")=$G(HL("MID"))
  1.  S HL("EIDS")=$G(HL("EIDS"))
  1.  S HL("EID")=$G(HL("EID"))
  1.  ;
  1.  N X
  1.  S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
  1.  S ^TMP("HLA",$J,1)=X
  1.  ;
  1.  S HLP("PRIORITY")="I"
  1.  D GENACK^HLMA1(HL("EID"),$G(HLMTIENS),HL("EIDS"),"GM",1,.HLRESLT)
  1.  ;
  1.  ; check for error
  1.  I ($P($G(HLRESLT),U,3)'="") D  Q
  1.  .S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
  1.  ;
  1.  ; successful call, message ID returned
  1.  S ERROR="0^"_$P($G(HLRESLT),U,1)
  1.  ;
  1.  Q
  1.  ;
  1. EXIT ; -- cleanup, and quit
  1.  ;
  1.  Q
  1.  ;
  1. EM(ERROR,ERR) ; -- error message p698
  1.  ;
  1.  N X,XMSUB,XMY,XMTEXT,FLG
  1.  S FLG=0
  1.  D MSG^DIALOG("AM",.X,80,,"ERR")
  1.  ;
  1.  S X(.1)="HL7 message ID: "_$G(HL("MID"))
  1.  S X(.2)="",X(.3)=$G(ERROR),X(.4)=""
  1.  S XMSUB="IMF HANDLER ERROR MESSAGE"
  1.  S XMY="G.XUMF INSTITUTION"
  1.  S XMTEXT="X("
  1.  S X=.9 F  S X=$O(X(X)) Q:'X  D
  1.  .I X(X)="" K X(X) Q
  1.  .I X(X)["DINUMed field cannot" S FLG=1 K X(X) Q
  1.  I FLG Q:'$O(X(.9))
  1.  D ^XMD
  1.  Q