BYIMPORT.m

BYIMPORT ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;

 ;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22

 ;

 ;

 ;this routine will import a GIS package from the ^INXPORT global

 ;it will then populate the SCRIPT GENERATOR FIELD, SEGMENT, and

 ;MESSAGE files and also the INTERFACE TRANSACTION TYPE, DESTINATION,

 ;and BACKGROUND PROCESS files

 ;

 ;-----

MAIN ;EP - this is the main routine driver

 S CLEAN=1

 I $O(^INXPORT(""))="" D  Q

 . W !,"Global ^INXPORT is missing, please restore and rerun"

 S KFM="K DIE,DR,DIC,DA,DD,DO,DIK"

 D NS

 D ADD01

 D MSG

 D EOJ

 Q

 ;-----

NS ;-- parse the INXPORT global get package name        

 S INMT=$O(^INXPORT(""))

 Q:INMT=""

 S INST=$O(^INXPORT(INMT,""))

 Q:INST=""

 S INPKG=$O(^INXPORT(INMT,INST,""))

 I INPKG="" S INPKG="CORE"

 I '$O(^INRHNS("B",INPKG,"")) D

 . K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 . S DIC(0)="L"

 . S DIC="^INRHNS("

 . S X=INPKG

 . D FILE^DICN

 . K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 . S INNS=+Y

 . K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 . S DA(1)=INNS

 . S DIC(0)="L"

 . S DIC="^INRHNS("_DA(1)_",1,"

 . S X=INST

 . S DIC("P")=$P(^DD(4007,1,0),U,2)

 . D FILE^DICN

 . K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S INNS=$O(^INRHNS("B",INPKG,""))

 S INSTOK=$$STCK(INNS,INST)

 S INMPRE="^INXPORT(INMT,INST,INPKG)"

 Q

 ;-----

MSG ;-- Import the fields from the INXPORT global

 D ADDTT

 D ADDD

 D ADDBP

 S INMDA=0

 F  S INMDA=$O(@INMPRE@(INMDA)) Q:'INMDA  D

 . D FD(INMDA,0)

 . D FD(INMDA,1)

 . D SD(INMDA)

 . S INOUT=$S($G(@INMPRE@(INMDA,"INOUT"))="IN":1,1:0)

 . D MD(INMDA)

 Q

 ;-----

FD(MDA,PASS)          ;-- parse the fields out of the message and check exist

 ;add all fields first then go back and add sub fields if necessary

 S INFDA=0 F  S INFDA=$O(@INMPRE@(MDA,"FD",INFDA)) Q:'INFDA  D

 . S INFDEF=$G(@INMPRE@(MDA,"FD",INFDA))

 . S INF01=$P(INFDEF,U)

 . S INF02=$P(INFDEF,U,2)

 . S INF03=$P(INFDEF,U,3)

 . S INF3=$P(INFDEF,U,4)

 . S INF5=$G(@INMPRE@(MDA,"FD",INFDA,"OUT"))

 . S INY=+$$CHKF(INF01,INF02,INF03,INF3,INF5)

 . Q:'INY!'$D(@INMPRE@(MDA,"FD",INFDA,"SUB"))!'PASS

 . S INFS=0

 . F  S INFS=$O(@INMPRE@(MDA,"FD",INFDA,"SUB",INFS)) Q:'INFS  D

 .. S INFSD=$G(@INMPRE@(MDA,"FD",INFDA,"SUB",INFS))

 .. S INFS01=$P(INFSD,U)

 .. S INFS02=$P(INFSD,U,2)

 .. S INFSB=$$FSUB(INY,INFS01,INFS02)

 K:PASS @INMPRE@(MDA,"FD")

 Q

 ;-----

SD(MDA)          ;-- lets setup the segments

 S INSDA=0 F  S INSDA=$O(@INMPRE@(MDA,"SD",INSDA)) Q:'INSDA  D

 . S INSGDT=$G(@INMPRE@(MDA,"SD",INSDA))

 . S INS01=$P(INSGDT,U)

 . S INS02=$P(INSGDT,U,2)

 . S INY=$$CHKS(INS01,INS02)

 . Q:'INY

 . S INSFDA=0 F  S INSFDA=$O(@INMPRE@(MDA,"SD",INSDA,"FD",INSFDA)) Q:'INSFDA  D

 .. S INSFDT=$G(@INMPRE@(MDA,"SD",INSDA,"FD",INSFDA))

 .. S INSF01=$P(INSFDT,U)

 .. S INSFIEN=$O(^INTHL7F("B",INSF01,0))

 .. Q:'INSFIEN

 .. S INSF02=$P(INSFDT,U,2)

 .. S INSF03=$P(INSFDT,U,3)

 .. S INSFLD=$$SEGF(INY,INSFIEN,INSF01,INSF02,INSF03)

 K @INMPRE@(MDA,"SD")

 Q

 ;-----

MD(MDA) ;-- setup the message

 S INMDT=$G(@INMPRE@(MDA,"MD"))

 S INM01=$P($P(INMDT,";"),"///",2)

 Q:'$L(INM01)

 S INLKST=$G(@INMPRE@(MDA,"MD","ROU"))

 S INY=$$CHKM(INM01,$P(INMDT,";",2,99)_INLKST)

 D CHARUP^BHLU(INY)

 S INMTT=0 F  S INMTT=$O(@INMPRE@(MDA,"MD","TT",INMTT)) Q:'INMTT  D

 . S INMTTE=$G(@INMPRE@(MDA,"MD","TT",INMTT))

 . S INTCHK=$$CHKMT(INY,INMTTE)

 K @INMPRE@(MDA,"MD","TT")

 S INMOM=0 F  S INMOM=$O(@INMPRE@(MDA,"MD","OIMC",INMOM)) Q:'INMOM  D

 . S INOME=$G(@INMPRE@(MDA,"MD","OIMC",INMOM))

 . S INOCHK=$$CHKOM(INY,INOME)

 K @INMPRE@(MDA,"MD","OIMC")

 S INMDS=0 F  S INMDS=$O(@INMPRE@(MDA,"MD","DESC",INMDS)) Q:'INMDS  D

 . S INDESC=$G(@INMPRE@(MDA,"MD","DESC",INMDS))

 . S INMADS=$$CHKDS(INY,INDESC)

 K @INMPRE@(MDA,"MD","DESC")

 S INMSG=0 F  S INMSG=$O(@INMPRE@(MDA,"MD","SEG",INMSG)) Q:'INMSG  D

 . S INMSGD=$G(@INMPRE@(MDA,"MD","SEG",INMSG))

 . S INMSGN=$P(INMSGD,U)

 . S INMSGS=$P(INMSGD,U,2)

 . S INMSGR=$P(INMSGD,U,3)

 . S INMSGOF=$P(INMSGD,U,4)

 . S INMSGFL=$P(INMSGD,U,5)

 . S INMSGP=$P(INMSGD,U,6)

 . S INMSGM=$P(INMSGD,U,7)

 . S INMSGPS=$P(INMSGD,U,8)

 . S INMSGU=$P(INMSGD,U,9)

 . S INMSY=$$CHKMS(INY,INMSGN,INMSGS,INMSGR,INMSGOF,INMSGFL,INMSGP,INMSGM,INMSGPS,INMSGU)

 . I $G(@INMPRE@(MDA,"MD","SEG",INMSG,"SCR"))]"" D

 .. S ^INTHL7M(INY,1,INMSY,4)=@INMPRE@(MDA,"MD","SEG",INMSG,"SCR")

 . K ^INTLH7M(INY,1,INMSY,5)  ;remove existing seg m code

 . S INMSGO=0 F  S INMSGO=$O(@INMPRE@(MDA,"MD","SEG",INMSG,"OMC",INMSGO)) Q:'INMSGO  D

 .. S INMSGOD=$G(@INMPRE@(MDA,"MD","SEG",INMSG,"OMC",INMSGO))

 .. S INMSGOMC=$$CHKSOM(INY,INMSY,INMSGOD)

 K @INMPRE@(MDA,"MD")

 D COMPILE^BHLU(INY)

 Q

 ;-----

STCK(NS,ST) ;-- check to see if the site already exists if not add it

 S INNDA=0 F  S INNDA=$O(^INRHNS(NS,1,INNDA)) Q:'INNDA!($G(INIEN))  D

 . I $G(^INRHNS(NS,1,INNDA,0))=ST S INIEN=INNDA Q

 I '$G(INIEN) Q $$ADD(NS,ST)

 Q INIEN

 ;-----

ADD(NMS,SIT)       ;-- add the site to the namespace file

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 ;PATCH 7 ENSURE DA(1) SET TO AVOID <UNDEF>

 S DA(1)=NMS

 S DIC="^INRHNS("_NMS_",1,"

 S:'$D(^INRHNS(NMS,1,0)) $P(^INRHNS(NMS,1,0),U,2)=4007.01

 S DIC(0)="L"

 S DIC("P")=$P(^DD(4007,1,0),U,2)

 S X=SIT

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

CHKF(F01,F02,F03,F3,F5)          ;-- check for field add/update

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 I $O(^INTHL7F("B",F01,0)) Q $$UPDF(F01,F02,F03,F3,F5)

 S DIC="^INTHL7F("

 S DIC(0)="L"

 S X=F01

 S DIC("DR")=".02///"_F02_";.03///"_F03_";3///"_F3_";5///"_F5

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S FLDI=+Y

 Q FLDI

 ;-----

CHKS(S01,S02)      ;-- check for seg existence add/update

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S SGIEN=$O(^INTHL7S("B",S01,0))

 I SGIEN,S01["IZV04" D:$G(CLEAN)  Q SGIEN  ;THL

 .S DA(1)=SGIEN

 .S DIK="^INTHL7S("_DA(1)_",1,"

 .S DA=0

 .F  S DA=$O(^INTHL7S(DA(1),1,DA)) Q:'DA  D ^DIK

 S DIC="^INTHL7S("

 S DIC(0)="L"

 S X=S01

 S DIC("DR")=".02///"_S02

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

CHKM(M01,MDT)      ;-- check for message process add/update

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S MIEN=$O(^INTHL7M("B",M01,0))

 I MIEN,M01["IZV04" D  Q MIEN  ;THL

 . D:$G(CLEAN)&$O(^INTHL7M(MIEN,1,0))

 .. S DA(1)=MIEN

 .. S DIK="^INTHL7M("_DA(1)_",1,"

 .. S DA=0

 .. F  S DA=$O(^INTHL7M(DA(1),1,DA)) Q:'DA  D ^DIK

 . S DIE="^INTHL7M("

 . S DA=MIEN

 . S DR=MDT

 . D DIE

 . S ^INTHL7M(MIEN,"FS")="|",^("EC")="^~\&"

 Q $$MADD(M01,MDT)

 ;-----

CHKMS(MS01,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU)        ;-- check for msg segment mult

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S SGIEN=$O(^INTHL7S("B",GN,0))

 S MSGIEN=$O(^INTHL7M("SEG",SGIEN,MS01,0))

 I MSGIEN D

 . S DIK="^INTHL7M("_MS01_",1,"

 . S DA(1)=MS01

 . S DA=MSGIEN

 . K ^INTHL7M(MS01,1,MSGIEN,1)

 . D ^DIK

 . Q

 . S DIE="^INTHL7M("_MS01_",1,"_MSGIEN_","

 . S DA(1)=MS01

 . S DA=MSGIEN

 . S DR=".02///"_GS_";.03///"_GR_";.04///"_GOF_";.05///"_GFL

 . S DR=DR_";.07///"_GP_";.08///"_GM_";.11///"_GPS_";.12///"_GU

 . S DIC("P")=$P(^DD(4011,1,0),U,2)

 . D DIE

 Q $$MSADD(MS01,SGIEN,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU)

 ;-----

MSADD(MSGI,MSGN,AGN,AGS,AGR,AGOF,AGFL,AGP,AGM,AGPS,AGU)        ;-- add segment

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC="^INTHL7M("_MSGI_",1,"

 S DIC(0)="L"

 S DA(1)=MSGI

 S X=MSGN

 S DIC("DR")=".02///"_AGS_";.03///"_AGR_";.04///"_AGOF_";.05///"_AGFL

 S DIC("DR")=DIC("DR")_";.07///"_AGP_";.08///"_AGM_";.11///"_AGPS

 S DIC("DR")=DIC("DR")_";.12///"_AGU

 S DIC("P")=$P(^DD(4011,1,0),U,2)

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

UPDF(FL01,FL02,FL03,FL3,FL5)  ;-- update an existing field 

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S INFIEN=$O(^INTHL7F("B",FL01,0))

 I $G(CLEAN),FL01["IZV04",$O(^INTHL7F(INFIEN,10,0)) D  ;THL

 .S DA(1)=INFIEN

 .S DIK="^INTHL7F("_DA(1)_",10,"

 .S DA=0

 .F  S DA=$O(^INTHL7F(DA(1),10,DA)) Q:'DA  D ^DIK

 S DA=INFIEN

 S DIE="^INTHL7F("

 S DR=".02///"_FL02_";.03///"_FL03_";3///"_FL3_";5///"_FL5

 D DIE

 Q INFIEN

 ;-----

FSUB(FDA,FS01,FS02)          ;-- check the subfields also

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S INFSIEN=$O(^INTHL7F("B",FS01,0))

 Q:INFSIEN=""

 I '$D(^INTHL7F(FDA,10)) Q $$FSUBADD(FDA,INFSIEN,FS02)

 K INMTCH

 S INFSX=$O(^INTHL7F(FDA,10,"B",INFSIEN,0))

 I $G(INFSX) D  Q INFSX

 . Q:$P($G(^INTHL7F(FDA,10,INFSX,0)),U,2)=FS02

 . S DIE="^INTHL7F("_FDA_",10,"_INFSX_","

 . S DIC("P")=$P(^DD(4012,10,0),U,2)

 . S DA(1)=FDA

 . S DA=INFSX

 . S DR=".02///"_FS02

 . D DIE

 . K DIE

 S INFSIEN=$O(^INTHL7F("B",FS01,0))

 S FSIEN=$$FSUBADD(FDA,INFSIEN,FS02)

 Q FSIEN

 ;-----

FSUBADD(FIEN,FSL01,FSL02)    ;-- add the subfile

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DA(1)=FIEN

 S DIC="^INTHL7F("_DA(1)_",10,"

 S X=FSL01

 S DIC(0)="L"

 S DIC("P")=$P(^DD(4012,10,0),U,2)

 S DIC("DR")=".02///"_FSL02

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

SEGF(SIEN,SFIEN,SF01,SF02,SF03)    ;-- check for fld exist add/upd

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 I '$D(^INTHL7S(SIEN,1)) Q $$SFADD(SIEN,SFIEN,SF02,SF03)

 S SFLIEN=$O(^INTHL7S(SIEN,1,"B",SFIEN,0))

 I 'SFLIEN Q $$SFADD(SIEN,SFIEN,SF02,SF03)

 I $P($G(^INTHL7S(SIEN,1,SFLIEN,0)),U,2)=SF02 Q SFLIEN

 S DA(1)=SIEN

 S DA=SFLIEN

 S DIE="^INTHL7S("_SIEN_",1,"_SFLIEN_","

 S DR=".02///"_SF02_";.03///"_SF03

 D DIE

 Q SFLIEN

 ;-----

SFADD(SN,S01,S02,S03)    ;-- add the field to the segment

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC="^INTHL7S("_SN_",1,",DIC(0)="L"

 S DA(1)=SN

 S X=S01

 S DIC("P")=$P(^DD(4010,1,0),U,2)

 S DIC("DR")=".02///"_S02_";.03///"_S03

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

MADD(MA01,MADT)    ;-- add the message

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC="^INTHL7M("

 S DIC(0)="L"

 S X=MA01

 S DIC("DR")=MADT

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S ^INTHL7M(+Y,"FS")="|",^("EC")="^~\&"

 Q +Y

 ;-----

CHKOM(MSG,OMC)     ;-- replace outgoing mumps code

 K ^INTHL7M(INY,6)  ;kill off existing outgoing m code

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC="^INTHL7M("_MSG_",6,"

 S DIC(0)="L"

 S DA(1)=MSG

 S X=OMC

 S DIC("P")=$P(^DD(4011,6,0),U,2)

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

CHKDS(MSG,DSC)     ;-- replace description

 K ^INTHL7M(INY,3)  ;kill of existing description

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC="^INTHL7M("_MSG_",3,"

 S DIC(0)="L"

 S DA(1)=MSG

 S X=DSC

 S DIC("P")=$P(^DD(4011,3,0),U,2)

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

CHKMT(MSG,MTT)     ;-- add tt to msg

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S MTIEN=$O(^INRHT("B",MTT,0))

 I 'MTIEN Q 0

 I '$O(^INTHL7M(MSG,2,"B",MTIEN,0)) Q $$ADDT(MSG,MTIEN)

 Q $O(^INTHL7M(MSG,2,"B",MTIEN,0))

 ;-----

ADDT(MSG,TT)       ;-- add the transaction to the message

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC="^INTHL7M("_MSG_",2,"

 S DA(1)=MSG

 S DIC(0)="L"

 S X=TT

 S DIC("P")=$P(^DD(4011,2,0),U,2)

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

CHKSOM(MS,MSEG,OMC)          ;-- add m code to segment

 K ^INTHL7M(MS,1,MSEG,1)  ;remove existing seg m code

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC="^INTHL7M("_MS_",1,"_MSEG_",5,"

 S DIC(0)="L"

 S DA(1)=MS

 S DA=MSEG

 S DIC("P")=$P(^DD(4011.01,5,0),U,2)

 S X=OMC

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q +Y

 ;-----

ADD01 ;

 S INADD01=""

 D ADDTT

 D ADDD

 D ADDBP

 K INADD01

 Q

 ;-----

ADDD ;-- add all destinations in namespace first    

 S INADA=0

 F  S INADA=$O(@INMPRE@("DEST",INADA)) Q:'INADA  D

 .S INADDT=$G(@INMPRE@("DEST",INADA))

 .S INAD01=$P($P(INADDT,";"),"///",2)

 .S INAD02=$P($P(INADDT,";",2),"///",2)

 .S:INAD02]"" INAD02=$O(^INRHT("B",INAD02,0))

 .S INADDR=$P(INADDT,";",2,99)

 .I INAD02 S $P(INADDR,";")=".02////"_INAD02

 .K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 .S INDIEN=$O(^INRHD("B",INAD01,0))

 .I 'INDIEN D  Q:INDIEN<0

 ..S DIC="^INRHD("

 ..S DIC(0)="L"

 ..S X=INAD01

 ..D FILE^DICN

 ..K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 ..S INDIEN=+Y

 .Q:$D(INADD01)

 .S DA=INDIEN

 .S DIE="^INRHD("

 .S DR=INADDR

 .D DIE

 .I INAD02,'$P(^INRHD(INDIEN,0),U,2) S $P(^(0),U,2)=INAD02

 Q

 ;-----

ADDTT ;-- add all transactions in namespace first    

 S INADA=0

 F  S INADA=$O(@INMPRE@("TT",INADA)) Q:'INADA  D

 .S INADDT=$G(@INMPRE@("TT",INADA))

 .S INAD01=$P($P(INADDT,";"),"///",2)

 .S INADDR=$P(INADDT,";",2,99)

 .K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 .S INDIEN=$O(^INRHT("B",INAD01,0))

 .I 'INDIEN D  Q:INDIEN<0

 ..S DIC="^INRHT("

 ..S DIC(0)="L"

 ..S X=INAD01

 ..D FILE^DICN

 ..K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 ..S INDIEN=+Y

 .Q:$D(INADD01)

 .S DA=INDIEN

 .S DIE="^INRHT("

 .S DR=INADDR

 .D DIE

 Q

 ;-----

ADDBP ;-- add all transactions in namespace first    

 S INADA=0

 F  S INADA=$O(@INMPRE@("BP",INADA)) Q:'INADA  D

 .S INADDT=$G(@INMPRE@("BP",INADA))

 .S INAD01=$P($P(INADDT,";"),"///",2)

 .S INADDR=$P(INADDT,";",2,99)

 .K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 .S INDIEN=$O(^INTHPC("B",INAD01,0))

 .I 'INDIEN D  Q:INDIEN<0

 ..S DIC="^INTHPC("

 ..S DIC(0)="L"

 ..S X=INAD01

 ..D FILE^DICN

 ..K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 ..S INDIEN=+Y

 .Q:$D(INADD01)

 .S DIE="^INTHPC("

 .S DA=INDIEN

 .S DR=INADDR

 .D DIE

 Q

 ;-----

EOJ ;-- kill variables and quit

 K DIK,FLDI,FSIEN,INAD01,INAD02,INADA,INADDR,INADDT,INDESC,INDIEN,INF01,INF02,INF03,INF3,INF5,INFDA,INFDEF,INFIEN,INFS,INFS01,INFS02,INFSB,INFSD,INFSIEN,INIEN,INLKST,INM01,INMADS,INMDA,INMDS,INMDT,INMOM,INMPRE,INMSG,INMSGD,INMSGFL

 K INMSGM,INMSGN,INMSGO,INMSGOD,INMSGOF,INMSGP,INMSGPS,INMSGR,INMSGS,INMSGU,INMSY,INMT,INMTCH,INMTT,INMTTE,INNDA,INNS,INOCHK,INOME,INOUT,INPKG,INS01,INS02,INSDA,INSF01,INSF02,INSF03,INSFDA,INSFDT,INSFIEN,INSFLD,INSGDT,INST,INSTOK

 K INTCHK,INY,KFM,MIEN,MSGIEN,MTIEN,SFLIEN,SGIEN,X,Y,INMSGOMC,CLEAN

 D EN^XBVK("IN")

 Q

 ;-----

DIE K Y

 D ^DIE

 K DA,DR,DIE,DIC,DINUM,Y

 Q

 ;-----

BYIMPORT  ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;

 +1       ;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22

 +2       ;

 +3       ;

 +4       ;this routine will import a GIS package from the ^INXPORT global

 +5       ;it will then populate the SCRIPT GENERATOR FIELD, SEGMENT, and

 +6       ;MESSAGE files and also the INTERFACE TRANSACTION TYPE, DESTINATION,

 +7       ;and BACKGROUND PROCESS files

 +8       ;

 +9       ;-----

MAIN      ;EP - this is the main routine driver

 +1        SET CLEAN=1

 +2        IF $ORDER(^INXPORT(""))=""

               Begin DoDot:1

 +3                WRITE !,"Global ^INXPORT is missing, please restore and rerun"

               End DoDot:1

               QUIT 

 +4        SET KFM="K DIE,DR,DIC,DA,DD,DO,DIK"

 +5        DO NS

 +6        DO ADD01

 +7        DO MSG

 +8        DO EOJ

 +9        QUIT 

 +10      ;-----

NS        ;-- parse the INXPORT global get package name        

 +1        SET INMT=$ORDER(^INXPORT(""))

 +2        IF INMT=""

               QUIT 

 +3        SET INST=$ORDER(^INXPORT(INMT,""))

 +4        IF INST=""

               QUIT 

 +5        SET INPKG=$ORDER(^INXPORT(INMT,INST,""))

 +6        IF INPKG=""

               SET INPKG="CORE"

 +7        IF '$ORDER(^INRHNS("B",INPKG,""))

               Begin DoDot:1

 +8                KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +9                SET DIC(0)="L"

 +10               SET DIC="^INRHNS("

 +11               SET X=INPKG

 +12               DO FILE^DICN

 +13               KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +14               SET INNS=+Y

 +15               KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +16               SET DA(1)=INNS

 +17               SET DIC(0)="L"

 +18               SET DIC="^INRHNS("_DA(1)_",1,"

 +19               SET X=INST

 +20               SET DIC("P")=$PIECE(^DD(4007,1,0),U,2)

 +21               DO FILE^DICN

 +22               KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

               End DoDot:1

 +23       SET INNS=$ORDER(^INRHNS("B",INPKG,""))

 +24       SET INSTOK=$$STCK(INNS,INST)

 +25       SET INMPRE="^INXPORT(INMT,INST,INPKG)"

 +26       QUIT 

 +27      ;-----

MSG       ;-- Import the fields from the INXPORT global

 +1        DO ADDTT

 +2        DO ADDD

 +3        DO ADDBP

 +4        SET INMDA=0

 +5        FOR 

               SET INMDA=$ORDER(@INMPRE@(INMDA))

               IF 'INMDA

                   QUIT 

               Begin DoDot:1

 +6                DO FD(INMDA,0)

 +7                DO FD(INMDA,1)

 +8                DO SD(INMDA)

 +9                SET INOUT=$SELECT($GET(@INMPRE@(INMDA,"INOUT"))="IN":1,1:0)

 +10               DO MD(INMDA)

               End DoDot:1

 +11       QUIT 

 +12      ;-----

FD(MDA,PASS) ;-- parse the fields out of the message and check exist

 +1       ;add all fields first then go back and add sub fields if necessary

 +2        SET INFDA=0

           FOR 

               SET INFDA=$ORDER(@INMPRE@(MDA,"FD",INFDA))

               IF 'INFDA

                   QUIT 

               Begin DoDot:1

 +3                SET INFDEF=$GET(@INMPRE@(MDA,"FD",INFDA))

 +4                SET INF01=$PIECE(INFDEF,U)

 +5                SET INF02=$PIECE(INFDEF,U,2)

 +6                SET INF03=$PIECE(INFDEF,U,3)

 +7                SET INF3=$PIECE(INFDEF,U,4)

 +8                SET INF5=$GET(@INMPRE@(MDA,"FD",INFDA,"OUT"))

 +9                SET INY=+$$CHKF(INF01,INF02,INF03,INF3,INF5)

 +10               IF 'INY!'$DATA(@INMPRE@(MDA,"FD",INFDA,"SUB"))!'PASS

                       QUIT 

 +11               SET INFS=0

 +12               FOR 

                       SET INFS=$ORDER(@INMPRE@(MDA,"FD",INFDA,"SUB",INFS))

                       IF 'INFS

                           QUIT 

                       Begin DoDot:2

 +13                       SET INFSD=$GET(@INMPRE@(MDA,"FD",INFDA,"SUB",INFS))

 +14                       SET INFS01=$PIECE(INFSD,U)

 +15                       SET INFS02=$PIECE(INFSD,U,2)

 +16                       SET INFSB=$$FSUB(INY,INFS01,INFS02)

                       End DoDot:2

               End DoDot:1

 +17       IF PASS

               KILL @INMPRE@(MDA,"FD")

 +18       QUIT 

 +19      ;-----

SD(MDA)   ;-- lets setup the segments

 +1        SET INSDA=0

           FOR 

               SET INSDA=$ORDER(@INMPRE@(MDA,"SD",INSDA))

               IF 'INSDA

                   QUIT 

               Begin DoDot:1

 +2                SET INSGDT=$GET(@INMPRE@(MDA,"SD",INSDA))

 +3                SET INS01=$PIECE(INSGDT,U)

 +4                SET INS02=$PIECE(INSGDT,U,2)

 +5                SET INY=$$CHKS(INS01,INS02)

 +6                IF 'INY

                       QUIT 

 +7                SET INSFDA=0

                   FOR 

                       SET INSFDA=$ORDER(@INMPRE@(MDA,"SD",INSDA,"FD",INSFDA))