BGOPROB2 ; IHS/MSC/PLS - Provide Map Advice ;24-Jun-2016 13:46;du
;;1.1;BGO COMPONENTS;**14,15,20,21**;Mar 20, 2007;Build 1
;---------------------------------------------
;Return the map advice for
MAP(DATA,LIST) ;EP GET MAP ADVICE
N IN,OUT,SNO,ARR,X,CNT,ADV,CNT2,MCNT,I
S DATA=$$TMPGBL
S CNT=0
S I="" F S I=$O(LIST(I)) Q:I="" D
.S SNO=$G(LIST(I))
.S CNT=CNT+1
.S @DATA@(CNT)="C"_U_SNO
.S IN=SNO_"^1"
.S OUT="ARR"
.;S X=$$MPADVICE^BSTSAPI(.OUT,.IN)
.S X=$$I10ADV^BSTSAPI(.OUT,.IN)
.S CNT2=0,MCNT=0
.F S CNT2=$O(ARR(CNT2)) Q:CNT2="" D
..S ADV=$G(ARR(CNT2))
..S CNT=CNT+1
..S @DATA@(CNT)="~t"_U_CNT2_U_ADV
.I CNT2=0 D
..S CNT=CNT+1
..S @DATA@(CNT)="~t"_U_1_U_"No Map advice available for this SNOMED term"
Q
CHK(RET,PRIEN) ;Check to see if it is OK to delete a problem
;Check and see if there are any V Care Plan entries for this problem
;If there are, the problem cannot be deleted Patch 13&14
N X,SIEN,STATUS
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
S X=0,RET=1
F S X=$O(^AUPNCPL("B",+PRIEN,X)) Q:X=""!(+RET<0) D
.S SIEN=$C(0) S SIEN=$O(^AUPNCPL(X,11,SIEN),-1)
.S STATUS=$P($G(^AUPNCPL(X,11,SIEN,0)),U,1)
.I STATUS'="E" S RET="-1^Care Plan entries are stored. Check Problem Details. Problem cannot be deleted"
Q:+RET<0
S X=0
F S X=$O(^AUPNVVI("B",+PRIEN,X)) Q:X=""!(+RET<0) D
.I $$GET1^DIQ(9000010.58,X,.06,"I")'=1 S RET="-1^Visit instructions are stored. Check Problem Details. Problem cannot be deleted"
F S X=$O(^AUPNVOB("B",+PRIEN,X)) Q:X=""!(+RET<0) D
.I $$GET1^DIQ(9000010.43,X,.06,"I")'=1 S RET="-1^OB notes are stored. Check Problem Details. Problem cannot be deleted"
Q
CLASS(REC,DFN,ASM) ;Return asthma class information
N CLASS,CONTROL,ASTHMA,DATA
S DATA=""
S CLASS=$P(REC,U,15)
S ASM=$G(ASM)
;P20 removed check for classification
;I CLASS'="" D
I ASM=1 D
.;Return asthma data for this problem
.;Patch 20 only return classification, not control
.S ASTHMA=""
.S CLASS=$S(CLASS=1:"INTERMITTENT",CLASS=2:"MILD PERSISTENT",CLASS=3:"MODERATE PERSISTENT",CLASS=4:"SEVERE PERSISTENT",1:"")
.;D GET2^BGOVAST(.ASTHMA,DFN)
.;S CONTROL=$P(ASTHMA,U,4)
.;S DATA="A"_U_CLASS_U_CONTROL_U_$P(ASTHMA,U,2)
.S DATA="A"_U_CLASS
Q DATA
INJCHK(PRIEN,VIEN) ;Return most recent injury information
N DATA,OUTPT,VST,FNUM,REC,CAUSE,REVISIT,IDP,IPL,ICCIEN,FOUND,VDATE
N ICCODE,ICAU,IDT
S DATA="",FNUM=9000010.07,FOUND=0
;Get the latest visit where this problem was used as a POV
S VST=$O(^AUPNPROB(PRIEN,14,"B",9999999),-1) D
.Q:'VST
.S OUTPT="" S OUTPT=$O(^AUPNPROB(PRIEN,14,"B",VST,OUTPT))
.I +OUTPT D
..N VPOV
..S FOUND=0
..;Find the POV from the visit that is attached to the correct problem
..S VPOV=0 F S VPOV=$O(^AUPNVPOV("AD",VST,VPOV)) Q:VPOV=""!(FOUND=1) D
...S (CAUSE,REVISIT,IDT,IPL,ICCIEN)=""
...I $P($G(^AUPNVPOV(VPOV,0)),U,16)=PRIEN D
....S REC=$G(^AUPNVPOV(VPOV,0))
....S VDATE=$$FMTDATE^BGOUTL($P($G(^AUPNVSIT(VST,0)),U))
....;Get the injury fields
....S CAUSE=$$EXTERNAL^DILFD(FNUM,.07,,$P(REC,U,7))
....S REVISIT=$$EXTERNAL^DILFD(FNUM,.08,,$P(REC,U,8))
....S IDT=$$FMTDATE^BGOUTL($P(REC,U,13))
....S IPL=$P(REC,U,11)
....I IPL'="" S IPL=$$EXTERNAL^DILFD(FNUM,.11,,IPL)_"~"_IPL
....S ICCIEN=$P(REC,U,9)
....S (ICCODE,ICAU)=""
....S:ICCIEN ICAU=$P($$ICDDX^ICDEX(ICCIEN,VDATE,"","I"),U,4),ICCODE=$P($$ICDDX^ICDEX(ICCIEN,VDATE,"","I"),U,2)
....I (CAUSE'="")!(REVISIT'="")!(IDT'="")!(IPL'="")!(ICCIEN'="") D
.....S FOUND=1
.....S DATA="H"_U_REVISIT_U_CAUSE_U_IDT_U_ICAU_U_ICCODE_U_IPL_U_VST
Q DATA
;IHS/MSC/MGH check for duplicates
;INP=SNOMED Concept CT ^ laterality code | laterality type ^ PRIEN
DUPCHK(RET,INP) ;EP
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
S RET=$$TMPGBL^BGOUTL
S CNT=0,FND=0,LST="",CNT2=0
S DFN=$P(INP,U,1)
S CONCID=$P(INP,U,2)
S CHK=$P(INP,U,3)
S LAT=$P(CHK,"|",2)
I LAT="" S CHK=""
S PRIEN=$P(INP,U,4)
D EQUIV^BSTSAPI("ARR",CONCID_"^"_CHK)
S I1="" F S I1=$O(ARR(I1)) Q:I1="" D
.S ENOD=$G(ARR(I1))
.S ESNO=$P(ENOD,U,1)
.S ELAT=$P(ENOD,U,2)
.S EEXT=$P(ENOD,U,3)
.S ETRM=$P(ENOD,U,4)
.I ELAT="" D
..S IEN="" F S IEN=$O(^AUPNPROB("APCT",DFN,ESNO,IEN)) Q:'+IEN D
...S STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
...Q:STAT="D"
...S F=$$SETDATA(.LST,.CNT,IEN,ENOD,.EXFND)
...S:F FND=1
.I ELAT'="" D
..S IEN="" F S IEN=$O(^AUPNPROB("ASLT",DFN,ESNO,ELAT,IEN)) Q:'+IEN D
...S STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
...Q:STAT="D"
...S F=$$SETDATA(.LST,.CNT,IEN,ENOD,.EXFND)
...S:F FND=1
.I FND=0,CONCID=ESNO,CHK=ELAT D
.. NEW PDST,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT
.. S PRMLST="" I $P(ELAT,"|",2)]"" S PRMLST="LAT="_$P(ELAT,"|",2)
.. S DDATA=$$CONC^BSTSAPI(CONCID_"^^^1^^"_PRMLST)
.. S PDST=$P(DDATA,U,4)
.. S DESCID=$P(DDATA,U,1)
.. ;
.. ;Get external laterality
.. S EXLAT="" I $TR(ELAT,"|")]"" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(ELAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(ELAT,"|",2))
.. ;
.. ;Get ICD, default status and prompt laterality
.. S ICD=$P(DDATA,U,5)
.. S DSTS=$P(DDATA,U,9)
.. S PMLT=$P(DDATA,U,8)
.. ;No match found - log that entry can be used
.. 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
.. I EEXT S EXMNOPRB=1 ;Track if an exact match
;Loop through results - eliminate others if exact match found
N TII,TNODE
S TII="" F S TII=$O(LST(TII)) Q:'TII D
. ;
. NEW TNODE,CONC,LAT,LATCHK
.S LATCHK=0
. S TNODE=$G(LST(TII))
.I +PRIEN D
..S LAT=$$GET1^DIQ(9000011,PRIEN,.22,"I")
..S CONC=$$GET1^DIQ(9000011,PRIEN,80001)
..I LAT'=$P(TNODE,U,3) S LATCHK=1
..I CONC'=$P(TNODE,U,1) S LATCHK=1
. ;Special logic for exact match found on IPL - Only include it
. I $D(LST("EXACT")) D Q
.. NEW EXNODE
.. ;Get the exact match
.. S EXNODE=$G(LST("EXACT"))
.. ;
.. ;If not an exact match do not include
.. I '$P(TNODE,U,6) Q
.. ;Passed in problem is the same as the exact match problem
.. ;
.. I +PRIEN,PRIEN=$P(EXNODE,U,5) D Q
... ;
... ;The user switched to the equivalent concept - update original
... ;passed in problem info with new SNOMED/laterality information
... I $P(TNODE,U,6)=1,$P(TNODE,U,1)=0 D Q
.... NEW I
.... S EXNODE=$G(LST("EXACT"))
.... F I=5:1:9 S $P(TNODE,U,I)=$P(EXNODE,U,I)
.... S CNT2=CNT2+1,@RET@(CNT2)=TNODE
... ;
... ;The user picked the same concept - return original
... I $P(TNODE,U,6)=1,$G(LST("EXACT"))=TII D Q
.... Q:CONCID'=$P(TNODE,U) ;Concept not the same
.... Q:LAT'=$P(TNODE,U,2) ;Laterality not the same
.... S TNODE=$G(LST("EXACT"))
.... S CNT2=CNT2+1,@RET@(CNT2)=TNODE
.. ;
.. ;No passed in problem or not a match with exact
.. ;
.. ;If exact match, allow - GUI will utilize IPL problem returned
.. I $G(LST("EXACT"))=TII D Q
... S TNODE=$G(LST(TII))
... S CNT2=CNT2+1,@RET@(CNT2)=TNODE
. ;
. ;Problem edit - changed SNOMED and it isn't a match on IPL
. ;update entry with passed in problem information
. I +PRIEN,$P(TNODE,U,1)=0 D Q
.. S $P(TNODE,U,1)=+PRIEN
..I LATCHK=1 S $P(TNODE,U,6)=0
.. S CNT2=CNT2+1,@RET@(CNT2)=TNODE
. ;
. ;Not an exact match on IPL, exact found by BSTS and edit fill entries
. I EXMNOPRB D Q ;Edit and an exact match was saved
.. I $P(TNODE,U,6) D ;This is the exact match
... S $P(TNODE,U,1)=+PRIEN
... I +PRIEN=0 S EXMNOPRB=0
...I LATCHK=1 S $P(TNODE,U,6)=0
... S CNT2=CNT2+1,@RET@(CNT2)=TNODE
. ;
. ;No exact matches - save related ones
. I EXMNOPRB=0 S CNT2=CNT2+1,@RET@(CNT2)=TNODE
Q
SETDATA(LST,CNT,IEN,DATA,EXFND) ;Get the needed data
N STRING,DESCID,PLAT,PCNC,PNAR,PDSC,PDST,ICD,PRMLST,DDATA,DSTS,PMLT
S STRING=""
;If matching concept id and no laterality passed in, filter out those with laterality
S PLAT=$$GET1^DIQ(9000011,IEN_",",.22,"I") ;Laterality
I $P(DATA,U,2)="",PLAT]"" Q 0
S PCNC=$$GET1^DIQ(9000011,IEN_",",80001,"I") ;Concept ID
S PDSC=$$GET1^DIQ(9000011,IEN_",",80002,"I") ;Description ID
S PDST=$P($$DESC^BSTSAPI(PDSC_"^^1"),U,2) ;Description Term
S PNAR=$$GET1^DIQ(9000011,IEN_",",.05)
S EEXT=$P(DATA,U,3)
S EXFND=1 ;Record that an exact IPL match was found
;Get external laterality
S EXLAT="" I $TR(PLAT,"|")]"" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|",2))
;
;Get ICD and default status
S PRMLST="" I $P(PLAT,"|",2)]"" S PRMLST="LAT="_$P(PLAT,"|",2)
S DDATA=$$DESC^BSTSAPI(PDSC_"^^1^^^"_PRMLST)
;
;Get ICD, default status, and prompt laterality
S ICD=$P(DDATA,U,3)
S DSTS=$P(DDATA,U,7)
S PMLT=$P(DDATA,U,6)
;Save the entry
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)
I EEXT S LST("EXACT")=CNT ;Record if this was an exact match
Q 1
;Return data for sorting P20
;1)Number of times the code has been used as POV
;2)If it is an eye DX
;3)The IEN of the inpt visit it was used last
P1(RET,CNT,DFN,PRIEN,DESCT) ;EP
N FREQ,EYE,INPT,ARR,X,X1,PAR
Q:'+DESCT
S (FREQ,EYE,INPT,X,X1)=0
S PAR=$$GET^XPAR("ALL","BGO IPL EYE DX",1,"E")
I PAR="YES" D
.S OUT="ARR"
.S IN=DESCT_"^EHR IPL EYE FILTER"
.S X=$$VALSBTRM^BSTSAPI(.OUT,.IN)
.I +X S X1=$G(@OUT)
.I +X1 S EYE=1
.E S EYE=0
S FREQ=$$FREQ(PRIEN)
S PAR=$$GET^XPAR("ALL","BGO IPL INPT TAB",1,"E")
I PAR="YES" D
.S INPT=$$LASTIP(PRIEN,DFN)
S CNT=CNT+1
S @RET@(CNT)="P1"_U_FREQ_U_EYE_U_INPT
Q
FREQ(PRIEN) ;P20 Find how many times a problem was used as POV
N USED,CNT,IEN
S USED=0
S IEN=0 F S IEN=$O(^AUPNPROB(PRIEN,14,IEN)) Q:'+IEN D
.S USED=USED+1
Q USED
LASTIP(PRIEN,DFN) ;P20 Find if problem was used as IP DX in last hospitalization
N USED,INVDT,IEN,INPT
S USED=""
S INVDT=""
S INVDT=$O(^AUPNVSIT("AAH",DFN,INVDT))
I '+INVDT Q USED
S IEN=0 S IEN=$O(^AUPNVSIT("AAH",DFN,INVDT,IEN))
I '+IEN Q USED
S INPT="" S INPT=$O(^AUPNPROB(PRIEN,15,"B",IEN,INPT))
I +INPT S USED=$$GET1^DIQ(9000010,IEN,.01,"I")
Q USED
UPSTAT(PRIEN,STAT) ;Update the status of a problem P20
N FDA,IENS,FNUM
S FNUM=9000011
S IENS=PRIEN_","
S FDA=$NA(FDA(FNUM,IENS))
S @FDA@(.12)=STAT
D FILE^DIE("","FDA","ERR")
Q
TMPGBL(X) ;EP
K ^TMP("BGOMAP",$J) Q $NA(^($J))
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
+2 ;---------------------------------------------
+3 ;Return the map advice for
MAP(DATA,LIST) ;EP GET MAP ADVICE
+1 NEW IN,OUT,SNO,ARR,X,CNT,ADV,CNT2,MCNT,I
+2 SET DATA=$$TMPGBL
+3 SET CNT=0
+4 SET I=""
FOR
SET I=$ORDER(LIST(I))
IF I=""
QUIT
Begin DoDot:1
+5 SET SNO=$GET(LIST(I))
+6 SET CNT=CNT+1
+7 SET @DATA@(CNT)="C"_U_SNO
+8 SET IN=SNO_"^1"
+9 SET OUT="ARR"
+10 ;S X=$$MPADVICE^BSTSAPI(.OUT,.IN)
+11 SET X=$$I10ADV^BSTSAPI(.OUT,.IN)
+12 SET CNT2=0
SET MCNT=0
+13 FOR
SET CNT2=$ORDER(ARR(CNT2))
IF CNT2=""
QUIT
Begin DoDot:2
+14 SET ADV=$GET(ARR(CNT2))
+15 SET CNT=CNT+1
+16 SET @DATA@(CNT)="~t"_U_CNT2_U_ADV
End DoDot:2
+17 IF CNT2=0
Begin DoDot:2
+18 SET CNT=CNT+1
+19 SET @DATA@(CNT)="~t"_U_1_U_"No Map advice available for this SNOMED term"
End DoDot:2
End DoDot:1
+20 QUIT
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
+2 ;If there are, the problem cannot be deleted Patch 13&14
+3 NEW X,SIEN,STATUS
+4 IF +$ORDER(^AUPNPROB(+PRIEN,14,"B",0))!(+$ORDER(^AUPNPROB(+PRIEN,15,"B",0)))
SET RET="-1^Problem has been used for a visit and cannot be deleted. Check Problem Details."
QUIT
+5 SET X=0
SET RET=1
+6 FOR
SET X=$ORDER(^AUPNCPL("B",+PRIEN,X))
IF X=""!(+RET<0)
QUIT
Begin DoDot:1
+7 SET SIEN=$CHAR(0)
SET SIEN=$ORDER(^AUPNCPL(X,11,SIEN),-1)
+8 SET STATUS=$PIECE($GET(^AUPNCPL(X,11,SIEN,0)),U,1)
+9 IF STATUS'="E"
SET RET="-1^Care Plan entries are stored. Check Problem Details. Problem cannot be deleted"
End DoDot:1
+10 IF +RET<0
QUIT
+11 SET X=0
+12 FOR
SET X=$ORDER(^AUPNVVI("B",+PRIEN,X))
IF X=""!(+RET<0)
QUIT
Begin DoDot:1
+13 IF $$GET1^DIQ(9000010.58,X,.06,"I")'=1
SET RET="-1^Visit instructions are stored. Check Problem Details. Problem cannot be deleted"
End DoDot:1
+14 FOR
SET X=$ORDER(^AUPNVOB("B",+PRIEN,X))
IF X=""!(+RET<0)
QUIT
Begin DoDot:1
+15 IF $$GET1^DIQ(9000010.43,X,.06,"I")'=1
SET RET="-1^OB notes are stored. Check Problem Details. Problem cannot be deleted"
End DoDot:1
+16 QUIT
CLASS(REC,DFN,ASM) ;Return asthma class information
+1 NEW CLASS,CONTROL,ASTHMA,DATA
+2 SET DATA=""
+3 SET CLASS=$PIECE(REC,U,15)
+4 SET ASM=$GET(ASM)
+5 ;P20 removed check for classification
+6 ;I CLASS'="" D
+7 IF ASM=1
Begin DoDot:1
+8 ;Return asthma data for this problem
+9 ;Patch 20 only return classification, not control
+10 SET ASTHMA=""
+11 SET CLASS=$SELECT(CLASS=1:"INTERMITTENT",CLASS=2:"MILD PERSISTENT",CLASS=3:"MODERATE PERSISTENT",CLASS=4:"SEVERE PERSISTENT",1:"")
+12 ;D GET2^BGOVAST(.ASTHMA,DFN)
+13 ;S CONTROL=$P(ASTHMA,U,4)
+14 ;S DATA="A"_U_CLASS_U_CONTROL_U_$P(ASTHMA,U,2)
+15 SET DATA="A"_U_CLASS
End DoDot:1
+16 QUIT DATA
INJCHK(PRIEN,VIEN) ;Return most recent injury information
+1 NEW DATA,OUTPT,VST,FNUM,REC,CAUSE,REVISIT,IDP,IPL,ICCIEN,FOUND,VDATE
+2 NEW ICCODE,ICAU,IDT
+3 SET DATA=""
SET FNUM=9000010.07
SET FOUND=0
+4 ;Get the latest visit where this problem was used as a POV
+5 SET VST=$ORDER(^AUPNPROB(PRIEN,14,"B",9999999),-1)
Begin DoDot:1
+6 IF 'VST
QUIT
+7 SET OUTPT=""
SET OUTPT=$ORDER(^AUPNPROB(PRIEN,14,"B",VST,OUTPT))
+8 IF +OUTPT
Begin DoDot:2
+9 NEW VPOV
+10 SET FOUND=0
+11 ;Find the POV from the visit that is attached to the correct problem
+12 SET VPOV=0
FOR
SET VPOV=$ORDER(^AUPNVPOV("AD",VST,VPOV))
IF VPOV=""!(FOUND=1)
QUIT
Begin DoDot:3
+13 SET (CAUSE,REVISIT,IDT,IPL,ICCIEN)=""
+14 IF $PIECE($GET(^AUPNVPOV(VPOV,0)),U,16)=PRIEN
Begin DoDot:4
+15 SET REC=$GET(^AUPNVPOV(VPOV,0))
+16 SET VDATE=$$FMTDATE^BGOUTL($PIECE($GET(^AUPNVSIT(VST,0)),U))
+17 ;Get the injury fields
+18 SET CAUSE=$$EXTERNAL^DILFD(FNUM,.07,,$PIECE(REC,U,7))
+19 SET REVISIT=$$EXTERNAL^DILFD(FNUM,.08,,$PIECE(REC,U,8))
+20 SET IDT=$$FMTDATE^BGOUTL($PIECE(REC,U,13))
+21 SET IPL=$PIECE(REC,U,11)
+22 IF IPL'=""
SET IPL=$$EXTERNAL^DILFD(FNUM,.11,,IPL)_"~"_IPL
+23 SET ICCIEN=$PIECE(REC,U,9)
+24 SET (ICCODE,ICAU)=""
+25 IF ICCIEN
SET ICAU=$PIECE($$ICDDX^ICDEX(ICCIEN,VDATE,"","I"),U,4)
SET ICCODE=$PIECE($$ICDDX^ICDEX(ICCIEN,VDATE,"","I"),U,2)
+26 IF (CAUSE'="")!(REVISIT'="")!(IDT'="")!(IPL'="")!(ICCIEN'="")
Begin DoDot:5
+27 SET FOUND=1
+28 SET DATA="H"_U_REVISIT_U_CAUSE_U_IDT_U_ICAU_U_ICCODE_U_IPL_U_VST
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT DATA
+30 ;IHS/MSC/MGH check for duplicates
+31 ;INP=SNOMED Concept CT ^ laterality code | laterality type ^ PRIEN
DUPCHK(RET,INP) ;EP
+1 NEW ESNO,F,ELAT,EXMNOPRB,ENOD,PRIEN,EEXT,DFN,MATCH,CONCID,CNT,STAT,IEN,I2,I1,LAT,CHK,USES,ARR,FND,LST,CNT2,CNK2,ETRM
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET CNT=0
SET FND=0
SET LST=""
SET CNT2=0
+4 SET DFN=$PIECE(INP,U,1)
+5 SET CONCID=$PIECE(INP,U,2)
+6 SET CHK=$PIECE(INP,U,3)
+7 SET LAT=$PIECE(CHK,"|",2)
+8 IF LAT=""
SET CHK=""
+9 SET PRIEN=$PIECE(INP,U,4)
+10 DO EQUIV^BSTSAPI("ARR",CONCID_"^"_CHK)
+11 SET I1=""
FOR
SET I1=$ORDER(ARR(I1))
IF I1=""
QUIT
Begin DoDot:1
+12 SET ENOD=$GET(ARR(I1))
+13 SET ESNO=$PIECE(ENOD,U,1)
+14 SET ELAT=$PIECE(ENOD,U,2)
+15 SET EEXT=$PIECE(ENOD,U,3)
+16 SET ETRM=$PIECE(ENOD,U,4)
+17 IF ELAT=""
Begin DoDot:2
+18 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNPROB("APCT",DFN,ESNO,IEN))
IF '+IEN
QUIT
Begin DoDot:3
+19 SET STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
+20 IF STAT="D"
QUIT
+21 SET F=$$SETDATA(.LST,.CNT,IEN,ENOD,.EXFND)
+22 IF F
SET FND=1
End DoDot:3
End DoDot:2
+23 IF ELAT'=""
Begin DoDot:2
+24 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNPROB("ASLT",DFN,ESNO,ELAT,IEN))
IF '+IEN
QUIT
Begin DoDot:3
+25 SET STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
+26 IF STAT="D"
QUIT
+27 SET F=$$SETDATA(.LST,.CNT,IEN,ENOD,.EXFND)
+28 IF F
SET FND=1
End DoDot:3
End DoDot:2
+29 IF FND=0
IF CONCID=ESNO
IF CHK=ELAT
Begin DoDot:2
+30 NEW PDST,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT
+31 SET PRMLST=""
IF $PIECE(ELAT,"|",2)]""
SET PRMLST="LAT="_$PIECE(ELAT,"|",2)
+32 SET DDATA=$$CONC^BSTSAPI(CONCID_"^^^1^^"_PRMLST)
+33 SET PDST=$PIECE(DDATA,U,4)
+34 SET DESCID=$PIECE(DDATA,U,1)
+35 ;
+36 ;Get external laterality
+37 SET EXLAT=""
IF $TRANSLATE(ELAT,"|")]""
SET EXLAT=$$CVPARM^BSTSMAP1("LAT",$PIECE(ELAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$PIECE(ELAT,"|",2))
+38 ;
+39 ;Get ICD, default status and prompt laterality
+40 SET ICD=$PIECE(DDATA,U,5)
+41 SET DSTS=$PIECE(DDATA,U,9)
+42 SET PMLT=$PIECE(DDATA,U,8)
+43 ;No match found - log that entry can be used
+44 SET CNT=$GET(CNT)+1
SET LST(CNT)=0_U_ESNO_U_ELAT_U_DESCID_U_PDST_U_EEXT_U_EXLAT_U_ICD_U_U_DSTS_U_$SELECT(PMLT:"Y",1:"")_U_ETRM
+45 ;Track if an exact match
IF EEXT
SET EXMNOPRB=1
End DoDot:2
End DoDot:1
+46 ;Loop through results - eliminate others if exact match found
+47 NEW TII,TNODE
+48 SET TII=""
FOR
SET TII=$ORDER(LST(TII))
IF 'TII
QUIT
Begin DoDot:1
+49 ;
+50 NEW TNODE,CONC,LAT,LATCHK
+51 SET LATCHK=0
+52 SET TNODE=$GET(LST(TII))
+53 IF +PRIEN
Begin DoDot:2
+54 SET LAT=$$GET1^DIQ(9000011,PRIEN,.22,"I")
+55 SET CONC=$$GET1^DIQ(9000011,PRIEN,80001)
+56 IF LAT'=$PIECE(TNODE,U,3)
SET LATCHK=1
+57 IF CONC'=$PIECE(TNODE,U,1)
SET LATCHK=1
End DoDot:2
+58 ;Special logic for exact match found on IPL - Only include it
+59 IF $DATA(LST("EXACT"))
Begin DoDot:2
+60 NEW EXNODE
+61 ;Get the exact match
+62 SET EXNODE=$GET(LST("EXACT"))
+63 ;
+64 ;If not an exact match do not include
+65 IF '$PIECE(TNODE,U,6)
QUIT
+66 ;Passed in problem is the same as the exact match problem
+67 ;
+68 IF +PRIEN
IF PRIEN=$PIECE(EXNODE,U,5)
Begin DoDot:3
+69 ;
+70 ;The user switched to the equivalent concept - update original
+71 ;passed in problem info with new SNOMED/laterality information
+72 IF $PIECE(TNODE,U,6)=1
IF $PIECE(TNODE,U,1)=0
Begin DoDot:4
+73 NEW I
+74 SET EXNODE=$GET(LST("EXACT"))
+75 FOR I=5:1:9
SET $PIECE(TNODE,U,I)=$PIECE(EXNODE,U,I)
+76 SET CNT2=CNT2+1
SET @RET@(CNT2)=TNODE
End DoDot:4
QUIT
+77 ;
+78 ;The user picked the same concept - return original
+79 IF $PIECE(TNODE,U,6)=1
IF $GET(LST("EXACT"))=TII
Begin DoDot:4
+80 ;Concept not the same
IF CONCID'=$PIECE(TNODE,U)
QUIT
+81 ;Laterality not the same
IF LAT'=$PIECE(TNODE,U,2)
QUIT
+82 SET TNODE=$GET(LST("EXACT"))
+83 SET CNT2=CNT2+1
SET @RET@(CNT2)=TNODE
End DoDot:4
QUIT
End DoDot:3
QUIT
+84 ;
+85 ;No passed in problem or not a match with exact
+86 ;
+87 ;If exact match, allow - GUI will utilize IPL problem returned
+88 IF $GET(LST("EXACT"))=TII
Begin DoDot:3
+89 SET TNODE=$GET(LST(TII))
+90 SET CNT2=CNT2+1
SET @RET@(CNT2)=TNODE
End DoDot:3
QUIT
End DoDot:2
QUIT
+91 ;
+92 ;Problem edit - changed SNOMED and it isn't a match on IPL
+93 ;update entry with passed in problem information
+94 IF +PRIEN
IF $PIECE(TNODE,U,1)=0
Begin DoDot:2
+95 SET $PIECE(TNODE,U,1)=+PRIEN
+96 IF LATCHK=1
SET $PIECE(TNODE,U,6)=0
+97 SET CNT2=CNT2+1
SET @RET@(CNT2)=TNODE
End DoDot:2
QUIT
+98 ;
+99 ;Not an exact match on IPL, exact found by BSTS and edit fill entries
+100 ;Edit and an exact match was saved
IF EXMNOPRB
Begin DoDot:2
+101 ;This is the exact match
IF $PIECE(TNODE,U,6)
Begin DoDot:3
+102 SET $PIECE(TNODE,U,1)=+PRIEN
+103 IF +PRIEN=0
SET EXMNOPRB=0
+104 IF LATCHK=1
SET $PIECE(TNODE,U,6)=0
+105 SET CNT2=CNT2+1
SET @RET@(CNT2)=TNODE
End DoDot:3
End DoDot:2
QUIT
+106 ;
+107 ;No exact matches - save related ones
+108 IF EXMNOPRB=0
SET CNT2=CNT2+1
SET @RET@(CNT2)=TNODE
End DoDot:1
+109 QUIT
SETDATA(LST,CNT,IEN,DATA,EXFND) ;Get the needed data
+1 NEW STRING,DESCID,PLAT,PCNC,PNAR,PDSC,PDST,ICD,PRMLST,DDATA,DSTS,PMLT
+2 SET STRING=""
+3 ;If matching concept id and no laterality passed in, filter out those with laterality
+4 ;Laterality
SET PLAT=$$GET1^DIQ(9000011,IEN_",",.22,"I")
+5 IF $PIECE(DATA,U,2)=""
IF PLAT]""
QUIT 0
+6 ;Concept ID
SET PCNC=$$GET1^DIQ(9000011,IEN_",",80001,"I")
+7 ;Description ID
SET PDSC=$$GET1^DIQ(9000011,IEN_",",80002,"I")
+8 ;Description Term
SET PDST=$PIECE($$DESC^BSTSAPI(PDSC_"^^1"),U,2)
+9 SET PNAR=$$GET1^DIQ(9000011,IEN_",",.05)
+10 SET EEXT=$PIECE(DATA,U,3)
+11 ;Record that an exact IPL match was found
SET EXFND=1
+12 ;Get external laterality
+13 SET EXLAT=""
IF $TRANSLATE(PLAT,"|")]""
SET EXLAT=$$CVPARM^BSTSMAP1("LAT",$PIECE(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$PIECE(PLAT,"|",2))
+14 ;
+15 ;Get ICD and default status
+16 SET PRMLST=""
IF $PIECE(PLAT,"|",2)]""
SET PRMLST="LAT="_$PIECE(PLAT,"|",2)
+17 SET DDATA=$$DESC^BSTSAPI(PDSC_"^^1^^^"_PRMLST)
+18 ;
+19 ;Get ICD, default status, and prompt laterality
+20 SET ICD=$PIECE(DDATA,U,3)
+21 SET DSTS=$PIECE(DDATA,U,7)
+22 SET PMLT=$PIECE(DDATA,U,6)
+23 ;Save the entry
+24 SET CNT=$GET(CNT)+1
SET LST(CNT)=IEN_U_PCNC_U_PLAT_U_PDSC_U_PNAR_U_EEXT_U_EXLAT_U_ICD_U_STAT_U_DSTS_U_$SELECT(PMLT:"Y",1:"")_U_$PIECE(DATA,U,4)
+25 ;Record if this was an exact match
IF EEXT
SET LST("EXACT")=CNT
+26 QUIT 1
+27 ;Return data for sorting P20
+28 ;1)Number of times the code has been used as POV
+29 ;2)If it is an eye DX
+30 ;3)The IEN of the inpt visit it was used last
P1(RET,CNT,DFN,PRIEN,DESCT) ;EP
+1 NEW FREQ,EYE,INPT,ARR,X,X1,PAR
+2 IF '+DESCT
QUIT
+3 SET (FREQ,EYE,INPT,X,X1)=0
+4 SET PAR=$$GET^XPAR("ALL","BGO IPL EYE DX",1,"E")
+5 IF PAR="YES"
Begin DoDot:1
+6 SET OUT="ARR"
+7 SET IN=DESCT_"^EHR IPL EYE FILTER"
+8 SET X=$$VALSBTRM^BSTSAPI(.OUT,.IN)
+9 IF +X
SET X1=$GET(@OUT)
+10 IF +X1
SET EYE=1
+11 IF '$TEST
SET EYE=0
End DoDot:1
+12 SET FREQ=$$FREQ(PRIEN)
+13 SET PAR=$$GET^XPAR("ALL","BGO IPL INPT TAB",1,"E")
+14 IF PAR="YES"
Begin DoDot:1
+15 SET INPT=$$LASTIP(PRIEN,DFN)
End DoDot:1
+16 SET CNT=CNT+1
+17 SET @RET@(CNT)="P1"_U_FREQ_U_EYE_U_INPT
+18 QUIT
FREQ(PRIEN) ;P20 Find how many times a problem was used as POV
+1 NEW USED,CNT,IEN
+2 SET USED=0
+3 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPROB(PRIEN,14,IEN))
IF '+IEN
QUIT
Begin DoDot:1
+4 SET USED=USED+1
End DoDot:1
+5 QUIT USED
LASTIP(PRIEN,DFN) ;P20 Find if problem was used as IP DX in last hospitalization
+1 NEW USED,INVDT,IEN,INPT
+2 SET USED=""
+3 SET INVDT=""
+4 SET INVDT=$ORDER(^AUPNVSIT("AAH",DFN,INVDT))
+5 IF '+INVDT
QUIT USED
+6 SET IEN=0
SET IEN=$ORDER(^AUPNVSIT("AAH",DFN,INVDT,IEN))
+7 IF '+IEN
QUIT USED
+8 SET INPT=""
SET INPT=$ORDER(^AUPNPROB(PRIEN,15,"B",IEN,INPT))
+9 IF +INPT
SET USED=$$GET1^DIQ(9000010,IEN,.01,"I")
+10 QUIT USED
UPSTAT(PRIEN,STAT) ;Update the status of a problem P20
+1 NEW FDA,IENS,FNUM
+2 SET FNUM=9000011
+3 SET IENS=PRIEN_","
+4 SET FDA=$NAME(FDA(FNUM,IENS))
+5 SET @FDA@(.12)=STAT
+6 DO FILE^DIE("","FDA","ERR")
+7 QUIT
TMPGBL(X) ;EP
+1 KILL ^TMP("BGOMAP",$JOB)
QUIT $NAME(^($JOB))
