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

BGOVPOV3.m

Go to the documentation of this file. 
  1. 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
  1.  ; Patch 23 added for fracture data
  1.  ; Add/Edit VPOV data
  1.  ;  INP = null^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4] ^ Prov Text [5] ^ Descriptive CT [6] ^
  1.  ;        SNOMED CT [7] ^ ^Primary/Seconday ^ Provider IEN [10]^ asthma control [11] ^norm/abn [12] ^ laterality [13] ^ fracture [14]
  1.  ;  LIST(n) = POV IEN [1]
  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.  ;  NORM = SNOMED
  1. EDIT(RET,INP,LIST,QUAL,INJ,NORM) ;EP
  1.  N VIEN,DFN,TYPE,ITYPE,NARR,STAGE,MOD,CAUSEDX,REVISIT,ECODE,PLACE,CONTROL,SNOMED,DESC,TEXT,SAVRET,VDT
  1.  N PRIM,INJDT,ONSET,FDA,FNUM,VFNEW,PRV,TYPE2,DUP,LAT,LATEXT,FIRST
  1.  N CANDUP,OFF,APCDVSIT,PXCEVIEN,PROB,NEW,DESCT,SNODATA,IMP,FRAC
  1.  N PTDATA,CHK,POVLST,IENS,POV,RET3,SPEC,VFIEN,X,FIRST
  1.  S FNUM=$$FNUM
  1.  S CHK=0,IENS="",SPEC="",FIRST=""
  1.  S FIVE=$G(FIVE),DUP=$G(DUP)
  1.  S NEW=0,RET3=""
  1.  S 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 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
  1.  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.  ;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.  S RET=$$FNDNARR^BGOUTL2(NARR)
  1.  Q:RET<0
  1.  S NARR=$S(RET:"`"_RET,1:""),RET=""
  1.  D GETPOVS(.LIST,.POVLST)
  1.  S FRAC=$P(INP,U,14)
  1.  S PTDATA=$$GETDATA^BGOVPOV2(DFN,$G(LIST(0)),FRAC)
  1.  S SNODATA=$$CONC^BSTSAPI(SNOMED_"^^"_VDT_"^1^^"_PTDATA)
  1.  I 'SPEC D
  1.  .S FIVE=$P(SNODATA,U,5)
  1.  .S FIRST=$P(FIVE,";",1)
  1.  .S CHK=$$MATCH^BGOVPOV3(FIVE,.POVLST)
  1.  .I CHK=1 D
  1.  ..D DELPOV(.LIST,PROB)
  1.  ..S VFNEW=1
  1.  ..S DEL=";"
  1.  ..S X=$L(FIVE,DEL)
  1.  ..F I=1:1:X D
  1.  ...S X2=$P(FIVE,DEL,I)
  1.  ...S TYPE=X2,VFIEN=0,NEW=1
  1.  ...D STORE
  1.  .I CHK=0 D
  1.  ..S VFNEW=0
  1.  ..S POV="" F  S POV=$O(LIST(POV)) Q:POV=""  D
  1.  ...S VFIEN=$P(LIST(POV),U,1)
  1.  ...S TYPE=$$GET1^DIQ(9000010.07,VFIEN,.01)
  1.  ...D STORE
  1.  I SPEC D STORE
  1.  S RET=IENS
  1.  Q
  1. MATCH(FIVE,POVLST) ;Match up the ICDs on the problem with the SNOMED
  1.  N DEL,X,X2,I,SFIVE,CHK2
  1.  S CHK2=0
  1.  S DEL=";"
  1.  S SFIVE=$G(FIVE)
  1.  S X=$L(SFIVE,DEL)
  1.  S CNT=$G(POVLST(0))
  1.  Q:X'=CNT 1
  1.  F I=1:1:X D
  1.  .S X2=$P(SFIVE,DEL,I)
  1.  .I '$D(POVLST(X2)) S CHK2=1                                           ;There is a code in the snomed lookup not in the POV file
  1.  Q CHK2
  1. GETPOVS(LIST,POVLST) ;Get the ICD codes currently stored
  1.  N IEN,CODE,ICDCODE,CNT
  1.  S CNT=0
  1.  S IEN="" F  S IEN=$O(LIST(IEN)) Q:IEN=""  D
  1.  .S ICDCODE=$P(LIST(IEN),U,1)
  1.  .S CODE=$$GET1^DIQ(9000010.07,ICDCODE,.01)
  1.  .S POVLST(CODE)="",CNT=CNT+1
  1.  S POVLST(0)=CNT
  1.  Q
  1. DELPOV(LIST,PROB) ;Delete the POVs in the list
  1.  N VPOV,RET1,POVICD
  1.  S VPOV="" F  S VPOV=$O(LIST(VPOV)) Q:VPOV=""  D
  1.  .S POVICD=$P(LIST(VPOV),U,1)
  1.  .D DEL^BGOVPOV(.RET1,POVICD,PROB)
  1.  Q
  1. STORE ;Store the POV
  1.  ;MSC/MGH Updated in patch 18 to send in extra data
  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 ITYPE=$P($$CODEN^ICDEX(TYPE,80),"~",1)
  1.  I 'ITYPE S RET=$$ERR^BGOUTL(1094) Q
  1.  I 'VFIEN  D CHECK^BGOVPOV(.DUP,ITYPE_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,ITYPE,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)="`"_ITYPE
  1.  S @FDA@(.04)=NARR
  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.  ;Patch 20
  1.  S PRIM=$S(PRIM="Primary":"P",PRIM="PRIMARY":"P",PRIM="P":"P",1:"S")
  1.  I PRIM="P"&(FIRST=TYPE) S @FDA@(.12)=PRIM
  1.  E  S @FDA@(.12)="S"
  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.  I PRIM="P"&(FIRST=TYPE) 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 Removed P18
  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(ITYPE,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=ITYPE
  1.  .S APCDDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
  1.  .S APCDVSIT=VIEN,ATXAD="",(APCDPAT,AUPNPAT)=DFN
  1.  .D ^ATXPOV
  1.  S IENS=IENS_";"_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.  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. ASTHMA(DFN,CONTROL,VIEN) ;Find last control, if it has changed store the change
  1.  N LEVEL,INP,RET,RETURN,AIEN
  1.  Q:CONTROL="@"
  1.  ;IHS/MSC/MGH change in patch 10 to always store, not just if a change
  1.  S RETURN=$$ACONTROL^BGOASLK(DFN,VIEN)
  1.  S LEVEL=$P(RETURN,U,1),AIEN=$P(RETURN,U,2)
  1.  I LEVEL'=CONTROL D
  1.  .S INP=AIEN_U_VIEN_U_CONTROL
  1.  .D SET^BGOVAST(.RET,INP)
  1.  Q
  1. FNUM() Q 9000010.07