Routine: BYIMRT

BYIMRT ;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

 ;REAL-TIME PROCESSING

 ;-----

RT ;EP;FOR REAL TIME QUERIES

 F  D RT1 Q:$D(BYIMQUIT)

 K BYIMQUIT

 ;-----

RT1 ;REAL TIME

 D PATH^BYIMIMM6

 K BYIMQTX,BYIMQUIT

 S BYIMQTX=$S(BYIMQT=1:"VXQ",1:"QBP")

 N RT

 W @IOF

 W !!?10,"Real-Time Query Options - Version: ",BYIMVER

 K DIR

 S DIR(0)="SO^1:Get  a Patient's Immunizations FROM State IIS;2:Send a Patient's Immunizations TO   State IIS;3:Review State IIS Responses;4:Check for Additional Response Messages"

 S DIR("A")="Select the action type"

 D ^DIR

 K DIR

 I 'Y S BYIMQUIT=1 Q

 S RT=$S(Y=1:"VXQ",Y=2:"VXU",Y=3:"RESP",Y=4:"RTIN",1:"")

 I RT="RESP" D RESP K BYIMQUIT Q

 I RT="RTIN" D  Q

 .W !!,"Checking for query responses that have not yet been processed."

 .W !!,"Please stand by..."

 .H 4

 .N BYIMRTIN

 .S BYIMRTIN=1

 .D RTIN

 .W !!,"Please check 'Review State IIS Responses' for new IIS responses."

 .D PAUSE^BYIMIMM6

 .K BYIMQUIT

 D PAT

 Q:'$D(^TMP($J,"BYIM RT"))

 D SEND

 K ^TMP($J,"BYIM RT")

 ;-----

PAT ;

 K ^TMP($J,"BYIM RT")

 I RT="VXU" D ALL

 W !!,"Select patient(s) to send to the State Immunization Registry"

 F  D P1 Q:$D(BYIMQUIT)

 K BYIMQUIT

 ;-----

P1 ;SELECT MULTIPE PATIENTS

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC=9000001

 S DIC("A")="Select "_$S($D(^TMP($J,"BYIM RT")):"another ",1:"")_"patient: "

 S DIC(0)="AEQM"

W !

 D ^DIC

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 I Y<1 S BYIMQUIT="" Q

 S ^TMP($J,"BYIM RT",+Y)=""

 D RTPAT

 ;-----

SEND ;SEND RT QUERY

 W !!,$S(RT="VXQ":"A 'Query for Vaccination Record ("_BYIMQTX_")'",1:"An 'Unsolicited Vaccine Record Update (VXU)'")," will be sent for:"

 D RTPAT

 K DIR

 S DIR(0)="YO"

 S DIR("A")="Do you want to proceed"

 S DIR("B")="YES"

W !

 D ^DIR

 K DIR

 Q:Y'=1

 I '$D(ZTQUEUED)&$D(^TMP($J,"BYIM RT")) D

 .W !!,"Please stand by.  This may take a couple of seconds...",!

 S DFN=0

 F  S DFN=$O(^TMP($J,"BYIM RT",DFN)) Q:'DFN  D

 .D:RT="VXQ" VXQ(DFN)

 .D:RT="VXU" VXU(DFN)

 .K ^TMP($J,"BYIM RT",DFN)

 K ^TMP($J,"BYIM RT")

 D PAUSE^BYIMIMM6

 ;-----

RTPAT ;DISPLAY PATIENTS FOR RT QUERY

 N DFN

W !

 S DFN=0

 F  S DFN=$O(^TMP($J,"BYIM RT",DFN)) Q:'DFN  D

 .W !," *** ",$P(^DPT(DFN,0),U)," *** "

 ;-----

VXQ(DFN) ;EP;TO SEND VXQ MESSAGE

 W:'$D(ZTQUEUED) !,"Query being sent for: ",$J(DFN,6),"  ",$P(^DPT(DFN,0),U)

 D DELAY

 S Y=$$VXQX(DFN)

DELAY Q:$D(ZTQUEUED)

 W "  "

 F J=1:1:3 W "." H 1

 ;-----

VXU(DFN) ;EP;TO SEND VXU MESSAGE

 N VST

 S VST=$O(^AUPNVSIT("AC",DFN,9999999999),-1)

 Q:'VST

 S Y=$$V04^BYIMIMM(VST,BYIMALL)

 W:'$D(ZTQUEUED) !,"Immunization record being sent for: ",$J(DFN,6),"  ",$P(^DPT(DFN,0),U)

 D DELAY

 S INHF=+Y

 Q:'INHF

 S BYIMUIF=$O(^INTHU("AT",INHF,0))

 Q:'BYIMUIF

 D LOGD^BYIMIMM4(DFN,"E")

 D RXR(BYIMUIF)

 S BYIMSTP="VXU"

 D SFILE(BYIMUIF,DFN,BYIMSTP)

 D CLEANVXU(BYIMUIF)

 ;-----

RSP ;EP;IMMUNIZATION DATA EXCHANGE

 S BHLDEST="D DEST^INHUSEN"

 S INDEST("RSPK11")="HL IHS IZV04 RSP IN"

 X BHLDEST

 ;-----

RESP ;EP;REVIEW RT RESPONSE FILES

 K BYIMQUIT

 F  D RESP1 Q:$D(BYIMQUIT)

 ;-----

RESP1 ;REVIEW RESPONSES

 K BYIMQUIT

 K ^TMP($J,"BYIM RT")

 N DFN,RT

 W @IOF

 W !!?10,"Review Responses from the State IIS"

 K DIR

 S DIR(0)="SO^1:Review Immunizations ready to add to RPMS;2:Review Query Response Messages"

 S DIR("A")="Select the action type"

W !

 D ^DIR

 K DIR,BYIMQUIT

 I 'Y S BYIMQUIT=1 Q

 S RT=$S(Y=1:"START",1:"NON")

 I RT="START" D START Q

 F  D NON Q:$D(BYIMQUIT)

 K BYIMQUIT

 ;-----

START ;

 W @IOF

 W !!?10,"All NEW immunizations for Query Responses from the state"

 W !!?10,"that can be added to RPMS will be listed below."

 W !!

 S DIR("A")="Press <ENTER> to review immunizations, press '^' to exit"

 D PAUSE^BYIMIMM6

 Q:'Y

 D START^BYIMIMM1

 ;-----

NON ;EP;TO REVIEW NON-IMMUNIZATION IIS RESPONSES

 W @IOF

 W !!?10,"Select Responses by Patient or Date"

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S DIC="^BYIMRT("

 S DIC(0)="AEMQ"

 S DIC("A")="Select Query Date or Patient: "

 S DIC("S")="I $P(^(0),U,2)=""E"""

W !

 D ^DIC

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 I Y<0 S BYIMQUIT=1 Q

 D DISP(+Y)

 ;-----

RTIMP(FILE) ;EP;TO AUTOMATICALLY IMPORT REAL-TIME MESSAGES

 K BYIMQUIT

 N AUTOIMP,AUTOADD,DIR

 S AUTOIMP=$P($G(^BYIMPARA(DUZ(2),0)),U,4)

 S AUTOADD=$P($G(^BYIMPARA(DUZ(2),0)),U,5)

 D PATH^BYIMIMM6

 Q:IPATH=""

 S Y=$$OPEN^%ZISH(IPATH,FILE,"R")

Q:Y

 N BYIMJ,BYIMX,UIF

 S UIF=""

 S BYIMJ=0

 ;F  U IO R BYIMX:DTIME D:BYIMX="" CLOSE^%ZISH() Q:BYIMX=""  D

 ;.I BYIMX["MSH|" D  Q:'UIF

 ;..D NEWUIF

 ;.I BYIMX["MSH|" D NEWUIF Q:'UIF

 ;.S BYIMJ=BYIMJ+1

 ;.S ^INTHU(UIF,3,BYIMJ,0)=BYIMX_"|CR|"

 D LOG(UIF,"I",FILE)

 N BYIMXX

 S BYIMXX=0

 F  S BYIMXX=$O(^BYIMTMP($J,"BYIM IMM",BYIMXX)) Q:'BYIMXX  D

 .D SET1^BYIMIMM1(BYIMXX)

 ;-----

LOG(UIF,ACT,FILE) ;LOG RT FILE

 Q:'$G(UIF)

 S ^BYIMTMP($J,"BYIM IMM",UIF)=""

 N XX,DFN

 S DFN=$P(FILE,"_",2)

 S MID=""

 S XX=0

 S:MID'["IHS-" MID=""

 D RTLOG(FILE,ACT,IPATH,DFN,UIF,MID,0)

 ;-----

VXQX(BYIMPAT) ;PEP;send query request for patient IEN - BYIMPAT

 ;BYIMPAT - PATIENT DFN/IEN

 ;RETURNS GIS HL7 MESSAGE CREATION MESSAGE

 I '$G(BYIMPAT)!'$D(^DPT(+$G(BYIMPAT),0)) Q "No Patient identified for DFN "_$G(BYIMPAT)

 D PATH^BYIMIMM6

 S BYIMQTX=$S(BYIMQT=1:"VXQ",1:"QBP")

 N BYIMDEST,INH,INDA,INA

 S INDA=BYIMPAT

 S INDA(2,1)=BYIMPAT

 S INDA(9000001,1)=BYIMPAT

 S INA("QNM",INDA)=""

 S BYIMDEST=$S(BYIMQT=1:"HL IHS IZV04 V01VXQ OUT PARENT",1:"HL IHS IZV04 QBP OUT PARENT")

 D ^INHF(BYIMDEST,.INDA,.INA)

H 2

 I $G(INHF) D

 .S BYIMUIF=$O(^INTHU("AT",INHF,0))

 .Q:'BYIMUIF

 .S BYIMSTP=BYIMQTX

 .D SFILE(BYIMUIF,BYIMPAT,BYIMSTP)

 D EOJ^BYIMIMM

 Q $$MSG^BYIMIMM(INHF)

 ;-----

SFILE(BYIMUIF,BYIMPAT,BYIMSTP) ;EP;TO SEND RT FILE VIA HL7 BRIDGE

 ;BYIMUIF - THE IEN OF THE ^INTHU( ENTRY FOR THE MESSAGE

 ;BYIMPAT - THE IEN OF PATIENT

 ;BYIMSTP - MESSAGE TYPE

 Q:'$G(BYIMUIF)!'$G(BYIMPAT)

 S BYIMSTP=$TR(BYIMSTP,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")

 S MID=""

 D PATH^BYIMIMM6

 D NOW^%DTC

 S QFILE="izrt"_BYIMSTP_$TR(BYIMVER,".")_"_"_$E("000000",1,6-$L(BYIMPAT))_BYIMPAT_"_"_($P(%,".")+17000000)_"_"_$P(%,".",2)_$E("000000",1,6-$L($P(%,".",2)))_".dat"

 S ACT="W"

 D FILE(OPATH,QFILE,ACT,BYIMUIF,BYIMPAT,BYIMSTP)

FILE(PATH,FILE,ACT,BYIMUIF,BYIMPAT,BYIMSTP) ;SEND FILE

 ;OPATH   - PATH FOR TRANSMISSION

 ;FILE    - FILE NAME

 ;ACT     - ACTION

 ;BYIMUIF - IEN IN ^INTHU

 ;BYIMPAT - PATIENT DFN

 ;BYIMSTP -

 S Y=$$OPEN^%ZISH(PATH,FILE,ACT)

 I Y D  Q

 .D EXPBULL^BYIMIMM4(FILE,0,PATH)

 .D RTLOG(FILE,"E",PATH,BYIMPAT,BYIMUIF,MID,1)

 N X,XX

 D REFUSAL^BYIMSEG1(BYIMPAT,BYIMUIF)

 S X=""

 S XX=0

 F  S XX=$O(^INTHU(BYIMUIF,3,XX)) Q:'XX  S READ=^(XX,0) D F1

 D CLOSE^%ZISH()

 D RTLOG(QFILE,"E",OPATH,BYIMPAT,BYIMUIF,MID,0)

 Q:BYIMBDG<1

 N BYIMRTIN

 S BYIMRTIN=0

 D RTIN

 ;-----

F1 ;WRTIE OUT EACH LINE

 S X=X_$P(READ,"|CR|")

 Q:READ'["|CR|"

 S:X["MSH|" MID=$P(X,"|",10)

 S:'BYIMIN1&($E(X,1,4)["IN1|"!($E(X,1,4)["IN2|")) X=""

 S:$E(X,1,5)="RXR||" X=""

 S:X["RXR|ZZZ" X=""

 S:X["OBX|"&(X["V00") X=""

 S:"|MSH|FHS|BHS|BTS|FTS|"'[("|"_$E(X,1,3)_"|") X=$TR(X,"\&")

 I X]"" U IO W X,!

 S X=""

 ;-----

RTIN ;EP;CHECK REAL-TIME INBOUND FILES

 N DIR,FILE

 D PATH^BYIMIMM6

 S DIR=$$LIST^%ZISH(IPATH,"izrt*",.DIR)

 N IN

 S IN=0

 F  S IN=$O(DIR(IN)) Q:'IN  S FILE=DIR(IN) D:FILE]""

 .Q:$D(^BYIMRT("ACT",FILE,"I"))

 .D RTIMP(FILE)

 .I $G(BYIMRTIN) W !,FILE," processed..."

 ;-----

RTDEST ;EP;CHECK DESTINATION GLOBAL FOR RT MESSAGES

 S BYIMDEST=$S(BYIMVER["2.3":"HL IHS IZV04 V01VXQ OUT PARENT",1:"HL IHS IZV04 QBP OUT PARENT")

 S BYIMDDA=$O(^INRHD("B",BYIMDEST,0))

 Q:'BYIMDDA

 N PRI

 S PRI=0

 F  S PRI=$O(^INLHDEST(BYIMDDA,PRI)) Q:'PRI  D

 .N BYIMDT

 .S BYIMDT=""

 .F  S BYIMDT=$O(^INLHDEST(BYIMDDA,PRI,BYIMDT)) Q:BYIMDT=""  D

 ..N BYIMUIF

 ..S BYIMUIF=0

 ..F  S BYIMUIF=$O(^INLHDEST(BYIMDDA,PRI,BYIMDT,BYIMUIF)) Q:'BYIMUIF  D

 ...Q:'$D(^INTHU(BYIMUIF,3))

 ...D UIF(BYIMUIF)

 ;-----

UIF(BYIMUIF) ;PROCESS UIF

 Q:'$G(BYIMUIF)

 Q:'$D(^INTHU(BYIMUIF,3))

 N XX

 S XX=$G(^INTHU(BYIMUIF,3,2))

 Q:XX=""

 N DFN,HRN,LOC,HRN,LOCDA,X,Y,Z

 S HRN=""

 S:XX["PID|" HRN=$P(XX,"|",4)

 S:XX["QRD|" HRN=$P($P(XX,"|",9),U)

 S:XX["QPD|" HRN=$P(XX,"|",3)

 S LOC=$E(HRN,1,6)

 S HRN=+$E(HRN,7,12)

 S LOCDA=$O(^AUTTLOC("C",LOC,0))

 Q:'LOCDA!'HRN

 S DFN=""

 S X=0

 F  S X=$O(^AUPNPAT("D",HRN,X)) Q:'X!DFN  I $D(^AUPNPAT("D",HRN,X,LOCDA)) S DFN=X

 Q:'DFN

 S BYIMSTP="IN"

 D SFILE(BYIMUIF,DFN,BYIMSTP)

 ;-----

RTLOG(FILE,ACT,PATH,DFN,UIF,MID,STAT) ;EP;

 ;LOG EXPORT/IMPORT FILES THAT HAVE BEEN PROCESSED

 ;FILE     = NAME OF FILE IMPORTED OR EXPORTED

 ;ACT      = ACTION - 'I'MPORT OR 'E'XPORT

 ;PATH     = DRIVE/DIRECTORY FILE SENT TO

 ;DFN      = DFN OF PATIENT FOR QUERY/RESPONSE

 ;UIF      = IEN OF THE UNIVERSAL MESSAGE ENTRY

 ;MID      = MESSAGE ID ASSIGNED FOR THE UNIVERSAL MESSAGE ENTRY

 ;STAT     = TRANSMITTION STATUS

 Q:$G(FILE)=""!($G(ACT)="")

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S X=FILE

 S DIC="^BYIMRT("

 S DIC(0)="L"

 S DIC("DR")=".02////"_ACT_";.03////"_PATH_";.04////"_DFN_";.05////"_($P(FILE,"_",3)-17000000)_"."_$P($P(FILE,"_",4),".")_";.06////"_MID_";.07////"_UIF_";.08////"_$G(STAT)

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 Q:Y<1

 S RTLDA=+Y

 S ^BYIMRT(RTLDA,1,0)="^90480.21"

N X

 S X=0

 F  S X=$O(^INTHU(UIF,3,X)) Q:'X  S ^BYIMRT(RTLDA,1,X,0)=^(X,0),Z=X

 S $P(^BYIMRT(RTLDA,1,0),U,3)=Z

 S $P(^BYIMRT(RTLDA,1,0),U,4)=Z

 ;-----

DISP(RTLDA) ;DISPLAY RESPONSE FILE

 D HDR

 N XX,BYIMQUIT

 S MID=$P(^BYIMRT(RTLDA,0),U,6)

 S FILE=$P(^BYIMRT(RTLDA,0),U)

 S XX=0

 S MIDDA=$O(^BYIMRT("ACT",FILE,"I",0))

 I 'MIDDA D  Q

 .W !!,"No response on file yet for this query."

 .D PAUSE^BYIMIMM6

 D MID

 K BYIMQUIT

 ;-----

HDR ;QUERY RESPONSE DISPLAY HEADER

 W @IOF

HDR1 W !!,"Query for Patient",?26,"Query Date",?38,"Query file"

 W !,"------------------------",?26,"----------",?38,"-------------------------------"

 N X0

 S X0=$G(^BYIMRT(RTLDA,0))

 W !,$P($G(^DPT(+$P(X0,U,4),0)),U)

 S X1=$P(X0,U,5)

 W ?26,$E(X1,4,5),"/",$E(X1,6,7),"/",$E(X1,1,3)+1700

 W ?38,$P(X0,U)

 ;-----

HDR2 ;DISPLAY RELATED MESSAGE

 W !!!,"HL7 Response Message"

 W:$P(^BYIMRT(MIDDA,0),U,6)]"" " ID: ",$P(^(0),U,6)

 W !,"*******************************************************"

W !

 ;-----

NEWUIF ;CREATE INTHU ENTRY

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 D NOW^%DTC

 S X=%

 S DIC="^INTHU("

 S DIC(0)="L"

 D FILE^DICN

 K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 S UIF=+Y

 ;-----

MID ;DISPLAY MESSAGE RESPONSES

 S MIDDA=0

 F  S MIDDA=$O(^BYIMRT("ACT",FILE,"I",MIDDA)) Q:'MIDDA!$G(BYIMQUIT)  D MID1

 K BYIMQUIT

 ;-----

MID1 ;

 D HDR2

 N XX,BYIMQUIT

 S XX=0

 F  S XX=$O(^BYIMRT(MIDDA,1,XX)) Q:'XX!$D(BYIMQUIT)  S X=^(XX,0) D

 .I X["MSH|",X["|VXU" D DVXU(X) S BYIMQUIT=1 Q

 .W !,X

 .I IOST["C-",IOSL<($Y+4) D PAUSE^BYIMIMM6 S:X[U BYIMQUIT=1 W @IOF

 D PAUSE^BYIMIMM6

 ;-----

VXQV01(UIF) ;EP;TO DISPLAY VXQ^V01 QUERY

 ;UIF     - IEN OF THE UNIVERSAL INTERFACE ENTRY

 Q:'$G(UIF)

 S MSH=$G(^INTHU(UIF,3,1,0))

 S QRD=$G(^INTHU(UIF,3,2,0))

 S QRF=$G(^INTHU(UIF,3,1,0))

 Q:MSH=""

 W !!,"Message ID: ",$P(MSH,"|",10)

 W !,"Patient HRN: ",+$E($P(QRD,"|",9),7,12),"  Facility: ",$P($G(^DIC(4,+$E($P(QRD,"|",9),1,6),0)),U)

 ;-----

RXR(BYIMUIF) ;EP;CLEAN OUT BLANK RXR AND '0' OBX segments

 N X,Y

 S X=0

 F  S X=$O(^INTHU(BYIMUIF,3,X)) Q:'X  S Y=^(X,0) D

 .K:$E(Y,1,5)="RXR||" ^INTHU(BYIMUIF,3,X,0)

 .K:Y["OBX|"&(Y["V00") ^INTHU(BYIMUIF,3,X,0)

 ;-----

DVXU(X) ;DISPLAY RT VXU MESSAGE

 N DISP,HDR

 S XX=XX

 F  S XX=$O(^BYIMRT(MIDDA,1,XX)) Q:'XX!$G(BYIMQUIT)  S X=^(XX,0) D

 .D:X["PID|" PID(X)

 .D:X["RXA|" RXA(X)

 Q:'$D(DISP)

 F J=1:1:6 W !,HDR(J)

 N XX,YY

 S XX=""

 F  S XX=$O(DISP(XX)) Q:XX=""!$G(BYIMQUIT)  D

 .S YY=""

 .F  S YY=$O(DISP(XX,YY)) Q:YY=""!$G(BYIMQUIT)  S Z=DISP(XX,YY) D

 ..W !,XX,?12,YY

 ..W ?39,$J($P(Z,U),4)

 ..W ?45,$P(Z,U,2)

 ..W ?54,$P(Z,U,3)

 ..W ?69,$P(Z,U,4)

 .I IOST["C-",IOSL<($Y+4) D

 ..D PAUSE^BYIMIMM6

 ..S:X[U BYIMQUIT=1

 ..Q:$G(BYIMQUIT)

 ..W @IOF

 ..F J=1:1:6 W !,HDR(J)

MSH ;DISPLAY RT MSH SEGMENT

 W !,$TR($P(X,"|",3),"^"," "),"  ",$TR($P(X,"|",4),"^"," "),"  "

 S Y=$P(X,"|",7)

 W $E(Y,1,4),"-",$E(Y,5,6),"-",$E(Y,7,8),"  ",$P(X,"|",9),"  ",$P(X,"|",11)

 ;-----

PID(X) ;DISPLAY RT PID SEGMENT

 N Y,Z

 S Y="NAME"

 S $E(Y,33)="DOB"

 S $E(Y,45)="SEX"

 S HDR(1)=Y

 S HDR(2)="------------------------------  ----------  ---"

 S Y=$P(X,"|",6)

 S Y=$P(Y,U)_","_$P(Y,U,2)_" "_$P(Y,U,3)

 S Z=$P(X,"|",8)

 S $E(Y,33)=$E(Z,1,4)_"-"_$E(Z,5,6)_"-"_$E(Z,7,8)

 S $E(Y,45)=$P(X,"|",9)

 S HDR(3)=Y

 S HDR(4)=""

 S Y="ADMIN DATE"

 S $E(Y,13)="CVX  VACCINE NAME"

 S $E(Y,40)="QUAN"

 S $E(Y,46)="TYPE"

 S $E(Y,55)="LOT NO."

 S $E(Y,70)="EXP. DATE"

 S HDR(5)=Y

 S Y="----------"

 S $E(Y,13)="---  --------------------"

 S $E(Y,40)="----"

 S $E(Y,46)="-------"

 S $E(Y,55)="-------------"

 S $E(Y,70)="---------"

 S HDR(6)=Y

 ;-----

RXA(X) ;DISPLAY RT RXA SEGMENT

 N Y,Z,AD,IMM,QUAN,TYPE,LOT,EXP

 S Y=$P(X,"|",4)

 S AD=$E(Y,1,4)_"-"_$E(Y,5,6)_"-"_$E(Y,7,8)

 S Y=$P(X,"|",6)

 S CVX=$P(Y,U)

 S IMM=$J(CVX,3)_"  "_$E($P(Y,U,2),1,20)

 S QUAN=$TR($P(X,"|",7),"^")

 S TYPE=$TR($E($P($P(X,"|",10),U,2),1,7),"^")

 S LOT=$TR($P(X,"|",16),"^")

 S Y=$TR($P(X,"|",17),"^")

 S EXP=$E(Y,1,4)_"-"_$E(Y,5,6)_"-"_$E(Y,7,8)

 S DISP(AD,IMM)=QUAN_U_TYPE_U_LOT_U_EXP

 ;-----

ALL ;EP;TO SPECIFY NEW ONLY OR ALL IMMUNIZATIONS

 K BYIMALL

 W !!,"Which immunizations should be include:"

 K DIR

 S DIR(0)="SO^1:NEW/EDITED Immunizations (not previously exported);2:ALL Immunizations for exported patient(s)"

 S DIR("A")="Send NEW or ALL Immunizations"

 S DIR("B")="NEW/EDITED Immunizations"

 D ^DIR

 K DIR

 I 'Y S BYIMQUIT=1 Q

 S BYIMALL=+Y

 ;-----

CLEANVXU(BYIMUIF) ;REMOVE INLHDEST REMNANT FOR RT MESSAGES

 Q:'$G(BYIMUIF)

 N X,Y,Z

 S X=0

 F  S X=$O(^INLHDEST(X)) Q:'X  D

 .S Y=""

 .F  S Y=$O(^INLHDEST(X,Y)) Q:Y=""  D

 ..S Z=""

 ..F  S Z=$O(^INLHDEST(X,Y,Z)) Q:Z=""  K ^INLHDEST(X,Y,Z,BYIMUIF)

BYIMRT    ;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       ;;CONTINUATION OF BYIMIMM

 +3       ;

 +4       ;REAL-TIME PROCESSING

 +5       ;

 +6       ;-----

RT        ;EP;FOR REAL TIME QUERIES

 +1        FOR

               DO RT1

               IF $DATA(BYIMQUIT)

                   QUIT

 +2        KILL BYIMQUIT

 +3        QUIT

 +4       ;-----

RT1       ;REAL TIME

 +1        DO PATH^BYIMIMM6

 +2        KILL BYIMQTX,BYIMQUIT

 +3        SET BYIMQTX=$SELECT(BYIMQT=1:"VXQ",1:"QBP")

 +4        NEW RT

 +5        WRITE @IOF

 +6        WRITE !!?10,"Real-Time Query Options - Version: ",BYIMVER

 +7        KILL DIR

 +8        SET DIR(0)="SO^1:Get  a Patient's Immunizations FROM State IIS;2:Send a Patient's Immunizations TO   State IIS;3:Review State IIS Responses;4:Check for Additional Response Messages"

 +9        SET DIR("A")="Select the action type"

 +10       DO ^DIR

 +11       KILL DIR

 +12       IF 'Y

               SET BYIMQUIT=1

               QUIT

 +13       SET RT=$SELECT(Y=1:"VXQ",Y=2:"VXU",Y=3:"RESP",Y=4:"RTIN",1:"")

 +14       IF RT="RESP"

               DO RESP

               KILL BYIMQUIT

               QUIT

 +15       IF RT="RTIN"

               Begin DoDot:1

 +16               WRITE !!,"Checking for query responses that have not yet been processed."

 +17               WRITE !!,"Please stand by..."

 +18               HANG 4

 +19               NEW BYIMRTIN

 +20               SET BYIMRTIN=1

 +21               DO RTIN

 +22               WRITE !!,"Please check 'Review State IIS Responses' for new IIS responses."

 +23               DO PAUSE^BYIMIMM6

 +24               KILL BYIMQUIT

               End DoDot:1

               QUIT

 +25       DO PAT

 +26       IF '$DATA(^TMP($JOB,"BYIM RT"))

               QUIT

 +27       DO SEND

 +28       KILL ^TMP($JOB,"BYIM RT")

 +29       QUIT

 +30      ;-----

PAT       ;

 +1        KILL ^TMP($JOB,"BYIM RT")

 +2        IF RT="VXU"

               DO ALL

 +3        WRITE !!,"Select patient(s) to send to the State Immunization Registry"

 +4        FOR

               DO P1

               IF $DATA(BYIMQUIT)

                   QUIT

 +5        KILL BYIMQUIT

 +6        QUIT

 +7       ;-----

P1        ;SELECT MULTIPE PATIENTS

 +1        KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +2        SET DIC=9000001

 +3        SET DIC("A")="Select "_$SELECT($DATA(^TMP($JOB,"BYIM RT")):"another ",1:"")_"patient: "

 +4        SET DIC(0)="AEQM"

 +5        WRITE !

 +6        DO ^DIC

 +7        KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +8        IF Y<1

               SET BYIMQUIT=""

               QUIT

 +9        SET ^TMP($JOB,"BYIM RT",+Y)=""

 +10       DO RTPAT

 +11       QUIT

 +12      ;-----

SEND      ;SEND RT QUERY

 +1        WRITE !!,$SELECT(RT="VXQ":"A 'Query for Vaccination Record ("_BYIMQTX_")'",1:"An 'Unsolicited Vaccine Record Update (VXU)'")," will be sent for:"

 +2        DO RTPAT

 +3        KILL DIR

 +4        SET DIR(0)="YO"

 +5        SET DIR("A")="Do you want to proceed"

 +6        SET DIR("B")="YES"

 +7        WRITE !

 +8        DO ^DIR

 +9        KILL DIR

 +10       IF Y'=1

               QUIT

 +11       IF '$DATA(ZTQUEUED)&$DATA(^TMP($JOB,"BYIM RT"))

               Begin DoDot:1

 +12               WRITE !!,"Please stand by.  This may take a couple of seconds...",!

               End DoDot:1

 +13       SET DFN=0

 +14       FOR

               SET DFN=$ORDER(^TMP($JOB,"BYIM RT",DFN))

               IF 'DFN

                   QUIT

               Begin DoDot:1

 +15               IF RT="VXQ"

                       DO VXQ(DFN)

 +16               IF RT="VXU"

                       DO VXU(DFN)

 +17               KILL ^TMP($JOB,"BYIM RT",DFN)

               End DoDot:1

 +18       KILL ^TMP($JOB,"BYIM RT")

 +19       DO PAUSE^BYIMIMM6

 +20       QUIT

 +21      ;-----

RTPAT     ;DISPLAY PATIENTS FOR RT QUERY

 +1        NEW DFN

 +2        WRITE !

 +3        SET DFN=0

 +4        FOR

               SET DFN=$ORDER(^TMP($JOB,"BYIM RT",DFN))

               IF 'DFN

                   QUIT

               Begin DoDot:1

 +5                WRITE !," *** ",$PIECE(^DPT(DFN,0),U)," *** "

               End DoDot:1

 +6        QUIT

 +7       ;-----

VXQ(DFN)  ;EP;TO SEND VXQ MESSAGE

 +1        IF '$DATA(ZTQUEUED)

               WRITE !,"Query being sent for: ",$JUSTIFY(DFN,6),"  ",$PIECE(^DPT(DFN,0),U)

 +2        DO DELAY

 +3        SET Y=$$VXQX(DFN)

 +4        QUIT

DELAY      IF $DATA(ZTQUEUED)

               QUIT

 +1        WRITE "  "

 +2        FOR J=1:1:3

               WRITE "."

               HANG 1

 +3        QUIT

 +4       ;-----

VXU(DFN)  ;EP;TO SEND VXU MESSAGE

 +1        NEW VST

 +2        SET VST=$ORDER(^AUPNVSIT("AC",DFN,9999999999),-1)

 +3        IF 'VST

               QUIT

 +4        SET Y=$$V04^BYIMIMM(VST,BYIMALL)

 +5        IF '$DATA(ZTQUEUED)

               WRITE !,"Immunization record being sent for: ",$JUSTIFY(DFN,6),"  ",$PIECE(^DPT(DFN,0),U)

 +6        DO DELAY

 +7        SET INHF=+Y

 +8        IF 'INHF

               QUIT

 +9        SET BYIMUIF=$ORDER(^INTHU("AT",INHF,0))

 +10       IF 'BYIMUIF

               QUIT

 +11       DO LOGD^BYIMIMM4(DFN,"E")

 +12       DO RXR(BYIMUIF)

 +13       SET BYIMSTP="VXU"

 +14       DO SFILE(BYIMUIF,DFN,BYIMSTP)

 +15       DO CLEANVXU(BYIMUIF)

 +16       QUIT

 +17      ;-----

RSP       ;EP;IMMUNIZATION DATA EXCHANGE

 +1        SET BHLDEST="D DEST^INHUSEN"

 +2        SET INDEST("RSPK11")="HL IHS IZV04 RSP IN"

 +3        XECUTE BHLDEST

 +4        QUIT

 +5       ;-----

RESP      ;EP;REVIEW RT RESPONSE FILES

 +1        KILL BYIMQUIT

 +2        FOR

               DO RESP1

               IF $DATA(BYIMQUIT)

                   QUIT

 +3        QUIT

 +4       ;-----

RESP1     ;REVIEW RESPONSES

 +1        KILL BYIMQUIT

 +2        KILL ^TMP($JOB,"BYIM RT")

 +3        NEW DFN,RT

 +4        WRITE @IOF

 +5        WRITE !!?10,"Review Responses from the State IIS"

 +6        KILL DIR

 +7        SET DIR(0)="SO^1:Review Immunizations ready to add to RPMS;2:Review Query Response Messages"

 +8        SET DIR("A")="Select the action type"

 +9        WRITE !

 +10       DO ^DIR

 +11       KILL DIR,BYIMQUIT

 +12       IF 'Y

               SET BYIMQUIT=1

               QUIT

 +13       SET RT=$SELECT(Y=1:"START",1:"NON")

 +14       IF RT="START"

               DO START

               QUIT

 +15       FOR

               DO NON

               IF $DATA(BYIMQUIT)

                   QUIT

 +16       KILL BYIMQUIT

 +17       QUIT

 +18      ;-----

START     ;

 +1        WRITE @IOF

 +2        WRITE !!?10,"All NEW immunizations for Query Responses from the state"

 +3        WRITE !!?10,"that can be added to RPMS will be listed below."

 +4        WRITE !!

 +5        SET DIR("A")="Press <ENTER> to review immunizations, press '^' to exit"

 +6        DO PAUSE^BYIMIMM6

 +7        IF 'Y

               QUIT

 +8        DO START^BYIMIMM1

 +9        QUIT

 +10      ;-----

NON       ;EP;TO REVIEW NON-IMMUNIZATION IIS RESPONSES

 +1        WRITE @IOF

 +2        WRITE !!?10,"Select Responses by Patient or Date"

 +3        KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +4        SET DIC="^BYIMRT("

 +5        SET DIC(0)="AEMQ"

 +6        SET DIC("A")="Select Query Date or Patient: "

 +7        SET DIC("S")="I $P(^(0),U,2)=""E"""

 +8        WRITE !

 +9        DO ^DIC

 +10       KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +11       IF Y<0

               SET BYIMQUIT=1

               QUIT

 +12       DO DISP(+Y)

 +13       QUIT

 +14      ;-----

RTIMP(FILE) ;EP;TO AUTOMATICALLY IMPORT REAL-TIME MESSAGES

 +1        KILL BYIMQUIT

 +2        NEW AUTOIMP,AUTOADD,DIR

 +3        SET AUTOIMP=$PIECE($GET(^BYIMPARA(DUZ(2),0)),U,4)

 +4        SET AUTOADD=$PIECE($GET(^BYIMPARA(DUZ(2),0)),U,5)

 +5        DO PATH^BYIMIMM6

 +6        IF IPATH=""

               QUIT

 +7        SET Y=$$OPEN^%ZISH(IPATH,FILE,"R")

 +8        IF Y

               QUIT

 +9        NEW BYIMJ,BYIMX,UIF

 +10       SET UIF=""

 +11       SET BYIMJ=0

 +12      ;F  U IO R BYIMX:DTIME D:BYIMX="" CLOSE^%ZISH() Q:BYIMX=""  D

 +13      ;.I BYIMX["MSH|" D  Q:'UIF

 +14      ;..D NEWUIF

 +15      ;.I BYIMX["MSH|" D NEWUIF Q:'UIF

 +16      ;.S BYIMJ=BYIMJ+1

 +17      ;.S ^INTHU(UIF,3,BYIMJ,0)=BYIMX_"|CR|"

 +18       DO LOG(UIF,"I",FILE)

 +19       NEW BYIMXX

 +20       SET BYIMXX=0

 +21       FOR

               SET BYIMXX=$ORDER(^BYIMTMP($JOB,"BYIM IMM",BYIMXX))

               IF 'BYIMXX

                   QUIT

               Begin DoDot:1

 +22               DO SET1^BYIMIMM1(BYIMXX)

               End DoDot:1

 +23       QUIT

 +24      ;-----

LOG(UIF,ACT,FILE) ;LOG RT FILE

 +1        IF '$GET(UIF)

               QUIT

 +2        SET ^BYIMTMP($JOB,"BYIM IMM",UIF)=""

 +3        NEW XX,DFN

 +4        SET DFN=$PIECE(FILE,"_",2)

 +5        SET MID=""

 +6        SET XX=0

 +7        IF MID'["IHS-"

               SET MID=""

 +8        DO RTLOG(FILE,ACT,IPATH,DFN,UIF,MID,0)

 +9        QUIT

 +10      ;-----

VXQX(BYIMPAT) ;PEP;send query request for patient IEN - BYIMPAT

 +1       ;BYIMPAT - PATIENT DFN/IEN

 +2       ;RETURNS GIS HL7 MESSAGE CREATION MESSAGE

 +3       ;

 +4        IF '$GET(BYIMPAT)!'$DATA(^DPT(+$GET(BYIMPAT),0))

               QUIT "No Patient identified for DFN "_$GET(BYIMPAT)

 +5        DO PATH^BYIMIMM6

 +6        SET BYIMQTX=$SELECT(BYIMQT=1:"VXQ",1:"QBP")

 +7        NEW BYIMDEST,INH,INDA,INA

 +8        SET INDA=BYIMPAT

 +9        SET INDA(2,1)=BYIMPAT

 +10       SET INDA(9000001,1)=BYIMPAT

 +11       SET INA("QNM",INDA)=""

 +12       SET BYIMDEST=$SELECT(BYIMQT=1:"HL IHS IZV04 V01VXQ OUT PARENT",1:"HL IHS IZV04 QBP OUT PARENT")

 +13       DO ^INHF(BYIMDEST,.INDA,.INA)

 +14       HANG 2

 +15       IF $GET(INHF)

               Begin DoDot:1

 +16               SET BYIMUIF=$ORDER(^INTHU("AT",INHF,0))

 +17               IF 'BYIMUIF

                       QUIT

 +18               SET BYIMSTP=BYIMQTX

 +19               DO SFILE(BYIMUIF,BYIMPAT,BYIMSTP)

               End DoDot:1

 +20       DO EOJ^BYIMIMM

 +21       QUIT $$MSG^BYIMIMM(INHF)

 +22      ;-----

SFILE(BYIMUIF,BYIMPAT,BYIMSTP) ;EP;TO SEND RT FILE VIA HL7 BRIDGE

 +1       ;BYIMUIF - THE IEN OF THE ^INTHU( ENTRY FOR THE MESSAGE

 +2       ;BYIMPAT - THE IEN OF PATIENT

 +3       ;BYIMSTP - MESSAGE TYPE

 +4        IF '$GET(BYIMUIF)!'$GET(BYIMPAT)

               QUIT

 +5        SET BYIMSTP=$TRANSLATE(BYIMSTP,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")

 +6        SET MID=""

 +7        DO PATH^BYIMIMM6

 +8        DO NOW^%DTC

 +9        SET QFILE="izrt"_BYIMSTP_$TRANSLATE(BYIMVER,".")_"_"_$EXTRACT("000000",1,6-$LENGTH(BYIMPAT))_BYIMPAT_"_"_($PIECE(%,".")+17000000)_"_"_$PIECE(%,".",2)_$EXTRACT("000000",1,6-$LENGTH($PIECE(%,".",2)))_".dat"

 +10       SET ACT="W"

 +11       DO FILE(OPATH,QFILE,ACT,BYIMUIF,BYIMPAT,BYIMSTP)

 +12       QUIT

FILE(PATH,FILE,ACT,BYIMUIF,BYIMPAT,BYIMSTP) ;SEND FILE

 +1       ;OPATH   - PATH FOR TRANSMISSION

 +2       ;FILE    - FILE NAME

 +3       ;ACT     - ACTION

 +4       ;BYIMUIF - IEN IN ^INTHU

 +5       ;BYIMPAT - PATIENT DFN

 +6       ;BYIMSTP -

 +7        SET Y=$$OPEN^%ZISH(PATH,FILE,ACT)

 +8        IF Y

               Begin DoDot:1

 +9                DO EXPBULL^BYIMIMM4(FILE,0,PATH)

 +10               DO RTLOG(FILE,"E",PATH,BYIMPAT,BYIMUIF,MID,1)

               End DoDot:1

               QUIT

 +11       NEW X,XX

 +12       DO REFUSAL^BYIMSEG1(BYIMPAT,BYIMUIF)

 +13       SET X=""

 +14       SET XX=0

 +15       FOR

               SET XX=$ORDER(^INTHU(BYIMUIF,3,XX))

               IF 'XX

                   QUIT

               SET READ=^(XX,0)

               DO F1

 +16       DO CLOSE^%ZISH()

 +17       DO RTLOG(QFILE,"E",OPATH,BYIMPAT,BYIMUIF,MID,0)

 +18       IF BYIMBDG<1

               QUIT

 +19       NEW BYIMRTIN

 +20       SET BYIMRTIN=0

 +21       DO RTIN

 +22       QUIT

 +23      ;-----

F1        ;WRTIE OUT EACH LINE

 +1        SET X=X_$PIECE(READ,"|CR|")

 +2        IF READ'["|CR|"

               QUIT

 +3        IF X["MSH|"

               SET MID=$PIECE(X,"|",10)

 +4        IF 'BYIMIN1&($EXTRACT(X,1,4)["IN1|"!($EXTRACT(X,1,4)["IN2|"))

               SET X=""

 +5        IF $EXTRACT(X,1,5)="RXR||"

               SET X=""

 +6        IF X["RXR|ZZZ"

               SET X=""

 +7        IF X["OBX|"&(X["V00")

               SET X=""

 +8        IF "|MSH|FHS|BHS|BTS|FTS|"'[("|"_$EXTRACT(X,1,3)_"|")

               SET X=$TRANSLATE(X,"\&")

 +9        IF X]""

               USE IO

               WRITE X,!

 +10       SET X=""

 +11       QUIT

 +12      ;-----

RTIN      ;EP;CHECK REAL-TIME INBOUND FILES

 +1        NEW DIR,FILE

 +2        DO PATH^BYIMIMM6

 +3        SET DIR=$$LIST^%ZISH(IPATH,"izrt*",.DIR)

 +4        NEW IN

 +5        SET IN=0

 +6        FOR

               SET IN=$ORDER(DIR(IN))

               IF 'IN

                   QUIT

               SET FILE=DIR(IN)

               IF FILE]""

                   Begin DoDot:1

 +7                    IF $DATA(^BYIMRT("ACT",FILE,"I"))

                           QUIT

 +8                    DO RTIMP(FILE)

 +9                    IF $GET(BYIMRTIN)

                           WRITE !,FILE," processed..."

                   End DoDot:1

 +10       QUIT

 +11      ;-----

RTDEST    ;EP;CHECK DESTINATION GLOBAL FOR RT MESSAGES

 +1        SET BYIMDEST=$SELECT(BYIMVER["2.3":"HL IHS IZV04 V01VXQ OUT PARENT",1:"HL IHS IZV04 QBP OUT PARENT")

 +2        SET BYIMDDA=$ORDER(^INRHD("B",BYIMDEST,0))

 +3        IF 'BYIMDDA

               QUIT

 +4        NEW PRI

 +5        SET PRI=0

 +6        FOR

               SET PRI=$ORDER(^INLHDEST(BYIMDDA,PRI))

               IF 'PRI

                   QUIT

               Begin DoDot:1

 +7                NEW BYIMDT

 +8                SET BYIMDT=""

 +9                FOR

                       SET BYIMDT=$ORDER(^INLHDEST(BYIMDDA,PRI,BYIMDT))

                       IF BYIMDT=""

                           QUIT

                       Begin DoDot:2

 +10                       NEW BYIMUIF

 +11                       SET BYIMUIF=0

 +12                       FOR

                               SET BYIMUIF=$ORDER(^INLHDEST(BYIMDDA,PRI,BYIMDT,BYIMUIF))

                               IF 'BYIMUIF

                                   QUIT

                               Begin DoDot:3

 +13                               IF '$DATA(^INTHU(BYIMUIF,3))

                                       QUIT

 +14                               DO UIF(BYIMUIF)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +15       QUIT

 +16      ;-----

UIF(BYIMUIF) ;PROCESS UIF

 +1        IF '$GET(BYIMUIF)

               QUIT

 +2        IF '$DATA(^INTHU(BYIMUIF,3))

               QUIT

 +3        NEW XX

 +4        SET XX=$GET(^INTHU(BYIMUIF,3,2))

 +5        IF XX=""

               QUIT

 +6        NEW DFN,HRN,LOC,HRN,LOCDA,X,Y,Z

 +7        SET HRN=""

 +8        IF XX["PID|"

               SET HRN=$PIECE(XX,"|",4)

 +9        IF XX["QRD|"

               SET HRN=$PIECE($PIECE(XX,"|",9),U)

 +10       IF XX["QPD|"

               SET HRN=$PIECE(XX,"|",3)

 +11       SET LOC=$EXTRACT(HRN,1,6)

 +12       SET HRN=+$EXTRACT(HRN,7,12)

 +13       SET LOCDA=$ORDER(^AUTTLOC("C",LOC,0))

 +14       IF 'LOCDA!'HRN

               QUIT

 +15       SET DFN=""

 +16       SET X=0

 +17       FOR

               SET X=$ORDER(^AUPNPAT("D",HRN,X))

               IF 'X!DFN

                   QUIT

               IF $DATA(^AUPNPAT("D",HRN,X,LOCDA))

                   SET DFN=X

 +18       IF 'DFN

               QUIT

 +19       SET BYIMSTP="IN"

 +20       DO SFILE(BYIMUIF,DFN,BYIMSTP)

 +21       QUIT

 +22      ;-----

RTLOG(FILE,ACT,PATH,DFN,UIF,MID,STAT) ;EP;

 +1       ;LOG EXPORT/IMPORT FILES THAT HAVE BEEN PROCESSED

 +2       ;FILE     = NAME OF FILE IMPORTED OR EXPORTED

 +3       ;ACT      = ACTION - 'I'MPORT OR 'E'XPORT

 +4       ;PATH     = DRIVE/DIRECTORY FILE SENT TO

 +5       ;DFN      = DFN OF PATIENT FOR QUERY/RESPONSE

 +6       ;UIF      = IEN OF THE UNIVERSAL MESSAGE ENTRY

 +7       ;MID      = MESSAGE ID ASSIGNED FOR THE UNIVERSAL MESSAGE ENTRY

 +8       ;STAT     = TRANSMITTION STATUS

 +9        IF $GET(FILE)=""!($GET(ACT)="")

               QUIT

 +10       KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +11       SET X=FILE

 +12       SET DIC="^BYIMRT("

 +13       SET DIC(0)="L"

 +14       SET DIC("DR")=".02////"_ACT_";.03////"_PATH_";.04////"_DFN_";.05////"_($PIECE(FILE,"_",3)-17000000)_"."_$PIECE($PIECE(FILE,"_",4),".")_";.06////"_MID_";.07////"_UIF_";.08////"_$GET(STAT)

 +15       DO FILE^DICN

 +16       KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +17       IF Y<1

               QUIT

 +18       SET RTLDA=+Y

 +19       SET ^BYIMRT(RTLDA,1,0)="^90480.21"

 +20       NEW X

 +21       SET X=0

 +22       FOR

               SET X=$ORDER(^INTHU(UIF,3,X))

               IF 'X

                   QUIT

               SET ^BYIMRT(RTLDA,1,X,0)=^(X,0)

               SET Z=X

 +23       SET $PIECE(^BYIMRT(RTLDA,1,0),U,3)=Z

 +24       SET $PIECE(^BYIMRT(RTLDA,1,0),U,4)=Z

 +25       QUIT

 +26      ;-----

DISP(RTLDA) ;DISPLAY RESPONSE FILE

 +1        DO HDR

 +2        NEW XX,BYIMQUIT

 +3        SET MID=$PIECE(^BYIMRT(RTLDA,0),U,6)

 +4        SET FILE=$PIECE(^BYIMRT(RTLDA,0),U)

 +5        SET XX=0

 +6        SET MIDDA=$ORDER(^BYIMRT("ACT",FILE,"I",0))

 +7        IF 'MIDDA

               Begin DoDot:1

 +8                WRITE !!,"No response on file yet for this query."

 +9                DO PAUSE^BYIMIMM6

               End DoDot:1

               QUIT

 +10       DO MID

 +11       KILL BYIMQUIT

 +12       QUIT

 +13      ;-----

HDR       ;QUERY RESPONSE DISPLAY HEADER

 +1        WRITE @IOF

HDR1       WRITE !!,"Query for Patient",?26,"Query Date",?38,"Query file"

 +1        WRITE !,"------------------------",?26,"----------",?38,"-------------------------------"

 +2        NEW X0

 +3        SET X0=$GET(^BYIMRT(RTLDA,0))

 +4        WRITE !,$PIECE($GET(^DPT(+$PIECE(X0,U,4),0)),U)

 +5        SET X1=$PIECE(X0,U,5)

 +6        WRITE ?26,$EXTRACT(X1,4,5),"/",$EXTRACT(X1,6,7),"/",$EXTRACT(X1,1,3)+1700

 +7        WRITE ?38,$PIECE(X0,U)

 +8        QUIT

 +9       ;-----

HDR2      ;DISPLAY RELATED MESSAGE

 +1        WRITE !!!,"HL7 Response Message"

 +2        IF $PIECE(^BYIMRT(MIDDA,0),U,6)]""

               WRITE " ID: ",$PIECE(^(0),U,6)

 +3        WRITE !,"*******************************************************"

 +4        WRITE !

 +5        QUIT

 +6       ;-----

NEWUIF    ;CREATE INTHU ENTRY

 +1        KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +2        DO NOW^%DTC

 +3        SET X=%

 +4        SET DIC="^INTHU("

 +5        SET DIC(0)="L"

 +6        DO FILE^DICN

 +7        KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO

 +8        SET UIF=+Y

 +9        QUIT

 +10      ;-----

MID       ;DISPLAY MESSAGE RESPONSES

 +1        SET MIDDA=0

 +2        FOR

               SET MIDDA=$ORDER(^BYIMRT("ACT",FILE,"I",MIDDA))

               IF 'MIDDA!$GET(BYIMQUIT)

                   QUIT

               DO MID1

 +3        KILL BYIMQUIT

 +4        QUIT

 +5       ;-----

MID1      ;

 +1        DO HDR2

 +2        NEW XX,BYIMQUIT

 +3        SET XX=0

 +4        FOR

               SET XX=$ORDER(^BYIMRT(MIDDA,1,XX))

               IF 'XX!$DATA(BYIMQUIT)

                   QUIT

               SET X=^(XX,0)

               Begin DoDot:1

 +5                IF X["MSH|"

                       IF X["|VXU"

                           DO DVXU(X)

                           SET BYIMQUIT=1

                           QUIT

 +6                WRITE !,X

 +7                IF IOST["C-"

                       IF IOSL<($Y+4)

                           DO PAUSE^BYIMIMM6

                           IF X[U

                               SET BYIMQUIT=1

                           WRITE @IOF

               End DoDot:1

 +8        DO PAUSE^BYIMIMM6

 +9        QUIT

 +10      ;-----

VXQV01(UIF) ;EP;TO DISPLAY VXQ^V01 QUERY

 +1       ;UIF     - IEN OF THE UNIVERSAL INTERFACE ENTRY

 +2        IF '$GET(UIF)

               QUIT

 +3        SET MSH=$GET(^INTHU(UIF,3,1,0))

 +4        SET QRD=$GET(^INTHU(UIF,3,2,0))

 +5        SET QRF=$GET(^INTHU(UIF,3,1,0))

 +6        IF MSH=""

               QUIT

 +7        WRITE !!,"Message ID: ",$PIECE(MSH,"|",10)

 +8        WRITE !,"Patient HRN: ",+$EXTRACT($PIECE(QRD,"|",9),7,12),"  Facility: ",$PIECE($GET(^DIC(4,+$EXTRACT($PIECE(QRD,"|",9),1,6),0)),U)

 +9        QUIT

 +10      ;-----

RXR(BYIMUIF) ;EP;CLEAN OUT BLANK RXR AND '0' OBX segments

 +1        NEW X,Y

 +2        SET X=0

 +3        FOR

               SET X=$ORDER(^INTHU(BYIMUIF,3,X))

               IF 'X

                   QUIT

               SET Y=^(X,0)

               Begin DoDot:1

 +4                IF $EXTRACT(Y,1,5)="RXR||"

                       KILL ^INTHU(BYIMUIF,3,X,0)

 +5                IF Y["OBX|"&(Y["V00")

                       KILL ^INTHU(BYIMUIF,3,X,0)

               End DoDot:1

 +6        QUIT

 +7       ;-----

DVXU(X)   ;DISPLAY RT VXU MESSAGE

 +1        NEW DISP,HDR

 +2        SET XX=XX

 +3        FOR

               SET XX=$ORDER(^BYIMRT(MIDDA,1,XX))

               IF 'XX!$GET(BYIMQUIT)

                   QUIT

               SET X=^(XX,0)

               Begin DoDot:1

 +4                IF X["PID|"

                       DO PID(X)

 +5                IF X["RXA|"

                       DO RXA(X)

               End DoDot:1

 +6        IF '$DATA(DISP)

               QUIT

 +7        FOR J=1:1:6

               WRITE !,HDR(J)

 +8        NEW XX,YY

 +9        SET XX=""

 +10       FOR

               SET XX=$ORDER(DISP(XX))

               IF XX=""!$GET(BYIMQUIT)

                   QUIT

               Begin DoDot:1

 +11               SET YY=""

 +12               FOR

                       SET YY=$ORDER(DISP(XX,YY))

                       IF YY=""!$GET(BYIMQUIT)

                           QUIT

                       SET Z=DISP(XX,YY)

                       Begin DoDot:2

 +13                       WRITE !,XX,?12,YY

 +14                       WRITE ?39,$JUSTIFY($PIECE(Z,U),4)

 +15                       WRITE ?45,$PIECE(Z,U,2)

 +16                       WRITE ?54,$PIECE(Z,U,3)

 +17                       WRITE ?69,$PIECE(Z,U,4)

                       End DoDot:2

 +18               IF IOST["C-"

                       IF IOSL<($Y+4)

                           Begin DoDot:2

 +19                           DO PAUSE^BYIMIMM6

 +20                           IF X[U

                                   SET BYIMQUIT=1

 +21                           IF $GET(BYIMQUIT)

                                   QUIT

 +22                           WRITE @IOF

 +23                           FOR J=1:1:6

                                   WRITE !,HDR(J)

                           End DoDot:2

               End DoDot:1

 +24       QUIT

MSH       ;DISPLAY RT MSH SEGMENT

 +1        WRITE !,$TRANSLATE($PIECE(X,"|",3),"^"," "),"  ",$TRANSLATE($PIECE(X,"|",4),"^"," "),"  "

 +2        SET Y=$PIECE(X,"|",7)

 +3        WRITE $EXTRACT(Y,1,4),"-",$EXTRACT(Y,5,6),"-",$EXTRACT(Y,7,8),"  ",$PIECE(X,"|",9),"  ",$PIECE(X,"|",11)

 +4        QUIT

 +5       ;-----

PID(X)    ;DISPLAY RT PID SEGMENT

 +1        NEW Y,Z

 +2        SET Y="NAME"

 +3        SET $EXTRACT(Y,33)="DOB"

 +4        SET $EXTRACT(Y,45)="SEX"

 +5        SET HDR(1)=Y

 +6        SET HDR(2)="------------------------------  ----------  ---"

 +7        SET Y=$PIECE(X,"|",6)

 +8        SET Y=$PIECE(Y,U)_","_$PIECE(Y,U,2)_" "_$PIECE(Y,U,3)

 +9        SET Z=$PIECE(X,"|",8)

 +10       SET $EXTRACT(Y,33)=$EXTRACT(Z,1,4)_"-"_$EXTRACT(Z,5,6)_"-"_$EXTRACT(Z,7,8)

 +11       SET $EXTRACT(Y,45)=$PIECE(X,"|",9)

 +12       SET HDR(3)=Y

 +13       SET HDR(4)=""

 +14       SET Y="ADMIN DATE"

 +15       SET $EXTRACT(Y,13)="CVX  VACCINE NAME"

 +16       SET $EXTRACT(Y,40)="QUAN"

 +17       SET $EXTRACT(Y,46)="TYPE"

 +18       SET $EXTRACT(Y,55)="LOT NO."

 +19       SET $EXTRACT(Y,70)="EXP. DATE"

 +20       SET HDR(5)=Y

 +21       SET Y="----------"

 +22       SET $EXTRACT(Y,13)="---  --------------------"

 +23       SET $EXTRACT(Y,40)="----"

 +24       SET $EXTRACT(Y,46)="-------"

 +25       SET $EXTRACT(Y,55)="-------------"

 +26       SET $EXTRACT(Y,70)="---------"

 +27       SET HDR(6)=Y

 +28       QUIT

 +29      ;-----

RXA(X)    ;DISPLAY RT RXA SEGMENT

 +1        NEW Y,Z,AD,IMM,QUAN,TYPE,LOT,EXP

 +2        SET Y=$PIECE(X,"|",4)

 +3        SET AD=$EXTRACT(Y,1,4)_"-"_$EXTRACT(Y,5,6)_"-"_$EXTRACT(Y,7,8)

 +4        SET Y=$PIECE(X,"|",6)

 +5        SET CVX=$PIECE(Y,U)

 +6        SET IMM=$JUSTIFY(CVX,3)_"  "_$EXTRACT($PIECE(Y,U,2),1,20)

 +7        SET QUAN=$TRANSLATE($PIECE(X,"|",7),"^")

 +8        SET TYPE=$TRANSLATE($EXTRACT($PIECE($PIECE(X,"|",10),U,2),1,7),"^")

 +9        SET LOT=$TRANSLATE($PIECE(X,"|",16),"^")

 +10       SET Y=$TRANSLATE($PIECE(X,"|",17),"^")

 +11       SET EXP=$EXTRACT(Y,1,4)_"-"_$EXTRACT(Y,5,6)_"-"_$EXTRACT(Y,7,8)

 +12       SET DISP(AD,IMM)=QUAN_U_TYPE_U_LOT_U_EXP

 +13       QUIT

 +14      ;-----

ALL       ;EP;TO SPECIFY NEW ONLY OR ALL IMMUNIZATIONS

 +1        KILL BYIMALL

 +2        WRITE !!,"Which immunizations should be include:"

 +3        KILL DIR

 +4        SET DIR(0)="SO^1:NEW/EDITED Immunizations (not previously exported);2:ALL Immunizations for exported patient(s)"

 +5        SET DIR("A")="Send NEW or ALL Immunizations"

 +6        SET DIR("B")="NEW/EDITED Immunizations"

 +7        DO ^DIR

 +8        KILL DIR

 +9        IF 'Y

               SET BYIMQUIT=1

               QUIT

 +10       SET BYIMALL=+Y

 +11       QUIT

 +12      ;-----

CLEANVXU(BYIMUIF) ;REMOVE INLHDEST REMNANT FOR RT MESSAGES

 +1        IF '$GET(BYIMUIF)

               QUIT

 +2        NEW X,Y,Z

 +3        SET X=0

 +4        FOR

               SET X=$ORDER(^INLHDEST(X))

               IF 'X

                   QUIT

               Begin DoDot:1

 +5                SET Y=""

 +6                FOR

                       SET Y=$ORDER(^INLHDEST(X,Y))

                       IF Y=""

                           QUIT

                       Begin DoDot:2

 +7                        SET Z=""

 +8                        FOR

                               SET Z=$ORDER(^INLHDEST(X,Y,Z))

                               IF Z=""

                                   QUIT

                               KILL ^INLHDEST(X,Y,Z,BYIMUIF)

                       End DoDot:2

               End DoDot:1

 +9        QUIT

 +10      ;

BYIMRT.m