INMPORT ; cmi/flag/maw - IN Import GIS Package ;
;;3.01;BHL IHS Interfaces with GIS;**2,11,14,15**;OCT 15, 2002
;
;
;
;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 ;PEP - this is the main routine driver
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 DD,DO
. S DIC(0)="L",DIC="^INRHNS(",X=INPKG
. D FILE^DICN
. S INNS=+Y
. S DA(1)=INNS
. K DIC,DD,DO
. S DIC(0)="L"
. S DIC="^INRHNS("_DA(1)_",1,",X=INST,DIC("P")=$P(^DD(4007,1,0),U,2)
. D FILE^DICN
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)
. D SD(INMDA)
. S INOUT=$S($G(@INMPRE@(INMDA,"INOUT"))="IN":1,1:0)
. D MD(INMDA)
Q
;
FD(MDA) ;-- 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
. I $D(@INMPRE@(MDA,"FD",INFDA,"SUB")) D
.. 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 @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)
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 INMCL=0 F S INMCL=$O(@INMPRE@(MDA,"MD","MCFL",INMCL)) Q:'INMCL D
. S INMCLE=$G(@INMPRE@(MDA,"MD","MCFL",INMCL))
. S INMCCHK=$$CHKMC(INY,INMCLE)
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)
. 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
X KFM
S DIC="^INRHNS("_NMS_",1,",DIC(0)="L"
S DIC("P")=$P(^DD(4007,1,0),U,2),X=SIT
D FILE^DICN
K DIC
Q +Y
;
CHKF(F01,F02,F03,F3,F5) ;-- check for field add/update
X KFM
I $O(^INTHL7F("B",F01,0)) Q $$UPDF(F01,F02,F03,F3,F5)
S DIC="^INTHL7F(",DIC(0)="L",X=F01
S DIC("DR")=".02///"_F02_";.03///"_F03_";3///"_F3_";5///"_F5
D FILE^DICN
S FLDI=+Y
Q FLDI
;
CHKS(S01,S02) ;-- check for seg existence add/update
X KFM
I $O(^INTHL7S("B",S01,0)) Q $O(^INTHL7S("B",S01,0))
S DIC="^INTHL7S(",DIC(0)="L",X=S01
S DIC("DR")=".02///"_S02
D FILE^DICN
Q +Y
;
CHKM(M01,MDT) ;-- check for message process add/update
X KFM
I $O(^INTHL7M("B",M01,0)) D Q MIEN
. S MIEN=$O(^INTHL7M("B",M01,0))
. S DIE="^INTHL7M(",DA=MIEN,DR=MDT
. D DIE
Q $$MADD(M01,MDT)
;
CHKMS(MS01,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU) ;-- check for msg segment mult
X KFM
S SGIEN=$O(^INTHL7S("B",GN,0))
S MSGIEN=$O(^INTHL7M("SEG",SGIEN,MS01,0))
I MSGIEN D
. S DIK="^INTHL7M("_MS01_",1,",DA(1)=MS01,DA=MSGIEN
. K ^INTHL7M(MS01,1,MSGIEN,1)
. D ^DIK
. Q
. S DIE="^INTHL7M("_MS01_",1,"_MSGIEN_",",DA(1)=MS01,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
X KFM
S DIC="^INTHL7M("_MSGI_",1,",DIC(0)="L",DA(1)=MSGI,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
Q +Y
;
UPDF(FL01,FL02,FL03,FL3,FL5) ;-- update an existing field
X KFM
S INFIEN=$O(^INTHL7F("B",FL01,0))
S DIE="^INTHL7F(",DA=INFIEN
S DR=".02///"_FL02_";.03///"_FL03_";3///"_FL3_";5///"_FL5
D DIE
Q INFIEN
;
FSUB(FDA,FS01,FS02) ;-- check the subfields also
X KFM
S INFSIEN=$O(^INTHL7F("B",FS01,0))
I '$D(^INTHL7F(FDA,10)) Q $$FSUBADD(FDA,INFSIEN,FS02)
K INMTCH
S INFS=$O(^INTHL7F(FDA,10,"B",INFSIEN,0))
I $G(INFS) D Q INFS
. Q:$P($G(^INTHL7F(FDA,10,INFS,0)),U,2)=FS02
. S DIE="^INTHL7F("_FDA_",10,"_INFS_","
. S DIC("P")=$P(^DD(4012,10,0),U,2)
. S DA(1)=FDA,DA=INFS,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
X KFM
S DA(1)=FIEN,DIC="^INTHL7F("_DA(1)_",10,",X=FSL01
S DIC(0)="L",DIC("P")=$P(^DD(4012,10,0),U,2)
S DIC("DR")=".02///"_FSL02
D FILE^DICN
Q +Y
;
SEGF(SIEN,SFIEN,SF01,SF02,SF03) ;-- check for fld exist add/upd
X KFM
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)
S DIE="^INTHL7S("_SIEN_",1,"_SFLIEN_",",DA(1)=SIEN,DA=SFLIEN
I $P($G(^INTHL7S(SIEN,1,SFLIEN,0)),U,2)=SF02 Q SFLIEN
S DR=".02///"_SF02_";.03///"_SF03
D DIE
Q SFLIEN
;
SFADD(SN,S01,S02,S03) ;-- add the field to the segment
X KFM
S DIC="^INTHL7S("_SN_",1,",DIC(0)="L",DA(1)=SN,X=S01
S DIC("P")=$P(^DD(4010,1,0),U,2)
S DIC("DR")=".02///"_S02_";.03///"_S03
D FILE^DICN
Q +Y
;
MADD(MA01,MADT) ;-- add the message
X KFM
S DIC="^INTHL7M(",DIC(0)="L",X=MA01
S DIC("DR")=MADT
D FILE^DICN
Q +Y
;
CHKOM(MSG,OMC) ;-- replace outgoing mumps code
K ^INTHL7M(INY,6) ;kill off existing outgoing m code
X KFM
S DIC="^INTHL7M("_MSG_",6,",DIC(0)="L",DA(1)=MSG,X=OMC
S DIC("P")=$P(^DD(4011,6,0),U,2)
D FILE^DICN
Q +Y
;
CHKMC(MSG,MCL) ;-- replace mumps code for lookup
K ^INTHL7M(INY,4) ;kill off existing mumps code for lookup
X KFM
S DIC="^INTHL7M("_MSG_",4,",DIC(0)="L",DA(1)=MSG,X=MCL
S DIC("P")=$P(^DD(4011,4,0),U,2)
D FILE^DICN
Q +Y
;
CHKDS(MSG,DSC) ;-- replace description
K ^INTHL7M(INY,3) ;kill of existing description
X KFM
S DIC="^INTHL7M("_MSG_",3,",DIC(0)="L",DA(1)=MSG,X=DSC
S DIC("P")=$P(^DD(4011,3,0),U,2)
D FILE^DICN
Q +Y
;
CHKMT(MSG,MTT) ;-- add tt to msg
X KFM
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
X KFM
S DIC="^INTHL7M("_MSG_",2,",DA(1)=MSG,DIC(0)="L",X=TT
S DIC("P")=$P(^DD(4011,2,0),U,2)
D FILE^DICN
Q +Y
;
CHKSOM(MS,MSEG,OMC) ;-- add m code to segment
K ^INTHL7M(MS,1,MSEG,1) ;remove existing seg m code
X KFM
S DIC="^INTHL7M("_MS_",1,"_MSEG_",5,",DIC(0)="L",DA(1)=MS,DA=MSEG
S DIC("P")=$P(^DD(4011.01,5,0),U,2)
S X=OMC
D FILE^DICN
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
.X KFM
.S INDIEN=$O(^INRHD("B",INAD01,0))
.I 'INDIEN D Q:INDIEN<0
..S DIC="^INRHD(",DIC(0)="L",X=INAD01
..D FILE^DICN
..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)
.X KFM
.S INDIEN=$O(^INRHT("B",INAD01,0))
.I 'INDIEN D Q:INDIEN<0
..S DIC="^INRHT(",DIC(0)="L",X=INAD01
..D FILE^DICN
..S INDIEN=+Y
.Q:$D(INADD01)
.S DA=INDIEN
.N INTP5
.S INTP5=$P($G(^INRHT(INDIEN,0)),U,5)
.S DIE="^INRHT("
.S DR=INADDR
.D DIE
.I $G(INTP5)="A" D
.. S $P(^INRHT(INDIEN,0),U,5)="A"
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)
.X KFM
.S INDIEN=$O(^INTHPC("B",INAD01,0))
.I 'INDIEN D Q:INDIEN<0
..S DIC="^INTHPC(",DIC(0)="L",X=INAD01
..D FILE^DICN
..S INDIEN=+Y
.Q:$D(INADD01)
.S DIE="^INTHPC(",DA=INDIEN
.S DR=INADDR
.D DIE
Q
;
EOJ ;-- kill variables and quit
D EN^XBVK("IN")
Q
;
DIE K Y
D ^DIE
K DA,DR,DIE,DIC,DINUM,Y
Q
INMPORT ; cmi/flag/maw - IN Import GIS Package ;
+1 ;;3.01;BHL IHS Interfaces with GIS;**2,11,14,15**;OCT 15, 2002
+2 ;
+3 ;
+4 ;
+5 ;this routine will import a GIS package from the ^INXPORT global
+6 ;it will then populate the SCRIPT GENERATOR FIELD, SEGMENT, and
+7 ;MESSAGE files and also the INTERFACE TRANSACTION TYPE, DESTINATION,
+8 ;and BACKGROUND PROCESS files
+9 ;
MAIN ;PEP - this is the main routine driver
+1 IF $ORDER(^INXPORT(""))=""
Begin DoDot:1
+2 WRITE !,"Global ^INXPORT is missing, please restore and rerun"
End DoDot:1
QUIT
+3 SET KFM="K DIE,DR,DIC,DA,DD,DO,DIK"
+4 DO NS
+5 DO ADD01
+6 DO MSG
+7 DO EOJ
+8 QUIT
+9 ;
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 DD,DO
+9 SET DIC(0)="L"
SET DIC="^INRHNS("
SET X=INPKG
+10 DO FILE^DICN
+11 SET INNS=+Y
+12 SET DA(1)=INNS
+13 KILL DIC,DD,DO
+14 SET DIC(0)="L"
+15 SET DIC="^INRHNS("_DA(1)_",1,"
SET X=INST
SET DIC("P")=$PIECE(^DD(4007,1,0),U,2)
+16 DO FILE^DICN
End DoDot:1
+17 SET INNS=$ORDER(^INRHNS("B",INPKG,""))
+18 SET INSTOK=$$STCK(INNS,INST)
+19 SET INMPRE="^INXPORT(INMT,INST,INPKG)"
+20 QUIT
+21 ;
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)
+7 DO SD(INMDA)
+8 SET INOUT=$SELECT($GET(@INMPRE@(INMDA,"INOUT"))="IN":1,1:0)
+9 DO MD(INMDA)
End DoDot:1
+10 QUIT
+11 ;
FD(MDA) ;-- 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
QUIT
+11 IF $DATA(@INMPRE@(MDA,"FD",INFDA,"SUB"))
Begin DoDot:2
+12 SET INFS=0
FOR
SET INFS=$ORDER(@INMPRE@(MDA,"FD",INFDA,"SUB",INFS))
IF 'INFS
QUIT
Begin DoDot:3
+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:3
End DoDot:2
End DoDot:1
+17 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 SET INLKST=$GET(@INMPRE@(MDA,"MD","ROU"))
+4 SET INY=$$CHKM(INM01,$PIECE(INMDT,";",2,99)_INLKST)
+5 DO CHARUP^BHLU(INY)
+6 SET INMTT=0
FOR
SET INMTT=$ORDER(@INMPRE@(MDA,"MD","TT",INMTT))
IF 'INMTT
QUIT
Begin DoDot:1
+7 SET INMTTE=$GET(@INMPRE@(MDA,"MD","TT",INMTT))
+8 SET INTCHK=$$CHKMT(INY,INMTTE)
End DoDot:1
+9 KILL @INMPRE@(MDA,"MD","TT")
+10 SET INMOM=0
FOR
SET INMOM=$ORDER(@INMPRE@(MDA,"MD","OIMC",INMOM))
IF 'INMOM
QUIT
Begin DoDot:1
+11 SET INOME=$GET(@INMPRE@(MDA,"MD","OIMC",INMOM))
+12 SET INOCHK=$$CHKOM(INY,INOME)
End DoDot:1
+13 KILL @INMPRE@(MDA,"MD","OIMC")
+14 SET INMCL=0
FOR
SET INMCL=$ORDER(@INMPRE@(MDA,"MD","MCFL",INMCL))
IF 'INMCL
QUIT
Begin DoDot:1
+15 SET INMCLE=$GET(@INMPRE@(MDA,"MD","MCFL",INMCL))
+16 SET INMCCHK=$$CHKMC(INY,INMCLE)
End DoDot:1
+17 KILL @INMPRE@(MDA,"MD","OIMC")
+18 SET INMDS=0
FOR
SET INMDS=$ORDER(@INMPRE@(MDA,"MD","DESC",INMDS))
IF 'INMDS
QUIT
Begin DoDot:1
+19 SET INDESC=$GET(@INMPRE@(MDA,"MD","DESC",INMDS))
+20 SET INMADS=$$CHKDS(INY,INDESC)
End DoDot:1
+21 KILL @INMPRE@(MDA,"MD","DESC")
+22 SET INMSG=0
FOR
SET INMSG=$ORDER(@INMPRE@(MDA,"MD","SEG",INMSG))
IF 'INMSG
QUIT
Begin DoDot:1
+23 SET INMSGD=$GET(@INMPRE@(MDA,"MD","SEG",INMSG))
+24 SET INMSGN=$PIECE(INMSGD,U)
+25 SET INMSGS=$PIECE(INMSGD,U,2)
+26 SET INMSGR=$PIECE(INMSGD,U,3)
+27 SET INMSGOF=$PIECE(INMSGD,U,4)
+28 SET INMSGFL=$PIECE(INMSGD,U,5)
+29 SET INMSGP=$PIECE(INMSGD,U,6)
+30 SET INMSGM=$PIECE(INMSGD,U,7)
+31 SET INMSGPS=$PIECE(INMSGD,U,8)
+32 SET INMSGU=$PIECE(INMSGD,U,9)
+33 SET INMSY=$$CHKMS(INY,INMSGN,INMSGS,INMSGR,INMSGOF,INMSGFL,INMSGP,INMSGM,INMSGPS,INMSGU)
+34 ;remove existing seg m code
KILL ^INTLH7M(INY,1,INMSY,5)
+35 SET INMSGO=0
FOR
SET INMSGO=$ORDER(@INMPRE@(MDA,"MD","SEG",INMSG,"OMC",INMSGO))
IF 'INMSGO
QUIT
Begin DoDot:2
+36 SET INMSGOD=$GET(@INMPRE@(MDA,"MD","SEG",INMSG,"OMC",INMSGO))
+37 SET INMSGOMC=$$CHKSOM(INY,INMSY,INMSGOD)
End DoDot:2
End DoDot:1
+38 KILL @INMPRE@(MDA,"MD")
+39 DO COMPILE^BHLU(INY)
+40 QUIT
+41 ;
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 XECUTE KFM
+2 SET DIC="^INRHNS("_NMS_",1,"
SET DIC(0)="L"
+3 SET DIC("P")=$PIECE(^DD(4007,1,0),U,2)
SET X=SIT
+4 DO FILE^DICN
+5 KILL DIC
+6 QUIT +Y
+7 ;
CHKF(F01,F02,F03,F3,F5) ;-- check for field add/update
+1 XECUTE KFM
+2 IF $ORDER(^INTHL7F("B",F01,0))
QUIT $$UPDF(F01,F02,F03,F3,F5)
+3 SET DIC="^INTHL7F("
SET DIC(0)="L"
SET X=F01
+4 SET DIC("DR")=".02///"_F02_";.03///"_F03_";3///"_F3_";5///"_F5
+5 DO FILE^DICN
+6 SET FLDI=+Y
+7 QUIT FLDI
+8 ;
CHKS(S01,S02) ;-- check for seg existence add/update
+1 XECUTE KFM
+2 IF $ORDER(^INTHL7S("B",S01,0))
QUIT $ORDER(^INTHL7S("B",S01,0))
+3 SET DIC="^INTHL7S("
SET DIC(0)="L"
SET X=S01
+4 SET DIC("DR")=".02///"_S02
+5 DO FILE^DICN
+6 QUIT +Y
+7 ;
CHKM(M01,MDT) ;-- check for message process add/update
+1 XECUTE KFM
+2 IF $ORDER(^INTHL7M("B",M01,0))
Begin DoDot:1
+3 SET MIEN=$ORDER(^INTHL7M("B",M01,0))
+4 SET DIE="^INTHL7M("
SET DA=MIEN
SET DR=MDT
+5 DO DIE
End DoDot:1
QUIT MIEN
+6 QUIT $$MADD(M01,MDT)
+7 ;
CHKMS(MS01,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU) ;-- check for msg segment mult
+1 XECUTE KFM
+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,"
SET DA(1)=MS01
SET DA=MSGIEN
+6 KILL ^INTHL7M(MS01,1,MSGIEN,1)
+7 DO ^DIK
+8 QUIT
+9 SET DIE="^INTHL7M("_MS01_",1,"_MSGIEN_","
SET DA(1)=MS01
SET DA=MSGIEN
+10 SET DR=".02///"_GS_";.03///"_GR_";.04///"_GOF_";.05///"_GFL
+11 SET DR=DR_";.07///"_GP_";.08///"_GM_";.11///"_GPS_";.12///"_GU
+12 SET DIC("P")=$PIECE(^DD(4011,1,0),U,2)
+13 DO DIE
End DoDot:1
+14 QUIT $$MSADD(MS01,SGIEN,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU)
+15 ;
MSADD(MSGI,MSGN,AGN,AGS,AGR,AGOF,AGFL,AGP,AGM,AGPS,AGU) ;-- add segment
+1 XECUTE KFM
+2 SET DIC="^INTHL7M("_MSGI_",1,"
SET DIC(0)="L"
SET DA(1)=MSGI
SET X=MSGN
+3 SET DIC("DR")=".02///"_AGS_";.03///"_AGR_";.04///"_AGOF_";.05///"_AGFL
+4 SET DIC("DR")=DIC("DR")_";.07///"_AGP_";.08///"_AGM_";.11///"_AGPS
+5 SET DIC("DR")=DIC("DR")_";.12///"_AGU
+6 SET DIC("P")=$PIECE(^DD(4011,1,0),U,2)
+7 DO FILE^DICN
+8 QUIT +Y
+9 ;
UPDF(FL01,FL02,FL03,FL3,FL5) ;-- update an existing field
+1 XECUTE KFM
+2 SET INFIEN=$ORDER(^INTHL7F("B",FL01,0))
+3 SET DIE="^INTHL7F("
SET DA=INFIEN
+4 SET DR=".02///"_FL02_";.03///"_FL03_";3///"_FL3_";5///"_FL5
+5 DO DIE
+6 QUIT INFIEN
+7 ;
FSUB(FDA,FS01,FS02) ;-- check the subfields also
+1 XECUTE KFM
+2 SET INFSIEN=$ORDER(^INTHL7F("B",FS01,0))
+3 IF '$DATA(^INTHL7F(FDA,10))
QUIT $$FSUBADD(FDA,INFSIEN,FS02)
+4 KILL INMTCH
+5 SET INFS=$ORDER(^INTHL7F(FDA,10,"B",INFSIEN,0))
+6 IF $GET(INFS)
Begin DoDot:1
+7 IF $PIECE($GET(^INTHL7F(FDA,10,INFS,0)),U,2)=FS02
QUIT
+8 SET DIE="^INTHL7F("_FDA_",10,"_INFS_","
+9 SET DIC("P")=$PIECE(^DD(4012,10,0),U,2)
+10 SET DA(1)=FDA
SET DA=INFS
SET DR=".02///"_FS02
+11 DO DIE
+12 KILL DIE
End DoDot:1
QUIT INFS
+13 SET INFSIEN=$ORDER(^INTHL7F("B",FS01,0))
+14 SET FSIEN=$$FSUBADD(FDA,INFSIEN,FS02)
+15 QUIT FSIEN
+16 ;
FSUBADD(FIEN,FSL01,FSL02) ;-- add the subfile
+1 XECUTE KFM
+2 SET DA(1)=FIEN
SET DIC="^INTHL7F("_DA(1)_",10,"
SET X=FSL01
+3 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(4012,10,0),U,2)
+4 SET DIC("DR")=".02///"_FSL02
+5 DO FILE^DICN
+6 QUIT +Y
+7 ;
SEGF(SIEN,SFIEN,SF01,SF02,SF03) ;-- check for fld exist add/upd
+1 XECUTE KFM
+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 SET DIE="^INTHL7S("_SIEN_",1,"_SFLIEN_","
SET DA(1)=SIEN
SET DA=SFLIEN
+6 IF $PIECE($GET(^INTHL7S(SIEN,1,SFLIEN,0)),U,2)=SF02
QUIT SFLIEN
+7 SET DR=".02///"_SF02_";.03///"_SF03
+8 DO DIE
+9 QUIT SFLIEN
+10 ;
SFADD(SN,S01,S02,S03) ;-- add the field to the segment
+1 XECUTE KFM
+2 SET DIC="^INTHL7S("_SN_",1,"
SET DIC(0)="L"
SET DA(1)=SN
SET X=S01
+3 SET DIC("P")=$PIECE(^DD(4010,1,0),U,2)
+4 SET DIC("DR")=".02///"_S02_";.03///"_S03
+5 DO FILE^DICN
+6 QUIT +Y
+7 ;
MADD(MA01,MADT) ;-- add the message
+1 XECUTE KFM
+2 SET DIC="^INTHL7M("
SET DIC(0)="L"
SET X=MA01
+3 SET DIC("DR")=MADT
+4 DO FILE^DICN
+5 QUIT +Y
+6 ;
CHKOM(MSG,OMC) ;-- replace outgoing mumps code
+1 ;kill off existing outgoing m code
KILL ^INTHL7M(INY,6)
+2 XECUTE KFM
+3 SET DIC="^INTHL7M("_MSG_",6,"
SET DIC(0)="L"
SET DA(1)=MSG
SET X=OMC
+4 SET DIC("P")=$PIECE(^DD(4011,6,0),U,2)
+5 DO FILE^DICN
+6 QUIT +Y
+7 ;
CHKMC(MSG,MCL) ;-- replace mumps code for lookup
+1 ;kill off existing mumps code for lookup
KILL ^INTHL7M(INY,4)
+2 XECUTE KFM
+3 SET DIC="^INTHL7M("_MSG_",4,"
SET DIC(0)="L"
SET DA(1)=MSG
SET X=MCL
+4 SET DIC("P")=$PIECE(^DD(4011,4,0),U,2)
+5 DO FILE^DICN
+6 QUIT +Y
+7 ;
CHKDS(MSG,DSC) ;-- replace description
+1 ;kill of existing description
KILL ^INTHL7M(INY,3)
+2 XECUTE KFM
+3 SET DIC="^INTHL7M("_MSG_",3,"
SET DIC(0)="L"
SET DA(1)=MSG
SET X=DSC
+4 SET DIC("P")=$PIECE(^DD(4011,3,0),U,2)
+5 DO FILE^DICN
+6 QUIT +Y
+7 ;
CHKMT(MSG,MTT) ;-- add tt to msg
+1 XECUTE KFM
+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 XECUTE KFM
+2 SET DIC="^INTHL7M("_MSG_",2,"
SET DA(1)=MSG
SET DIC(0)="L"
SET X=TT
+3 SET DIC("P")=$PIECE(^DD(4011,2,0),U,2)
+4 DO FILE^DICN
+5 QUIT +Y
+6 ;
CHKSOM(MS,MSEG,OMC) ;-- add m code to segment
+1 ;remove existing seg m code
KILL ^INTHL7M(MS,1,MSEG,1)
+2 XECUTE KFM
+3 SET DIC="^INTHL7M("_MS_",1,"_MSEG_",5,"
SET DIC(0)="L"
SET DA(1)=MS
SET DA=MSEG
+4 SET DIC("P")=$PIECE(^DD(4011.01,5,0),U,2)
+5 SET X=OMC
+6 DO FILE^DICN
+7 QUIT +Y
+8 ;
ADD01 ;
+1 SET INADD01=""
+2 DO ADDTT
+3 DO ADDD
+4 DO ADDBP
+5 KILL INADD01
+6 QUIT
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 XECUTE KFM
+10 SET INDIEN=$ORDER(^INRHD("B",INAD01,0))
+11 IF 'INDIEN
Begin DoDot:2
+12 SET DIC="^INRHD("
SET DIC(0)="L"
SET X=INAD01
+13 DO FILE^DICN
+14 SET INDIEN=+Y
End DoDot:2
IF INDIEN<0
QUIT
+15 IF $DATA(INADD01)
QUIT
+16 SET DA=INDIEN
+17 SET DIE="^INRHD("
+18 SET DR=INADDR
+19 DO DIE
+20 IF INAD02
IF '$PIECE(^INRHD(INDIEN,0),U,2)
SET $PIECE(^(0),U,2)=INAD02
End DoDot:1
+21 QUIT
+22 ;
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 XECUTE KFM
+7 SET INDIEN=$ORDER(^INRHT("B",INAD01,0))
+8 IF 'INDIEN
Begin DoDot:2
+9 SET DIC="^INRHT("
SET DIC(0)="L"
SET X=INAD01
+10 DO FILE^DICN
+11 SET INDIEN=+Y
End DoDot:2
IF INDIEN<0
QUIT
+12 IF $DATA(INADD01)
QUIT
+13 SET DA=INDIEN
+14 NEW INTP5
+15 SET INTP5=$PIECE($GET(^INRHT(INDIEN,0)),U,5)
+16 SET DIE="^INRHT("
+17 SET DR=INADDR
+18 DO DIE
+19 IF $GET(INTP5)="A"
Begin DoDot:2
+20 SET $PIECE(^INRHT(INDIEN,0),U,5)="A"
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
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 XECUTE KFM
+7 SET INDIEN=$ORDER(^INTHPC("B",INAD01,0))
+8 IF 'INDIEN
Begin DoDot:2
+9 SET DIC="^INTHPC("
SET DIC(0)="L"
SET X=INAD01
+10 DO FILE^DICN
+11 SET INDIEN=+Y
End DoDot:2
IF INDIEN<0
QUIT
+12 IF $DATA(INADD01)
QUIT
+13 SET DIE="^INTHPC("
SET DA=INDIEN
+14 SET DR=INADDR
+15 DO DIE
End DoDot:1
+16 QUIT
+17 ;
EOJ ;-- kill variables and quit
+1 DO EN^XBVK("IN")
+2 QUIT
+3 ;
DIE KILL Y
+1 DO ^DIE
+2 KILL DA,DR,DIE,DIC,DINUM,Y
+3 QUIT
