INXPORT ; cmi/flag/maw - IN GIS Package Exporter ; [ 10/09/2002 11:05 AM ]
;;3.01;BHL IHS Interfaces with GIS;**2,15**;OCT 15, 2002
;
;
;this routine will take all components of a package and export
;to transport global ^INXPORT. This global will then get moved to
;the remote system and get imported into GIS. This will act as a
;replacement to the KIDS data install
;
MAIN ;PEP - this is the main routine driver
D ASK
Q:$D(DIRUT)
Q:$G(INSTND)=""
Q:$G(INST)=""
D MSG(INSTND,INST,ININT)
W !!,"The export of ",INMSGPR," has completed successfully. The content"
W !,"is in the global ^'INXPORT' which can be saved to a host file."
D EOJ
Q
;
ASK ;-- ask the site and project
S DIR(0)="S^HL7:HL;X12:X1"
S DIR("A")="What is the type of messaging you are exporting from"
D ^DIR
I $D(DIRUT) W !!,"Export aborted..." H 2 Q
S INSTND=Y(0)
K DIC
K DIR
S DIR(0)="F^2:10"
S DIR("A")="What is the site you are exporting from............."
D ^DIR
I $D(DIRUT) W !!,"Export aborted..." H 2 Q
S INST=Y
S DIC(0)="AEMQZ",DIC="^INRHNS("
S DIC("A")="What is the interface you are exporting from........: "
S DIC("S")="I $D(^(1))"
D ^DIC
I +Y<0 W !!,"Export aborted..." H 2 Q
S ININTI=+Y
S (INIF,ININT)=$P(Y,U,2)
I ININT="" S INIF="CORE"
I INIF="CORE" S ININTI=$O(^INRHNS("B","CORE",0))
S INMPRE="^INXPORT(INSTND,INST,INIF)"
Q
;
MSG(STD,SIT,INT) ;PEP - get the data
;lets find the message, tt, dest, bp, then segment, then field
K ^INXPORT
S INMSGPR=$G(STD)_" "_$G(SIT)_$S($G(INT)'="":" "_INT,1:"")
D SETD(INMSGPR)
D SETT(INMSGPR)
D SETBP(INMSGPR)
S INMDA=0 F S INMDA=$O(^INTHL7M("B",INMDA)) Q:INMDA="" D
. Q:INMDA'[INMSGPR
. S INIEN=0 F S INIEN=$O(^INTHL7M("B",INMDA,INIEN)) Q:'INIEN D
.. D TT(INIEN)
.. D MD(INIEN)
Q
;
TT(MSG) ;-- set up the transaction types based upon the message
S INTTDA=0
F S INTTDA=$O(^INTHL7M(INIEN,2,INTTDA)) Q:'INTTDA D
. S INSCNT=0
. S INTTI=$P($G(^INTHL7M(INIEN,2,INTTDA,0)),U)
. S INOUT=$$GET1^DIQ(4000,INTTI,.08,"E")
. S @INMPRE@(INIEN,"INOUT")=INOUT
. F INCNTI=$P($G(^INRHT(INTTI,0)),U,6),INTTI D
.. I INCNTI,'$D(@INMPRE@("TT",INCNTI)) D TTFIELD(INCNTI)
. D DEST(INTTI)
. Q:INDI=""
. D BP(INDI)
Q
;
DEST(TTI) ;-- setup the destination information
S INDI=$P($G(^INRHT(TTI,0)),U,2)
Q:'INDI
I '$D(@INMPRE@("DEST",INDI)) D DFIELD(INDI)
Q
;
BP(DSTI) ;-- setup the background process infomation
S INBPI=$O(^INTHPC("DEST",DSTI,0))
Q:'INBPI
I '$D(@INMPRE@("BP",INBPI)) D BPFIELD(INBPI)
Q
;the following can be added if IP port and IP address are sent
S INBPDA=0 F S INBPDA=$O(^INTHPC(INBPI,5,INBPDA)) Q:'INBPDA D
. S INSRVP=$G(^INTHPC(INBPI,5,INBPDA,0))
. S @INMPRE@(INIEN,"BP",INBPI,5,INBPDA)=INSRVP
S INBPIEN=0 F S INBPIEN=$O(^INTHPC(INBPI,6,INBPIEN)) Q:'INBPIEN D
. S INSCNT=1
. S INCLIP=$G(^INTHPC(INBPI,6,INBPIEN,0))
. S $P(@INMPRE@(INIEN,"BP",INBPI,6,INBPIEN),U,INSCNT)=INCLIP
. S INBPOEN=0 F S INBPOEN=$O(^INTHPC(INBPI,6,INBPIEN,1,INBPOEN)) Q:'INBPOEN D
.. S INSCNT=INSCNT+1
.. S INCLP=$G(^INTHPC(INBPI,6,INBPIEN,1,INBPOEN,0))
.. S $P(@INMPRE@(INIEN,"BP",INBPI,6,INBPIEN),U,INSCNT)=INCLP
Q
;
MD(INIEN) ;-- setup the message structure
S INCNT=0
F INMF=.01,.02,.03,.04,.05,.06,.07,.08,.1,.11,.12,5,7.01,7.02,7.03,7.04 D
. S INCNT=INCNT+1
. S $P(@INMPRE@(INIEN,"MD"),";",INCNT)=INMF_"///"_$$GET1^DIQ(4011,INIEN,INMF,"E")
S INIMC=0 F S INIMC=$O(^INTHL7M(INIEN,6,INIMC)) Q:'INIMC D
. S @INMPRE@(INIEN,"MD","OIMC",INIMC)=$G(^INTHL7M(INIEN,6,INIMC,0)) ;8/2/2007 cmi/maw patch 15
S INIMC=0 F S INIMC=$O(^INTHL7M(INIEN,4,INIMC)) Q:'INIMC D
. S @INMPRE@(INIEN,"MD","MCFL",INIMC)=$G(^INTHL7M(INIEN,4,INIMC,0))
S INMDS=0 F S INMDS=$O(^INTHL7M(INIEN,3,INMDS)) Q:'INMDS D
. S @INMPRE@(INIEN,"MD","DESC",INMDS)=$G(^INTHL7M(INIEN,3,INMDS,0))
S INMTT=0 F S INMTT=$O(^INTHL7M(INIEN,2,INMTT)) Q:'INMTT D
. S INMTTI=+$G(^INTHL7M(INIEN,2,INMTT,0))
. Q:'INMTTI
. S INMTTE=$$GET1^DIQ(4000,INMTTI,.01,"E")
. S @INMPRE@(INIEN,"MD","TT",INMTT)=INMTTE
S INMS=0 F S INMS=$O(^INTHL7M(INIEN,1,INMS)) Q:'INMS D
. S INCNT=0
. K INFILE,INPNTE
. S INSIEN=$P($G(^INTHL7M(INIEN,1,INMS,0)),U)
. S INSDT=$G(^INTHL7M(INIEN,1,INMS,0))
. S INSEG=$P($G(^INTHL7S(INSIEN,0)),U)
. S INSEQ=$P($G(^INTHL7M(INIEN,1,INMS,0)),U,2)
. S INREP=$P($G(^INTHL7M(INIEN,1,INMS,0)),U,3)
. S INOF=$P($G(^INTHL7M(INIEN,1,INMS,0)),U,4)
. S INFILI=$P($G(^INTHL7M(INIEN,1,INMS,0)),U,5)
. I INFILI]"" S INFILE=$P($G(^DIC(INFILI,0)),U)
. S INPAR=$P($G(^INTHL7M(INIEN,1,INMS,0)),U,7)
. S INMULT=$P($G(^INTHL7M(INIEN,1,INMS,0)),U,8)
. S INPNTI=$P($G(^INTHL7M(INIEN,1,INMS,0)),U,11)
. I INPNTI]"" S INPNTE=$P($G(^INTHL7S(INPNTI,0)),U)
. S INUDI=$P($G(^INTHL7M(INIEN,1,INMS,0)),U,12)
. S INSTR=INSEG_U_INSEQ_U_INREP_U_INOF_U_$G(INFILE)_U_INPAR_U_INMULT
. S INSTR=INSTR_U_$G(INPNTE)_U_INUDI
. S @INMPRE@(INIEN,"MD","SEG",INSIEN)=INSTR
. S INOMC=0 F S INOMC=$O(^INTHL7M(INIEN,1,INMS,5,INOMC)) Q:'INOMC D
.. S @INMPRE@(INIEN,"MD","SEG",INSIEN,"OMC",INOMC)=$G(^INTHL7M(INIEN,1,INMS,5,INOMC,0))
. D SD(INSIEN)
Q
;
SD(SIEN) ;-- get the segment definition
S INCNT=0
F INSF=.01,.02 D
. S INCNT=INCNT+1
. S $P(@INMPRE@(INIEN,"SD",SIEN),U,INCNT)=$$GET1^DIQ(4010,SIEN,INSF,"E")
S INSDA=0 F S INSDA=$O(^INTHL7S(SIEN,1,INSDA)) Q:'INSDA D
. S INFIEN=$P($G(^INTHL7S(SIEN,1,INSDA,0)),U)
. S INFLD=$P($G(^INTHL7F(INFIEN,0)),U)
. S INFSEQ=$P($G(^INTHL7S(SIEN,1,INSDA,0)),U,2)
. S INFREQ=$P($G(^INTHL7S(SIEN,1,INSDA,0)),U,3)
. S @INMPRE@(INIEN,"SD",SIEN,"FD",INSDA)=INFLD_U_INFSEQ_U_INFREQ
. D FD(INFIEN)
Q
;
FD(FIEN) ;-- define the fields in this message
S INCNT=0
F INF=.01,.02,.03,3 D
. S INCNT=INCNT+1
. S $P(@INMPRE@(INIEN,"FD",FIEN),U,INCNT)=$$GET1^DIQ(4012,FIEN,INF,"E")
S @INMPRE@(INIEN,"FD",FIEN,"OUT")=$$GET1^DIQ(4012,FIEN,5,"E")
S INFD=0 F S INFD=$O(^INTHL7F(FIEN,1,INFD)) Q:'INFD D
. S @INMPRE@(INIEN,"FD",FIEN,"DESC",INFD)=$G(^INTHL7F(FIEN,1,INFD,0))
S INFS=0 F S INFS=$O(^INTHL7F(FIEN,10,INFS)) Q:'INFS D
. S INFSFI=$P($G(^INTHL7F(FIEN,10,INFS,0)),U)
. S INFSFE=$P($G(^INTHL7F(INFSFI,0)),U)
. S INFSFDT=$P($G(^INTHL7F(INFSFI,0)),U,2)
. S INFSFLN=$P($G(^INTHL7F(INFSFI,0)),U,3)
. S INFSFDL=$G(^INTHL7F(INFSFI,"C"))
. S INFSFOT=$G(^INTHL7F(INFSFI,5))
. S INFSFS=$P($G(^INTHL7F(FIEN,10,INFS,0)),U,2)
. S @INMPRE@(INIEN,"FD",INFSFI)=INFSFE_U_INFSFDT_U_INFSFLN_U_INFSFDL
. S @INMPRE@(INIEN,"FD",INFSFI,"OUT")=INFSFOT
. S @INMPRE@(INIEN,"FD",FIEN,"SUB",INFS)=INFSFE_U_INFSFS
Q
;
EOJ ;-- kill variables and quit
D EN^XBVK("IN")
Q
;
LIST(INTI) ;-- return a list for the DIR reader
S INCNT=0
S INLDA=0 F S INLDA=$O(^INRHNS(INTI,1,INLDA)) Q:INLDA="" D
. S INCNT=INCNT+1
. S INDATA=$P($G(^INRHNS(INTI,1,INLDA,0)),U)
. S $P(INVAR,";",INCNT)=$E(INDATA,1,3)_":"_INDATA
Q INVAR
;
SETD(MSGPR) ;-- get all destinations for this package
S INDA=0
F S INDA=$O(^INRHD(INDA)) Q:'INDA D
. S INPT=$$GET1^DIQ(4005,INDA,.02)
. S INPTX=$$GET1^DIQ(4005,INDA,.01)
. Q:INPT'[MSGPR&(INPTX'[MSGPR)
. D DFIELD(INDA)
Q
DFIELD(INDA) ;
S INCNT=0
F INF=.01,.02,.03,.05,.06,.08,.1,.11 D
. S INCNT=INCNT+1
. S $P(@INMPRE@("DEST",INDA),";",INCNT)=INF_"///"_$$GET1^DIQ(4005,INDA,INF,"E")
Q
;
SETT(MSGPR) ;-- get all destinations for this package
S INDA=0
F S INDA=$O(^INRHT(INDA)) Q:'INDA D
. S INTPT=$$GET1^DIQ(4000,INDA,.01)
. Q:INTPT'[MSGPR
. D TTFIELD(INDA)
Q
TTFIELD(INDA) ;
S INCNT=0
F INF=.01,.02,.05,.06,.08,.09,.1,.11 D
. S INCNT=INCNT+1
. S $P(@INMPRE@("TT",INDA),";",INCNT)=INF_"///"_$$GET1^DIQ(4000,INDA,INF,"E")
Q
;
SETBP(MSGPR) ;-- get all destinations for this package
S INDA=0 F S INDA=$O(^INTHPC(INDA)) Q:'INDA D
. S INTPT=$$GET1^DIQ(4004,INDA,.01)
. Q:INTPT'[MSGPR
. D BPFIELD(INDA)
Q
BPFIELD(INDA) ;
S INCNT=0
F INF=.01,.02,.06,.07,.08,.09,1.8,1,8 D
. S INCNT=INCNT+1
. S $P(@INMPRE@("BP",INDA),";",INCNT)=INF_"///"_$$GET1^DIQ(4004,INDA,INF,"E")
Q
;
INXPORT ; cmi/flag/maw - IN GIS Package Exporter ; [ 10/09/2002 11:05 AM ]
+1 ;;3.01;BHL IHS Interfaces with GIS;**2,15**;OCT 15, 2002
+2 ;
+3 ;
+4 ;this routine will take all components of a package and export
+5 ;to transport global ^INXPORT. This global will then get moved to
+6 ;the remote system and get imported into GIS. This will act as a
+7 ;replacement to the KIDS data install
+8 ;
MAIN ;PEP - this is the main routine driver
+1 DO ASK
+2 IF $DATA(DIRUT)
QUIT
+3 IF $GET(INSTND)=""
QUIT
+4 IF $GET(INST)=""
QUIT
+5 DO MSG(INSTND,INST,ININT)
+6 WRITE !!,"The export of ",INMSGPR," has completed successfully. The content"
+7 WRITE !,"is in the global ^'INXPORT' which can be saved to a host file."
+8 DO EOJ
+9 QUIT
+10 ;
ASK ;-- ask the site and project
+1 SET DIR(0)="S^HL7:HL;X12:X1"
+2 SET DIR("A")="What is the type of messaging you are exporting from"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
WRITE !!,"Export aborted..."
HANG 2
QUIT
+5 SET INSTND=Y(0)
+6 KILL DIC
+7 KILL DIR
+8 SET DIR(0)="F^2:10"
+9 SET DIR("A")="What is the site you are exporting from............."
+10 DO ^DIR
+11 IF $DATA(DIRUT)
WRITE !!,"Export aborted..."
HANG 2
QUIT
+12 SET INST=Y
+13 SET DIC(0)="AEMQZ"
SET DIC="^INRHNS("
+14 SET DIC("A")="What is the interface you are exporting from........: "
+15 SET DIC("S")="I $D(^(1))"
+16 DO ^DIC
+17 IF +Y<0
WRITE !!,"Export aborted..."
HANG 2
QUIT
+18 SET ININTI=+Y
+19 SET (INIF,ININT)=$PIECE(Y,U,2)
+20 IF ININT=""
SET INIF="CORE"
+21 IF INIF="CORE"
SET ININTI=$ORDER(^INRHNS("B","CORE",0))
+22 SET INMPRE="^INXPORT(INSTND,INST,INIF)"
+23 QUIT
+24 ;
MSG(STD,SIT,INT) ;PEP - get the data
+1 ;lets find the message, tt, dest, bp, then segment, then field
+2 KILL ^INXPORT
+3 SET INMSGPR=$GET(STD)_" "_$GET(SIT)_$SELECT($GET(INT)'="":" "_INT,1:"")
+4 DO SETD(INMSGPR)
+5 DO SETT(INMSGPR)
+6 DO SETBP(INMSGPR)
+7 SET INMDA=0
FOR
SET INMDA=$ORDER(^INTHL7M("B",INMDA))
IF INMDA=""
QUIT
Begin DoDot:1
+8 IF INMDA'[INMSGPR
QUIT
+9 SET INIEN=0
FOR
SET INIEN=$ORDER(^INTHL7M("B",INMDA,INIEN))
IF 'INIEN
QUIT
Begin DoDot:2
+10 DO TT(INIEN)
+11 DO MD(INIEN)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
TT(MSG) ;-- set up the transaction types based upon the message
+1 SET INTTDA=0
+2 FOR
SET INTTDA=$ORDER(^INTHL7M(INIEN,2,INTTDA))
IF 'INTTDA
QUIT
Begin DoDot:1
+3 SET INSCNT=0
+4 SET INTTI=$PIECE($GET(^INTHL7M(INIEN,2,INTTDA,0)),U)
+5 SET INOUT=$$GET1^DIQ(4000,INTTI,.08,"E")
+6 SET @INMPRE@(INIEN,"INOUT")=INOUT
+7 FOR INCNTI=$PIECE($GET(^INRHT(INTTI,0)),U,6),INTTI
Begin DoDot:2
+8 IF INCNTI
IF '$DATA(@INMPRE@("TT",INCNTI))
DO TTFIELD(INCNTI)
End DoDot:2
+9 DO DEST(INTTI)
+10 IF INDI=""
QUIT
+11 DO BP(INDI)
End DoDot:1
+12 QUIT
+13 ;
DEST(TTI) ;-- setup the destination information
+1 SET INDI=$PIECE($GET(^INRHT(TTI,0)),U,2)
+2 IF 'INDI
QUIT
+3 IF '$DATA(@INMPRE@("DEST",INDI))
DO DFIELD(INDI)
+4 QUIT
+5 ;
BP(DSTI) ;-- setup the background process infomation
+1 SET INBPI=$ORDER(^INTHPC("DEST",DSTI,0))
+2 IF 'INBPI
QUIT
+3 IF '$DATA(@INMPRE@("BP",INBPI))
DO BPFIELD(INBPI)
+4 QUIT
+5 ;the following can be added if IP port and IP address are sent
+6 SET INBPDA=0
FOR
SET INBPDA=$ORDER(^INTHPC(INBPI,5,INBPDA))
IF 'INBPDA
QUIT
Begin DoDot:1
+7 SET INSRVP=$GET(^INTHPC(INBPI,5,INBPDA,0))
+8 SET @INMPRE@(INIEN,"BP",INBPI,5,INBPDA)=INSRVP
End DoDot:1
+9 SET INBPIEN=0
FOR
SET INBPIEN=$ORDER(^INTHPC(INBPI,6,INBPIEN))
IF 'INBPIEN
QUIT
Begin DoDot:1
+10 SET INSCNT=1
+11 SET INCLIP=$GET(^INTHPC(INBPI,6,INBPIEN,0))
+12 SET $PIECE(@INMPRE@(INIEN,"BP",INBPI,6,INBPIEN),U,INSCNT)=INCLIP
+13 SET INBPOEN=0
FOR
SET INBPOEN=$ORDER(^INTHPC(INBPI,6,INBPIEN,1,INBPOEN))
IF 'INBPOEN
QUIT
Begin DoDot:2
+14 SET INSCNT=INSCNT+1
+15 SET INCLP=$GET(^INTHPC(INBPI,6,INBPIEN,1,INBPOEN,0))
+16 SET $PIECE(@INMPRE@(INIEN,"BP",INBPI,6,INBPIEN),U,INSCNT)=INCLP
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
MD(INIEN) ;-- setup the message structure
+1 SET INCNT=0
+2 FOR INMF=.01,.02,.03,.04,.05,.06,.07,.08,.1,.11,.12,5,7.01,7.02,7.03,7.04
Begin DoDot:1
+3 SET INCNT=INCNT+1
+4 SET $PIECE(@INMPRE@(INIEN,"MD"),";",INCNT)=INMF_"///"_$$GET1^DIQ(4011,INIEN,INMF,"E")
End DoDot:1
+5 SET INIMC=0
FOR
SET INIMC=$ORDER(^INTHL7M(INIEN,6,INIMC))
IF 'INIMC
QUIT
Begin DoDot:1
+6 ;8/2/2007 cmi/maw patch 15
SET @INMPRE@(INIEN,"MD","OIMC",INIMC)=$GET(^INTHL7M(INIEN,6,INIMC,0))
End DoDot:1
+7 SET INIMC=0
FOR
SET INIMC=$ORDER(^INTHL7M(INIEN,4,INIMC))
IF 'INIMC
QUIT
Begin DoDot:1
+8 SET @INMPRE@(INIEN,"MD","MCFL",INIMC)=$GET(^INTHL7M(INIEN,4,INIMC,0))
End DoDot:1
+9 SET INMDS=0
FOR
SET INMDS=$ORDER(^INTHL7M(INIEN,3,INMDS))
IF 'INMDS
QUIT
Begin DoDot:1
+10 SET @INMPRE@(INIEN,"MD","DESC",INMDS)=$GET(^INTHL7M(INIEN,3,INMDS,0))
End DoDot:1
+11 SET INMTT=0
FOR
SET INMTT=$ORDER(^INTHL7M(INIEN,2,INMTT))
IF 'INMTT
QUIT
Begin DoDot:1
+12 SET INMTTI=+$GET(^INTHL7M(INIEN,2,INMTT,0))
+13 IF 'INMTTI
QUIT
+14 SET INMTTE=$$GET1^DIQ(4000,INMTTI,.01,"E")
+15 SET @INMPRE@(INIEN,"MD","TT",INMTT)=INMTTE
End DoDot:1
+16 SET INMS=0
FOR
SET INMS=$ORDER(^INTHL7M(INIEN,1,INMS))
IF 'INMS
QUIT
Begin DoDot:1
+17 SET INCNT=0
+18 KILL INFILE,INPNTE
+19 SET INSIEN=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U)
+20 SET INSDT=$GET(^INTHL7M(INIEN,1,INMS,0))
+21 SET INSEG=$PIECE($GET(^INTHL7S(INSIEN,0)),U)
+22 SET INSEQ=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U,2)
+23 SET INREP=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U,3)
+24 SET INOF=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U,4)
+25 SET INFILI=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U,5)
+26 IF INFILI]""
SET INFILE=$PIECE($GET(^DIC(INFILI,0)),U)
+27 SET INPAR=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U,7)
+28 SET INMULT=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U,8)
+29 SET INPNTI=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U,11)
+30 IF INPNTI]""
SET INPNTE=$PIECE($GET(^INTHL7S(INPNTI,0)),U)
+31 SET INUDI=$PIECE($GET(^INTHL7M(INIEN,1,INMS,0)),U,12)
+32 SET INSTR=INSEG_U_INSEQ_U_INREP_U_INOF_U_$GET(INFILE)_U_INPAR_U_INMULT
+33 SET INSTR=INSTR_U_$GET(INPNTE)_U_INUDI
+34 SET @INMPRE@(INIEN,"MD","SEG",INSIEN)=INSTR
+35 SET INOMC=0
FOR
SET INOMC=$ORDER(^INTHL7M(INIEN,1,INMS,5,INOMC))
IF 'INOMC
QUIT
Begin DoDot:2
+36 SET @INMPRE@(INIEN,"MD","SEG",INSIEN,"OMC",INOMC)=$GET(^INTHL7M(INIEN,1,INMS,5,INOMC,0))
End DoDot:2
+37 DO SD(INSIEN)
End DoDot:1
+38 QUIT
+39 ;
SD(SIEN) ;-- get the segment definition
+1 SET INCNT=0
+2 FOR INSF=.01,.02
Begin DoDot:1
+3 SET INCNT=INCNT+1
+4 SET $PIECE(@INMPRE@(INIEN,"SD",SIEN),U,INCNT)=$$GET1^DIQ(4010,SIEN,INSF,"E")
End DoDot:1
+5 SET INSDA=0
FOR
SET INSDA=$ORDER(^INTHL7S(SIEN,1,INSDA))
IF 'INSDA
QUIT
Begin DoDot:1
+6 SET INFIEN=$PIECE($GET(^INTHL7S(SIEN,1,INSDA,0)),U)
+7 SET INFLD=$PIECE($GET(^INTHL7F(INFIEN,0)),U)
+8 SET INFSEQ=$PIECE($GET(^INTHL7S(SIEN,1,INSDA,0)),U,2)
+9 SET INFREQ=$PIECE($GET(^INTHL7S(SIEN,1,INSDA,0)),U,3)
+10 SET @INMPRE@(INIEN,"SD",SIEN,"FD",INSDA)=INFLD_U_INFSEQ_U_INFREQ
+11 DO FD(INFIEN)
End DoDot:1
+12 QUIT
+13 ;
FD(FIEN) ;-- define the fields in this message
+1 SET INCNT=0
+2 FOR INF=.01,.02,.03,3
Begin DoDot:1
+3 SET INCNT=INCNT+1
+4 SET $PIECE(@INMPRE@(INIEN,"FD",FIEN),U,INCNT)=$$GET1^DIQ(4012,FIEN,INF,"E")
End DoDot:1
+5 SET @INMPRE@(INIEN,"FD",FIEN,"OUT")=$$GET1^DIQ(4012,FIEN,5,"E")
+6 SET INFD=0
FOR
SET INFD=$ORDER(^INTHL7F(FIEN,1,INFD))
IF 'INFD
QUIT
Begin DoDot:1
+7 SET @INMPRE@(INIEN,"FD",FIEN,"DESC",INFD)=$GET(^INTHL7F(FIEN,1,INFD,0))
End DoDot:1
+8 SET INFS=0
FOR
SET INFS=$ORDER(^INTHL7F(FIEN,10,INFS))
IF 'INFS
QUIT
Begin DoDot:1
+9 SET INFSFI=$PIECE($GET(^INTHL7F(FIEN,10,INFS,0)),U)
+10 SET INFSFE=$PIECE($GET(^INTHL7F(INFSFI,0)),U)
+11 SET INFSFDT=$PIECE($GET(^INTHL7F(INFSFI,0)),U,2)
+12 SET INFSFLN=$PIECE($GET(^INTHL7F(INFSFI,0)),U,3)
+13 SET INFSFDL=$GET(^INTHL7F(INFSFI,"C"))
+14 SET INFSFOT=$GET(^INTHL7F(INFSFI,5))
+15 SET INFSFS=$PIECE($GET(^INTHL7F(FIEN,10,INFS,0)),U,2)
+16 SET @INMPRE@(INIEN,"FD",INFSFI)=INFSFE_U_INFSFDT_U_INFSFLN_U_INFSFDL
+17 SET @INMPRE@(INIEN,"FD",INFSFI,"OUT")=INFSFOT
+18 SET @INMPRE@(INIEN,"FD",FIEN,"SUB",INFS)=INFSFE_U_INFSFS
End DoDot:1
+19 QUIT
+20 ;
EOJ ;-- kill variables and quit
+1 DO EN^XBVK("IN")
+2 QUIT
+3 ;
LIST(INTI) ;-- return a list for the DIR reader
+1 SET INCNT=0
+2 SET INLDA=0
FOR
SET INLDA=$ORDER(^INRHNS(INTI,1,INLDA))
IF INLDA=""
QUIT
Begin DoDot:1
+3 SET INCNT=INCNT+1
+4 SET INDATA=$PIECE($GET(^INRHNS(INTI,1,INLDA,0)),U)
+5 SET $PIECE(INVAR,";",INCNT)=$EXTRACT(INDATA,1,3)_":"_INDATA
End DoDot:1
+6 QUIT INVAR
+7 ;
SETD(MSGPR) ;-- get all destinations for this package
+1 SET INDA=0
+2 FOR
SET INDA=$ORDER(^INRHD(INDA))
IF 'INDA
QUIT
Begin DoDot:1
+3 SET INPT=$$GET1^DIQ(4005,INDA,.02)
+4 SET INPTX=$$GET1^DIQ(4005,INDA,.01)
+5 IF INPT'[MSGPR&(INPTX'[MSGPR)
QUIT
+6 DO DFIELD(INDA)
End DoDot:1
+7 QUIT
DFIELD(INDA) ;
+1 SET INCNT=0
+2 FOR INF=.01,.02,.03,.05,.06,.08,.1,.11
Begin DoDot:1
+3 SET INCNT=INCNT+1
+4 SET $PIECE(@INMPRE@("DEST",INDA),";",INCNT)=INF_"///"_$$GET1^DIQ(4005,INDA,INF,"E")
End DoDot:1
+5 QUIT
+6 ;
SETT(MSGPR) ;-- get all destinations for this package
+1 SET INDA=0
+2 FOR
SET INDA=$ORDER(^INRHT(INDA))
IF 'INDA
QUIT
Begin DoDot:1
+3 SET INTPT=$$GET1^DIQ(4000,INDA,.01)
+4 IF INTPT'[MSGPR
QUIT
+5 DO TTFIELD(INDA)
End DoDot:1
+6 QUIT
TTFIELD(INDA) ;
+1 SET INCNT=0
+2 FOR INF=.01,.02,.05,.06,.08,.09,.1,.11
Begin DoDot:1
+3 SET INCNT=INCNT+1
+4 SET $PIECE(@INMPRE@("TT",INDA),";",INCNT)=INF_"///"_$$GET1^DIQ(4000,INDA,INF,"E")
End DoDot:1
+5 QUIT
+6 ;
SETBP(MSGPR) ;-- get all destinations for this package
+1 SET INDA=0
FOR
SET INDA=$ORDER(^INTHPC(INDA))
IF 'INDA
QUIT
Begin DoDot:1
+2 SET INTPT=$$GET1^DIQ(4004,INDA,.01)
+3 IF INTPT'[MSGPR
QUIT
+4 DO BPFIELD(INDA)
End DoDot:1
+5 QUIT
BPFIELD(INDA) ;
+1 SET INCNT=0
+2 FOR INF=.01,.02,.06,.07,.08,.09,1.8,1,8
Begin DoDot:1
+3 SET INCNT=INCNT+1
+4 SET $PIECE(@INMPRE@("BP",INDA),";",INCNT)=INF_"///"_$$GET1^DIQ(4004,INDA,INF,"E")
End DoDot:1
+5 QUIT
+6 ;
