BYIMIMM1 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8**;JUL 11, 2017;Build 310
;
;;CONTINUATION OF BYIMIMM
;
;-----
FILE ;ENTER FILE NAME OF IMPORT FILE
K BYIMQUIT
D PATH^BYIMIMM6
I IPATH="" D NOPATH^BYIMIMM6 Q
S DIR(0)="FO^3:50"
S DIR("A",1)="The file from the State Registry must be in the drive/directory: "
S DIR("A",2)=" ** "_IPATH_" **"
S DIR("A")="Enter the name of the file from the State Registry"
W !
D ^DIR
K DIR
I X=""!(X[U) S BYIMQUIT="" Q
S FILE=X
Q
;-----
IMPORT ;EP;IMMUNIZATION IMPORT
N AUTO,BYIMERR,BYIMJ,BYIMX,DATE,DIC,DIE,DIK,DR,DA,DLAYGO,HRN,IMM,IVDA,JJ,LOC,MSHX,NAME,NUM,PID,SEX,DOB,FACILITY,INHDA,STATUS,T,VALMBCK,VALMCC,VALMCNT,VDATE,X1,X2,YY,ZTQUEUED,DFNCNT,BYIMIMM,IMMCNT,NODFNCNT,NEWIMCNT,ADDIMCNT,MSGCNT,RXACNT
D FILE
Q:$D(BYIMQUIT)
D PATH^BYIMIMM6
I IPATH="" D Q
.W:'$D(ZTQUEUED) !!,"No directory path found."
.H 4
I1 ;EP;FOR AUTO IMPORT MODE
S Y=$$OPEN^%ZISH(IPATH,FILE,"R")
I Y D Q:$D(BYIMQUIT)
.D:'$G(AUTOADD)&'$D(ZTQUEUED)
..W !!,*7,"Cannot find FILE: ",FILE
..W !,*7," in DIRECTORY: ",IPATH
.S BYIMQUIT=""
.D PAUSE^BYIMIMM6
D CLOSE^%ZISH()
D:'$G(AUTOIMP)
.W !!,"Import of immunizations of patients from the"
.W !,"State Immunization 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
.S:Y'=1 BYIMQUIT=""
Q:$D(BYIMQUIT)
D NCNT^BYIMIMM2
D IN(IPATH,FILE)
Q
;-----
IN(IPATH,FILE) ;EP;TO PROCESS INCOMING FILE
;IPATH - INBOUND FILE PATH
;FILE - INBOUND FILE
W:'$G(AUTOIMP) !!,"Please do not interrupt."
S (DFNCNT,NODFNCNT,IMMCNT,NEWIMCNT,BYIMIMM,ADDIMCNT,MSGCNT,RXACNT)=0
D READ(IPATH,FILE)
D S1:$G(AUTOADD)
D LOG^BYIMIMM4(FILE,"I",DFNCNT,RXACNT,NODFNCNT,NEWIMCNT,ADDIMCNT,IPATH)
I '$G(AUTOIMP),'$G(AUTOADD),'$D(ZTQUEUED) D MATCH^BYIMIMM2
D ADDIM
K AUTOIMP,AUTOADD
Q
;-----
READ(IPATH,FILE) ;PEP pull up a file into the TMP global for display
N Y,X,I,J,OPATH
S MSGCNT=0
S RXACNT=0
S J=1
S Y=$$OPEN^%ZISH(IPATH,FILE,"R")
I Y D Q
.W:'$G(AUTOIMP) !,*7,"CANNOT OPEN (OR ACCESS) FILE '",IPATH,FILE,"'."
.S BYIMQUIT=""
;THE READ STATEMENT BELOW IS A READ FROM A HOST FILE WHICH REQUIRES A
;DIRECT READ VS AN FM/DIR CALL SAC EXEMPTION REQUESTED
K ^BYIMTMP($J,"BYIM IMM")
N RX
S RX="R"_" X:"_"DTIME"
F I=1:1 U IO X RX S STATUS=$$STATUS^%ZISH Q:STATUS=1!(STATUS=-1)!(X="") D:"|MSH|PID|RXA|"[("|"_$E(X,1,3)_"|") INSET^BYIMIMM2
D CLOSE^%ZISH()
Q:'$D(^BYIMTMP($J,"BYIM IMM"))
D SET
K ^BYIMTMP($J,"BYIM IMM")
Q
;-----
SET ;EP;ID PATIENTS AND SET NEW IMMUNIZATIONS
S AUTOADD=$P($G(^BYIMPARA(DUZ(2),0)),U,5)
S INHDA=0
F S INHDA=$O(^BYIMTMP($J,"BYIM IMM",INHDA)) Q:'INHDA D SET1(INHDA)
I $G(OLDDUZ(2)) S Z=2,DUZ(Z)=OLDDUZ(2) K OLDDUZ
Q:'$D(^BYIMXTMP("BYIM"))
D FMINIT
S BYIMCNT=BYIMJ
Q
;-----
SET1(INHDA) ;EP;TO PROCESS INCOMING HL7 MESSAGE
D ID ;VERIFY PATIENT ID
I $D(BYIMQUIT) K BYIMQUIT Q
S DFNCNT=$G(DFNCNT)+1
D IMM ;CHECK EACH INCOMING IMMUNIZATION
I '$D(ZTQUEUED) U 0 W "/"
Q
;-----
ID ;ID PATIENT
I $G(OLDDUZ(2)) S Z=2,DUZ(Z)=OLDDUZ(2) K OLDDUZ
N J
S PID=""
S J=0
F S J=$O(^INTHU(INHDA,3,J)) Q:'J!(PID["PID|") I $E(^(J,0),1,4)="PID|" S PID=^(0)
I PID="" S BYIMQUIT="" Q
S PIDX=$P(PID,"|",4)
F J=1:1:$L(PIDX,"~") S X=$P($P(PIDX,"~",J),U) S:$E(X,1,4)="RPMS" X=$E(X,5,99) Q:$L(X)=12
S HRN=+$E(X,7,99)
S FACILITY=$E(X,1,6)
S X=$P(PID,"|",6)
S X=$P(X,U)_","_$P(X,U,2)_$S($P(X,U,3)]"":" "_$P(X,U,3),1:"")
S (NAME,FULLNAME)=X
I FACILITY]"",$O(^AUTTLOC("C",FACILITY,0)) S Z=2,OLDDUZ(Z)=DUZ(2),DUZ(Z)=$O(^AUTTLOC("C",FACILITY,0))
S DOB=$E($P(PID,"|",8),1,8)-17000000
S SEX=$P(PID,"|",9)
S X=HRN
S DIC="^DPT("
S DIC(0)="MZ"
S DIC("S")="I $P(^DPT(+Y,0),U,3)=DOB,$P(^(0),U,2)=SEX"
S AUPNLK("ALL")=""
S AUPNLK("INAC")=""
D ^DIC
K DIC,DINUM,DR,DA,DLAYGO
S:$G(OLDDUZ(2)) Z=2,DUZ(Z)=OLDDUZ(2)
I +Y<1 D
.S X=$P(PID,"|",6)
.S X=$P(X,U)_","_$P(X,U,2)_$S($P(X,U,3)]"":" "_$P(X,U,3),1:"")
.S DIC="^DPT("
.S DIC(0)="MZ"
.S DIC("S")="I $P(^DPT(+Y,0),U,3)=DOB,$P(^(0),U,2)=SEX"
.S AUPNLK("ALL")=""
.S AUPNLK("INAC")=""
.D ^DIC
.K DIC,DINUM,DR,DA,DLAYGO
I +Y<1 D
.S X=$TR($P(PID,"|",6),".","")
.S X=$P(X,U)_","_$P(X,U,2)
.S DIC="^DPT("
.S DIC(0)="MZ"
.S DIC("S")="I $P(^DPT(+Y,0),U,3)=DOB,$P(^(0),U,2)=SEX"
.D ^DIC
.K DIC,DINUM,DR,DA,DLAYGO
I +Y<1 D Q:Y<1
.D DIRECT
.Q:Y>0
.S BYIMQUIT=""
.I $L(FULLNAME),$L(DOB),$L(SEX),'$D(^BYIMPARA("NMNAME",FULLNAME)) D
..;RECORD NO MATCH PATIENTS
..S DA(1)=DUZ(2)
..S DIC="^BYIMPARA("_DUZ(2)_",4,"
..S DIC(0)="LZ"
..S X=FULLNAME
..S DIC("DR")=".02////"_(DOB+17000000)_";.03////"_$E(FILE,7,14)_";.04////"_SEX_";.05////"_$G(MM)_";.06////"_$G(UIF)
..D FILE^DICN
..S NODFNCNT=$G(NODFNCNT)+1
..S Y=-1
S DFN=+Y
I '$D(^AUPNPAT(DFN,41,DUZ(2),0)) D
.K OLDDUZ
.N XX
.S XX=0
.F S XX=$O(^AUPNPAT(DFN,41,XX)) Q:'XX!$G(OLDDUZ(2)) D
..S Z=2,OLDDUZ(Z)=DUZ(2)
..S Z=2,DUZ(Z)=XX
..K BYIMQUIT
.S:'$G(OLDDUZ(2)) BYIMQUIT=""
I $G(^DPT(DFN,.35)) S BYIMQUIT=""
Q
;-----
DIRECT ;DIRECT FIND OF PATIENT
D DIRECT^BYIMIMM3
Q
;-----
IMM ;COMPARE INCOMING IMMUNIZATIONS WITH EXISTING IMMUNIZATIONS
N X,Y,Z,ZZ,BYIMY,LOT
S J=2
F S J=$O(^INTHU(INHDA,3,J)) Q:'J S BYIMY=^(J,0) D:$E(BYIMY,1,3)="RXA"
.S Z=$E($P(BYIMY,"|",4),1,8)-17000000
.S Y=+$P($P(BYIMY,"|",6),U)
.Q:Y=999
.Q:'Y!'Z
.S IMMCNT=$G(IMMCNT)+1
.S IMM=Y
.D CONVERT
.S Y=IMM
.S X=$P(BYIMY,"|",12)
.S X=$P(X,U,4)_U_$P(X,U)
.S VOL=+$P(BYIMY,"|",7)
.S:'VOL!(VOL[999) VOL=""
.S LOT=$P(BYIMY,"|",16)
.S MAN=$P($P(BYIMY,"|",18),U,1,2)
.S ^BYIMXTMP("BYIM",DOB,NAME,DFN,Y,Z)=INHDA_U_Z_U_X_U_LOT_U_MAN_U_VOL
.Q:'$O(IMM(0))
.S Y=0
.F S Y=$O(IMM(Y)) Q:'Y D
..S ^BYIMXTMP("BYIM",DOB,NAME,DFN,Y,Z)=INHDA_U_Z_U_X
S X=0
F S X=$O(^AUPNVIMM("AC",DFN,X)) Q:'X D
.S Y=$G(^AUPNVIMM(X,0))
.S Z=$P($G(^AUPNVSIT(+$P(Y,U,3),0)),".")
.S Y=+Y
.Q:'Y!'Z
.K ^BYIMXTMP("BYIM",DOB,NAME,DFN,Y,Z)
.D KILL^BYIMIMM2
Q
;-----
DEL ;EP;DEL IMMUNIZATIONS FROM THE STATE REGISTRY LIST
N DEL
S DEL=""
ADD ;EP;ADD NEW IMMUNIZATIONS FROM THE STATE REGISTRY
K BYIMQUIT
D SELECT
I $D(BYIMQUIT) K BYIMQUIT Q
D CLEAR^VALM1
D NEWIMM
BACK S VALMBCK="R"
Q
;-----
SELECT ;SELECT CHILD TO ADD
I BYIMJ-3=0 D Q
.W !!,"No Immunizations to ",$S('$D(DEL):"Add",1:"Delete"),"..."
.H 3
S DIR(0)="LO^1:"_(BYIMJ-3)
S DIR("A")="Select Immunization(s) to "_$S('$D(DEL):"add to RPMS",1:"delete from the list")
W !
D ^DIR
K DIR
I 'Y S BYIMQUIT="" Q
M BYIMY=Y
Q
;-----
S1 ;FOR AUTOADD TO SET ADD ARRAY
N X,Y,Z,J
F J=1:1:$G(BYIMJ)-3 S BYIMY(J)=J
NEWIMM ;ADD NEW IMMUNIZATION
K BYIMPAUS
N XX
S XX=""
F S XX=$O(BYIMY(XX)) Q:XX="" D
.S YY=BYIMY(XX)
.F JJ=1:1 S ZZ=$P(YY,",",JJ) Q:ZZ="" D NI1
Q
NI1 ;NEW IMMUNIZATION
K NEWLOT
S NUM=ZZ+3
S (X,BYIMX)=$G(^BYIMTMP($J,"BYIM DISP","DFN",NUM))
Q:$E(X)="*"!(X="")
;1 = NAME
;2 = DFN
;3 = ADMIN DATE
;4 = CVX CODE
;5 = IMM IEN
;6 = LOC
;7 = DOB
;8 = LOC2
;9 = LOT NUM
;10 = MVX CODE
;11 = MANUF NAME
;12 = VOLUME
S NAME=$P(X,U)
S DFN=$P(X,U,2)
S VDATE=$P(X,U,3)
S IMM=$P(X,U,4)
D CONVERT
S IVDA=$P(X,U,5)
S LOC=$P(X,U,6)
S LOC2=$P(X,U,8)
I LOC="",LOC2]"" S LOC=LOC2
S:LOC="" LOC="OTHER"
S DOB=$P(X,U,7)
S LOT=$P(X,U,9)
S LOTDA=""
S MVX=$P(X,U,10)
S MAN=$P(X,U,11)
S VOL=$P(X,U,12)
I LOT]"",IMM]"",MVX]"" D
.I $T(ADDLOT^BIRPC5)]"" D
..S BYIMDATA=LOT_"|"_IMM_"|"_MVX
..D ADDLOT^BIRPC5(.BYIMERR,BYIMDATA,.LOTDA)
.I $T(ADDLOT^BIRPC5)="" D
..D LOT^BYIMIMM4(LOT,MAN,IVDA)
K APCDALVR("APCDAFLG"),BYIMERR
N BYIMDUZ,NEWLOT
I $G(LOTDA),$P($G(^AUTTIML(LOTDA,0)),U,3) S $P(^(0),U,3)=0,NEWLOT=LOTDA
S BYIMDUZ=DUZ
D VISIT:'$D(DEL)
S X="DUZ"
S @X=BYIMDUZ
I $G(NEWLOT) S $P(^AUTTIML(NEWLOT,0),U,3)=1 K NEWLOT
Q:$G(BYIMERR)]""&'$D(DEL)
S X=BYIMX
K ^BYIMXTMP("BYIM",$P(X,U,7),$P(X,U),$P(X,U,2),$P(X,U,4),$P(X,U,3))
K ^BYIMTMP($J,"BYIM IMM","DFN",NUM)
S Z=VDATE
S Y=$O(^AUTTIMM("C",IMM,0))
Q:'Y!'Z
D KILL^BYIMIMM2
Q
;-----
VISIT ;FIND OR CREATE VISIT
K BYIMDUZ
S BYIMDUZ=DUZ
D DUZ
D LOCIN(LOC)
N P
S P="|"
S BYIMERR=""
S $P(BYIMDATA,P,1)="I"
S $P(BYIMDATA,P,2)=DFN
S $P(BYIMDATA,P,3)=IVDA
S $P(BYIMDATA,P,6)=VDATE_".12"
S $P(BYIMDATA,P,7)=LOCDA
S $P(BYIMDATA,P,8)=$E($S($E(LOC2)?1U&(LOC2'=LOC):LOC2,1:LOC),1,50)
S $P(BYIMDATA,P,9)="E"
S $P(BYIMDATA,P,21)=$G(VOL)
S $P(BYIMDATA,P,23)=DUZ(2)
S $P(BYIMDATA,P,25)=1
D ADDEDIT^BIRPC3(.BYIMERR,BYIMDATA,1)
I $G(OLDDUZ(2)) S Z=2,DUZ(Z)=OLDDUZ(2) K OLDDUZ
I BYIMERR]"" D Q
.K BYIMQUIT
.S:BYIMERR["Lot Number" BYIMERR="**"_$P($G(^AUTTIML(+$G(LOTDA),0)),U)_"** "_BYIMERR
.S BYIMERR=BYIMERR_" - V IMMUNIZATIONN CREATION FAILED"
.S X="DUZ",@X=BYIMDUZ
.N %X,%Y,X,XMB,XMDT,XMDUZ,Y1
.S XMB="BYIM V IMM CREATION FAILED"
.S XMB(1)=$P(^DPT(DFN,0),U)_" (DOB: "_$E($P(^(0),U,3),4,5)_"/"_$E($P(^(0),U,3),6,7)_"/"_$E($P(^(0),U,3),1,3)+17000
.S XMB(2)=IMM_" - "_$P($G(^AUTTIMM(IVDA,0)),U)
.N X
.S X=VDATE
.S XMB(3)=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,1,3)+1700
.S XMB(4)=BYIMERR
.S XMDUZ=.5
.D ^XMB
.I '$D(ZTQUEUED),$G(BYIMPAUS)'[U D
..W !!,"Visit not added:"
..W !,BYIMERR
..W !!,"Patient.....: ",XMB(1)
..W !,"Immunization: ",XMB(2)
..W !,"Visit Date..: ",XMB(3)
..D PAUSE^BYIMIMM6
S ADDIMCNT=$G(ADDIMCNT)+1
Q:'$G(LOTDA)
D ADDLOT^BYIMIMM6(DFN,IVDA,LOTDA,VDATE)
Q
;-----
CONVERT ;CONVERT INACTIVE VACCINE TO ACTIVE EQUIVALENT
S:IMM=105 IMM=75,OLDIMM=105
S:IMM=17 IMM=47,OLDIMM=17
S:IMM=31 IMM=83,OLDIMM=31
Q
;-----
FMINIT ;EP;PUT NEW IMMUNIZATIONS INTO TMP STORAGE FOR
K ^BYIMTMP($J,"BYIM DISP")
N A,B,C,X,Y,Z,J,XXX
S J=3
S DOB=9999999
F S DOB=$O(^BYIMXTMP("BYIM",DOB),-1) Q:'DOB D
.S A=""
.F S A=$O(^BYIMXTMP("BYIM",DOB,A)) Q:A="" D
..S B=0
..F S B=$O(^BYIMXTMP("BYIM",DOB,A,B)) Q:'B D
...S C=0
...F S C=$O(^BYIMXTMP("BYIM",DOB,A,B,C)) Q:'C D
....S X=0
....F S X=$O(^BYIMXTMP("BYIM",DOB,A,B,C,X)) Q:'X S XXX=^(X) D FM
S (BYIMJ,VALMCNT)=J
S NEWIMCNT=J-3
D BACK
Q
;-----
FM ;SET DISPLAY GLOBAL
S XX=$P(XXX,U,2)
S DATE=$E(XX,4,5)_"/"_$E(XX,6,7)_"/"_(1700+$E(XX,1,3))
S IVDA=+$O(^AUTTIMM("C",C,0))
I 'IVDA S ^BYIMTMP($J,"BYIM TEST","NO IMM CODE: "_C)="" Q
S IMM=$P($G(^AUTTIMM(+IVDA,0)),U,2)
I IMM="" S ^BYIMTMP($J,"BYIM TEST","NO IMM CODE 2: "_IMM)="" Q
S J=J+1
S IMM=IMM_"-"_C
S T=J-3
S $E(T,5)=DOB+17000000
S $E(T,14)=$E(A,1,28)
S $E(T,43)=IMM
S $E(T,60)=$P(XXX,U,5)
S $E(T,71)=DATE
S ^BYIMTMP($J,"BYIM DISP",J,0)=T
S ^BYIMTMP($J,"BYIM DISP","DFN",J)=A_U_B_U_XX_U_C_U_IVDA_U_$P(XXX,U,3)_U_DOB_U_$P(XXX,U,4)_U_$P(XXX,U,5)_U_$P(XXX,U,6)_U_$P(XXX,U,7)_U_$P(XXX,U,8)
;A = NAME
;B = DFN
;XX = ADMIN DATE
;C = CVX CODE
;IVDA = IMM IEN
;$P(XXX,U,3) = LOC
;DOB = DOB
;$P(XXX,U,4) = LOC2
;$P(XXX,U,5) = LOT NUM
;$P(XXX,U,6) = MVX CODE
;$P(XXX,U,7) = MANUF NAME
;$P(XXX,U,8) = VOLUME
S BYIMCNT=+T
Q
;-----
HDR ;EP;FOR LIST HEADER
S ^BYIMTMP($J,"BYIM DISP",1,0)=" "_$S($G(VALMCNT):" ("_(VALMCNT-3)_")",1:"")_" Immunizations from the State Registry"
S T="NUM"
S $E(T,5)="DOB"
S $E(T,14)="NAME"
S $E(T,43)="IMMUNIZATION-CVX"
S $E(T,60)="LOT NO."
S $E(T,71)="DATE REC'D"
S ^BYIMTMP($J,"BYIM DISP",2,0)=T
S T="---"
S $E(T,5)="--------"
S $E(T,14)="----------------------------"
S $E(T,43)="----------------"
S $E(T,60)="----------"
S $E(T,71)="----------"
S ^BYIMTMP($J,"BYIM DISP",3,0)=T
Q
;-----
START ;EP;
S BYIMVALM="BYIM STATE IMMUNIZATIONS"
D VALM(BYIMVALM)
Q
VALM(BYIMVALM) ;EP; -- main entry point for list templates
S VALMCC=1 ;1=screen mode, 0=scrolling mode
D TERM^VALM0
D CLEAR^VALM1
D EN^VALM(BYIMVALM)
D CLEAR^VALM1
K ^BYIMTMP($J,"BYIM DISP")
Q
;-----
PARAM ;EP;TO UPDATE PARAMETERS
N DA,DR,DIC,DIE,BYIMDA
D PADD
Q:DA<1
S DIE="^BYIMPARA("
S DR="[BYIM SET PARAMETERS]"
W @IOF
W !!,"UPDATE Data Exchange Parameters for ",$P(^DIC(4,DA,0),U)
W !
D ^DIE
D PATH^BYIMIMM6
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
Q
;-----
PADD ;EP;TO ADD PARAMETER SITE
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
S DIC="^BYIMPARA("
S DIC(0)="AEMLQZ"
S DIC("A")="Select SITE for Data Exchange Parameters: "
S DIC("B")=$P(^DIC(4,DUZ(2),0),U)
W @IOF
W !!,"ADD Data Exchange Parameter Site"
W !
D ^DIC
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
S (BYIMDA,DA)=+Y
Q
;-----
DUZ ;SET DUZ FOR VISIT 'CREATED BY USER'
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
N X,Y,Z
S X="USER,IMMUNIZATION INTERFACE"
S Y=$O(^VA(200,"B",X,0))
D:'Y
.S DIC="^VA(200,"
.S DIC(0)="M"
.S DIC("DR")="3////@"
.D FILE^DICN
.K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
.S Y=+Y
S:Y<1 Y=.5
S X="DUZ",@X=+Y
Q
;-----
ADDIM ;EP;PROCESS ADDITIONAL IMPORT FILES
N BYIMAS
S BYIMDA=DUZ(2)
S BYIMAS=0
F S BYIMAS=$O(^BYIMPARA(BYIMDA,3,BYIMAS)) Q:'BYIMAS D
.S X=^BYIMPARA(BYIMDA,3,BYIMAS,0)
.S IPATH=$P(X,U,3)
.D ADDIM1
Q
;-----
ADDIM1 ;PROCESS EACH ADDIONAL IMPORT SITE
I '$G(AUTOIMP) D
.W:'$D(ZTQUEUED) !!,"Processing additional import files."
.W:'$D(ZTQUEUED) !,"Please do not interrupt."
S (DFNCNT,NODFNCNT,IMMCNT,NEWIMCNT,BYIMIMM,ADDIMCNT,MSGCNT,RXACNT)=0
D READ(IPATH,FILE)
D S1:$G(AUTOADD)
D LOG^BYIMIMM4(FILE,"I",DFNCNT,RXACNT,NODFNCNT,NEWIMCNT,ADDIMCNT,IPATH)
I '$G(AUTOIMP),'$G(AUTOADD),'$D(ZTQUEUED) D MATCH^BYIMIMM2
Q
;-----
LOCIN(LOC) ;PROCESS LOCATION DATA FOR FACILITY NAME OR CODE
S:LOC="" LOC="OTHER"
S LOCDA=0
S LOCDA=$O(^BYIMPARA("RXA",LOC,0))
S:LOCDA LOCDA=$O(^BYIMPARA("RXA",LOC,LOCDA,0))
S:'LOCDA LOCDA=$S($O(^DIC(4,"B",LOC,0)):$O(^DIC(4,"B",LOC,0)),1:$O(^DIC(4,"B","OTHER",0)))
I $P($G(^DIC(4,+LOCDA,0)),U)="OTHER",LOC2]"",$O(^DIC(4,"B",LOC2,0)) S LOCDA=$O(^DIC(4,"B",LOC2,0)),LOC=LOC2
I $P(^DIC(4,+LOCDA,0),U)="OTHER",$P($G(^BISITE($S($G(OLDDUZ(2)):OLDDUZ(2),1:+$G(DUZ(2))),0)),U,3),LOCDA'=$P(^(0),U,3) S LOCDA=$P(^(0),U,3)
Q:$P(^DIC(4,+LOCDA,0),U)'="OTHER"
;DETERMINE STATE FOR 'OTHER' FACILITY
N X,Y,Z
S X=$P($G(^DIC(4,+$G(DUZ(2)),0)),U,2)
Q:'X
S Z=0
S Y=0
F S Y=$O(^DIC(4,"B","OTHER",Y)) Q:'Y!Z D
.S:$P($G(^DIC(4,Y,0)),U,2)=X Z=Y
S:Z LOCDA=Z
Q
;
BYIMIMM1 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
+1 ;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8**;JUL 11, 2017;Build 310
+2 ;
+3 ;;CONTINUATION OF BYIMIMM
+4 ;
+5 ;-----
FILE ;ENTER FILE NAME OF IMPORT FILE
+1 KILL BYIMQUIT
+2 DO PATH^BYIMIMM6
+3 IF IPATH=""
DO NOPATH^BYIMIMM6
QUIT
+4 SET DIR(0)="FO^3:50"
+5 SET DIR("A",1)="The file from the State Registry must be in the drive/directory: "
+6 SET DIR("A",2)=" ** "_IPATH_" **"
+7 SET DIR("A")="Enter the name of the file from the State Registry"
+8 WRITE !
+9 DO ^DIR
+10 KILL DIR
+11 IF X=""!(X[U)
SET BYIMQUIT=""
QUIT
+12 SET FILE=X
+13 QUIT
+14 ;-----
IMPORT ;EP;IMMUNIZATION IMPORT
+1 NEW AUTO,BYIMERR,BYIMJ,BYIMX,DATE,DIC,DIE,DIK,DR,DA,DLAYGO,HRN,IMM,IVDA,JJ,LOC,MSHX,NAME,NUM,PID,SEX,DOB,FACILITY,INHDA,STATUS,T,VALMBCK,VALMCC,VALMCNT,VDATE,X1,X2,YY,ZTQUEUED,DFNCNT,BYIMIMM,IMMCNT,NODFNCNT,NEWIMCNT,ADDIMCNT,MSGCNT,RXACNT
+2 DO FILE
+3 IF $DATA(BYIMQUIT)
QUIT
+4 DO PATH^BYIMIMM6
+5 IF IPATH=""
Begin DoDot:1
+6 IF '$DATA(ZTQUEUED)
WRITE !!,"No directory path found."
+7 HANG 4
End DoDot:1
QUIT
I1 ;EP;FOR AUTO IMPORT MODE
+1 SET Y=$$OPEN^%ZISH(IPATH,FILE,"R")
+2 IF Y
Begin DoDot:1
+3 IF '$GET(AUTOADD)&'$DATA(ZTQUEUED)
Begin DoDot:2
+4 WRITE !!,*7,"Cannot find FILE: ",FILE
+5 WRITE !,*7," in DIRECTORY: ",IPATH
End DoDot:2
+6 SET BYIMQUIT=""
+7 DO PAUSE^BYIMIMM6
End DoDot:1
IF $DATA(BYIMQUIT)
QUIT
+8 DO CLOSE^%ZISH()
+9 IF '$GET(AUTOIMP)
Begin DoDot:1
+10 WRITE !!,"Import of immunizations of patients from the"
+11 WRITE !,"State Immunization registry may take several minutes."
+12 SET DIR(0)="YO"
+13 SET DIR("A")="Do you want to proceed"
+14 SET DIR("B")="NO"
+15 WRITE !
+16 DO ^DIR
+17 KILL DIR
+18 IF Y'=1
SET BYIMQUIT=""
End DoDot:1
+19 IF $DATA(BYIMQUIT)
QUIT
+20 DO NCNT^BYIMIMM2
+21 DO IN(IPATH,FILE)
+22 QUIT
+23 ;-----
IN(IPATH,FILE) ;EP;TO PROCESS INCOMING FILE
+1 ;IPATH - INBOUND FILE PATH
+2 ;FILE - INBOUND FILE
+3 IF '$GET(AUTOIMP)
WRITE !!,"Please do not interrupt."
+4 SET (DFNCNT,NODFNCNT,IMMCNT,NEWIMCNT,BYIMIMM,ADDIMCNT,MSGCNT,RXACNT)=0
+5 DO READ(IPATH,FILE)
+6 IF $GET(AUTOADD)
DO S1
+7 DO LOG^BYIMIMM4(FILE,"I",DFNCNT,RXACNT,NODFNCNT,NEWIMCNT,ADDIMCNT,IPATH)
+8 IF '$GET(AUTOIMP)
IF '$GET(AUTOADD)
IF '$DATA(ZTQUEUED)
DO MATCH^BYIMIMM2
+9 DO ADDIM
+10 KILL AUTOIMP,AUTOADD
+11 QUIT
+12 ;-----
READ(IPATH,FILE) ;PEP pull up a file into the TMP global for display
+1 NEW Y,X,I,J,OPATH
+2 SET MSGCNT=0
+3 SET RXACNT=0
+4 SET J=1
+5 SET Y=$$OPEN^%ZISH(IPATH,FILE,"R")
+6 IF Y
Begin DoDot:1
+7 IF '$GET(AUTOIMP)
WRITE !,*7,"CANNOT OPEN (OR ACCESS) FILE '",IPATH,FILE,"'."
+8 SET BYIMQUIT=""
End DoDot:1
QUIT
+9 ;THE READ STATEMENT BELOW IS A READ FROM A HOST FILE WHICH REQUIRES A
+10 ;DIRECT READ VS AN FM/DIR CALL SAC EXEMPTION REQUESTED
+11 KILL ^BYIMTMP($JOB,"BYIM IMM")
+12 NEW RX
+13 SET RX="R"_" X:"_"DTIME"
+14 FOR I=1:1
USE IO
XECUTE RX
SET STATUS=$$STATUS^%ZISH
IF STATUS=1!(STATUS=-1)!(X="")
QUIT
IF "|MSH|PID|RXA|"[("|"_$EXTRACT(X,1,3)_"|")
DO INSET^BYIMIMM2
+15 DO CLOSE^%ZISH()
+16 IF '$DATA(^BYIMTMP($JOB,"BYIM IMM"))
QUIT
+17 DO SET
+18 KILL ^BYIMTMP($JOB,"BYIM IMM")
+19 QUIT
+20 ;-----
SET ;EP;ID PATIENTS AND SET NEW IMMUNIZATIONS
+1 SET AUTOADD=$PIECE($GET(^BYIMPARA(DUZ(2),0)),U,5)
+2 SET INHDA=0
+3 FOR
SET INHDA=$ORDER(^BYIMTMP($JOB,"BYIM IMM",INHDA))
IF 'INHDA
QUIT
DO SET1(INHDA)
+4 IF $GET(OLDDUZ(2))
SET Z=2
SET DUZ(Z)=OLDDUZ(2)
KILL OLDDUZ
+5 IF '$DATA(^BYIMXTMP("BYIM"))
QUIT
+6 DO FMINIT
+7 SET BYIMCNT=BYIMJ
+8 QUIT
+9 ;-----
SET1(INHDA) ;EP;TO PROCESS INCOMING HL7 MESSAGE
+1 ;VERIFY PATIENT ID
DO ID
+2 IF $DATA(BYIMQUIT)
KILL BYIMQUIT
QUIT
+3 SET DFNCNT=$GET(DFNCNT)+1
+4 ;CHECK EACH INCOMING IMMUNIZATION
DO IMM
+5 IF '$DATA(ZTQUEUED)
USE 0
WRITE "/"
+6 QUIT
+7 ;-----
ID ;ID PATIENT
+1 IF $GET(OLDDUZ(2))
SET Z=2
SET DUZ(Z)=OLDDUZ(2)
KILL OLDDUZ
+2 NEW J
+3 SET PID=""
+4 SET J=0
+5 FOR
SET J=$ORDER(^INTHU(INHDA,3,J))
IF 'J!(PID["PID|")
QUIT
IF $EXTRACT(^(J,0),1,4)="PID|"
SET PID=^(0)
+6 IF PID=""
SET BYIMQUIT=""
QUIT
+7 SET PIDX=$PIECE(PID,"|",4)
+8 FOR J=1:1:$LENGTH(PIDX,"~")
SET X=$PIECE($PIECE(PIDX,"~",J),U)
IF $EXTRACT(X,1,4)="RPMS"
SET X=$EXTRACT(X,5,99)
IF $LENGTH(X)=12
QUIT
+9 SET HRN=+$EXTRACT(X,7,99)
+10 SET FACILITY=$EXTRACT(X,1,6)
+11 SET X=$PIECE(PID,"|",6)
+12 SET X=$PIECE(X,U)_","_$PIECE(X,U,2)_$SELECT($PIECE(X,U,3)]"":" "_$PIECE(X,U,3),1:"")
+13 SET (NAME,FULLNAME)=X
+14 IF FACILITY]""
IF $ORDER(^AUTTLOC("C",FACILITY,0))
SET Z=2
SET OLDDUZ(Z)=DUZ(2)
SET DUZ(Z)=$ORDER(^AUTTLOC("C",FACILITY,0))
+15 SET DOB=$EXTRACT($PIECE(PID,"|",8),1,8)-17000000
+16 SET SEX=$PIECE(PID,"|",9)
+17 SET X=HRN
+18 SET DIC="^DPT("
+19 SET DIC(0)="MZ"
+20 SET DIC("S")="I $P(^DPT(+Y,0),U,3)=DOB,$P(^(0),U,2)=SEX"
+21 SET AUPNLK("ALL")=""
+22 SET AUPNLK("INAC")=""
+23 DO ^DIC
+24 KILL DIC,DINUM,DR,DA,DLAYGO
+25 IF $GET(OLDDUZ(2))
SET Z=2
SET DUZ(Z)=OLDDUZ(2)
+26 IF +Y<1
Begin DoDot:1
+27 SET X=$PIECE(PID,"|",6)
+28 SET X=$PIECE(X,U)_","_$PIECE(X,U,2)_$SELECT($PIECE(X,U,3)]"":" "_$PIECE(X,U,3),1:"")
+29 SET DIC="^DPT("
+30 SET DIC(0)="MZ"
+31 SET DIC("S")="I $P(^DPT(+Y,0),U,3)=DOB,$P(^(0),U,2)=SEX"
+32 SET AUPNLK("ALL")=""
+33 SET AUPNLK("INAC")=""
+34 DO ^DIC
+35 KILL DIC,DINUM,DR,DA,DLAYGO
End DoDot:1
+36 IF +Y<1
Begin DoDot:1
+37 SET X=$TRANSLATE($PIECE(PID,"|",6),".","")
+38 SET X=$PIECE(X,U)_","_$PIECE(X,U,2)
+39 SET DIC="^DPT("
+40 SET DIC(0)="MZ"
+41 SET DIC("S")="I $P(^DPT(+Y,0),U,3)=DOB,$P(^(0),U,2)=SEX"
+42 DO ^DIC
+43 KILL DIC,DINUM,DR,DA,DLAYGO
End DoDot:1
+44 IF +Y<1
Begin DoDot:1
+45 DO DIRECT
+46 IF Y>0
QUIT
+47 SET BYIMQUIT=""
+48 IF $LENGTH(FULLNAME)
IF $LENGTH(DOB)
IF $LENGTH(SEX)
IF '$DATA(^BYIMPARA("NMNAME",FULLNAME))
Begin DoDot:2
+49 ;RECORD NO MATCH PATIENTS
+50 SET DA(1)=DUZ(2)
+51 SET DIC="^BYIMPARA("_DUZ(2)_",4,"
+52 SET DIC(0)="LZ"
+53 SET X=FULLNAME
+54 SET DIC("DR")=".02////"_(DOB+17000000)_";.03////"_$EXTRACT(FILE,7,14)_";.04////"_SEX_";.05////"_$GET(MM)_";.06////"_$GET(UIF)
+55 DO FILE^DICN
+56 SET NODFNCNT=$GET(NODFNCNT)+1
+57 SET Y=-1
End DoDot:2
End DoDot:1
IF Y<1
QUIT
+58 SET DFN=+Y
+59 IF '$DATA(^AUPNPAT(DFN,41,DUZ(2),0))
Begin DoDot:1
+60 KILL OLDDUZ
+61 NEW XX
+62 SET XX=0
+63 FOR
SET XX=$ORDER(^AUPNPAT(DFN,41,XX))
IF 'XX!$GET(OLDDUZ(2))
QUIT
Begin DoDot:2
+64 SET Z=2
SET OLDDUZ(Z)=DUZ(2)
+65 SET Z=2
SET DUZ(Z)=XX
+66 KILL BYIMQUIT
End DoDot:2
+67 IF '$GET(OLDDUZ(2))
SET BYIMQUIT=""
End DoDot:1
+68 IF $GET(^DPT(DFN,.35))
SET BYIMQUIT=""
+69 QUIT
+70 ;-----
DIRECT ;DIRECT FIND OF PATIENT
+1 DO DIRECT^BYIMIMM3
+2 QUIT
+3 ;-----
IMM ;COMPARE INCOMING IMMUNIZATIONS WITH EXISTING IMMUNIZATIONS
+1 NEW X,Y,Z,ZZ,BYIMY,LOT
+2 SET J=2
+3 FOR
SET J=$ORDER(^INTHU(INHDA,3,J))
IF 'J
QUIT
SET BYIMY=^(J,0)
IF $EXTRACT(BYIMY,1,3)="RXA"
Begin DoDot:1
+4 SET Z=$EXTRACT($PIECE(BYIMY,"|",4),1,8)-17000000
+5 SET Y=+$PIECE($PIECE(BYIMY,"|",6),U)
+6 IF Y=999
QUIT
+7 IF 'Y!'Z
QUIT
+8 SET IMMCNT=$GET(IMMCNT)+1
+9 SET IMM=Y
+10 DO CONVERT
+11 SET Y=IMM
+12 SET X=$PIECE(BYIMY,"|",12)
+13 SET X=$PIECE(X,U,4)_U_$PIECE(X,U)
+14 SET VOL=+$PIECE(BYIMY,"|",7)
+15 IF 'VOL!(VOL[999)
SET VOL=""
+16 SET LOT=$PIECE(BYIMY,"|",16)
+17 SET MAN=$PIECE($PIECE(BYIMY,"|",18),U,1,2)
+18 SET ^BYIMXTMP("BYIM",DOB,NAME,DFN,Y,Z)=INHDA_U_Z_U_X_U_LOT_U_MAN_U_VOL
+19 IF '$ORDER(IMM(0))
QUIT
+20 SET Y=0
+21 FOR
SET Y=$ORDER(IMM(Y))
IF 'Y
QUIT
Begin DoDot:2
+22 SET ^BYIMXTMP("BYIM",DOB,NAME,DFN,Y,Z)=INHDA_U_Z_U_X
End DoDot:2
End DoDot:1
+23 SET X=0
+24 FOR
SET X=$ORDER(^AUPNVIMM("AC",DFN,X))
IF 'X
QUIT
Begin DoDot:1
+25 SET Y=$GET(^AUPNVIMM(X,0))
+26 SET Z=$PIECE($GET(^AUPNVSIT(+$PIECE(Y,U,3),0)),".")
+27 SET Y=+Y
+28 IF 'Y!'Z
QUIT
+29 KILL ^BYIMXTMP("BYIM",DOB,NAME,DFN,Y,Z)
+30 DO KILL^BYIMIMM2
End DoDot:1
+31 QUIT
+32 ;-----
DEL ;EP;DEL IMMUNIZATIONS FROM THE STATE REGISTRY LIST
+1 NEW DEL
+2 SET DEL=""
ADD ;EP;ADD NEW IMMUNIZATIONS FROM THE STATE REGISTRY
+1 KILL BYIMQUIT
+2 DO SELECT
+3 IF $DATA(BYIMQUIT)
KILL BYIMQUIT
QUIT
+4 DO CLEAR^VALM1
+5 DO NEWIMM
BACK SET VALMBCK="R"
+1 QUIT
+2 ;-----
SELECT ;SELECT CHILD TO ADD
+1 IF BYIMJ-3=0
Begin DoDot:1
+2 WRITE !!,"No Immunizations to ",$SELECT('$DATA(DEL):"Add",1:"Delete"),"..."
+3 HANG 3
End DoDot:1
QUIT
+4 SET DIR(0)="LO^1:"_(BYIMJ-3)
+5 SET DIR("A")="Select Immunization(s) to "_$SELECT('$DATA(DEL):"add to RPMS",1:"delete from the list")
+6 WRITE !
+7 DO ^DIR
+8 KILL DIR
+9 IF 'Y
SET BYIMQUIT=""
QUIT
+10 MERGE BYIMY=Y
+11 QUIT
+12 ;-----
S1 ;FOR AUTOADD TO SET ADD ARRAY
+1 NEW X,Y,Z,J
+2 FOR J=1:1:$GET(BYIMJ)-3
SET BYIMY(J)=J
NEWIMM ;ADD NEW IMMUNIZATION
+1 KILL BYIMPAUS
+2 NEW XX
+3 SET XX=""
+4 FOR
SET XX=$ORDER(BYIMY(XX))
IF XX=""
QUIT
Begin DoDot:1
+5 SET YY=BYIMY(XX)
+6 FOR JJ=1:1
SET ZZ=$PIECE(YY,",",JJ)
IF ZZ=""
QUIT
DO NI1
End DoDot:1
+7 QUIT
NI1 ;NEW IMMUNIZATION
+1 KILL NEWLOT
+2 SET NUM=ZZ+3
+3 SET (X,BYIMX)=$GET(^BYIMTMP($JOB,"BYIM DISP","DFN",NUM))
+4 IF $EXTRACT(X)="*"!(X="")
QUIT
+5 ;1 = NAME
+6 ;2 = DFN
+7 ;3 = ADMIN DATE
+8 ;4 = CVX CODE
+9 ;5 = IMM IEN
+10 ;6 = LOC
+11 ;7 = DOB
+12 ;8 = LOC2
+13 ;9 = LOT NUM
+14 ;10 = MVX CODE
+15 ;11 = MANUF NAME
+16 ;12 = VOLUME
+17 SET NAME=$PIECE(X,U)
+18 SET DFN=$PIECE(X,U,2)
+19 SET VDATE=$PIECE(X,U,3)
+20 SET IMM=$PIECE(X,U,4)
+21 DO CONVERT
+22 SET IVDA=$PIECE(X,U,5)
+23 SET LOC=$PIECE(X,U,6)
+24 SET LOC2=$PIECE(X,U,8)
+25 IF LOC=""
IF LOC2]""
SET LOC=LOC2
+26 IF LOC=""
SET LOC="OTHER"
+27 SET DOB=$PIECE(X,U,7)
+28 SET LOT=$PIECE(X,U,9)
+29 SET LOTDA=""
+30 SET MVX=$PIECE(X,U,10)
+31 SET MAN=$PIECE(X,U,11)
+32 SET VOL=$PIECE(X,U,12)
+33 IF LOT]""
IF IMM]""
IF MVX]""
Begin DoDot:1
+34 IF $TEXT(ADDLOT^BIRPC5)]""
Begin DoDot:2
+35 SET BYIMDATA=LOT_"|"_IMM_"|"_MVX
+36 DO ADDLOT^BIRPC5(.BYIMERR,BYIMDATA,.LOTDA)
End DoDot:2
+37 IF $TEXT(ADDLOT^BIRPC5)=""
Begin DoDot:2
+38 DO LOT^BYIMIMM4(LOT,MAN,IVDA)
End DoDot:2
End DoDot:1
+39 KILL APCDALVR("APCDAFLG"),BYIMERR
+40 NEW BYIMDUZ,NEWLOT
+41 IF $GET(LOTDA)
IF $PIECE($GET(^AUTTIML(LOTDA,0)),U,3)
SET $PIECE(^(0),U,3)=0
SET NEWLOT=LOTDA
+42 SET BYIMDUZ=DUZ
+43 IF '$DATA(DEL)
DO VISIT
+44 SET X="DUZ"
+45 SET @X=BYIMDUZ
+46 IF $GET(NEWLOT)
SET $PIECE(^AUTTIML(NEWLOT,0),U,3)=1
KILL NEWLOT
+47 IF $GET(BYIMERR)]""&'$DATA(DEL)
QUIT
+48 SET X=BYIMX
+49 KILL ^BYIMXTMP("BYIM",$PIECE(X,U,7),$PIECE(X,U),$PIECE(X,U,2),$PIECE(X,U,4),$PIECE(X,U,3))
+50 KILL ^BYIMTMP($JOB,"BYIM IMM","DFN",NUM)
+51 SET Z=VDATE
+52 SET Y=$ORDER(^AUTTIMM("C",IMM,0))
+53 IF 'Y!'Z
QUIT
+54 DO KILL^BYIMIMM2
+55 QUIT
+56 ;-----
VISIT ;FIND OR CREATE VISIT
+1 KILL BYIMDUZ
+2 SET BYIMDUZ=DUZ
+3 DO DUZ
+4 DO LOCIN(LOC)
+5 NEW P
+6 SET P="|"
+7 SET BYIMERR=""
+8 SET $PIECE(BYIMDATA,P,1)="I"
+9 SET $PIECE(BYIMDATA,P,2)=DFN
+10 SET $PIECE(BYIMDATA,P,3)=IVDA
+11 SET $PIECE(BYIMDATA,P,6)=VDATE_".12"
+12 SET $PIECE(BYIMDATA,P,7)=LOCDA
+13 SET $PIECE(BYIMDATA,P,8)=$EXTRACT($SELECT($EXTRACT(LOC2)?1U&(LOC2'=LOC):LOC2,1:LOC),1,50)
+14 SET $PIECE(BYIMDATA,P,9)="E"
+15 SET $PIECE(BYIMDATA,P,21)=$GET(VOL)
+16 SET $PIECE(BYIMDATA,P,23)=DUZ(2)
+17 SET $PIECE(BYIMDATA,P,25)=1
+18 DO ADDEDIT^BIRPC3(.BYIMERR,BYIMDATA,1)
+19 IF $GET(OLDDUZ(2))
SET Z=2
SET DUZ(Z)=OLDDUZ(2)
KILL OLDDUZ
+20 IF BYIMERR]""
Begin DoDot:1
+21 KILL BYIMQUIT
+22 IF BYIMERR["Lot Number"
SET BYIMERR="**"_$PIECE($GET(^AUTTIML(+$GET(LOTDA),0)),U)_"** "_BYIMERR
+23 SET BYIMERR=BYIMERR_" - V IMMUNIZATIONN CREATION FAILED"
+24 SET X="DUZ"
SET @X=BYIMDUZ
+25 NEW %X,%Y,X,XMB,XMDT,XMDUZ,Y1
+26 SET XMB="BYIM V IMM CREATION FAILED"
+27 SET XMB(1)=$PIECE(^DPT(DFN,0),U)_" (DOB: "_$EXTRACT($PIECE(^(0),U,3),4,5)_"/"_$EXTRACT($PIECE(^(0),U,3),6,7)_"/"_$EXTRACT($PIECE(^(0),U,3),1,3)+17000
+28 SET XMB(2)=IMM_" - "_$PIECE($GET(^AUTTIMM(IVDA,0)),U)
+29 NEW X
+30 SET X=VDATE
+31 SET XMB(3)=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,1,3)+1700
+32 SET XMB(4)=BYIMERR
+33 SET XMDUZ=.5
+34 DO ^XMB
+35 IF '$DATA(ZTQUEUED)
IF $GET(BYIMPAUS)'[U
Begin DoDot:2
+36 WRITE !!,"Visit not added:"
+37 WRITE !,BYIMERR
+38 WRITE !!,"Patient.....: ",XMB(1)
+39 WRITE !,"Immunization: ",XMB(2)
+40 WRITE !,"Visit Date..: ",XMB(3)
+41 DO PAUSE^BYIMIMM6
End DoDot:2
End DoDot:1
QUIT
+42 SET ADDIMCNT=$GET(ADDIMCNT)+1
+43 IF '$GET(LOTDA)
QUIT
+44 DO ADDLOT^BYIMIMM6(DFN,IVDA,LOTDA,VDATE)
+45 QUIT
+46 ;-----
CONVERT ;CONVERT INACTIVE VACCINE TO ACTIVE EQUIVALENT
+1 IF IMM=105
SET IMM=75
SET OLDIMM=105
+2 IF IMM=17
SET IMM=47
SET OLDIMM=17
+3 IF IMM=31
SET IMM=83
SET OLDIMM=31
+4 QUIT
+5 ;-----
FMINIT ;EP;PUT NEW IMMUNIZATIONS INTO TMP STORAGE FOR
+1 KILL ^BYIMTMP($JOB,"BYIM DISP")
+2 NEW A,B,C,X,Y,Z,J,XXX
+3 SET J=3
+4 SET DOB=9999999
+5 FOR
SET DOB=$ORDER(^BYIMXTMP("BYIM",DOB),-1)
IF 'DOB
QUIT
Begin DoDot:1
+6 SET A=""
+7 FOR
SET A=$ORDER(^BYIMXTMP("BYIM",DOB,A))
IF A=""
QUIT
Begin DoDot:2
+8 SET B=0
+9 FOR
SET B=$ORDER(^BYIMXTMP("BYIM",DOB,A,B))
IF 'B
QUIT
Begin DoDot:3
+10 SET C=0
+11 FOR
SET C=$ORDER(^BYIMXTMP("BYIM",DOB,A,B,C))
IF 'C
QUIT
Begin DoDot:4
+12 SET X=0
+13 FOR
SET X=$ORDER(^BYIMXTMP("BYIM",DOB,A,B,C,X))
IF 'X
QUIT
SET XXX=^(X)
DO FM
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET (BYIMJ,VALMCNT)=J
+15 SET NEWIMCNT=J-3
+16 DO BACK
+17 QUIT
+18 ;-----
FM ;SET DISPLAY GLOBAL
+1 SET XX=$PIECE(XXX,U,2)
+2 SET DATE=$EXTRACT(XX,4,5)_"/"_$EXTRACT(XX,6,7)_"/"_(1700+$EXTRACT(XX,1,3))
+3 SET IVDA=+$ORDER(^AUTTIMM("C",C,0))
+4 IF 'IVDA
SET ^BYIMTMP($JOB,"BYIM TEST","NO IMM CODE: "_C)=""
QUIT
+5 SET IMM=$PIECE($GET(^AUTTIMM(+IVDA,0)),U,2)
+6 IF IMM=""
SET ^BYIMTMP($JOB,"BYIM TEST","NO IMM CODE 2: "_IMM)=""
QUIT
+7 SET J=J+1
+8 SET IMM=IMM_"-"_C
+9 SET T=J-3
+10 SET $EXTRACT(T,5)=DOB+17000000
+11 SET $EXTRACT(T,14)=$EXTRACT(A,1,28)
+12 SET $EXTRACT(T,43)=IMM
+13 SET $EXTRACT(T,60)=$PIECE(XXX,U,5)
+14 SET $EXTRACT(T,71)=DATE
+15 SET ^BYIMTMP($JOB,"BYIM DISP",J,0)=T
+16 SET ^BYIMTMP($JOB,"BYIM DISP","DFN",J)=A_U_B_U_XX_U_C_U_IVDA_U_$PIECE(XXX,U,3)_U_DOB_U_$PIECE(XXX,U,4)_U_$PIECE(XXX,U,5)_U_$PIECE(XXX,U,6)_U_$PIECE(XXX,U,7)_U_$PIECE(XXX,U,8)
+17 ;A = NAME
+18 ;B = DFN
+19 ;XX = ADMIN DATE
+20 ;C = CVX CODE
+21 ;IVDA = IMM IEN
+22 ;$P(XXX,U,3) = LOC
+23 ;DOB = DOB
+24 ;$P(XXX,U,4) = LOC2
+25 ;$P(XXX,U,5) = LOT NUM
+26 ;$P(XXX,U,6) = MVX CODE
+27 ;$P(XXX,U,7) = MANUF NAME
+28 ;$P(XXX,U,8) = VOLUME
+29 SET BYIMCNT=+T
+30 QUIT
+31 ;-----
HDR ;EP;FOR LIST HEADER
+1 SET ^BYIMTMP($JOB,"BYIM DISP",1,0)=" "_$SELECT($GET(VALMCNT):" ("_(VALMCNT-3)_")",1:"")_" Immunizations from the State Registry"
+2 SET T="NUM"
+3 SET $EXTRACT(T,5)="DOB"
+4 SET $EXTRACT(T,14)="NAME"
+5 SET $EXTRACT(T,43)="IMMUNIZATION-CVX"
+6 SET $EXTRACT(T,60)="LOT NO."
+7 SET $EXTRACT(T,71)="DATE REC'D"
+8 SET ^BYIMTMP($JOB,"BYIM DISP",2,0)=T
+9 SET T="---"
+10 SET $EXTRACT(T,5)="--------"
+11 SET $EXTRACT(T,14)="----------------------------"
+12 SET $EXTRACT(T,43)="----------------"
+13 SET $EXTRACT(T,60)="----------"
+14 SET $EXTRACT(T,71)="----------"
+15 SET ^BYIMTMP($JOB,"BYIM DISP",3,0)=T
+16 QUIT
+17 ;-----
START ;EP;
+1 SET BYIMVALM="BYIM STATE IMMUNIZATIONS"
+2 DO VALM(BYIMVALM)
+3 QUIT
VALM(BYIMVALM) ;EP; -- main entry point for list templates
+1 ;1=screen mode, 0=scrolling mode
SET VALMCC=1
+2 DO TERM^VALM0
+3 DO CLEAR^VALM1
+4 DO EN^VALM(BYIMVALM)
+5 DO CLEAR^VALM1
+6 KILL ^BYIMTMP($JOB,"BYIM DISP")
+7 QUIT
+8 ;-----
PARAM ;EP;TO UPDATE PARAMETERS
+1 NEW DA,DR,DIC,DIE,BYIMDA
+2 DO PADD
+3 IF DA<1
QUIT
+4 SET DIE="^BYIMPARA("
+5 SET DR="[BYIM SET PARAMETERS]"
+6 WRITE @IOF
+7 WRITE !!,"UPDATE Data Exchange Parameters for ",$PIECE(^DIC(4,DA,0),U)
+8 WRITE !
+9 DO ^DIE
+10 DO PATH^BYIMIMM6
+11 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+12 QUIT
+13 ;-----
PADD ;EP;TO ADD PARAMETER SITE
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 SET DIC="^BYIMPARA("
+3 SET DIC(0)="AEMLQZ"
+4 SET DIC("A")="Select SITE for Data Exchange Parameters: "
+5 SET DIC("B")=$PIECE(^DIC(4,DUZ(2),0),U)
+6 WRITE @IOF
+7 WRITE !!,"ADD Data Exchange Parameter Site"
+8 WRITE !
+9 DO ^DIC
+10 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+11 SET (BYIMDA,DA)=+Y
+12 QUIT
+13 ;-----
DUZ ;SET DUZ FOR VISIT 'CREATED BY USER'
+1 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+2 NEW X,Y,Z
+3 SET X="USER,IMMUNIZATION INTERFACE"
+4 SET Y=$ORDER(^VA(200,"B",X,0))
+5 IF 'Y
Begin DoDot:1
+6 SET DIC="^VA(200,"
+7 SET DIC(0)="M"
+8 SET DIC("DR")="3////@"
+9 DO FILE^DICN
+10 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+11 SET Y=+Y
End DoDot:1
+12 IF Y<1
SET Y=.5
+13 SET X="DUZ"
SET @X=+Y
+14 QUIT
+15 ;-----
ADDIM ;EP;PROCESS ADDITIONAL IMPORT FILES
+1 NEW BYIMAS
+2 SET BYIMDA=DUZ(2)
+3 SET BYIMAS=0
+4 FOR
SET BYIMAS=$ORDER(^BYIMPARA(BYIMDA,3,BYIMAS))
IF 'BYIMAS
QUIT
Begin DoDot:1
+5 SET X=^BYIMPARA(BYIMDA,3,BYIMAS,0)
+6 SET IPATH=$PIECE(X,U,3)
+7 DO ADDIM1
End DoDot:1
+8 QUIT
+9 ;-----
ADDIM1 ;PROCESS EACH ADDIONAL IMPORT SITE
+1 IF '$GET(AUTOIMP)
Begin DoDot:1
+2 IF '$DATA(ZTQUEUED)
WRITE !!,"Processing additional import files."
+3 IF '$DATA(ZTQUEUED)
WRITE !,"Please do not interrupt."
End DoDot:1
+4 SET (DFNCNT,NODFNCNT,IMMCNT,NEWIMCNT,BYIMIMM,ADDIMCNT,MSGCNT,RXACNT)=0
+5 DO READ(IPATH,FILE)
+6 IF $GET(AUTOADD)
DO S1
+7 DO LOG^BYIMIMM4(FILE,"I",DFNCNT,RXACNT,NODFNCNT,NEWIMCNT,ADDIMCNT,IPATH)
+8 IF '$GET(AUTOIMP)
IF '$GET(AUTOADD)
IF '$DATA(ZTQUEUED)
DO MATCH^BYIMIMM2
+9 QUIT
+10 ;-----
LOCIN(LOC) ;PROCESS LOCATION DATA FOR FACILITY NAME OR CODE
+1 IF LOC=""
SET LOC="OTHER"
+2 SET LOCDA=0
+3 SET LOCDA=$ORDER(^BYIMPARA("RXA",LOC,0))
+4 IF LOCDA
SET LOCDA=$ORDER(^BYIMPARA("RXA",LOC,LOCDA,0))
+5 IF 'LOCDA
SET LOCDA=$SELECT($ORDER(^DIC(4,"B",LOC,0)):$ORDER(^DIC(4,"B",LOC,0)),1:$ORDER(^DIC(4,"B","OTHER",0)))
+6 IF $PIECE($GET(^DIC(4,+LOCDA,0)),U)="OTHER"
IF LOC2]""
IF $ORDER(^DIC(4,"B",LOC2,0))
SET LOCDA=$ORDER(^DIC(4,"B",LOC2,0))
SET LOC=LOC2
+7 IF $PIECE(^DIC(4,+LOCDA,0),U)="OTHER"
IF $PIECE($GET(^BISITE($SELECT($GET(OLDDUZ(2)):OLDDUZ(2),1:+$GET(DUZ(2))),0)),U,3)
IF LOCDA'=$PIECE(^(0),U,3)
SET LOCDA=$PIECE(^(0),U,3)
+8 IF $PIECE(^DIC(4,+LOCDA,0),U)'="OTHER"
QUIT
+9 ;DETERMINE STATE FOR 'OTHER' FACILITY
+10 NEW X,Y,Z
+11 SET X=$PIECE($GET(^DIC(4,+$GET(DUZ(2)),0)),U,2)
+12 IF 'X
QUIT
+13 SET Z=0
+14 SET Y=0
+15 FOR
SET Y=$ORDER(^DIC(4,"B","OTHER",Y))
IF 'Y!Z
QUIT
Begin DoDot:1
+16 IF $PIECE($GET(^DIC(4,Y,0)),U,2)=X
SET Z=Y
End DoDot:1
+17 IF Z
SET LOCDA=Z
+18 QUIT
+19 ;
