BKMVSUP4 ;PRXM/HC/WOM - Continuation of BKMVSUP, HIV SUPPLEMENT; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 12:31 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
Q
HEP(DFN) ; EP - Retrieve Hepatitis Panel taxonomies
N LAST,GLOBAL
; D UPD^BKMVSUP
S LINE=" Hepatitis: "
D UPD^BKMVSUP S LINE=" Hepatitis Panel:"
K BKMT("HPNL")
S GLOBAL="BKMT(""HPNL"",VSTDT,TEST,""LAB"")"
D LABTAX^BKMIXX(DFN,"BKM HEPATITIS PANEL TAX","","",GLOBAL)
D LOINC^BKMIXX(DFN,"BKM HEP PANEL LOINC CODES","","",GLOBAL)
; Retrieve labs for CPT and store in BKMT("HPNL")
S LAST=$$GETLAB("BKM HEPATITIS PANEL CPTS",DFN)
I LAST S BKMT("HPNL",+LAST,$P(LAST,U,2),"LAB")=$P(LAST,U,3)
;
; Find most recent lab test from BKMT("HPNL") and process panel
D PANEL
; If no results found check refusal file
I '$D(BKMT("HPNL")) D
. S GLOBAL="BKMT(""HPNL"",VSTDT,TEST,""LAB"")"
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP PANEL LOINC CODES","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEPATITIS PANEL TAX","","",GLOBAL)
. ; Print results
. D LTAXPRT^BKMVSUP1("HPNL",1,1,1)
; Retain array for comparison with Hep B and C
I LINE'="" D UPD^BKMVSUP
Q
HEPA(DFN) ; EP - Retrieve Hep A taxonomies
N RESULT,VDT,TST,LABT,GLOBAL,LDT
S LINE=" Hep A: "
K BKMT("HEPA")
S GLOBAL="BKMT(""HEPA"",VSTDT,TEST,""LAB"")"
D LABTAX^BKMIXX(DFN,"BKM HEP A TAX","","",GLOBAL)
D LOINC^BKMIXX(DFN,"BKM HEP A LOINC CODES","","",GLOBAL)
D MULT("HEPA")
S GLOBAL="LABT(""HEPA"",LSTDT\1,TEST)"
S RESULT=$$GETLAB^BKMVSUP4("BKM HEP A TESTS CPTS",DFN,GLOBAL)
I RESULT]"" D
. S VDT=+RESULT,TST=$P(RESULT,U,2),RESULT=$P(RESULT,U,3)
. I TST]"" S BKMT("HEPA",VDT,TST,"LAB")=RESULT
D HEPCMP("HEPA") ;Compare BKMT("HEPA" with BKMT("HPNL" and delete overlaps
; Only print results if last HEP A is more recent than last Hep Panel
I $D(BKMT("HEPA")) D
. S LDT=$O(BKMT("HEPA",""),-1)\1
. I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
. ; Print results
. D PRTHEP(LDT,"HEPA")
; If no results found check refusal file
I '$D(BKMT("HEPA")) D
. S GLOBAL="BKMT(""HEPA"",VSTDT,TEST,""LAB"")"
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP A LOINC CODES","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP A TAX","","",GLOBAL)
. S LDT=$O(BKMT("HEPA",""),-1)\1
. I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
. ; Print results
. D LTAXPRT^BKMVSUP1("HEPA",1,1,1)
K BKMT("HEPA")
I LINE'="" D UPD^BKMVSUP
Q
HEPB(DFN) ; EP - Retrieve Hep B taxonomies
N RESULT,VDT,TST,LABT,GLOBAL,LDT
S LINE=" Hep B: "
K BKMT("HEPB")
S GLOBAL="BKMT(""HEPB"",VSTDT,TEST,""LAB"")"
D LABTAX^BKMIXX(DFN,"BKM HEP B TAX","","",GLOBAL)
D LOINC^BKMIXX(DFN,"BKM HEP B LOINC CODES","","",GLOBAL)
D MULT("HEPB")
S GLOBAL="LABT(""HEPB"",LSTDT\1,TEST)"
S RESULT=$$GETLAB^BKMVSUP4("BKM HEP B TESTS CPTS",DFN,GLOBAL)
I RESULT]"" D
. S VDT=+RESULT,TST=$P(RESULT,U,2),RESULT=$P(RESULT,U,3)
. I TST]"" S BKMT("HEPB",VDT,TST,"LAB")=RESULT
D HEPCMP("HEPB") ;Compare BKMT("HEPB" with BKMT("HPNL" and delete overlaps
; Only print results if last HEP B is more recent than last Hep Panel
I $D(BKMT("HEPB")) D
. S LDT=$O(BKMT("HEPB",""),-1)\1
. I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
. ; Print results
. D PRTHEP(LDT,"HEPB")
; If no results found check refusal file
I '$D(BKMT("HEPB")) D
. S GLOBAL="BKMT(""HEPB"",VSTDT,TEST,""LAB"")"
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP B LOINC CODES","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP B TAX","","",GLOBAL)
. S LDT=$O(BKMT("HEPB",""),-1)\1
. I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
. ; Print results
. D LTAXPRT^BKMVSUP1("HEPB",1,1,1)
K BKMT("HEPB")
I LINE'="" D UPD^BKMVSUP
Q
HEPC(DFN) ; EP - Retrieve Hep C taxonomies
N LAST,TYP,GLOBAL1,GLOBAL2,LABT,LDT,VDT,TST,RESULT,Y,TEST,END
S LINE=" Hep C: "
K BKMT("HEPC"),BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
S GLOBAL1="BKMT(""HEPC-EIA"",VSTDT,TEST,""LAB"")"
S GLOBAL2="BKMT(""HEPC-RIBA"",VSTDT,TEST,""LAB"")"
D LABTAX^BKMIXX(DFN,"BKM HEP C SCREENING TAX","","",GLOBAL1)
D LABTAX^BKMIXX(DFN,"BKM HEP C CONFIRMATORY TAX","","",GLOBAL2)
D LOINC^BKMIXX(DFN,"BKM HEP C SCREEN LOINC CODES","","",GLOBAL1)
D LOINC^BKMIXX(DFN,"BKM HEP C CONFIRM LOINC CODES","","",GLOBAL2)
F TYP="HEPC-EIA","HEPC-RIBA" D MULT(TYP)
S GLOBAL1="LABT(""HEPC-EIA"",LSTDT\1,TEST)"
S GLOBAL2="LABT(""HEPC-RIBA"",LSTDT\1,TEST)"
S RESULT=$$GETLAB("BKM HEP C SCREEN TESTS CPTS",DFN,GLOBAL1)
I RESULT]"" D
. S VDT=+RESULT,TST=$P(RESULT,U,2),RESULT=$P(RESULT,U,3)
. I TST]"" S BKMT("HEPC-EIA",VDT,TST,"LAB")=RESULT
S RESULT=$$GETLAB("BKM HEP C CONFIRM TESTS CPTS",DFN,GLOBAL2)
I RESULT]"" D
. S VDT=+RESULT,TST=$P(RESULT,U,2),RESULT=$P(RESULT,U,3)
. I TST]"" S BKMT("HEPC-RIBA",VDT,TST,"CPT")=RESULT
; BKMT("HEPC") is consolidated list of results
M BKMT("HEPC")=BKMT("HEPC-EIA")
M BKMT("HEPC")=BKMT("HEPC-RIBA")
D HEPCMP("HEPC") ;Compare BKMT("HEPC" with BKMT("HPNL" and delete overlaps
; Determine if result (last test) is EIA or RIBA
I $D(BKMT("HEPC")),$O(BKMT("HEPC",""),-1) D
. S LAST=$Q(BKMT("HEPC",""),-1)
. ; Only print results if last HEP C is more recent than last Hep Panel
. S LDT=$O(BKMT("HEPC",""),-1)\1
. I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
. I $D(@("BKMT(""HEPC-EIA"","_$P(LAST,",",2)_")")) S LINE=LINE_"[EIA] " D
.. D PRTHEP(LDT,"HEPC-EIA")
.. I '$D(@("BKMT(""HEPC-RIBA"","_$P(LAST,",",2)_")")) Q
.. ; If EIA and Confirm on same day print both
.. D UPD^BKMVSUP S LINE=" Hep C: "
. I $D(@("BKMT(""HEPC-RIBA"","_$P(LAST,",",2)_")")) D
.. S LINE=LINE_"[Confirm] " D PRTHEP(LDT,"HEPC-RIBA")
K BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
; If no results found check refusal file
I '$D(BKMT("HEPC")) D
. S GLOBAL1="BKMT(""HEPC-EIA"",VSTDT,TEST,""LAB"")"
. S GLOBAL2="BKMT(""HEPC-RIBA"",VSTDT,TEST,""LAB"")"
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP C SCREEN LOINC CODES","","",GLOBAL1)
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP C CONFIRM LOINC CODES","","",GLOBAL2)
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP C SCREENING TAX","","",GLOBAL1)
. D REFUSAL^BKMIXX2(DFN,60,"BKM HEP C CONFIRMATORY TAX","","",GLOBAL2)
. ; BKMT("HEPC") is consolidated list of results
. M BKMT("HEPC")=BKMT("HEPC-EIA")
. M BKMT("HEPC")=BKMT("HEPC-RIBA")
. ; Is refusal EIA or RIBA
. I $D(BKMT("HEPC")),$O(BKMT("HEPC",""),-1) D
.. S LAST=$Q(BKMT("HEPC",""),-1)
.. S LDT=$O(BKMT("HEPC",""),-1)\1
.. I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
.. I $D(@("BKMT(""HEPC-EIA"","_$P(LAST,",",2,9999))) S LINE=LINE_"[SCREENING] " Q
.. S LINE=LINE_"[CONFIRMATORY] "
. K BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
. ; Print results
. D LTAXPRT^BKMVSUP1("HEPC",1,1,1)
K BKMT("HEPC")
I LINE'="" D UPD^BKMVSUP
Q
PANEL ; EP - Get panel of tests associated with lab and print
N PDT,REVDT,TEST,LAB,PNL,LABIEN,OLABIEN,OLAB,VISIT,VSTDT
K ^TMP("BKMSUPP",$J,"LAB"),^TMP("BKMSUPP",$J,"PANEL"),^TMP("BKMSUPP",$J,"HPNL")
;
; Get most recent lab test
S PDT=$O(BKMT("HPNL",""),-1) Q:PDT=""
S REVDT=9999999-$P(PDT,"."),TEST=""
F S TEST=$O(BKMT("HPNL",PDT,TEST)) Q:TEST="" D
. I $D(BKMT("HPNL",PDT,TEST,"LAB")) D Q:LAB]""
.. S LAB=$$GET1^DIQ(9000010.09,TEST,.01,"I") Q:LAB=""
.. S ^TMP("BKMSUPP",$J,"LAB",LAB)=BKMT("HPNL",PDT,TEST,"LAB")
Q:'$D(^TMP("BKMSUPP",$J,"LAB")) ; No lab tests found
;
; get panels associated with lab tests
S (LAB,PNL)=""
F S LAB=$O(^TMP("BKMSUPP",$J,"LAB",LAB)) Q:LAB="" D
. F S PNL=$O(^LAB(60,"AB",LAB,PNL)) Q:PNL="" D
.. ; Check if patient has lab panel on lab date
.. S LABIEN=$O(^AUPNVLAB("AA",DFN,PNL,REVDT,"")) Q:'LABIEN
.. S ^TMP("BKMSUPP",$J,"PANEL",PNL,LAB)=^TMP("BKMSUPP",$J,"LAB",LAB)
.. ;
.. ; Check other lab tests in panel
.. D PANLD(PNL,DFN,REVDT,LAB)
. I $D(^LAB(60,LAB,2)) D PANLD(LAB,DFN,REVDT) ; Test is itself a panel
;
; If no panel of tests for most recent lab do not print Hep Panel info
I '$D(^TMP("BKMSUPP",$J,"PANEL")) K BKMT("HPNL"),^TMP("BKMSUPP",$J,"HPNL") D UPD^BKMVSUP:LINE'="" Q
;
; Print panel of tests associated with most recent lab
S PNL=""
F S PNL=$O(^TMP("BKMSUPP",$J,"PANEL",PNL)) Q:PNL="" D
. S LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_$P($$FMTE^XLFDT(PDT,"5Z"),"@")
. I LNCNT>MAXCT D NEWPG^BKMVSUP
. D UPD^BKMVSUP S LINE=" "_$$GET1^DIQ(60,PNL,.01,"E")
. S LAB=""
. F S LAB=$O(^TMP("BKMSUPP",$J,"PANEL",PNL,LAB)) Q:LAB="" D
.. I LNCNT>MAXCT D NEWPG^BKMVSUP
.. D UPD^BKMVSUP S LINE=" "_$$GET1^DIQ(60,LAB,.01,"E")
.. S LINE=$$LINE^BKMVSUP(LINE,"Result: ",43)_^TMP("BKMSUPP",$J,"PANEL",PNL,LAB)
;
; Copy related lab tests into BKMT("HPNL") for HEPCMP to ensure
; that any tests printed here will not be duplicated in the Hep B or C sections
I $D(^TMP("BKMSUPP",$J,"HPNL")) D
. M BKMT("HPNL")=^TMP("BKMSUPP",$J,"HPNL") K ^TMP("BKMSUPP",$J,"HPNL")
I LINE'="" D UPD^BKMVSUP
Q
;
PANLD(PANEL,DFN,REVDT,OTHER) ; EP
; Load lab tests associated with panel in ^TMP
; If lab test in taxonomy is part of a panel, OTHER is the original lab test
N LABTST,LAB,LABIEN,VISIT,VSTDT
S OTHER=$G(OTHER)
S LABTST=0
F S LABTST=$O(^LAB(60,PANEL,2,LABTST)) Q:'LABTST D
. S LAB=$G(^LAB(60,PANEL,2,LABTST,0)) Q:LAB=""!(LAB=OTHER)
. S LABIEN=$O(^AUPNVLAB("AA",DFN,LAB,REVDT,"")) Q:'LABIEN
. S ^TMP("BKMSUPP",$J,"PANEL",PANEL,LAB)=$$GET1^DIQ(9000010.09,LABIEN,.04,"I")
. S VISIT=$$GET1^DIQ(9000010.09,LABIEN,.03,"I")
. S VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
. I VSTDT]"" S ^TMP("BKMSUPP",$J,"HPNL",VSTDT,LABIEN,"LAB")=""
Q
;
GETLAB(TAX,DFN,TARGET) ; EP
; Get most recent lab result associated with a CPT taxonomy for a patient
; To return all lab tests for most recent date, TARGET (Target root - global or local)
; can be passed and will return this data; this is an optional parameter
N CPT,BCPTR,LAB,LAST,LSTDT,TEST,VISIT,VSTDT,RESULT
K ^TMP("BKMCPT",$J)
S (LAST,LSTDT,RESULT)=""
D BLDTAX^BKMIXX5(TAX,"^TMP(""BKMCPT"",$J)")
S CPT="" F S CPT=$O(^TMP("BKMCPT",$J,CPT)) Q:CPT="" D
. S BCPTR=0 F S BCPTR=$O(^BLRCPT(BCPTR)) Q:'BCPTR D
.. Q:'$D(^BLRCPT(BCPTR,11,"B",CPT))
.. S LAB=$P($G(^BLRCPT(BCPTR,1)),U) Q:LAB=""
.. S LAB(LAB)=""
I $O(LAB("")) D
. N LABR
. S TEST=""
. F S TEST=$O(^AUPNVLAB("AC",DFN,TEST),-1) Q:TEST="" D Q:LAST]""
.. S LAB=$$GET1^DIQ(9000010.09,TEST,.01,"I") Q:LAB="" Q:'$D(LAB(LAB))
.. S VISIT=$$GET1^DIQ(9000010.09,TEST,.03,"I")
.. S VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
.. I VSTDT>LSTDT S LAST=TEST,LSTDT=VSTDT,LABR(LSTDT\1,TEST)=""
. I $G(TARGET)]"" D
.. Q:'$D(LABR)
.. S TEST="" F S TEST=$O(LABR(LSTDT\1,TEST)) Q:TEST="" D
... S @TARGET=$$GET1^DIQ(9000010.09,TEST,.04,"I")_U_$$GET1^DIQ(9000010.09,TEST,.01,"E")
. I LAST S RESULT=$$GET1^DIQ(9000010.09,LAST,.04,"I")
Q LSTDT_U_LAST_U_RESULT
;
MULT(TYP) ; Load multiple results in LABT array
N HEPDT,HEPIEN
S HEPDT=$O(BKMT(TYP,""),-1) I HEPDT D
. S HEPIEN=""
. F S HEPIEN=$O(BKMT(TYP,HEPDT,HEPIEN)) Q:'HEPIEN D
.. S LABT(TYP,HEPDT\1,HEPIEN)=$$GET1^DIQ(9000010.09,HEPIEN,.04,"I")_U_$$GET1^DIQ(9000010.09,HEPIEN,.01,"E")
Q
;
HEPCMP(TYPE) ; Compare Hep Panel results with Hep B or Hep C (TYPE determines which one)
N STOP,OTHER,PANEL
S STOP="BKMT("""_TYPE_"""",OTHER=STOP_")",PANEL="BKMT(""HPNL"","
F S OTHER=$Q(@OTHER) Q:$P(OTHER,",")'=STOP I $D(@(PANEL_$P(OTHER,",",2,99))) K @OTHER
Q
;
PRTHEP(LDT,TYP) ; For Hep B and C print all results for last date using LABT array
S Y=$$FMTE^XLFDT(LDT,"5Z")
S LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_Y
I TYP]"" D
. S END="LABT("""_TYP_""","_LDT,TEST=END_")"
. F S TEST=$Q(@TEST) Q:$P(TEST,",",1,2)'=END D
.. D UPD^BKMVSUP S LINE=" "_$P(@TEST,U,2)
.. S LINE=$$LINE^BKMVSUP(LINE," Result: ",42)_$P(@TEST,U)
I LINE'="" D UPD^BKMVSUP
Q
XIT ; QUIT POINT
Q
BKMVSUP4 ;PRXM/HC/WOM - Continuation of BKMVSUP, HIV SUPPLEMENT; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 12:31 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 QUIT
HEP(DFN) ; EP - Retrieve Hepatitis Panel taxonomies
+1 NEW LAST,GLOBAL
+2 ; D UPD^BKMVSUP
+3 SET LINE=" Hepatitis: "
+4 DO UPD^BKMVSUP
SET LINE=" Hepatitis Panel:"
+5 KILL BKMT("HPNL")
+6 SET GLOBAL="BKMT(""HPNL"",VSTDT,TEST,""LAB"")"
+7 DO LABTAX^BKMIXX(DFN,"BKM HEPATITIS PANEL TAX","","",GLOBAL)
+8 DO LOINC^BKMIXX(DFN,"BKM HEP PANEL LOINC CODES","","",GLOBAL)
+9 ; Retrieve labs for CPT and store in BKMT("HPNL")
+10 SET LAST=$$GETLAB("BKM HEPATITIS PANEL CPTS",DFN)
+11 IF LAST
SET BKMT("HPNL",+LAST,$PIECE(LAST,U,2),"LAB")=$PIECE(LAST,U,3)
+12 ;
+13 ; Find most recent lab test from BKMT("HPNL") and process panel
+14 DO PANEL
+15 ; If no results found check refusal file
+16 IF '$DATA(BKMT("HPNL"))
Begin DoDot:1
+17 SET GLOBAL="BKMT(""HPNL"",VSTDT,TEST,""LAB"")"
+18 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP PANEL LOINC CODES","","",GLOBAL)
+19 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEPATITIS PANEL TAX","","",GLOBAL)
+20 ; Print results
+21 DO LTAXPRT^BKMVSUP1("HPNL",1,1,1)
End DoDot:1
+22 ; Retain array for comparison with Hep B and C
+23 IF LINE'=""
DO UPD^BKMVSUP
+24 QUIT
HEPA(DFN) ; EP - Retrieve Hep A taxonomies
+1 NEW RESULT,VDT,TST,LABT,GLOBAL,LDT
+2 SET LINE=" Hep A: "
+3 KILL BKMT("HEPA")
+4 SET GLOBAL="BKMT(""HEPA"",VSTDT,TEST,""LAB"")"
+5 DO LABTAX^BKMIXX(DFN,"BKM HEP A TAX","","",GLOBAL)
+6 DO LOINC^BKMIXX(DFN,"BKM HEP A LOINC CODES","","",GLOBAL)
+7 DO MULT("HEPA")
+8 SET GLOBAL="LABT(""HEPA"",LSTDT\1,TEST)"
+9 SET RESULT=$$GETLAB^BKMVSUP4("BKM HEP A TESTS CPTS",DFN,GLOBAL)
+10 IF RESULT]""
Begin DoDot:1
+11 SET VDT=+RESULT
SET TST=$PIECE(RESULT,U,2)
SET RESULT=$PIECE(RESULT,U,3)
+12 IF TST]""
SET BKMT("HEPA",VDT,TST,"LAB")=RESULT
End DoDot:1
+13 ;Compare BKMT("HEPA" with BKMT("HPNL" and delete overlaps
DO HEPCMP("HEPA")
+14 ; Only print results if last HEP A is more recent than last Hep Panel
+15 IF $DATA(BKMT("HEPA"))
Begin DoDot:1
+16 SET LDT=$ORDER(BKMT("HEPA",""),-1)\1
+17 IF LDT'>($ORDER(BKMT("HPNL",""),-1)\1)
QUIT
+18 ; Print results
+19 DO PRTHEP(LDT,"HEPA")
End DoDot:1
+20 ; If no results found check refusal file
+21 IF '$DATA(BKMT("HEPA"))
Begin DoDot:1
+22 SET GLOBAL="BKMT(""HEPA"",VSTDT,TEST,""LAB"")"
+23 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP A LOINC CODES","","",GLOBAL)
+24 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP A TAX","","",GLOBAL)
+25 SET LDT=$ORDER(BKMT("HEPA",""),-1)\1
+26 IF LDT'>($ORDER(BKMT("HPNL",""),-1)\1)
QUIT
+27 ; Print results
+28 DO LTAXPRT^BKMVSUP1("HEPA",1,1,1)
End DoDot:1
+29 KILL BKMT("HEPA")
+30 IF LINE'=""
DO UPD^BKMVSUP
+31 QUIT
HEPB(DFN) ; EP - Retrieve Hep B taxonomies
+1 NEW RESULT,VDT,TST,LABT,GLOBAL,LDT
+2 SET LINE=" Hep B: "
+3 KILL BKMT("HEPB")
+4 SET GLOBAL="BKMT(""HEPB"",VSTDT,TEST,""LAB"")"
+5 DO LABTAX^BKMIXX(DFN,"BKM HEP B TAX","","",GLOBAL)
+6 DO LOINC^BKMIXX(DFN,"BKM HEP B LOINC CODES","","",GLOBAL)
+7 DO MULT("HEPB")
+8 SET GLOBAL="LABT(""HEPB"",LSTDT\1,TEST)"
+9 SET RESULT=$$GETLAB^BKMVSUP4("BKM HEP B TESTS CPTS",DFN,GLOBAL)
+10 IF RESULT]""
Begin DoDot:1
+11 SET VDT=+RESULT
SET TST=$PIECE(RESULT,U,2)
SET RESULT=$PIECE(RESULT,U,3)
+12 IF TST]""
SET BKMT("HEPB",VDT,TST,"LAB")=RESULT
End DoDot:1
+13 ;Compare BKMT("HEPB" with BKMT("HPNL" and delete overlaps
DO HEPCMP("HEPB")
+14 ; Only print results if last HEP B is more recent than last Hep Panel
+15 IF $DATA(BKMT("HEPB"))
Begin DoDot:1
+16 SET LDT=$ORDER(BKMT("HEPB",""),-1)\1
+17 IF LDT'>($ORDER(BKMT("HPNL",""),-1)\1)
QUIT
+18 ; Print results
+19 DO PRTHEP(LDT,"HEPB")
End DoDot:1
+20 ; If no results found check refusal file
+21 IF '$DATA(BKMT("HEPB"))
Begin DoDot:1
+22 SET GLOBAL="BKMT(""HEPB"",VSTDT,TEST,""LAB"")"
+23 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP B LOINC CODES","","",GLOBAL)
+24 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP B TAX","","",GLOBAL)
+25 SET LDT=$ORDER(BKMT("HEPB",""),-1)\1
+26 IF LDT'>($ORDER(BKMT("HPNL",""),-1)\1)
QUIT
+27 ; Print results
+28 DO LTAXPRT^BKMVSUP1("HEPB",1,1,1)
End DoDot:1
+29 KILL BKMT("HEPB")
+30 IF LINE'=""
DO UPD^BKMVSUP
+31 QUIT
HEPC(DFN) ; EP - Retrieve Hep C taxonomies
+1 NEW LAST,TYP,GLOBAL1,GLOBAL2,LABT,LDT,VDT,TST,RESULT,Y,TEST,END
+2 SET LINE=" Hep C: "
+3 KILL BKMT("HEPC"),BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
+4 SET GLOBAL1="BKMT(""HEPC-EIA"",VSTDT,TEST,""LAB"")"
+5 SET GLOBAL2="BKMT(""HEPC-RIBA"",VSTDT,TEST,""LAB"")"
+6 DO LABTAX^BKMIXX(DFN,"BKM HEP C SCREENING TAX","","",GLOBAL1)
+7 DO LABTAX^BKMIXX(DFN,"BKM HEP C CONFIRMATORY TAX","","",GLOBAL2)
+8 DO LOINC^BKMIXX(DFN,"BKM HEP C SCREEN LOINC CODES","","",GLOBAL1)
+9 DO LOINC^BKMIXX(DFN,"BKM HEP C CONFIRM LOINC CODES","","",GLOBAL2)
+10 FOR TYP="HEPC-EIA","HEPC-RIBA"
DO MULT(TYP)
+11 SET GLOBAL1="LABT(""HEPC-EIA"",LSTDT\1,TEST)"
+12 SET GLOBAL2="LABT(""HEPC-RIBA"",LSTDT\1,TEST)"
+13 SET RESULT=$$GETLAB("BKM HEP C SCREEN TESTS CPTS",DFN,GLOBAL1)
+14 IF RESULT]""
Begin DoDot:1
+15 SET VDT=+RESULT
SET TST=$PIECE(RESULT,U,2)
SET RESULT=$PIECE(RESULT,U,3)
+16 IF TST]""
SET BKMT("HEPC-EIA",VDT,TST,"LAB")=RESULT
End DoDot:1
+17 SET RESULT=$$GETLAB("BKM HEP C CONFIRM TESTS CPTS",DFN,GLOBAL2)
+18 IF RESULT]""
Begin DoDot:1
+19 SET VDT=+RESULT
SET TST=$PIECE(RESULT,U,2)
SET RESULT=$PIECE(RESULT,U,3)
+20 IF TST]""
SET BKMT("HEPC-RIBA",VDT,TST,"CPT")=RESULT
End DoDot:1
+21 ; BKMT("HEPC") is consolidated list of results
+22 MERGE BKMT("HEPC")=BKMT("HEPC-EIA")
+23 MERGE BKMT("HEPC")=BKMT("HEPC-RIBA")
+24 ;Compare BKMT("HEPC" with BKMT("HPNL" and delete overlaps
DO HEPCMP("HEPC")
+25 ; Determine if result (last test) is EIA or RIBA
+26 IF $DATA(BKMT("HEPC"))
IF $ORDER(BKMT("HEPC",""),-1)
Begin DoDot:1
+27 SET LAST=$QUERY(BKMT("HEPC",""),-1)
+28 ; Only print results if last HEP C is more recent than last Hep Panel
+29 SET LDT=$ORDER(BKMT("HEPC",""),-1)\1
+30 IF LDT'>($ORDER(BKMT("HPNL",""),-1)\1)
QUIT
+31 IF $DATA(@("BKMT(""HEPC-EIA"","_$PIECE(LAST,",",2)_")"))
SET LINE=LINE_"[EIA] "
Begin DoDot:2
+32 DO PRTHEP(LDT,"HEPC-EIA")
+33 IF '$DATA(@("BKMT(""HEPC-RIBA"","_$PIECE(LAST,",",2)_")"))
QUIT
+34 ; If EIA and Confirm on same day print both
+35 DO UPD^BKMVSUP
SET LINE=" Hep C: "
End DoDot:2
+36 IF $DATA(@("BKMT(""HEPC-RIBA"","_$PIECE(LAST,",",2)_")"))
Begin DoDot:2
+37 SET LINE=LINE_"[Confirm] "
DO PRTHEP(LDT,"HEPC-RIBA")
End DoDot:2
End DoDot:1
+38 KILL BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
+39 ; If no results found check refusal file
+40 IF '$DATA(BKMT("HEPC"))
Begin DoDot:1
+41 SET GLOBAL1="BKMT(""HEPC-EIA"",VSTDT,TEST,""LAB"")"
+42 SET GLOBAL2="BKMT(""HEPC-RIBA"",VSTDT,TEST,""LAB"")"
+43 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP C SCREEN LOINC CODES","","",GLOBAL1)
+44 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP C CONFIRM LOINC CODES","","",GLOBAL2)
+45 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP C SCREENING TAX","","",GLOBAL1)
+46 DO REFUSAL^BKMIXX2(DFN,60,"BKM HEP C CONFIRMATORY TAX","","",GLOBAL2)
+47 ; BKMT("HEPC") is consolidated list of results
+48 MERGE BKMT("HEPC")=BKMT("HEPC-EIA")
+49 MERGE BKMT("HEPC")=BKMT("HEPC-RIBA")
+50 ; Is refusal EIA or RIBA
+51 IF $DATA(BKMT("HEPC"))
IF $ORDER(BKMT("HEPC",""),-1)
Begin DoDot:2
+52 SET LAST=$QUERY(BKMT("HEPC",""),-1)
+53 SET LDT=$ORDER(BKMT("HEPC",""),-1)\1
+54 IF LDT'>($ORDER(BKMT("HPNL",""),-1)\1)
QUIT
+55 IF $DATA(@("BKMT(""HEPC-EIA"","_$PIECE(LAST,",",2,9999)))
SET LINE=LINE_"[SCREENING] "
QUIT
+56 SET LINE=LINE_"[CONFIRMATORY] "
End DoDot:2
+57 KILL BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
+58 ; Print results
+59 DO LTAXPRT^BKMVSUP1("HEPC",1,1,1)
End DoDot:1
+60 KILL BKMT("HEPC")
+61 IF LINE'=""
DO UPD^BKMVSUP
+62 QUIT
PANEL ; EP - Get panel of tests associated with lab and print
+1 NEW PDT,REVDT,TEST,LAB,PNL,LABIEN,OLABIEN,OLAB,VISIT,VSTDT
+2 KILL ^TMP("BKMSUPP",$JOB,"LAB"),^TMP("BKMSUPP",$JOB,"PANEL"),^TMP("BKMSUPP",$JOB,"HPNL")
+3 ;
+4 ; Get most recent lab test
+5 SET PDT=$ORDER(BKMT("HPNL",""),-1)
IF PDT=""
QUIT
+6 SET REVDT=9999999-$PIECE(PDT,".")
SET TEST=""
+7 FOR
SET TEST=$ORDER(BKMT("HPNL",PDT,TEST))
IF TEST=""
QUIT
Begin DoDot:1
+8 IF $DATA(BKMT("HPNL",PDT,TEST,"LAB"))
Begin DoDot:2
+9 SET LAB=$$GET1^DIQ(9000010.09,TEST,.01,"I")
IF LAB=""
QUIT
+10 SET ^TMP("BKMSUPP",$JOB,"LAB",LAB)=BKMT("HPNL",PDT,TEST,"LAB")
End DoDot:2
IF LAB]""
QUIT
End DoDot:1
+11 ; No lab tests found
IF '$DATA(^TMP("BKMSUPP",$JOB,"LAB"))
QUIT
+12 ;
+13 ; get panels associated with lab tests
+14 SET (LAB,PNL)=""
+15 FOR
SET LAB=$ORDER(^TMP("BKMSUPP",$JOB,"LAB",LAB))
IF LAB=""
QUIT
Begin DoDot:1
+16 FOR
SET PNL=$ORDER(^LAB(60,"AB",LAB,PNL))
IF PNL=""
QUIT
Begin DoDot:2
+17 ; Check if patient has lab panel on lab date
+18 SET LABIEN=$ORDER(^AUPNVLAB("AA",DFN,PNL,REVDT,""))
IF 'LABIEN
QUIT
+19 SET ^TMP("BKMSUPP",$JOB,"PANEL",PNL,LAB)=^TMP("BKMSUPP",$JOB,"LAB",LAB)
+20 ;
+21 ; Check other lab tests in panel
+22 DO PANLD(PNL,DFN,REVDT,LAB)
End DoDot:2
+23 ; Test is itself a panel
IF $DATA(^LAB(60,LAB,2))
DO PANLD(LAB,DFN,REVDT)
End DoDot:1
+24 ;
+25 ; If no panel of tests for most recent lab do not print Hep Panel info
+26 IF '$DATA(^TMP("BKMSUPP",$JOB,"PANEL"))
KILL BKMT("HPNL"),^TMP("BKMSUPP",$JOB,"HPNL")
IF LINE'=""
DO UPD^BKMVSUP
QUIT
+27 ;
+28 ; Print panel of tests associated with most recent lab
+29 SET PNL=""
+30 FOR
SET PNL=$ORDER(^TMP("BKMSUPP",$JOB,"PANEL",PNL))
IF PNL=""
QUIT
Begin DoDot:1
+31 SET LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_$PIECE($$FMTE^XLFDT(PDT,"5Z"),"@")
+32 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+33 DO UPD^BKMVSUP
SET LINE=" "_$$GET1^DIQ(60,PNL,.01,"E")
+34 SET LAB=""
+35 FOR
SET LAB=$ORDER(^TMP("BKMSUPP",$JOB,"PANEL",PNL,LAB))
IF LAB=""
QUIT
Begin DoDot:2
+36 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+37 DO UPD^BKMVSUP
SET LINE=" "_$$GET1^DIQ(60,LAB,.01,"E")
+38 SET LINE=$$LINE^BKMVSUP(LINE,"Result: ",43)_^TMP("BKMSUPP",$JOB,"PANEL",PNL,LAB)
End DoDot:2
End DoDot:1
+39 ;
+40 ; Copy related lab tests into BKMT("HPNL") for HEPCMP to ensure
+41 ; that any tests printed here will not be duplicated in the Hep B or C sections
+42 IF $DATA(^TMP("BKMSUPP",$JOB,"HPNL"))
Begin DoDot:1
+43 MERGE BKMT("HPNL")=^TMP("BKMSUPP",$JOB,"HPNL")
KILL ^TMP("BKMSUPP",$JOB,"HPNL")
End DoDot:1
+44 IF LINE'=""
DO UPD^BKMVSUP
+45 QUIT
+46 ;
PANLD(PANEL,DFN,REVDT,OTHER) ; EP
+1 ; Load lab tests associated with panel in ^TMP
+2 ; If lab test in taxonomy is part of a panel, OTHER is the original lab test
+3 NEW LABTST,LAB,LABIEN,VISIT,VSTDT
+4 SET OTHER=$GET(OTHER)
+5 SET LABTST=0
+6 FOR
SET LABTST=$ORDER(^LAB(60,PANEL,2,LABTST))
IF 'LABTST
QUIT
Begin DoDot:1
+7 SET LAB=$GET(^LAB(60,PANEL,2,LABTST,0))
IF LAB=""!(LAB=OTHER)
QUIT
+8 SET LABIEN=$ORDER(^AUPNVLAB("AA",DFN,LAB,REVDT,""))
IF 'LABIEN
QUIT
+9 SET ^TMP("BKMSUPP",$JOB,"PANEL",PANEL,LAB)=$$GET1^DIQ(9000010.09,LABIEN,.04,"I")
+10 SET VISIT=$$GET1^DIQ(9000010.09,LABIEN,.03,"I")
+11 SET VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
+12 IF VSTDT]""
SET ^TMP("BKMSUPP",$JOB,"HPNL",VSTDT,LABIEN,"LAB")=""
End DoDot:1
+13 QUIT
+14 ;
GETLAB(TAX,DFN,TARGET) ; EP
+1 ; Get most recent lab result associated with a CPT taxonomy for a patient
+2 ; To return all lab tests for most recent date, TARGET (Target root - global or local)
+3 ; can be passed and will return this data; this is an optional parameter
+4 NEW CPT,BCPTR,LAB,LAST,LSTDT,TEST,VISIT,VSTDT,RESULT
+5 KILL ^TMP("BKMCPT",$JOB)
+6 SET (LAST,LSTDT,RESULT)=""
+7 DO BLDTAX^BKMIXX5(TAX,"^TMP(""BKMCPT"",$J)")
+8 SET CPT=""
FOR
SET CPT=$ORDER(^TMP("BKMCPT",$JOB,CPT))
IF CPT=""
QUIT
Begin DoDot:1
+9 SET BCPTR=0
FOR
SET BCPTR=$ORDER(^BLRCPT(BCPTR))
IF 'BCPTR
QUIT
Begin DoDot:2
+10 IF '$DATA(^BLRCPT(BCPTR,11,"B",CPT))
QUIT
+11 SET LAB=$PIECE($GET(^BLRCPT(BCPTR,1)),U)
IF LAB=""
QUIT
+12 SET LAB(LAB)=""
End DoDot:2
End DoDot:1
+13 IF $ORDER(LAB(""))
Begin DoDot:1
+14 NEW LABR
+15 SET TEST=""
+16 FOR
SET TEST=$ORDER(^AUPNVLAB("AC",DFN,TEST),-1)
IF TEST=""
QUIT
Begin DoDot:2
+17 SET LAB=$$GET1^DIQ(9000010.09,TEST,.01,"I")
IF LAB=""
QUIT
IF '$DATA(LAB(LAB))
QUIT
+18 SET VISIT=$$GET1^DIQ(9000010.09,TEST,.03,"I")
+19 SET VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
+20 IF VSTDT>LSTDT
SET LAST=TEST
SET LSTDT=VSTDT
SET LABR(LSTDT\1,TEST)=""
End DoDot:2
IF LAST]""
QUIT
+21 IF $GET(TARGET)]""
Begin DoDot:2
+22 IF '$DATA(LABR)
QUIT
+23 SET TEST=""
FOR
SET TEST=$ORDER(LABR(LSTDT\1,TEST))
IF TEST=""
QUIT
Begin DoDot:3
+24 SET @TARGET=$$GET1^DIQ(9000010.09,TEST,.04,"I")_U_$$GET1^DIQ(9000010.09,TEST,.01,"E")
End DoDot:3
End DoDot:2
+25 IF LAST
SET RESULT=$$GET1^DIQ(9000010.09,LAST,.04,"I")
End DoDot:1
+26 QUIT LSTDT_U_LAST_U_RESULT
+27 ;
MULT(TYP) ; Load multiple results in LABT array
+1 NEW HEPDT,HEPIEN
+2 SET HEPDT=$ORDER(BKMT(TYP,""),-1)
IF HEPDT
Begin DoDot:1
+3 SET HEPIEN=""
+4 FOR
SET HEPIEN=$ORDER(BKMT(TYP,HEPDT,HEPIEN))
IF 'HEPIEN
QUIT
Begin DoDot:2
+5 SET LABT(TYP,HEPDT\1,HEPIEN)=$$GET1^DIQ(9000010.09,HEPIEN,.04,"I")_U_$$GET1^DIQ(9000010.09,HEPIEN,.01,"E")
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
HEPCMP(TYPE) ; Compare Hep Panel results with Hep B or Hep C (TYPE determines which one)
+1 NEW STOP,OTHER,PANEL
+2 SET STOP="BKMT("""_TYPE_""""
SET OTHER=STOP_")"
SET PANEL="BKMT(""HPNL"","
+3 FOR
SET OTHER=$QUERY(@OTHER)
IF $PIECE(OTHER,",")'=STOP
QUIT
IF $DATA(@(PANEL_$PIECE(OTHER,",",2,99)))
KILL @OTHER
+4 QUIT
+5 ;
PRTHEP(LDT,TYP) ; For Hep B and C print all results for last date using LABT array
+1 SET Y=$$FMTE^XLFDT(LDT,"5Z")
+2 SET LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_Y
+3 IF TYP]""
Begin DoDot:1
+4 SET END="LABT("""_TYP_""","_LDT
SET TEST=END_")"
+5 FOR
SET TEST=$QUERY(@TEST)
IF $PIECE(TEST,",",1,2)'=END
QUIT
Begin DoDot:2
+6 DO UPD^BKMVSUP
SET LINE=" "_$PIECE(@TEST,U,2)
+7 SET LINE=$$LINE^BKMVSUP(LINE," Result: ",42)_$PIECE(@TEST,U)
End DoDot:2
End DoDot:1
+8 IF LINE'=""
DO UPD^BKMVSUP
+9 QUIT
XIT ; QUIT POINT
+1 QUIT
