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

BGOPROB2.m

Go to the documentation of this file. 
  1. BGOPROB2 ; IHS/MSC/PLS - Provide Map Advice ;24-Jun-2016 13:46;du
  1.  ;;1.1;BGO COMPONENTS;**14,15,20,21**;Mar 20, 2007;Build 1
  1.  ;---------------------------------------------
  1.  ;Return the map advice for
  1. MAP(DATA,LIST) ;EP GET MAP ADVICE
  1.  N IN,OUT,SNO,ARR,X,CNT,ADV,CNT2,MCNT,I
  1.  S DATA=$$TMPGBL
  1.  S CNT=0
  1.  S I="" F  S I=$O(LIST(I)) Q:I=""  D
  1.  .S SNO=$G(LIST(I))
  1.  .S CNT=CNT+1
  1.  .S @DATA@(CNT)="C"_U_SNO
  1.  .S IN=SNO_"^1"
  1.  .S OUT="ARR"
  1.  .;S X=$$MPADVICE^BSTSAPI(.OUT,.IN)
  1.  .S X=$$I10ADV^BSTSAPI(.OUT,.IN)
  1.  .S CNT2=0,MCNT=0
  1.  .F  S CNT2=$O(ARR(CNT2)) Q:CNT2=""  D
  1.  ..S ADV=$G(ARR(CNT2))
  1.  ..S CNT=CNT+1
  1.  ..S @DATA@(CNT)="~t"_U_CNT2_U_ADV
  1.  .I CNT2=0 D
  1.  ..S CNT=CNT+1
  1.  ..S @DATA@(CNT)="~t"_U_1_U_"No Map advice available for this SNOMED term"
  1.  Q
  1. CHK(RET,PRIEN) ;Check to see if it is OK to delete a problem
  1.  ;Check and see if there are any V Care Plan entries for this problem
  1.  ;If there are, the problem cannot be deleted Patch 13&14
  1.  N X,SIEN,STATUS
  1.  I +$O(^AUPNPROB(+PRIEN,14,"B",0))!(+$O(^AUPNPROB(+PRIEN,15,"B",0))) S RET="-1^Problem has been used for a visit and cannot be deleted. Check Problem Details."  Q
  1.  S X=0,RET=1
  1.  F  S X=$O(^AUPNCPL("B",+PRIEN,X)) Q:X=""!(+RET<0)  D
  1.  .S SIEN=$C(0) S SIEN=$O(^AUPNCPL(X,11,SIEN),-1)
  1.  .S STATUS=$P($G(^AUPNCPL(X,11,SIEN,0)),U,1)
  1.  .I STATUS'="E" S RET="-1^Care Plan entries are stored. Check Problem Details. Problem cannot be deleted"
  1.  Q:+RET<0
  1.  S X=0
  1.  F  S X=$O(^AUPNVVI("B",+PRIEN,X)) Q:X=""!(+RET<0)  D
  1.  .I $$GET1^DIQ(9000010.58,X,.06,"I")'=1 S RET="-1^Visit instructions are stored. Check Problem Details. Problem cannot be deleted"
  1.  F  S X=$O(^AUPNVOB("B",+PRIEN,X)) Q:X=""!(+RET<0)  D
  1.  .I $$GET1^DIQ(9000010.43,X,.06,"I")'=1 S RET="-1^OB notes are stored. Check Problem Details. Problem cannot be deleted"
  1.  Q
  1. CLASS(REC,DFN,ASM) ;Return asthma class information
  1.  N CLASS,CONTROL,ASTHMA,DATA
  1.  S DATA=""
  1.  S CLASS=$P(REC,U,15)
  1.  S ASM=$G(ASM)
  1.  ;P20 removed check for classification
  1.  ;I CLASS'="" D
  1.  I ASM=1 D
  1.  .;Return asthma data for this problem
  1.  .;Patch 20 only return classification, not control
  1.  .S ASTHMA=""
  1.  .S CLASS=$S(CLASS=1:"INTERMITTENT",CLASS=2:"MILD PERSISTENT",CLASS=3:"MODERATE PERSISTENT",CLASS=4:"SEVERE PERSISTENT",1:"")
  1.  .;D GET2^BGOVAST(.ASTHMA,DFN)
  1.  .;S CONTROL=$P(ASTHMA,U,4)
  1.  .;S DATA="A"_U_CLASS_U_CONTROL_U_$P(ASTHMA,U,2)
  1.  .S DATA="A"_U_CLASS
  1.  Q DATA
  1. INJCHK(PRIEN,VIEN) ;Return most recent injury information
  1.  N DATA,OUTPT,VST,FNUM,REC,CAUSE,REVISIT,IDP,IPL,ICCIEN,FOUND,VDATE
  1.  N ICCODE,ICAU,IDT
  1.  S DATA="",FNUM=9000010.07,FOUND=0
  1.  ;Get the latest visit where this problem was used as a POV
  1.  S VST=$O(^AUPNPROB(PRIEN,14,"B",9999999),-1)  D
  1.  .Q:'VST
  1.  .S OUTPT="" S OUTPT=$O(^AUPNPROB(PRIEN,14,"B",VST,OUTPT))
  1.  .I +OUTPT D
  1.  ..N VPOV
  1.  ..S FOUND=0
  1.  ..;Find the POV from the visit that is attached to the correct problem
  1.  ..S VPOV=0 F  S VPOV=$O(^AUPNVPOV("AD",VST,VPOV)) Q:VPOV=""!(FOUND=1)  D
  1.  ...S (CAUSE,REVISIT,IDT,IPL,ICCIEN)=""
  1.  ...I $P($G(^AUPNVPOV(VPOV,0)),U,16)=PRIEN D
  1.  ....S REC=$G(^AUPNVPOV(VPOV,0))
  1.  ....S VDATE=$$FMTDATE^BGOUTL($P($G(^AUPNVSIT(VST,0)),U))
  1.  ....;Get the injury fields
  1.  ....S CAUSE=$$EXTERNAL^DILFD(FNUM,.07,,$P(REC,U,7))
  1.  ....S REVISIT=$$EXTERNAL^DILFD(FNUM,.08,,$P(REC,U,8))
  1.  ....S IDT=$$FMTDATE^BGOUTL($P(REC,U,13))
  1.  ....S IPL=$P(REC,U,11)
  1.  ....I IPL'="" S IPL=$$EXTERNAL^DILFD(FNUM,.11,,IPL)_"~"_IPL
  1.  ....S ICCIEN=$P(REC,U,9)
  1.  ....S (ICCODE,ICAU)=""
  1.  ....S:ICCIEN ICAU=$P($$ICDDX^ICDEX(ICCIEN,VDATE,"","I"),U,4),ICCODE=$P($$ICDDX^ICDEX(ICCIEN,VDATE,"","I"),U,2)
  1.  ....I (CAUSE'="")!(REVISIT'="")!(IDT'="")!(IPL'="")!(ICCIEN'="") D
  1.  .....S FOUND=1
  1.  .....S DATA="H"_U_REVISIT_U_CAUSE_U_IDT_U_ICAU_U_ICCODE_U_IPL_U_VST
  1.  Q DATA
  1.  ;IHS/MSC/MGH check for duplicates
  1.  ;INP=SNOMED Concept CT ^ laterality code | laterality type ^ PRIEN
  1. DUPCHK(RET,INP) ;EP
  1.  N ESNO,F,ELAT,EXMNOPRB,ENOD,PRIEN,EEXT,DFN,MATCH,CONCID,CNT,STAT,IEN,I2,I1,LAT,CHK,USES,ARR,FND,LST,CNT2,CNK2,ETRM
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S CNT=0,FND=0,LST="",CNT2=0
  1.  S DFN=$P(INP,U,1)
  1.  S CONCID=$P(INP,U,2)
  1.  S CHK=$P(INP,U,3)
  1.  S LAT=$P(CHK,"|",2)
  1.  I LAT="" S CHK=""
  1.  S PRIEN=$P(INP,U,4)
  1.  D EQUIV^BSTSAPI("ARR",CONCID_"^"_CHK)
  1.  S I1="" F  S I1=$O(ARR(I1)) Q:I1=""  D
  1.  .S ENOD=$G(ARR(I1))
  1.  .S ESNO=$P(ENOD,U,1)
  1.  .S ELAT=$P(ENOD,U,2)
  1.  .S EEXT=$P(ENOD,U,3)
  1.  .S ETRM=$P(ENOD,U,4)
  1.  .I ELAT="" D
  1.  ..S IEN="" F  S IEN=$O(^AUPNPROB("APCT",DFN,ESNO,IEN)) Q:'+IEN  D
  1.  ...S STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
  1.  ...Q:STAT="D"
  1.  ...S F=$$SETDATA(.LST,.CNT,IEN,ENOD,.EXFND)
  1.  ...S:F FND=1
  1.  .I ELAT'="" D
  1.  ..S IEN="" F  S IEN=$O(^AUPNPROB("ASLT",DFN,ESNO,ELAT,IEN)) Q:'+IEN  D
  1.  ...S STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
  1.  ...Q:STAT="D"
  1.  ...S F=$$SETDATA(.LST,.CNT,IEN,ENOD,.EXFND)
  1.  ...S:F FND=1
  1.  .I FND=0,CONCID=ESNO,CHK=ELAT D
  1.  .. NEW PDST,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT
  1.  .. S PRMLST="" I $P(ELAT,"|",2)]"" S PRMLST="LAT="_$P(ELAT,"|",2)
  1.  .. S DDATA=$$CONC^BSTSAPI(CONCID_"^^^1^^"_PRMLST)
  1.  .. S PDST=$P(DDATA,U,4)
  1.  .. S DESCID=$P(DDATA,U,1)
  1.  .. ;
  1.  .. ;Get external laterality
  1.  .. S EXLAT="" I $TR(ELAT,"|")]"" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(ELAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(ELAT,"|",2))
  1.  .. ;
  1.  .. ;Get ICD, default status and prompt laterality
  1.  .. S ICD=$P(DDATA,U,5)
  1.  .. S DSTS=$P(DDATA,U,9)
  1.  .. S PMLT=$P(DDATA,U,8)
  1.  .. ;No match found - log that entry can be used
  1.  .. S CNT=$G(CNT)+1,LST(CNT)=0_U_ESNO_U_ELAT_U_DESCID_U_PDST_U_EEXT_U_EXLAT_U_ICD_U_U_DSTS_U_$S(PMLT:"Y",1:"")_U_ETRM
  1.  .. I EEXT S EXMNOPRB=1  ;Track if an exact match
  1.  ;Loop through results - eliminate others if exact match found
  1.  N TII,TNODE
  1.  S TII="" F  S TII=$O(LST(TII)) Q:'TII  D
  1.  . ;
  1.  . NEW TNODE,CONC,LAT,LATCHK
  1.  .S LATCHK=0
  1.  . S TNODE=$G(LST(TII))
  1.  .I +PRIEN D
  1.  ..S LAT=$$GET1^DIQ(9000011,PRIEN,.22,"I")
  1.  ..S CONC=$$GET1^DIQ(9000011,PRIEN,80001)
  1.  ..I LAT'=$P(TNODE,U,3) S LATCHK=1
  1.  ..I CONC'=$P(TNODE,U,1) S LATCHK=1
  1.  . ;Special logic for exact match found on IPL - Only include it
  1.  . I $D(LST("EXACT")) D  Q
  1.  .. NEW EXNODE
  1.  .. ;Get the exact match
  1.  .. S EXNODE=$G(LST("EXACT"))
  1.  .. ;
  1.  .. ;If not an exact match do not include
  1.  .. I '$P(TNODE,U,6) Q
  1.  .. ;Passed in problem is the same as the exact match problem
  1.  .. ;
  1.  .. I +PRIEN,PRIEN=$P(EXNODE,U,5) D  Q
  1.  ... ;
  1.  ... ;The user switched to the equivalent concept - update original
  1.  ... ;passed in problem info with new SNOMED/laterality information
  1.  ... I $P(TNODE,U,6)=1,$P(TNODE,U,1)=0 D  Q
  1.  .... NEW I
  1.  .... S EXNODE=$G(LST("EXACT"))
  1.  .... F I=5:1:9 S $P(TNODE,U,I)=$P(EXNODE,U,I)
  1.  .... S CNT2=CNT2+1,@RET@(CNT2)=TNODE
  1.  ... ;
  1.  ... ;The user picked the same concept - return original
  1.  ... I $P(TNODE,U,6)=1,$G(LST("EXACT"))=TII D  Q
  1.  .... Q:CONCID'=$P(TNODE,U)  ;Concept not the same
  1.  .... Q:LAT'=$P(TNODE,U,2)  ;Laterality not the same
  1.  .... S TNODE=$G(LST("EXACT"))
  1.  .... S CNT2=CNT2+1,@RET@(CNT2)=TNODE
  1.  .. ;
  1.  .. ;No passed in problem or not a match with exact
  1.  .. ;
  1.  .. ;If exact match, allow - GUI will utilize IPL problem returned
  1.  .. I $G(LST("EXACT"))=TII D  Q
  1.  ... S TNODE=$G(LST(TII))
  1.  ... S CNT2=CNT2+1,@RET@(CNT2)=TNODE
  1.  . ;
  1.  . ;Problem edit - changed SNOMED and it isn't a match on IPL
  1.  . ;update entry with passed in problem information
  1.  . I +PRIEN,$P(TNODE,U,1)=0 D  Q
  1.  .. S $P(TNODE,U,1)=+PRIEN
  1.  ..I LATCHK=1 S $P(TNODE,U,6)=0
  1.  .. S CNT2=CNT2+1,@RET@(CNT2)=TNODE
  1.  . ;
  1.  . ;Not an exact match on IPL, exact found by BSTS and edit fill entries
  1.  . I EXMNOPRB D  Q        ;Edit and an exact match was saved
  1.  .. I $P(TNODE,U,6) D  ;This is the exact match
  1.  ... S $P(TNODE,U,1)=+PRIEN
  1.  ... I +PRIEN=0 S EXMNOPRB=0
  1.  ...I LATCHK=1 S $P(TNODE,U,6)=0
  1.  ... S CNT2=CNT2+1,@RET@(CNT2)=TNODE
  1.  . ;
  1.  . ;No exact matches - save related ones
  1.  . I EXMNOPRB=0 S CNT2=CNT2+1,@RET@(CNT2)=TNODE
  1.  Q
  1. SETDATA(LST,CNT,IEN,DATA,EXFND) ;Get the needed data
  1.  N STRING,DESCID,PLAT,PCNC,PNAR,PDSC,PDST,ICD,PRMLST,DDATA,DSTS,PMLT
  1.  S STRING=""
  1.  ;If matching concept id and no laterality passed in, filter out those with laterality
  1.  S PLAT=$$GET1^DIQ(9000011,IEN_",",.22,"I") ;Laterality
  1.  I $P(DATA,U,2)="",PLAT]"" Q 0
  1.  S PCNC=$$GET1^DIQ(9000011,IEN_",",80001,"I") ;Concept ID
  1.  S PDSC=$$GET1^DIQ(9000011,IEN_",",80002,"I") ;Description ID
  1.  S PDST=$P($$DESC^BSTSAPI(PDSC_"^^1"),U,2) ;Description Term
  1.  S PNAR=$$GET1^DIQ(9000011,IEN_",",.05)
  1.  S EEXT=$P(DATA,U,3)
  1.  S EXFND=1  ;Record that an exact IPL match was found
  1.  ;Get external laterality
  1.  S EXLAT="" I $TR(PLAT,"|")]"" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|",2))
  1.  ;
  1.  ;Get ICD and default status
  1.  S PRMLST="" I $P(PLAT,"|",2)]"" S PRMLST="LAT="_$P(PLAT,"|",2)
  1.  S DDATA=$$DESC^BSTSAPI(PDSC_"^^1^^^"_PRMLST)
  1.  ;
  1.  ;Get ICD, default status, and prompt laterality
  1.  S ICD=$P(DDATA,U,3)
  1.  S DSTS=$P(DDATA,U,7)
  1.  S PMLT=$P(DDATA,U,6)
  1.  ;Save the entry
  1.  S CNT=$G(CNT)+1,LST(CNT)=IEN_U_PCNC_U_PLAT_U_PDSC_U_PNAR_U_EEXT_U_EXLAT_U_ICD_U_STAT_U_DSTS_U_$S(PMLT:"Y",1:"")_U_$P(DATA,U,4)
  1.  I EEXT S LST("EXACT")=CNT ;Record if this was an exact match
  1.  Q 1
  1.  ;Return data for sorting P20
  1.  ;1)Number of times the code has been used as POV
  1.  ;2)If it is an eye DX
  1.  ;3)The IEN of the inpt visit it was used last
  1. P1(RET,CNT,DFN,PRIEN,DESCT) ;EP
  1.  N FREQ,EYE,INPT,ARR,X,X1,PAR
  1.  Q:'+DESCT
  1.  S (FREQ,EYE,INPT,X,X1)=0
  1.  S PAR=$$GET^XPAR("ALL","BGO IPL EYE DX",1,"E")
  1.  I PAR="YES" D
  1.  .S OUT="ARR"
  1.  .S IN=DESCT_"^EHR IPL EYE FILTER"
  1.  .S X=$$VALSBTRM^BSTSAPI(.OUT,.IN)
  1.  .I +X S X1=$G(@OUT)
  1.  .I +X1 S EYE=1
  1.  .E  S EYE=0
  1.  S FREQ=$$FREQ(PRIEN)
  1.  S PAR=$$GET^XPAR("ALL","BGO IPL INPT TAB",1,"E")
  1.  I PAR="YES" D
  1.  .S INPT=$$LASTIP(PRIEN,DFN)
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)="P1"_U_FREQ_U_EYE_U_INPT
  1.  Q
  1. FREQ(PRIEN) ;P20 Find how many times a problem was used as POV
  1.  N USED,CNT,IEN
  1.  S USED=0
  1.  S IEN=0 F  S IEN=$O(^AUPNPROB(PRIEN,14,IEN)) Q:'+IEN  D
  1.  .S USED=USED+1
  1.  Q USED
  1. LASTIP(PRIEN,DFN) ;P20 Find if problem was used as IP DX in last hospitalization
  1.  N USED,INVDT,IEN,INPT
  1.  S USED=""
  1.  S INVDT=""
  1.  S INVDT=$O(^AUPNVSIT("AAH",DFN,INVDT))
  1.  I '+INVDT Q USED
  1.  S IEN=0 S IEN=$O(^AUPNVSIT("AAH",DFN,INVDT,IEN))
  1.  I '+IEN Q USED
  1.  S INPT="" S INPT=$O(^AUPNPROB(PRIEN,15,"B",IEN,INPT))
  1.  I +INPT S USED=$$GET1^DIQ(9000010,IEN,.01,"I")
  1.  Q USED
  1. UPSTAT(PRIEN,STAT) ;Update the status of a problem P20
  1.  N FDA,IENS,FNUM
  1.  S FNUM=9000011
  1.  S IENS=PRIEN_","
  1.  S FDA=$NA(FDA(FNUM,IENS))
  1.  S @FDA@(.12)=STAT
  1.  D FILE^DIE("","FDA","ERR")
  1.  Q
  1. TMPGBL(X) ;EP
  1.  K ^TMP("BGOMAP",$J) Q $NA(^($J))