Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGOVPOV2

BGOVPOV2.m

Go to the documentation of this file. 
  1. 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
  1.  ; Add/Edit VPOV data
  1.  ;  INP = VPOV IEN [1] ^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4] ^ Prov Text [5] ^ Descriptive CT [6] ^
  1.  ;        SNOMED CT [7] ^ ICD code [8] ^ Primary/Secondary [9] ^ Provider IEN [10]^ asthma control [11] ^ norm/abn [12] ^ Laterality [13] ^ Fracture [14]
  1.  ;  QUAL = Q [1] ^ TYPE [2] ^IEN (If edit)  [3] ^ SNOMED [4] ^ BY [5] ^WHEN [6] ^ DEL [7]
  1.  ;  INJ  = Cause DX[1] ^ Injury Code [2] ^ Injury Place [3] ^ First/Revisit [4] ^ Injury Dt [5] ^ Onset Date [6]
  1.  ;  SPEC = Special cases
  1.  ;  NORM = SNOMED
  1. SET2(RET,INP,QUAL,INJ,VFIEN,DUP,FIVE,SPEC,NORM) ;EP
  1.  N VIEN,DFN,TYPE,NARR,STAGE,MOD,CAUSEDX,REVISIT,ECODE,PLACE,CONTROL,SNOMED,DESC,TEXT,SAVRET,VDT,LAT,LATEXT,POVLAT
  1.  N PRIM,INJDT,ONSET,FDA,FNUM,VFNEW,FRAC,PRV,TYPE2,CANDUP,OFF,APCDVSIT,PXCEVIEN,PROB,NEW,DESCT,SNODATA,IMP,PTDATA,RET3
  1.  S FNUM=$$FNUM
  1.  S FIVE=$G(FIVE),DUP=$G(DUP)
  1.  S NEW=0,RET3="",SPEC=$G(SPEC)
  1.  S VFIEN=$G(VFIEN),NORM=$G(NORM)
  1.  S INJ=$G(INJ)
  1.  S QUAL=$G(QUAL)
  1.  ;MSC/MGH - 07/08/09 - Offset to support VistA and RPMS
  1.  S OFF=$S($G(DUZ("AG"))="I":0,1:9999999)
  1.  ;S VFIEN=+INP
  1.  I +VFIEN=0 S NEW=1
  1.  S VFNEW='VFIEN
  1.  S VIEN=$P(INP,U,2)
  1.  S PROB=$P(INP,U,3)
  1.  I 'VIEN S RET=$$ERR^BGOUTL(1008) Q
  1.  I $G(DUZ("AG"))="I" S APCDVSIT=VIEN
  1.  E  S PXCEVIEN=VIEN
  1.  S DFN=$P(INP,U,4)
  1.  S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
  1.  Q:RET
  1.  ;Patch 13 SNOMED CT data
  1.  S VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
  1.  S SNOMED=$P(INP,U,7)
  1.  S NARR=$P(INP,U,5),DESCT=$P(INP,U,6)
  1.  S NARR=$TR(NARR,"^|","")
  1.  ;IHS/MSC/MGH changes for laterality p20
  1.  S LAT=$P(INP,U,13)
  1.  I LAT="272741003|261665006"!(LAT="272741003|") S LAT=""
  1.  I LAT="" S LAT=$$GET1^DIQ(9000011,PROB,.22,"I")
  1.  I LAT'="" D
  1.  .S LATEXT=$$CVPARM^BSTSMAP1("LAT",$P(LAT,"|",2))
  1.  .S NARR=NARR_"|"_DESCT_"|"_LATEXT
  1.  E  S NARR=NARR_"|"_DESCT
  1.  S TYPE=$P($P(INP,U,8),"|",1)
  1.  ;I TYPE'["." S TYPE=TYPE_"."
  1.  ;Handle Prenatal 1.0 POV sets
  1.  I $P(INP,U,5)["|",DESCT="" D
  1.  . S NARR=$P(INP,U,5)
  1.  . S TYPE=$TR($P(INP,U,3),"`")
  1.  . I TYPE]"" S TYPE=$P($$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT),U,2)
  1.  . S SPEC=1,PROB=""
  1.  I $E($P(INP,U,3))="`" D
  1.  . S NARR=$P(INP,U,5)
  1.  . S TYPE=$TR($P(INP,U,3),"`")
  1.  . I TYPE]"" S TYPE=$P($$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT),U,2)
  1.  . S SPEC=1,PROB=""
  1.  ;
  1.  S RET=$$FNDNARR^BGOUTL2(NARR)
  1.  Q:RET<0
  1.  S NARR=$S(RET:"`"_RET,1:""),RET=""
  1.  ;Get ICD code for POV from the Apelon
  1.  ;MSC/MGH Updated in patch 18 to send in extra data
  1.  S FRAC=$P(INP,U,14)
  1.  S PTDATA=$$GETDATA(DFN,VFIEN,FRAC)
  1.  S SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1^^"_PTDATA)
  1.  I FIVE=""&('SPEC) D
  1.  .S FIVE=$P(SNODATA,U,5)
  1.  .S TYPE2=$P($P(SNODATA,U,5),";",1)
  1.  .I TYPE2'["." S TYPE2=TYPE2_"."
  1.  .I TYPE2'="" S TYPE=TYPE2
  1.  S CANDUP=1
  1.  I TYPE="" D
  1.  .;Patch 14 check for which undefined code to use
  1.  .I $$AICD^BGOUTL2 D
  1.  ..S IMP=$$IMP^ICDEX("10D",DT)
  1.  ..I IMP<VDT!(IMP=VDT) S TYPE="ZZZ.999"
  1.  ..I IMP>VDT S TYPE=".9999"
  1.  .E  S TYPE=".9999"
  1.  I TYPE'["." S TYPE=TYPE_"."
  1.  S TYPE=$P($$CODEN^ICDEX(TYPE,80),"~",1)
  1.  I 'TYPE S RET=$$ERR^BGOUTL(1094) Q
  1.  I 'VFIEN  D CHECK^BGOVPOV(.DUP,TYPE_U_DFN_U_+$G(^AUPNVSIT(VIEN,0))_U_SNOMED_U_LAT)
  1.  I DUP'="" S RET=DUP
  1.  Q:RET
  1.  ;Injury data
  1.  S (CAUSEDX,REVISIT,ECODE,PLACE,INJDT,ONSET)=""
  1.  I INJ'="" D
  1.  .S CAUSEDX=$P(INJ,U,1)
  1.  .S REVISIT=$P(INJ,U,4)
  1.  .S ECODE=$P(INJ,U,2)
  1.  .S PLACE=$P(INJ,U,3)
  1.  .S INJDT=$$CVTDATE^BGOUTL($P(INJ,U,5))
  1.  .S INJDT=$P(INJDT,".",1)
  1.  .S ONSET=$$CVTDATE^BGOUTL($P(INJ,U,6))
  1.  ;
  1.  ;Provider Information
  1.  S PRIM=$P(INP,U,9)
  1.  S PRIM=$S($L(PRIM):PRIM,$$FNDPRI^BGOVPOV1(VIEN):"S",1:"P")
  1.  S PRV=$P(INP,U,10)
  1.  S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
  1.  Q:RET
  1.  ;
  1.  I 'VFIEN D  Q:'VFIEN
  1.  .D VFNEW^BGOUTL2(.RET,FNUM,TYPE,VIEN,$S(CANDUP:"",1:"POV"))
  1.  .S:RET>0 VFIEN=RET,SAVRET=RET,RET=""
  1.  E  S SAVRET=VFIEN
  1.  S FDA=$NA(FDA(FNUM,VFIEN_","))
  1.  S @FDA@(.01)="`"_TYPE
  1.  S @FDA@(.04)=NARR
  1.  ;S @FDA@(.05)=STAGE
  1.  ;S @FDA@(.06)=MOD
  1.  S @FDA@(.29)=NORM    ;Patch 18
  1.  S @FDA@(.07)=CAUSEDX
  1.  S @FDA@(.08)=REVISIT
  1.  S @FDA@(.09)=$S(ECODE'="":ECODE,1:"")
  1.  S @FDA@(.11)=PLACE
  1.  S @FDA@(.12)=PRIM
  1.  S @FDA@(.13)=INJDT
  1.  S @FDA@(.17+OFF)=ONSET  ;P6
  1.  I PROB'="" S @FDA@(.16)="`"_PROB
  1.  S @FDA@(1104)=$S(LAT="":"@",1:LAT)   ;p20
  1.  S @FDA@(1101)=SNOMED
  1.  S @FDA@(1102)=DESCT
  1.  S @FDA@(1106)=FRAC   ;P23
  1.  S @FDA@(1201)="N"
  1.  S @FDA@(1204)="`"_DUZ  ; PATCH 5
  1.  ;IHS/MSC/MGH added new fields patch 11
  1.  I VFNEW D
  1.  .S @FDA@(1216)="N"
  1.  .S @FDA@(1217)="`"_DUZ
  1.  S @FDA@(1218)="N"
  1.  S @FDA@(1219)="`"_DUZ
  1.  S RET=$$UPDATE^BGOUTL(.FDA,"E@")
  1.  I RET,VFNEW,$$DELETE^BGOUTL(FNUM,VFIEN)
  1.  Q:RET
  1.  ;IHS/MSC/MGH Patch 13 check for qualifiers
  1.  I NEW=1 D QUALB^BGOVPOV1(.RET,PROB,VFIEN)
  1.  I QUAL'="" D QUAL^BGOVPOV1(.RET,VFIEN,QUAL)
  1.  S PRIM=$S(PRIM="Primary":"P",PRIM="PRIMARY":"P",PRIM="P":"P",1:"S")
  1.  I PRIM="P" D  Q:RET
  1.  .D SETPRI^BGOVPOV(.RET,VFIEN_U_PRIM,1)
  1.  .S:RET>0 VFIEN=RET,RET=""
  1.  ;E  I $$FIXVPOVS^BGOVPOV1(VIEN,.VFIEN)  ; Fix VPOV sequencing
  1.  D VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
  1.  ;Check for asthma diagnoses
  1.  S CONTROL=$P(INP,U,11)
  1.  I DUZ("AG")="I" D
  1.  . N ASTHMA
  1.  . ;IHS/MSC/MGH Patch 15, change to DESCT
  1.  . S ASTHMA=$$CHECK^BGOASLK(TYPE,DESCT)
  1.  . I ASTHMA=1 S RET=RET_U_ASTHMA
  1.  . I CONTROL="NONE RECORDED" S CONTROL=""
  1.  . I CONTROL'="" D ASTHMA^BGOVPOV3(DFN,CONTROL,VIEN)
  1.  .;Check for bulletin for new dx
  1.  .N DA,X,APCDDATE,APCDVSIT,ATXAD,APCDPAT,AUPNPAT
  1.  .S DA=VFIEN,X=TYPE
  1.  .S APCDDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
  1.  .S APCDVSIT=VIEN,ATXAD="",(APCDPAT,AUPNPAT)=DFN
  1.  .D ^ATXPOV
  1.  S RET=SAVRET
  1.  ;Add POV to the problem multiple
  1.  Q:PROB=""
  1.  Q:$D(^AUPNPROB(PROB,14,"B",VIEN))
  1.  N PRIEN,FDA,IEN,ERR
  1.  I VFNEW D
  1.  .S PRIEN="+1,"_PROB_","
  1.  .S FDA(9000011.14,PRIEN,.01)=VIEN
  1.  .D UPDATE^DIE(,"FDA","IEN","ERR")
  1.  .I $D(ERR) S RET="Unable to update problem multiple"
  1.  Q
  1.  ;Input=CODIEN  SNOMED concept ID
  1.  ;      VIEN    Visit IEN
  1. INJURY(RET,SNOMED,VIEN) ;Is this problem an injury?
  1.  N ICD,SNODATA,VDT
  1.  S RET=0
  1.  I 'SNOMED S RET="-1^Missing SNOMED CT"
  1.  S VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
  1.  S SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1")
  1.  S ICD=$P($P(SNODATA,U,5),";",1)
  1.  I $$AICD^BGOUTL2 D ICD10(.RET,ICD) Q
  1.  S X=$$ICDDX^ICDCODE(ICD)
  1.  S ICD=$P(X,U,2)
  1.  I ICD>799.9&(ICD<1000) S RET=1
  1.  Q
  1. ICD10(RET,ICD) ;New entry point for ICD-10
  1.  N IMP,X
  1.  S IMP=$$IMP^ICDEX("10D",DT)
  1.  I IMP<VDT D
  1.  .I $E(ICD,1)="S" S RET=1
  1.  .I $E(ICD,1)="T",$E(ICD,2,3)<89 S RET=1
  1.  I IMP>VDT D
  1.  .I ICD>799.9&(ICD<1000) S RET=1
  1.  Q
  1. ADDICD(RET,INP,QUAL,INJ,VFIEN,DUP,FIVE,SPEC) ;Add any additional ICD codes as POV
  1.  N DUP2,SFIVE,X,ADDI,DEL
  1.  S DEL=";",DUP2=""
  1.  S SFIVE=$G(FIVE)
  1.  S X=$L(FIVE,DEL)
  1.  F ADDI=2:1:X D
  1.  .S $P(INP,U,8)=$P(SFIVE,DEL,ADDI)
  1.  .S $P(INP,U,9)="Secondary"
  1.  .D SET2^BGOVPOV2(.RET,INP,QUAL,INJ,VFIEN,.DUP2,.FIVE,SPEC)
  1.  Q
  1.  ; Return V File #
  1. GETDATA(DFN,VFIEN,FRAC) ;EP
  1.  N STRING,AF,DATAI,SNO,EPI,HTERM,TRM,LTRM
  1.  S STRING="",EPI=""
  1.  S FRAC=$G(FRAC)
  1.  S STRING="VST="_VIEN_";PRB="_PROB
  1.  I QUAL'="" S EPI=$P(QUAL,U,4)
  1.  E  I +VFIEN S EPI=$O(^AUPNVPOV(+VFIEN,14,"B",""))
  1.  I EPI]"" S STRING=STRING_";EPI="_EPI
  1.  I NORM'="" D
  1.  .S AF=$S(NORM=71994000:"With",NORM=162656002:"Without",1:"")
  1.  .S STRING=STRING_";AF="_AF
  1.  S DATAI=0 F  S DATAI=$O(^AUPNPROB(PROB,13,DATAI)) Q:'+DATAI  D
  1.  .S SNO=$P($G(^AUPNPROB(PROB,13,DATAI,0)),U,1)
  1.  .I SNO'="",$$CVPARM^BSTSMAP1("SEV",SNO)'="Severity" S STRING=STRING_";SEV="_SNO
  1.  ;Patch 23 add fracture healing
  1.  I FRAC'="" S HTERM=$$CVPARM^BSTSMAP1("HEAL",FRAC) I HTERM]"" S STRING=STRING_";HEAL="_HTERM
  1.  Q STRING
  1. FNUM() Q 9000010.07