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))
IF 'INSFDA
QUIT
Begin DoDot:2
+8 SET INSFDT=$GET(@INMPRE@(MDA,"SD",INSDA,"FD",INSFDA))
+9 SET INSF01=$PIECE(INSFDT,U)
+10 SET INSFIEN=$ORDER(^INTHL7F("B",INSF01,0))
+11 IF 'INSFIEN
QUIT
+12 SET INSF02=$PIECE(INSFDT,U,2)
+13 SET INSF03=$PIECE(INSFDT,U,3)
+14 SET INSFLD=$$SEGF(INY,INSFIEN,INSF01,INSF02,INSF03)
End DoDot:2
End DoDot:1
+15 KILL @INMPRE@(MDA,"SD")
+16 QUIT
+17 ;-----
MD(MDA) ;-- setup the message
+1 SET INMDT=$GET(@INMPRE@(MDA,"MD"))
+2 SET INM01=$PIECE($PIECE(INMDT,";"),"///",2)
+3 IF '$LENGTH(INM01)
QUIT
+4 SET INLKST=$GET(@INMPRE@(MDA,"MD","ROU"))
+5 SET INY=$$CHKM(INM01,$PIECE(INMDT,";",2,99)_INLKST)
+6 DO CHARUP^BHLU(INY)
+7 SET INMTT=0
FOR
SET INMTT=$ORDER(@INMPRE@(MDA,"MD","TT",INMTT))
IF 'INMTT
QUIT
Begin DoDot:1
+8 SET INMTTE=$GET(@INMPRE@(MDA,"MD","TT",INMTT))
+9 SET INTCHK=$$CHKMT(INY,INMTTE)
End DoDot:1
+10 KILL @INMPRE@(MDA,"MD","TT")
+11 SET INMOM=0
FOR
SET INMOM=$ORDER(@INMPRE@(MDA,"MD","OIMC",INMOM))
IF 'INMOM
QUIT
Begin DoDot:1
+12 SET INOME=$GET(@INMPRE@(MDA,"MD","OIMC",INMOM))
+13 SET INOCHK=$$CHKOM(INY,INOME)
End DoDot:1
+14 KILL @INMPRE@(MDA,"MD","OIMC")
+15 SET INMDS=0
FOR
SET INMDS=$ORDER(@INMPRE@(MDA,"MD","DESC",INMDS))
IF 'INMDS
QUIT
Begin DoDot:1
+16 SET INDESC=$GET(@INMPRE@(MDA,"MD","DESC",INMDS))
+17 SET INMADS=$$CHKDS(INY,INDESC)
End DoDot:1
+18 KILL @INMPRE@(MDA,"MD","DESC")
+19 SET INMSG=0
FOR
SET INMSG=$ORDER(@INMPRE@(MDA,"MD","SEG",INMSG))
IF 'INMSG
QUIT
Begin DoDot:1
+20 SET INMSGD=$GET(@INMPRE@(MDA,"MD","SEG",INMSG))
+21 SET INMSGN=$PIECE(INMSGD,U)
+22 SET INMSGS=$PIECE(INMSGD,U,2)
+23 SET INMSGR=$PIECE(INMSGD,U,3)
+24 SET INMSGOF=$PIECE(INMSGD,U,4)
+25 SET INMSGFL=$PIECE(INMSGD,U,5)
+26 SET INMSGP=$PIECE(INMSGD,U,6)
+27 SET INMSGM=$PIECE(INMSGD,U,7)
+28 SET INMSGPS=$PIECE(INMSGD,U,8)
+29 SET INMSGU=$PIECE(INMSGD,U,9)
+30 SET INMSY=$$CHKMS(INY,INMSGN,INMSGS,INMSGR,INMSGOF,INMSGFL,INMSGP,INMSGM,INMSGPS,INMSGU)
+31 IF $GET(@INMPRE@(MDA,"MD","SEG",INMSG,"SCR"))]""
Begin DoDot:2
+32 SET ^INTHL7M(INY,1,INMSY,4)=@INMPRE@(MDA,"MD","SEG",INMSG,"SCR")
End DoDot:2
+33 ;remove existing seg m code
KILL ^INTLH7M(INY,1,INMSY,5)
+34 SET INMSGO=0
FOR
SET INMSGO=$ORDER(@INMPRE@(MDA,"MD","SEG",INMSG,"OMC",INMSGO))
IF 'INMSGO
QUIT
Begin DoDot:2
+35 SET INMSGOD=$GET(@INMPRE@(MDA,"MD","SEG",INMSG,"OMC",INMSGO))
+36 SET INMSGOMC=$$CHKSOM(INY,INMSY,INMSGOD)
End DoDot:2
End DoDot:1
+37 KILL @INMPRE@(MDA,"MD")
+38 DO COMPILE^BHLU(INY)
+39 QUIT
+40 ;-----
STCK(NS,ST) ;-- check to see if the site already exists if not add it
+1 SET INNDA=0
FOR
SET INNDA=$ORDER(^INRHNS(NS,1,INNDA))
IF 'INNDA!($GET(INIEN))
QUIT
Begin DoDot:1
+2 IF $GET(^INRHNS(NS,1,INNDA,0))=ST
SET INIEN=INNDA
QUIT
End DoDot:1
+3 IF '$GET(INIEN)
QUIT $$ADD(NS,ST)
+4 QUIT INIEN
+5 ;-----
ADD(NMS,SIT) ;-- add the site to the namespace file
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 ;PATCH 7 ENSURE DA(1) SET TO AVOID <UNDEF>
+3 SET DA(1)=NMS
+4 SET DIC="^INRHNS("_NMS_",1,"
+5 IF '$DATA(^INRHNS(NMS,1,0))
SET $PIECE(^INRHNS(NMS,1,0),U,2)=4007.01
+6 SET DIC(0)="L"
+7 SET DIC("P")=$PIECE(^DD(4007,1,0),U,2)
+8 SET X=SIT
+9 DO FILE^DICN
+10 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+11 QUIT +Y
+12 ;-----
CHKF(F01,F02,F03,F3,F5) ;-- check for field add/update
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 IF $ORDER(^INTHL7F("B",F01,0))
QUIT $$UPDF(F01,F02,F03,F3,F5)
+3 SET DIC="^INTHL7F("
+4 SET DIC(0)="L"
+5 SET X=F01
+6 SET DIC("DR")=".02///"_F02_";.03///"_F03_";3///"_F3_";5///"_F5
+7 DO FILE^DICN
+8 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+9 SET FLDI=+Y
+10 QUIT FLDI
+11 ;-----
CHKS(S01,S02) ;-- check for seg existence add/update
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET SGIEN=$ORDER(^INTHL7S("B",S01,0))
+3 ;THL
IF SGIEN
IF S01["IZV04"
IF $GET(CLEAN)
Begin DoDot:1
+4 SET DA(1)=SGIEN
+5 SET DIK="^INTHL7S("_DA(1)_",1,"
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^INTHL7S(DA(1),1,DA))
IF 'DA
QUIT
DO ^DIK
End DoDot:1
QUIT SGIEN
+8 SET DIC="^INTHL7S("
+9 SET DIC(0)="L"
+10 SET X=S01
+11 SET DIC("DR")=".02///"_S02
+12 DO FILE^DICN
+13 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+14 QUIT +Y
+15 ;-----
CHKM(M01,MDT) ;-- check for message process add/update
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET MIEN=$ORDER(^INTHL7M("B",M01,0))
+3 ;THL
IF MIEN
IF M01["IZV04"
Begin DoDot:1
+4 IF $GET(CLEAN)&$ORDER(^INTHL7M(MIEN,1,0))
Begin DoDot:2
+5 SET DA(1)=MIEN
+6 SET DIK="^INTHL7M("_DA(1)_",1,"
+7 SET DA=0
+8 FOR
SET DA=$ORDER(^INTHL7M(DA(1),1,DA))
IF 'DA
QUIT
DO ^DIK
End DoDot:2
+9 SET DIE="^INTHL7M("
+10 SET DA=MIEN
+11 SET DR=MDT
+12 DO DIE
+13 SET ^INTHL7M(MIEN,"FS")="|"
SET ^("EC")="^~\&"
End DoDot:1
QUIT MIEN
+14 QUIT $$MADD(M01,MDT)
+15 ;-----
CHKMS(MS01,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU) ;-- check for msg segment mult
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET SGIEN=$ORDER(^INTHL7S("B",GN,0))
+3 SET MSGIEN=$ORDER(^INTHL7M("SEG",SGIEN,MS01,0))
+4 IF MSGIEN
Begin DoDot:1
+5 SET DIK="^INTHL7M("_MS01_",1,"
+6 SET DA(1)=MS01
+7 SET DA=MSGIEN
+8 KILL ^INTHL7M(MS01,1,MSGIEN,1)
+9 DO ^DIK
+10 QUIT
+11 SET DIE="^INTHL7M("_MS01_",1,"_MSGIEN_","
+12 SET DA(1)=MS01
+13 SET DA=MSGIEN
+14 SET DR=".02///"_GS_";.03///"_GR_";.04///"_GOF_";.05///"_GFL
+15 SET DR=DR_";.07///"_GP_";.08///"_GM_";.11///"_GPS_";.12///"_GU
+16 SET DIC("P")=$PIECE(^DD(4011,1,0),U,2)
+17 DO DIE
End DoDot:1
+18 QUIT $$MSADD(MS01,SGIEN,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU)
+19 ;-----
MSADD(MSGI,MSGN,AGN,AGS,AGR,AGOF,AGFL,AGP,AGM,AGPS,AGU) ;-- add segment
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET DIC="^INTHL7M("_MSGI_",1,"
+3 SET DIC(0)="L"
+4 SET DA(1)=MSGI
+5 SET X=MSGN
+6 SET DIC("DR")=".02///"_AGS_";.03///"_AGR_";.04///"_AGOF_";.05///"_AGFL
+7 SET DIC("DR")=DIC("DR")_";.07///"_AGP_";.08///"_AGM_";.11///"_AGPS
+8 SET DIC("DR")=DIC("DR")_";.12///"_AGU
+9 SET DIC("P")=$PIECE(^DD(4011,1,0),U,2)
+10 DO FILE^DICN
+11 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+12 QUIT +Y
+13 ;-----
UPDF(FL01,FL02,FL03,FL3,FL5) ;-- update an existing field
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET INFIEN=$ORDER(^INTHL7F("B",FL01,0))
+3 ;THL
IF $GET(CLEAN)
IF FL01["IZV04"
IF $ORDER(^INTHL7F(INFIEN,10,0))
Begin DoDot:1
+4 SET DA(1)=INFIEN
+5 SET DIK="^INTHL7F("_DA(1)_",10,"
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^INTHL7F(DA(1),10,DA))
IF 'DA
QUIT
DO ^DIK
End DoDot:1
+8 SET DA=INFIEN
+9 SET DIE="^INTHL7F("
+10 SET DR=".02///"_FL02_";.03///"_FL03_";3///"_FL3_";5///"_FL5
+11 DO DIE
+12 QUIT INFIEN
+13 ;-----
FSUB(FDA,FS01,FS02) ;-- check the subfields also
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET INFSIEN=$ORDER(^INTHL7F("B",FS01,0))
+3 IF INFSIEN=""
QUIT
+4 IF '$DATA(^INTHL7F(FDA,10))
QUIT $$FSUBADD(FDA,INFSIEN,FS02)
+5 KILL INMTCH
+6 SET INFSX=$ORDER(^INTHL7F(FDA,10,"B",INFSIEN,0))
+7 IF $GET(INFSX)
Begin DoDot:1
+8 IF $PIECE($GET(^INTHL7F(FDA,10,INFSX,0)),U,2)=FS02
QUIT
+9 SET DIE="^INTHL7F("_FDA_",10,"_INFSX_","
+10 SET DIC("P")=$PIECE(^DD(4012,10,0),U,2)
+11 SET DA(1)=FDA
+12 SET DA=INFSX
+13 SET DR=".02///"_FS02
+14 DO DIE
+15 KILL DIE
End DoDot:1
QUIT INFSX
+16 SET INFSIEN=$ORDER(^INTHL7F("B",FS01,0))
+17 SET FSIEN=$$FSUBADD(FDA,INFSIEN,FS02)
+18 QUIT FSIEN
+19 ;-----
FSUBADD(FIEN,FSL01,FSL02) ;-- add the subfile
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET DA(1)=FIEN
+3 SET DIC="^INTHL7F("_DA(1)_",10,"
+4 SET X=FSL01
+5 SET DIC(0)="L"
+6 SET DIC("P")=$PIECE(^DD(4012,10,0),U,2)
+7 SET DIC("DR")=".02///"_FSL02
+8 DO FILE^DICN
+9 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+10 QUIT +Y
+11 ;-----
SEGF(SIEN,SFIEN,SF01,SF02,SF03) ;-- check for fld exist add/upd
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 IF '$DATA(^INTHL7S(SIEN,1))
QUIT $$SFADD(SIEN,SFIEN,SF02,SF03)
+3 SET SFLIEN=$ORDER(^INTHL7S(SIEN,1,"B",SFIEN,0))
+4 IF 'SFLIEN
QUIT $$SFADD(SIEN,SFIEN,SF02,SF03)
+5 IF $PIECE($GET(^INTHL7S(SIEN,1,SFLIEN,0)),U,2)=SF02
QUIT SFLIEN
+6 SET DA(1)=SIEN
+7 SET DA=SFLIEN
+8 SET DIE="^INTHL7S("_SIEN_",1,"_SFLIEN_","
+9 SET DR=".02///"_SF02_";.03///"_SF03
+10 DO DIE
+11 QUIT SFLIEN
+12 ;-----
SFADD(SN,S01,S02,S03) ;-- add the field to the segment
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET DIC="^INTHL7S("_SN_",1,"
SET DIC(0)="L"
+3 SET DA(1)=SN
+4 SET X=S01
+5 SET DIC("P")=$PIECE(^DD(4010,1,0),U,2)
+6 SET DIC("DR")=".02///"_S02_";.03///"_S03
+7 DO FILE^DICN
+8 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+9 QUIT +Y
+10 ;-----
MADD(MA01,MADT) ;-- add the message
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET DIC="^INTHL7M("
+3 SET DIC(0)="L"
+4 SET X=MA01
+5 SET DIC("DR")=MADT
+6 DO FILE^DICN
+7 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+8 SET ^INTHL7M(+Y,"FS")="|"
SET ^("EC")="^~\&"
+9 QUIT +Y
+10 ;-----
CHKOM(MSG,OMC) ;-- replace outgoing mumps code
+1 ;kill off existing outgoing m code
KILL ^INTHL7M(INY,6)
+2 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+3 SET DIC="^INTHL7M("_MSG_",6,"
+4 SET DIC(0)="L"
+5 SET DA(1)=MSG
+6 SET X=OMC
+7 SET DIC("P")=$PIECE(^DD(4011,6,0),U,2)
+8 DO FILE^DICN
+9 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+10 QUIT +Y
+11 ;-----
CHKDS(MSG,DSC) ;-- replace description
+1 ;kill of existing description
KILL ^INTHL7M(INY,3)
+2 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+3 SET DIC="^INTHL7M("_MSG_",3,"
+4 SET DIC(0)="L"
+5 SET DA(1)=MSG
+6 SET X=DSC
+7 SET DIC("P")=$PIECE(^DD(4011,3,0),U,2)
+8 DO FILE^DICN
+9 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+10 QUIT +Y
+11 ;-----
CHKMT(MSG,MTT) ;-- add tt to msg
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET MTIEN=$ORDER(^INRHT("B",MTT,0))
+3 IF 'MTIEN
QUIT 0
+4 IF '$ORDER(^INTHL7M(MSG,2,"B",MTIEN,0))
QUIT $$ADDT(MSG,MTIEN)
+5 QUIT $ORDER(^INTHL7M(MSG,2,"B",MTIEN,0))
+6 ;-----
ADDT(MSG,TT) ;-- add the transaction to the message
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET DIC="^INTHL7M("_MSG_",2,"
+3 SET DA(1)=MSG
+4 SET DIC(0)="L"
+5 SET X=TT
+6 SET DIC("P")=$PIECE(^DD(4011,2,0),U,2)
+7 DO FILE^DICN
+8 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+9 QUIT +Y
+10 ;-----
CHKSOM(MS,MSEG,OMC) ;-- add m code to segment
+1 ;remove existing seg m code
KILL ^INTHL7M(MS,1,MSEG,1)
+2 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+3 SET DIC="^INTHL7M("_MS_",1,"_MSEG_",5,"
+4 SET DIC(0)="L"
+5 SET DA(1)=MS
+6 SET DA=MSEG
+7 SET DIC("P")=$PIECE(^DD(4011.01,5,0),U,2)
+8 SET X=OMC
+9 DO FILE^DICN
+10 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+11 QUIT +Y
+12 ;-----
ADD01 ;
+1 SET INADD01=""
+2 DO ADDTT
+3 DO ADDD
+4 DO ADDBP
+5 KILL INADD01
+6 QUIT
+7 ;-----
ADDD ;-- add all destinations in namespace first
+1 SET INADA=0
+2 FOR
SET INADA=$ORDER(@INMPRE@("DEST",INADA))
IF 'INADA
QUIT
Begin DoDot:1
+3 SET INADDT=$GET(@INMPRE@("DEST",INADA))
+4 SET INAD01=$PIECE($PIECE(INADDT,";"),"///",2)
+5 SET INAD02=$PIECE($PIECE(INADDT,";",2),"///",2)
+6 IF INAD02]""
SET INAD02=$ORDER(^INRHT("B",INAD02,0))
+7 SET INADDR=$PIECE(INADDT,";",2,99)
+8 IF INAD02
SET $PIECE(INADDR,";")=".02////"_INAD02
+9 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+10 SET INDIEN=$ORDER(^INRHD("B",INAD01,0))
+11 IF 'INDIEN
Begin DoDot:2
+12 SET DIC="^INRHD("
+13 SET DIC(0)="L"
+14 SET X=INAD01
+15 DO FILE^DICN
+16 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+17 SET INDIEN=+Y
End DoDot:2
IF INDIEN<0
QUIT
+18 IF $DATA(INADD01)
QUIT
+19 SET DA=INDIEN
+20 SET DIE="^INRHD("
+21 SET DR=INADDR
+22 DO DIE
+23 IF INAD02
IF '$PIECE(^INRHD(INDIEN,0),U,2)
SET $PIECE(^(0),U,2)=INAD02
End DoDot:1
+24 QUIT
+25 ;-----
ADDTT ;-- add all transactions in namespace first
+1 SET INADA=0
+2 FOR
SET INADA=$ORDER(@INMPRE@("TT",INADA))
IF 'INADA
QUIT
Begin DoDot:1
+3 SET INADDT=$GET(@INMPRE@("TT",INADA))
+4 SET INAD01=$PIECE($PIECE(INADDT,";"),"///",2)
+5 SET INADDR=$PIECE(INADDT,";",2,99)
+6 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+7 SET INDIEN=$ORDER(^INRHT("B",INAD01,0))
+8 IF 'INDIEN
Begin DoDot:2
+9 SET DIC="^INRHT("
+10 SET DIC(0)="L"
+11 SET X=INAD01
+12 DO FILE^DICN
+13 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+14 SET INDIEN=+Y
End DoDot:2
IF INDIEN<0
QUIT
+15 IF $DATA(INADD01)
QUIT
+16 SET DA=INDIEN
+17 SET DIE="^INRHT("
+18 SET DR=INADDR
+19 DO DIE
End DoDot:1
+20 QUIT
+21 ;-----
ADDBP ;-- add all transactions in namespace first
+1 SET INADA=0
+2 FOR
SET INADA=$ORDER(@INMPRE@("BP",INADA))
IF 'INADA
QUIT
Begin DoDot:1
+3 SET INADDT=$GET(@INMPRE@("BP",INADA))
+4 SET INAD01=$PIECE($PIECE(INADDT,";"),"///",2)
+5 SET INADDR=$PIECE(INADDT,";",2,99)
+6 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+7 SET INDIEN=$ORDER(^INTHPC("B",INAD01,0))
+8 IF 'INDIEN
Begin DoDot:2
+9 SET DIC="^INTHPC("
+10 SET DIC(0)="L"
+11 SET X=INAD01
+12 DO FILE^DICN
+13 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+14 SET INDIEN=+Y
End DoDot:2
IF INDIEN<0
QUIT
+15 IF $DATA(INADD01)
QUIT
+16 SET DIE="^INTHPC("
+17 SET DA=INDIEN
+18 SET DR=INADDR
+19 DO DIE
End DoDot:1
+20 QUIT
+21 ;-----
EOJ ;-- kill variables and quit
+1 KILL 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
+2 KILL 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
+3 KILL INTCHK,INY,KFM,MIEN,MSGIEN,MTIEN,SFLIEN,SGIEN,X,Y,INMSGOMC,CLEAN
+4 DO EN^XBVK("IN")
+5 QUIT
+6 ;-----
DIE KILL Y
+1 DO ^DIE
+2 KILL DA,DR,DIE,DIC,DINUM,Y
+3 QUIT
+4 ;-----
