BPXRMSNO.m

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