BYIMIMM4 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
;
;-----
MULT ;EP;PROCESS MULTIPLE INBOUND MESSAGES
K BYIMQUIT
N AUTOIMP,AUTOADD,DIR,FILE
S AUTOIMP=1
S AUTOADD=0
D PATH^BYIMIMM6
Q:IPATH=""
S DIR=$$LIST^%ZISH(IPATH,"*",.DIR)
S FILE=""
S XX=0
F S XX=$O(DIR(XX)) Q:'XX S:DIR(XX)]"" FILE(DIR(XX))=""
S XX=""
F S XX=$O(FILE(XX)) Q:XX="" D
.S:XX["izdata"&(XX[".dat"!(XX[".hl7")) FILE=XX
.Q:FILE=""
.N DA
.S DA=0
.F S DA=$O(^BYIMPARA("FILE",FILE,$$DUZ^BYIMIMM(),DA)) Q:'DA I $P($G(^BYIMPARA($$DUZ^BYIMIMM(),2,+DA,0)),U,3)="I" S BYIMQUIT=""
.I $D(BYIMQUIT) K BYIMQUIT Q
.D I1^BYIMIMM1
Q
;-----
ASITE(BYIMDA) ;EP;ADDITIONAL EXPORT SITES
Q:'$G(BYIMDA)
I $O(^BYIMPARA(BYIMDA,3,0)) D AS Q
K DIR
S DIR(0)="YO"
S DIR("A")="Add export/import information for additional states"
S DIR("B")="NO"
W !!
D ^DIR
K DIR
Q:'Y
AS N BYIMAS
S BYIMQUIT=0
F D ASACT Q:BYIMQUIT
Q
;-----
ASACT ;ADDITIONAL SITE ACTION
I '$O(^BYIMPARA(BYIMDA,3,0)) D ASADD
I '$O(^BYIMPARA(BYIMDA,3,0)) S BYIMQUIT=1 Q
D ASD
K DIR
S DIR(0)="SO^1:Edit site;2:Add site;3:Delete site"
W !!
D ^DIR
K DIR
I 'Y S BYIMQUIT=1 Q
I Y=1 D ASEDIT Q
I Y=2 D ASADD Q
I Y=3 D ASDEL
Q
;-----
ASSEL ;SELECT ADDITION SITE
I J=1 S Y=1 D ASSEL1 Q
K DIR
S DIR(0)="NO^1:"_J
S DIR("A")="Select site number"
W !!
D ^DIR
K DIR
ASSEL1 Q:'Y
Q:'$G(BYIMAS(Y))
S DA=BYIMAS(Y)
Q
;-----
ASD ;DISPLAY SITES
W @IOF
W !!?10,"Additional EXPORT/IMPORT Site Directories"
W !!?5,"NUM",?10,"SITE/STATE"
W !?5,"---",?10,"--------------------------------------------------"
N X0,X1
S J=0
S BYIMAS=0
F S BYIMAS=$O(^BYIMPARA(BYIMDA,3,BYIMAS)) Q:'BYIMAS D
.S X0=$G(^BYIMPARA(BYIMDA,3,BYIMAS,0))
.S X1=$G(^BYIMPARA(BYIMDA,3,BYIMAS,1))
.S J=J+1
.S BYIMAS(J)=BYIMAS
.W !?5,J,?10,$P(X0,U)
.W !?15,"OUTBOUND: ",$P(X0,U,2)
.W !?15," INBOUND: ",$P(X0,U,3)
Q
;-----
ASADD ;ADD SITES
N BYIMQUIT
S BYIMQUIT=0
S J=0
N BYIMAS
S J=J+1
K DIR
S DIR(0)="FO^1:10"
S DIR("A")="NEW interface state name"
S DIR("?")="Enter a name to identify the additional interface state, 3-10 characters"
W !!
D ^DIR
K DIR
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
I X=""!(X[U) S BYIMQUIT=1 Q
S (NSITE,BYIMAS(J))=X
S DA(1)=BYIMDA
S DIC="^BYIMPARA("_BYIMDA_",3,"
S DIC(0)="L"
S:'$D(^BYIMPARA(BYIMDA,3,0)) ^BYIMPARA(BYIMDA,3,0)="^90480.03"
D FILE^DICN
I Y<0 S BYIMQUIT=1 Q
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
N NSDA
S (NSDA,DA)=+Y
N X,Y,Z,ZZ
S X=$P(^BYIMPARA(BYIMDA,0),U,2)
S V=$S(X["\":"\",1:"/")
S NSITE=$$LC(NSITE)
S X=$$LC(X)
I X["hlrbridge" D I 1
.S X=$P(X,"hl7bridge")
.S:$E(X,$L(X))'=V X=X_V
.S Y=X_"hl7bridge"_V_NSITE_V_"responses"
.S X=X_"hl7bridge"_V_NSITE_V_"requests"
E D
.S X=$P(X,"requests")
.S:$E(X,$L(X))'=V X=X_V
.S Y=X_NSITE_V_"responses"
.S X=X_NSITE_V_"requests"
S $P(^BYIMPARA(BYIMDA,3,NSDA,0),U,2)=X
S $P(^BYIMPARA(BYIMDA,3,NSDA,0),U,3)=Y
S $P(^BYIMPARA(BYIMDA,3,NSDA,0),U,4,13)=$P(^BYIMPARA(BYIMDA,0),U,4,13)
S DA=NSDA
D ASE1
Q
;-----
ASEDIT ;EDIT
D ASSEL
Q:'$G(DA)
ASE1 S DA(1)=BYIMDA
;INCLUDE AGE TO EXPORT FOR ADD. SITES
S DR=".01T;.02T;.03T;.06T;1.03T;1.04T;1.05T;.07T;1.06T;1.07T;6.03T;6.04T;6.05T;1.08T;.15T;6.11T;6.08T;6.01T;6.02T;6.09T;.17T;6.1T;.08T;.1T;6.07T;.14T;.16T"
S DIE="^BYIMPARA("_BYIMDA_",3,"
W !!
D ^DIE
K DA,DR,DIE
Q
;-----
ASDEL ;DELETE
D ASSEL
;PATCH 8 CR 08549
;Q:DA
Q:'$G(DA)
;PATCH 8 END
S X=^BYIMPARA(BYIMDA,3,DA,0)
W !?10,$P(X,U)
K DIR
S DIR(0)="YO"
S DIR("A")="Delete export/import site: "_$P(X,U)
S DIR("B")="NO"
W !
D ^DIR
K DIR
Q:Y'=1
S DA(1)=BYIMDA
S DIK="^BYIMPARA("_BYIMDA_",3,"
D ^DIK
K DA,DIK
Q
;-----
CP(DFN) ;EP;DETERMINE VARICELLA EXPOSURE
;DFN = PATIENT DFN
Q:'$D(^BIPC("B",+DFN))
N BIX,VDAT
S BIX=0
F S BIX=$O(^BIPC("B",DFN,BIX)) Q:'BIX S:$P($G(^BIPC(BIX,0)),U,3)=12 VDAT=$P(^(0),U,4)
Q:$L($G(VDAT))'=7
S VDAT=VDAT+17000000
S RXA="RXA|0|1|"_VDAT_"|"_VDAT_"|998^No vaccine administered^CVX|999"
S OBX="OBX|1|CE|59784-9^Disease with presumed immunity ^LN|1|38907003^Varicella infection^SCT||||||F|CR|"
N LINE
S LINE=$O(^UTILITY("INH",$J,9999999999),-1)+1
S X=U_"UTILITY(""INH"","_$J_","_LINE_")"
S @X=RXA
S X=U_"UTILITY(""INH"","_$J_","_(LINE+1)_")"
S @X=OBX
Q
;-----
IMMDUP ;EP;DEDUP IMMUNIZATIONS
S DIK="^AUPNVIMM("
S DFN=0
F S DFN=$O(^AUPNVIMM("AC",DFN)) Q:'DFN D
.K TMP
.S IEN=0
.F S IEN=$O(^AUPNVIMM("AC",DFN,IEN)) Q:'IEN D
..S X=$P($G(^AUPNVIMM(IEN,0)),U,1,3)
..S VIS=$P(X,U,3)
..Q:'$P(X,U,2)!'X!'VIS
..S DAT=$P($G(^AUPNVSIT(VIS,0)),".")
..Q:'DAT
..S X=$P(X,U,1,2)_U_DAT
..I +X=242 S $P(X,U)=148
..I +X=243 S $P(X,U)=148
..S TMP(X,IEN)=""
.S X=""
.F S X=$O(TMP(X)) Q:X="" D
..S J=0
..S IEN=0
..F S IEN=$O(TMP(X,IEN)) Q:'IEN D
...S J=J+1
...Q:J<2
...W:'$D(ZTQUEUED) !,DFN,?10,J,?15,IEN,?25,X,?45,$P(^AUTTIMM(+X,0),U,3)
...M ^BYIMTMP("BYIM IMM DUPS",DA)=^AUPNVIMM(DA)
...S DA=IEN
...;D ^DIK
Q
;-----
DEXIT ;EP;CLEAN UP AFTER IZAD
K ^BYIMTMP($J,"BYIM DISP")
Q
;-----
ALOT(LDA,IVDA) ;EP;ACTIVATE LOT NUMBER
Q:'LDA
Q:'$D(^AUTTIML(LDA,0))
S NEWLOT(LDA)=^AUTTIML(LDA,0)
I '$P(NEWLOT(LDA),U,4) D
.S $P(NEWLOT(LDA),U,4)=IVDA
.S ^AUTTIML("C",IVDA,LDA)=""
S $P(^AUTTIML(LDA,0),U,3)=0
S $P(^AUTTIML(LDA,0),U,4)=IVDA
Q
;-----
ILOT(LDA) ;EP;INACTIVATE LOT NUMBER
Q:'LDA
Q:'$D(^AUTTIML(LDA,0))
S:$G(NEWLOT(LDA))]"" ^AUTTIML(LDA,0)=$G(NEWLOT(LDA))
K NEWLOT
Q
;-----
LV(DFN,IVDA,LOTDA) ;EP;CALCULATE LAST V IMM FOR PAT
Q:'$G(DFN)!'$G(IVDA)!'$G(LOTDA)
N XX,YY,ZZ
S XX=$O(^AUPNVIMM("AC",DFN,9999999999),-1)
Q:'XX
S XX0=$G(^AUPNVIMM(XX,0))
Q:+XX0'=IVDA
Q:$P(XX0,U,5)
S $P(^AUPNVIMM(XX,0),U,5)=LOTDA
Q
;-----
MAN(MAN) ;EP;CHECK IMMUNIZATION MAN.
Q:MAN=""
S:MAN["\T\" MAN=$P(MAN,"\T\")_"&"_$P(MAN,"\T\",2)
N X,Y,Z
S X=MAN
X ^%ZOSF("UPPERCASE")
S MAN=Y
S MANA=$P(MAN,U)
S MANN=$P(MAN,U,2)
S MANDA=$O(^AUTTIMAN("B",MANN,0))
Q:MANDA
S X=MANN
S DIC="^AUTTIMAN("
S DIC(0)="L"
S DIC("DR")=".02////"_MANA
D FILE^DICN
I Y>0 S MANDA=+Y
Q
;-----
LOT(LOT,MAN,IVDA) ;EP;EVALUATE LOT AND MANUFACTURER DATA
S LOTDA=""
S MANDA=""
Q:$G(LOT)=""
D:MAN]"" MAN^BYIMIMM4(MAN)
S X=LOT
X ^%ZOSF("UPPERCASE")
S LOT=Y
S LOTDA=$O(^AUTTIML("B",LOT,0))
I LOTDA D ALOT(LOTDA,IVDA) Q
S X=LOT
S DIC="^AUTTIML("
S DIC(0)="L"
S DIC("DR")=".02////"_$G(MANDA)_";.03////1;.04////"_IVDA
D FILE^DICN
Q:Y<0
S LOTDA=+Y
D ALOT(LOTDA,IVDA)
Q
;-----
LOG(FILE,ACT,DFNCNT,IMMCNT,NODFNCNT,NEWIMCNT,ADDIMCNT,PATH,DFN) ;EP;LOG AUTO IMPORT FILES THAT HAVE BEEN PROCESSED
;FILE = NAME OF FILE IMPORTED OR EXPORTED
;ACT = ACTION - 'I'MPORT OR 'E'XPORT
;DFNCNT = NUMBER OF PATIENTS
;IMMCNT = NUMBER OF IMMUNIZATIONS
;NODFNCNT = NUMBER OF PATIENTS FOR WHOM THERE IS NO PATIENT MATCH
;NEWIMCNT = NUMBER OF NEW IMMUNIZATIONS
;ADDIMCNT = NUMBER OF NEW IMMUNIZATIONS ADDED TO V IMMUNIZATIONS
;PATH = DRIVE/DIRECTORY FILE SENT TO
Q:$G(FILE)=""!($G(ACT)="")
S X=FILE
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
S DA(1)=$$DUZ^BYIMIMM()
S DIC="^BYIMPARA("_DA(1)_",2,"
S DIC(0)="L"
S DIC("DR")=".02////"_DT_";.03////"_ACT_";.04////"_$G(DFNCNT)_";.05////"_$G(IMMCNT)
S:$G(NODFNCNT) DIC("DR")=DIC("DR")_";.06////"_NODFNCNT
S:$G(NEWIMCNT) DIC("DR")=DIC("DR")_";.07////"_NEWIMCNT
S:$G(ADDIMCNT) DIC("DR")=DIC("DR")_";.08////"_ADDIMCNT
S:$G(PATH)]"" DIC("DR")=DIC("DR")_";.09////"_PATH
D FILE^DICN
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
N BYIMACT
S BYIMACT=$S(ACT="I":"imported from",1:"exported to")
;-----
BULLETIN ;EP;CREATE EXPORT/IMPORT BULLETIN
N %X,%Y,X,XMB,XMDT,XMDUZ,Y1
S XMB="BYIM EXPORT/IMPORT MESSAGE"
S XMB(1)="The file '"_FILE_"' was "_BYIMACT_" the State Immunization Registry on "_$$HTE^XLFDT($H)
S XMDUZ=.5
D ^XMB
Q
;-----
EXPBULL(BYIMHFNM,DEST,BYIMHDIR) ;EP;EXPORT FILE CREATION FAILED
N %X,%Y,X,XMB,XMDT,XMDUZ,Y1
S XMB="BYIM EXPORT FILE FAILED"
S XMB(1)=BYIMHFNM
S XMB(2)=$P($G(^INRHD(+DEST,0)),U)
S XMB(3)=BYIMHDIR
S XMDUZ=.5
D ^XMB
Q
;-----
LC(X) ;LOWERCASE
S X=$TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ ","abcdefghijklmnopqrstuvwxyz_")
Q X
;-----
QPATH(BYIMDA) ;EP;QUERY DIRECTORIES
Q
Q:'$G(BYIMDA)
N V,X,Y,Z
S X=$P($G(^BYIMPARA(BYIMDA,0)),U,2)
S X=$$LC(X)
S V=$S(X["\":"\",1:"/")
I X["hl7bridge" D I 1
.S X=$P(X,"hl7bridge")
.S:$E(X,$L(X))'=V X=X_V
.S Y=X_"hl7bridge"_V_"queries"
.S Z=X_"hl7bridge"_V_"qresponses"
E D
.S X=$P(X,"requests")
.S:$E(X,$L(X))'=V X=X_V
.S Y=X_"queries"
.S Z=X_"qresponses"
S $P(^BYIMPARA(BYIMDA,1),U)=Y
S $P(^BYIMPARA(BYIMDA,1),U,2)=Z
Q
;-----
LOGDFN ;EP;LOG PATIENTS INCLUDED IN EXPORT
N DFN,TYPE
S TYPE="E"
S DFN=0
F S DFN=$O(^BYIMTMP("LOG",DFN)) Q:'DFN D
.D LOGD(DFN,TYPE)
.K ^BYIMTMP("LOG",DFN)
Q
;-----
LOGD(DFN,TYPE) ;EP;LOG EACH EXPORTED OR IMPORTED IMM
N IMM,X,Y,Z
S:$G(TYPE)="" TYPE="E"
;S DFNCNT=$G(DFNCNT)+1
S IMM=0
F S IMM=$O(^BYIMTMP("LOG",DFN,IMM)) Q:'IMM D
.I $G(BYIMALL)'=2,$D(^BYIMEXP("D",IMM)) Q
.Q:$G(BYIMMU2)
.K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
.S DIC="^BYIMEXP("
.S DIC(0)="L"
.S DIC("DR")=".02////"_DT_";.03////"_IMM_";.04////"_TYPE_";.05////"_$G(XQY)_";.06////"_$G(BYIMALL)
.S X=DFN
.D FILE^DICN
.K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
Q
;-----
DFN(UIF) ;FIND PATIENT DFN
N X,Y,Z,LOC,HRN,DFN
S X=$P($P($G(^INTHU(UIF,3,2,0)),"|",4),U)
S LOC=$E(X,1,6)
S HRN=+$E(X,7,12)
Q:'LOC!'HRN ""
S LOC=$O(^AUTTLOC("C",LOC,0))
Q:'LOC ""
S DFN=""
S X=0
F S X=$O(^AUPNPAT("D",HRN,X)) Q:'X!DFN S Y=0 F S Y=$O(^AUPNPAT("D",HRN,X,Y)) Q:'Y!DFN S:Y=LOC DFN=X
Q DFN
;-----
HFSA(DEST,BYIMHDIR,BYIMHFNM) ;EP - export from this destination
;PATCH 8 CR 08549 CHANGES TO CREATE MULTIPLE STATE FILES
I '$G(DEST) D Q
.S ^BYIMTMP("EXP FAIL",$H,"NO DEST")=BYIMHDIR_U_BYIMHFNM_U_DUZ
.S BYIMFAIL=$G(BYIMFAIL)+1
I '$D(^INLHDEST(DEST)) D Q
.S ^BYIMTMP("EXP FAIL",$H,DEST,"NO MESSAGE")=BYIMHDIR_U_BYIMHFNM_U_DUZ
.S BYIMFAIL=$G(BYIMFAIL)+1
S BYIMDUZ=$$DUZ^BYIMIMM()
K ^BYIMTMP("DEST")
M ^BYIMTMP("DEST",BYIMDUZ,DEST)=^INLHDEST(DEST)
N X
S X=0
F S X=$O(^BYIMPARA(BYIMDUZ,3,X)) Q:'X I X'=BYIMDUZ M ^BYIMTMP("DEST",X,DEST)=^INLHDEST(DEST)
N BYIMH,BYIMU
S STATE=0
F S STATE=$O(^BYIMTMP("DEST",STATE)) Q:'STATE D HFSA1(DEST,STATE,BYIMHFNM)
;PATCH 8 CR 08549 END
Q
;-----
HFSA1(DEST,STATE,BYIMHFNM) ;PROCESS EACH EXPORT FILE
N XX,X0,X1,X6,PATH,FE,PI,ESSN
;MOVE ASSET CALL TO BYIMIMM5
D ASSET^BYIMIMM5(STATE)
;PATCH 8 CR 08385 - allow 'hl7' or 'dat' file extension
S BYIMHFNM=$P(BYIMHFNM,".")_"."_$S($G(FE)]"":FE,1:"dat")
;PATCH 8 CR 08385 END
S Y=$$OPEN^%ZISH(PATH,BYIMHFNM,"W")
I Y D Q
.D EXPBULL(BYIMHFNM,DEST,PATH)
.S ^BYIMTMP("EXP FAIL",$H,DEST,"NO OPEN")=PATH_U_BYIMHFNM_U_DUZ
.S BYIMFAIL=$G(BYIMFAIL)+1
S BYIMH=""
F S BYIMH=$O(^BYIMTMP("DEST",STATE,DEST,0,BYIMH)) Q:BYIMH="" D
.S BYIMU=0
.F S BYIMU=$O(^BYIMTMP("DEST",STATE,DEST,0,BYIMH,BYIMU)) Q:'BYIMU D
..K ^BYIMTMP("ORIG",BYIMU)
..M ^BYIMTMP("ORIG",BYIMU)=^INTHU(BYIMU)
..I $G(^INTHU(BYIMU,3,1,0))["VXU^V04" D Q:'DFN
...S DFN=$$DFN(BYIMU)
...I 'DFN D Q
....K ^INLHDEST(DEST,0,BYIMH,BYIMU)
....K ^BYIMTMP("DEST",STATE,DEST,0,BYIMH,BYIMU)
...S ^BYIMTMP("BYIMIMM4",BYIMU)=DFN
...D REFUSAL^BYIMSEG1(DFN,BYIMU)
..D LP(BYIMU,STATE)
..K ^INTHU(BYIMU)
..M ^INTHU(BYIMU)=^BYIMTMP("ORIG",BYIMU)
..K ^INLHDEST(DEST,0,BYIMH,BYIMU)
..K ^BYIMTMP("DEST",STATE,DEST,0,BYIMH,BYIMU)
K ^BYIMTMP("BYIMIMM4")
K ^BYIMTMP("ORIG")
D ^%ZISC
D LOGDFN:'$G(BYIMTEST)
Q
;-----
LP(BYIMUIEN,AS) ;EP - loop through UIF and set to file
;INCLUDE AGE TO EXPORT CHECK FOR ADD. SITES
I 'AGE,$P(^BYIMPARA(BYIMDUZ,0),U,6) Q:$$AGECHK^BYIMIMM5(BYIMUIEN)
I IO["\\" D
.F J=1:1:$L(IO,"\\") S X=$P(IO,"\\",J)_"\"
.S IO=$E(X,1,$L(X)-1)
I IO["//" D
.F J=1:1:$L(IO,"//") S X=$P(IO,"//",J)_"/"
.S IO=$E(X,1,$L(X)-1)
I $G(PI),$G(^INTHU(BYIMUIEN,3,1,0))["VXU^V04",$$PI(BYIMUIEN) Q
N BYIMUDA
S BYIMUDA=0
F S BYIMUDA=$O(^INTHU(BYIMUIEN,3,BYIMUDA)) Q:'BYIMUDA D
.S SEGX=$G(^INTHU(BYIMUIEN,3,BYIMUDA,0))
.Q:SEGX=""
.I SEGX["PID|",$G(ESSN),SEGX["SSA^SS"!($P(SEGX,"|",20)]"") D ESSN(SEGX)
.I SEGX["PID|"!(SEGX["IN1|"),$G(DFN),SEGX["MEDICARE"!(SEGX["MCR^MC") D MCR(SEGX)
.I SEGX'["|CR|" D
..S BYIMUDA=BYIMUDA+1
..S SEGX=SEGX_$G(^INTHU(BYIMUIEN,3,BYIMUDA,0))
..Q:SEGX["|CR|"
..S BYIMUDA=BYIMUDA+1
..S SEGX=SEGX_$G(^INTHU(BYIMUIEN,3,BYIMUDA,0))
.Q:SEGX'["|CR|"
.;PATCH 8 CR 08781 - CPT CODE
.I SEGX["RXA|",$G(CPT)]"" D CPT(CPT)
.;PATCH 8 CR 08781 END
.I SEGX["FHS|" S $P(SEGX,"|",9)=BYIMHFNM,$P(SEGX,"|",11)=$E($TR($H,","),1,7)
.I SEGX["BHS|" S $P(SEGX,"|",11)=$E($TR($H,","),1,7)
.I '$G(IN1),SEGX["IN1|"!(SEGX["IN2|") Q
.S:"|MSH|FHS|BHS|BTS|FTS|"'[("|"_$E(SEGX,1,3)_"|") SEGX=$TR(SEGX,"\&")
.Q:$E(SEGX,1,4)'?2U1UN1"|"
.I "|BTS|FTS|"'[("|"_$E(SEGX,1,3)_"|") D AE
.U IO W $P(SEGX,"|CR|"),!
Q
;-----
AE ;PROCESS ADDITIONAL SITE EXPORT FILE
I $E(SEGX,1,4)="PID|",$G(ESSN),SEGX["SSA^SS" D ESSN(SEGX)
D SET
Q
;-----
SET ;CUSTOMIZE MSH SEGMENT
N A,B,X,Y,Z
S SEG=$E(SEGX,1,3)
S X=0
F S X=$O(XX(SEG,X)) Q:'X D
.S Y=0
.F S Y=$O(XX(SEG,X,Y)) Q:'Y S Z=XX(SEG,X,Y) D:Z]""
..I SEG="MSH",X=11,'$G(BYIMTEST) Q
..I SEG="RXA",X=6,Y=1,$P(SEGX,"|",7),$P(SEGX,"|",7)<100 Q
..S B=X
..S:"MSHFHSBHS"'[SEG B=X+1
..S A=$P(SEGX,"|",B)
..S $P(A,U,Y)=Z
..S $P(SEGX,"|",B)=A
Q
;-----
PI(UIEN) ;ELIMINATE HL7 MESSAGE IF PATIENT PRIVACY NOT ON FILE
N HRN,LOC,X,Y,Z,XX
S DFN=+$G(^BYIMTMP("BYIMIMM4",UIEN))
I 'DFN S DFN=+$$DFN(UIEN)
Q:'DFN 1
Q:$P($G(^BIP(DFN,0)),U,24) 0
Q 1
;-----
CPT(CPT) ;ADJUST RXA-5 FOR CPT
;PATCH 8 CR 08781 - CPT CODE
N X,Y,Z
S X=$P(SEGX,"|",6)
Q:CPT=123
I CPT=0 S X=$P(X,"~")
I CPT=1,$P(X,"~",2)]"" S X=$P(X,"~",2)
I CPT=2 S X=$P(X,"~",1,2)
;I CPT=1 S X=$P(X,"~")
;I CPT=2,$P(X,"~",2)="" S X=$P(X,"~",2)
;I CPT=3,$P(X,"~",3)]"" S X=$P(X,"~",3)
;I CPT=12 S X=$P(X,"~",1,2)
;I CPT=13 S X=$P(X,"~")_"~"_$P(X,"~",3)
;I CPT=23 S X=$P(X,"~",2)_"~"_$P(X,"~",3)
S $P(SEGX,"|",6)=X
Q
;-----
ESSN(SEGX) ;REMOVE SSN
N J,X,Y,Z,XX
S X=$P(SEGX,"|",4)
S XX=""
F J=1:1 S Y=$P(X,"~",J) Q:Y="" I Y["SSA^SS" S XX=$P(X,"~",1,J-1) S:$P(X,"~",J+1)]"" XX=XX_"~"_$P(X,"~",J+1,99)
S $P(SEGX,"|",4)=XX
S $P(SEGX,"|",20)=""
Q
;-----
MCR(SEGX) ;REMOVE SSN
N J,X,Y,Z,XX
S X=$P(SEGX,"|",4)
S XX=""
F J=1:1 S Y=$P(X,"~",J) Q:Y="" I Y["MEDICARE"!(Y["MCR^MC") S XX=$P($P(X,"~",J),U) S:XX[$P($G(^DPT(DFN,0)),U,9) XX=$P(X,"~",1,J-1)_"~"_$P(X,"~",J+1,99)
S $P(SEGX,"|",4)=XX
S:SEGX["PID|" $P(SEGX,"|",20)=""
Q
;-----
BYIMIMM4 ;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 ;-----
MULT ;EP;PROCESS MULTIPLE INBOUND MESSAGES
+1 KILL BYIMQUIT
+2 NEW AUTOIMP,AUTOADD,DIR,FILE
+3 SET AUTOIMP=1
+4 SET AUTOADD=0
+5 DO PATH^BYIMIMM6
+6 IF IPATH=""
QUIT
+7 SET DIR=$$LIST^%ZISH(IPATH,"*",.DIR)
+8 SET FILE=""
+9 SET XX=0
+10 FOR
SET XX=$ORDER(DIR(XX))
IF 'XX
QUIT
IF DIR(XX)]""
SET FILE(DIR(XX))=""
+11 SET XX=""
+12 FOR
SET XX=$ORDER(FILE(XX))
IF XX=""
QUIT
Begin DoDot:1
+13 IF XX["izdata"&(XX[".dat"!(XX[".hl7"))
SET FILE=XX
+14 IF FILE=""
QUIT
+15 NEW DA
+16 SET DA=0
+17 FOR
SET DA=$ORDER(^BYIMPARA("FILE",FILE,$$DUZ^BYIMIMM(),DA))
IF 'DA
QUIT
IF $PIECE($GET(^BYIMPARA($$DUZ^BYIMIMM(),2,+DA,0)),U,3)="I"
SET BYIMQUIT=""
+18 IF $DATA(BYIMQUIT)
KILL BYIMQUIT
QUIT
+19 DO I1^BYIMIMM1
End DoDot:1
+20 QUIT
+21 ;-----
ASITE(BYIMDA) ;EP;ADDITIONAL EXPORT SITES
+1 IF '$GET(BYIMDA)
QUIT
+2 IF $ORDER(^BYIMPARA(BYIMDA,3,0))
DO AS
QUIT
+3 KILL DIR
+4 SET DIR(0)="YO"
+5 SET DIR("A")="Add export/import information for additional states"
+6 SET DIR("B")="NO"
+7 WRITE !!
+8 DO ^DIR
+9 KILL DIR
+10 IF 'Y
QUIT
AS NEW BYIMAS
+1 SET BYIMQUIT=0
+2 FOR
DO ASACT
IF BYIMQUIT
QUIT
+3 QUIT
+4 ;-----
ASACT ;ADDITIONAL SITE ACTION
+1 IF '$ORDER(^BYIMPARA(BYIMDA,3,0))
DO ASADD
+2 IF '$ORDER(^BYIMPARA(BYIMDA,3,0))
SET BYIMQUIT=1
QUIT
+3 DO ASD
+4 KILL DIR
+5 SET DIR(0)="SO^1:Edit site;2:Add site;3:Delete site"
+6 WRITE !!
+7 DO ^DIR
+8 KILL DIR
+9 IF 'Y
SET BYIMQUIT=1
QUIT
+10 IF Y=1
DO ASEDIT
QUIT
+11 IF Y=2
DO ASADD
QUIT
+12 IF Y=3
DO ASDEL
+13 QUIT
+14 ;-----
ASSEL ;SELECT ADDITION SITE
+1 IF J=1
SET Y=1
DO ASSEL1
QUIT
+2 KILL DIR
+3 SET DIR(0)="NO^1:"_J
+4 SET DIR("A")="Select site number"
+5 WRITE !!
+6 DO ^DIR
+7 KILL DIR
ASSEL1 IF 'Y
QUIT
+1 IF '$GET(BYIMAS(Y))
QUIT
+2 SET DA=BYIMAS(Y)
+3 QUIT
+4 ;-----
ASD ;DISPLAY SITES
+1 WRITE @IOF
+2 WRITE !!?10,"Additional EXPORT/IMPORT Site Directories"
+3 WRITE !!?5,"NUM",?10,"SITE/STATE"
+4 WRITE !?5,"---",?10,"--------------------------------------------------"
+5 NEW X0,X1
+6 SET J=0
+7 SET BYIMAS=0
+8 FOR
SET BYIMAS=$ORDER(^BYIMPARA(BYIMDA,3,BYIMAS))
IF 'BYIMAS
QUIT
Begin DoDot:1
+9 SET X0=$GET(^BYIMPARA(BYIMDA,3,BYIMAS,0))
+10 SET X1=$GET(^BYIMPARA(BYIMDA,3,BYIMAS,1))
+11 SET J=J+1
+12 SET BYIMAS(J)=BYIMAS
+13 WRITE !?5,J,?10,$PIECE(X0,U)
+14 WRITE !?15,"OUTBOUND: ",$PIECE(X0,U,2)
+15 WRITE !?15," INBOUND: ",$PIECE(X0,U,3)
End DoDot:1
+16 QUIT
+17 ;-----
ASADD ;ADD SITES
+1 NEW BYIMQUIT
+2 SET BYIMQUIT=0
+3 SET J=0
+4 NEW BYIMAS
+5 SET J=J+1
+6 KILL DIR
+7 SET DIR(0)="FO^1:10"
+8 SET DIR("A")="NEW interface state name"
+9 SET DIR("?")="Enter a name to identify the additional interface state, 3-10 characters"
+10 WRITE !!
+11 DO ^DIR
+12 KILL DIR
+13 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+14 IF X=""!(X[U)
SET BYIMQUIT=1
QUIT
+15 SET (NSITE,BYIMAS(J))=X
+16 SET DA(1)=BYIMDA
+17 SET DIC="^BYIMPARA("_BYIMDA_",3,"
+18 SET DIC(0)="L"
+19 IF '$DATA(^BYIMPARA(BYIMDA,3,0))
SET ^BYIMPARA(BYIMDA,3,0)="^90480.03"
+20 DO FILE^DICN
+21 IF Y<0
SET BYIMQUIT=1
QUIT
+22 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+23 NEW NSDA
+24 SET (NSDA,DA)=+Y
+25 NEW X,Y,Z,ZZ
+26 SET X=$PIECE(^BYIMPARA(BYIMDA,0),U,2)
+27 SET V=$SELECT(X["\":"\",1:"/")
+28 SET NSITE=$$LC(NSITE)
+29 SET X=$$LC(X)
+30 IF X["hlrbridge"
Begin DoDot:1
+31 SET X=$PIECE(X,"hl7bridge")
+32 IF $EXTRACT(X,$LENGTH(X))'=V
SET X=X_V
+33 SET Y=X_"hl7bridge"_V_NSITE_V_"responses"
+34 SET X=X_"hl7bridge"_V_NSITE_V_"requests"
End DoDot:1
IF 1
+35 IF '$TEST
Begin DoDot:1
+36 SET X=$PIECE(X,"requests")
+37 IF $EXTRACT(X,$LENGTH(X))'=V
SET X=X_V
+38 SET Y=X_NSITE_V_"responses"
+39 SET X=X_NSITE_V_"requests"
End DoDot:1
+40 SET $PIECE(^BYIMPARA(BYIMDA,3,NSDA,0),U,2)=X
+41 SET $PIECE(^BYIMPARA(BYIMDA,3,NSDA,0),U,3)=Y
+42 SET $PIECE(^BYIMPARA(BYIMDA,3,NSDA,0),U,4,13)=$PIECE(^BYIMPARA(BYIMDA,0),U,4,13)
+43 SET DA=NSDA
+44 DO ASE1
+45 QUIT
+46 ;-----
ASEDIT ;EDIT
+1 DO ASSEL
+2 IF '$GET(DA)
QUIT
ASE1 SET DA(1)=BYIMDA
+1 ;INCLUDE AGE TO EXPORT FOR ADD. SITES
+2 SET DR=".01T;.02T;.03T;.06T;1.03T;1.04T;1.05T;.07T;1.06T;1.07T;6.03T;6.04T;6.05T;1.08T;.15T;6.11T;6.08T;6.01T;6.02T;6.09T;.17T;6.1T;.08T;.1T;6.07T;.14T;.16T"
+3 SET DIE="^BYIMPARA("_BYIMDA_",3,"
+4 WRITE !!
+5 DO ^DIE
+6 KILL DA,DR,DIE
+7 QUIT
+8 ;-----
ASDEL ;DELETE
+1 DO ASSEL
+2 ;PATCH 8 CR 08549
+3 ;Q:DA
+4 IF '$GET(DA)
QUIT
+5 ;PATCH 8 END
+6 SET X=^BYIMPARA(BYIMDA,3,DA,0)
+7 WRITE !?10,$PIECE(X,U)
+8 KILL DIR
+9 SET DIR(0)="YO"
+10 SET DIR("A")="Delete export/import site: "_$PIECE(X,U)
+11 SET DIR("B")="NO"
+12 WRITE !
+13 DO ^DIR
+14 KILL DIR
+15 IF Y'=1
QUIT
+16 SET DA(1)=BYIMDA
+17 SET DIK="^BYIMPARA("_BYIMDA_",3,"
+18 DO ^DIK
+19 KILL DA,DIK
+20 QUIT
+21 ;-----
CP(DFN) ;EP;DETERMINE VARICELLA EXPOSURE
+1 ;DFN = PATIENT DFN
+2 IF '$DATA(^BIPC("B",+DFN))
QUIT
+3 NEW BIX,VDAT
+4 SET BIX=0
+5 FOR
SET BIX=$ORDER(^BIPC("B",DFN,BIX))
IF 'BIX
QUIT
IF $PIECE($GET(^BIPC(BIX,0)),U,3)=12
SET VDAT=$PIECE(^(0),U,4)
+6 IF $LENGTH($GET(VDAT))'=7
QUIT
+7 SET VDAT=VDAT+17000000
+8 SET RXA="RXA|0|1|"_VDAT_"|"_VDAT_"|998^No vaccine administered^CVX|999"
+9 SET OBX="OBX|1|CE|59784-9^Disease with presumed immunity ^LN|1|38907003^Varicella infection^SCT||||||F|CR|"
+10 NEW LINE
+11 SET LINE=$ORDER(^UTILITY("INH",$JOB,9999999999),-1)+1
+12 SET X=U_"UTILITY(""INH"","_$JOB_","_LINE_")"
+13 SET @X=RXA
+14 SET X=U_"UTILITY(""INH"","_$JOB_","_(LINE+1)_")"
+15 SET @X=OBX
+16 QUIT
+17 ;-----
IMMDUP ;EP;DEDUP IMMUNIZATIONS
+1 SET DIK="^AUPNVIMM("
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(^AUPNVIMM("AC",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+4 KILL TMP
+5 SET IEN=0
+6 FOR
SET IEN=$ORDER(^AUPNVIMM("AC",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 SET X=$PIECE($GET(^AUPNVIMM(IEN,0)),U,1,3)
+8 SET VIS=$PIECE(X,U,3)
+9 IF '$PIECE(X,U,2)!'X!'VIS
QUIT
+10 SET DAT=$PIECE($GET(^AUPNVSIT(VIS,0)),".")
+11 IF 'DAT
QUIT
+12 SET X=$PIECE(X,U,1,2)_U_DAT
+13 IF +X=242
SET $PIECE(X,U)=148
+14 IF +X=243
SET $PIECE(X,U)=148
+15 SET TMP(X,IEN)=""
End DoDot:2
+16 SET X=""
+17 FOR
SET X=$ORDER(TMP(X))
IF X=""
QUIT
Begin DoDot:2
+18 SET J=0
+19 SET IEN=0
+20 FOR
SET IEN=$ORDER(TMP(X,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+21 SET J=J+1
+22 IF J<2
QUIT
+23 IF '$DATA(ZTQUEUED)
WRITE !,DFN,?10,J,?15,IEN,?25,X,?45,$PIECE(^AUTTIMM(+X,0),U,3)
+24 MERGE ^BYIMTMP("BYIM IMM DUPS",DA)=^AUPNVIMM(DA)
+25 SET DA=IEN
+26 ;D ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;-----
DEXIT ;EP;CLEAN UP AFTER IZAD
+1 KILL ^BYIMTMP($JOB,"BYIM DISP")
+2 QUIT
+3 ;-----
ALOT(LDA,IVDA) ;EP;ACTIVATE LOT NUMBER
+1 IF 'LDA
QUIT
+2 IF '$DATA(^AUTTIML(LDA,0))
QUIT
+3 SET NEWLOT(LDA)=^AUTTIML(LDA,0)
+4 IF '$PIECE(NEWLOT(LDA),U,4)
Begin DoDot:1
+5 SET $PIECE(NEWLOT(LDA),U,4)=IVDA
+6 SET ^AUTTIML("C",IVDA,LDA)=""
End DoDot:1
+7 SET $PIECE(^AUTTIML(LDA,0),U,3)=0
+8 SET $PIECE(^AUTTIML(LDA,0),U,4)=IVDA
+9 QUIT
+10 ;-----
ILOT(LDA) ;EP;INACTIVATE LOT NUMBER
+1 IF 'LDA
QUIT
+2 IF '$DATA(^AUTTIML(LDA,0))
QUIT
+3 IF $GET(NEWLOT(LDA))]""
SET ^AUTTIML(LDA,0)=$GET(NEWLOT(LDA))
+4 KILL NEWLOT
+5 QUIT
+6 ;-----
LV(DFN,IVDA,LOTDA) ;EP;CALCULATE LAST V IMM FOR PAT
+1 IF '$GET(DFN)!'$GET(IVDA)!'$GET(LOTDA)
QUIT
+2 NEW XX,YY,ZZ
+3 SET XX=$ORDER(^AUPNVIMM("AC",DFN,9999999999),-1)
+4 IF 'XX
QUIT
+5 SET XX0=$GET(^AUPNVIMM(XX,0))
+6 IF +XX0'=IVDA
QUIT
+7 IF $PIECE(XX0,U,5)
QUIT
+8 SET $PIECE(^AUPNVIMM(XX,0),U,5)=LOTDA
+9 QUIT
+10 ;-----
MAN(MAN) ;EP;CHECK IMMUNIZATION MAN.
+1 IF MAN=""
QUIT
+2 IF MAN["\T\"
SET MAN=$PIECE(MAN,"\T\")_"&"_$PIECE(MAN,"\T\",2)
+3 NEW X,Y,Z
+4 SET X=MAN
+5 XECUTE ^%ZOSF("UPPERCASE")
+6 SET MAN=Y
+7 SET MANA=$PIECE(MAN,U)
+8 SET MANN=$PIECE(MAN,U,2)
+9 SET MANDA=$ORDER(^AUTTIMAN("B",MANN,0))
+10 IF MANDA
QUIT
+11 SET X=MANN
+12 SET DIC="^AUTTIMAN("
+13 SET DIC(0)="L"
+14 SET DIC("DR")=".02////"_MANA
+15 DO FILE^DICN
+16 IF Y>0
SET MANDA=+Y
+17 QUIT
+18 ;-----
LOT(LOT,MAN,IVDA) ;EP;EVALUATE LOT AND MANUFACTURER DATA
+1 SET LOTDA=""
+2 SET MANDA=""
+3 IF $GET(LOT)=""
QUIT
+4 IF MAN]""
DO MAN^BYIMIMM4(MAN)
+5 SET X=LOT
+6 XECUTE ^%ZOSF("UPPERCASE")
+7 SET LOT=Y
+8 SET LOTDA=$ORDER(^AUTTIML("B",LOT,0))
+9 IF LOTDA
DO ALOT(LOTDA,IVDA)
QUIT
+10 SET X=LOT
+11 SET DIC="^AUTTIML("
+12 SET DIC(0)="L"
+13 SET DIC("DR")=".02////"_$GET(MANDA)_";.03////1;.04////"_IVDA
+14 DO FILE^DICN
+15 IF Y<0
QUIT
+16 SET LOTDA=+Y
+17 DO ALOT(LOTDA,IVDA)
+18 QUIT
+19 ;-----
LOG(FILE,ACT,DFNCNT,IMMCNT,NODFNCNT,NEWIMCNT,ADDIMCNT,PATH,DFN) ;EP;LOG AUTO IMPORT FILES THAT HAVE BEEN PROCESSED
+1 ;FILE = NAME OF FILE IMPORTED OR EXPORTED
+2 ;ACT = ACTION - 'I'MPORT OR 'E'XPORT
+3 ;DFNCNT = NUMBER OF PATIENTS
+4 ;IMMCNT = NUMBER OF IMMUNIZATIONS
+5 ;NODFNCNT = NUMBER OF PATIENTS FOR WHOM THERE IS NO PATIENT MATCH
+6 ;NEWIMCNT = NUMBER OF NEW IMMUNIZATIONS
+7 ;ADDIMCNT = NUMBER OF NEW IMMUNIZATIONS ADDED TO V IMMUNIZATIONS
+8 ;PATH = DRIVE/DIRECTORY FILE SENT TO
+9 IF $GET(FILE)=""!($GET(ACT)="")
QUIT
+10 SET X=FILE
+11 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+12 SET DA(1)=$$DUZ^BYIMIMM()
+13 SET DIC="^BYIMPARA("_DA(1)_",2,"
+14 SET DIC(0)="L"
+15 SET DIC("DR")=".02////"_DT_";.03////"_ACT_";.04////"_$GET(DFNCNT)_";.05////"_$GET(IMMCNT)
+16 IF $GET(NODFNCNT)
SET DIC("DR")=DIC("DR")_";.06////"_NODFNCNT
+17 IF $GET(NEWIMCNT)
SET DIC("DR")=DIC("DR")_";.07////"_NEWIMCNT
+18 IF $GET(ADDIMCNT)
SET DIC("DR")=DIC("DR")_";.08////"_ADDIMCNT
+19 IF $GET(PATH)]""
SET DIC("DR")=DIC("DR")_";.09////"_PATH
+20 DO FILE^DICN
+21 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+22 NEW BYIMACT
+23 SET BYIMACT=$SELECT(ACT="I":"imported from",1:"exported to")
+24 ;-----
BULLETIN ;EP;CREATE EXPORT/IMPORT BULLETIN
+1 NEW %X,%Y,X,XMB,XMDT,XMDUZ,Y1
+2 SET XMB="BYIM EXPORT/IMPORT MESSAGE"
+3 SET XMB(1)="The file '"_FILE_"' was "_BYIMACT_" the State Immunization Registry on "_$$HTE^XLFDT($HOROLOG)
+4 SET XMDUZ=.5
+5 DO ^XMB
+6 QUIT
+7 ;-----
EXPBULL(BYIMHFNM,DEST,BYIMHDIR) ;EP;EXPORT FILE CREATION FAILED
+1 NEW %X,%Y,X,XMB,XMDT,XMDUZ,Y1
+2 SET XMB="BYIM EXPORT FILE FAILED"
+3 SET XMB(1)=BYIMHFNM
+4 SET XMB(2)=$PIECE($GET(^INRHD(+DEST,0)),U)
+5 SET XMB(3)=BYIMHDIR
+6 SET XMDUZ=.5
+7 DO ^XMB
+8 QUIT
+9 ;-----
LC(X) ;LOWERCASE
+1 SET X=$TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ ","abcdefghijklmnopqrstuvwxyz_")
+2 QUIT X
+3 ;-----
QPATH(BYIMDA) ;EP;QUERY DIRECTORIES
+1 QUIT
+2 IF '$GET(BYIMDA)
QUIT
+3 NEW V,X,Y,Z
+4 SET X=$PIECE($GET(^BYIMPARA(BYIMDA,0)),U,2)
+5 SET X=$$LC(X)
+6 SET V=$SELECT(X["\":"\",1:"/")
+7 IF X["hl7bridge"
Begin DoDot:1
+8 SET X=$PIECE(X,"hl7bridge")
+9 IF $EXTRACT(X,$LENGTH(X))'=V
SET X=X_V
+10 SET Y=X_"hl7bridge"_V_"queries"
+11 SET Z=X_"hl7bridge"_V_"qresponses"
End DoDot:1
IF 1
+12 IF '$TEST
Begin DoDot:1
+13 SET X=$PIECE(X,"requests")
+14 IF $EXTRACT(X,$LENGTH(X))'=V
SET X=X_V
+15 SET Y=X_"queries"
+16 SET Z=X_"qresponses"
End DoDot:1
+17 SET $PIECE(^BYIMPARA(BYIMDA,1),U)=Y
+18 SET $PIECE(^BYIMPARA(BYIMDA,1),U,2)=Z
+19 QUIT
+20 ;-----
LOGDFN ;EP;LOG PATIENTS INCLUDED IN EXPORT
+1 NEW DFN,TYPE
+2 SET TYPE="E"
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^BYIMTMP("LOG",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+5 DO LOGD(DFN,TYPE)
+6 KILL ^BYIMTMP("LOG",DFN)
End DoDot:1
+7 QUIT
+8 ;-----
LOGD(DFN,TYPE) ;EP;LOG EACH EXPORTED OR IMPORTED IMM
+1 NEW IMM,X,Y,Z
+2 IF $GET(TYPE)=""
SET TYPE="E"
+3 ;S DFNCNT=$G(DFNCNT)+1
+4 SET IMM=0
+5 FOR
SET IMM=$ORDER(^BYIMTMP("LOG",DFN,IMM))
IF 'IMM
QUIT
Begin DoDot:1
+6 IF $GET(BYIMALL)'=2
IF $DATA(^BYIMEXP("D",IMM))
QUIT
+7 IF $GET(BYIMMU2)
QUIT
+8 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+9 SET DIC="^BYIMEXP("
+10 SET DIC(0)="L"
+11 SET DIC("DR")=".02////"_DT_";.03////"_IMM_";.04////"_TYPE_";.05////"_$GET(XQY)_";.06////"_$GET(BYIMALL)
+12 SET X=DFN
+13 DO FILE^DICN
+14 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
End DoDot:1
+15 QUIT
+16 ;-----
DFN(UIF) ;FIND PATIENT DFN
+1 NEW X,Y,Z,LOC,HRN,DFN
+2 SET X=$PIECE($PIECE($GET(^INTHU(UIF,3,2,0)),"|",4),U)
+3 SET LOC=$EXTRACT(X,1,6)
+4 SET HRN=+$EXTRACT(X,7,12)
+5 IF 'LOC!'HRN
QUIT ""
+6 SET LOC=$ORDER(^AUTTLOC("C",LOC,0))
+7 IF 'LOC
QUIT ""
+8 SET DFN=""
+9 SET X=0
+10 FOR
SET X=$ORDER(^AUPNPAT("D",HRN,X))
IF 'X!DFN
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT("D",HRN,X,Y))
IF 'Y!DFN
QUIT
IF Y=LOC
SET DFN=X
+11 QUIT DFN
+12 ;-----
HFSA(DEST,BYIMHDIR,BYIMHFNM) ;EP - export from this destination
+1 ;PATCH 8 CR 08549 CHANGES TO CREATE MULTIPLE STATE FILES
+2 IF '$GET(DEST)
Begin DoDot:1
+3 SET ^BYIMTMP("EXP FAIL",$HOROLOG,"NO DEST")=BYIMHDIR_U_BYIMHFNM_U_DUZ
+4 SET BYIMFAIL=$GET(BYIMFAIL)+1
End DoDot:1
QUIT
+5 IF '$DATA(^INLHDEST(DEST))
Begin DoDot:1
+6 SET ^BYIMTMP("EXP FAIL",$HOROLOG,DEST,"NO MESSAGE")=BYIMHDIR_U_BYIMHFNM_U_DUZ
+7 SET BYIMFAIL=$GET(BYIMFAIL)+1
End DoDot:1
QUIT
+8 SET BYIMDUZ=$$DUZ^BYIMIMM()
+9 KILL ^BYIMTMP("DEST")
+10 MERGE ^BYIMTMP("DEST",BYIMDUZ,DEST)=^INLHDEST(DEST)
+11 NEW X
+12 SET X=0
+13 FOR
SET X=$ORDER(^BYIMPARA(BYIMDUZ,3,X))
IF 'X
QUIT
IF X'=BYIMDUZ
MERGE ^BYIMTMP("DEST",X,DEST)=^INLHDEST(DEST)
+14 NEW BYIMH,BYIMU
+15 SET STATE=0
+16 FOR
SET STATE=$ORDER(^BYIMTMP("DEST",STATE))
IF 'STATE
QUIT
DO HFSA1(DEST,STATE,BYIMHFNM)
+17 ;PATCH 8 CR 08549 END
+18 QUIT
+19 ;-----
HFSA1(DEST,STATE,BYIMHFNM) ;PROCESS EACH EXPORT FILE
+1 NEW XX,X0,X1,X6,PATH,FE,PI,ESSN
+2 ;MOVE ASSET CALL TO BYIMIMM5
+3 DO ASSET^BYIMIMM5(STATE)
+4 ;PATCH 8 CR 08385 - allow 'hl7' or 'dat' file extension
+5 SET BYIMHFNM=$PIECE(BYIMHFNM,".")_"."_$SELECT($GET(FE)]"":FE,1:"dat")
+6 ;PATCH 8 CR 08385 END
+7 SET Y=$$OPEN^%ZISH(PATH,BYIMHFNM,"W")
+8 IF Y
Begin DoDot:1
+9 DO EXPBULL(BYIMHFNM,DEST,PATH)
+10 SET ^BYIMTMP("EXP FAIL",$HOROLOG,DEST,"NO OPEN")=PATH_U_BYIMHFNM_U_DUZ
+11 SET BYIMFAIL=$GET(BYIMFAIL)+1
End DoDot:1
QUIT
+12 SET BYIMH=""
+13 FOR
SET BYIMH=$ORDER(^BYIMTMP("DEST",STATE,DEST,0,BYIMH))
IF BYIMH=""
QUIT
Begin DoDot:1
+14 SET BYIMU=0
+15 FOR
SET BYIMU=$ORDER(^BYIMTMP("DEST",STATE,DEST,0,BYIMH,BYIMU))
IF 'BYIMU
QUIT
Begin DoDot:2
+16 KILL ^BYIMTMP("ORIG",BYIMU)
+17 MERGE ^BYIMTMP("ORIG",BYIMU)=^INTHU(BYIMU)
+18 IF $GET(^INTHU(BYIMU,3,1,0))["VXU^V04"
Begin DoDot:3
+19 SET DFN=$$DFN(BYIMU)
+20 IF 'DFN
Begin DoDot:4
+21 KILL ^INLHDEST(DEST,0,BYIMH,BYIMU)
+22 KILL ^BYIMTMP("DEST",STATE,DEST,0,BYIMH,BYIMU)
End DoDot:4
QUIT
+23 SET ^BYIMTMP("BYIMIMM4",BYIMU)=DFN
+24 DO REFUSAL^BYIMSEG1(DFN,BYIMU)
End DoDot:3
IF 'DFN
QUIT
+25 DO LP(BYIMU,STATE)
+26 KILL ^INTHU(BYIMU)
+27 MERGE ^INTHU(BYIMU)=^BYIMTMP("ORIG",BYIMU)
+28 KILL ^INLHDEST(DEST,0,BYIMH,BYIMU)
+29 KILL ^BYIMTMP("DEST",STATE,DEST,0,BYIMH,BYIMU)
End DoDot:2
End DoDot:1
+30 KILL ^BYIMTMP("BYIMIMM4")
+31 KILL ^BYIMTMP("ORIG")
+32 DO ^%ZISC
+33 IF '$GET(BYIMTEST)
DO LOGDFN
+34 QUIT
+35 ;-----
LP(BYIMUIEN,AS) ;EP - loop through UIF and set to file
+1 ;INCLUDE AGE TO EXPORT CHECK FOR ADD. SITES
+2 IF 'AGE
IF $PIECE(^BYIMPARA(BYIMDUZ,0),U,6)
IF $$AGECHK^BYIMIMM5(BYIMUIEN)
QUIT
+3 IF IO["\\"
Begin DoDot:1
+4 FOR J=1:1:$LENGTH(IO,"\\")
SET X=$PIECE(IO,"\\",J)_"\"
+5 SET IO=$EXTRACT(X,1,$LENGTH(X)-1)
End DoDot:1
+6 IF IO["//"
Begin DoDot:1
+7 FOR J=1:1:$LENGTH(IO,"//")
SET X=$PIECE(IO,"//",J)_"/"
+8 SET IO=$EXTRACT(X,1,$LENGTH(X)-1)
End DoDot:1
+9 IF $GET(PI)
IF $GET(^INTHU(BYIMUIEN,3,1,0))["VXU^V04"
IF $$PI(BYIMUIEN)
QUIT
+10 NEW BYIMUDA
+11 SET BYIMUDA=0
+12 FOR
SET BYIMUDA=$ORDER(^INTHU(BYIMUIEN,3,BYIMUDA))
IF 'BYIMUDA
QUIT
Begin DoDot:1
+13 SET SEGX=$GET(^INTHU(BYIMUIEN,3,BYIMUDA,0))
+14 IF SEGX=""
QUIT
+15 IF SEGX["PID|"
IF $GET(ESSN)
IF SEGX["SSA^SS"!($PIECE(SEGX,"|",20)]"")
DO ESSN(SEGX)
+16 IF SEGX["PID|"!(SEGX["IN1|")
IF $GET(DFN)
IF SEGX["MEDICARE"!(SEGX["MCR^MC")
DO MCR(SEGX)
+17 IF SEGX'["|CR|"
Begin DoDot:2
+18 SET BYIMUDA=BYIMUDA+1
+19 SET SEGX=SEGX_$GET(^INTHU(BYIMUIEN,3,BYIMUDA,0))
+20 IF SEGX["|CR|"
QUIT
+21 SET BYIMUDA=BYIMUDA+1
+22 SET SEGX=SEGX_$GET(^INTHU(BYIMUIEN,3,BYIMUDA,0))
End DoDot:2
+23 IF SEGX'["|CR|"
QUIT
+24 ;PATCH 8 CR 08781 - CPT CODE
+25 IF SEGX["RXA|"
IF $GET(CPT)]""
DO CPT(CPT)
+26 ;PATCH 8 CR 08781 END
+27 IF SEGX["FHS|"
SET $PIECE(SEGX,"|",9)=BYIMHFNM
SET $PIECE(SEGX,"|",11)=$EXTRACT($TRANSLATE($HOROLOG,","),1,7)
+28 IF SEGX["BHS|"
SET $PIECE(SEGX,"|",11)=$EXTRACT($TRANSLATE($HOROLOG,","),1,7)
+29 IF '$GET(IN1)
IF SEGX["IN1|"!(SEGX["IN2|")
QUIT
+30 IF "|MSH|FHS|BHS|BTS|FTS|"'[("|"_$EXTRACT(SEGX,1,3)_"|")
SET SEGX=$TRANSLATE(SEGX,"\&")
+31 IF $EXTRACT(SEGX,1,4)'?2U1UN1"|"
QUIT
+32 IF "|BTS|FTS|"'[("|"_$EXTRACT(SEGX,1,3)_"|")
DO AE
+33 USE IO
WRITE $PIECE(SEGX,"|CR|"),!
End DoDot:1
+34 QUIT
+35 ;-----
AE ;PROCESS ADDITIONAL SITE EXPORT FILE
+1 IF $EXTRACT(SEGX,1,4)="PID|"
IF $GET(ESSN)
IF SEGX["SSA^SS"
DO ESSN(SEGX)
+2 DO SET
+3 QUIT
+4 ;-----
SET ;CUSTOMIZE MSH SEGMENT
+1 NEW A,B,X,Y,Z
+2 SET SEG=$EXTRACT(SEGX,1,3)
+3 SET X=0
+4 FOR
SET X=$ORDER(XX(SEG,X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=0
+6 FOR
SET Y=$ORDER(XX(SEG,X,Y))
IF 'Y
QUIT
SET Z=XX(SEG,X,Y)
IF Z]""
Begin DoDot:2
+7 IF SEG="MSH"
IF X=11
IF '$GET(BYIMTEST)
QUIT
+8 IF SEG="RXA"
IF X=6
IF Y=1
IF $PIECE(SEGX,"|",7)
IF $PIECE(SEGX,"|",7)<100
QUIT
+9 SET B=X
+10 IF "MSHFHSBHS"'[SEG
SET B=X+1
+11 SET A=$PIECE(SEGX,"|",B)
+12 SET $PIECE(A,U,Y)=Z
+13 SET $PIECE(SEGX,"|",B)=A
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;-----
PI(UIEN) ;ELIMINATE HL7 MESSAGE IF PATIENT PRIVACY NOT ON FILE
+1 NEW HRN,LOC,X,Y,Z,XX
+2 SET DFN=+$GET(^BYIMTMP("BYIMIMM4",UIEN))
+3 IF 'DFN
SET DFN=+$$DFN(UIEN)
+4 IF 'DFN
QUIT 1
+5 IF $PIECE($GET(^BIP(DFN,0)),U,24)
QUIT 0
+6 QUIT 1
+7 ;-----
CPT(CPT) ;ADJUST RXA-5 FOR CPT
+1 ;PATCH 8 CR 08781 - CPT CODE
+2 NEW X,Y,Z
+3 SET X=$PIECE(SEGX,"|",6)
+4 IF CPT=123
QUIT
+5 IF CPT=0
SET X=$PIECE(X,"~")
+6 IF CPT=1
IF $PIECE(X,"~",2)]""
SET X=$PIECE(X,"~",2)
+7 IF CPT=2
SET X=$PIECE(X,"~",1,2)
+8 ;I CPT=1 S X=$P(X,"~")
+9 ;I CPT=2,$P(X,"~",2)="" S X=$P(X,"~",2)
+10 ;I CPT=3,$P(X,"~",3)]"" S X=$P(X,"~",3)
+11 ;I CPT=12 S X=$P(X,"~",1,2)
+12 ;I CPT=13 S X=$P(X,"~")_"~"_$P(X,"~",3)
+13 ;I CPT=23 S X=$P(X,"~",2)_"~"_$P(X,"~",3)
+14 SET $PIECE(SEGX,"|",6)=X
+15 QUIT
+16 ;-----
ESSN(SEGX) ;REMOVE SSN
+1 NEW J,X,Y,Z,XX
+2 SET X=$PIECE(SEGX,"|",4)
+3 SET XX=""
+4 FOR J=1:1
SET Y=$PIECE(X,"~",J)
IF Y=""
QUIT
IF Y["SSA^SS"
SET XX=$PIECE(X,"~",1,J-1)
IF $PIECE(X,"~",J+1)]""
SET XX=XX_"~"_$PIECE(X,"~",J+1,99)
+5 SET $PIECE(SEGX,"|",4)=XX
+6 SET $PIECE(SEGX,"|",20)=""
+7 QUIT
+8 ;-----
MCR(SEGX) ;REMOVE SSN
+1 NEW J,X,Y,Z,XX
+2 SET X=$PIECE(SEGX,"|",4)
+3 SET XX=""
+4 FOR J=1:1
SET Y=$PIECE(X,"~",J)
IF Y=""
QUIT
IF Y["MEDICARE"!(Y["MCR^MC")
SET XX=$PIECE($PIECE(X,"~",J),U)
IF XX[$PIECE($GET(^DPT(DFN,0)),U,9)
SET XX=$PIECE(X,"~",1,J-1)_"~"_$PIECE(X,"~",J+1,99)
+5 SET $PIECE(SEGX,"|",4)=XX
+6 IF SEGX["PID|"
SET $PIECE(SEGX,"|",20)=""
+7 QUIT
+8 ;-----
