BYIMIMM ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
;
;----
ENV ;EP;
F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
N BYIMDA
S BYIMDA=+^AUTTSITE(1,0)
I '$D(^BYIMPARA(+BYIMDA,0)) D
.K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
.S DIC="^BYIMPARA("
.S DIC(0)="L"
.S (X,DINUM)=+^AUTTSITE(1,0)
.D FILE^DICN
.K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
.S BYIMDA=+Y
I $D(^BYIMPARA(BYIMDA)),'$D(^BYIMPARA(BYIMDA,0)) D
.S ^BYIMPARA(BYIMDA,0)=BYIMDA
.S ^BYIMPARA("B",BYIMDA,BYIMDA)=""
Q
;-----
DE ;EP;IMMUNIZATION EXPORT
N BYIMJOB,BYIMY,BYIMRMSG,BYIMY,BYIMX,DA,DIC,DIE,DIK,DR,DIR,D19,DD19,DATE,DDATE,DDDATE,DATE19,DEST,ENC,EVDT,FACILITY,BYIMFILE,INA,MSG,NUM,OPATH,IPATH,ZTDESC,ZTDTC,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,VALMBCK,XPDDIQ,BYIMCNT
N AGE,AGE19,MSGCNT,DFNCNT,IMMCNT,BYIMQUIT
N BYIMDATE,DEND
D PATH
I OPATH="" D NOPATH Q
K BYIMQUIT
I '$D(ZTQUEUED) D Q:$D(BYIMQUIT)
.N WRITING,DE
.S DE=""
.D READY:$O(^BYIMPARA($$DUZ(),"LAST EXPORT",0))
.I $D(WRITING) D Q:$D(BYIMQUIT)
..D RESTART
DATE ;EP;SELECT EXPORT DATE
K BYIMQUIT
N DATE,X,Y,Z,BYIMDUZ
S Y=2,BYIMDUZ(Y)=DUZ(2),BYIMALL=1,BYIMADM=1
I '$D(^BYIMPARA($$DUZ(),0)),+$G(^AUTTSITE(1,0)) D
.S X=+^AUTTSITE(1,0)
.I $D(^BYIMPARA(X,0)) S Y=2,DUZ(Y)=X
I '$D(^BYIMPARA($$DUZ(),0)) D
.S X=0
.F S X=$O(^BYIMPARA(X)) Q:'X I $D(^BYIMPARA(X,0)) S Y=2,DUZ(Y)=X Q
Q:'$D(^BYIMPARA($$DUZ(),0))
D DATE19
S (DATE,D19)=0
S X=9999999999
F S X=$O(^BYIMPARA($$DUZ(),"LAST EXPORT",X),-1) Q:'X!DATE D
.S:$P(^BYIMPARA($$DUZ(),"LAST EXPORT",X),U)&$P(^(X),U,2) (DATE,D19)=X
I DATE D D1 Q:$D(BYIMQUIT)
I 'DATE D
.S (DATE,D19)=$S(YEARS=19:DATE19,1:DATE99)
.Q:$D(ZTQUEUED)
.W !!,"The date of the last Immunization export is not on file."
.W !,"The export will include all Children 0-18 years of age."
I '$D(ZTQUEUED) D Q:$D(BYIMQUIT)
.D ALL^BYIMRT
.W !!,"Evaluation of immunizations for export to the State Immunization"
.W !,"registry may take several minutes."
.S DIR(0)="YO"
.S DIR("A")="Do you want to proceed"
.S DIR("B")="NO"
.W !
.D ^DIR
.K DIR
.I Y'=1 S BYIMQUIT=""
K ^BYIMTMP($J,"BYIM EXP")
N X,Y,Z,ZZ,MSGCNT,DFN,BYIMQUIT,XX
S XX=$P($H,",",2)
;PATCH 8
D PATH
I OPATH="" D NOPATH Q
S:'$G(BYIMFAIL) BYIMFAIL=""
;END PATCH 8
D FN
S ^BYIMTMP("BYIMFILE")=BYIMFILE
I $D(^BYIMPARA($$DUZ(),"LAST EXPORT")) D LE Q
I '$D(^BYIMPARA($$DUZ(),"LAST EXPORT")) D NLE Q
Q
;-----
DEX ;EP;TO CREATE ACTUAL HL7 MESSAGES
;M ^TMP("BYIMTMP")=^BYIMTMP
D HEADER
S:'$G(BYIMALL) BYIMALL=1
S:'$G(BYIMADM) BYIMADM=1
S:'$G(DDDATE) DDDATE=""
K ^BYIMTMP("LOG")
S (MSGCNT,DFN,DFNCNT,IMMCNT)=0
F S DFN=$O(^BYIMTMP($J,"BYIM EXP",DFN)) Q:'DFN D
.;PATCH 8 CR 08549 CHANGES TO CREATE MULTIPLE STATE FILES
.;INCLUDE ALL PATIENT - SCREEN AT FILE CREATION
.;I $P(^BYIMPARA($$DUZ(),0),U,10),'$P($G(^BIP(DFN,0)),U,24) Q
.;PATCH 8 CR 08549 END
.S DA=$O(^BYIMTMP($J,"BYIM EXP",DFN,0))
.Q:'DA
.W:'$D(ZTQUEUED) "/"
.S MSG=$$V04(DA,BYIMALL,BYIMADM,DDDATE)
.Q:MSG'["Message Created Successfully"
.S MSGCNT=MSGCNT+1
.S DFNCNT=DFNCNT+1
.S IMMCNT=IMMCNT+$$IMMCNT(DFN)
.S ^BYIMTMP("LOG",DFN)=""
S ^BYIMTMP("NUM")=MSGCNT_U_DFNCNT_U_IMMCNT
S BYIMJOB=$J
K ^BYIMTMP($J,"BYIM EXP")
S XX=$P($H,",",2)-XX
ZIS S ZTRTN="HFSA^BYIMIMM"
S ZTDESC="IMMUNIZATION INTERFACE"
F X="BYIM*","DFN*","MSG*","IMM*" S ZTSAVE(X)=""
S ZTIO=""
S ZTDTC=$H
D ^%ZTLOAD
I $G(X)[U D Q
.W !!,"The export has been terminated."
.D PAUSE
.S BYIMQUIT=""
.D RES1
OUT I '$D(ZTQUEUED) D
.W !!?10,IMMCNT," immunizations for ",MSGCNT," ",CHILD," 0-",YEARS
.W !?10,"were evaluated in "
.N M,S
.S M=XX\60
.S S=XX#60
.I M]"" W M," minutes"
.I S]"" W ", ",S," seconds"
.W "."
.D PATH
.I OPATH="" D NOPATH Q
.W !!?10,"The file '",BYIMFILE,"' will now be created in the"
.W !?10,"'",OPATH,"' directory. This may take several minutes."
.W !!?10,"It can be retrieved from this directory for transfer"
.W !?10,"to the State registry."
.D PAUSE
Q
;-----
HFSA ;EP;TO PROCESS EXPORT
H 60
S:'$G(BYIMTEST)&'$D(^BYIMPARA($$DUZ(),"LAST EXPORT",DT)) ^BYIMPARA($$DUZ(),"LAST EXPORT",DT)=$H
N READY
S READY=""
D READY
I $D(BYIMQUIT) K BYIMQUIT G HFSA
S DEST=$O(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
N PRI
S PRI=+$O(^INLHDEST(DEST,""))
D HFSA^BYIMIMM6(DEST,PRI)
S NUM=$G(^BYIMTMP("NUM"))
S DFNCNT=$P(NUM,U,2)
S IMMCNT=$P(NUM,U,3)
S NUM=+NUM
N J,X,Y
S J=0
S X=""
F S X=$O(^INLHDEST(DEST,PRI,X)) Q:X="" D
.S Y=0
.F S Y=$O(^INLHDEST(DEST,PRI,X,Y)) Q:'Y S J=J+1
G:J<NUM HFSA
D FOOTER
D:$G(BYIMTEST) CLEAN^BYIMIMM5
H 30
S ^TMP($J,"BYIM","CLEAN","BEFORE")=$D(^INLHDEST(DEST))
D CLEAN
S ^TMP($J,"BYIM","CLEAN","AFTER")=$D(^INLHDEST(DEST))
HFSARES ;EP;RESTART EXPORT WHEN FILE NOT CREATED
S DEST=$O(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
N PRI
S PRI=+$O(^INLHDEST(DEST,""))
S NUM=$G(^BYIMTMP("NUM"))
K ^BYIMTMP("NUM"),^("BYIMFILE")
S DFNCNT=$P(NUM,U,2)
S IMMCNT=$P(NUM,U,3)
S NUM=+NUM
D PATH
I OPATH="" D NOPATH Q
S:'$G(BYIMFAIL) BYIMFAIL=""
D FN
D HFSA^BYIMIMM4(DEST,OPATH,BYIMFILE)
I $G(BYIMFAIL)=1 H 10 G HFSARES
I $G(BYIMFAIL)>1 S:'$G(BYIMTEST) $P(^BYIMPARA($$DUZ(),"LAST EXPORT",DT),U,2)="ExportFail" Q
S:'$G(BYIMTEST) $P(^BYIMPARA($$DUZ(),"LAST EXPORT",DT),U,2)=$H
D LOG^BYIMIMM4(BYIMFILE,"E",DFNCNT,IMMCNT,,,,OPATH)
K ^BYIMTMP("NUM")
K ^BYIMTMP("BYIMFILE")
;PATCH 8 CR 08549 PROCESS FILES FOR MULTIPLE STATES
;D ADDEX
;PATCH 8 CR 08549 END
Q
;-----
READY ;EP;
N X,Y,Z
S X=""
F S X=$O(^INLHSCH(0,X)) Q:X=""!$D(BYIMQUIT) D
.S Y=0
.F S Y=$O(^INLHSCH(0,X,Y)) Q:'Y!$D(BYIMQUIT) D
..S:$G(^INTHU(Y,3,1,0))["V04" BYIMQUIT=""
I '$D(BYIMQUIT) D Q
.S DEST=$O(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
.I '$D(READY),$D(^INLHDEST(+DEST)) D Q
..W:'$D(ZTQUEUED) !!,"Immunization data file creation still in process."
..S WRITING=""
..H 4
.Q:$D(ZTQUEUED)!$D(DE)
.N NUM
.S NUM=+$G(^BYIMTMP("NUM"))
.H 2
.W !!,"The Immunization data export file is ready for transmission"
.W !,"to the state immunization registry."
.H 4
.N J,X,Y,NUM,PRI
.S PRI=0
.S J=0
.S X=""
.F S X=$O(^INLHDEST(DEST,PRI,X)) Q:X="" D
..S Y=0
..F S Y=$O(^INLHDEST(DEST,PRI,X,Y)) Q:'Y S J=J+1
.S $P(^BYIMTMP("NUM"),U)=J
Q:$D(ZTQUEUED)
W !!,"Immunization data export still in process."
S J=0
S X=""
F S X=$O(^INLHSCH(0,X)) Q:X="" D
.S Y=0
.F S Y=$O(^INLHSCH(0,X,Y)) Q:'Y D
..S:$G(^INTHU(Y,3,1,0))["V04" J=J+1
W " (",J,")"
H 2
Q
;-----
V04(BYIMVST,BYIMALL,BYIMADM,DDDATE) ;this is the unsolicited Imm record
I 'BYIMVST Q $$MSG("VST")
D PATH
S BYIMPAT=$P($G(^AUPNVSIT(BYIMVST,0)),U,5)
S INDA=BYIMPAT
S INDA(9000010,1)=BYIMVST
S INDA(2,1)=BYIMPAT
S INDA("BYIMALL")=$G(BYIMALL)
S INDA("BYIMADM")=$G(BYIMADM)
S INDA("DDDATE")=$G(DDDATE)
S BYIMPAR="HL IHS IZV04 OUT PARENT"
D ^INHF(BYIMPAR,.INDA)
D EOJ
Q $$MSG(INHF)
;-----
S DEST=$O(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
K ^INLHDEST(+DEST)
D NOW^%DTC
S INA("EVDT")=%
S EVDT="INA(""EVDT"")"
S INA("ENC")="^~\&"
S ENC="INA(""ENC"")"
S INA("FACILITY")=$P($G(^DIC(4,$$DUZ(),0)),U)
S FACILITY="INA(""FACILITY"")"
L +^INTHU(0):DTIME
S INDA=$P(^INTHU(0),U,3)
D ^INHF("HL IHS IZV04 OUT HEADER PARENT",.INDA,.INA)
L -^INTHU(0)
D EOJ
Q
;-----
S INDA=$P(^INTHU(0),U,3)+1
D ^INHF("HL IHS IZV04 OUT FOOTER PARENT",.INDA,.INA)
D EOJ
Q
;-----
EOJ ;EP;kills variables
K INDA,BYIMPAT,BYIMVST,BYIMVAIN,BYIMADT
Q
;-----
MSG(BYIMMVAR) ;-- return message defining status
I BYIMMVAR="PAT" S BYIMRMSG="Patient Not Passed In, Message Not Created"
I BYIMMVAR="VST" S BYIMRMSG="Visit Not Passed In, Message Not Created"
I BYIMMVAR="VLAB" S BYIMRMSG="VLAB Not Passed In, Message Not Created"
I BYIMMVAR="MFL" S BYIMRMSG="Mstr File Not Passed In, Message Not Created"
I BYIMMVAR=0 S BYIMRMSG="Message Not Created, problem with GIS call"
I BYIMMVAR S BYIMRMSG=BYIMMVAR_U_"Message Created Successfully"
Q $G(BYIMRMSG)
;-----
IMZIS S ZTRTN="HFSARES^BYIMIMM"
S ZTDESC="IMMUNIZATION INTERFACE"
S ZTIO=""
S ZTSAVE("BYIMJOB")=""
S ZTDTC=$H
D ^%ZTLOAD
Q
;-----
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
N I
F I=1:1:$L(Z) I (32>$A($E(Z,I))) S Z=$E(Z,1,I-1)_" "_$E(Z,I+1,999)
Q Z
;-----
BACK S VALMBCK="R"
Q
;-----
MPORT ;EP;run the import package utility
I $O(^INXPORT(""))="" D Q
. W !,"Global ^INXPORT missing, please restore and the global."
S BYIMIT=$O(^INXPORT(""))
S BYIMIST=$O(^INXPORT(BYIMIT,""))
S BYIMIPK=$O(^INXPORT(BYIMIT,BYIMIST,""))
W !,"Importing GIS "_$G(BYIMIT)_" Supplement "_$G(BYIMIPK)
W ", developing site "_$G(BYIMIST)
D ^BYIMPORT
W !,"Finished Importing GIS Supplement "
K BYIMIT,BYIMIST,BYIMIPK
Q
;-----
RESTART ;EP;
S DIR(0)="YO"
W !!,"Do you want to restart the export?"
S DIR("B")="NO"
D ^DIR
K DIR
I Y'=1 S BYIMQUIT="" Q
D HFSARES
Q:'$G(BYIMFAIL)
D RES1
D PATH
I OPATH="" D NOPATH Q
D FN
S Y=$$DEL^%ZISH(OPATH,BYIMFILE)
Q
;-----
RES1 ;CLEAR CURRENT EXPORT QUEUE
S DEST=$O(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
K ^INLHDEST(DEST)
N X,Y,Z,BYIMQUIT
S X=""
F S X=$O(^INLHSCH(0,X)) Q:X=""!$D(BYIMQUIT) D
.S Y=0
.F S Y=$O(^INLHSCH(0,X,Y)) Q:'Y!$D(BYIMQUIT) D
..I $G(^INTHU(Y,3,1,0))["V04" K ^INLHSCH(0,X,Y)
Q
;-----
DATE19 ;SET AGE FOR EXPORT
N Y
S Y=$P($G(^BYIMPARA($$DUZ(),0)),U,6)
S YEARS=$S('Y:19,Y=1:65,1:99)
S CHILD=$S('Y:"Children",1:"Patients")
S (AGE,AGE19)=19*10000
S DATE19=DT-(19*10000)
S AGE65=65*10000
S DATE65=DT-(65*10000)
S AGE99=99*10000
S DATE99=DT-(99*10000)
S D19=$S(YEARS=19:DATE19,YEARS=65:DATE65,1:DATE99)
Q
;-----
ADDEX ;EP;PROCESS ADDITIONAL EXPORT SITES
;PATCH 8 CR 08627 CORRECT 'COPY' FOR MULTI-SITES
;PATCH 8 CR 08627 END
Q
;-----
LE ;PROCESS SEQUENTIAL EXPORT
S:'$G(DDDATE) DDDATE=""
S:'$G(DEND) DEND=9999999
S D19=D19-.01
F S D19=$O(^AUPNVSIT("APCIS",D19)) Q:'D19!(D19>DEND) D
.S DA=0
.F S DA=$O(^AUPNVSIT("APCIS",D19,DA)) Q:'DA D
..S X=$G(^AUPNVSIT(DA,0))
..S DFN=$P(X,U,5)
..Q:'DFN
..Q:$D(^BYIMTMP($J,"BYIM EXP",DFN))
..Q:$G(^DPT(DFN,.35))!'$O(^AUPNPAT(DFN,41,0))!'$G(^AUPNPAT(DFN,0))
..S X=$G(^DPT(DFN,0))
..Q:X=""
..Q:X["PATIENT,ERROR"!(X["ERROR,PATIENT")!(X["DEMO,PAT")
..;FILTER OUT KIDS WITHOUT PERMANENT NAME
..Q:X["BABY "!(X["BABY ")
..;PATCH 8 CR 08549 CHANGES TO CREATE MULTIPLE STATE FILES
..;Q:$P($G(^BIP(DFN,0)),U,24)=0
..S:'$G(BYIMALL) BYIMALL=1
..S:'$G(BYIMADM) BYIMADM=1
..S:'$G(DDATE) DDATE=""
..;PATCH 8 CR 08549 END
..I YEARS=19 Q:$P(X,U,3)<DATE19
..I YEARS=65 Q:$P(X,U,3)<DATE19&($P(X,U,3)>DATE65)
..I BYIMALL,BYIMALL'=2!(BYIMADM&BYIMADM'=2) Q:'$$NEW^BYIMIMM6(DFN,BYIMALL,BYIMADM,DDDATE)
..S ^BYIMTMP($J,"BYIM EXP",DFN,DA)=""
..W:'$D(ZTQUEUED) "."
I '$O(^BYIMTMP($J,"BYIM EXP",0)) D Q
.S BYIMFILE="NoImmsToExp_"_$P($G(^AUTTLOC($$DUZ(),0)),U,10)_"_"_(DT+17000000)_"_"_$P($H,",",2)_".dat"
.S:'$G(BYIMTEST) $P(^BYIMPARA($$DUZ(),"LAST EXPORT",DT),U)=$H,$P(^(DT),U,2)=$H
.S DFNCNT=0
.S IMMCNT=0
.D PATH^BYIMIMM6
.D LOG^BYIMIMM4(BYIMFILE,"E",DFNCNT,IMMCNT,,,,OPATH)
.S:'$G(BYIMTEST) $P(^BYIMPARA($$DUZ(),"LAST EXPORT",DT),U,2)="NoImmsToExp"
.Q:$D(ZTQUEUED)
.W !!,"No Immunizations found that need to be exported."
.D PAUSE
D DEX
S Y=2,DUZ(Y)=BYIMDUZ(2)
Q
;-----
NLE ;PROCESS FIRST EXPORT
N BYIMALL
S BYIMALL=2
S BYIMADM=2
F S D19=$O(^DPT("ADOB",D19)) Q:'D19 D
.S DFN=0
.F S DFN=$O(^DPT("ADOB",D19,DFN)) Q:'DFN D
..Q:$G(^DPT(DFN,.35))!'$G(^AUPNPAT(DFN,0))
..S X=$G(^DPT(DFN,0))
..Q:X["PATIENT,ERROR"!(X["ERROR,PATIENT")!(X["DEMO,PAT")!($E(X,1,2)="ZZ")!$P(X,U,19)
..S X=$O(^AUPNVSIT("AC",DFN,9999999999),-1)
..Q:'X
..Q:'$G(^AUPNVSIT(X,0))
..Q:+^AUPNVSIT(X,0)<DATE
..Q:$O(^BYIMTMP($J,"BYIM EXP",DFN,0))
..S ^BYIMTMP($J,"BYIM EXP",DFN,X)=""
..W:'$D(ZTQUEUED) "."
D DEX
S Y=2,DUZ(Y)=BYIMDUZ(2)
Q
;-----
D1 ;PROCESS WHEN DATE IDENTIFIED
S (Y,DDDATE)=DATE
X ^DD("DD")
S DDATE=Y
S Y=DT-AGE
X ^DD("DD")
S DD19=Y
Q:$D(ZTQUEUED)
W @IOF
W !!,"The last Immunization export ran on: ",DDATE
I YEARS=19 D
.W !,"Children 18 and under were born after: ",DD19
W !!,"This export will include: ",!
I YEARS=19 D
.W !?5,"Children 18 and under"
I YEARS=65 D
.W !?5,"Children 18 and under and"
.W !?5,"Adults.. 65 and over"
I YEARS=99 D
.W !?5,"All patients"
W !!,"who have had a visit since the last export."
W !,"You can enter another date for the export."
S DIR(0)="DO"
S DIR("A")="Export Immunizations given since "_DDATE
S DIR("B")=DDATE
W !
D ^DIR
K DIR
I 'Y S BYIMQUIT="" Q
S (BYIMDATE,DATE,D19)=Y
S Y=DT
X ^DD("DD")
S DEND=Y
S DIR(0)="DO"
S DIR("A")="Exclude Immunizations given after "_DEND
S DIR("B")=DEND
W !
I D19=DT S Y=DT
I D19<DT D ^DIR
K DIR
I 'Y S BYIMQUIT="" Q
S DEND=Y
Q
;-----
PATH ;EP;SET PATH
D PATH^BYIMIMM6
Q
;-----
NOPATH ;EP;NO PATH MESSAGE
D NOPATH^BYIMIMM6
Q
;-----
PAUSE ;EP;FOR PAUSE READ
D PAUSE^BYIMIMM6
Q
;-----
CLEAN ;CLEAN OUT MESSAGES WITH NO RXA SEGMENT, BLANK RXR AND OBX SEGMENTS
N DEST,QUIT,X,Y,Z,XX,ZZ
S DEST=$O(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
Q:'DEST
S X=""
F S X=$O(^INLHDEST(DEST,X)) Q:'X D
.S Y=""
.F S Y=$O(^INLHDEST(DEST,X,Y)) Q:Y="" D
..S Z=0
..F S Z=$O(^INLHDEST(DEST,X,Y,Z)) Q:'Z D
...S QUIT=0
...S ZZ=0
...F S ZZ=$O(^INTHU(Z,3,ZZ)) Q:'ZZ S XX=^(ZZ,0) D
....I XX["RXA" S QUIT=1 Q
....I XX["RXR||" K ^INTHU(Z,3,ZZ,0) Q
....I XX["OBX|"&(XX["V00") K ^INTHU(Z,3,ZZ,0)
...Q:QUIT
...K ^INLHDEST(DEST,X,Y,Z)
Q
;-----
IMMCNT(DFN) ;COUNT PT IMMS TO BE EXPORTED
N X,Y,Z
S Y=0
S X=0
F S X=$O(^AUPNVIMM("AC",DFN,X)) Q:'X D
.I $G(BYIMALL)=2 S Y=Y+1,^BYIMTMP("LOG",DFN,X)="" Q
.I '$D(^BYIMEXP("D",X)) S Y=Y+1,^BYIMTMP("LOG",DFN,X)=""
Q Y
;-----
FN ;EP;SET FILE NAME
S:'$G(ASUFAC) ASUFAC=$P($G(^AUTTLOC($$DUZ(),0)),U,10)
S:$G(BYIMFILE)="" BYIMFILE="izdata_"_$G(ASUFAC)_"_"_(DT+17000000)_"_"_$P($H,",",2)_$S($G(BYIMTEST):"_test",1:"")_"."_BYIMEXT
Q
;-----
DUZ() ;PRIMARY PARAM SITE
N X,Y,Z
S Y=0
S X=0
F S X=$O(^BYIMPARA(X)) Q:'X I X=+^AUTTSITE(1,0) S Y=X
I 'Y S X=0 F S X=$O(^BYIMPARA(X)) Q:'X I $D(^BYIMPARA(X,0)) S Y=X
Q Y
;-----
BYIMIMM ;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 ;----
ENV ;EP;
+1 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+2 NEW BYIMDA
+3 SET BYIMDA=+^AUTTSITE(1,0)
+4 IF '$DATA(^BYIMPARA(+BYIMDA,0))
Begin DoDot:1
+5 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+6 SET DIC="^BYIMPARA("
+7 SET DIC(0)="L"
+8 SET (X,DINUM)=+^AUTTSITE(1,0)
+9 DO FILE^DICN
+10 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+11 SET BYIMDA=+Y
End DoDot:1
+12 IF $DATA(^BYIMPARA(BYIMDA))
IF '$DATA(^BYIMPARA(BYIMDA,0))
Begin DoDot:1
+13 SET ^BYIMPARA(BYIMDA,0)=BYIMDA
+14 SET ^BYIMPARA("B",BYIMDA,BYIMDA)=""
End DoDot:1
+15 QUIT
+16 ;-----
DE ;EP;IMMUNIZATION EXPORT
+1 NEW BYIMJOB,BYIMY,BYIMRMSG,BYIMY,BYIMX,DA,DIC,DIE,DIK,DR,DIR,D19,DD19,DATE,DDATE,DDDATE,DATE19,DEST,ENC,EVDT,FACILITY,BYIMFILE,INA,MSG,NUM,OPATH,IPATH,ZTDESC,ZTDTC,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,VALMBCK,XPDDIQ,BYIMCNT
+2 NEW AGE,AGE19,MSGCNT,DFNCNT,IMMCNT,BYIMQUIT
+3 NEW BYIMDATE,DEND
+4 DO PATH
+5 IF OPATH=""
DO NOPATH
QUIT
+6 KILL BYIMQUIT
+7 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+8 NEW WRITING,DE
+9 SET DE=""
+10 IF $ORDER(^BYIMPARA($$DUZ(),"LAST EXPORT",0))
DO READY
+11 IF $DATA(WRITING)
Begin DoDot:2
+12 DO RESTART
End DoDot:2
IF $DATA(BYIMQUIT)
QUIT
End DoDot:1
IF $DATA(BYIMQUIT)
QUIT
DATE ;EP;SELECT EXPORT DATE
+1 KILL BYIMQUIT
+2 NEW DATE,X,Y,Z,BYIMDUZ
+3 SET Y=2
SET BYIMDUZ(Y)=DUZ(2)
SET BYIMALL=1
SET BYIMADM=1
+4 IF '$DATA(^BYIMPARA($$DUZ(),0))
IF +$GET(^AUTTSITE(1,0))
Begin DoDot:1
+5 SET X=+^AUTTSITE(1,0)
+6 IF $DATA(^BYIMPARA(X,0))
SET Y=2
SET DUZ(Y)=X
End DoDot:1
+7 IF '$DATA(^BYIMPARA($$DUZ(),0))
Begin DoDot:1
+8 SET X=0
+9 FOR
SET X=$ORDER(^BYIMPARA(X))
IF 'X
QUIT
IF $DATA(^BYIMPARA(X,0))
SET Y=2
SET DUZ(Y)=X
QUIT
End DoDot:1
+10 IF '$DATA(^BYIMPARA($$DUZ(),0))
QUIT
+11 DO DATE19
+12 SET (DATE,D19)=0
+13 SET X=9999999999
+14 FOR
SET X=$ORDER(^BYIMPARA($$DUZ(),"LAST EXPORT",X),-1)
IF 'X!DATE
QUIT
Begin DoDot:1
+15 IF $PIECE(^BYIMPARA($$DUZ(),"LAST EXPORT",X),U)&$PIECE(^(X),U,2)
SET (DATE,D19)=X
End DoDot:1
+16 IF DATE
DO D1
IF $DATA(BYIMQUIT)
QUIT
+17 IF 'DATE
Begin DoDot:1
+18 SET (DATE,D19)=$SELECT(YEARS=19:DATE19,1:DATE99)
+19 IF $DATA(ZTQUEUED)
QUIT
+20 WRITE !!,"The date of the last Immunization export is not on file."
+21 WRITE !,"The export will include all Children 0-18 years of age."
End DoDot:1
+22 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+23 DO ALL^BYIMRT
+24 WRITE !!,"Evaluation of immunizations for export to the State Immunization"
+25 WRITE !,"registry may take several minutes."
+26 SET DIR(0)="YO"
+27 SET DIR("A")="Do you want to proceed"
+28 SET DIR("B")="NO"
+29 WRITE !
+30 DO ^DIR
+31 KILL DIR
+32 IF Y'=1
SET BYIMQUIT=""
End DoDot:1
IF $DATA(BYIMQUIT)
QUIT
+33 KILL ^BYIMTMP($JOB,"BYIM EXP")
+34 NEW X,Y,Z,ZZ,MSGCNT,DFN,BYIMQUIT,XX
+35 SET XX=$PIECE($HOROLOG,",",2)
+36 ;PATCH 8
+37 DO PATH
+38 IF OPATH=""
DO NOPATH
QUIT
+39 IF '$GET(BYIMFAIL)
SET BYIMFAIL=""
+40 ;END PATCH 8
+41 DO FN
+42 SET ^BYIMTMP("BYIMFILE")=BYIMFILE
+43 IF $DATA(^BYIMPARA($$DUZ(),"LAST EXPORT"))
DO LE
QUIT
+44 IF '$DATA(^BYIMPARA($$DUZ(),"LAST EXPORT"))
DO NLE
QUIT
+45 QUIT
+46 ;-----
DEX ;EP;TO CREATE ACTUAL HL7 MESSAGES
+1 ;M ^TMP("BYIMTMP")=^BYIMTMP
+2 DO HEADER
+3 IF '$GET(BYIMALL)
SET BYIMALL=1
+4 IF '$GET(BYIMADM)
SET BYIMADM=1
+5 IF '$GET(DDDATE)
SET DDDATE=""
+6 KILL ^BYIMTMP("LOG")
+7 SET (MSGCNT,DFN,DFNCNT,IMMCNT)=0
+8 FOR
SET DFN=$ORDER(^BYIMTMP($JOB,"BYIM EXP",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+9 ;PATCH 8 CR 08549 CHANGES TO CREATE MULTIPLE STATE FILES
+10 ;INCLUDE ALL PATIENT - SCREEN AT FILE CREATION
+11 ;I $P(^BYIMPARA($$DUZ(),0),U,10),'$P($G(^BIP(DFN,0)),U,24) Q
+12 ;PATCH 8 CR 08549 END
+13 SET DA=$ORDER(^BYIMTMP($JOB,"BYIM EXP",DFN,0))
+14 IF 'DA
QUIT
+15 IF '$DATA(ZTQUEUED)
WRITE "/"
+16 SET MSG=$$V04(DA,BYIMALL,BYIMADM,DDDATE)
+17 IF MSG'["Message Created Successfully"
QUIT
+18 SET MSGCNT=MSGCNT+1
+19 SET DFNCNT=DFNCNT+1
+20 SET IMMCNT=IMMCNT+$$IMMCNT(DFN)
+21 SET ^BYIMTMP("LOG",DFN)=""
End DoDot:1
+22 SET ^BYIMTMP("NUM")=MSGCNT_U_DFNCNT_U_IMMCNT
+23 SET BYIMJOB=$JOB
+24 KILL ^BYIMTMP($JOB,"BYIM EXP")
+25 SET XX=$PIECE($HOROLOG,",",2)-XX
ZIS SET ZTRTN="HFSA^BYIMIMM"
+1 SET ZTDESC="IMMUNIZATION INTERFACE"
+2 FOR X="BYIM*","DFN*","MSG*","IMM*"
SET ZTSAVE(X)=""
+3 SET ZTIO=""
+4 SET ZTDTC=$HOROLOG
+5 DO ^%ZTLOAD
+6 IF $GET(X)[U
Begin DoDot:1
+7 WRITE !!,"The export has been terminated."
+8 DO PAUSE
+9 SET BYIMQUIT=""
+10 DO RES1
End DoDot:1
QUIT
OUT IF '$DATA(ZTQUEUED)
Begin DoDot:1
+1 WRITE !!?10,IMMCNT," immunizations for ",MSGCNT," ",CHILD," 0-",YEARS
+2 WRITE !?10,"were evaluated in "
+3 NEW M,S
+4 SET M=XX\60
+5 SET S=XX#60
+6 IF M]""
WRITE M," minutes"
+7 IF S]""
WRITE ", ",S," seconds"
+8 WRITE "."
+9 DO PATH
+10 IF OPATH=""
DO NOPATH
QUIT
+11 WRITE !!?10,"The file '",BYIMFILE,"' will now be created in the"
+12 WRITE !?10,"'",OPATH,"' directory. This may take several minutes."
+13 WRITE !!?10,"It can be retrieved from this directory for transfer"
+14 WRITE !?10,"to the State registry."
+15 DO PAUSE
End DoDot:1
+16 QUIT
+17 ;-----
HFSA ;EP;TO PROCESS EXPORT
+1 HANG 60
+2 IF '$GET(BYIMTEST)&'$DATA(^BYIMPARA($$DUZ(),"LAST EXPORT",DT))
SET ^BYIMPARA($$DUZ(),"LAST EXPORT",DT)=$HOROLOG
+3 NEW READY
+4 SET READY=""
+5 DO READY
+6 IF $DATA(BYIMQUIT)
KILL BYIMQUIT
GOTO HFSA
+7 SET DEST=$ORDER(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
+8 NEW PRI
+9 SET PRI=+$ORDER(^INLHDEST(DEST,""))
+10 DO HFSA^BYIMIMM6(DEST,PRI)
+11 SET NUM=$GET(^BYIMTMP("NUM"))
+12 SET DFNCNT=$PIECE(NUM,U,2)
+13 SET IMMCNT=$PIECE(NUM,U,3)
+14 SET NUM=+NUM
+15 NEW J,X,Y
+16 SET J=0
+17 SET X=""
+18 FOR
SET X=$ORDER(^INLHDEST(DEST,PRI,X))
IF X=""
QUIT
Begin DoDot:1
+19 SET Y=0
+20 FOR
SET Y=$ORDER(^INLHDEST(DEST,PRI,X,Y))
IF 'Y
QUIT
SET J=J+1
End DoDot:1
+21 IF J<NUM
GOTO HFSA
+22 DO FOOTER
+23 IF $GET(BYIMTEST)
DO CLEAN^BYIMIMM5
+24 HANG 30
+25 SET ^TMP($JOB,"BYIM","CLEAN","BEFORE")=$DATA(^INLHDEST(DEST))
+26 DO CLEAN
+27 SET ^TMP($JOB,"BYIM","CLEAN","AFTER")=$DATA(^INLHDEST(DEST))
HFSARES ;EP;RESTART EXPORT WHEN FILE NOT CREATED
+1 SET DEST=$ORDER(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
+2 NEW PRI
+3 SET PRI=+$ORDER(^INLHDEST(DEST,""))
+4 SET NUM=$GET(^BYIMTMP("NUM"))
+5 KILL ^BYIMTMP("NUM"),^("BYIMFILE")
+6 SET DFNCNT=$PIECE(NUM,U,2)
+7 SET IMMCNT=$PIECE(NUM,U,3)
+8 SET NUM=+NUM
+9 DO PATH
+10 IF OPATH=""
DO NOPATH
QUIT
+11 IF '$GET(BYIMFAIL)
SET BYIMFAIL=""
+12 DO FN
+13 DO HFSA^BYIMIMM4(DEST,OPATH,BYIMFILE)
+14 IF $GET(BYIMFAIL)=1
HANG 10
GOTO HFSARES
+15 IF $GET(BYIMFAIL)>1
IF '$GET(BYIMTEST)
SET $PIECE(^BYIMPARA($$DUZ(),"LAST EXPORT",DT),U,2)="ExportFail"
QUIT
+16 IF '$GET(BYIMTEST)
SET $PIECE(^BYIMPARA($$DUZ(),"LAST EXPORT",DT),U,2)=$HOROLOG
+17 DO LOG^BYIMIMM4(BYIMFILE,"E",DFNCNT,IMMCNT,,,,OPATH)
+18 KILL ^BYIMTMP("NUM")
+19 KILL ^BYIMTMP("BYIMFILE")
+20 ;PATCH 8 CR 08549 PROCESS FILES FOR MULTIPLE STATES
+21 ;D ADDEX
+22 ;PATCH 8 CR 08549 END
+23 QUIT
+24 ;-----
READY ;EP;
+1 NEW X,Y,Z
+2 SET X=""
+3 FOR
SET X=$ORDER(^INLHSCH(0,X))
IF X=""!$DATA(BYIMQUIT)
QUIT
Begin DoDot:1
+4 SET Y=0
+5 FOR
SET Y=$ORDER(^INLHSCH(0,X,Y))
IF 'Y!$DATA(BYIMQUIT)
QUIT
Begin DoDot:2
+6 IF $GET(^INTHU(Y,3,1,0))["V04"
SET BYIMQUIT=""
End DoDot:2
End DoDot:1
+7 IF '$DATA(BYIMQUIT)
Begin DoDot:1
+8 SET DEST=$ORDER(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
+9 IF '$DATA(READY)
IF $DATA(^INLHDEST(+DEST))
Begin DoDot:2
+10 IF '$DATA(ZTQUEUED)
WRITE !!,"Immunization data file creation still in process."
+11 SET WRITING=""
+12 HANG 4
End DoDot:2
QUIT
+13 IF $DATA(ZTQUEUED)!$DATA(DE)
QUIT
+14 NEW NUM
+15 SET NUM=+$GET(^BYIMTMP("NUM"))
+16 HANG 2
+17 WRITE !!,"The Immunization data export file is ready for transmission"
+18 WRITE !,"to the state immunization registry."
+19 HANG 4
+20 NEW J,X,Y,NUM,PRI
+21 SET PRI=0
+22 SET J=0
+23 SET X=""
+24 FOR
SET X=$ORDER(^INLHDEST(DEST,PRI,X))
IF X=""
QUIT
Begin DoDot:2
+25 SET Y=0
+26 FOR
SET Y=$ORDER(^INLHDEST(DEST,PRI,X,Y))
IF 'Y
QUIT
SET J=J+1
End DoDot:2
+27 SET $PIECE(^BYIMTMP("NUM"),U)=J
End DoDot:1
QUIT
+28 IF $DATA(ZTQUEUED)
QUIT
+29 WRITE !!,"Immunization data export still in process."
+30 SET J=0
+31 SET X=""
+32 FOR
SET X=$ORDER(^INLHSCH(0,X))
IF X=""
QUIT
Begin DoDot:1
+33 SET Y=0
+34 FOR
SET Y=$ORDER(^INLHSCH(0,X,Y))
IF 'Y
QUIT
Begin DoDot:2
+35 IF $GET(^INTHU(Y,3,1,0))["V04"
SET J=J+1
End DoDot:2
End DoDot:1
+36 WRITE " (",J,")"
+37 HANG 2
+38 QUIT
+39 ;-----
V04(BYIMVST,BYIMALL,BYIMADM,DDDATE) ;this is the unsolicited Imm record
+1 IF 'BYIMVST
QUIT $$MSG("VST")
+2 DO PATH
+3 SET BYIMPAT=$PIECE($GET(^AUPNVSIT(BYIMVST,0)),U,5)
+4 SET INDA=BYIMPAT
+5 SET INDA(9000010,1)=BYIMVST
+6 SET INDA(2,1)=BYIMPAT
+7 SET INDA("BYIMALL")=$GET(BYIMALL)
+8 SET INDA("BYIMADM")=$GET(BYIMADM)
+9 SET INDA("DDDATE")=$GET(DDDATE)
+10 SET BYIMPAR="HL IHS IZV04 OUT PARENT"
+11 DO ^INHF(BYIMPAR,.INDA)
+12 DO EOJ
+13 QUIT $$MSG(INHF)
+14 ;-----
+1 SET DEST=$ORDER(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
+2 KILL ^INLHDEST(+DEST)
+3 DO NOW^%DTC
+4 SET INA("EVDT")=%
+5 SET EVDT="INA(""EVDT"")"
+6 SET INA("ENC")="^~\&"
+7 SET ENC="INA(""ENC"")"
+8 SET INA("FACILITY")=$PIECE($GET(^DIC(4,$$DUZ(),0)),U)
+9 SET FACILITY="INA(""FACILITY"")"
+10 LOCK +^INTHU(0):DTIME
+11 SET INDA=$PIECE(^INTHU(0),U,3)
+12 DO ^INHF("HL IHS IZV04 OUT HEADER PARENT",.INDA,.INA)
+13 LOCK -^INTHU(0)
+14 DO EOJ
+15 QUIT
+16 ;-----
+1 SET INDA=$PIECE(^INTHU(0),U,3)+1
+2 DO ^INHF("HL IHS IZV04 OUT FOOTER PARENT",.INDA,.INA)
+3 DO EOJ
+4 QUIT
+5 ;-----
EOJ ;EP;kills variables
+1 KILL INDA,BYIMPAT,BYIMVST,BYIMVAIN,BYIMADT
+2 QUIT
+3 ;-----
MSG(BYIMMVAR) ;-- return message defining status
+1 IF BYIMMVAR="PAT"
SET BYIMRMSG="Patient Not Passed In, Message Not Created"
+2 IF BYIMMVAR="VST"
SET BYIMRMSG="Visit Not Passed In, Message Not Created"
+3 IF BYIMMVAR="VLAB"
SET BYIMRMSG="VLAB Not Passed In, Message Not Created"
+4 IF BYIMMVAR="MFL"
SET BYIMRMSG="Mstr File Not Passed In, Message Not Created"
+5 IF BYIMMVAR=0
SET BYIMRMSG="Message Not Created, problem with GIS call"
+6 IF BYIMMVAR
SET BYIMRMSG=BYIMMVAR_U_"Message Created Successfully"
+7 QUIT $GET(BYIMRMSG)
+8 ;-----
IMZIS SET ZTRTN="HFSARES^BYIMIMM"
+1 SET ZTDESC="IMMUNIZATION INTERFACE"
+2 SET ZTIO=""
+3 SET ZTSAVE("BYIMJOB")=""
+4 SET ZTDTC=$HOROLOG
+5 DO ^%ZTLOAD
+6 QUIT
+7 ;-----
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
+1 NEW I
+2 FOR I=1:1:$LENGTH(Z)
IF (32>$ASCII($EXTRACT(Z,I)))
SET Z=$EXTRACT(Z,1,I-1)_" "_$EXTRACT(Z,I+1,999)
+3 QUIT Z
+4 ;-----
BACK SET VALMBCK="R"
+1 QUIT
+2 ;-----
MPORT ;EP;run the import package utility
+1 IF $ORDER(^INXPORT(""))=""
Begin DoDot:1
+2 WRITE !,"Global ^INXPORT missing, please restore and the global."
End DoDot:1
QUIT
+3 SET BYIMIT=$ORDER(^INXPORT(""))
+4 SET BYIMIST=$ORDER(^INXPORT(BYIMIT,""))
+5 SET BYIMIPK=$ORDER(^INXPORT(BYIMIT,BYIMIST,""))
+6 WRITE !,"Importing GIS "_$GET(BYIMIT)_" Supplement "_$GET(BYIMIPK)
+7 WRITE ", developing site "_$GET(BYIMIST)
+8 DO ^BYIMPORT
+9 WRITE !,"Finished Importing GIS Supplement "
+10 KILL BYIMIT,BYIMIST,BYIMIPK
+11 QUIT
+12 ;-----
RESTART ;EP;
+1 SET DIR(0)="YO"
+2 WRITE !!,"Do you want to restart the export?"
+3 SET DIR("B")="NO"
+4 DO ^DIR
+5 KILL DIR
+6 IF Y'=1
SET BYIMQUIT=""
QUIT
+7 DO HFSARES
+8 IF '$GET(BYIMFAIL)
QUIT
+9 DO RES1
+10 DO PATH
+11 IF OPATH=""
DO NOPATH
QUIT
+12 DO FN
+13 SET Y=$$DEL^%ZISH(OPATH,BYIMFILE)
+14 QUIT
+15 ;-----
RES1 ;CLEAR CURRENT EXPORT QUEUE
+1 SET DEST=$ORDER(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
+2 KILL ^INLHDEST(DEST)
+3 NEW X,Y,Z,BYIMQUIT
+4 SET X=""
+5 FOR
SET X=$ORDER(^INLHSCH(0,X))
IF X=""!$DATA(BYIMQUIT)
QUIT
Begin DoDot:1
+6 SET Y=0
+7 FOR
SET Y=$ORDER(^INLHSCH(0,X,Y))
IF 'Y!$DATA(BYIMQUIT)
QUIT
Begin DoDot:2
+8 IF $GET(^INTHU(Y,3,1,0))["V04"
KILL ^INLHSCH(0,X,Y)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;-----
DATE19 ;SET AGE FOR EXPORT
+1 NEW Y
+2 SET Y=$PIECE($GET(^BYIMPARA($$DUZ(),0)),U,6)
+3 SET YEARS=$SELECT('Y:19,Y=1:65,1:99)
+4 SET CHILD=$SELECT('Y:"Children",1:"Patients")
+5 SET (AGE,AGE19)=19*10000
+6 SET DATE19=DT-(19*10000)
+7 SET AGE65=65*10000
+8 SET DATE65=DT-(65*10000)
+9 SET AGE99=99*10000
+10 SET DATE99=DT-(99*10000)
+11 SET D19=$SELECT(YEARS=19:DATE19,YEARS=65:DATE65,1:DATE99)
+12 QUIT
+13 ;-----
ADDEX ;EP;PROCESS ADDITIONAL EXPORT SITES
+1 ;PATCH 8 CR 08627 CORRECT 'COPY' FOR MULTI-SITES
+2 ;PATCH 8 CR 08627 END
+3 QUIT
+4 ;-----
LE ;PROCESS SEQUENTIAL EXPORT
+1 IF '$GET(DDDATE)
SET DDDATE=""
+2 IF '$GET(DEND)
SET DEND=9999999
+3 SET D19=D19-.01
+4 FOR
SET D19=$ORDER(^AUPNVSIT("APCIS",D19))
IF 'D19!(D19>DEND)
QUIT
Begin DoDot:1
+5 SET DA=0
+6 FOR
SET DA=$ORDER(^AUPNVSIT("APCIS",D19,DA))
IF 'DA
QUIT
Begin DoDot:2
+7 SET X=$GET(^AUPNVSIT(DA,0))
+8 SET DFN=$PIECE(X,U,5)
+9 IF 'DFN
QUIT
+10 IF $DATA(^BYIMTMP($JOB,"BYIM EXP",DFN))
QUIT
+11 IF $GET(^DPT(DFN,.35))!'$ORDER(^AUPNPAT(DFN,41,0))!'$GET(^AUPNPAT(DFN,0))
QUIT
+12 SET X=$GET(^DPT(DFN,0))
+13 IF X=""
QUIT
+14 IF X["PATIENT,ERROR"!(X["ERROR,PATIENT")!(X["DEMO,PAT")
QUIT
+15 ;FILTER OUT KIDS WITHOUT PERMANENT NAME
+16 IF X["BABY "!(X["BABY ")
QUIT
+17 ;PATCH 8 CR 08549 CHANGES TO CREATE MULTIPLE STATE FILES
+18 ;Q:$P($G(^BIP(DFN,0)),U,24)=0
+19 IF '$GET(BYIMALL)
SET BYIMALL=1
+20 IF '$GET(BYIMADM)
SET BYIMADM=1
+21 IF '$GET(DDATE)
SET DDATE=""
+22 ;PATCH 8 CR 08549 END
+23 IF YEARS=19
IF $PIECE(X,U,3)<DATE19
QUIT
+24 IF YEARS=65
IF $PIECE(X,U,3)<DATE19&($PIECE(X,U,3)>DATE65)
QUIT
+25 IF BYIMALL
IF BYIMALL'=2!(BYIMADM&BYIMADM'=2)
IF '$$NEW^BYIMIMM6(DFN,BYIMALL,BYIMADM,DDDATE)
QUIT
+26 SET ^BYIMTMP($JOB,"BYIM EXP",DFN,DA)=""
+27 IF '$DATA(ZTQUEUED)
WRITE "."
End DoDot:2
End DoDot:1
+28 IF '$ORDER(^BYIMTMP($JOB,"BYIM EXP",0))
Begin DoDot:1
+29 SET BYIMFILE="NoImmsToExp_"_$PIECE($GET(^AUTTLOC($$DUZ(),0)),U,10)_"_"_(DT+17000000)_"_"_$PIECE($HOROLOG,",",2)_".dat"
+30 IF '$GET(BYIMTEST)
SET $PIECE(^BYIMPARA($$DUZ(),"LAST EXPORT",DT),U)=$HOROLOG
SET $PIECE(^(DT),U,2)=$HOROLOG
+31 SET DFNCNT=0
+32 SET IMMCNT=0
+33 DO PATH^BYIMIMM6
+34 DO LOG^BYIMIMM4(BYIMFILE,"E",DFNCNT,IMMCNT,,,,OPATH)
+35 IF '$GET(BYIMTEST)
SET $PIECE(^BYIMPARA($$DUZ(),"LAST EXPORT",DT),U,2)="NoImmsToExp"
+36 IF $DATA(ZTQUEUED)
QUIT
+37 WRITE !!,"No Immunizations found that need to be exported."
+38 DO PAUSE
End DoDot:1
QUIT
+39 DO DEX
+40 SET Y=2
SET DUZ(Y)=BYIMDUZ(2)
+41 QUIT
+42 ;-----
NLE ;PROCESS FIRST EXPORT
+1 NEW BYIMALL
+2 SET BYIMALL=2
+3 SET BYIMADM=2
+4 FOR
SET D19=$ORDER(^DPT("ADOB",D19))
IF 'D19
QUIT
Begin DoDot:1
+5 SET DFN=0
+6 FOR
SET DFN=$ORDER(^DPT("ADOB",D19,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+7 IF $GET(^DPT(DFN,.35))!'$GET(^AUPNPAT(DFN,0))
QUIT
+8 SET X=$GET(^DPT(DFN,0))
+9 IF X["PATIENT,ERROR"!(X["ERROR,PATIENT")!(X["DEMO,PAT")!($EXTRACT(X,1,2)="ZZ")!$PIECE(X,U,19)
QUIT
+10 SET X=$ORDER(^AUPNVSIT("AC",DFN,9999999999),-1)
+11 IF 'X
QUIT
+12 IF '$GET(^AUPNVSIT(X,0))
QUIT
+13 IF +^AUPNVSIT(X,0)<DATE
QUIT
+14 IF $ORDER(^BYIMTMP($JOB,"BYIM EXP",DFN,0))
QUIT
+15 SET ^BYIMTMP($JOB,"BYIM EXP",DFN,X)=""
+16 IF '$DATA(ZTQUEUED)
WRITE "."
End DoDot:2
End DoDot:1
+17 DO DEX
+18 SET Y=2
SET DUZ(Y)=BYIMDUZ(2)
+19 QUIT
+20 ;-----
D1 ;PROCESS WHEN DATE IDENTIFIED
+1 SET (Y,DDDATE)=DATE
+2 XECUTE ^DD("DD")
+3 SET DDATE=Y
+4 SET Y=DT-AGE
+5 XECUTE ^DD("DD")
+6 SET DD19=Y
+7 IF $DATA(ZTQUEUED)
QUIT
+8 WRITE @IOF
+9 WRITE !!,"The last Immunization export ran on: ",DDATE
+10 IF YEARS=19
Begin DoDot:1
+11 WRITE !,"Children 18 and under were born after: ",DD19
End DoDot:1
+12 WRITE !!,"This export will include: ",!
+13 IF YEARS=19
Begin DoDot:1
+14 WRITE !?5,"Children 18 and under"
End DoDot:1
+15 IF YEARS=65
Begin DoDot:1
+16 WRITE !?5,"Children 18 and under and"
+17 WRITE !?5,"Adults.. 65 and over"
End DoDot:1
+18 IF YEARS=99
Begin DoDot:1
+19 WRITE !?5,"All patients"
End DoDot:1
+20 WRITE !!,"who have had a visit since the last export."
+21 WRITE !,"You can enter another date for the export."
+22 SET DIR(0)="DO"
+23 SET DIR("A")="Export Immunizations given since "_DDATE
+24 SET DIR("B")=DDATE
+25 WRITE !
+26 DO ^DIR
+27 KILL DIR
+28 IF 'Y
SET BYIMQUIT=""
QUIT
+29 SET (BYIMDATE,DATE,D19)=Y
+30 SET Y=DT
+31 XECUTE ^DD("DD")
+32 SET DEND=Y
+33 SET DIR(0)="DO"
+34 SET DIR("A")="Exclude Immunizations given after "_DEND
+35 SET DIR("B")=DEND
+36 WRITE !
+37 IF D19=DT
SET Y=DT
+38 IF D19<DT
DO ^DIR
+39 KILL DIR
+40 IF 'Y
SET BYIMQUIT=""
QUIT
+41 SET DEND=Y
+42 QUIT
+43 ;-----
PATH ;EP;SET PATH
+1 DO PATH^BYIMIMM6
+2 QUIT
+3 ;-----
NOPATH ;EP;NO PATH MESSAGE
+1 DO NOPATH^BYIMIMM6
+2 QUIT
+3 ;-----
PAUSE ;EP;FOR PAUSE READ
+1 DO PAUSE^BYIMIMM6
+2 QUIT
+3 ;-----
CLEAN ;CLEAN OUT MESSAGES WITH NO RXA SEGMENT, BLANK RXR AND OBX SEGMENTS
+1 NEW DEST,QUIT,X,Y,Z,XX,ZZ
+2 SET DEST=$ORDER(^INRHD("B","HL IHS IZV04 FRAMEWORK",0))
+3 IF 'DEST
QUIT
+4 SET X=""
+5 FOR
SET X=$ORDER(^INLHDEST(DEST,X))
IF 'X
QUIT
Begin DoDot:1
+6 SET Y=""
+7 FOR
SET Y=$ORDER(^INLHDEST(DEST,X,Y))
IF Y=""
QUIT
Begin DoDot:2
+8 SET Z=0
+9 FOR
SET Z=$ORDER(^INLHDEST(DEST,X,Y,Z))
IF 'Z
QUIT
Begin DoDot:3
+10 SET QUIT=0
+11 SET ZZ=0
+12 FOR
SET ZZ=$ORDER(^INTHU(Z,3,ZZ))
IF 'ZZ
QUIT
SET XX=^(ZZ,0)
Begin DoDot:4
+13 IF XX["RXA"
SET QUIT=1
QUIT
+14 IF XX["RXR||"
KILL ^INTHU(Z,3,ZZ,0)
QUIT
+15 IF XX["OBX|"&(XX["V00")
KILL ^INTHU(Z,3,ZZ,0)
End DoDot:4
+16 IF QUIT
QUIT
+17 KILL ^INLHDEST(DEST,X,Y,Z)
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;-----
IMMCNT(DFN) ;COUNT PT IMMS TO BE EXPORTED
+1 NEW X,Y,Z
+2 SET Y=0
+3 SET X=0
+4 FOR
SET X=$ORDER(^AUPNVIMM("AC",DFN,X))
IF 'X
QUIT
Begin DoDot:1
+5 IF $GET(BYIMALL)=2
SET Y=Y+1
SET ^BYIMTMP("LOG",DFN,X)=""
QUIT
+6 IF '$DATA(^BYIMEXP("D",X))
SET Y=Y+1
SET ^BYIMTMP("LOG",DFN,X)=""
End DoDot:1
+7 QUIT Y
+8 ;-----
FN ;EP;SET FILE NAME
+1 IF '$GET(ASUFAC)
SET ASUFAC=$PIECE($GET(^AUTTLOC($$DUZ(),0)),U,10)
+2 IF $GET(BYIMFILE)=""
SET BYIMFILE="izdata_"_$GET(ASUFAC)_"_"_(DT+17000000)_"_"_$PIECE($HOROLOG,",",2)_$SELECT($GET(BYIMTEST):"_test",1:"")_"."_BYIMEXT
+3 QUIT
+4 ;-----
DUZ() ;PRIMARY PARAM SITE
+1 NEW X,Y,Z
+2 SET Y=0
+3 SET X=0
+4 FOR
SET X=$ORDER(^BYIMPARA(X))
IF 'X
QUIT
IF X=+^AUTTSITE(1,0)
SET Y=X
+5 IF 'Y
SET X=0
FOR
SET X=$ORDER(^BYIMPARA(X))
IF 'X
QUIT
IF $DATA(^BYIMPARA(X,0))
SET Y=X
+6 QUIT Y
+7 ;-----
