BGOVIMM2 ;IHS/BAO/TMD BGO - IMMUNIZATION mgt;20-Jan-2015 11:20;PLS
;;1.1;BGO COMPONENTS;**1,3,4,6,10,11,12,13,14**;Mar 20, 2007;Build 16
;---------------------------------------------
; Get case data
GETCASE(RET,DFN) ;EP
K RET
I '$D(^BIP(DFN,0)) S RET(0)=$$ERR^BGOUTL(1083)
E D GETS^DIQ(9002084,DFN,".1;.09;.13;.08;.16;.12;.15;.11","IE","RET")
Q
; Add/edit patient immunization registry entry
; INP = Patient IEN [1] ^ Case Manager IEN [2] ^ Parent [3] ^ Other Info [4] ^ Activate Flag [5] ^
; Inactive Date [6] ^ Inactive Reason [7] ^ Tx Location [8] ^ Forecast Inf/Pneu [9] ^
; Mother HBSAg Status [10]
SETREG(RET,INP) ;EP
N DFNX,CM,PARENT,OTH,ACTIVATE,INACT,REAS,MOV,FLU,HBSAG,FDA
S RET=""
S DFNX=+$G(INP)
I '$D(^DPT(DFNX,0)) S RET=$$ERR^BGOUTL(1001) Q
S CM=$P(INP,U,2)
S PARENT=$P(INP,U,3)
S OTH=$P(INP,U,4)
S ACTIVATE=$P(INP,U,5)
S INACT=$P(INP,U,6)
S REAS=$P(INP,U,7)
S MOV=$P(INP,U,8)
S FLU=$P(INP,U,9)
S HBSAG=$P(INP,U,10)
D:'$D(^BIP(DFNX)) ADDPAT^BIPATE(DFNX,DUZ(2),.RET)
S RET=$$IMMERR^BGOVIMM(.RET)
Q:RET
S FDA=$NA(FDA(9002084,DFNX_","))
I $L(ACTIVATE),$P(^BIP(DFNX,0),U,8) S (INACT,REAS,MOV)="@"
S:CM @FDA@(.1)="`"_CM
S @FDA@(.09)=PARENT
S @FDA@(.13)=OTH
S @FDA@(.08)=INACT
S @FDA@(.16)=REAS
S @FDA@(.12)=MOV
S @FDA@(.15)=FLU
S @FDA@(.11)=HBSAG
S RET=$$UPDATE^BGOUTL(.FDA,"E")
Q
; Get Primary Provider for VIMM IEN
PRIPRV(RET,VIMMIEN) ;EP
S RET=$$PRIPRV^BGOUTL($P($G(^AUPNVIMM(+VIMMIEN,0)),U,3))
Q
; Retrieve lot #'s associated with a vaccine
; IMM = Immunization type IEN
; Returned as a list of records in the format:
; Lot IEN ^ Name ^ Manufacturer ^ Exp Date
LOT(RET,IMM) ;EP
N CNT,FLG,LOT
S RET=$$TMPGBL^BGOUTL
S CNT=0,IMM=+$G(IMM),FLG=IMM
F D:IMM Q:FLG S IMM=$O(^AUTTIML("C",IMM)) Q:'IMM
.S LOT=0
.F S LOT=$O(^AUTTIML("C",IMM,LOT)) Q:'LOT D
..N X,NAME,MANUFAC,EXPDT
..S X=$G(^AUTTIML(LOT,0))
..Q:'$L(X)
..Q:$P(X,U,3)=1
..;IHS/MSC/MGH P14 Facility specific lot
..Q:(($P(X,U,14))&($P(X,U,14)'=$G(DUZ(2)))) ""
..S NAME=$P(X,U)
..S MANUFAC=$P(X,U,2)
..S:MANUFAC MANUFAC=$P($G(^AUTTIMAN(MANUFAC,0)),U)
..S EXPDT=$$FMTDATE^BGOUTL($P(X,U,9))
..S CNT=CNT+1,@RET@(CNT)=LOT_U_NAME_U_MANUFAC_U_EXPDT
Q
; Add a contraindication
; INP = Patient IEN [1] ^ Vaccine IEN [2] ^ Reason IEN [3] ^ Visit Date [4]
SETCONT(RET,INP) ;EP
N DATE,REFDT,DFN,VACP,RSN,FDA,NEW,IEN,IENX,X,CT
S CT=""
S DFN=+INP
I '$D(^DPT(DFN,0)) S RET=$$ERR^BGOUTL(1001) Q
S VACP=+$P(INP,U,2)
I '$D(^AUTTIMM(VACP,0)) S RET=$$ERR^BGOUTL(1084) Q
S RSN=+$P(INP,U,3)
S DATE=$P(INP,U,4)
S IEN=0
F S IEN=$O(^BIPC("B",DFN,IEN)) Q:'IEN D Q:$D(X)
.S X=$G(^BIPC(IEN,0))
.I +X=DFN,$P(X,U,2)=VACP,$P(X,U,3)=RSN Q
.K X
S NEW='IEN
S FDA=$NA(FDA(9002084.11,$S(NEW:"+1,",1:IEN_",")))
S @FDA@(.01)="`"_DFN
S @FDA@(.02)="`"_VACP
S @FDA@(.03)="`"_RSN
;IHS/MSC/MGH Patch 10 save date for refusal file
S DATE=$S(DATE:DATE,1:DT)
S @FDA@(.04)=DATE
S RET=$$UPDATE^BGOUTL(.FDA,"E",.IENX)
Q:RET
S:NEW IEN=$G(IENX(1))
;IHS/MSC/MGH add concept CT for refusal contraindication only
I $$UP^XLFSTR($P($G(^BICONT(RSN,0)),U))["REFUSAL" D
.S CT=443390004
.S RET=$$REFSET2^BGOUTL2(DFN,DATE,VACP,"IMMUNIZATION","R","","","",CT)
S:'RET RET=IEN
D:RET>0 BRDCAST^CIANBEVT("CONTRAINDICATION."_DFN_".IMMUNIZATION",IEN_U_$G(CIA("UID"))_U_'NEW)
Q
; Delete a contraindication
DELCONT(RET,IEN) ;EP
N DFN
S DFN=+$G(^BIPC(IEN,0))
Q:'DFN
;S RET=$$DELETE^BGOUTL("^BIPC(",IEN)
D DELCONT^BIRPC4(.RET,IEN)
D:'RET BRDCAST^CIANBEVT("CONTRAINDICATION."_DFN_".IMMUNIZATION",IEN_U_$G(CIA("UID"))_U_2)
Q
; Get contraindication reasons
; Returns a list of records in the format:
; IEN ^ Name
GETCONT(RET,DUMMY) ;EP
N CNT,X,Y
S RET=$$TMPGBL^BGOUTL
S (X,CNT)=0
F S X=$O(^BICONT(X)) Q:'X D
.S Y=$P($G(^BICONT(X,0)),U)
.S:$L(Y) CNT=CNT+1,@RET@(CNT)=X_U_Y
Q
; Return immunization profile
PROFILE(RET,DFN) ;EP
D IMMPROF^BIRPC(.RET,+DFN,"","")
S:$A($G(@RET@(1)))=31 @RET@(1)=$$IMMERR^BGOVIMM(@RET@(1))
Q
; Return fully resolved immunization letter
; INP = Patient IEN [1] ^ Letter IEN [2] ^ Text of Date/Location Line [3] ^ Forecast Date [4]
PRINT(RET,INP) ;EP
N BIDFN,BIDLOC,BIFDT,BIPCS,BILET,S,N
S RET=$NA(^UTILITY($J,"W"))
K @RET
S BIDFN=+INP
S BILET=$P(INP,U,2)
S BIDLOC=$P(INP,U,3)
S BIFDT=$P(INP,U,4)
S S=$S($D(^BISITE(DUZ(2),0)):DUZ(2),1:+^AUTTSITE(1,0))
S BILET=$S(BILET=1:$P($G(^BISITE(S,0)),U,4),1:$P($G(^BISITE(S,0)),U,13))
I 'BILET S @RET@(1,0)="ERROR: Missing letter template" Q
D BUILD^BILETPR1(BIDFN,BILET,BIDLOC,BIFDT)
I '$D(^TMP("BILET",$J)) S @RET@(1,0)="ERROR: Blank letter template" Q
; Resolve embedded functions
S N=0
F S N=$O(^TMP("BILET",$J,N)) Q:'N D
.N X,DIWL,DIWR,DIWF
.S X=^TMP("BILET",$J,N,0),DIWL=1,DIWR=80,DIWF="N"
.D ^DIWP
K ^TMP("BILET",$J)
S ^UTILITY($J,"W",1)=""
Q
;Determine patient's age, if the site is an IHS site,and the default value for the VFC
;INP=DFN of patient
;RET= [1] IHS (Y/N)^ [2] Age ^ [3] Default
GETVFC(RET,INP) ;EP call to get the VFC default for a patient
N IHS,AGE,DEFAULT,DFN
K RET
S IHS="N",AGE="",DEFAULT=""
S DFN=$P(INP,U,1)
I DUZ("AG")="I" D
.;IHS/MSC/MGH P11 no longer age dependent
.S IHS="Y"
.S AGE=$$PTAGE^BGOUTL(DFN)
.;I AGE<19 D
.S DEFAULT=$$BENTYP^BIUTL11(DFN)
.I DEFAULT=1 S DEFAULT="Am Indian/AK Native"
S RET=IHS_U_AGE_U_DEFAULT
Q
; Add CPT code(s)
ADDCPT(CPT,ICD,VIEN,DFN,PRV,SITE,DATE,CNSL) ;EP
;IHS/MSC/MGH Patch 9 CPT codes no longer added or deleted
Q 0
N RET,CPT2,CPT3
Q:$$GET^XPAR("ALL","BGO IMM STOP ADDING CPT CODES") 0
S:'$G(DATE) DATE=+$G(^AUPNVSIT(VIEN,0))
S CPT2=$$ADMINCPT^BGOVIMM(VIEN,CPT,SITE),CPT3=$$SYRCPT^BGOVIMM(SITE),RET=0
Q:'CPT2 RET ; Already exists
S CPT=$$ADJCPT^BGOVIMM(CPT,DFN,DATE,.CNSL),CPT2=$$ADJCPT^BGOVIMM(CPT2,DFN,DATE,.CNSL)
S RET=$$ADDCPT^BGOVCPT(CPT,,VIEN,DFN,PRV)
S:RET'<0 RET=$$ADDCPT^BGOVCPT(CPT2,.ICD,VIEN,DFN,PRV)
I 'RET,CPT3 S RET=$$ADDCPT^BGOVCPT(CPT3,,VIEN,DFN,PRV)
Q RET
; Return the CPT code IEN for a vaccine and visit
IMMCPT(TYPE,VIEN,ACTV) ;EP
N X,CVX,CPT,AGE,DFN,DATE
Q:'VIEN $$ERR^BGOUTL(1002)
S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5),DATE=+$G(^(0))
Q:'DFN!'DATE $$ERR^BGOUTL(1003)
S AGE=$$PTAGE^BGOUTL(DFN,DATE)
S X=$G(^AUTTIMM(TYPE,0))
S CVX=$P(X,U,3)
S CPT=$P(X,U,11)
I CVX=15 S CPT=$S(AGE>2:90658,1:90657) ;ihs=90757
E I CVX=43 S CPT=$S(AGE>18:90746,1:90743) ;ihs=90743
E I CVX=111 S CPT=90660 ;ihs=none
I CPT,$G(ACTV) D
.;IHS/MSC/MGH HOTFIX P13
.S X=$$CHKCPT^BGOVCPT(CPT,DATE,1)
.S:X<0 CPT=X
Q CPT
;DKA Added DFN to satisfy RPC call from EHR component
GETELIG(RET,DFN) ;Return active eligibility codes
N ACT,CNT,IEN,NODE
S RET=$$TMPGBL^BGOUTL
S CNT=0
S ACT="" F S ACT=$O(^BIELIG("AC",0,ACT)) Q:ACT="" D
.S IEN=0 F S IEN=$O(^BIELIG("AC",0,ACT,IEN)) Q:'+IEN D
..S CNT=CNT+1
..S NODE=$G(^BIELIG(IEN,0))
..S @RET@(CNT)=IEN_U_$P(NODE,U,1)_U_$P(NODE,U,2)_U_$P(NODE,U,4)
Q
BGOVIMM2 ;IHS/BAO/TMD BGO - IMMUNIZATION mgt;20-Jan-2015 11:20;PLS
+1 ;;1.1;BGO COMPONENTS;**1,3,4,6,10,11,12,13,14**;Mar 20, 2007;Build 16
+2 ;---------------------------------------------
+3 ; Get case data
GETCASE(RET,DFN) ;EP
+1 KILL RET
+2 IF '$DATA(^BIP(DFN,0))
SET RET(0)=$$ERR^BGOUTL(1083)
+3 IF '$TEST
DO GETS^DIQ(9002084,DFN,".1;.09;.13;.08;.16;.12;.15;.11","IE","RET")
+4 QUIT
+5 ; Add/edit patient immunization registry entry
+6 ; INP = Patient IEN [1] ^ Case Manager IEN [2] ^ Parent [3] ^ Other Info [4] ^ Activate Flag [5] ^
+7 ; Inactive Date [6] ^ Inactive Reason [7] ^ Tx Location [8] ^ Forecast Inf/Pneu [9] ^
+8 ; Mother HBSAg Status [10]
SETREG(RET,INP) ;EP
+1 NEW DFNX,CM,PARENT,OTH,ACTIVATE,INACT,REAS,MOV,FLU,HBSAG,FDA
+2 SET RET=""
+3 SET DFNX=+$GET(INP)
+4 IF '$DATA(^DPT(DFNX,0))
SET RET=$$ERR^BGOUTL(1001)
QUIT
+5 SET CM=$PIECE(INP,U,2)
+6 SET PARENT=$PIECE(INP,U,3)
+7 SET OTH=$PIECE(INP,U,4)
+8 SET ACTIVATE=$PIECE(INP,U,5)
+9 SET INACT=$PIECE(INP,U,6)
+10 SET REAS=$PIECE(INP,U,7)
+11 SET MOV=$PIECE(INP,U,8)
+12 SET FLU=$PIECE(INP,U,9)
+13 SET HBSAG=$PIECE(INP,U,10)
+14 IF '$DATA(^BIP(DFNX))
DO ADDPAT^BIPATE(DFNX,DUZ(2),.RET)
+15 SET RET=$$IMMERR^BGOVIMM(.RET)
+16 IF RET
QUIT
+17 SET FDA=$NAME(FDA(9002084,DFNX_","))
+18 IF $LENGTH(ACTIVATE)
IF $PIECE(^BIP(DFNX,0),U,8)
SET (INACT,REAS,MOV)="@"
+19 IF CM
SET @FDA@(.1)="`"_CM
+20 SET @FDA@(.09)=PARENT
+21 SET @FDA@(.13)=OTH
+22 SET @FDA@(.08)=INACT
+23 SET @FDA@(.16)=REAS
+24 SET @FDA@(.12)=MOV
+25 SET @FDA@(.15)=FLU
+26 SET @FDA@(.11)=HBSAG
+27 SET RET=$$UPDATE^BGOUTL(.FDA,"E")
+28 QUIT
+29 ; Get Primary Provider for VIMM IEN
PRIPRV(RET,VIMMIEN) ;EP
+1 SET RET=$$PRIPRV^BGOUTL($PIECE($GET(^AUPNVIMM(+VIMMIEN,0)),U,3))
+2 QUIT
+3 ; Retrieve lot #'s associated with a vaccine
+4 ; IMM = Immunization type IEN
+5 ; Returned as a list of records in the format:
+6 ; Lot IEN ^ Name ^ Manufacturer ^ Exp Date
LOT(RET,IMM) ;EP
+1 NEW CNT,FLG,LOT
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET CNT=0
SET IMM=+$GET(IMM)
SET FLG=IMM
+4 FOR
IF IMM
Begin DoDot:1
+5 SET LOT=0
+6 FOR
SET LOT=$ORDER(^AUTTIML("C",IMM,LOT))
IF 'LOT
QUIT
Begin DoDot:2
+7 NEW X,NAME,MANUFAC,EXPDT
+8 SET X=$GET(^AUTTIML(LOT,0))
+9 IF '$LENGTH(X)
QUIT
+10 IF $PIECE(X,U,3)=1
QUIT
+11 ;IHS/MSC/MGH P14 Facility specific lot
+12 IF (($PIECE(X,U,14))&($PIECE(X,U,14)'=$GET(DUZ(2))))
QUIT ""
+13 SET NAME=$PIECE(X,U)
+14 SET MANUFAC=$PIECE(X,U,2)
+15 IF MANUFAC
SET MANUFAC=$PIECE($GET(^AUTTIMAN(MANUFAC,0)),U)
+16 SET EXPDT=$$FMTDATE^BGOUTL($PIECE(X,U,9))
+17 SET CNT=CNT+1
SET @RET@(CNT)=LOT_U_NAME_U_MANUFAC_U_EXPDT
End DoDot:2
End DoDot:1
IF FLG
QUIT
SET IMM=$ORDER(^AUTTIML("C",IMM))
IF 'IMM
QUIT
+18 QUIT
+19 ; Add a contraindication
+20 ; INP = Patient IEN [1] ^ Vaccine IEN [2] ^ Reason IEN [3] ^ Visit Date [4]
SETCONT(RET,INP) ;EP
+1 NEW DATE,REFDT,DFN,VACP,RSN,FDA,NEW,IEN,IENX,X,CT
+2 SET CT=""
+3 SET DFN=+INP
+4 IF '$DATA(^DPT(DFN,0))
SET RET=$$ERR^BGOUTL(1001)
QUIT
+5 SET VACP=+$PIECE(INP,U,2)
+6 IF '$DATA(^AUTTIMM(VACP,0))
SET RET=$$ERR^BGOUTL(1084)
QUIT
+7 SET RSN=+$PIECE(INP,U,3)
+8 SET DATE=$PIECE(INP,U,4)
+9 SET IEN=0
+10 FOR
SET IEN=$ORDER(^BIPC("B",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+11 SET X=$GET(^BIPC(IEN,0))
+12 IF +X=DFN
IF $PIECE(X,U,2)=VACP
IF $PIECE(X,U,3)=RSN
QUIT
+13 KILL X
End DoDot:1
IF $DATA(X)
QUIT
+14 SET NEW='IEN
+15 SET FDA=$NAME(FDA(9002084.11,$SELECT(NEW:"+1,",1:IEN_",")))
+16 SET @FDA@(.01)="`"_DFN
+17 SET @FDA@(.02)="`"_VACP
+18 SET @FDA@(.03)="`"_RSN
+19 ;IHS/MSC/MGH Patch 10 save date for refusal file
+20 SET DATE=$SELECT(DATE:DATE,1:DT)
+21 SET @FDA@(.04)=DATE
+22 SET RET=$$UPDATE^BGOUTL(.FDA,"E",.IENX)
+23 IF RET
QUIT
+24 IF NEW
SET IEN=$GET(IENX(1))
+25 ;IHS/MSC/MGH add concept CT for refusal contraindication only
+26 IF $$UP^XLFSTR($PIECE($GET(^BICONT(RSN,0)),U))["REFUSAL"
Begin DoDot:1
+27 SET CT=443390004
+28 SET RET=$$REFSET2^BGOUTL2(DFN,DATE,VACP,"IMMUNIZATION","R","","","",CT)
End DoDot:1
+29 IF 'RET
SET RET=IEN
+30 IF RET>0
DO BRDCAST^CIANBEVT("CONTRAINDICATION."_DFN_".IMMUNIZATION",IEN_U_$GET(CIA("UID"))_U_'NEW)
+31 QUIT
+32 ; Delete a contraindication
DELCONT(RET,IEN) ;EP
+1 NEW DFN
+2 SET DFN=+$GET(^BIPC(IEN,0))
+3 IF 'DFN
QUIT
+4 ;S RET=$$DELETE^BGOUTL("^BIPC(",IEN)
+5 DO DELCONT^BIRPC4(.RET,IEN)
+6 IF 'RET
DO BRDCAST^CIANBEVT("CONTRAINDICATION."_DFN_".IMMUNIZATION",IEN_U_$GET(CIA("UID"))_U_2)
+7 QUIT
+8 ; Get contraindication reasons
+9 ; Returns a list of records in the format:
+10 ; IEN ^ Name
GETCONT(RET,DUMMY) ;EP
+1 NEW CNT,X,Y
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET (X,CNT)=0
+4 FOR
SET X=$ORDER(^BICONT(X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=$PIECE($GET(^BICONT(X,0)),U)
+6 IF $LENGTH(Y)
SET CNT=CNT+1
SET @RET@(CNT)=X_U_Y
End DoDot:1
+7 QUIT
+8 ; Return immunization profile
PROFILE(RET,DFN) ;EP
+1 DO IMMPROF^BIRPC(.RET,+DFN,"","")
+2 IF $ASCII($GET(@RET@(1)))=31
SET @RET@(1)=$$IMMERR^BGOVIMM(@RET@(1))
+3 QUIT
+4 ; Return fully resolved immunization letter
+5 ; INP = Patient IEN [1] ^ Letter IEN [2] ^ Text of Date/Location Line [3] ^ Forecast Date [4]
PRINT(RET,INP) ;EP
+1 NEW BIDFN,BIDLOC,BIFDT,BIPCS,BILET,S,N
+2 SET RET=$NAME(^UTILITY($JOB,"W"))
+3 KILL @RET
+4 SET BIDFN=+INP
+5 SET BILET=$PIECE(INP,U,2)
+6 SET BIDLOC=$PIECE(INP,U,3)
+7 SET BIFDT=$PIECE(INP,U,4)
+8 SET S=$SELECT($DATA(^BISITE(DUZ(2),0)):DUZ(2),1:+^AUTTSITE(1,0))
+9 SET BILET=$SELECT(BILET=1:$PIECE($GET(^BISITE(S,0)),U,4),1:$PIECE($GET(^BISITE(S,0)),U,13))
+10 IF 'BILET
SET @RET@(1,0)="ERROR: Missing letter template"
QUIT
+11 DO BUILD^BILETPR1(BIDFN,BILET,BIDLOC,BIFDT)
+12 IF '$DATA(^TMP("BILET",$JOB))
SET @RET@(1,0)="ERROR: Blank letter template"
QUIT
+13 ; Resolve embedded functions
+14 SET N=0
+15 FOR
SET N=$ORDER(^TMP("BILET",$JOB,N))
IF 'N
QUIT
Begin DoDot:1
+16 NEW X,DIWL,DIWR,DIWF
+17 SET X=^TMP("BILET",$JOB,N,0)
SET DIWL=1
SET DIWR=80
SET DIWF="N"
+18 DO ^DIWP
End DoDot:1
+19 KILL ^TMP("BILET",$JOB)
+20 SET ^UTILITY($JOB,"W",1)=""
+21 QUIT
+22 ;Determine patient's age, if the site is an IHS site,and the default value for the VFC
+23 ;INP=DFN of patient
+24 ;RET= [1] IHS (Y/N)^ [2] Age ^ [3] Default
GETVFC(RET,INP) ;EP call to get the VFC default for a patient
+1 NEW IHS,AGE,DEFAULT,DFN
+2 KILL RET
+3 SET IHS="N"
SET AGE=""
SET DEFAULT=""
+4 SET DFN=$PIECE(INP,U,1)
+5 IF DUZ("AG")="I"
Begin DoDot:1
+6 ;IHS/MSC/MGH P11 no longer age dependent
+7 SET IHS="Y"
+8 SET AGE=$$PTAGE^BGOUTL(DFN)
+9 ;I AGE<19 D
+10 SET DEFAULT=$$BENTYP^BIUTL11(DFN)
+11 IF DEFAULT=1
SET DEFAULT="Am Indian/AK Native"
End DoDot:1
+12 SET RET=IHS_U_AGE_U_DEFAULT
+13 QUIT
+14 ; Add CPT code(s)
ADDCPT(CPT,ICD,VIEN,DFN,PRV,SITE,DATE,CNSL) ;EP
+1 ;IHS/MSC/MGH Patch 9 CPT codes no longer added or deleted
+2 QUIT 0
+3 NEW RET,CPT2,CPT3
+4 IF $$GET^XPAR("ALL","BGO IMM STOP ADDING CPT CODES")
QUIT 0
+5 IF '$GET(DATE)
SET DATE=+$GET(^AUPNVSIT(VIEN,0))
+6 SET CPT2=$$ADMINCPT^BGOVIMM(VIEN,CPT,SITE)
SET CPT3=$$SYRCPT^BGOVIMM(SITE)
SET RET=0
+7 ; Already exists
IF 'CPT2
QUIT RET
+8 SET CPT=$$ADJCPT^BGOVIMM(CPT,DFN,DATE,.CNSL)
SET CPT2=$$ADJCPT^BGOVIMM(CPT2,DFN,DATE,.CNSL)
+9 SET RET=$$ADDCPT^BGOVCPT(CPT,,VIEN,DFN,PRV)
+10 IF RET'<0
SET RET=$$ADDCPT^BGOVCPT(CPT2,.ICD,VIEN,DFN,PRV)
+11 IF 'RET
IF CPT3
SET RET=$$ADDCPT^BGOVCPT(CPT3,,VIEN,DFN,PRV)
+12 QUIT RET
+13 ; Return the CPT code IEN for a vaccine and visit
IMMCPT(TYPE,VIEN,ACTV) ;EP
+1 NEW X,CVX,CPT,AGE,DFN,DATE
+2 IF 'VIEN
QUIT $$ERR^BGOUTL(1002)
+3 SET DFN=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,5)
SET DATE=+$GET(^(0))
+4 IF 'DFN!'DATE
QUIT $$ERR^BGOUTL(1003)
+5 SET AGE=$$PTAGE^BGOUTL(DFN,DATE)
+6 SET X=$GET(^AUTTIMM(TYPE,0))
+7 SET CVX=$PIECE(X,U,3)
+8 SET CPT=$PIECE(X,U,11)
+9 ;ihs=90757
IF CVX=15
SET CPT=$SELECT(AGE>2:90658,1:90657)
+10 ;ihs=90743
IF '$TEST
IF CVX=43
SET CPT=$SELECT(AGE>18:90746,1:90743)
+11 ;ihs=none
IF '$TEST
IF CVX=111
SET CPT=90660
+12 IF CPT
IF $GET(ACTV)
Begin DoDot:1
+13 ;IHS/MSC/MGH HOTFIX P13
+14 SET X=$$CHKCPT^BGOVCPT(CPT,DATE,1)
+15 IF X<0
SET CPT=X
End DoDot:1
+16 QUIT CPT
+17 ;DKA Added DFN to satisfy RPC call from EHR component
GETELIG(RET,DFN) ;Return active eligibility codes
+1 NEW ACT,CNT,IEN,NODE
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET CNT=0
+4 SET ACT=""
FOR
SET ACT=$ORDER(^BIELIG("AC",0,ACT))
IF ACT=""
QUIT
Begin DoDot:1
+5 SET IEN=0
FOR
SET IEN=$ORDER(^BIELIG("AC",0,ACT,IEN))
IF '+IEN
QUIT
Begin DoDot:2
+6 SET CNT=CNT+1
+7 SET NODE=$GET(^BIELIG(IEN,0))
+8 SET @RET@(CNT)=IEN_U_$PIECE(NODE,U,1)_U_$PIECE(NODE,U,2)_U_$PIECE(NODE,U,4)
End DoDot:2
End DoDot:1
+9 QUIT
