BPXRMSNO ; IHS/MSC/MGH - Use SNOMED problems in reminder resolution. ;01-Apr-2016 08:44;du
;;2.0;CLINICAL REMINDERS;**1002,1003,1005,1006,1007**;Feb 04, 2005;Build 12
;===================================================================
;IHS/MSC/MGH Included in patch 1005 for backards compatability
;
SNO(DFN,TEST,DATE,VALUE,TEXT) ;EP
N BPXTRM,BPXPR,BPXIEN,BPXREC,BPXSTAT,X,IN,BPXSNO,FOUND,SEARCH,TODAY,Y
;Test will contain the name of the subset to see if this problem is in that subset
Q:TEST=""
S TODAY=$$DT^XLFDT()
S SEARCH=TEST,FOUND=0
;First search patient's active list of problems
S BPXPR="" F S BPXPR=$O(^AUPNPROB("AC",DFN,BPXPR)) Q:'BPXPR!(FOUND=1) D
.S BPXREC=$G(^AUPNPROB(BPXPR,0))
.Q:$P(BPXREC,U,2)'=DFN
.S BPXIEN=$P(BPXREC,U)
.Q:BPXIEN=""
.;Check for which statuses to return since we only want active ones
.S BPXSTAT=$P(BPXREC,U,12)
.Q:BPXSTAT="D"!(BPXSTAT="I")
.S BPXSNO=$$GET1^DIQ(9000011,BPXPR,80002)
.Q:BPXSNO=""
.N ARR
.S IN=BPXSNO_U_SEARCH_U_U_1
.S FOUND=$$VSBTRMF^BSTSAPI(IN)
.I FOUND=1 D
..S IN=BPXSNO_U_U_1
..S Y=$$DESC^BSTSAPI(IN)
..S VALUE=$P(Y,U,2)
..S TEST=1,TEXT=VALUE,DATE=TODAY
I FOUND=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
POV(DFN,TEST,DATE,VALUE,TEXT) ;EP
N BPXTRM,BPXPR,BPXIEN,BPXREC,BPXSTAT,X,IN,TODAY,BPXSNO,FOUND,SEARCH,BPXINV,Y,DONDTE,BEG,END,CODE,CODETXT
;Test will contain the name of the subset to see if this problem is in that subset
Q:TEST=""
S TODAY=$$DT^XLFDT()
I $G(FIEVAL("EDTE"))'="" S END=9999999-FIEVAL("EDTE")
E S END=9999999-DT
I $G(FIEVAL("BDTE"))'="" S BEG=9999999-FIEVAL("BDTE")
E S BEG=9999999-3000101
S SEARCH=TEST,FOUND=0
;First search patient's pov
S BPXINV=END F S BPXINV=$O(^AUPNVPOV("AA",DFN,BPXINV)) Q:'BPXINV!(FOUND=1)!(BPXINV>BEG) D
.S BPXPR="" F S BPXPR=$O(^AUPNVPOV("AA",DFN,BPXINV,BPXPR)) Q:'BPXPR!(FOUND=1) D
..S BPXREC=$G(^AUPNVPOV(BPXPR,0))
..Q:$P(BPXREC,U,2)'=DFN
..S BPXIEN=$P(BPXREC,U)
..Q:BPXIEN=""
..S BPXSNO=$$GET1^DIQ(9000010.07,BPXPR,1102)
..Q:BPXSNO=""
..N ARR
..S IN=BPXSNO_U_SEARCH_U_U_1
..S FOUND=$$VSBTRMF^BSTSAPI(IN)
..I FOUND=1 D
...S IN=BPXSNO_U_U_1
...S Y=$$DESC^BSTSAPI(IN)
...S VALUE=$P(Y,U,2)
...S DONDTE=$$GET1^DIQ(9000010.07,BPXPR,1201,"I")
...I DONDTE="" S DONDTE=$$GET1^DIQ(9000010.07,BPXPR,.03,"I")
...S TEST=1,TEXT="POV code",DATE=DONDTE
I FOUND=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
;Computed finding to find an item in an IHS taxonomy
POVTAX(DFN,TEST,DATE,VALUE,TEXT) ;EP
N BPXTRM,BPXPR,BPXIEN,BPXREC,BPXSTAT,TAX,TODAY,Y,DONDTE,BEG,END
;Test will contain the name of the taxonomy to see if this POV is in that taxonomy
Q:TEST=""
S TODAY=$$DT^XLFDT()
S TAX=TEST,FOUND=0
I $G(FIEVAL("EDTE"))'="" S END=9999999-FIEVAL("EDTE")
E S END=9999999-DT
I $G(FIEVAL("BDTE"))'="" S BEG=9999999-FIEVAL("BDTE")
E S BEG=9999999-3000101
;First search patient's pov
S BPXINV=END F S BPXINV=$O(^AUPNVPOV("AA",DFN,BPXINV)) Q:'BPXINV!(FOUND=1)!(BPXINV>BEG) D
.S BPXPR="" F S BPXPR=$O(^AUPNVPOV("AA",DFN,BPXINV,BPXPR)) Q:'BPXPR!(FOUND=1) D
..S BPXREC=$G(^AUPNVPOV(BPXPR,0))
..Q:$P(BPXREC,U,2)'=DFN
..S BPXIEN=$P(BPXREC,U)
..Q:BPXIEN=""
..S CODE=$$GET1^DIQ(9000010.07,BPXPR,.01,"I")
..I $$ICD^ATXAPI(CODE,$O(^ATXAX("B",TAX,0)),9) D
...S FOUND=1
...S CODETXT=$$GET1^DIQ(9000010.07,BPXPR,.01)
...S DONDTE=$$GET1^DIQ(9000010.07,BPXPR,1201,"I")
...I DONDTE="" S DONDTE=$$GET1^DIQ(9000010.07,BPXPR,.03,"I")
...S TEST=1,TEXT="Diagnosis Code",DATE=DONDTE,VALUE=CODETXT
I FOUND=0 S TEST=0,DATE=TODAY
Q
;Computed finding to find a CPT item in an IHS taxonomy
CPTTAX(DFN,TEST,DATE,VALUE,TEXT) ;EP
N BPXTRM,BPXPR,BPXIEN,BPXCODE,BPXREC,BPXSTAT,TAX,TODAY,Y,DONDTE,BEG,END
;Test will contain the name of the taxonomy to see if this CPT is in that taxonomy
Q:TEST=""
S TODAY=$$DT^XLFDT()
S TAX=TEST,FOUND=0
I $G(FIEVAL("EDTE"))'="" S END=9999999-FIEVAL("EDTE")
E S END=9999999-DT
I $G(FIEVAL("BDTE"))'="" S BEG=9999999-FIEVAL("BDTE")
E S BEG=9999999-2400101
;First search patient's CPT file
S BPXCODE="" F S BPXCODE=$O(^AUPNVCPT("AA",DFN,BPXCODE)) Q:'BPXCODE!(FOUND=1) D
.S BPXINV=END F S BPXINV=$O(^AUPNVCPT("AA",DFN,BPXCODE,BPXINV)) Q:'BPXINV!(FOUND=1)!(BPXINV>BEG) D
..S BPXPR="" F S BPXPR=$O(^AUPNVCPT("AA",DFN,BPXCODE,BPXINV,BPXPR)) Q:'BPXPR!(FOUND=1) D
...S BPXREC=$G(^AUPNVCPT(BPXPR,0))
...Q:$P(BPXREC,U,2)'=DFN
...S BPXIEN=$P(BPXREC,U)
...Q:BPXIEN=""
...S CODE=$$GET1^DIQ(9000010.18,BPXPR,.01,"I")
...I $$ICD^ATXAPI(CODE,$O(^ATXAX("B",TAX,0)),1) D
....S FOUND=1
....S CODETXT=$P($G(^ICPT(CODE,0)),U,2)
....S DONDTE=$$GET1^DIQ(9000010.18,BPXPR,1201)
....I DONDTE="" S DONDTE=$$GET1^DIQ(9000010.18,BPXPR,.03)
....S TEST=1,TEXT="CPT Code",DATE=DONDTE,VALUE=CODETXT
I FOUND=0 S TEST=0,DATE=TODAY
Q
BPXRMSNO ; IHS/MSC/MGH - Use SNOMED problems in reminder resolution. ;01-Apr-2016 08:44;du
+1 ;;2.0;CLINICAL REMINDERS;**1002,1003,1005,1006,1007**;Feb 04, 2005;Build 12
+2 ;===================================================================
+3 ;IHS/MSC/MGH Included in patch 1005 for backards compatability
+4 ;
SNO(DFN,TEST,DATE,VALUE,TEXT) ;EP
+1 NEW BPXTRM,BPXPR,BPXIEN,BPXREC,BPXSTAT,X,IN,BPXSNO,FOUND,SEARCH,TODAY,Y
+2 ;Test will contain the name of the subset to see if this problem is in that subset
+3 IF TEST=""
QUIT
+4 SET TODAY=$$DT^XLFDT()
+5 SET SEARCH=TEST
SET FOUND=0
+6 ;First search patient's active list of problems
+7 SET BPXPR=""
FOR
SET BPXPR=$ORDER(^AUPNPROB("AC",DFN,BPXPR))
IF 'BPXPR!(FOUND=1)
QUIT
Begin DoDot:1
+8 SET BPXREC=$GET(^AUPNPROB(BPXPR,0))
+9 IF $PIECE(BPXREC,U,2)'=DFN
QUIT
+10 SET BPXIEN=$PIECE(BPXREC,U)
+11 IF BPXIEN=""
QUIT
+12 ;Check for which statuses to return since we only want active ones
+13 SET BPXSTAT=$PIECE(BPXREC,U,12)
+14 IF BPXSTAT="D"!(BPXSTAT="I")
QUIT
+15 SET BPXSNO=$$GET1^DIQ(9000011,BPXPR,80002)
+16 IF BPXSNO=""
QUIT
+17 NEW ARR
+18 SET IN=BPXSNO_U_SEARCH_U_U_1
+19 SET FOUND=$$VSBTRMF^BSTSAPI(IN)
+20 IF FOUND=1
Begin DoDot:2
+21 SET IN=BPXSNO_U_U_1
+22 SET Y=$$DESC^BSTSAPI(IN)
+23 SET VALUE=$PIECE(Y,U,2)
+24 SET TEST=1
SET TEXT=VALUE
SET DATE=TODAY
End DoDot:2
End DoDot:1
+25 IF FOUND=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+26 QUIT
POV(DFN,TEST,DATE,VALUE,TEXT) ;EP
+1 NEW BPXTRM,BPXPR,BPXIEN,BPXREC,BPXSTAT,X,IN,TODAY,BPXSNO,FOUND,SEARCH,BPXINV,Y,DONDTE,BEG,END,CODE,CODETXT
+2 ;Test will contain the name of the subset to see if this problem is in that subset
+3 IF TEST=""
QUIT
+4 SET TODAY=$$DT^XLFDT()
+5 IF $GET(FIEVAL("EDTE"))'=""
SET END=9999999-FIEVAL("EDTE")
+6 IF '$TEST
SET END=9999999-DT
+7 IF $GET(FIEVAL("BDTE"))'=""
SET BEG=9999999-FIEVAL("BDTE")
+8 IF '$TEST
SET BEG=9999999-3000101
+9 SET SEARCH=TEST
SET FOUND=0
+10 ;First search patient's pov
+11 SET BPXINV=END
FOR
SET BPXINV=$ORDER(^AUPNVPOV("AA",DFN,BPXINV))
IF 'BPXINV!(FOUND=1)!(BPXINV>BEG)
QUIT
Begin DoDot:1
+12 SET BPXPR=""
FOR
SET BPXPR=$ORDER(^AUPNVPOV("AA",DFN,BPXINV,BPXPR))
IF 'BPXPR!(FOUND=1)
QUIT
Begin DoDot:2
+13 SET BPXREC=$GET(^AUPNVPOV(BPXPR,0))
+14 IF $PIECE(BPXREC,U,2)'=DFN
QUIT
+15 SET BPXIEN=$PIECE(BPXREC,U)
+16 IF BPXIEN=""
QUIT
+17 SET BPXSNO=$$GET1^DIQ(9000010.07,BPXPR,1102)
+18 IF BPXSNO=""
QUIT
+19 NEW ARR
+20 SET IN=BPXSNO_U_SEARCH_U_U_1
+21 SET FOUND=$$VSBTRMF^BSTSAPI(IN)
+22 IF FOUND=1
Begin DoDot:3
+23 SET IN=BPXSNO_U_U_1
+24 SET Y=$$DESC^BSTSAPI(IN)
+25 SET VALUE=$PIECE(Y,U,2)
+26 SET DONDTE=$$GET1^DIQ(9000010.07,BPXPR,1201,"I")
+27 IF DONDTE=""
SET DONDTE=$$GET1^DIQ(9000010.07,BPXPR,.03,"I")
+28 SET TEST=1
SET TEXT="POV code"
SET DATE=DONDTE
End DoDot:3
End DoDot:2
End DoDot:1
+29 IF FOUND=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+30 QUIT
+31 ;Computed finding to find an item in an IHS taxonomy
POVTAX(DFN,TEST,DATE,VALUE,TEXT) ;EP
+1 NEW BPXTRM,BPXPR,BPXIEN,BPXREC,BPXSTAT,TAX,TODAY,Y,DONDTE,BEG,END
+2 ;Test will contain the name of the taxonomy to see if this POV is in that taxonomy
+3 IF TEST=""
QUIT
+4 SET TODAY=$$DT^XLFDT()
+5 SET TAX=TEST
SET FOUND=0
+6 IF $GET(FIEVAL("EDTE"))'=""
SET END=9999999-FIEVAL("EDTE")
+7 IF '$TEST
SET END=9999999-DT
+8 IF $GET(FIEVAL("BDTE"))'=""
SET BEG=9999999-FIEVAL("BDTE")
+9 IF '$TEST
SET BEG=9999999-3000101
+10 ;First search patient's pov
+11 SET BPXINV=END
FOR
SET BPXINV=$ORDER(^AUPNVPOV("AA",DFN,BPXINV))
IF 'BPXINV!(FOUND=1)!(BPXINV>BEG)
QUIT
Begin DoDot:1
+12 SET BPXPR=""
FOR
SET BPXPR=$ORDER(^AUPNVPOV("AA",DFN,BPXINV,BPXPR))
IF 'BPXPR!(FOUND=1)
QUIT
Begin DoDot:2
+13 SET BPXREC=$GET(^AUPNVPOV(BPXPR,0))
+14 IF $PIECE(BPXREC,U,2)'=DFN
QUIT
+15 SET BPXIEN=$PIECE(BPXREC,U)
+16 IF BPXIEN=""
QUIT
+17 SET CODE=$$GET1^DIQ(9000010.07,BPXPR,.01,"I")
+18 IF $$ICD^ATXAPI(CODE,$ORDER(^ATXAX("B",TAX,0)),9)
Begin DoDot:3
+19 SET FOUND=1
+20 SET CODETXT=$$GET1^DIQ(9000010.07,BPXPR,.01)
+21 SET DONDTE=$$GET1^DIQ(9000010.07,BPXPR,1201,"I")
+22 IF DONDTE=""
SET DONDTE=$$GET1^DIQ(9000010.07,BPXPR,.03,"I")
+23 SET TEST=1
SET TEXT="Diagnosis Code"
SET DATE=DONDTE
SET VALUE=CODETXT
End DoDot:3
End DoDot:2
End DoDot:1
+24 IF FOUND=0
SET TEST=0
SET DATE=TODAY
+25 QUIT
+26 ;Computed finding to find a CPT item in an IHS taxonomy
CPTTAX(DFN,TEST,DATE,VALUE,TEXT) ;EP
+1 NEW BPXTRM,BPXPR,BPXIEN,BPXCODE,BPXREC,BPXSTAT,TAX,TODAY,Y,DONDTE,BEG,END
+2 ;Test will contain the name of the taxonomy to see if this CPT is in that taxonomy
+3 IF TEST=""
QUIT
+4 SET TODAY=$$DT^XLFDT()
+5 SET TAX=TEST
SET FOUND=0
+6 IF $GET(FIEVAL("EDTE"))'=""
SET END=9999999-FIEVAL("EDTE")
+7 IF '$TEST
SET END=9999999-DT
+8 IF $GET(FIEVAL("BDTE"))'=""
SET BEG=9999999-FIEVAL("BDTE")
+9 IF '$TEST
SET BEG=9999999-2400101
+10 ;First search patient's CPT file
+11 SET BPXCODE=""
FOR
SET BPXCODE=$ORDER(^AUPNVCPT("AA",DFN,BPXCODE))
IF 'BPXCODE!(FOUND=1)
QUIT
Begin DoDot:1
+12 SET BPXINV=END
FOR
SET BPXINV=$ORDER(^AUPNVCPT("AA",DFN,BPXCODE,BPXINV))
IF 'BPXINV!(FOUND=1)!(BPXINV>BEG)
QUIT
Begin DoDot:2
+13 SET BPXPR=""
FOR
SET BPXPR=$ORDER(^AUPNVCPT("AA",DFN,BPXCODE,BPXINV,BPXPR))
IF 'BPXPR!(FOUND=1)
QUIT
Begin DoDot:3
+14 SET BPXREC=$GET(^AUPNVCPT(BPXPR,0))
+15 IF $PIECE(BPXREC,U,2)'=DFN
QUIT
+16 SET BPXIEN=$PIECE(BPXREC,U)
+17 IF BPXIEN=""
QUIT
+18 SET CODE=$$GET1^DIQ(9000010.18,BPXPR,.01,"I")
+19 IF $$ICD^ATXAPI(CODE,$ORDER(^ATXAX("B",TAX,0)),1)
Begin DoDot:4
+20 SET FOUND=1
+21 SET CODETXT=$PIECE($GET(^ICPT(CODE,0)),U,2)
+22 SET DONDTE=$$GET1^DIQ(9000010.18,BPXPR,1201)
+23 IF DONDTE=""
SET DONDTE=$$GET1^DIQ(9000010.18,BPXPR,.03)
+24 SET TEST=1
SET TEXT="CPT Code"
SET DATE=DONDTE
SET VALUE=CODETXT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 IF FOUND=0
SET TEST=0
SET DATE=TODAY
+26 QUIT
