Routine: XUMF04H

XUMF04H ;BP/RAM - INSTITUTION Handler ;May 03, 2022@07:45:35

 ;;8.0;KERNEL;**549,678,698,723,735,769,662**;Jul 10, 1995;Build 49

 ;;Per VA Directive 6402, this routine should not be modified

 ; This routine handles Institution Master File HL7 messages.

MAIN ; -- entry point

 Q:$$KSP^XUPARAM("INST")=12000

 N X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,KEY,VALUE,ROOT,HLSCS,CDSYS,TEXT,ID

 D INIT,PROCESS,REPLY,EXIT

INIT ; -- initialize

 S ERROR=0,IEN=""

 S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)

PROCESS ; -- pull message text

 F  X HLNEXT Q:HLQUIT'>0  D

 .Q:$P(HLNODE,HLFS)=""

 .D @($P(HLNODE,HLFS))

MSH ; -- MSH segment

MSA ; -- MSA segment

QRD ; -- QRD segment

MFI ; -- MFI segment

MFE ; -- MFE segment

 S KEY=$P(HLNODE,HLFS,5)

 S ID=$P(KEY,HLCS)

 S TEXT=$P(KEY,HLCS,2)

 S CDSYS=$P(KEY,HLCS,3)

 I CDSYS="VASTANUM" D  Q

 .S IEN=$O(^DIC(4,"D",ID,0)) Q:IEN

 .S IEN=$O(^DIC(4,"B",TEXT,0))

 I CDSYS="NPI" D  Q

 .S IEN=$O(^DIC(4,"ANPI",ID,0)) Q:IEN

 .S IEN=$O(^DIC(4,"B",TEXT,0))

 I CDSYS="DMIS" D  Q

 .S IEN=$O(^DIC(4,"XUMFIDX","DMIS",ID,0)) Q:IEN

 .S IEN=$O(^DIC(4,"B",TEXT,0))

ZIN ; -- VHA Institution segment

 W "."

 N NAME,FACTYP,OFNME,INACTIVE,STATE,VISN,PARENT,STREET,STREET2,CITY,ZIP

 N STRT1,STRT2,CITY1,STATE1,STANUM,BILLNAME,IEN1,IENS,ERR,ERROR1

 N ZIP1,AGENCY,NPIDT,NPISTAT,NPI,TAX,TAXPC,TAXSTAT,MAMMO,CLIA,DMIS,XXXX

 N LOCTZONE,COUNTRY,TZONEX,CERNER

 D PARSE^XUMFXHL7("HLNODE","XXXX")

 S STANUM=XXXX(2)

 I $G(STANUM),CDSYS'="VASTANUM" Q

 S XUMF=1,ERROR1=""

 S NAME=XXXX(1)

 S FACTYP=$P(XXXX(4),"~",1)

 S OFNME=XXXX(5)

 S INACTIVE=XXXX(6)

 S STATE=XXXX(7)

 S VISN=XXXX(8)

 S:VISN'="" VISN=$O(^DIC(4,"B",VISN,0)) ;p698

 S PARENT=XXXX(9)

 S:PARENT'="" PARENT=$O(^DIC(4,"D",PARENT,0)) ;p698

 S STREET=$P(XXXX(14),"~",1)

 S STREET2=$P(XXXX(14),"~",2)

 S CITY=$P(XXXX(14),"~",3)

 S ZIP=$P(XXXX(14),"~",5)

 S COUNTRY=$P(XXXX(14),"~",6)

 S STRT1=$P(XXXX(15),"~",1)

 S STRT2=$P(XXXX(15),"~",2)

 S CITY1=$P(XXXX(15),"~",3)

 S STATE1=$P(XXXX(15),"~",4)

 S ZIP1=$P(XXXX(15),"~",5)

 S AGENCY=$P(XXXX(16),"~")

 S NPI=XXXX(17)

 S NPISTAT=XXXX(18)

 I NPISTAT="ACTIVE" S NPISTAT=1 ;p698

 I NPISTAT="INACTIVE" S NPISTAT=0 ;698

 S NPIDT=$$FMDATE^HLFNC(XXXX(19))

 S TAX=XXXX(20)

 S TAXSTAT=XXXX(21)

 S TAXPC=XXXX(22)

 S CLIA=XXXX(23)

 S MAMMO=XXXX(24)

 S DMIS=XXXX(25)

 S BILLNAME=XXXX(26)

 S LOCTZONE=XXXX(27)

 S TZONEX=XXXX(28)

 S CERNER=$G(XXXX(29)) ;p723

 ; -- new entry

 I 'IEN D  Q:'IEN

 .N X,Y S X=NAME

 .K DIC S DIC=4,DIC(0)="F"

 .D FILE^DICN K DIC

 .S IEN=$S(Y="-1":0,1:+Y)

 S IENS=IEN_","

 K FDA

 S FDA(4,IENS,.01)=NAME

 S FDA(4,IENS,13)=FACTYP

 S FDA(4,IENS,1.01)=STREET

 S FDA(4,IENS,1.02)=STREET2

 S FDA(4,IENS,1.03)=CITY

 S FDA(4,IENS,1.04)=ZIP

 S FDA(4,IENS,.02)=STATE

 ; -- check for changes to physical address

 D PADDCK

 S FDA(4,IENS,4.01)=STRT1

 S FDA(4,IENS,4.02)=STRT2

 S FDA(4,IENS,4.03)=CITY1

 S FDA(4,IENS,4.04)=STATE1

 S FDA(4,IENS,4.05)=ZIP1

 S FDA(4,IENS,11)="National"

 S FDA(4,IENS,100)=OFNME

 S FDA(4,IENS,101)=INACTIVE

 S FDA(4,IENS,102)=CERNER ;p723

 S FDA(4,IENS,95)=AGENCY

 S FDA(4,IENS,99)=STANUM

 S FDA(4,IENS,200)=BILLNAME

 S FDA(4,IENS,800)=LOCTZONE

 S FDA(4,IENS,801)=COUNTRY

 S FDA(4,IENS,802)=TZONEX

 D FILE^DIE("E","FDA","ERR")

 I $D(ERR) D

 .D EM("error updating ZIN",.ERR)

 .K ERR

 I $G(VISN)'="" D

 .K FDA

 .S IENS="?+1,"_IEN_","

 .S FDAIEN(1)=1

 .S FDA(4.014,IENS,.01)=1

 .S FDA(4.014,IENS,1)=VISN

 .D UPDATE^DIE("","FDA","FDAIEN","ERR")

 I $D(ERR) D

 .D EM("error updating VISN",.ERR)

 .K ERR

 I $G(PARENT) D

 .S IENS="?+1,"_IEN_","

 .S FDAIEN(1)=2

 .S FDA(4.014,IENS,.01)=2

 .S FDA(4.014,IENS,1)=PARENT

 .D UPDATE^DIE("","FDA","FDAIEN","ERR")

 I $D(ERR) D

 .D EM("error updating PARENT",.ERR)

 .K ERR

 I $G(NPIDT)'="",NPI'="" D

 .K FDA

 .S IENS="?+2,"_IEN_","

 .S FDA(4.042,IENS,.01)=NPIDT

 .S FDA(4.042,IENS,.02)=NPISTAT

 .S FDA(4.042,IENS,.03)=NPI

 .D UPDATE^DIE("","FDA",,"ERR")

 I $D(ERR) D

 .D EM("error updating NPI",.ERR)

 .K ERR

 I $G(NPIDT)'="",NPI="" D

 . N XUIENEFF S XUIENEFF=$O(^DIC(4,IEN,"NPISTATUS","B",NPIDT,0))

 . I XUIENEFF>0 N DIK,DA S DA(1)=IEN,DA=XUIENEFF,DIK="^DIC(4,"_DA(1)_",""NPISTATUS""," D ^DIK

 I $G(TAX)'="",TAXSTAT'="" D

 .K FDA,ROOT,IDX

 .N IENS

 .S IENS="?+2,"_IEN_","

 .S FDA(4.043,IENS,.01)=$O(^USC(8932.1,"G",TAX,0))

 .S FDA(4.043,IENS,.02)=$S(TAXPC="YES":1,1:0)

 .S FDA(4.043,IENS,.03)=$S(TAXSTAT="ACTIVE":"A",1:"I")

 .D UPDATE^DIE("","FDA",,"ERR")

 I $D(ERR) D

 .D EM("error updating TAXANOMY",.ERR)

 .K ERR

 I $G(TAX)'="",TAXSTAT="" D

 . N TAX1 S TAX1=$O(^USC(8932.1,"G",TAX,0))

 . I TAX1'>0 Q

 . N XUIENTAX S XUIENTAX=$O(^DIC(4,IEN,"TAXONOMY","B",TAX1,0))

 . I XUIENTAX>0 N DIK,DA S DA(1)=IEN,DA=XUIENTAX,DIK="^DIC(4,"_DA(1)_",""TAXONOMY""," D ^DIK

 I $G(CLIA)'="" D

 .S IENS="?+2,"_IEN_","

 .K FDA

 .S FDA(4.9999,IENS,.01)="CLIA"

 .S FDA(4.9999,IENS,.02)=CLIA

 .D UPDATE^DIE("E","FDA",,"ERR")

 I $D(ERR) D

 .D EM("error updating CLIA",.ERR)

 .K ERR

 I $G(MAMMO)'="" D

 .S IENS="?+2,"_IEN_","

 .K FDA

 .S FDA(4.9999,IENS,.01)="MAMMO"

 .S FDA(4.9999,IENS,.02)=MAMMO

 .D UPDATE^DIE("E","FDA",,"ERR")

 I $D(ERR) D

 .D EM("error updating MAMMO",.ERR)

 .K ERR

 I $G(DMIS)'="" D

 .S IENS="?+2,"_IEN_","

 .K FDA

 .S FDA(4.9999,IENS,.01)="DMIS"

 .S FDA(4.9999,IENS,.02)=DMIS

 .D UPDATE^DIE("E","FDA",,"ERR")

 I $D(ERR) D

 .D EM("error updating DMIS",.ERR)

 .K ERR

PADDCK ; -- check for changes to physical address

 N XSTREET,XSTREET2,XCITY,XZIP,XSTATE

 N XHPADD,XIENS S XHPADD=0

 ; -- retrieve current physical address fields

 S XSTREET=$$GET1^DIQ(4,IENS,1.01)

 S XSTREET2=$$GET1^DIQ(4,IENS,1.02)

 S XCITY=$$GET1^DIQ(4,IENS,1.03)

 S XZIP=$$GET1^DIQ(4,IENS,1.04)

 S XSTATE=$$GET1^DIQ(4,IENS,.02)

 ; -- compare against fields in master file update

 I STREET'=XSTREET S XHPADD=1

 I STREET2'=XSTREET2 S XHPADD=1

 I CITY'=XCITY S XHPADD=1

 I ZIP'=XZIP S XHPADD=1

 I STATE'=XSTATE S XHPADD=1

 ; -- if differences, create historical address array

 I XHPADD D

 . K XUADD,XUEFFDT

 . S XUEFFDT(1)=DT

 . S XIENS="+1,"_IENS

 . S XUADD(4.999,XIENS,.01)=XUEFFDT(1)

 . S XUADD(4.999,XIENS,1)=XSTREET

 . S XUADD(4.999,XIENS,1.1)=XSTREET2

 . S XUADD(4.999,XIENS,1.2)=XCITY

 . S XUADD(4.999,XIENS,1.3)=XSTATE

 . S XUADD(4.999,XIENS,1.4)=XZIP

 . D UPDATE^DIE("E","XUADD","XUEFFDT")

 . K XUADD,XUEFFDT

 K XSTREET,XSTREET2,XCITY,XZIP,XSTATE,XHPADD,XIENS

REPLY ; -- master file response

 Q:HL("MTN")="MFR"

 Q:HL("MTN")="MFK"

 Q:HL("MTN")="ACK"

 S HLFS=$G(HLFS)

 S HL("MID")=$G(HL("MID"))

 S HL("EIDS")=$G(HL("EIDS"))

 S HL("EID")=$G(HL("EID"))

N X

 S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)

 S ^TMP("HLA",$J,1)=X

 S HLP("PRIORITY")="I"

 D GENACK^HLMA1(HL("EID"),$G(HLMTIENS),HL("EIDS"),"GM",1,.HLRESLT)

 ; check for error

 I ($P($G(HLRESLT),U,3)'="") D  Q

 .S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)

 ; successful call, message ID returned

 S ERROR="0^"_$P($G(HLRESLT),U,1)

EXIT ; -- cleanup, and quit

EM(ERROR,ERR) ; -- error message p698

 N X,XMSUB,XMY,XMTEXT,FLG

 S FLG=0

 D MSG^DIALOG("AM",.X,80,,"ERR")

 S X(.1)="HL7 message ID: "_$G(HL("MID"))

 S X(.2)="",X(.3)=$G(ERROR),X(.4)=""

 S XMSUB="IMF HANDLER ERROR MESSAGE"

 S XMY="G.XUMF INSTITUTION"

 S XMTEXT="X("

 S X=.9 F  S X=$O(X(X)) Q:'X  D

 .I X(X)="" K X(X) Q

 .I X(X)["DINUMed field cannot" S FLG=1 K X(X) Q

 I FLG Q:'$O(X(.9))

 D ^XMD

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF04H   7770     printed  Apr 09, 2024@21:14:43                                                                                                                                                                                                     Page 2

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

 +2       ;;Per VA Directive 6402, this routine should not be modified

 +3       ; This routine handles Institution Master File HL7 messages.

 +4       ;

MAIN      ; -- entry point

 +1       ;

 +2        if $$KSP^XUPARAM("INST")=12000

               QUIT

 +3       ;

 +4        NEW X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,KEY,VALUE,ROOT,HLSCS,CDSYS,TEXT,ID

 +5       ;

 +6        DO INIT

           DO PROCESS

           DO REPLY

           DO EXIT

 +7       ;

 +8        QUIT

 +9       ;

INIT      ; -- initialize

 +1       ;

 +2        SET ERROR=0

           SET IEN=""

 +3        SET HLFS=HL("FS")

           SET HLCS=$EXTRACT(HL("ECH"))

           SET HLSCS=$EXTRACT(HL("ECH"),4)

 +4       ;

 +5        QUIT

 +6       ;

PROCESS   ; -- pull message text

 +1       ;

 +2        FOR

               XECUTE HLNEXT

               if HLQUIT'>0

                   QUIT

               Begin DoDot:1

 +3                if $PIECE(HLNODE,HLFS)=""

                       QUIT

 +4                DO @($PIECE(HLNODE,HLFS))

               End DoDot:1

 +5       ;

 +6        QUIT

 +7       ;

MSH       ; -- MSH segment

 +1       ;

 +2        QUIT

 +3       ;

MSA       ; -- MSA segment

 +1       ;

 +2        QUIT

 +3       ;

QRD       ; -- QRD segment

 +1       ;

 +2        QUIT

 +3       ;

MFI       ; -- MFI segment

 +1       ;

 +2        QUIT

 +3       ;

MFE       ; -- MFE segment

 +1       ;

 +2        SET KEY=$PIECE(HLNODE,HLFS,5)

 +3       ;

 +4        SET ID=$PIECE(KEY,HLCS)

 +5        SET TEXT=$PIECE(KEY,HLCS,2)

 +6        SET CDSYS=$PIECE(KEY,HLCS,3)

 +7       ;

 +8        IF CDSYS="VASTANUM"

               Begin DoDot:1

 +9                SET IEN=$ORDER(^DIC(4,"D",ID,0))

                   if IEN

                       QUIT

 +10               SET IEN=$ORDER(^DIC(4,"B",TEXT,0))

               End DoDot:1

               QUIT

 +11      ;

 +12       IF CDSYS="NPI"

               Begin DoDot:1

 +13               SET IEN=$ORDER(^DIC(4,"ANPI",ID,0))

                   if IEN

                       QUIT

 +14               SET IEN=$ORDER(^DIC(4,"B",TEXT,0))

               End DoDot:1

               QUIT

 +15       IF CDSYS="DMIS"

               Begin DoDot:1

 +16               SET IEN=$ORDER(^DIC(4,"XUMFIDX","DMIS",ID,0))

                   if IEN

                       QUIT

 +17               SET IEN=$ORDER(^DIC(4,"B",TEXT,0))

               End DoDot:1

               QUIT

 +18      ;

 +19       QUIT

 +20      ;

ZIN       ; -- VHA Institution segment

 +1       ;

 +2        WRITE "."

 +3       ;

 +4        NEW NAME,FACTYP,OFNME,INACTIVE,STATE,VISN,PARENT,STREET,STREET2,CITY,ZIP

 +5        NEW STRT1,STRT2,CITY1,STATE1,STANUM,BILLNAME,IEN1,IENS,ERR,ERROR1

 +6        NEW ZIP1,AGENCY,NPIDT,NPISTAT,NPI,TAX,TAXPC,TAXSTAT,MAMMO,CLIA,DMIS,XXXX

 +7        NEW LOCTZONE,COUNTRY,TZONEX,CERNER

 +8       ;

 +9        DO PARSE^XUMFXHL7("HLNODE","XXXX")

 +10      ;

 +11       SET STANUM=XXXX(2)

 +12      ;

 +13       IF $GET(STANUM)

               IF CDSYS'="VASTANUM"

                   QUIT

 +14      ;

 +15       SET XUMF=1

           SET ERROR1=""

 +16      ;

 +17       SET NAME=XXXX(1)

 +18       SET FACTYP=$PIECE(XXXX(4),"~",1)

 +19       SET OFNME=XXXX(5)

 +20       SET INACTIVE=XXXX(6)

 +21       SET STATE=XXXX(7)

 +22       SET VISN=XXXX(8)

 +23      ;p698

           if VISN'=""

               SET VISN=$ORDER(^DIC(4,"B",VISN,0))

 +24       SET PARENT=XXXX(9)

 +25      ;p698

           if PARENT'=""

               SET PARENT=$ORDER(^DIC(4,"D",PARENT,0))

 +26       SET STREET=$PIECE(XXXX(14),"~",1)

 +27       SET STREET2=$PIECE(XXXX(14),"~",2)

 +28       SET CITY=$PIECE(XXXX(14),"~",3)

 +29       SET ZIP=$PIECE(XXXX(14),"~",5)

 +30       SET COUNTRY=$PIECE(XXXX(14),"~",6)

 +31       SET STRT1=$PIECE(XXXX(15),"~",1)

 +32       SET STRT2=$PIECE(XXXX(15),"~",2)

 +33       SET CITY1=$PIECE(XXXX(15),"~",3)

 +34       SET STATE1=$PIECE(XXXX(15),"~",4)

 +35       SET ZIP1=$PIECE(XXXX(15),"~",5)

 +36       SET AGENCY=$PIECE(XXXX(16),"~")

 +37       SET NPI=XXXX(17)

 +38       SET NPISTAT=XXXX(18)

 +39      ;p698

           IF NPISTAT="ACTIVE"

               SET NPISTAT=1

 +40      ;698

           IF NPISTAT="INACTIVE"

               SET NPISTAT=0

 +41       SET NPIDT=$$FMDATE^HLFNC(XXXX(19))

 +42       SET TAX=XXXX(20)

 +43       SET TAXSTAT=XXXX(21)

 +44       SET TAXPC=XXXX(22)

 +45       SET CLIA=XXXX(23)

 +46       SET MAMMO=XXXX(24)

 +47       SET DMIS=XXXX(25)

 +48       SET BILLNAME=XXXX(26)

 +49       SET LOCTZONE=XXXX(27)

 +50       SET TZONEX=XXXX(28)

 +51      ;p723

           SET CERNER=$GET(XXXX(29))

 +52      ;

 +53      ; -- new entry

 +54       IF 'IEN

               Begin DoDot:1

 +55               NEW X,Y

                   SET X=NAME

 +56               KILL DIC

                   SET DIC=4

                   SET DIC(0)="F"

 +57               DO FILE^DICN

                   KILL DIC

 +58               SET IEN=$SELECT(Y="-1":0,1:+Y)

               End DoDot:1

               if 'IEN

                   QUIT

 +59      ;

 +60       SET IENS=IEN_","

 +61      ;

 +62       KILL FDA

 +63       SET FDA(4,IENS,.01)=NAME

 +64       SET FDA(4,IENS,13)=FACTYP

 +65       SET FDA(4,IENS,1.01)=STREET

 +66       SET FDA(4,IENS,1.02)=STREET2

 +67       SET FDA(4,IENS,1.03)=CITY

 +68       SET FDA(4,IENS,1.04)=ZIP

 +69       SET FDA(4,IENS,.02)=STATE

 +70      ;

 +71      ; -- check for changes to physical address

 +72       DO PADDCK

 +73      ;

 +74       SET FDA(4,IENS,4.01)=STRT1

 +75       SET FDA(4,IENS,4.02)=STRT2

 +76       SET FDA(4,IENS,4.03)=CITY1

 +77       SET FDA(4,IENS,4.04)=STATE1

 +78       SET FDA(4,IENS,4.05)=ZIP1

 +79       SET FDA(4,IENS,11)="National"

 +80       SET FDA(4,IENS,100)=OFNME

 +81       SET FDA(4,IENS,101)=INACTIVE

 +82      ;p723

           SET FDA(4,IENS,102)=CERNER

 +83       SET FDA(4,IENS,95)=AGENCY

 +84       SET FDA(4,IENS,99)=STANUM

 +85       SET FDA(4,IENS,200)=BILLNAME

 +86       SET FDA(4,IENS,800)=LOCTZONE

 +87       SET FDA(4,IENS,801)=COUNTRY

 +88       SET FDA(4,IENS,802)=TZONEX

 +89       DO FILE^DIE("E","FDA","ERR")

 +90       IF $DATA(ERR)

               Begin DoDot:1

 +91               DO EM("error updating ZIN",.ERR)

 +92               KILL ERR

               End DoDot:1

 +93      ;

 +94       IF $GET(VISN)'=""

               Begin DoDot:1

 +95               KILL FDA

 +96               SET IENS="?+1,"_IEN_","

 +97               SET FDAIEN(1)=1

 +98               SET FDA(4.014,IENS,.01)=1

 +99               SET FDA(4.014,IENS,1)=VISN

 +100              DO UPDATE^DIE("","FDA","FDAIEN","ERR")

               End DoDot:1

 +101      IF $DATA(ERR)

               Begin DoDot:1

 +102              DO EM("error updating VISN",.ERR)

 +103              KILL ERR

               End DoDot:1

 +104     ;

 +105      IF $GET(PARENT)

               Begin DoDot:1

 +106              SET IENS="?+1,"_IEN_","

 +107              SET FDAIEN(1)=2

 +108              SET FDA(4.014,IENS,.01)=2

 +109              SET FDA(4.014,IENS,1)=PARENT

 +110              DO UPDATE^DIE("","FDA","FDAIEN","ERR")

               End DoDot:1

 +111      IF $DATA(ERR)

               Begin DoDot:1

 +112              DO EM("error updating PARENT",.ERR)

 +113              KILL ERR

               End DoDot:1

 +114     ;

 +115      IF $GET(NPIDT)'=""

               IF NPI'=""

                   Begin DoDot:1

 +116                  KILL FDA

 +117                  SET IENS="?+2,"_IEN_","

 +118                  SET FDA(4.042,IENS,.01)=NPIDT

 +119                  SET FDA(4.042,IENS,.02)=NPISTAT

 +120                  SET FDA(4.042,IENS,.03)=NPI

 +121                  DO UPDATE^DIE("","FDA",,"ERR")

                   End DoDot:1

 +122      IF $DATA(ERR)

               Begin DoDot:1

 +123              DO EM("error updating NPI",.ERR)

 +124              KILL ERR

               End DoDot:1

 +125     ;

 +126      IF $GET(NPIDT)'=""

               IF NPI=""

                   Begin DoDot:1

 +127                  NEW XUIENEFF

                       SET XUIENEFF=$ORDER(^DIC(4,IEN,"NPISTATUS","B",NPIDT,0))

 +128                  IF XUIENEFF>0

                           NEW DIK,DA

                           SET DA(1)=IEN

                           SET DA=XUIENEFF

                           SET DIK="^DIC(4,"_DA(1)_",""NPISTATUS"","

                           DO ^DIK

                   End DoDot:1

 +129     ;

 +130      IF $GET(TAX)'=""

               IF TAXSTAT'=""

                   Begin DoDot:1

 +131                  KILL FDA,ROOT,IDX

 +132                  NEW IENS

 +133                  SET IENS="?+2,"_IEN_","

 +134                  SET FDA(4.043,IENS,.01)=$ORDER(^USC(8932.1,"G",TAX,0))

 +135                  SET FDA(4.043,IENS,.02)=$SELECT(TAXPC="YES":1,1:0)

 +136                  SET FDA(4.043,IENS,.03)=$SELECT(TAXSTAT="ACTIVE":"A",1:"I")

 +137                  DO UPDATE^DIE("","FDA",,"ERR")

                   End DoDot:1

 +138      IF $DATA(ERR)

               Begin DoDot:1

 +139              DO EM("error updating TAXANOMY",.ERR)

 +140              KILL ERR

               End DoDot:1

 +141     ;

 +142      IF $GET(TAX)'=""

               IF TAXSTAT=""

                   Begin DoDot:1

 +143                  NEW TAX1

                       SET TAX1=$ORDER(^USC(8932.1,"G",TAX,0))

 +144                  IF TAX1'>0

                           QUIT

 +145                  NEW XUIENTAX

                       SET XUIENTAX=$ORDER(^DIC(4,IEN,"TAXONOMY","B",TAX1,0))

 +146                  IF XUIENTAX>0

                           NEW DIK,DA

                           SET DA(1)=IEN

                           SET DA=XUIENTAX

                           SET DIK="^DIC(4,"_DA(1)_",""TAXONOMY"","

                           DO ^DIK

                   End DoDot:1

 +147     ;

 +148      IF $GET(CLIA)'=""

               Begin DoDot:1

 +149              SET IENS="?+2,"_IEN_","

 +150              KILL FDA

 +151              SET FDA(4.9999,IENS,.01)="CLIA"

 +152              SET FDA(4.9999,IENS,.02)=CLIA

 +153              DO UPDATE^DIE("E","FDA",,"ERR")

               End DoDot:1

 +154      IF $DATA(ERR)

               Begin DoDot:1

 +155              DO EM("error updating CLIA",.ERR)

 +156              KILL ERR

               End DoDot:1

 +157     ;

 +158      IF $GET(MAMMO)'=""

               Begin DoDot:1

 +159              SET IENS="?+2,"_IEN_","

 +160              KILL FDA

 +161              SET FDA(4.9999,IENS,.01)="MAMMO"

 +162              SET FDA(4.9999,IENS,.02)=MAMMO

 +163              DO UPDATE^DIE("E","FDA",,"ERR")

               End DoDot:1

 +164      IF $DATA(ERR)

               Begin DoDot:1

 +165              DO EM("error updating MAMMO",.ERR)

 +166              KILL ERR

               End DoDot:1

 +167     ;

 +168      IF $GET(DMIS)'=""

               Begin DoDot:1

 +169              SET IENS="?+2,"_IEN_","

 +170              KILL FDA

 +171              SET FDA(4.9999,IENS,.01)="DMIS"

 +172              SET FDA(4.9999,IENS,.02)=DMIS

 +173              DO UPDATE^DIE("E","FDA",,"ERR")

               End DoDot:1

 +174      IF $DATA(ERR)

               Begin DoDot:1

 +175              DO EM("error updating DMIS",.ERR)

 +176              KILL ERR

               End DoDot:1

 +177     ;

 +178      QUIT

 +179     ;

PADDCK    ; -- check for changes to physical address

 +1       ;

 +2        NEW XSTREET,XSTREET2,XCITY,XZIP,XSTATE

 +3        NEW XHPADD,XIENS

           SET XHPADD=0

 +4       ;

 +5       ; -- retrieve current physical address fields

 +6        SET XSTREET=$$GET1^DIQ(4,IENS,1.01)

 +7        SET XSTREET2=$$GET1^DIQ(4,IENS,1.02)

 +8        SET XCITY=$$GET1^DIQ(4,IENS,1.03)

 +9        SET XZIP=$$GET1^DIQ(4,IENS,1.04)

 +10       SET XSTATE=$$GET1^DIQ(4,IENS,.02)

 +11      ;

 +12      ; -- compare against fields in master file update

 +13       IF STREET'=XSTREET

               SET XHPADD=1

 +14       IF STREET2'=XSTREET2

               SET XHPADD=1

 +15       IF CITY'=XCITY

               SET XHPADD=1

 +16       IF ZIP'=XZIP

               SET XHPADD=1

 +17       IF STATE'=XSTATE

               SET XHPADD=1

 +18      ;

 +19      ; -- if differences, create historical address array

 +20       IF XHPADD

               Begin DoDot:1

 +21               KILL XUADD,XUEFFDT

 +22               SET XUEFFDT(1)=DT

 +23               SET XIENS="+1,"_IENS

 +24               SET XUADD(4.999,XIENS,.01)=XUEFFDT(1)

 +25               SET XUADD(4.999,XIENS,1)=XSTREET

 +26               SET XUADD(4.999,XIENS,1.1)=XSTREET2

 +27               SET XUADD(4.999,XIENS,1.2)=XCITY

 +28               SET XUADD(4.999,XIENS,1.3)=XSTATE

 +29               SET XUADD(4.999,XIENS,1.4)=XZIP

 +30               DO UPDATE^DIE("E","XUADD","XUEFFDT")

 +31               KILL XUADD,XUEFFDT

               End DoDot:1

 +32       KILL XSTREET,XSTREET2,XCITY,XZIP,XSTATE,XHPADD,XIENS

 +33       QUIT

 +34      ;

REPLY     ; -- master file response

 +1       ;

 +2        if HL("MTN")="MFR"

               QUIT

 +3        if HL("MTN")="MFK"

               QUIT

 +4        if HL("MTN")="ACK"

               QUIT

 +5        SET HLFS=$GET(HLFS)

 +6        SET HL("MID")=$GET(HL("MID"))

 +7        SET HL("EIDS")=$GET(HL("EIDS"))

 +8        SET HL("EID")=$GET(HL("EID"))

 +9       ;

 +10       NEW X

 +11       SET X="MSA"_HLFS_$SELECT(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$PIECE(ERROR,U,2)

 +12       SET ^TMP("HLA",$JOB,1)=X

 +13      ;

 +14       SET HLP("PRIORITY")="I"

 +15       DO GENACK^HLMA1(HL("EID"),$GET(HLMTIENS),HL("EIDS"),"GM",1,.HLRESLT)

 +16      ;

 +17      ; check for error

 +18       IF ($PIECE($GET(HLRESLT),U,3)'="")

               Begin DoDot:1

 +19               SET ERROR=1_U_$PIECE(HLRESLT,HLFS,3)_U_$PIECE(HLRESLT,HLFS,2)_U_$PIECE(HLRESLT,U)

               End DoDot:1

               QUIT

 +20      ;

 +21      ; successful call, message ID returned

 +22       SET ERROR="0^"_$PIECE($GET(HLRESLT),U,1)

 +23      ;

 +24       QUIT

 +25      ;

EXIT      ; -- cleanup, and quit

 +1       ;

 +2        QUIT

 +3       ;

EM(ERROR,ERR) ; -- error message p698

 +1       ;

 +2        NEW X,XMSUB,XMY,XMTEXT,FLG

 +3        SET FLG=0

 +4        DO MSG^DIALOG("AM",.X,80,,"ERR")

 +5       ;

 +6        SET X(.1)="HL7 message ID: "_$GET(HL("MID"))

 +7        SET X(.2)=""

           SET X(.3)=$GET(ERROR)

           SET X(.4)=""

 +8        SET XMSUB="IMF HANDLER ERROR MESSAGE"

 +9        SET XMY="G.XUMF INSTITUTION"

 +10       SET XMTEXT="X("

 +11       SET X=.9

FOR

               SET X=$ORDER(X(X))

               if 'X

                   QUIT

               Begin DoDot:1

 +12               IF X(X)=""

                       KILL X(X)

                       QUIT

 +13               IF X(X)["DINUMed field cannot"

                       SET FLG=1

                       KILL X(X)

                       QUIT

               End DoDot:1

 +14       IF FLG

               if '$ORDER(X(.9))

                   QUIT

 +15       DO ^XMD

 +16       QUIT

XUMF04H.m