BGOVPOV2 ; IHS/BAO/TMD - Visit POV maintenance ;09-Nov-2017 14:35;PLS
;;1.1;BGO COMPONENTS;**13,14,15,19,20,23**;Mar 20, 2007;Build 6
; Add/Edit VPOV data
; INP = VPOV IEN [1] ^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4] ^ Prov Text [5] ^ Descriptive CT [6] ^
; SNOMED CT [7] ^ ICD code [8] ^ Primary/Secondary [9] ^ Provider IEN [10]^ asthma control [11] ^ norm/abn [12] ^ Laterality [13] ^ Fracture [14]
; 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]
; SPEC = Special cases
; NORM = SNOMED
SET2(RET,INP,QUAL,INJ,VFIEN,DUP,FIVE,SPEC,NORM) ;EP
N VIEN,DFN,TYPE,NARR,STAGE,MOD,CAUSEDX,REVISIT,ECODE,PLACE,CONTROL,SNOMED,DESC,TEXT,SAVRET,VDT,LAT,LATEXT,POVLAT
N PRIM,INJDT,ONSET,FDA,FNUM,VFNEW,FRAC,PRV,TYPE2,CANDUP,OFF,APCDVSIT,PXCEVIEN,PROB,NEW,DESCT,SNODATA,IMP,PTDATA,RET3
S FNUM=$$FNUM
S FIVE=$G(FIVE),DUP=$G(DUP)
S NEW=0,RET3="",SPEC=$G(SPEC)
S VFIEN=$G(VFIEN),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 VFIEN=+INP
I +VFIEN=0 S NEW=1
S VFNEW='VFIEN
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 p20
S LAT=$P(INP,U,13)
I LAT="272741003|261665006"!(LAT="272741003|") S LAT=""
I LAT="" 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)
;I TYPE'["." S TYPE=TYPE_"."
;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=""
;Get ICD code for POV from the Apelon
;MSC/MGH Updated in patch 18 to send in extra data
S FRAC=$P(INP,U,14)
S PTDATA=$$GETDATA(DFN,VFIEN,FRAC)
S SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1^^"_PTDATA)
I FIVE=""&('SPEC) D
.S FIVE=$P(SNODATA,U,5)
.S TYPE2=$P($P(SNODATA,U,5),";",1)
.I TYPE2'["." S TYPE2=TYPE2_"."
.I TYPE2'="" S TYPE=TYPE2
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 TYPE=$P($$CODEN^ICDEX(TYPE,80),"~",1)
I 'TYPE S RET=$$ERR^BGOUTL(1094) Q
I 'VFIEN D CHECK^BGOVPOV(.DUP,TYPE_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,TYPE,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)="`"_TYPE
S @FDA@(.04)=NARR
;S @FDA@(.05)=STAGE
;S @FDA@(.06)=MOD
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
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)
S PRIM=$S(PRIM="Primary":"P",PRIM="PRIMARY":"P",PRIM="P":"P",1:"S")
I PRIM="P" 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
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(TYPE,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=TYPE
.S APCDDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
.S APCDVSIT=VIEN,ATXAD="",(APCDPAT,AUPNPAT)=DFN
.D ^ATXPOV
S RET=SAVRET
;Add POV to the problem multiple
Q:PROB=""
Q:$D(^AUPNPROB(PROB,14,"B",VIEN))
N PRIEN,FDA,IEN,ERR
I VFNEW D
.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
ADDICD(RET,INP,QUAL,INJ,VFIEN,DUP,FIVE,SPEC) ;Add any additional ICD codes as POV
N DUP2,SFIVE,X,ADDI,DEL
S DEL=";",DUP2=""
S SFIVE=$G(FIVE)
S X=$L(FIVE,DEL)
F ADDI=2:1:X D
.S $P(INP,U,8)=$P(SFIVE,DEL,ADDI)
.S $P(INP,U,9)="Secondary"
.D SET2^BGOVPOV2(.RET,INP,QUAL,INJ,VFIEN,.DUP2,.FIVE,SPEC)
Q
; Return V File #
GETDATA(DFN,VFIEN,FRAC) ;EP
N STRING,AF,DATAI,SNO,EPI,HTERM,TRM,LTRM
S STRING="",EPI=""
S FRAC=$G(FRAC)
S STRING="VST="_VIEN_";PRB="_PROB
I QUAL'="" S EPI=$P(QUAL,U,4)
E I +VFIEN S EPI=$O(^AUPNVPOV(+VFIEN,14,"B",""))
I EPI]"" S STRING=STRING_";EPI="_EPI
I NORM'="" D
.S AF=$S(NORM=71994000:"With",NORM=162656002:"Without",1:"")
.S STRING=STRING_";AF="_AF
S DATAI=0 F S DATAI=$O(^AUPNPROB(PROB,13,DATAI)) Q:'+DATAI D
.S SNO=$P($G(^AUPNPROB(PROB,13,DATAI,0)),U,1)
.I SNO'="",$$CVPARM^BSTSMAP1("SEV",SNO)'="Severity" S STRING=STRING_";SEV="_SNO
;Patch 23 add fracture healing
I FRAC'="" S HTERM=$$CVPARM^BSTSMAP1("HEAL",FRAC) I HTERM]"" S STRING=STRING_";HEAL="_HTERM
Q STRING
FNUM() Q 9000010.07
BGOVPOV2 ; IHS/BAO/TMD - Visit POV maintenance ;09-Nov-2017 14:35;PLS
+1 ;;1.1;BGO COMPONENTS;**13,14,15,19,20,23**;Mar 20, 2007;Build 6
+2 ; Add/Edit VPOV data
+3 ; INP = VPOV IEN [1] ^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4] ^ Prov Text [5] ^ Descriptive CT [6] ^
+4 ; SNOMED CT [7] ^ ICD code [8] ^ Primary/Secondary [9] ^ Provider IEN [10]^ asthma control [11] ^ norm/abn [12] ^ Laterality [13] ^ Fracture [14]
+5 ; QUAL = Q [1] ^ TYPE [2] ^IEN (If edit) [3] ^ SNOMED [4] ^ BY [5] ^WHEN [6] ^ DEL [7]
+6 ; INJ = Cause DX[1] ^ Injury Code [2] ^ Injury Place [3] ^ First/Revisit [4] ^ Injury Dt [5] ^ Onset Date [6]
+7 ; SPEC = Special cases
+8 ; NORM = SNOMED
SET2(RET,INP,QUAL,INJ,VFIEN,DUP,FIVE,SPEC,NORM) ;EP
+1 NEW VIEN,DFN,TYPE,NARR,STAGE,MOD,CAUSEDX,REVISIT,ECODE,PLACE,CONTROL,SNOMED,DESC,TEXT,SAVRET,VDT,LAT,LATEXT,POVLAT
+2 NEW PRIM,INJDT,ONSET,FDA,FNUM,VFNEW,FRAC,PRV,TYPE2,CANDUP,OFF,APCDVSIT,PXCEVIEN,PROB,NEW,DESCT,SNODATA,IMP,PTDATA,RET3
+3 SET FNUM=$$FNUM
+4 SET FIVE=$GET(FIVE)
SET DUP=$GET(DUP)
+5 SET NEW=0
SET RET3=""
SET SPEC=$GET(SPEC)
+6 SET VFIEN=$GET(VFIEN)
SET NORM=$GET(NORM)
+7 SET INJ=$GET(INJ)
+8 SET QUAL=$GET(QUAL)
+9 ;MSC/MGH - 07/08/09 - Offset to support VistA and RPMS
+10 SET OFF=$SELECT($GET(DUZ("AG"))="I":0,1:9999999)
+11 ;S VFIEN=+INP
+12 IF +VFIEN=0
SET NEW=1
+13 SET VFNEW='VFIEN
+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 p20
+28 SET LAT=$PIECE(INP,U,13)
+29 IF LAT="272741003|261665006"!(LAT="272741003|")
SET LAT=""
+30 IF LAT=""
SET LAT=$$GET1^DIQ(9000011,PROB,.22,"I")
+31 IF LAT'=""
Begin DoDot:1
+32 SET LATEXT=$$CVPARM^BSTSMAP1("LAT",$PIECE(LAT,"|",2))
+33 SET NARR=NARR_"|"_DESCT_"|"_LATEXT
End DoDot:1
+34 IF '$TEST
SET NARR=NARR_"|"_DESCT
+35 SET TYPE=$PIECE($PIECE(INP,U,8),"|",1)
+36 ;I TYPE'["." S TYPE=TYPE_"."
+37 ;Handle Prenatal 1.0 POV sets
+38 IF $PIECE(INP,U,5)["|"
IF DESCT=""
Begin DoDot:1
+39 SET NARR=$PIECE(INP,U,5)
+40 SET TYPE=$TRANSLATE($PIECE(INP,U,3),"`")
+41 IF TYPE]""
SET TYPE=$PIECE($$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT),U,2)
+42 SET SPEC=1
SET PROB=""
End DoDot:1
+43 IF $EXTRACT($PIECE(INP,U,3))="`"
Begin DoDot:1
+44 SET NARR=$PIECE(INP,U,5)
+45 SET TYPE=$TRANSLATE($PIECE(INP,U,3),"`")
+46 IF TYPE]""
SET TYPE=$PIECE($$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT),U,2)
+47 SET SPEC=1
SET PROB=""
End DoDot:1
+48 ;
+49 SET RET=$$FNDNARR^BGOUTL2(NARR)
+50 IF RET<0
QUIT
+51 SET NARR=$SELECT(RET:"`"_RET,1:"")
SET RET=""
+52 ;Get ICD code for POV from the Apelon
+53 ;MSC/MGH Updated in patch 18 to send in extra data
+54 SET FRAC=$PIECE(INP,U,14)
+55 SET PTDATA=$$GETDATA(DFN,VFIEN,FRAC)
+56 SET SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1^^"_PTDATA)
+57 IF FIVE=""&('SPEC)
Begin DoDot:1
+58 SET FIVE=$PIECE(SNODATA,U,5)
+59 SET TYPE2=$PIECE($PIECE(SNODATA,U,5),";",1)
+60 IF TYPE2'["."
SET TYPE2=TYPE2_"."
+61 IF TYPE2'=""
SET TYPE=TYPE2
End DoDot:1
+62 SET CANDUP=1
+63 IF TYPE=""
Begin DoDot:1
+64 ;Patch 14 check for which undefined code to use
+65 IF $$AICD^BGOUTL2
Begin DoDot:2
+66 SET IMP=$$IMP^ICDEX("10D",DT)
+67 IF IMP<VDT!(IMP=VDT)
SET TYPE="ZZZ.999"
+68 IF IMP>VDT
SET TYPE=".9999"
End DoDot:2
+69 IF '$TEST
SET TYPE=".9999"
End DoDot:1
+70 IF TYPE'["."
SET TYPE=TYPE_"."
+71 SET TYPE=$PIECE($$CODEN^ICDEX(TYPE,80),"~",1)
+72 IF 'TYPE
SET RET=$$ERR^BGOUTL(1094)
QUIT
+73 IF 'VFIEN
DO CHECK^BGOVPOV(.DUP,TYPE_U_DFN_U_+$GET(^AUPNVSIT(VIEN,0))_U_SNOMED_U_LAT)
+74 IF DUP'=""
SET RET=DUP
+75 IF RET
QUIT
+76 ;Injury data
+77 SET (CAUSEDX,REVISIT,ECODE,PLACE,INJDT,ONSET)=""
+78 IF INJ'=""
Begin DoDot:1
+79 SET CAUSEDX=$PIECE(INJ,U,1)
+80 SET REVISIT=$PIECE(INJ,U,4)
+81 SET ECODE=$PIECE(INJ,U,2)
+82 SET PLACE=$PIECE(INJ,U,3)
+83 SET INJDT=$$CVTDATE^BGOUTL($PIECE(INJ,U,5))
+84 SET INJDT=$PIECE(INJDT,".",1)
+85 SET ONSET=$$CVTDATE^BGOUTL($PIECE(INJ,U,6))
End DoDot:1
+86 ;
+87 ;Provider Information
+88 SET PRIM=$PIECE(INP,U,9)
+89 SET PRIM=$SELECT($LENGTH(PRIM):PRIM,$$FNDPRI^BGOVPOV1(VIEN):"S",1:"P")
+90 SET PRV=$PIECE(INP,U,10)
+91 SET RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
+92 IF RET
QUIT
+93 ;
+94 IF 'VFIEN
Begin DoDot:1
+95 DO VFNEW^BGOUTL2(.RET,FNUM,TYPE,VIEN,$SELECT(CANDUP:"",1:"POV"))
+96 IF RET>0
SET VFIEN=RET
SET SAVRET=RET
SET RET=""
End DoDot:1
IF 'VFIEN
QUIT
+97 IF '$TEST
SET SAVRET=VFIEN
+98 SET FDA=$NAME(FDA(FNUM,VFIEN_","))
+99 SET @FDA@(.01)="`"_TYPE
+100 SET @FDA@(.04)=NARR
+101 ;S @FDA@(.05)=STAGE
+102 ;S @FDA@(.06)=MOD
+103 ;Patch 18
SET @FDA@(.29)=NORM
+104 SET @FDA@(.07)=CAUSEDX
+105 SET @FDA@(.08)=REVISIT
+106 SET @FDA@(.09)=$SELECT(ECODE'="":ECODE,1:"")
+107 SET @FDA@(.11)=PLACE
+108 SET @FDA@(.12)=PRIM
+109 SET @FDA@(.13)=INJDT
+110 ;P6
SET @FDA@(.17+OFF)=ONSET
+111 IF PROB'=""
SET @FDA@(.16)="`"_PROB
+112 ;p20
SET @FDA@(1104)=$SELECT(LAT="":"@",1:LAT)
+113 SET @FDA@(1101)=SNOMED
+114 SET @FDA@(1102)=DESCT
+115 ;P23
SET @FDA@(1106)=FRAC
+116 SET @FDA@(1201)="N"
+117 ; PATCH 5
SET @FDA@(1204)="`"_DUZ
+118 ;IHS/MSC/MGH added new fields patch 11
+119 IF VFNEW
Begin DoDot:1
+120 SET @FDA@(1216)="N"
+121 SET @FDA@(1217)="`"_DUZ
End DoDot:1
+122 SET @FDA@(1218)="N"
+123 SET @FDA@(1219)="`"_DUZ
+124 SET RET=$$UPDATE^BGOUTL(.FDA,"E@")
+125 IF RET
IF VFNEW
IF $$DELETE^BGOUTL(FNUM,VFIEN)
+126 IF RET
QUIT
+127 ;IHS/MSC/MGH Patch 13 check for qualifiers
+128 IF NEW=1
DO QUALB^BGOVPOV1(.RET,PROB,VFIEN)
+129 IF QUAL'=""
DO QUAL^BGOVPOV1(.RET,VFIEN,QUAL)
+130 SET PRIM=$SELECT(PRIM="Primary":"P",PRIM="PRIMARY":"P",PRIM="P":"P",1:"S")
+131 IF PRIM="P"
Begin DoDot:1
+132 DO SETPRI^BGOVPOV(.RET,VFIEN_U_PRIM,1)
+133 IF RET>0
SET VFIEN=RET
SET RET=""
End DoDot:1
IF RET
QUIT
+134 ;E I $$FIXVPOVS^BGOVPOV1(VIEN,.VFIEN) ; Fix VPOV sequencing
+135 DO VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
+136 ;Check for asthma diagnoses
+137 SET CONTROL=$PIECE(INP,U,11)
+138 IF DUZ("AG")="I"
Begin DoDot:1
+139 NEW ASTHMA
+140 ;IHS/MSC/MGH Patch 15, change to DESCT
+141 SET ASTHMA=$$CHECK^BGOASLK(TYPE,DESCT)
+142 IF ASTHMA=1
SET RET=RET_U_ASTHMA
+143 IF CONTROL="NONE RECORDED"
SET CONTROL=""
+144 IF CONTROL'=""
DO ASTHMA^BGOVPOV3(DFN,CONTROL,VIEN)
+145 ;Check for bulletin for new dx
+146 NEW DA,X,APCDDATE,APCDVSIT,ATXAD,APCDPAT,AUPNPAT
+147 SET DA=VFIEN
SET X=TYPE
+148 SET APCDDATE=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
+149 SET APCDVSIT=VIEN
SET ATXAD=""
SET (APCDPAT,AUPNPAT)=DFN
+150 DO ^ATXPOV
End DoDot:1
+151 SET RET=SAVRET
+152 ;Add POV to the problem multiple
+153 IF PROB=""
QUIT
+154 IF $DATA(^AUPNPROB(PROB,14,"B",VIEN))
QUIT
+155 NEW PRIEN,FDA,IEN,ERR
+156 IF VFNEW
Begin DoDot:1
+157 SET PRIEN="+1,"_PROB_","
+158 SET FDA(9000011.14,PRIEN,.01)=VIEN
+159 DO UPDATE^DIE(,"FDA","IEN","ERR")
+160 IF $DATA(ERR)
SET RET="Unable to update problem multiple"
End DoDot:1
+161 QUIT
+162 ;Input=CODIEN SNOMED concept ID
+163 ; 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
ADDICD(RET,INP,QUAL,INJ,VFIEN,DUP,FIVE,SPEC) ;Add any additional ICD codes as POV
+1 NEW DUP2,SFIVE,X,ADDI,DEL
+2 SET DEL=";"
SET DUP2=""
+3 SET SFIVE=$GET(FIVE)
+4 SET X=$LENGTH(FIVE,DEL)
+5 FOR ADDI=2:1:X
Begin DoDot:1
+6 SET $PIECE(INP,U,8)=$PIECE(SFIVE,DEL,ADDI)
+7 SET $PIECE(INP,U,9)="Secondary"
+8 DO SET2^BGOVPOV2(.RET,INP,QUAL,INJ,VFIEN,.DUP2,.FIVE,SPEC)
End DoDot:1
+9 QUIT
+10 ; Return V File #
GETDATA(DFN,VFIEN,FRAC) ;EP
+1 NEW STRING,AF,DATAI,SNO,EPI,HTERM,TRM,LTRM
+2 SET STRING=""
SET EPI=""
+3 SET FRAC=$GET(FRAC)
+4 SET STRING="VST="_VIEN_";PRB="_PROB
+5 IF QUAL'=""
SET EPI=$PIECE(QUAL,U,4)
+6 IF '$TEST
IF +VFIEN
SET EPI=$ORDER(^AUPNVPOV(+VFIEN,14,"B",""))
+7 IF EPI]""
SET STRING=STRING_";EPI="_EPI
+8 IF NORM'=""
Begin DoDot:1
+9 SET AF=$SELECT(NORM=71994000:"With",NORM=162656002:"Without",1:"")
+10 SET STRING=STRING_";AF="_AF
End DoDot:1
+11 SET DATAI=0
FOR
SET DATAI=$ORDER(^AUPNPROB(PROB,13,DATAI))
IF '+DATAI
QUIT
Begin DoDot:1
+12 SET SNO=$PIECE($GET(^AUPNPROB(PROB,13,DATAI,0)),U,1)
+13 IF SNO'=""
IF $$CVPARM^BSTSMAP1("SEV",SNO)'="Severity"
SET STRING=STRING_";SEV="_SNO
End DoDot:1
+14 ;Patch 23 add fracture healing
+15 IF FRAC'=""
SET HTERM=$$CVPARM^BSTSMAP1("HEAL",FRAC)
IF HTERM]""
SET STRING=STRING_";HEAL="_HTERM
+16 QUIT STRING
FNUM() QUIT 9000010.07
