BYIMIMM3 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
;;CONTINUATION OF BYIMIMM
;
;-----
SELECT ;EP;
F D S1 Q:$D(BYIMQUIT)
K BYIMQUIT
Q
;-----
S1 NEW XREF,BYIMBEG,BYIMEND
W @IOF
W !!?20,"Select the FILE report option"
W !
K DIR
S DIR(0)="SO^1:File Name;2:By Date range"
D ^DIR
K DIR
I 'Y S BYIMQUIT="" Q
I Y=1 D FN S Y=1 I $D(BYIMQUIT) K BYIMQUIT Q
I Y=2 D DR
I $D(BYIMQUIT) K BYIMQUIT Q
ZIS ;SELECT DEVICE FOR DISPLAY
S BYIMRTN="DISP^BYIMIMM3"
D ZIS^BYIMXIS
Q
;-----
FN ;SELECT FILE NAME TO DISPLAY
N X,Y,Z
K DIR
S DIR(0)="FO^1:50"
S DIR("A")="Select FILE NAME to display"
W !
D ^DIR
K DIR
I X="" S BYIMQUIT="" Q
I '$O(^BYIMPARA("FILE",X,$$DUZ^BYIMIMM(),0)) D Q
.W !!,"No file with this name - ",X," - on file."
.H 4
.S BYIMQUIT=""
S BYIMBEG=X
S XREF="FILE"
Q
;-----
DR ;SELECT DATE RANGE FOR DISPLAY
K DIR
S DIR(0)="DO"
S DIR("A")="Beginning Date FILE STATISTICS Report"
S Y=DT
X ^DD("DD")
S DIR("B")=Y
W !
D ^DIR
K DIR
I 'Y D Q
.S BYIMQUIT=""
.W !!,"To display FILE STATS by date range"
.W !,"the Beginning Date must be selected."
S BYIMBEG=Y
K DIR
S DIR(0)="DO"
S DIR("A")="Ending Date FILE STATISTICS Report"
S Y=DT
X ^DD("DD")
S DIR("B")=Y
W !
D ^DIR
K DIR
I 'Y S BYIMQUIT="" Q
S BYIMEND=Y
S XREF="DATE"
Q
;-----
DISP ;EP;TO DISPLAY FILE STATS REPORT
K BYIMQUIT
N X,Y,Z,JJ,XX,YY,ZZ,XXX,BYIMPREF
S JJ=0
D HDR
S BYIMPREF=""
S XX=BYIMBEG
S:'XX XX=$E(XX,1,$L(XX)-1)
S:XX XX=XX-1
F S XX=$O(^BYIMPARA(XREF,XX)) Q:XX=""!($S(BYIMBEG:XX>BYIMEND,1:XX'[BYIMBEG))!(BYIMPREF]"") D
.S YY=0
.F S YY=$O(^BYIMPARA(XREF,XX,$$DUZ^BYIMIMM(),YY)) Q:'YY!(BYIMPREF]"") D
..S X=$G(^BYIMPARA($$DUZ^BYIMIMM(),2,YY,0))
..S Y=$P(X,U),(BYIMPREF,BYIMPREF(1))="File Name Prefix: "_$S($L(Y,"_")<3:"izdata",1:$P(Y,"_",1,2)_"_")
S XX=BYIMBEG
S:'XX XX=$E(XX,1,$L(XX)-1)
S:XX XX=XX-1
F S XX=$O(^BYIMPARA(XREF,XX)) Q:XX=""!($S(BYIMBEG:XX>BYIMEND,1:XX'[BYIMBEG))!$D(BYIMQUIT) D
.S YY=0
.F S YY=$O(^BYIMPARA(XREF,XX,$$DUZ^BYIMIMM(),YY)) Q:'YY!$D(BYIMQUIT) D D1
I '$D(ZTQUEUED) W !! D PAUSE^BYIMIMM6
Q
;-----
D1 ;GET FILE INFO
I JJ=6 W !,BYIMPREF
S X=$G(^BYIMPARA($$DUZ^BYIMIMM(),2,YY,0))
S Y=$P(X,U)
S BYIMPREF="File Name Prefix: "_$S($L(Y,"_")<3:"izdata",1:$P(Y,"_",1,2)_"_")
S Y=$S($L(Y,"_")<3:$P(Y,"izdata",2),1:$P($P(Y,U),"_",3,99))
S DATE=$P(X,U,2)
S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)
S $E(Y,21)=DATE
S MODE=$P(X,U,3)
S MODE=$S(MODE="E":"EXPORT",MODE="I":"IMPORT",1:"")
S $E(Y,33)=MODE
S $E(Y,41)=$J($P(X,U,4),5)
S $E(Y,49)=$J($P(X,U,5),5)
S $E(Y,57)=$J($P(X,U,6),5)
S $E(Y,65)=$J($P(X,U,7),5)
S $E(Y,73)=$J($P(X,U,8),5)
I BYIMPREF'=BYIMPREF(1) W !!,BYIMPREF S BYIMPREF(1)=BYIMPREF
W !,Y
S JJ=JJ+1
I '$D(ZTQUEUED),JJ#IOSL=0 D
.W !!
.D PAUSE^BYIMIMM6
.I X[U S BYIMQUIT="" Q
.D HDR
Q
;-----
OL(INDA) ;EP;TO SET OUTSIDE LOCATION
S VDA=$P($G(^AUPNVIMM(INDA,0)),U,3)
S OL=$P($G(^AUPNVSIT(+VDA,21)),U)
Q:OL]"" OL
S OL=$P($G(^AUPNVSIT(VDA,0)),U,6)
S OL=$P($G(^DIC(4,+OL,0)),U)
Q OL
;-----
HX1(X) ;EP;TO RETURN HX CODE
N VIS,I0,V0,TYPE,CB,MFI
D VINFO(X)
Q:CB=.5!$L(MFI) "02"
Q:"CTNOEDXM"[TYPE "01"
Q "00"
;-----
HX2(X) ;EP;TO RETURN HX CODE
N VIS,I0,V0,TYPE,CB,MFI
D VINFO(X)
Q:CB=.5!$G(MFI) "HISTORICAL INFORMATION - OTHER PROVIDER"
Q:TYPE="E"!'VIS "HISTORICAL INFORMATION - SOURCE UNSPECIFIED"
Q "NEW IMMUNIZATION RECORD"
;-----
VINFO(X) ;GET VISIT INFOR
N X1,X2
S I0=$G(^AUPNVIMM(+$G(X),0))
S VIS=+$P(I0,U,3)
S V0=$G(^AUPNVSIT(VIS,0))
S TYPE=$P(V0,U,7)
I $G(BYIMHIST),BYIMHIST>+V0!'$P(I0,U,5) S TYPE="E"
S CB=$P(V0,U,23)
S MFI=$P($G(^AUPNVSIT(VIS,11)),U,13)
Q
;-----
VFC(INDA) ;EP;TO RETURN PATIENT LEVEL PV1-20 VFC CODE
N X,Y,Z,DFN
S VSIT=+$G(INDA)
S DFN=+$P($G(^AUPNVSIT(VSIT,0)),U,5)
S X=$P($G(^AUPNPAT(DFN,11)),U,11)
N MCD
S MCD=$O(^AUPNMCD(DFN,11,9999999999),-1)
I MCD,'$P($G(^AUPNMCD(DFN,11,MCD,0)),U,2) S X=2
S X=$S(X=2:2,X=1:4,1:1)
I $P($G(^DPT(DFN,0)),U,3)<(DT-190000) S X=1
S X="V0"_X
S X=X_U_$$VFCD(VSIT)
Q:$G(BYIMVER)<2.5 X
I $P($G(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,9) S X=X_"~"_$$VT(INDA)
Q X
;-----
VFCD(VSIT) ;EP;TO RETURN THE VFC DATE
N X,Y,Z
S X=""
S:VSIT X=$P($P($G(^AUPNVSIT(VSIT,0)),U),".")
S:'X X=$P($G(^DPT(+DFN,0)),U,3)
S:'X X=DT
S X=X+17000000
Q X
;-----
IVFC(INDA) ;EP;TO RETURN IMMUNIZATION SPECIFIC VFC CODE
;PATCH 8 CR 08628 DEFAULT TO NOT VFC ELIGIBLE IF >18
N DFN,DOB,X,Y,Z,VFC,VDAT
S DFN=+$P($G(^AUPNVIMM(+INDA,0)),U,2)
S DOB=$P($G(^DPT(DFN,0)),U,3)
S VDAT=+$P($G(^AUPNVIMM(+INDA,0)),U,3)
S VDAT=$P($G(^AUPNVSIT(VDAT,0)),".")
S X=$P($G(^AUPNVIMM(+INDA,0)),U,14)
I 'X,VDAT,VDAT<(DOB-190000) S X=1
;PATCH 8 CR 08628 END
I 'X S X=$$VFC($P($G(^AUPNVIMM(+INDA,0)),U,3)),X=$E(X,3)
I X,$P(^DD(9000010.11,.14,0),U,2)["S" S X=$$IVFCD(X)
I X,$P(^DD(9000010.11,.14,0),U,2)["P" S X=$$IVFCP(X)
I $P($G(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,9) S X=$S(X]"":(X_"~"),1:"")_$$IVT(INDA)
Q X
;-----
IVFCD(IDAT) ;EP;TO RETURN THE VFC FROM SET OF CODES
N X,Y,Z
S Y=IDAT_":"
S X=$P(^DD(9000010.11,.14,0),U,3)
S X=$P($P(X,Y,2),";")
S X="V0"_IDAT_U_X_U_"HL70064"
Q X
;-----
IVFCP(IDAT) ;EP;TO RETURN THE VFC FROM POINTER
N CODE,DESC
S:'IDAT IDAT=1
S CODE=$$VAL^XBDIQ1(9002084.83,IDAT,.01)
S DESC=$$VAL^XBDIQ1(9002084.83,IDAT,.02)
S X=$TR(CODE_U_DESC_U_"HL70064","-")
Q X
;-----
VT(INDA) ;EP;TO RETURN LAST VISIT TYPE
N X,Y,Z
S X=+$O(^AUPNVSIT("AC",INDA,9999999999),-1)
Q:'X ""
S Y=$P($G(^AUPNVSIT(X,0)),".")+17000000
Q:Y=17000000 ""
S X=$P($G(^AUPNVSIT(X,0)),U,3)
S X=$S(X="I":1,X="C":2,X="T":4,X="O":5,X=6:6,X="V":7,X="P":8,X="U":9,1:"")
Q:X="" ""
S Y="IHS0"_X_U_Y
Q Y
;-----
IVT(INDA) ;EP;TO RETURN IMM VISIT TYPE
N X,Y,Z
S X=+$P($G(^AUPNVIMM(+INDA,0)),U,3)
Q:'X ""
S Y=$P($G(^AUPNVSIT(X,0)),".")+17000000
Q:Y=17000000 ""
S X=$P($G(^AUPNVSIT(X,0)),U,3)
S X=$S(X="I":1,X="C":2,X="T":4,X="O":5,X=6:6,X="V":7,X="P":8,X="U":9,1:"")
Q:X="" ""
S Y="IHS0"_X_U_Y
Q Y
;-----
HRN(INDA) ;EP;TO RETURN THE HRN CODE
N X,XX,Y,Z,HRN,LOC,ASUFAC,BYIMDUZ
S BYIMDUZ(2)=+DUZ(2)
S XX=$$DUZ^BYIMIMM()
S HRN=$P($G(^AUPNPAT(INDA,41,XX,0)),U,2)
D:HRN=""
.S XX=$O(^AUPNPAT(INDA,41,0))
.I 'XX S XX=BYIMDUZ(2) Q
.S HRN=$P($G(^AUPNPAT(INDA,41,XX,0)),U,2)
S:$L(HRN)<6 HRN=$E("000000",1,6-$L(HRN))_HRN
S LOC=$P($G(^DIC(4,XX,0)),U)
S ASUFAC=$P($G(^AUTTLOC(XX,0)),U,10) S ASUFAC=$E("000000",1,6-$L(ASUFAC))_ASUFAC
;PATCH 7 ENSURE LOC 20 CHARACTERS OR LESS
;S XX=ASUFAC_HRN_CS_CS_CS_LOC_CS_"MR"
S XX=ASUFAC_HRN_CS_CS_CS_$E(LOC,1,20)_CS_"MR"
S X="DUZ(2)"
S @X=BYIMDUZ(2)
Q XX
;-----
RACE(INDA) ;EP;TO RETURN RACE
N X,Y,Z
I '$G(INDA) Q "2131-1^OTHER RACE^HL70005"
S X=$O(^DPT(INDA,.02,0))
S:'X X=$P($G(^DPT(INDA,0)),U,6)
S:X X=$P($G(^DIC(10,X,0)),U,3)_U_$P($G(^DIC(10,X,0)),U)
S:X["9999-4" X=U_$P(X,U,2)
I $P(X,U)="" D
.S Y=$P(X,U,2)
.S:Y["AMERICAN INDIAN" X="1002-5"_X
.S:Y["WHITE" X="2106-3"_X
.S:Y["BLACK" X="2054-5"_X
.S:$P(X,U)="" X="2131-1^OTHER RACE"
S:X=""!(X=U) X=$P($G(^AUPNPAT(INDA,11)),U,11)
S:X=1 X="1002-5^AMERICAN INDIAN OR ALASKA NATIVE"
S:$P(X,U,2)="" X="2131-1^OTHER RACE"
;PATCH 7 USE 'OTHER' IF NO RACE ON FILE
;S:X["0000-0" X="2131-1^OTHER RACE"
S:X["0000-0"!(X["9999-4") X="2131-1^OTHER RACE"
Q (X_"^HL70005")
;-----
ETH(DFN) ;EP;TO RETURN ETHNICITY
N X,Y,Z
S Z=""
I '$O(^DPT(+$G(DFN),.06,0)) S Z="2186-5^NOT HISPANIC OR LATINO^CDCREC" Q Z
S X=0
F S X=$O(^DPT(DFN,.06,X)) Q:'X D
.S Y=$P($G(^DIC(10.2,X,0)),U,3)_U_$P($G(^DIC(10.2,X,0)),U)
.Q:Y=U
.S Y=Y_"^CDCREC"
.S Z=$S(Z]"":(Z_"~"),1:"")_Y
S:Z=""!(Z["0000")!(Z["9999") Z="2186-5^NOT HISPANIC OR LATINO^CDCREC" Q Z
Q Z
;-----
TEST ;EP;CREATE & SEND TEST MESSAGES
D TEST^BYIMIMM5
Q
IZV04 ;EP;IMMUNIZATION DATA EXCHANGE
S BHLDEST="D DEST^INHUSEN"
S INDEST("VXUV04")="HL IHS IZV04 IN"
X BHLDEST
Q
;-----
RSP ;EP;IMMUNIZATION DATA EXCHANGE
S BHLDEST="D DEST^INHUSEN"
S INDEST("RSPK11")="HL IHS IZV04 RSP IN"
X BHLDEST
Q
;-----
LOC ;EP;TO CHECK LOC. OF ENCOUNTER VERSUS OUTSIDE LOCATION
;PATCH 2
N BYIMUDA,BYIMVDA,BYIMLDA,BYIMLODA
S BYIMUDA=$O(^VA(200,"B","USER,IMMUNIZATION INTERFACE",0))
Q:'BYIMUDA
S BYIMVDA=0
F S BYIMVDA=$O(^AUPNVIMM("AD",BYIMVDA)) Q:'BYIMVDA D
.S X=$G(^AUPNVSIT(BYIMVDA,0))
.Q:$P(X,U,23)'=BYIMUDA&($P(X,U,27)'=BYIMUDA)
.S BYIMLDA=$P($G(^AUPNVSIT(BYIMVDA,0)),U,6)
.Q:$P($G(^DIC(4,+BYIMLDA,0)),U)'="OTHER"
.S BYIMLODA=$P($G(^AUPNVSIT(BYIMVDA,21)),U)
.Q:BYIMLODA=""
.S X=BYIMLODA
.X ^%ZOSF("UPPERCASE")
.S BYIMLODA=Y
.Q:BYIMLODA["OTHER"
.S BYIMLODA=$O(^DIC(4,"B",BYIMLODA,0))
.Q:'BYIMLODA
.S DR=".06////"_BYIMLODA
.S DIE="^AUPNVSIT("
.S DA=BYIMVDA
.D ^DIE
.I $E($G(IOST),1,2)="C-" W "."
Q
;-----
PROT(INDA) ;EP;TO DETERMINE PROTECTION FLAG
Q:'INDA ""
N X
S X=$P($G(^BIP(+$G(INDA),0)),U,24)
I $G(BYIMVER)<2.5 S X=$S(X=1:"Y",X=0:"N",1:"")
;PATCH 7 CORRECT VERSION CHECK LOGIC
;I $G(BYIMVER)>2.5 S X=$S(X=1:"N",X=0:"Y",1:"")
I $G(BYIMVER)>2.49 S X=$S(X=1:"N",X=0:"Y",1:"")
Q X
;-----
PROTDT(INDA) ;EP;TO DETERMINE PROTECTION FLAG
N X
S X=$P($G(^BIP(+$G(INDA),0)),U,25)
S:'X X=$P($G(^BIP(+$G(INDA),0)),U,21)
S:X'?7N X=DT
S X=X+17000000
Q X
;-----
ACTDT(INDA) ;EP;TO DETERMINE INACTIVATION DATE
N X
S X=$P($G(^BIP(+$G(INDA),0)),U,8)
S:X'?7N X=$P($G(^BIP(+$G(INDA),0)),U,21)
S:X'?7N X=DT
S X=X+17000000
Q X
;-----
PUB(INDA) ;EP;TO DETERMINE PUBLICITY FOR PATIENT
Q:'INDA ""
N X
S X=$P($G(^BIP(+$G(INDA),0)),U,99),X=$S(X=1:"N",X=0:"Y",1:"02")
I X="01" S X=X_CS_"NO REMINDER/RECALL"_CS_"HL70215"
I X="02" S X=X_CS_"REMINDER/RECALL - ANY METHOD"_CS_"HL70215"
I X="03" S X=X_CS_"REMINDER/RECALL - NO CALLS"_CS_"HL70215"
I X="04" S X=X_CS_"REMINDER ONLY - ANY METHOD"_CS_"HL70215"
I X="05" S X=X_CS_"REMINDER ONLY - NO CALLS"_CS_"HL70215"
I X="06" S X=X_CS_"RECALL ONLY - ANY METHOD"_CS_"HL70215"
I X="07" S X=X_CS_"RECALL ONLY - NO CALLS"_CS_"HL70215"
I X="08" S X=X_CS_"REMINDER/RECALL - TO PROVIDER"_CS_"HL70215"
I X="09" S X=X_CS_"REMINDER - TO PROVIDER"_CS_"HL70215"
I X="10" S X=X_CS_"ONLY REMINDER TO PROVIDER, NO RECALL"_CS_"HL70215"
I X="11" S X=X_CS_"RECALL TO PROVIDER"_CS_"HL70215"
I X="12" S X=X_CS_"ONLY RECALL TO PROVIDER, NO REMINDER"_CS_"HL70215"
Q X
;-----
PUBDT(INDA) ;EP;TO DETERMINE PUBLICITY DATE
N X
S X=$P($G(^BIP(+$G(INDA),0)),U,21)
S:X'?7N X=DT
S X=X+17000000
Q X
;-----
IVFS(INDA) ;EP;TO RETURN IMMUNIZATION SPECIFIC VFS CODE
N X,Y,Z,ZD,VFC
S X=+$P($G(^AUPNVIMM(+INDA,0)),U,5)
S Y=$P($G(^AUTTIML(X,0)),U,13)
;S Z=$S(Y="v":"VXC1",Y="o":"VXC2",Y="i":"VXC3",1:"UNK")
S Z=$S(Y="v":"VXC1",Y="o":"VXC2",Y="i":"VXC3",1:"VXC1")
;S ZD=$S(Y="v":"Federal funds",Y="o":"State funds",Y="i":"Tribal funds",1:"Unspecified")
S ZD=$S(Y="v":"Federal funds",Y="o":"State funds",Y="i":"Tribal funds",1:"Federal funds")
S X=Z_CS_ZD_CS_"CDCPHINVS"
Q X
;-----
HDR ;DISPLAY HEADER
S JJ=JJ+6
W @IOF
W !!,"File Status Report",?40,"Report Date: "
W $E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,1,3)+1700
W !!,?20,"IMP/EXP",?40,"Pat-",?48,"Imuni-",?56,"NO Pat",?64,"New",?72,"Imms"
W !,"File",?20,"Date",?32,"Type",?40,"ients",?48,"zations",?56,"Match",?64,"Imms",?72,"Added"
W !,"------------------",?20,"----------",?32,"------",?40,"------",?48,"------",?56,"------",?64,"------",?72,"------"
Q
;-----
DIRECT ;EP;DIRECT FIND OF PATIENT
K Y,MM
N X,Z,DFN,NAMEX
S NAME=$P(NAME,",")_","_$P($P(NAME,",",2)," ")
S NAME=$TR(NAME,".","")
S (X,NAMEX)=$E(NAME,1,$L(NAME)-1)
F S X=$O(^DPT("B",X)) Q:X=""!(X'[NAMEX) D
.S Y=0
.F S Y=$O(^DPT("B",X,Y)) Q:'Y D
..S Z=$G(^DPT(Y,0))
..I $P(Z,U,3)=DOB,$P(Z,U,2)=SEX S DFN=Y Q
..I $P(Z,U,3)=DOB,$P(Z,U,2)'=SEX S MM="SEX"
..I $P(Z,U,3)'=DOB,$P(Z,U,2)=SEX S MM="DOB"
I $G(DFN) S Y=DFN Q
S Y=0
I HRN F S Y=$O(^AUPNPAT("D",HRN,Y)) Q:'Y D
.S Z=$G(^DPT(Y,0))
.I $P(Z,U,3)=DOB,$P(Z,U,2)=SEX S DFN=Y
.I $P(Z,U,3)=DOB,$P(Z,U,2)'=SEX S MM="SEX"
.I $P(Z,U,3)'=DOB,$P(Z,U,2)=SEX S MM="DOB"
S:$G(DFN) Y=DFN
S:$G(MM)="" MM="NAME"
Q
;-----
SEL ;EP;TO SELECT SPECIFIC PATIENTS TO RE-EXPORT
K ^BYIMTMP($J,"BYIM EXP")
N Y
S Y=$P($G(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,6)
S YEARS=$S('Y:19,Y=1:65,1:99)
S CHILD=$S('Y:"Children",1:"Patients")
D SPAT
Q:'$D(^BYIMTMP($J,"BYIM EXP"))
N BYIMALL
S BYIMALL=2
K DIR
S DIR(0)="YO"
S DIR("A")="Proceed with export of selected patients"
S DIR("B")="NO"
W !!
D ^DIR
K DIR
Q:'Y
S MSGCNT=BYIMJ
S BYIMTEST=BYIMJ
S XX=$P($H,",",2)
N DDATE
D FN^BYIMIMM
S (DDATE,DDDATE)=$O(^BYIMPARA($$DUZ^BYIMIMM(),"LAST EXPORT",9999999999),-1)
D DEX^BYIMIMM
Q
;-----
SPAT ;SELECT PATIENTS
N BYIMQUIT
S BYIMQUIT=""
S BYIMJ=0
F D SPAT1 Q:BYIMQUIT
K BYIMQUIT
Q
;-----
SPAT1 ;SELECT EACH PATIENT
W @IOF
W !!?10,"Export selected patients"
W !!?10,"An export file will be created for selected patients:"
W !!
N BYIMX
S X=0
F S X=$O(^BYIMTMP($J,"BYIM EXP",X)) Q:'X D
.S Y=$P($G(^DPT(X,0)),U)
.Q:Y=""
.S BYIMX(Y)=""
S J=0
S X=""
F S X=$O(BYIMX(X)) Q:X="" S J=J+1 W !?10,J,?15,X
W !!
K DIC
S DIC="^DPT("
S DIC(0)="AMEQZ"
S DIC("A")="Select patient to export: "
S DIC("S")="I $O(^AUPNVIMM(""AC"",+Y,0))"
D ^DIC
K DIC,DR,DA,DIE
I Y<1 S BYIMQUIT=1 Q
N XX,X,Z,DOB,DFN,VIS,J
S DFN=+Y
Q:$D(^BYIMTMP($J,"BYIM EXP",DFN))
S XX=$O(^AUPNVIMM("AC",DFN,9999999999),-1)
Q:'XX
S X=$G(^AUPNVIMM(XX,0))
S VIS=$P(X,U,3)
Q:'VIS
S ^BYIMTMP($J,"BYIM EXP",DFN,VIS)=""
S BYIMJ=BYIMJ+1
Q
;-----
BYIMIMM3 ;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 ;;CONTINUATION OF BYIMIMM
+3 ;
+4 ;-----
SELECT ;EP;
+1 FOR
DO S1
IF $DATA(BYIMQUIT)
QUIT
+2 KILL BYIMQUIT
+3 QUIT
+4 ;-----
S1 NEW XREF,BYIMBEG,BYIMEND
+1 WRITE @IOF
+2 WRITE !!?20,"Select the FILE report option"
+3 WRITE !
+4 KILL DIR
+5 SET DIR(0)="SO^1:File Name;2:By Date range"
+6 DO ^DIR
+7 KILL DIR
+8 IF 'Y
SET BYIMQUIT=""
QUIT
+9 IF Y=1
DO FN
SET Y=1
IF $DATA(BYIMQUIT)
KILL BYIMQUIT
QUIT
+10 IF Y=2
DO DR
+11 IF $DATA(BYIMQUIT)
KILL BYIMQUIT
QUIT
ZIS ;SELECT DEVICE FOR DISPLAY
+1 SET BYIMRTN="DISP^BYIMIMM3"
+2 DO ZIS^BYIMXIS
+3 QUIT
+4 ;-----
FN ;SELECT FILE NAME TO DISPLAY
+1 NEW X,Y,Z
+2 KILL DIR
+3 SET DIR(0)="FO^1:50"
+4 SET DIR("A")="Select FILE NAME to display"
+5 WRITE !
+6 DO ^DIR
+7 KILL DIR
+8 IF X=""
SET BYIMQUIT=""
QUIT
+9 IF '$ORDER(^BYIMPARA("FILE",X,$$DUZ^BYIMIMM(),0))
Begin DoDot:1
+10 WRITE !!,"No file with this name - ",X," - on file."
+11 HANG 4
+12 SET BYIMQUIT=""
End DoDot:1
QUIT
+13 SET BYIMBEG=X
+14 SET XREF="FILE"
+15 QUIT
+16 ;-----
DR ;SELECT DATE RANGE FOR DISPLAY
+1 KILL DIR
+2 SET DIR(0)="DO"
+3 SET DIR("A")="Beginning Date FILE STATISTICS Report"
+4 SET Y=DT
+5 XECUTE ^DD("DD")
+6 SET DIR("B")=Y
+7 WRITE !
+8 DO ^DIR
+9 KILL DIR
+10 IF 'Y
Begin DoDot:1
+11 SET BYIMQUIT=""
+12 WRITE !!,"To display FILE STATS by date range"
+13 WRITE !,"the Beginning Date must be selected."
End DoDot:1
QUIT
+14 SET BYIMBEG=Y
+15 KILL DIR
+16 SET DIR(0)="DO"
+17 SET DIR("A")="Ending Date FILE STATISTICS Report"
+18 SET Y=DT
+19 XECUTE ^DD("DD")
+20 SET DIR("B")=Y
+21 WRITE !
+22 DO ^DIR
+23 KILL DIR
+24 IF 'Y
SET BYIMQUIT=""
QUIT
+25 SET BYIMEND=Y
+26 SET XREF="DATE"
+27 QUIT
+28 ;-----
DISP ;EP;TO DISPLAY FILE STATS REPORT
+1 KILL BYIMQUIT
+2 NEW X,Y,Z,JJ,XX,YY,ZZ,XXX,BYIMPREF
+3 SET JJ=0
+4 DO HDR
+5 SET BYIMPREF=""
+6 SET XX=BYIMBEG
+7 IF 'XX
SET XX=$EXTRACT(XX,1,$LENGTH(XX)-1)
+8 IF XX
SET XX=XX-1
+9 FOR
SET XX=$ORDER(^BYIMPARA(XREF,XX))
IF XX=""!($SELECT(BYIMBEG
QUIT
Begin DoDot:1
+10 SET YY=0
+11 FOR
SET YY=$ORDER(^BYIMPARA(XREF,XX,$$DUZ^BYIMIMM(),YY))
IF 'YY!(BYIMPREF]"")
QUIT
Begin DoDot:2
+12 SET X=$GET(^BYIMPARA($$DUZ^BYIMIMM(),2,YY,0))
+13 SET Y=$PIECE(X,U)
SET (BYIMPREF,BYIMPREF(1))="File Name Prefix: "_$SELECT($LENGTH(Y,"_")<3:"izdata",1:$PIECE(Y,"_",1,2)_"_")
End DoDot:2
End DoDot:1
+14 SET XX=BYIMBEG
+15 IF 'XX
SET XX=$EXTRACT(XX,1,$LENGTH(XX)-1)
+16 IF XX
SET XX=XX-1
+17 FOR
SET XX=$ORDER(^BYIMPARA(XREF,XX))
IF XX=""!($SELECT(BYIMBEG
QUIT
Begin DoDot:1
+18 SET YY=0
+19 FOR
SET YY=$ORDER(^BYIMPARA(XREF,XX,$$DUZ^BYIMIMM(),YY))
IF 'YY!$DATA(BYIMQUIT)
QUIT
DO D1
End DoDot:1
+20 IF '$DATA(ZTQUEUED)
WRITE !!
DO PAUSE^BYIMIMM6
+21 QUIT
+22 ;-----
D1 ;GET FILE INFO
+1 IF JJ=6
WRITE !,BYIMPREF
+2 SET X=$GET(^BYIMPARA($$DUZ^BYIMIMM(),2,YY,0))
+3 SET Y=$PIECE(X,U)
+4 SET BYIMPREF="File Name Prefix: "_$SELECT($LENGTH(Y,"_")<3:"izdata",1:$PIECE(Y,"_",1,2)_"_")
+5 SET Y=$SELECT($LENGTH(Y,"_")<3:$PIECE(Y,"izdata",2),1:$PIECE($PIECE(Y,U),"_",3,99))
+6 SET DATE=$PIECE(X,U,2)
+7 SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_($EXTRACT(DATE,1,3)+1700)
+8 SET $EXTRACT(Y,21)=DATE
+9 SET MODE=$PIECE(X,U,3)
+10 SET MODE=$SELECT(MODE="E":"EXPORT",MODE="I":"IMPORT",1:"")
+11 SET $EXTRACT(Y,33)=MODE
+12 SET $EXTRACT(Y,41)=$JUSTIFY($PIECE(X,U,4),5)
+13 SET $EXTRACT(Y,49)=$JUSTIFY($PIECE(X,U,5),5)
+14 SET $EXTRACT(Y,57)=$JUSTIFY($PIECE(X,U,6),5)
+15 SET $EXTRACT(Y,65)=$JUSTIFY($PIECE(X,U,7),5)
+16 SET $EXTRACT(Y,73)=$JUSTIFY($PIECE(X,U,8),5)
+17 IF BYIMPREF'=BYIMPREF(1)
WRITE !!,BYIMPREF
SET BYIMPREF(1)=BYIMPREF
+18 WRITE !,Y
+19 SET JJ=JJ+1
+20 IF '$DATA(ZTQUEUED)
IF JJ#IOSL=0
Begin DoDot:1
+21 WRITE !!
+22 DO PAUSE^BYIMIMM6
+23 IF X[U
SET BYIMQUIT=""
QUIT
+24 DO HDR
End DoDot:1
+25 QUIT
+26 ;-----
OL(INDA) ;EP;TO SET OUTSIDE LOCATION
+1 SET VDA=$PIECE($GET(^AUPNVIMM(INDA,0)),U,3)
+2 SET OL=$PIECE($GET(^AUPNVSIT(+VDA,21)),U)
+3 IF OL]""
QUIT OL
+4 SET OL=$PIECE($GET(^AUPNVSIT(VDA,0)),U,6)
+5 SET OL=$PIECE($GET(^DIC(4,+OL,0)),U)
+6 QUIT OL
+7 ;-----
HX1(X) ;EP;TO RETURN HX CODE
+1 NEW VIS,I0,V0,TYPE,CB,MFI
+2 DO VINFO(X)
+3 IF CB=.5!$LENGTH(MFI)
QUIT "02"
+4 IF "CTNOEDXM"[TYPE
QUIT "01"
+5 QUIT "00"
+6 ;-----
HX2(X) ;EP;TO RETURN HX CODE
+1 NEW VIS,I0,V0,TYPE,CB,MFI
+2 DO VINFO(X)
+3 IF CB=.5!$GET(MFI)
QUIT "HISTORICAL INFORMATION - OTHER PROVIDER"
+4 IF TYPE="E"!'VIS
QUIT "HISTORICAL INFORMATION - SOURCE UNSPECIFIED"
+5 QUIT "NEW IMMUNIZATION RECORD"
+6 ;-----
VINFO(X) ;GET VISIT INFOR
+1 NEW X1,X2
+2 SET I0=$GET(^AUPNVIMM(+$GET(X),0))
+3 SET VIS=+$PIECE(I0,U,3)
+4 SET V0=$GET(^AUPNVSIT(VIS,0))
+5 SET TYPE=$PIECE(V0,U,7)
+6 IF $GET(BYIMHIST)
IF BYIMHIST>+V0!'$PIECE(I0,U,5)
SET TYPE="E"
+7 SET CB=$PIECE(V0,U,23)
+8 SET MFI=$PIECE($GET(^AUPNVSIT(VIS,11)),U,13)
+9 QUIT
+10 ;-----
VFC(INDA) ;EP;TO RETURN PATIENT LEVEL PV1-20 VFC CODE
+1 NEW X,Y,Z,DFN
+2 SET VSIT=+$GET(INDA)
+3 SET DFN=+$PIECE($GET(^AUPNVSIT(VSIT,0)),U,5)
+4 SET X=$PIECE($GET(^AUPNPAT(DFN,11)),U,11)
+5 NEW MCD
+6 SET MCD=$ORDER(^AUPNMCD(DFN,11,9999999999),-1)
+7 IF MCD
IF '$PIECE($GET(^AUPNMCD(DFN,11,MCD,0)),U,2)
SET X=2
+8 SET X=$SELECT(X=2:2,X=1:4,1:1)
+9 IF $PIECE($GET(^DPT(DFN,0)),U,3)<(DT-190000)
SET X=1
+10 SET X="V0"_X
+11 SET X=X_U_$$VFCD(VSIT)
+12 IF $GET(BYIMVER)<2.5
QUIT X
+13 IF $PIECE($GET(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,9)
SET X=X_"~"_$$VT(INDA)
+14 QUIT X
+15 ;-----
VFCD(VSIT) ;EP;TO RETURN THE VFC DATE
+1 NEW X,Y,Z
+2 SET X=""
+3 IF VSIT
SET X=$PIECE($PIECE($GET(^AUPNVSIT(VSIT,0)),U),".")
+4 IF 'X
SET X=$PIECE($GET(^DPT(+DFN,0)),U,3)
+5 IF 'X
SET X=DT
+6 SET X=X+17000000
+7 QUIT X
+8 ;-----
IVFC(INDA) ;EP;TO RETURN IMMUNIZATION SPECIFIC VFC CODE
+1 ;PATCH 8 CR 08628 DEFAULT TO NOT VFC ELIGIBLE IF >18
+2 NEW DFN,DOB,X,Y,Z,VFC,VDAT
+3 SET DFN=+$PIECE($GET(^AUPNVIMM(+INDA,0)),U,2)
+4 SET DOB=$PIECE($GET(^DPT(DFN,0)),U,3)
+5 SET VDAT=+$PIECE($GET(^AUPNVIMM(+INDA,0)),U,3)
+6 SET VDAT=$PIECE($GET(^AUPNVSIT(VDAT,0)),".")
+7 SET X=$PIECE($GET(^AUPNVIMM(+INDA,0)),U,14)
+8 IF 'X
IF VDAT
IF VDAT<(DOB-190000)
SET X=1
+9 ;PATCH 8 CR 08628 END
+10 IF 'X
SET X=$$VFC($PIECE($GET(^AUPNVIMM(+INDA,0)),U,3))
SET X=$EXTRACT(X,3)
+11 IF X
IF $PIECE(^DD(9000010.11,.14,0),U,2)["S"
SET X=$$IVFCD(X)
+12 IF X
IF $PIECE(^DD(9000010.11,.14,0),U,2)["P"
SET X=$$IVFCP(X)
+13 IF $PIECE($GET(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,9)
SET X=$SELECT(X]"":(X_"~"),1:"")_$$IVT(INDA)
+14 QUIT X
+15 ;-----
IVFCD(IDAT) ;EP;TO RETURN THE VFC FROM SET OF CODES
+1 NEW X,Y,Z
+2 SET Y=IDAT_":"
+3 SET X=$PIECE(^DD(9000010.11,.14,0),U,3)
+4 SET X=$PIECE($PIECE(X,Y,2),";")
+5 SET X="V0"_IDAT_U_X_U_"HL70064"
+6 QUIT X
+7 ;-----
IVFCP(IDAT) ;EP;TO RETURN THE VFC FROM POINTER
+1 NEW CODE,DESC
+2 IF 'IDAT
SET IDAT=1
+3 SET CODE=$$VAL^XBDIQ1(9002084.83,IDAT,.01)
+4 SET DESC=$$VAL^XBDIQ1(9002084.83,IDAT,.02)
+5 SET X=$TRANSLATE(CODE_U_DESC_U_"HL70064","-")
+6 QUIT X
+7 ;-----
VT(INDA) ;EP;TO RETURN LAST VISIT TYPE
+1 NEW X,Y,Z
+2 SET X=+$ORDER(^AUPNVSIT("AC",INDA,9999999999),-1)
+3 IF 'X
QUIT ""
+4 SET Y=$PIECE($GET(^AUPNVSIT(X,0)),".")+17000000
+5 IF Y=17000000
QUIT ""
+6 SET X=$PIECE($GET(^AUPNVSIT(X,0)),U,3)
+7 SET X=$SELECT(X="I":1,X="C":2,X="T":4,X="O":5,X=6:6,X="V":7,X="P":8,X="U":9,1:"")
+8 IF X=""
QUIT ""
+9 SET Y="IHS0"_X_U_Y
+10 QUIT Y
+11 ;-----
IVT(INDA) ;EP;TO RETURN IMM VISIT TYPE
+1 NEW X,Y,Z
+2 SET X=+$PIECE($GET(^AUPNVIMM(+INDA,0)),U,3)
+3 IF 'X
QUIT ""
+4 SET Y=$PIECE($GET(^AUPNVSIT(X,0)),".")+17000000
+5 IF Y=17000000
QUIT ""
+6 SET X=$PIECE($GET(^AUPNVSIT(X,0)),U,3)
+7 SET X=$SELECT(X="I":1,X="C":2,X="T":4,X="O":5,X=6:6,X="V":7,X="P":8,X="U":9,1:"")
+8 IF X=""
QUIT ""
+9 SET Y="IHS0"_X_U_Y
+10 QUIT Y
+11 ;-----
HRN(INDA) ;EP;TO RETURN THE HRN CODE
+1 NEW X,XX,Y,Z,HRN,LOC,ASUFAC,BYIMDUZ
+2 SET BYIMDUZ(2)=+DUZ(2)
+3 SET XX=$$DUZ^BYIMIMM()
+4 SET HRN=$PIECE($GET(^AUPNPAT(INDA,41,XX,0)),U,2)
+5 IF HRN=""
Begin DoDot:1
+6 SET XX=$ORDER(^AUPNPAT(INDA,41,0))
+7 IF 'XX
SET XX=BYIMDUZ(2)
QUIT
+8 SET HRN=$PIECE($GET(^AUPNPAT(INDA,41,XX,0)),U,2)
End DoDot:1
+9 IF $LENGTH(HRN)<6
SET HRN=$EXTRACT("000000",1,6-$LENGTH(HRN))_HRN
+10 SET LOC=$PIECE($GET(^DIC(4,XX,0)),U)
+11 SET ASUFAC=$PIECE($GET(^AUTTLOC(XX,0)),U,10)
SET ASUFAC=$EXTRACT("000000",1,6-$LENGTH(ASUFAC))_ASUFAC
+12 ;PATCH 7 ENSURE LOC 20 CHARACTERS OR LESS
+13 ;S XX=ASUFAC_HRN_CS_CS_CS_LOC_CS_"MR"
+14 SET XX=ASUFAC_HRN_CS_CS_CS_$EXTRACT(LOC,1,20)_CS_"MR"
+15 SET X="DUZ(2)"
+16 SET @X=BYIMDUZ(2)
+17 QUIT XX
+18 ;-----
RACE(INDA) ;EP;TO RETURN RACE
+1 NEW X,Y,Z
+2 IF '$GET(INDA)
QUIT "2131-1^OTHER RACE^HL70005"
+3 SET X=$ORDER(^DPT(INDA,.02,0))
+4 IF 'X
SET X=$PIECE($GET(^DPT(INDA,0)),U,6)
+5 IF X
SET X=$PIECE($GET(^DIC(10,X,0)),U,3)_U_$PIECE($GET(^DIC(10,X,0)),U)
+6 IF X["9999-4"
SET X=U_$PIECE(X,U,2)
+7 IF $PIECE(X,U)=""
Begin DoDot:1
+8 SET Y=$PIECE(X,U,2)
+9 IF Y["AMERICAN INDIAN"
SET X="1002-5"_X
+10 IF Y["WHITE"
SET X="2106-3"_X
+11 IF Y["BLACK"
SET X="2054-5"_X
+12 IF $PIECE(X,U)=""
SET X="2131-1^OTHER RACE"
End DoDot:1
+13 IF X=""!(X=U)
SET X=$PIECE($GET(^AUPNPAT(INDA,11)),U,11)
+14 IF X=1
SET X="1002-5^AMERICAN INDIAN OR ALASKA NATIVE"
+15 IF $PIECE(X,U,2)=""
SET X="2131-1^OTHER RACE"
+16 ;PATCH 7 USE 'OTHER' IF NO RACE ON FILE
+17 ;S:X["0000-0" X="2131-1^OTHER RACE"
+18 IF X["0000-0"!(X["9999-4")
SET X="2131-1^OTHER RACE"
+19 QUIT (X_"^HL70005")
+20 ;-----
ETH(DFN) ;EP;TO RETURN ETHNICITY
+1 NEW X,Y,Z
+2 SET Z=""
+3 IF '$ORDER(^DPT(+$GET(DFN),.06,0))
SET Z="2186-5^NOT HISPANIC OR LATINO^CDCREC"
QUIT Z
+4 SET X=0
+5 FOR
SET X=$ORDER(^DPT(DFN,.06,X))
IF 'X
QUIT
Begin DoDot:1
+6 SET Y=$PIECE($GET(^DIC(10.2,X,0)),U,3)_U_$PIECE($GET(^DIC(10.2,X,0)),U)
+7 IF Y=U
QUIT
+8 SET Y=Y_"^CDCREC"
+9 SET Z=$SELECT(Z]"":(Z_"~"),1:"")_Y
End DoDot:1
+10 IF Z=""!(Z["0000")!(Z["9999")
SET Z="2186-5^NOT HISPANIC OR LATINO^CDCREC"
QUIT Z
+11 QUIT Z
+12 ;-----
TEST ;EP;CREATE & SEND TEST MESSAGES
+1 DO TEST^BYIMIMM5
+2 QUIT
IZV04 ;EP;IMMUNIZATION DATA EXCHANGE
+1 SET BHLDEST="D DEST^INHUSEN"
+2 SET INDEST("VXUV04")="HL IHS IZV04 IN"
+3 XECUTE BHLDEST
+4 QUIT
+5 ;-----
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 ;-----
LOC ;EP;TO CHECK LOC. OF ENCOUNTER VERSUS OUTSIDE LOCATION
+1 ;PATCH 2
+2 NEW BYIMUDA,BYIMVDA,BYIMLDA,BYIMLODA
+3 SET BYIMUDA=$ORDER(^VA(200,"B","USER,IMMUNIZATION INTERFACE",0))
+4 IF 'BYIMUDA
QUIT
+5 SET BYIMVDA=0
+6 FOR
SET BYIMVDA=$ORDER(^AUPNVIMM("AD",BYIMVDA))
IF 'BYIMVDA
QUIT
Begin DoDot:1
+7 SET X=$GET(^AUPNVSIT(BYIMVDA,0))
+8 IF $PIECE(X,U,23)'=BYIMUDA&($PIECE(X,U,27)'=BYIMUDA)
QUIT
+9 SET BYIMLDA=$PIECE($GET(^AUPNVSIT(BYIMVDA,0)),U,6)
+10 IF $PIECE($GET(^DIC(4,+BYIMLDA,0)),U)'="OTHER"
QUIT
+11 SET BYIMLODA=$PIECE($GET(^AUPNVSIT(BYIMVDA,21)),U)
+12 IF BYIMLODA=""
QUIT
+13 SET X=BYIMLODA
+14 XECUTE ^%ZOSF("UPPERCASE")
+15 SET BYIMLODA=Y
+16 IF BYIMLODA["OTHER"
QUIT
+17 SET BYIMLODA=$ORDER(^DIC(4,"B",BYIMLODA,0))
+18 IF 'BYIMLODA
QUIT
+19 SET DR=".06////"_BYIMLODA
+20 SET DIE="^AUPNVSIT("
+21 SET DA=BYIMVDA
+22 DO ^DIE
+23 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE "."
End DoDot:1
+24 QUIT
+25 ;-----
PROT(INDA) ;EP;TO DETERMINE PROTECTION FLAG
+1 IF 'INDA
QUIT ""
+2 NEW X
+3 SET X=$PIECE($GET(^BIP(+$GET(INDA),0)),U,24)
+4 IF $GET(BYIMVER)<2.5
SET X=$SELECT(X=1:"Y",X=0:"N",1:"")
+5 ;PATCH 7 CORRECT VERSION CHECK LOGIC
+6 ;I $G(BYIMVER)>2.5 S X=$S(X=1:"N",X=0:"Y",1:"")
+7 IF $GET(BYIMVER)>2.49
SET X=$SELECT(X=1:"N",X=0:"Y",1:"")
+8 QUIT X
+9 ;-----
PROTDT(INDA) ;EP;TO DETERMINE PROTECTION FLAG
+1 NEW X
+2 SET X=$PIECE($GET(^BIP(+$GET(INDA),0)),U,25)
+3 IF 'X
SET X=$PIECE($GET(^BIP(+$GET(INDA),0)),U,21)
+4 IF X'?7N
SET X=DT
+5 SET X=X+17000000
+6 QUIT X
+7 ;-----
ACTDT(INDA) ;EP;TO DETERMINE INACTIVATION DATE
+1 NEW X
+2 SET X=$PIECE($GET(^BIP(+$GET(INDA),0)),U,8)
+3 IF X'?7N
SET X=$PIECE($GET(^BIP(+$GET(INDA),0)),U,21)
+4 IF X'?7N
SET X=DT
+5 SET X=X+17000000
+6 QUIT X
+7 ;-----
PUB(INDA) ;EP;TO DETERMINE PUBLICITY FOR PATIENT
+1 IF 'INDA
QUIT ""
+2 NEW X
+3 SET X=$PIECE($GET(^BIP(+$GET(INDA),0)),U,99)
SET X=$SELECT(X=1:"N",X=0:"Y",1:"02")
+4 IF X="01"
SET X=X_CS_"NO REMINDER/RECALL"_CS_"HL70215"
+5 IF X="02"
SET X=X_CS_"REMINDER/RECALL - ANY METHOD"_CS_"HL70215"
+6 IF X="03"
SET X=X_CS_"REMINDER/RECALL - NO CALLS"_CS_"HL70215"
+7 IF X="04"
SET X=X_CS_"REMINDER ONLY - ANY METHOD"_CS_"HL70215"
+8 IF X="05"
SET X=X_CS_"REMINDER ONLY - NO CALLS"_CS_"HL70215"
+9 IF X="06"
SET X=X_CS_"RECALL ONLY - ANY METHOD"_CS_"HL70215"
+10 IF X="07"
SET X=X_CS_"RECALL ONLY - NO CALLS"_CS_"HL70215"
+11 IF X="08"
SET X=X_CS_"REMINDER/RECALL - TO PROVIDER"_CS_"HL70215"
+12 IF X="09"
SET X=X_CS_"REMINDER - TO PROVIDER"_CS_"HL70215"
+13 IF X="10"
SET X=X_CS_"ONLY REMINDER TO PROVIDER, NO RECALL"_CS_"HL70215"
+14 IF X="11"
SET X=X_CS_"RECALL TO PROVIDER"_CS_"HL70215"
+15 IF X="12"
SET X=X_CS_"ONLY RECALL TO PROVIDER, NO REMINDER"_CS_"HL70215"
+16 QUIT X
+17 ;-----
PUBDT(INDA) ;EP;TO DETERMINE PUBLICITY DATE
+1 NEW X
+2 SET X=$PIECE($GET(^BIP(+$GET(INDA),0)),U,21)
+3 IF X'?7N
SET X=DT
+4 SET X=X+17000000
+5 QUIT X
+6 ;-----
IVFS(INDA) ;EP;TO RETURN IMMUNIZATION SPECIFIC VFS CODE
+1 NEW X,Y,Z,ZD,VFC
+2 SET X=+$PIECE($GET(^AUPNVIMM(+INDA,0)),U,5)
+3 SET Y=$PIECE($GET(^AUTTIML(X,0)),U,13)
+4 ;S Z=$S(Y="v":"VXC1",Y="o":"VXC2",Y="i":"VXC3",1:"UNK")
+5 SET Z=$SELECT(Y="v":"VXC1",Y="o":"VXC2",Y="i":"VXC3",1:"VXC1")
+6 ;S ZD=$S(Y="v":"Federal funds",Y="o":"State funds",Y="i":"Tribal funds",1:"Unspecified")
+7 SET ZD=$SELECT(Y="v":"Federal funds",Y="o":"State funds",Y="i":"Tribal funds",1:"Federal funds")
+8 SET X=Z_CS_ZD_CS_"CDCPHINVS"
+9 QUIT X
+10 ;-----
HDR ;DISPLAY HEADER
+1 SET JJ=JJ+6
+2 WRITE @IOF
+3 WRITE !!,"File Status Report",?40,"Report Date: "
+4 WRITE $EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,1,3)+1700
+5 WRITE !!,?20,"IMP/EXP",?40,"Pat-",?48,"Imuni-",?56,"NO Pat",?64,"New",?72,"Imms"
+6 WRITE !,"File",?20,"Date",?32,"Type",?40,"ients",?48,"zations",?56,"Match",?64,"Imms",?72,"Added"
+7 WRITE !,"------------------",?20,"----------",?32,"------",?40,"------",?48,"------",?56,"------",?64,"------",?72,"------"
+8 QUIT
+9 ;-----
DIRECT ;EP;DIRECT FIND OF PATIENT
+1 KILL Y,MM
+2 NEW X,Z,DFN,NAMEX
+3 SET NAME=$PIECE(NAME,",")_","_$PIECE($PIECE(NAME,",",2)," ")
+4 SET NAME=$TRANSLATE(NAME,".","")
+5 SET (X,NAMEX)=$EXTRACT(NAME,1,$LENGTH(NAME)-1)
+6 FOR
SET X=$ORDER(^DPT("B",X))
IF X=""!(X'[NAMEX)
QUIT
Begin DoDot:1
+7 SET Y=0
+8 FOR
SET Y=$ORDER(^DPT("B",X,Y))
IF 'Y
QUIT
Begin DoDot:2
+9 SET Z=$GET(^DPT(Y,0))
+10 IF $PIECE(Z,U,3)=DOB
IF $PIECE(Z,U,2)=SEX
SET DFN=Y
QUIT
+11 IF $PIECE(Z,U,3)=DOB
IF $PIECE(Z,U,2)'=SEX
SET MM="SEX"
+12 IF $PIECE(Z,U,3)'=DOB
IF $PIECE(Z,U,2)=SEX
SET MM="DOB"
End DoDot:2
End DoDot:1
+13 IF $GET(DFN)
SET Y=DFN
QUIT
+14 SET Y=0
+15 IF HRN
FOR
SET Y=$ORDER(^AUPNPAT("D",HRN,Y))
IF 'Y
QUIT
Begin DoDot:1
+16 SET Z=$GET(^DPT(Y,0))
+17 IF $PIECE(Z,U,3)=DOB
IF $PIECE(Z,U,2)=SEX
SET DFN=Y
+18 IF $PIECE(Z,U,3)=DOB
IF $PIECE(Z,U,2)'=SEX
SET MM="SEX"
+19 IF $PIECE(Z,U,3)'=DOB
IF $PIECE(Z,U,2)=SEX
SET MM="DOB"
End DoDot:1
+20 IF $GET(DFN)
SET Y=DFN
+21 IF $GET(MM)=""
SET MM="NAME"
+22 QUIT
+23 ;-----
SEL ;EP;TO SELECT SPECIFIC PATIENTS TO RE-EXPORT
+1 KILL ^BYIMTMP($JOB,"BYIM EXP")
+2 NEW Y
+3 SET Y=$PIECE($GET(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,6)
+4 SET YEARS=$SELECT('Y:19,Y=1:65,1:99)
+5 SET CHILD=$SELECT('Y:"Children",1:"Patients")
+6 DO SPAT
+7 IF '$DATA(^BYIMTMP($JOB,"BYIM EXP"))
QUIT
+8 NEW BYIMALL
+9 SET BYIMALL=2
+10 KILL DIR
+11 SET DIR(0)="YO"
+12 SET DIR("A")="Proceed with export of selected patients"
+13 SET DIR("B")="NO"
+14 WRITE !!
+15 DO ^DIR
+16 KILL DIR
+17 IF 'Y
QUIT
+18 SET MSGCNT=BYIMJ
+19 SET BYIMTEST=BYIMJ
+20 SET XX=$PIECE($HOROLOG,",",2)
+21 NEW DDATE
+22 DO FN^BYIMIMM
+23 SET (DDATE,DDDATE)=$ORDER(^BYIMPARA($$DUZ^BYIMIMM(),"LAST EXPORT",9999999999),-1)
+24 DO DEX^BYIMIMM
+25 QUIT
+26 ;-----
SPAT ;SELECT PATIENTS
+1 NEW BYIMQUIT
+2 SET BYIMQUIT=""
+3 SET BYIMJ=0
+4 FOR
DO SPAT1
IF BYIMQUIT
QUIT
+5 KILL BYIMQUIT
+6 QUIT
+7 ;-----
SPAT1 ;SELECT EACH PATIENT
+1 WRITE @IOF
+2 WRITE !!?10,"Export selected patients"
+3 WRITE !!?10,"An export file will be created for selected patients:"
+4 WRITE !!
+5 NEW BYIMX
+6 SET X=0
+7 FOR
SET X=$ORDER(^BYIMTMP($JOB,"BYIM EXP",X))
IF 'X
QUIT
Begin DoDot:1
+8 SET Y=$PIECE($GET(^DPT(X,0)),U)
+9 IF Y=""
QUIT
+10 SET BYIMX(Y)=""
End DoDot:1
+11 SET J=0
+12 SET X=""
+13 FOR
SET X=$ORDER(BYIMX(X))
IF X=""
QUIT
SET J=J+1
WRITE !?10,J,?15,X
+14 WRITE !!
+15 KILL DIC
+16 SET DIC="^DPT("
+17 SET DIC(0)="AMEQZ"
+18 SET DIC("A")="Select patient to export: "
+19 SET DIC("S")="I $O(^AUPNVIMM(""AC"",+Y,0))"
+20 DO ^DIC
+21 KILL DIC,DR,DA,DIE
+22 IF Y<1
SET BYIMQUIT=1
QUIT
+23 NEW XX,X,Z,DOB,DFN,VIS,J
+24 SET DFN=+Y
+25 IF $DATA(^BYIMTMP($JOB,"BYIM EXP",DFN))
QUIT
+26 SET XX=$ORDER(^AUPNVIMM("AC",DFN,9999999999),-1)
+27 IF 'XX
QUIT
+28 SET X=$GET(^AUPNVIMM(XX,0))
+29 SET VIS=$PIECE(X,U,3)
+30 IF 'VIS
QUIT
+31 SET ^BYIMTMP($JOB,"BYIM EXP",DFN,VIS)=""
+32 SET BYIMJ=BYIMJ+1
+33 QUIT
+34 ;-----
