BGOVPOV3 ; IHS/BAO/TMD - Visit POV maintenance ;09-Nov-2017 14:34;PLS
;;1.1;BGO COMPONENTS;**19,20,23**;Mar 20, 2007;Build 6
; Patch 23 added for fracture data
; Add/Edit VPOV data
; INP = null^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4] ^ Prov Text [5] ^ Descriptive CT [6] ^
; SNOMED CT [7] ^ ^Primary/Seconday ^ Provider IEN [10]^ asthma control [11] ^norm/abn [12] ^ laterality [13] ^ fracture [14]
; LIST(n) = POV IEN [1]
; QUAL = Q [1] ^ TYPE [2] ^IEN (If edit) [3] ^ SNOMED [4] ^ BY [5] ^WHEN [6] ^ DEL [7]
; INJ = Cause DX[1] ^ Injury Code [2] ^ Injury Place [3] ^ First/Revisit [4] ^ Injury Dt [5] ^ Onset Date [6]
; NORM = SNOMED
EDIT(RET,INP,LIST,QUAL,INJ,NORM) ;EP
N VIEN,DFN,TYPE,ITYPE,NARR,STAGE,MOD,CAUSEDX,REVISIT,ECODE,PLACE,CONTROL,SNOMED,DESC,TEXT,SAVRET,VDT
N PRIM,INJDT,ONSET,FDA,FNUM,VFNEW,PRV,TYPE2,DUP,LAT,LATEXT,FIRST
N CANDUP,OFF,APCDVSIT,PXCEVIEN,PROB,NEW,DESCT,SNODATA,IMP,FRAC
N PTDATA,CHK,POVLST,IENS,POV,RET3,SPEC,VFIEN,X,FIRST
S FNUM=$$FNUM
S CHK=0,IENS="",SPEC="",FIRST=""
S FIVE=$G(FIVE),DUP=$G(DUP)
S NEW=0,RET3=""
S NORM=$G(NORM)
S INJ=$G(INJ)
S QUAL=$G(QUAL)
;MSC/MGH - 07/08/09 - Offset to support VistA and RPMS
S OFF=$S($G(DUZ("AG"))="I":0,1:9999999)
S VIEN=$P(INP,U,2)
S PROB=$P(INP,U,3)
I 'VIEN S RET=$$ERR^BGOUTL(1008) Q
I $G(DUZ("AG"))="I" S APCDVSIT=VIEN
E S PXCEVIEN=VIEN
S DFN=$P(INP,U,4)
S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
Q:RET
;Patch 13 SNOMED CT data
S VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
S SNOMED=$P(INP,U,7)
S NARR=$P(INP,U,5),DESCT=$P(INP,U,6)
S NARR=$TR(NARR,"^|","")
;IHS/MSC/MGH Changes for laterality
S LAT=$$GET1^DIQ(9000011,PROB,.22,"I")
I LAT'="" D
.S LATEXT=$$CVPARM^BSTSMAP1("LAT",$P(LAT,"|",2))
.S NARR=NARR_"|"_DESCT_"|"_LATEXT
E S NARR=NARR_"|"_DESCT
S TYPE=$P($P(INP,U,8),"|",1)
;Handle Prenatal 1.0 POV sets
I $P(INP,U,5)["|",DESCT="" D
. S NARR=$P(INP,U,5)
. S TYPE=$TR($P(INP,U,3),"`")
. I TYPE]"" S TYPE=$P($$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT),U,2)
. S SPEC=1,PROB=""
I $E($P(INP,U,3))="`" D
. S NARR=$P(INP,U,5)
. S TYPE=$TR($P(INP,U,3),"`")
. I TYPE]"" S TYPE=$P($$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT),U,2)
. S SPEC=1,PROB=""
S RET=$$FNDNARR^BGOUTL2(NARR)
Q:RET<0
S NARR=$S(RET:"`"_RET,1:""),RET=""
D GETPOVS(.LIST,.POVLST)
S FRAC=$P(INP,U,14)
S PTDATA=$$GETDATA^BGOVPOV2(DFN,$G(LIST(0)),FRAC)
S SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1^^"_PTDATA)
I 'SPEC D
.S FIVE=$P(SNODATA,U,5)
.S FIRST=$P(FIVE,";",1)
.S CHK=$$MATCH^BGOVPOV3(FIVE,.POVLST)
.I CHK=1 D
..D DELPOV(.LIST,PROB)
..S VFNEW=1
..S DEL=";"
..S X=$L(FIVE,DEL)
..F I=1:1:X D
...S X2=$P(FIVE,DEL,I)
...S TYPE=X2,VFIEN=0,NEW=1
...D STORE
.I CHK=0 D
..S VFNEW=0
..S POV="" F S POV=$O(LIST(POV)) Q:POV="" D
...S VFIEN=$P(LIST(POV),U,1)
...S TYPE=$$GET1^DIQ(9000010.07,VFIEN,.01)
...D STORE
I SPEC D STORE
S RET=IENS
Q
MATCH(FIVE,POVLST) ;Match up the ICDs on the problem with the SNOMED
N DEL,X,X2,I,SFIVE,CHK2
S CHK2=0
S DEL=";"
S SFIVE=$G(FIVE)
S X=$L(SFIVE,DEL)
S CNT=$G(POVLST(0))
Q:X'=CNT 1
F I=1:1:X D
.S X2=$P(SFIVE,DEL,I)
.I '$D(POVLST(X2)) S CHK2=1 ;There is a code in the snomed lookup not in the POV file
Q CHK2
GETPOVS(LIST,POVLST) ;Get the ICD codes currently stored
N IEN,CODE,ICDCODE,CNT
S CNT=0
S IEN="" F S IEN=$O(LIST(IEN)) Q:IEN="" D
.S ICDCODE=$P(LIST(IEN),U,1)
.S CODE=$$GET1^DIQ(9000010.07,ICDCODE,.01)
.S POVLST(CODE)="",CNT=CNT+1
S POVLST(0)=CNT
Q
DELPOV(LIST,PROB) ;Delete the POVs in the list
N VPOV,RET1,POVICD
S VPOV="" F S VPOV=$O(LIST(VPOV)) Q:VPOV="" D
.S POVICD=$P(LIST(VPOV),U,1)
.D DEL^BGOVPOV(.RET1,POVICD,PROB)
Q
STORE ;Store the POV
;MSC/MGH Updated in patch 18 to send in extra data
S CANDUP=1
I TYPE="" D
.;Patch 14 check for which undefined code to use
.I $$AICD^BGOUTL2 D
..S IMP=$$IMP^ICDEX("10D",DT)
..I IMP<VDT!(IMP=VDT) S TYPE="ZZZ.999"
..I IMP>VDT S TYPE=".9999"
.E S TYPE=".9999"
I TYPE'["." S TYPE=TYPE_"."
S ITYPE=$P($$CODEN^ICDEX(TYPE,80),"~",1)
I 'ITYPE S RET=$$ERR^BGOUTL(1094) Q
I 'VFIEN D CHECK^BGOVPOV(.DUP,ITYPE_U_DFN_U_+$G(^AUPNVSIT(VIEN,0))_U_SNOMED_U_LAT)
I DUP'="" S RET=DUP
Q:RET
;Injury data
S (CAUSEDX,REVISIT,ECODE,PLACE,INJDT,ONSET)=""
I INJ'="" D
.S CAUSEDX=$P(INJ,U,1)
.S REVISIT=$P(INJ,U,4)
.S ECODE=$P(INJ,U,2)
.S PLACE=$P(INJ,U,3)
.S INJDT=$$CVTDATE^BGOUTL($P(INJ,U,5))
.S INJDT=$P(INJDT,".",1)
.S ONSET=$$CVTDATE^BGOUTL($P(INJ,U,6))
;
;Provider Information
S PRIM=$P(INP,U,9)
S PRIM=$S($L(PRIM):PRIM,$$FNDPRI^BGOVPOV1(VIEN):"S",1:"P")
S PRV=$P(INP,U,10)
S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
Q:RET
;
I 'VFIEN D Q:'VFIEN
.D VFNEW^BGOUTL2(.RET,FNUM,ITYPE,VIEN,$S(CANDUP:"",1:"POV"))
.S:RET>0 VFIEN=RET,SAVRET=RET,RET=""
E S SAVRET=VFIEN
S FDA=$NA(FDA(FNUM,VFIEN_","))
S @FDA@(.01)="`"_ITYPE
S @FDA@(.04)=NARR
S @FDA@(.29)=NORM ;Patch 18
S @FDA@(.07)=CAUSEDX
S @FDA@(.08)=REVISIT
S @FDA@(.09)=$S(ECODE'="":ECODE,1:"")
S @FDA@(.11)=PLACE
;Patch 20
S PRIM=$S(PRIM="Primary":"P",PRIM="PRIMARY":"P",PRIM="P":"P",1:"S")
I PRIM="P"&(FIRST=TYPE) S @FDA@(.12)=PRIM
E S @FDA@(.12)="S"
;S @FDA@(.12)=PRIM
S @FDA@(.13)=INJDT
S @FDA@(.17+OFF)=ONSET ;P6
I PROB'="" S @FDA@(.16)="`"_PROB
S @FDA@(1104)=$S(LAT="":"@",1:LAT) ;P20
S @FDA@(1101)=SNOMED
S @FDA@(1102)=DESCT
S @FDA@(1106)=FRAC ;P23
S @FDA@(1201)="N"
S @FDA@(1204)="`"_DUZ ; PATCH 5
;IHS/MSC/MGH added new fields patch 11
I VFNEW D
.S @FDA@(1216)="N"
.S @FDA@(1217)="`"_DUZ
S @FDA@(1218)="N"
S @FDA@(1219)="`"_DUZ
S RET=$$UPDATE^BGOUTL(.FDA,"E@")
I RET,VFNEW,$$DELETE^BGOUTL(FNUM,VFIEN)
Q:RET
;IHS/MSC/MGH Patch 13 check for qualifiers
I NEW=1 D QUALB^BGOVPOV1(.RET,PROB,VFIEN)
I QUAL'="" D QUAL^BGOVPOV1(.RET,VFIEN,QUAL)
I PRIM="P"&(FIRST=TYPE) D Q:RET
.D SETPRI^BGOVPOV(.RET,VFIEN_U_PRIM,1)
.S:RET>0 VFIEN=RET,RET=""
;E I $$FIXVPOVS^BGOVPOV1(VIEN,.VFIEN) ; Fix VPOV sequencing Removed P18
D VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
;Check for asthma diagnoses
S CONTROL=$P(INP,U,11)
I DUZ("AG")="I" D
. N ASTHMA
. ;IHS/MSC/MGH Patch 15, change to DESCT
. S ASTHMA=$$CHECK^BGOASLK(ITYPE,DESCT)
. I ASTHMA=1 S RET=RET_U_ASTHMA
. I CONTROL="NONE RECORDED" S CONTROL=""
. I CONTROL'="" D ASTHMA^BGOVPOV3(DFN,CONTROL,VIEN)
.;Check for bulletin for new dx
.N DA,X,APCDDATE,APCDVSIT,ATXAD,APCDPAT,AUPNPAT
.S DA=VFIEN,X=ITYPE
.S APCDDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
.S APCDVSIT=VIEN,ATXAD="",(APCDPAT,AUPNPAT)=DFN
.D ^ATXPOV
S IENS=IENS_";"_SAVRET
;Add POV to the problem multiple
Q:PROB=""
Q:$D(^AUPNPROB(PROB,14,"B",VIEN))
N PRIEN,FDA,IEN,ERR
S PRIEN="+1,"_PROB_","
S FDA(9000011.14,PRIEN,.01)=VIEN
D UPDATE^DIE(,"FDA","IEN","ERR")
I $D(ERR) S RET="Unable to update problem multiple"
Q
;Input=CODIEN SNOMED concept ID
; VIEN Visit IEN
INJURY(RET,SNOMED,VIEN) ;Is this problem an injury?
N ICD,SNODATA,VDT
S RET=0
I 'SNOMED S RET="-1^Missing SNOMED CT"
S VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
S SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1")
S ICD=$P($P(SNODATA,U,5),";",1)
I $$AICD^BGOUTL2 D ICD10(.RET,ICD) Q
S X=$$ICDDX^ICDCODE(ICD)
S ICD=$P(X,U,2)
I ICD>799.9&(ICD<1000) S RET=1
Q
ICD10(RET,ICD) ;New entry point for ICD-10
N IMP,X
S IMP=$$IMP^ICDEX("10D",DT)
I IMP<VDT D
.I $E(ICD,1)="S" S RET=1
.I $E(ICD,1)="T",$E(ICD,2,3)<89 S RET=1
I IMP>VDT D
.I ICD>799.9&(ICD<1000) S RET=1
Q
ASTHMA(DFN,CONTROL,VIEN) ;Find last control, if it has changed store the change
N LEVEL,INP,RET,RETURN,AIEN
Q:CONTROL="@"
;IHS/MSC/MGH change in patch 10 to always store, not just if a change
S RETURN=$$ACONTROL^BGOASLK(DFN,VIEN)
S LEVEL=$P(RETURN,U,1),AIEN=$P(RETURN,U,2)
I LEVEL'=CONTROL D
.S INP=AIEN_U_VIEN_U_CONTROL
.D SET^BGOVAST(.RET,INP)
Q
FNUM() Q 9000010.07
BGOVPOV3 ; IHS/BAO/TMD - Visit POV maintenance ;09-Nov-2017 14:34;PLS
+1 ;;1.1;BGO COMPONENTS;**19,20,23**;Mar 20, 2007;Build 6
+2 ; Patch 23 added for fracture data
+3 ; Add/Edit VPOV data
+4 ; INP = null^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4] ^ Prov Text [5] ^ Descriptive CT [6] ^
+5 ; SNOMED CT [7] ^ ^Primary/Seconday ^ Provider IEN [10]^ asthma control [11] ^norm/abn [12] ^ laterality [13] ^ fracture [14]
+6 ; LIST(n) = POV IEN [1]
+7 ; QUAL = Q [1] ^ TYPE [2] ^IEN (If edit) [3] ^ SNOMED [4] ^ BY [5] ^WHEN [6] ^ DEL [7]
+8 ; INJ = Cause DX[1] ^ Injury Code [2] ^ Injury Place [3] ^ First/Revisit [4] ^ Injury Dt [5] ^ Onset Date [6]
+9 ; NORM = SNOMED
EDIT(RET,INP,LIST,QUAL,INJ,NORM) ;EP
+1 NEW VIEN,DFN,TYPE,ITYPE,NARR,STAGE,MOD,CAUSEDX,REVISIT,ECODE,PLACE,CONTROL,SNOMED,DESC,TEXT,SAVRET,VDT
+2 NEW PRIM,INJDT,ONSET,FDA,FNUM,VFNEW,PRV,TYPE2,DUP,LAT,LATEXT,FIRST
+3 NEW CANDUP,OFF,APCDVSIT,PXCEVIEN,PROB,NEW,DESCT,SNODATA,IMP,FRAC
+4 NEW PTDATA,CHK,POVLST,IENS,POV,RET3,SPEC,VFIEN,X,FIRST
+5 SET FNUM=$$FNUM
+6 SET CHK=0
SET IENS=""
SET SPEC=""
SET FIRST=""
+7 SET FIVE=$GET(FIVE)
SET DUP=$GET(DUP)
+8 SET NEW=0
SET RET3=""
+9 SET NORM=$GET(NORM)
+10 SET INJ=$GET(INJ)
+11 SET QUAL=$GET(QUAL)
+12 ;MSC/MGH - 07/08/09 - Offset to support VistA and RPMS
+13 SET OFF=$SELECT($GET(DUZ("AG"))="I":0,1:9999999)
+14 SET VIEN=$PIECE(INP,U,2)
+15 SET PROB=$PIECE(INP,U,3)
+16 IF 'VIEN
SET RET=$$ERR^BGOUTL(1008)
QUIT
+17 IF $GET(DUZ("AG"))="I"
SET APCDVSIT=VIEN
+18 IF '$TEST
SET PXCEVIEN=VIEN
+19 SET DFN=$PIECE(INP,U,4)
+20 SET RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
+21 IF RET
QUIT
+22 ;Patch 13 SNOMED CT data
+23 SET VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
+24 SET SNOMED=$PIECE(INP,U,7)
+25 SET NARR=$PIECE(INP,U,5)
SET DESCT=$PIECE(INP,U,6)
+26 SET NARR=$TRANSLATE(NARR,"^|","")
+27 ;IHS/MSC/MGH Changes for laterality
+28 SET LAT=$$GET1^DIQ(9000011,PROB,.22,"I")
+29 IF LAT'=""
Begin DoDot:1
+30 SET LATEXT=$$CVPARM^BSTSMAP1("LAT",$PIECE(LAT,"|",2))
+31 SET NARR=NARR_"|"_DESCT_"|"_LATEXT
End DoDot:1
+32 IF '$TEST
SET NARR=NARR_"|"_DESCT
+33 SET TYPE=$PIECE($PIECE(INP,U,8),"|",1)
+34 ;Handle Prenatal 1.0 POV sets
+35 IF $PIECE(INP,U,5)["|"
IF DESCT=""
Begin DoDot:1
+36 SET NARR=$PIECE(INP,U,5)
+37 SET TYPE=$TRANSLATE($PIECE(INP,U,3),"`")
+38 IF TYPE]""
SET TYPE=$PIECE($$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT),U,2)
+39 SET SPEC=1
SET PROB=""
End DoDot:1
+40 IF $EXTRACT($PIECE(INP,U,3))="`"
Begin DoDot:1
+41 SET NARR=$PIECE(INP,U,5)
+42 SET TYPE=$TRANSLATE($PIECE(INP,U,3),"`")
+43 IF TYPE]""
SET TYPE=$PIECE($$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT),U,2)
+44 SET SPEC=1
SET PROB=""
End DoDot:1
+45 SET RET=$$FNDNARR^BGOUTL2(NARR)
+46 IF RET<0
QUIT
+47 SET NARR=$SELECT(RET:"`"_RET,1:"")
SET RET=""
+48 DO GETPOVS(.LIST,.POVLST)
+49 SET FRAC=$PIECE(INP,U,14)
+50 SET PTDATA=$$GETDATA^BGOVPOV2(DFN,$GET(LIST(0)),FRAC)
+51 SET SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1^^"_PTDATA)
+52 IF 'SPEC
Begin DoDot:1
+53 SET FIVE=$PIECE(SNODATA,U,5)
+54 SET FIRST=$PIECE(FIVE,";",1)
+55 SET CHK=$$MATCH^BGOVPOV3(FIVE,.POVLST)
+56 IF CHK=1
Begin DoDot:2
+57 DO DELPOV(.LIST,PROB)
+58 SET VFNEW=1
+59 SET DEL=";"
+60 SET X=$LENGTH(FIVE,DEL)
+61 FOR I=1:1:X
Begin DoDot:3
+62 SET X2=$PIECE(FIVE,DEL,I)
+63 SET TYPE=X2
SET VFIEN=0
SET NEW=1
+64 DO STORE
End DoDot:3
End DoDot:2
+65 IF CHK=0
Begin DoDot:2
+66 SET VFNEW=0
+67 SET POV=""
FOR
SET POV=$ORDER(LIST(POV))
IF POV=""
QUIT
Begin DoDot:3
+68 SET VFIEN=$PIECE(LIST(POV),U,1)
+69 SET TYPE=$$GET1^DIQ(9000010.07,VFIEN,.01)
+70 DO STORE
End DoDot:3
End DoDot:2
End DoDot:1
+71 IF SPEC
DO STORE
+72 SET RET=IENS
+73 QUIT
MATCH(FIVE,POVLST) ;Match up the ICDs on the problem with the SNOMED
+1 NEW DEL,X,X2,I,SFIVE,CHK2
+2 SET CHK2=0
+3 SET DEL=";"
+4 SET SFIVE=$GET(FIVE)
+5 SET X=$LENGTH(SFIVE,DEL)
+6 SET CNT=$GET(POVLST(0))
+7 IF X'=CNT
QUIT 1
+8 FOR I=1:1:X
Begin DoDot:1
+9 SET X2=$PIECE(SFIVE,DEL,I)
+10 ;There is a code in the snomed lookup not in the POV file
IF '$DATA(POVLST(X2))
SET CHK2=1
End DoDot:1
+11 QUIT CHK2
GETPOVS(LIST,POVLST) ;Get the ICD codes currently stored
+1 NEW IEN,CODE,ICDCODE,CNT
+2 SET CNT=0
+3 SET IEN=""
FOR
SET IEN=$ORDER(LIST(IEN))
IF IEN=""
QUIT
Begin DoDot:1
+4 SET ICDCODE=$PIECE(LIST(IEN),U,1)
+5 SET CODE=$$GET1^DIQ(9000010.07,ICDCODE,.01)
+6 SET POVLST(CODE)=""
SET CNT=CNT+1
End DoDot:1
+7 SET POVLST(0)=CNT
+8 QUIT
DELPOV(LIST,PROB) ;Delete the POVs in the list
+1 NEW VPOV,RET1,POVICD
+2 SET VPOV=""
FOR
SET VPOV=$ORDER(LIST(VPOV))
IF VPOV=""
QUIT
Begin DoDot:1
+3 SET POVICD=$PIECE(LIST(VPOV),U,1)
+4 DO DEL^BGOVPOV(.RET1,POVICD,PROB)
End DoDot:1
+5 QUIT
STORE ;Store the POV
+1 ;MSC/MGH Updated in patch 18 to send in extra data
+2 SET CANDUP=1
+3 IF TYPE=""
Begin DoDot:1
+4 ;Patch 14 check for which undefined code to use
+5 IF $$AICD^BGOUTL2
Begin DoDot:2
+6 SET IMP=$$IMP^ICDEX("10D",DT)
+7 IF IMP<VDT!(IMP=VDT)
SET TYPE="ZZZ.999"
+8 IF IMP>VDT
SET TYPE=".9999"
End DoDot:2
+9 IF '$TEST
SET TYPE=".9999"
End DoDot:1
+10 IF TYPE'["."
SET TYPE=TYPE_"."
+11 SET ITYPE=$PIECE($$CODEN^ICDEX(TYPE,80),"~",1)
+12 IF 'ITYPE
SET RET=$$ERR^BGOUTL(1094)
QUIT
+13 IF 'VFIEN
DO CHECK^BGOVPOV(.DUP,ITYPE_U_DFN_U_+$GET(^AUPNVSIT(VIEN,0))_U_SNOMED_U_LAT)
+14 IF DUP'=""
SET RET=DUP
+15 IF RET
QUIT
+16 ;Injury data
+17 SET (CAUSEDX,REVISIT,ECODE,PLACE,INJDT,ONSET)=""
+18 IF INJ'=""
Begin DoDot:1
+19 SET CAUSEDX=$PIECE(INJ,U,1)
+20 SET REVISIT=$PIECE(INJ,U,4)
+21 SET ECODE=$PIECE(INJ,U,2)
+22 SET PLACE=$PIECE(INJ,U,3)
+23 SET INJDT=$$CVTDATE^BGOUTL($PIECE(INJ,U,5))
+24 SET INJDT=$PIECE(INJDT,".",1)
+25 SET ONSET=$$CVTDATE^BGOUTL($PIECE(INJ,U,6))
End DoDot:1
+26 ;
+27 ;Provider Information
+28 SET PRIM=$PIECE(INP,U,9)
+29 SET PRIM=$SELECT($LENGTH(PRIM):PRIM,$$FNDPRI^BGOVPOV1(VIEN):"S",1:"P")
+30 SET PRV=$PIECE(INP,U,10)
+31 SET RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
+32 IF RET
QUIT
+33 ;
+34 IF 'VFIEN
Begin DoDot:1
+35 DO VFNEW^BGOUTL2(.RET,FNUM,ITYPE,VIEN,$SELECT(CANDUP:"",1:"POV"))
+36 IF RET>0
SET VFIEN=RET
SET SAVRET=RET
SET RET=""
End DoDot:1
IF 'VFIEN
QUIT
+37 IF '$TEST
SET SAVRET=VFIEN
+38 SET FDA=$NAME(FDA(FNUM,VFIEN_","))
+39 SET @FDA@(.01)="`"_ITYPE
+40 SET @FDA@(.04)=NARR
+41 ;Patch 18
SET @FDA@(.29)=NORM
+42 SET @FDA@(.07)=CAUSEDX
+43 SET @FDA@(.08)=REVISIT
+44 SET @FDA@(.09)=$SELECT(ECODE'="":ECODE,1:"")
+45 SET @FDA@(.11)=PLACE
+46 ;Patch 20
+47 SET PRIM=$SELECT(PRIM="Primary":"P",PRIM="PRIMARY":"P",PRIM="P":"P",1:"S")
+48 IF PRIM="P"&(FIRST=TYPE)
SET @FDA@(.12)=PRIM
+49 IF '$TEST
SET @FDA@(.12)="S"
+50 ;S @FDA@(.12)=PRIM
+51 SET @FDA@(.13)=INJDT
+52 ;P6
SET @FDA@(.17+OFF)=ONSET
+53 IF PROB'=""
SET @FDA@(.16)="`"_PROB
+54 ;P20
SET @FDA@(1104)=$SELECT(LAT="":"@",1:LAT)
+55 SET @FDA@(1101)=SNOMED
+56 SET @FDA@(1102)=DESCT
+57 ;P23
SET @FDA@(1106)=FRAC
+58 SET @FDA@(1201)="N"
+59 ; PATCH 5
SET @FDA@(1204)="`"_DUZ
+60 ;IHS/MSC/MGH added new fields patch 11
+61 IF VFNEW
Begin DoDot:1
+62 SET @FDA@(1216)="N"
+63 SET @FDA@(1217)="`"_DUZ
End DoDot:1
+64 SET @FDA@(1218)="N"
+65 SET @FDA@(1219)="`"_DUZ
+66 SET RET=$$UPDATE^BGOUTL(.FDA,"E@")
+67 IF RET
IF VFNEW
IF $$DELETE^BGOUTL(FNUM,VFIEN)
+68 IF RET
QUIT
+69 ;IHS/MSC/MGH Patch 13 check for qualifiers
+70 IF NEW=1
DO QUALB^BGOVPOV1(.RET,PROB,VFIEN)
+71 IF QUAL'=""
DO QUAL^BGOVPOV1(.RET,VFIEN,QUAL)
+72 IF PRIM="P"&(FIRST=TYPE)
Begin DoDot:1
+73 DO SETPRI^BGOVPOV(.RET,VFIEN_U_PRIM,1)
+74 IF RET>0
SET VFIEN=RET
SET RET=""
End DoDot:1
IF RET
QUIT
+75 ;E I $$FIXVPOVS^BGOVPOV1(VIEN,.VFIEN) ; Fix VPOV sequencing Removed P18
+76 DO VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
+77 ;Check for asthma diagnoses
+78 SET CONTROL=$PIECE(INP,U,11)
+79 IF DUZ("AG")="I"
Begin DoDot:1
+80 NEW ASTHMA
+81 ;IHS/MSC/MGH Patch 15, change to DESCT
+82 SET ASTHMA=$$CHECK^BGOASLK(ITYPE,DESCT)
+83 IF ASTHMA=1
SET RET=RET_U_ASTHMA
+84 IF CONTROL="NONE RECORDED"
SET CONTROL=""
+85 IF CONTROL'=""
DO ASTHMA^BGOVPOV3(DFN,CONTROL,VIEN)
+86 ;Check for bulletin for new dx
+87 NEW DA,X,APCDDATE,APCDVSIT,ATXAD,APCDPAT,AUPNPAT
+88 SET DA=VFIEN
SET X=ITYPE
+89 SET APCDDATE=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
+90 SET APCDVSIT=VIEN
SET ATXAD=""
SET (APCDPAT,AUPNPAT)=DFN
+91 DO ^ATXPOV
End DoDot:1
+92 SET IENS=IENS_";"_SAVRET
+93 ;Add POV to the problem multiple
+94 IF PROB=""
QUIT
+95 IF $DATA(^AUPNPROB(PROB,14,"B",VIEN))
QUIT
+96 NEW PRIEN,FDA,IEN,ERR
+97 SET PRIEN="+1,"_PROB_","
+98 SET FDA(9000011.14,PRIEN,.01)=VIEN
+99 DO UPDATE^DIE(,"FDA","IEN","ERR")
+100 IF $DATA(ERR)
SET RET="Unable to update problem multiple"
+101 QUIT
+102 ;Input=CODIEN SNOMED concept ID
+103 ; VIEN Visit IEN
INJURY(RET,SNOMED,VIEN) ;Is this problem an injury?
+1 NEW ICD,SNODATA,VDT
+2 SET RET=0
+3 IF 'SNOMED
SET RET="-1^Missing SNOMED CT"
+4 SET VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
+5 SET SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1")
+6 SET ICD=$PIECE($PIECE(SNODATA,U,5),";",1)
+7 IF $$AICD^BGOUTL2
DO ICD10(.RET,ICD)
QUIT
+8 SET X=$$ICDDX^ICDCODE(ICD)
+9 SET ICD=$PIECE(X,U,2)
+10 IF ICD>799.9&(ICD<1000)
SET RET=1
+11 QUIT
ICD10(RET,ICD) ;New entry point for ICD-10
+1 NEW IMP,X
+2 SET IMP=$$IMP^ICDEX("10D",DT)
+3 IF IMP<VDT
Begin DoDot:1
+4 IF $EXTRACT(ICD,1)="S"
SET RET=1
+5 IF $EXTRACT(ICD,1)="T"
IF $EXTRACT(ICD,2,3)<89
SET RET=1
End DoDot:1
+6 IF IMP>VDT
Begin DoDot:1
+7 IF ICD>799.9&(ICD<1000)
SET RET=1
End DoDot:1
+8 QUIT
ASTHMA(DFN,CONTROL,VIEN) ;Find last control, if it has changed store the change
+1 NEW LEVEL,INP,RET,RETURN,AIEN
+2 IF CONTROL="@"
QUIT
+3 ;IHS/MSC/MGH change in patch 10 to always store, not just if a change
+4 SET RETURN=$$ACONTROL^BGOASLK(DFN,VIEN)
+5 SET LEVEL=$PIECE(RETURN,U,1)
SET AIEN=$PIECE(RETURN,U,2)
+6 IF LEVEL'=CONTROL
Begin DoDot:1
+7 SET INP=AIEN_U_VIEN_U_CONTROL
+8 DO SET^BGOVAST(.RET,INP)
End DoDot:1
+9 QUIT
FNUM() QUIT 9000010.07
