BGOVIMM ;IHS/BAO/TMD - IMMUNIZATION mgt ;24-Mar-2015 16:10;PLS
;;1.1;BGO COMPONENTS;**1,3,4,5,6,9,10,11,12,13,14**;Mar 20, 2007;Build 5
; Returns the version # of the Immunization package
VERSION(RET,DUMMY) ;
S RET=$$VER^BILOGO
Q
; Return the ICD9 code IEN for a vaccine
IMMICD(TYPE,VIEN,ACTV) ;EP
N X,ICD,ICDIEN,DATE
S ICD=$P($G(^AUTTIMM(TYPE,0)),U,14),ICDIEN=""
I ICD'="" D
.I $$AICD^BGOUTL2 D
..S ICDIEN=$P($$ICDDX^ICDEX(ICD,$$NOW^XLFDT,"","I"),U,1)
.E D
..S ICDIEN=$P($$ICDDX^ICDCODE(ICD,$$NOW^XLFDT),U,1)
I ICDIEN,$G(ACTV) D
.S DATE=$S($G(VIEN):+$G(^AUPNVSIT(VIEN,0)),1:"")
.S X=$$CHKICD^BGOVPOV(ICDIEN,DATE)
.S:X<0 ICDIEN=X
Q ICDIEN
; Return the CPT code IEN for a vaccine and visit
IMMCPT(TYPE,VIEN,ACTV) ;EP
Q $$IMMCPT^BGOVIMM2(.TYPE,.VIEN,.ACTV)
; Get the patient's immunization defaults and contraindications
; INP = Patient IEN ^ Immunization Type IEN
; Returned as:
; RET(0) = Default Lot # [1] ^ Default Volume [2] ^ Default VIS Date [3]
; RET(n) = Contraindication IEN [1] ^ Contraindication Text [2] ^ Date Noted [3]
LOADIMM(RET,INP) ;EP
N DFN,IMM,X,N,D,DFLTLOT,DFLTVOL,DFLTVISD,CNT
S RET(0)=$$ERR^BGOUTL(1008)
S DFN=+INP
Q:'DFN
S IMM=+$P(INP,U,2)
Q:'IMM
S X=$G(^AUTTIMM(IMM,0))
S DFLTLOT=$P(X,U,4)
S DFLTVOL=$P(X,U,18)
I $E(DFLTVOL,1,1)="." S DFLTVOL="0"_DFLTVOL
S DFLTVISD=$$FMTDATE^BGOUTL($P(X,U,13))
S RET(0)=DFLTLOT_U_DFLTVOL_U_DFLTVISD
S (X,CNT)=0
F S X=$O(^BIPC("AC",DFN,IMM,X)) Q:'X D
.S N=$P($G(^BIPC(X,0)),U,3),D=$P(^(0),U,4)
.Q:'N
.Q:$P($G(^BICONT(N,0)),U,2)
.S CNT=CNT+1,RET(CNT)=N_U_$P($G(^BICONT(N,0)),U)_U_D
Q
; Get immunization history
; INP = Patient IEN[1]^Record Types[2]
; RET returned as a list of records in one of the following formats:
; For immunizations:
; I^Imm Name[2]^Visit Date[3]^V File IEN[4]^Other Location[5]^Group[6]^Imm IEN[7]^Lot[8]^
; Reaction[9]^VIS Date[10]^Age[11]^Visit Date[12]^Provider IEN~Name[13]^Inj Site[14]^
; Volume[15]^Visit IEN[16]^Visit Category[17]^Full Name[18]^Location IEN~Name[19]^
; Visit Locked[20]^Event Date/Time[21]^Dose Override[22]^VPED IEN[23]^VFC eligibility[24]^Manufacturer[25]^Admin Notes[26]
; For forecast:
; F^Imm Name[2]^Status[3]
; For contraindications:
; C^Contra IEN[2]^Imm Name[3]^Reason[4]^Date[5]
; For refusals:
; R^Refusal IEN[2]^Type IEN[3]^Type Name[4]^Item IEN[5]^Item Name[6]^Provider IEN[7]^
; Provider Name[8]^Date[9]^Locked[10]^Reason[11]^Comment[12]
GET(RET,INP) ;EP
N BIRESULT,DFN,DLM,HX,ELE,CNT,VIEN,DOB,BIPDSS,VIMM,TYPE,P,A,I,J,K,X,V,VFC,ADMIN
N XREF,FNUM,OFF,BIPDSSA,OR,LOT,LOTIEN,MANUF
S RET=$$TMPGBL^BGOUTL
S DFN=+INP,INP=$P(INP,U,2)
Q:'DFN
S:INP="" INP="IFCR"
S BIPDSS=""
S DLM=$C(31,31),HX="",V="|",CNT=0
S XREF=$$VFPTXREF^BGOUTL2,FNUM=$$FNUM,OFF=$S($G(DUZ("AG"))="I":0,1:9999999)
D:INP["F" IMMFORC^BIRPC(.HX,DFN,"","","",.BIPDSS)
S P=$P(HX,DLM,2),V="|"
S:'$L(P) P=$P(HX,DLM)
I $L(P) F I=1:1:$L(P,U) D:$L($P(P,U,I)) ADD("F^"_$P(P,U,I))
S HX=""
D:INP["C" CONTRAS^BIRPC5(.HX,DFN)
S P=$P(HX,DLM,2)
S:'$L(P) P=$P(HX,DLM)
I $L(P) F I=1:1:$L(P,U) D:$L($P(P,U,I)) ADD("C^"_$P(P,U,I))
S HX="",P=1
;MSC/MGH - 07/08/09 - Branching for compatibility with Vista and RPMS
I DUZ("AG")="I" D
.;IHS/MSC/MGH patch 6 added field 77 VFC
.;IHS/MSC/MGH patch 10 field 69 aded
.;IHS/MSC/MGH patch 13 field 85 added
.F I=4,21,24,36,27,30,33,44,51,57,60,61,67,68,76,35,9,34,0,0,65,77,69,87 S P=P+1 S:I ELE(I)=P
.D:INP["I" IMMHX^BIRPC(.HX,DFN,.ELE,0)
.S P=$P(HX,DLM,2),V="|"
.I $L(P) D ADD("I^"_P) Q ; Error
.S HX=$P(HX,DLM)
.F I=1:1 S P=$P(HX,U,I) Q:P="" D
..Q:$P(P,V)'="I"
..S A="I",J=0,K=1
..F S J=$O(ELE(J)) Q:'J S K=K+1,$P(A,V,ELE(J))=$P(P,V,K)
..S VIMM=+$P(A,V,4),VIEN=$P(A,V,16),TYPE=$P(A,V,7),VFC=$P(A,V,23),OR=$P(A,V,22)
..S ADMIN=$P(A,V,25)
..S LOT=$P(A,V,8)
..I LOT'="" D
...S LOTIEN=$O(^AUTTIML("B",LOT,""))
...S MANUF=$$GET1^DIQ(9999999.41,LOTIEN,.02)
...I MANUF'="" S $P(A,V,26)=MANUF
..;IHS/MSC/MGH call added for INVALID DOSE
..S BIPDSSA=0
..I $$PDSS^BIUTL8($P(A,V,4),$P(A,V,24),BIPDSS) D
...S Z=$P(A,V,2),BIPDSSA=1
...S $P(A,V,2)=Z_"--INVALID SEE IMMSERVE--"
..I OR'="" D
...S Z=$P(A,V,2)
...S OR=$S(OR=1:"INVALID--BAD STORAGE",OR=2:"INVALID--DEFECTIVE",OR=3:"INVALID--EXPIRED",OR=4:"INVALID--ADMIN ERROR",OR=5:"FORCED VALID",1:"@")
...S $P(A,V,2)=Z_"-- "_OR
...;End patch 10 changes
..S:$P(A,V,10)="NO DATE" $P(A,V,10)=""
..S X=$P(A,V,14)
..S:$L(X) $P(A,V,14)=X_"~"_$$EXTERNAL^DILFD(9000010.11,.09,,X)
..D GI1(13,200),GI1(19,9999999.06)
..;IHS/MSC/MGH Patch 11 Add leading zero
..I $E($P(A,V,15),1,1)="." S $P(A,V,15)="0"_$P(A,V,15)
..S $P(A,V,20)=$$ISLOCKED^BEHOENCX(VIEN)
..S $P(A,V,21)=$P($G(^AUPNVIMM(VIMM,12)),U)
..S $P(A,V,23)=$$FNDPED(VIEN,$$IMMCPT(TYPE,VIEN))
..;S $P(A,V,24)=$S(VFC=0:"Unknown",VFC=1:"Not Eligible",VFC=2:"Medicaid",VFC=3:"Uninsured",VFC=4:"Am Indian/AK Native",VFC=5:"Federally Qualified",VFC=6:"State-specific Elig",VFC=7:"Local-specific Elig",1:"")
..;Next line changed for patch 13
..S $P(A,V,24)=$$GET1^DIQ(9002084.83,VFC,.02)
..D ADD(A)
E D
.N REC,LP,X,Y,Z,FNUM
.S FNUM=9000010.11,OFF=9999999
.S LP="" F S LP=$O(^AUPNVIMM("C",DFN,LP)) Q:'LP D
..S X=$G(^AUPNVIMM(LP,0))
..Q:$P(X,U,2)'=DFN
..S $P(X,U,8,99)=$P($G(^AUPNVIMM(LP,9999999)),U,8,99)
..S Y=$G(^AUTTIMM(+X,0))
..Q:'$L(Y)
..S VIEN=+$P(X,U,3)
..S Z=$G(^AUPNVSIT(VIEN,0))
..Q:'$L(Z)
..S REC="I"
..S REC=REC_U_$P(Y,U,2) ; Imm Short
..S REC=REC_U_$$FMTDATE^BGOUTL(+Z) ; Visit Date
..S REC=REC_U_LP ; V File IEN
..S REC=REC_U_$P($G(^AUPNVSIT(VIEN,21)),U) ; Other Loc
..S REC=REC_U_$$GET1^DIQ(FNUM,LP,.09) ; Group
..S REC=REC_U_+X ; Imm IEN
..S REC=REC_U_$$GET1^DIQ(9999999.41,+$P(X,U,5),.01) ; Lot
..S REC=REC_U_$$GET1^DIQ(FNUM,LP,.06) ; Reaction
..S REC=REC_U_$$ENTRY^CIAUDT($P(X,U,12)) ; VIS Date
..S DOB=$$GET1^DIQ(2,DFN,.03,"I")
..S REC=REC_U_$$GETAGE^BGOVSK(+Z,DOB) ; Age
..S REC=REC_U_$$ENTRY^CIAUDT(+Z,0) ; Visit Date
..S REC=REC_U_$$GI2($P($G(^AUPNVIMM(LP,12)),U,4),200) ; Provider
..S REC=REC_U_$P(X,U,9)_"~"_$$GET1^DIQ(FNUM,LP,.09+OFF) ; Inj Site
..S REC=REC_U_$P(X,U,11) ; Volume
..S REC=REC_U_VIEN ; Visit IEN
..S REC=REC_U_$P(Z,U,7) ; Visit Cat
..S REC=REC_U_$P(Y,U) ; Full Name
..S REC=REC_U_$$GI2($P(Z,U,6),9999999.06) ; Location
..S REC=REC_U_$$ISLOCKED^BEHOENCX(VIEN) ; Visit Loc
..D ADD(REC)
I INP["R" D
.N ARRAY,CNT2,Z,STR,SAVE,SAVE2,DATA
.S CNT2=0,ARRAY="DATA"
.D REFGET^BGOUTL2(.ARRAY,DFN,9999999.14,.CNT2)
.S Z=0 F S Z=$O(@ARRAY@(Z)) Q:Z="" D
..S STR=$G(@ARRAY@(Z))
..S SAVE=$P(STR,U,13),SAVE2=$P(STR,U,11)
..I SAVE'="" S $P(STR,U,11)=SAVE,$P(STR,U,13)=SAVE2
..D ADD(STR)
Q
GI1(PC,FN) ;EP
N X
S X=+$P(A,V,PC)
S:X $P(A,V,PC)=X_"~"_$$GET1^DIQ(FN,X,.01)
Q
GI2(PC,FN) ;EP
Q $S(PC:PC_"~"_$$GET1^DIQ(FN,PC,.01),1:"")
; Delete an immunization
; VIMM = V File IEN
; FLG = Delete flag where
; 0: V File and codes (default)
; 1: V File only
; 2: Codes only
DEL(RET,VIMM,FLG) ;EP
N VIEN,TYPE,CPT,ICD,INJS,DATE,DFN,PRV,VPED,X0,X12
S RET=""
S VIMM=+$G(VIMM),FLG=+$G(FLG)
S X0=$G(^AUPNVIMM(VIMM,0)),X12=$G(^(12))
I 'X0 S RET=$$ERR^BGOUTL(1080) Q
S TYPE=+X0,DFN=$P(X0,U,2),VIEN=$P(X0,U,3),INJS=$P(X0,U,9)
S DATE=+X12,PRV=$P(X12,U,4)
S:'DATE DATE=+$G(^AUPNVSIT(VIEN,0))
D:FLG'=2 BIDEL(.RET,VIMM,$$FNUM)
Q:RET!(FLG=1)
S CPT=$$IMMCPT(TYPE,VIEN),ICD=$$IMMICD(TYPE,VIEN),VPED=$$FNDPED(VIEN,CPT)
;IHS/MSC/MGH Patch 13 CPT codes no longer added or deleted
;S:CPT>0 RET=$$DELCPT(CPT,ICD,VIEN,DFN,PRV,INJS,DATE,VPED)
Q:RET
D:VPED DEL^BGOVPED(,VPED)
;IHS/MSC/MGG Patch 13 ICD code no longer added or deleted
;S:ICD>0 RET=$$DELICD(ICD,VIEN,DFN,PRV)
Q
; Immunization education topic IEN
IMMTOP() Q $O(^AUTTEDT("B","IM-INFORMATION",0))
; Find patient ed entry corresponding to immunization CPT code
FNDPED(VIEN,CPT) ;
N VPED,TOP,X,CPTIEN
Q:'CPT ""
S VPED=0,TOP=$$IMMTOP
;MSC/MGH HOTFIX 13
S CPTIEN=$$CODEN^ICPTCOD(CPT)
F S VPED=$O(^AUPNVPED("AD",VIEN,VPED)) Q:'VPED S X=$G(^AUPNVPED(VPED,0)) I +X=TOP,$P(X,U,9)=CPTIEN Q
Q VPED
; Call BI delete
BIDEL(RET,VFIEN,FNUM) ;EP
N GBL,DATA,VIEN
S GBL=$$ROOT^DILFD(FNUM,,1)
S DATA=$G(@GBL@(VFIEN,0)),VIEN=$P(DATA,U,3)
S RET=$$CHKVISIT^BGOUTL(VIEN)
Q:RET
D DELETE^BIRPC3(.RET,VFIEN,$S(FNUM=$$FNUM:"I",1:"S"))
S RET=$$IMMERR(RET)
D:'RET VFEVT^BGOUTL2(FNUM,VFIEN,2,DATA)
Q
; Delete ICD9 code
DELICD(ICD,VIEN,DFN,PRV) ;EP
N RET,VPOV,X0,X12
Q:"E"[$P($G(^AUPNVSIT(VIEN,0)),U,7)!'$G(ICD) ""
S VPOV=0
F S VPOV=$O(^AUPNVPOV("AD",VIEN,VPOV)) Q:'VPOV D Q:$D(RET)
.S X0=$G(^AUPNVPOV(VPOV,0)),X12=$G(^(12))
.Q:ICD'=+X0
.I $G(PRV),$P(X12,U,4)'=PRV Q
.D VFDEL^BGOUTL2(.RET,9000010.07,VPOV)
Q $G(RET)
; Delete CPT code(s)
DELCPT(CPT,ICD,VIEN,DFN,PRV,SITE,DATE,CNSL) ;EP
N RET
S RET=""
;Patch 9 IHS/MSC/MGH CPT codes no longer added or deleted
Q RET
Q:"E"[$P($G(^AUPNVSIT(VIEN,0)),U,7) ""
S:CPT CPT=$$ADJCPT(CPT,DFN,DATE,.CNSL)
S:CPT RET=$$DC1(CPT,VIEN,.PRV)
Q:RET RET
I 'RET D
.N C
.I SITE'="O",SITE'="IN" F C=90465,90466,90471,90472 S C(C)=""
.E F C=90467,90468,90473,90474 S C(C)=""
.S RET=$$DC1(.C,VIEN,.PRV,.ICD)
I 'RET D
.N C
.S C=$$SYRCPT(SITE)
.S:C RET=$$DC1(C,VIEN,.PRV)
Q RET
; Delete CPT in visit
DC1(CPTS,VIEN,PRV,ICD) ;
N C,X0,X12,VCPT,RET,QTY
S VCPT=0
S:$D(CPTS)=1 CPTS(CPTS)=""
F S VCPT=$O(^AUPNVCPT("AD",VIEN,VCPT)) Q:'VCPT D Q:$D(RET)
.S X0=$G(^AUPNVCPT(VCPT,0)),X12=$G(^(12)),C=$P(X0,U)
.Q:$G(PRV)'=$P(X12,U,4)
.Q:$G(ICD)'=$P(X0,U,5)
.Q:'$D(CPTS(C))
.S QTY=$P(X0,U,16)
.I QTY>1 D
..D SETQTY^BGOVCPT(.RET,VCPT_U_(QTY-1))
.E D VFDEL^BGOUTL2(.RET,9000010.18,VCPT)
Q $G(RET)
; Get syringe CPT
SYRCPT(SITE) ;
Q $S(SITE="O":"",SITE="IN":"",1:$O(^ICPT("B","A4206",0)))
; Get administration CPT
ADMINCPT(VIEN,CPT,SITE) ;
N C,X,Y,CPT2,CNT
S (X,Y,CNT)=0,CPT2=90471
F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:'X!Y D
.S C=$P($G(^AUPNVCPT(X,0)),U)
.S:(C=90471)!(C=90473)!(C=90465)!(C=90467) CPT2=90472
.S:C=CPT Y=1
Q:Y "" ; Already exists
S:SITE="O"!(SITE="IN") CPT2=$S(CPT2=90471:90473,1:90474)
Q CPT2
; Adjust CPT code for age
ADJCPT(CPT,DFN,DATE,CNSL) ;
Q $S('$G(CNSL,1):CPT,$$PTAGE^BGOUTL(DFN,DATE)'<8:CPT,CPT=90471:90465,CPT=90472:90466,CPT=90473:90467,CPT=90474:90468,1:CPT)
; Add an ICD9 code
ADDICD(ICDIEN,VIEN,DFN,PRV) ;EP
N X,Y,RET,APCDALVR,DLAYGO,ICD,ICDNAME
Q:$$GET^XPAR("ALL","BGO IMM STOP ADDING ICD CODES") 0
S (X,Y)=0
F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:'X!Y S Y=ICDIEN=$P($G(^AUPNVPOV(X,0)),U)
;IHS/MSC/MGH Patch 12
I $$AICD^BGOUTL2 S ICDNAME=$$ICDDX^ICDEX(+ICDIEN,$$NOW^XLFDT,"","I")
E S ICDNAME=$P($G(^ICD9(+ICDIEN,0)),U,3)
D:'Y SET^BGOVPOV(.RET,U_VIEN_U_"`"_ICDIEN_U_DFN_U_ICDNAME_"^^^^^^^^^^"_PRV)
Q $G(RET)
; Add/Edit immunization
; INP = Visit IEN [1] ^ Historical [2] ^ Patient IEN [3] ^ Imm IEN [4] ^ V File IEN [5] ^
; Provider IEN [6] ^ Location [7] ^ Other Location [8] ^ Imm Date [9] ^ Lot # [10] ^
; Reaction [11] ^ VIS Date [12] ^ Dose Override [13] ^ Inj Site [14] ^ Volume [15] ^
; Counselled [16] ^ VFC Eligibility [17] ^ admin comments [18]
SET(RET,INP) ;EP
N V,CPT,ICD,VFIEN,VOL,OVRD,VIEN,DFN,TYPE,LOT,RXN,PRV,VISD,CNSL
N EVNTDT,LOCIEN,OUTLOC,HIST,CAT,INJS,IMMNM,FNUM,VFNEW,ARG,OFF,VFC,VFCIEN
S RET="",FNUM=$$FNUM,V="|"
S OFF=$S($G(DUZ("AG"))="I":0,1:9999999)
S VIEN=+INP
S HIST=$P(INP,U,2)
I 'VIEN,'HIST S RET=$$ERR^BGOUTL(1002) Q
S DFN=+$P(INP,U,3)
S TYPE=+$P(INP,U,4)
S VFIEN=$P(INP,U,5)
S VFNEW='VFIEN
S PRV=$P(INP,U,6)
S LOCIEN=$P(INP,U,7)
S OUTLOC=$P(INP,U,8)
S EVNTDT=$$CVTDATE^BGOUTL($P(INP,U,9))
I 'DFN!'TYPE S RET=$$ERR^BGOUTL(1008) Q
S CAT=$P($G(^AUPNVSIT(VIEN,0)),U,7)
S:CAT="E" HIST=1
I HIST D Q:RET<0
.S PRV=""
.S RET=$$MAKEHIST^BGOUTL(DFN,EVNTDT,$S($L(OUTLOC):OUTLOC,1:LOCIEN),VIEN)
.S:RET>0 VIEN=RET,CAT="E",RET=""
S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
Q:RET
S LOT=$P(INP,U,10)
S RXN=$P(INP,U,11) ; Reaction
S VISD=$P(INP,U,12)
S OVRD=$P(INP,U,13) ; Dose override
S INJS=$$TOINTRNL^BGOUTL(FNUM,.09+OFF,$P(INP,U,14)) ; Immun Site
;IHS/MSC/MGH Patch 11 take the + off to save 0.5 mg
S VOL=$P(INP,U,15)
S CNSL=$P(INP,U,16) ; Patient/family counselled
S VFC=$P(INP,U,17) ;VFC elig for children
I VFC'="" D
.S VFCIEN=$O(^BIELIG("C",VFC,""))
S:'$L(CNSL) CNSL=$P($G(^VA(200,DUZ,"PS")),U)&($$PTAGE^BGOUTL(DFN,EVNTDT)<8)
S ADMIN=$P(INP,U,18)
I 'VFIEN D Q:RET
.S IMMNM=$$GET1^DIQ(9999999.14,TYPE,.01)
.D VFCHK^BGOUTL2(.RET,FNUM,TYPE,IMMNM,VIEN)
I VFIEN,'HIST D DEL(,VFIEN,2)
S ARG=$$BIARG("I",VIEN,VFIEN,TYPE,PRV)
S:LOT $P(ARG,V,5)=LOT
S:RXN $P(ARG,V,15)=RXN
S $P(ARG,V,16)=$G(VFCIEN)
S $P(ARG,V,17)=VISD
S $P(ARG,V,19)=OVRD
S $P(ARG,V,20)=INJS
S $P(ARG,V,21)=VOL
S $P(ARG,V,27)=ADMIN
I 'HIST D Q:RET
.;IHS/MSC/MGH Patch 13 stop adding ICD codes
.;S ICD=$$IMMICD(TYPE,VIEN,1),CPT=0
.;IHS/MSC/MGH patch 9 stop adding CPT codes
.;IHS/MSC/MGH this part put back to add CPT to education
.S CPT=$$IMMCPT(TYPE,VIEN,1)
.;MSC/MGH HOTFIX moved to P14
.S CPT=$$CODEN^ICPTCOD(CPT)
.;S:ICD<0 RET=ICD
.;S:CPT<0 RET=CPT
D BISET(.RET,ARG,FNUM,TYPE,VIEN,VFIEN,EVNTDT)
Q:HIST!(RET'>0)
I RET'<0,CNSL D
.N RET1,TOP
.S TOP=$$IMMTOP
.Q:'TOP
.D SET^BGOVPED(.RET1,U_TOP_U_DFN_U_VIEN_U_PRV_"^^^^"_CPT_"^^^^"_EVNTDT_"^^^^^1")
.S:RET1 RET=RET1
I RET'<0,$G(ICD) D
.N RET1
.;Remove adding ICD codes in Patch 13
.;S RET1=$$ADDICD(ICD,VIEN,DFN,PRV)
.S:RET1 RET=RET1
Q
; Set data using BI add/edit call
BISET(RET,ARG,FNUM,TYPE,VIEN,VFIEN,EVNTDT) ;EP
N VFNEW,FDA
S VFNEW='VFIEN
D ADDEDIT^BIRPC3(.RET,ARG)
S RET=$$IMMERR(.RET)
Q:RET
D VFFND^BGOUTL2(.VFIEN,FNUM,TYPE,VIEN)
S FDA=$NA(FDA(FNUM,VFIEN_","))
S @FDA@(1201)=$S(EVNTDT:EVNTDT,1:"")
;IHS/MSC/MGH new fields added patch 11
I VFNEW D
.S @FDA@(1216)="N"
.S @FDA@(1217)="`"_DUZ
S @FDA@(1218)="N"
S @FDA@(1219)="`"_DUZ
I FNUM=9000010.11 D
.;Patch 6 Updated to capture user last update
.S @FDA@(1214)="`"_DUZ
I $$UPDATE^BGOUTL(.FDA,"E@")
D VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
S RET=VFIEN
Q
; Format argument for BI add/edit call
BIARG(REC,VIEN,VFIEN,ITM,PRV) ;EP
N X,V,X0,X21
S V="|",X=REC,X0=$G(^AUPNVSIT(VIEN,0)),X21=$G(^(21))
S $P(X,V,2)=$P(X0,U,5)
S $P(X,V,3)=ITM
S $P(X,V,6)=$P(X0,U)
S $P(X,V,7)=$P(X0,U,6)
S $P(X,V,8)=$P(X21,U)
S $P(X,V,9)=$P(X0,U,7)
S $P(X,V,10)=VIEN
S:VFIEN $P(X,V,11)=VFIEN
S:PRV $P(X,V,18)=PRV
S $P(X,V,23)=DUZ(2)
Q X
; Format error message from immunization package
IMMERR(MSG) ;EP
N X
S X=$P($G(MSG),$C(31),3)
S:X[" #" X=$P(X," #")
Q $S($L(X):$$ERR^BGOUTL(1082,X),1:"")
; Add record to output
ADD(X) S CNT=CNT+1,@RET@(CNT)=$TR(X,"|",U)
Q
; Return V File #
FNUM() Q 9000010.11
BGOVIMM ;IHS/BAO/TMD - IMMUNIZATION mgt ;24-Mar-2015 16:10;PLS
+1 ;;1.1;BGO COMPONENTS;**1,3,4,5,6,9,10,11,12,13,14**;Mar 20, 2007;Build 5
+2 ; Returns the version # of the Immunization package
VERSION(RET,DUMMY) ;
+1 SET RET=$$VER^BILOGO
+2 QUIT
+3 ; Return the ICD9 code IEN for a vaccine
IMMICD(TYPE,VIEN,ACTV) ;EP
+1 NEW X,ICD,ICDIEN,DATE
+2 SET ICD=$PIECE($GET(^AUTTIMM(TYPE,0)),U,14)
SET ICDIEN=""
+3 IF ICD'=""
Begin DoDot:1
+4 IF $$AICD^BGOUTL2
Begin DoDot:2
+5 SET ICDIEN=$PIECE($$ICDDX^ICDEX(ICD,$$NOW^XLFDT,"","I"),U,1)
End DoDot:2
+6 IF '$TEST
Begin DoDot:2
+7 SET ICDIEN=$PIECE($$ICDDX^ICDCODE(ICD,$$NOW^XLFDT),U,1)
End DoDot:2
End DoDot:1
+8 IF ICDIEN
IF $GET(ACTV)
Begin DoDot:1
+9 SET DATE=$SELECT($GET(VIEN):+$GET(^AUPNVSIT(VIEN,0)),1:"")
+10 SET X=$$CHKICD^BGOVPOV(ICDIEN,DATE)
+11 IF X<0
SET ICDIEN=X
End DoDot:1
+12 QUIT ICDIEN
+13 ; Return the CPT code IEN for a vaccine and visit
IMMCPT(TYPE,VIEN,ACTV) ;EP
+1 QUIT $$IMMCPT^BGOVIMM2(.TYPE,.VIEN,.ACTV)
+2 ; Get the patient's immunization defaults and contraindications
+3 ; INP = Patient IEN ^ Immunization Type IEN
+4 ; Returned as:
+5 ; RET(0) = Default Lot # [1] ^ Default Volume [2] ^ Default VIS Date [3]
+6 ; RET(n) = Contraindication IEN [1] ^ Contraindication Text [2] ^ Date Noted [3]
LOADIMM(RET,INP) ;EP
+1 NEW DFN,IMM,X,N,D,DFLTLOT,DFLTVOL,DFLTVISD,CNT
+2 SET RET(0)=$$ERR^BGOUTL(1008)
+3 SET DFN=+INP
+4 IF 'DFN
QUIT
+5 SET IMM=+$PIECE(INP,U,2)
+6 IF 'IMM
QUIT
+7 SET X=$GET(^AUTTIMM(IMM,0))
+8 SET DFLTLOT=$PIECE(X,U,4)
+9 SET DFLTVOL=$PIECE(X,U,18)
+10 IF $EXTRACT(DFLTVOL,1,1)="."
SET DFLTVOL="0"_DFLTVOL
+11 SET DFLTVISD=$$FMTDATE^BGOUTL($PIECE(X,U,13))
+12 SET RET(0)=DFLTLOT_U_DFLTVOL_U_DFLTVISD
+13 SET (X,CNT)=0
+14 FOR
SET X=$ORDER(^BIPC("AC",DFN,IMM,X))
IF 'X
QUIT
Begin DoDot:1
+15 SET N=$PIECE($GET(^BIPC(X,0)),U,3)
SET D=$PIECE(^(0),U,4)
+16 IF 'N
QUIT
+17 IF $PIECE($GET(^BICONT(N,0)),U,2)
QUIT
+18 SET CNT=CNT+1
SET RET(CNT)=N_U_$PIECE($GET(^BICONT(N,0)),U)_U_D
End DoDot:1
+19 QUIT
+20 ; Get immunization history
+21 ; INP = Patient IEN[1]^Record Types[2]
+22 ; RET returned as a list of records in one of the following formats:
+23 ; For immunizations:
+24 ; I^Imm Name[2]^Visit Date[3]^V File IEN[4]^Other Location[5]^Group[6]^Imm IEN[7]^Lot[8]^
+25 ; Reaction[9]^VIS Date[10]^Age[11]^Visit Date[12]^Provider IEN~Name[13]^Inj Site[14]^
+26 ; Volume[15]^Visit IEN[16]^Visit Category[17]^Full Name[18]^Location IEN~Name[19]^
+27 ; Visit Locked[20]^Event Date/Time[21]^Dose Override[22]^VPED IEN[23]^VFC eligibility[24]^Manufacturer[25]^Admin Notes[26]
+28 ; For forecast:
+29 ; F^Imm Name[2]^Status[3]
+30 ; For contraindications:
+31 ; C^Contra IEN[2]^Imm Name[3]^Reason[4]^Date[5]
+32 ; For refusals:
+33 ; R^Refusal IEN[2]^Type IEN[3]^Type Name[4]^Item IEN[5]^Item Name[6]^Provider IEN[7]^
+34 ; Provider Name[8]^Date[9]^Locked[10]^Reason[11]^Comment[12]
GET(RET,INP) ;EP
+1 NEW BIRESULT,DFN,DLM,HX,ELE,CNT,VIEN,DOB,BIPDSS,VIMM,TYPE,P,A,I,J,K,X,V,VFC,ADMIN
+2 NEW XREF,FNUM,OFF,BIPDSSA,OR,LOT,LOTIEN,MANUF
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET DFN=+INP
SET INP=$PIECE(INP,U,2)
+5 IF 'DFN
QUIT
+6 IF INP=""
SET INP="IFCR"
+7 SET BIPDSS=""
+8 SET DLM=$CHAR(31,31)
SET HX=""
SET V="|"
SET CNT=0
+9 SET XREF=$$VFPTXREF^BGOUTL2
SET FNUM=$$FNUM
SET OFF=$SELECT($GET(DUZ("AG"))="I":0,1:9999999)
+10 IF INP["F"
DO IMMFORC^BIRPC(.HX,DFN,"","","",.BIPDSS)
+11 SET P=$PIECE(HX,DLM,2)
SET V="|"
+12 IF '$LENGTH(P)
SET P=$PIECE(HX,DLM)
+13 IF $LENGTH(P)
FOR I=1:1:$LENGTH(P,U)
IF $LENGTH($PIECE(P,U,I))
DO ADD("F^"_$PIECE(P,U,I))
+14 SET HX=""
+15 IF INP["C"
DO CONTRAS^BIRPC5(.HX,DFN)
+16 SET P=$PIECE(HX,DLM,2)
+17 IF '$LENGTH(P)
SET P=$PIECE(HX,DLM)
+18 IF $LENGTH(P)
FOR I=1:1:$LENGTH(P,U)
IF $LENGTH($PIECE(P,U,I))
DO ADD("C^"_$PIECE(P,U,I))
+19 SET HX=""
SET P=1
+20 ;MSC/MGH - 07/08/09 - Branching for compatibility with Vista and RPMS
+21 IF DUZ("AG")="I"
Begin DoDot:1
+22 ;IHS/MSC/MGH patch 6 added field 77 VFC
+23 ;IHS/MSC/MGH patch 10 field 69 aded
+24 ;IHS/MSC/MGH patch 13 field 85 added
+25 FOR I=4,21,24,36,27,30,33,44,51,57,60,61,67,68,76,35,9,34,0,0,65,77,69,87
SET P=P+1
IF I
SET ELE(I)=P
+26 IF INP["I"
DO IMMHX^BIRPC(.HX,DFN,.ELE,0)
+27 SET P=$PIECE(HX,DLM,2)
SET V="|"
+28 ; Error
IF $LENGTH(P)
DO ADD("I^"_P)
QUIT
+29 SET HX=$PIECE(HX,DLM)
+30 FOR I=1:1
SET P=$PIECE(HX,U,I)
IF P=""
QUIT
Begin DoDot:2
+31 IF $PIECE(P,V)'="I"
QUIT
+32 SET A="I"
SET J=0
SET K=1
+33 FOR
SET J=$ORDER(ELE(J))
IF 'J
QUIT
SET K=K+1
SET $PIECE(A,V,ELE(J))=$PIECE(P,V,K)
+34 SET VIMM=+$PIECE(A,V,4)
SET VIEN=$PIECE(A,V,16)
SET TYPE=$PIECE(A,V,7)
SET VFC=$PIECE(A,V,23)
SET OR=$PIECE(A,V,22)
+35 SET ADMIN=$PIECE(A,V,25)
+36 SET LOT=$PIECE(A,V,8)
+37 IF LOT'=""
Begin DoDot:3
+38 SET LOTIEN=$ORDER(^AUTTIML("B",LOT,""))
+39 SET MANUF=$$GET1^DIQ(9999999.41,LOTIEN,.02)
+40 IF MANUF'=""
SET $PIECE(A,V,26)=MANUF
End DoDot:3
+41 ;IHS/MSC/MGH call added for INVALID DOSE
+42 SET BIPDSSA=0
+43 IF $$PDSS^BIUTL8($PIECE(A,V,4),$PIECE(A,V,24),BIPDSS)
Begin DoDot:3
+44 SET Z=$PIECE(A,V,2)
SET BIPDSSA=1
+45 SET $PIECE(A,V,2)=Z_"--INVALID SEE IMMSERVE--"
End DoDot:3
+46 IF OR'=""
Begin DoDot:3
+47 SET Z=$PIECE(A,V,2)
+48 SET OR=$SELECT(OR=1:"INVALID--BAD STORAGE",OR=2:"INVALID--DEFECTIVE",OR=3:"INVALID--EXPIRED",OR=4:"INVALID--ADMIN ERROR",OR=5:"FORCED VALID",1:"@")
+49 SET $PIECE(A,V,2)=Z_"-- "_OR
+50 ;End patch 10 changes
End DoDot:3
+51 IF $PIECE(A,V,10)="NO DATE"
SET $PIECE(A,V,10)=""
+52 SET X=$PIECE(A,V,14)
+53 IF $LENGTH(X)
SET $PIECE(A,V,14)=X_"~"_$$EXTERNAL^DILFD(9000010.11,.09,,X)
+54 DO GI1(13,200)
DO GI1(19,9999999.06)
+55 ;IHS/MSC/MGH Patch 11 Add leading zero
+56 IF $EXTRACT($PIECE(A,V,15),1,1)="."
SET $PIECE(A,V,15)="0"_$PIECE(A,V,15)
+57 SET $PIECE(A,V,20)=$$ISLOCKED^BEHOENCX(VIEN)
+58 SET $PIECE(A,V,21)=$PIECE($GET(^AUPNVIMM(VIMM,12)),U)
+59 SET $PIECE(A,V,23)=$$FNDPED(VIEN,$$IMMCPT(TYPE,VIEN))
+60 ;S $P(A,V,24)=$S(VFC=0:"Unknown",VFC=1:"Not Eligible",VFC=2:"Medicaid",VFC=3:"Uninsured",VFC=4:"Am Indian/AK Native",VFC=5:"Federally Qualified",VFC=6:"State-specific Elig",VFC=7:"Local-specific Elig",1:"")
+61 ;Next line changed for patch 13
+62 SET $PIECE(A,V,24)=$$GET1^DIQ(9002084.83,VFC,.02)
+63 DO ADD(A)
End DoDot:2
End DoDot:1
+64 IF '$TEST
Begin DoDot:1
+65 NEW REC,LP,X,Y,Z,FNUM
+66 SET FNUM=9000010.11
SET OFF=9999999
+67 SET LP=""
FOR
SET LP=$ORDER(^AUPNVIMM("C",DFN,LP))
IF 'LP
QUIT
Begin DoDot:2
+68 SET X=$GET(^AUPNVIMM(LP,0))
+69 IF $PIECE(X,U,2)'=DFN
QUIT
+70 SET $PIECE(X,U,8,99)=$PIECE($GET(^AUPNVIMM(LP,9999999)),U,8,99)
+71 SET Y=$GET(^AUTTIMM(+X,0))
+72 IF '$LENGTH(Y)
QUIT
+73 SET VIEN=+$PIECE(X,U,3)
+74 SET Z=$GET(^AUPNVSIT(VIEN,0))
+75 IF '$LENGTH(Z)
QUIT
+76 SET REC="I"
+77 ; Imm Short
SET REC=REC_U_$PIECE(Y,U,2)
+78 ; Visit Date
SET REC=REC_U_$$FMTDATE^BGOUTL(+Z)
+79 ; V File IEN
SET REC=REC_U_LP
+80 ; Other Loc
SET REC=REC_U_$PIECE($GET(^AUPNVSIT(VIEN,21)),U)
+81 ; Group
SET REC=REC_U_$$GET1^DIQ(FNUM,LP,.09)
+82 ; Imm IEN
SET REC=REC_U_+X
+83 ; Lot
SET REC=REC_U_$$GET1^DIQ(9999999.41,+$PIECE(X,U,5),.01)
+84 ; Reaction
SET REC=REC_U_$$GET1^DIQ(FNUM,LP,.06)
+85 ; VIS Date
SET REC=REC_U_$$ENTRY^CIAUDT($PIECE(X,U,12))
+86 SET DOB=$$GET1^DIQ(2,DFN,.03,"I")
+87 ; Age
SET REC=REC_U_$$GETAGE^BGOVSK(+Z,DOB)
+88 ; Visit Date
SET REC=REC_U_$$ENTRY^CIAUDT(+Z,0)
+89 ; Provider
SET REC=REC_U_$$GI2($PIECE($GET(^AUPNVIMM(LP,12)),U,4),200)
+90 ; Inj Site
SET REC=REC_U_$PIECE(X,U,9)_"~"_$$GET1^DIQ(FNUM,LP,.09+OFF)
+91 ; Volume
SET REC=REC_U_$PIECE(X,U,11)
+92 ; Visit IEN
SET REC=REC_U_VIEN
+93 ; Visit Cat
SET REC=REC_U_$PIECE(Z,U,7)
+94 ; Full Name
SET REC=REC_U_$PIECE(Y,U)
+95 ; Location
SET REC=REC_U_$$GI2($PIECE(Z,U,6),9999999.06)
+96 ; Visit Loc
SET REC=REC_U_$$ISLOCKED^BEHOENCX(VIEN)
+97 DO ADD(REC)
End DoDot:2
End DoDot:1
+98 IF INP["R"
Begin DoDot:1
+99 NEW ARRAY,CNT2,Z,STR,SAVE,SAVE2,DATA
+100 SET CNT2=0
SET ARRAY="DATA"
+101 DO REFGET^BGOUTL2(.ARRAY,DFN,9999999.14,.CNT2)
+102 SET Z=0
FOR
SET Z=$ORDER(@ARRAY@(Z))
IF Z=""
QUIT
Begin DoDot:2
+103 SET STR=$GET(@ARRAY@(Z))
+104 SET SAVE=$PIECE(STR,U,13)
SET SAVE2=$PIECE(STR,U,11)
+105 IF SAVE'=""
SET $PIECE(STR,U,11)=SAVE
SET $PIECE(STR,U,13)=SAVE2
+106 DO ADD(STR)
End DoDot:2
End DoDot:1
+107 QUIT
GI1(PC,FN) ;EP
+1 NEW X
+2 SET X=+$PIECE(A,V,PC)
+3 IF X
SET $PIECE(A,V,PC)=X_"~"_$$GET1^DIQ(FN,X,.01)
+4 QUIT
GI2(PC,FN) ;EP
+1 QUIT $SELECT(PC:PC_"~"_$$GET1^DIQ(FN,PC,.01),1:"")
+2 ; Delete an immunization
+3 ; VIMM = V File IEN
+4 ; FLG = Delete flag where
+5 ; 0: V File and codes (default)
+6 ; 1: V File only
+7 ; 2: Codes only
DEL(RET,VIMM,FLG) ;EP
+1 NEW VIEN,TYPE,CPT,ICD,INJS,DATE,DFN,PRV,VPED,X0,X12
+2 SET RET=""
+3 SET VIMM=+$GET(VIMM)
SET FLG=+$GET(FLG)
+4 SET X0=$GET(^AUPNVIMM(VIMM,0))
SET X12=$GET(^(12))
+5 IF 'X0
SET RET=$$ERR^BGOUTL(1080)
QUIT
+6 SET TYPE=+X0
SET DFN=$PIECE(X0,U,2)
SET VIEN=$PIECE(X0,U,3)
SET INJS=$PIECE(X0,U,9)
+7 SET DATE=+X12
SET PRV=$PIECE(X12,U,4)
+8 IF 'DATE
SET DATE=+$GET(^AUPNVSIT(VIEN,0))
+9 IF FLG'=2
DO BIDEL(.RET,VIMM,$$FNUM)
+10 IF RET!(FLG=1)
QUIT
+11 SET CPT=$$IMMCPT(TYPE,VIEN)
SET ICD=$$IMMICD(TYPE,VIEN)
SET VPED=$$FNDPED(VIEN,CPT)
+12 ;IHS/MSC/MGH Patch 13 CPT codes no longer added or deleted
+13 ;S:CPT>0 RET=$$DELCPT(CPT,ICD,VIEN,DFN,PRV,INJS,DATE,VPED)
+14 IF RET
QUIT
+15 IF VPED
DO DEL^BGOVPED(,VPED)
+16 ;IHS/MSC/MGG Patch 13 ICD code no longer added or deleted
+17 ;S:ICD>0 RET=$$DELICD(ICD,VIEN,DFN,PRV)
+18 QUIT
+19 ; Immunization education topic IEN
IMMTOP() QUIT $ORDER(^AUTTEDT("B","IM-INFORMATION",0))
+1 ; Find patient ed entry corresponding to immunization CPT code
FNDPED(VIEN,CPT) ;
+1 NEW VPED,TOP,X,CPTIEN
+2 IF 'CPT
QUIT ""
+3 SET VPED=0
SET TOP=$$IMMTOP
+4 ;MSC/MGH HOTFIX 13
+5 SET CPTIEN=$$CODEN^ICPTCOD(CPT)
+6 FOR
SET VPED=$ORDER(^AUPNVPED("AD",VIEN,VPED))
IF 'VPED
QUIT
SET X=$GET(^AUPNVPED(VPED,0))
IF +X=TOP
IF $PIECE(X,U,9)=CPTIEN
QUIT
+7 QUIT VPED
+8 ; Call BI delete
BIDEL(RET,VFIEN,FNUM) ;EP
+1 NEW GBL,DATA,VIEN
+2 SET GBL=$$ROOT^DILFD(FNUM,,1)
+3 SET DATA=$GET(@GBL@(VFIEN,0))
SET VIEN=$PIECE(DATA,U,3)
+4 SET RET=$$CHKVISIT^BGOUTL(VIEN)
+5 IF RET
QUIT
+6 DO DELETE^BIRPC3(.RET,VFIEN,$SELECT(FNUM=$$FNUM:"I",1:"S"))
+7 SET RET=$$IMMERR(RET)
+8 IF 'RET
DO VFEVT^BGOUTL2(FNUM,VFIEN,2,DATA)
+9 QUIT
+10 ; Delete ICD9 code
DELICD(ICD,VIEN,DFN,PRV) ;EP
+1 NEW RET,VPOV,X0,X12
+2 IF "E"[$PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)!'$GET(ICD)
QUIT ""
+3 SET VPOV=0
+4 FOR
SET VPOV=$ORDER(^AUPNVPOV("AD",VIEN,VPOV))
IF 'VPOV
QUIT
Begin DoDot:1
+5 SET X0=$GET(^AUPNVPOV(VPOV,0))
SET X12=$GET(^(12))
+6 IF ICD'=+X0
QUIT
+7 IF $GET(PRV)
IF $PIECE(X12,U,4)'=PRV
QUIT
+8 DO VFDEL^BGOUTL2(.RET,9000010.07,VPOV)
End DoDot:1
IF $DATA(RET)
QUIT
+9 QUIT $GET(RET)
+10 ; Delete CPT code(s)
DELCPT(CPT,ICD,VIEN,DFN,PRV,SITE,DATE,CNSL) ;EP
+1 NEW RET
+2 SET RET=""
+3 ;Patch 9 IHS/MSC/MGH CPT codes no longer added or deleted
+4 QUIT RET
+5 IF "E"[$PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)
QUIT ""
+6 IF CPT
SET CPT=$$ADJCPT(CPT,DFN,DATE,.CNSL)
+7 IF CPT
SET RET=$$DC1(CPT,VIEN,.PRV)
+8 IF RET
QUIT RET
+9 IF 'RET
Begin DoDot:1
+10 NEW C
+11 IF SITE'="O"
IF SITE'="IN"
FOR C=90465,90466,90471,90472
SET C(C)=""
+12 IF '$TEST
FOR C=90467,90468,90473,90474
SET C(C)=""
+13 SET RET=$$DC1(.C,VIEN,.PRV,.ICD)
End DoDot:1
+14 IF 'RET
Begin DoDot:1
+15 NEW C
+16 SET C=$$SYRCPT(SITE)
+17 IF C
SET RET=$$DC1(C,VIEN,.PRV)
End DoDot:1
+18 QUIT RET
+19 ; Delete CPT in visit
DC1(CPTS,VIEN,PRV,ICD) ;
+1 NEW C,X0,X12,VCPT,RET,QTY
+2 SET VCPT=0
+3 IF $DATA(CPTS)=1
SET CPTS(CPTS)=""
+4 FOR
SET VCPT=$ORDER(^AUPNVCPT("AD",VIEN,VCPT))
IF 'VCPT
QUIT
Begin DoDot:1
+5 SET X0=$GET(^AUPNVCPT(VCPT,0))
SET X12=$GET(^(12))
SET C=$PIECE(X0,U)
+6 IF $GET(PRV)'=$PIECE(X12,U,4)
QUIT
+7 IF $GET(ICD)'=$PIECE(X0,U,5)
QUIT
+8 IF '$DATA(CPTS(C))
QUIT
+9 SET QTY=$PIECE(X0,U,16)
+10 IF QTY>1
Begin DoDot:2
+11 DO SETQTY^BGOVCPT(.RET,VCPT_U_(QTY-1))
End DoDot:2
+12 IF '$TEST
DO VFDEL^BGOUTL2(.RET,9000010.18,VCPT)
End DoDot:1
IF $DATA(RET)
QUIT
+13 QUIT $GET(RET)
+14 ; Get syringe CPT
SYRCPT(SITE) ;
+1 QUIT $SELECT(SITE="O":"",SITE="IN":"",1:$ORDER(^ICPT("B","A4206",0)))
+2 ; Get administration CPT
ADMINCPT(VIEN,CPT,SITE) ;
+1 NEW C,X,Y,CPT2,CNT
+2 SET (X,Y,CNT)=0
SET CPT2=90471
+3 FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF 'X!Y
QUIT
Begin DoDot:1
+4 SET C=$PIECE($GET(^AUPNVCPT(X,0)),U)
+5 IF (C=90471)!(C=90473)!(C=90465)!(C=90467)
SET CPT2=90472
+6 IF C=CPT
SET Y=1
End DoDot:1
+7 ; Already exists
IF Y
QUIT ""
+8 IF SITE="O"!(SITE="IN")
SET CPT2=$SELECT(CPT2=90471:90473,1:90474)
+9 QUIT CPT2
+10 ; Adjust CPT code for age
ADJCPT(CPT,DFN,DATE,CNSL) ;
+1 QUIT $SELECT('$GET(CNSL,1):CPT,$$PTAGE^BGOUTL(DFN,DATE)'<8:CPT,CPT=90471:90465,CPT=90472:90466,CPT=90473:90467,CPT=90474:90468,1:CPT)
+2 ; Add an ICD9 code
ADDICD(ICDIEN,VIEN,DFN,PRV) ;EP
+1 NEW X,Y,RET,APCDALVR,DLAYGO,ICD,ICDNAME
+2 IF $$GET^XPAR("ALL","BGO IMM STOP ADDING ICD CODES")
QUIT 0
+3 SET (X,Y)=0
+4 FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF 'X!Y
QUIT
SET Y=ICDIEN=$PIECE($GET(^AUPNVPOV(X,0)),U)
+5 ;IHS/MSC/MGH Patch 12
+6 IF $$AICD^BGOUTL2
SET ICDNAME=$$ICDDX^ICDEX(+ICDIEN,$$NOW^XLFDT,"","I")
+7 IF '$TEST
SET ICDNAME=$PIECE($GET(^ICD9(+ICDIEN,0)),U,3)
+8 IF 'Y
DO SET^BGOVPOV(.RET,U_VIEN_U_"`"_ICDIEN_U_DFN_U_ICDNAME_"^^^^^^^^^^"_PRV)
+9 QUIT $GET(RET)
+10 ; Add/Edit immunization
+11 ; INP = Visit IEN [1] ^ Historical [2] ^ Patient IEN [3] ^ Imm IEN [4] ^ V File IEN [5] ^
+12 ; Provider IEN [6] ^ Location [7] ^ Other Location [8] ^ Imm Date [9] ^ Lot # [10] ^
+13 ; Reaction [11] ^ VIS Date [12] ^ Dose Override [13] ^ Inj Site [14] ^ Volume [15] ^
+14 ; Counselled [16] ^ VFC Eligibility [17] ^ admin comments [18]
SET(RET,INP) ;EP
+1 NEW V,CPT,ICD,VFIEN,VOL,OVRD,VIEN,DFN,TYPE,LOT,RXN,PRV,VISD,CNSL
+2 NEW EVNTDT,LOCIEN,OUTLOC,HIST,CAT,INJS,IMMNM,FNUM,VFNEW,ARG,OFF,VFC,VFCIEN
+3 SET RET=""
SET FNUM=$$FNUM
SET V="|"
+4 SET OFF=$SELECT($GET(DUZ("AG"))="I":0,1:9999999)
+5 SET VIEN=+INP
+6 SET HIST=$PIECE(INP,U,2)
+7 IF 'VIEN
IF 'HIST
SET RET=$$ERR^BGOUTL(1002)
QUIT
+8 SET DFN=+$PIECE(INP,U,3)
+9 SET TYPE=+$PIECE(INP,U,4)
+10 SET VFIEN=$PIECE(INP,U,5)
+11 SET VFNEW='VFIEN
+12 SET PRV=$PIECE(INP,U,6)
+13 SET LOCIEN=$PIECE(INP,U,7)
+14 SET OUTLOC=$PIECE(INP,U,8)
+15 SET EVNTDT=$$CVTDATE^BGOUTL($PIECE(INP,U,9))
+16 IF 'DFN!'TYPE
SET RET=$$ERR^BGOUTL(1008)
QUIT
+17 SET CAT=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)
+18 IF CAT="E"
SET HIST=1
+19 IF HIST
Begin DoDot:1
+20 SET PRV=""
+21 SET RET=$$MAKEHIST^BGOUTL(DFN,EVNTDT,$SELECT($LENGTH(OUTLOC):OUTLOC,1:LOCIEN),VIEN)
+22 IF RET>0
SET VIEN=RET
SET CAT="E"
SET RET=""
End DoDot:1
IF RET<0
QUIT
+23 SET RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
+24 IF RET
QUIT
+25 SET LOT=$PIECE(INP,U,10)
+26 ; Reaction
SET RXN=$PIECE(INP,U,11)
+27 SET VISD=$PIECE(INP,U,12)
+28 ; Dose override
SET OVRD=$PIECE(INP,U,13)
+29 ; Immun Site
SET INJS=$$TOINTRNL^BGOUTL(FNUM,.09+OFF,$PIECE(INP,U,14))
+30 ;IHS/MSC/MGH Patch 11 take the + off to save 0.5 mg
+31 SET VOL=$PIECE(INP,U,15)
+32 ; Patient/family counselled
SET CNSL=$PIECE(INP,U,16)
+33 ;VFC elig for children
SET VFC=$PIECE(INP,U,17)
+34 IF VFC'=""
Begin DoDot:1
+35 SET VFCIEN=$ORDER(^BIELIG("C",VFC,""))
End DoDot:1
+36 IF '$LENGTH(CNSL)
SET CNSL=$PIECE($GET(^VA(200,DUZ,"PS")),U)&($$PTAGE^BGOUTL(DFN,EVNTDT)<8)
+37 SET ADMIN=$PIECE(INP,U,18)
+38 IF 'VFIEN
Begin DoDot:1
+39 SET IMMNM=$$GET1^DIQ(9999999.14,TYPE,.01)
+40 DO VFCHK^BGOUTL2(.RET,FNUM,TYPE,IMMNM,VIEN)
End DoDot:1
IF RET
QUIT
+41 IF VFIEN
IF 'HIST
DO DEL(,VFIEN,2)
+42 SET ARG=$$BIARG("I",VIEN,VFIEN,TYPE,PRV)
+43 IF LOT
SET $PIECE(ARG,V,5)=LOT
+44 IF RXN
SET $PIECE(ARG,V,15)=RXN
+45 SET $PIECE(ARG,V,16)=$GET(VFCIEN)
+46 SET $PIECE(ARG,V,17)=VISD
+47 SET $PIECE(ARG,V,19)=OVRD
+48 SET $PIECE(ARG,V,20)=INJS
+49 SET $PIECE(ARG,V,21)=VOL
+50 SET $PIECE(ARG,V,27)=ADMIN
+51 IF 'HIST
Begin DoDot:1
+52 ;IHS/MSC/MGH Patch 13 stop adding ICD codes
+53 ;S ICD=$$IMMICD(TYPE,VIEN,1),CPT=0
+54 ;IHS/MSC/MGH patch 9 stop adding CPT codes
+55 ;IHS/MSC/MGH this part put back to add CPT to education
+56 SET CPT=$$IMMCPT(TYPE,VIEN,1)
+57 ;MSC/MGH HOTFIX moved to P14
+58 SET CPT=$$CODEN^ICPTCOD(CPT)
+59 ;S:ICD<0 RET=ICD
+60 ;S:CPT<0 RET=CPT
End DoDot:1
IF RET
QUIT
+61 DO BISET(.RET,ARG,FNUM,TYPE,VIEN,VFIEN,EVNTDT)
+62 IF HIST!(RET'>0)
QUIT
+63 IF RET'<0
IF CNSL
Begin DoDot:1
+64 NEW RET1,TOP
+65 SET TOP=$$IMMTOP
+66 IF 'TOP
QUIT
+67 DO SET^BGOVPED(.RET1,U_TOP_U_DFN_U_VIEN_U_PRV_"^^^^"_CPT_"^^^^"_EVNTDT_"^^^^^1")
+68 IF RET1
SET RET=RET1
End DoDot:1
+69 IF RET'<0
IF $GET(ICD)
Begin DoDot:1
+70 NEW RET1
+71 ;Remove adding ICD codes in Patch 13
+72 ;S RET1=$$ADDICD(ICD,VIEN,DFN,PRV)
+73 IF RET1
SET RET=RET1
End DoDot:1
+74 QUIT
+75 ; Set data using BI add/edit call
BISET(RET,ARG,FNUM,TYPE,VIEN,VFIEN,EVNTDT) ;EP
+1 NEW VFNEW,FDA
+2 SET VFNEW='VFIEN
+3 DO ADDEDIT^BIRPC3(.RET,ARG)
+4 SET RET=$$IMMERR(.RET)
+5 IF RET
QUIT
+6 DO VFFND^BGOUTL2(.VFIEN,FNUM,TYPE,VIEN)
+7 SET FDA=$NAME(FDA(FNUM,VFIEN_","))
+8 SET @FDA@(1201)=$SELECT(EVNTDT:EVNTDT,1:"")
+9 ;IHS/MSC/MGH new fields added patch 11
+10 IF VFNEW
Begin DoDot:1
+11 SET @FDA@(1216)="N"
+12 SET @FDA@(1217)="`"_DUZ
End DoDot:1
+13 SET @FDA@(1218)="N"
+14 SET @FDA@(1219)="`"_DUZ
+15 IF FNUM=9000010.11
Begin DoDot:1
+16 ;Patch 6 Updated to capture user last update
+17 SET @FDA@(1214)="`"_DUZ
End DoDot:1
+18 IF $$UPDATE^BGOUTL(.FDA,"E@")
+19 DO VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
+20 SET RET=VFIEN
+21 QUIT
+22 ; Format argument for BI add/edit call
BIARG(REC,VIEN,VFIEN,ITM,PRV) ;EP
+1 NEW X,V,X0,X21
+2 SET V="|"
SET X=REC
SET X0=$GET(^AUPNVSIT(VIEN,0))
SET X21=$GET(^(21))
+3 SET $PIECE(X,V,2)=$PIECE(X0,U,5)
+4 SET $PIECE(X,V,3)=ITM
+5 SET $PIECE(X,V,6)=$PIECE(X0,U)
+6 SET $PIECE(X,V,7)=$PIECE(X0,U,6)
+7 SET $PIECE(X,V,8)=$PIECE(X21,U)
+8 SET $PIECE(X,V,9)=$PIECE(X0,U,7)
+9 SET $PIECE(X,V,10)=VIEN
+10 IF VFIEN
SET $PIECE(X,V,11)=VFIEN
+11 IF PRV
SET $PIECE(X,V,18)=PRV
+12 SET $PIECE(X,V,23)=DUZ(2)
+13 QUIT X
+14 ; Format error message from immunization package
IMMERR(MSG) ;EP
+1 NEW X
+2 SET X=$PIECE($GET(MSG),$CHAR(31),3)
+3 IF X[" #"
SET X=$PIECE(X," #")
+4 QUIT $SELECT($LENGTH(X):$$ERR^BGOUTL(1082,X),1:"")
+5 ; Add record to output
ADD(X) SET CNT=CNT+1
SET @RET@(CNT)=$TRANSLATE(X,"|",U)
+1 QUIT
+2 ; Return V File #
FNUM() QUIT 9000010.11
