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

BKMVSUP4.m

Go to the documentation of this file. 
  1. 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
  1.  Q
  1. HEP(DFN) ; EP - Retrieve Hepatitis Panel taxonomies
  1.  N LAST,GLOBAL
  1.  ; D UPD^BKMVSUP
  1.  S LINE=" Hepatitis: "
  1.  D UPD^BKMVSUP S LINE="     Hepatitis Panel:"
  1.  K BKMT("HPNL")
  1.  S GLOBAL="BKMT(""HPNL"",VSTDT,TEST,""LAB"")"
  1.  D LABTAX^BKMIXX(DFN,"BKM HEPATITIS PANEL TAX","","",GLOBAL)
  1.  D LOINC^BKMIXX(DFN,"BKM HEP PANEL LOINC CODES","","",GLOBAL)
  1.  ; Retrieve labs for CPT and store in BKMT("HPNL")
  1.  S LAST=$$GETLAB("BKM HEPATITIS PANEL CPTS",DFN)
  1.  I LAST S BKMT("HPNL",+LAST,$P(LAST,U,2),"LAB")=$P(LAST,U,3)
  1.  ;
  1.  ; Find most recent lab test from BKMT("HPNL") and process panel 
  1.  D PANEL
  1.  ; If no results found check refusal file
  1.  I '$D(BKMT("HPNL")) D
  1.  . S GLOBAL="BKMT(""HPNL"",VSTDT,TEST,""LAB"")"
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP PANEL LOINC CODES","","",GLOBAL)
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEPATITIS PANEL TAX","","",GLOBAL)
  1.  . ; Print results
  1.  . D LTAXPRT^BKMVSUP1("HPNL",1,1,1)
  1.  ; Retain array for comparison with Hep B and C
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. HEPA(DFN) ; EP - Retrieve Hep A taxonomies
  1.  N RESULT,VDT,TST,LABT,GLOBAL,LDT
  1.  S LINE="     Hep A: "
  1.  K BKMT("HEPA")
  1.  S GLOBAL="BKMT(""HEPA"",VSTDT,TEST,""LAB"")"
  1.  D LABTAX^BKMIXX(DFN,"BKM HEP A TAX","","",GLOBAL)
  1.  D LOINC^BKMIXX(DFN,"BKM HEP A LOINC CODES","","",GLOBAL)
  1.  D MULT("HEPA")
  1.  S GLOBAL="LABT(""HEPA"",LSTDT\1,TEST)"
  1.  S RESULT=$$GETLAB^BKMVSUP4("BKM HEP A TESTS CPTS",DFN,GLOBAL)
  1.  I RESULT]"" D
  1.  . S VDT=+RESULT,TST=$P(RESULT,U,2),RESULT=$P(RESULT,U,3)
  1.  . I TST]"" S BKMT("HEPA",VDT,TST,"LAB")=RESULT
  1.  D HEPCMP("HEPA") ;Compare BKMT("HEPA" with BKMT("HPNL" and delete overlaps
  1.  ; Only print results if last HEP A is more recent than last Hep Panel
  1.  I $D(BKMT("HEPA")) D
  1.  . S LDT=$O(BKMT("HEPA",""),-1)\1
  1.  . I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
  1.  . ; Print results
  1.  . D PRTHEP(LDT,"HEPA")
  1.  ; If no results found check refusal file
  1.  I '$D(BKMT("HEPA")) D
  1.  . S GLOBAL="BKMT(""HEPA"",VSTDT,TEST,""LAB"")"
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP A LOINC CODES","","",GLOBAL)
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP A TAX","","",GLOBAL)
  1.  . S LDT=$O(BKMT("HEPA",""),-1)\1
  1.  . I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
  1.  . ; Print results
  1.  . D LTAXPRT^BKMVSUP1("HEPA",1,1,1)
  1.  K BKMT("HEPA")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. HEPB(DFN) ; EP - Retrieve Hep B taxonomies
  1.  N RESULT,VDT,TST,LABT,GLOBAL,LDT
  1.  S LINE="     Hep B: "
  1.  K BKMT("HEPB")
  1.  S GLOBAL="BKMT(""HEPB"",VSTDT,TEST,""LAB"")"
  1.  D LABTAX^BKMIXX(DFN,"BKM HEP B TAX","","",GLOBAL)
  1.  D LOINC^BKMIXX(DFN,"BKM HEP B LOINC CODES","","",GLOBAL)
  1.  D MULT("HEPB")
  1.  S GLOBAL="LABT(""HEPB"",LSTDT\1,TEST)"
  1.  S RESULT=$$GETLAB^BKMVSUP4("BKM HEP B TESTS CPTS",DFN,GLOBAL)
  1.  I RESULT]"" D
  1.  . S VDT=+RESULT,TST=$P(RESULT,U,2),RESULT=$P(RESULT,U,3)
  1.  . I TST]"" S BKMT("HEPB",VDT,TST,"LAB")=RESULT
  1.  D HEPCMP("HEPB") ;Compare BKMT("HEPB" with BKMT("HPNL" and delete overlaps
  1.  ; Only print results if last HEP B is more recent than last Hep Panel
  1.  I $D(BKMT("HEPB")) D
  1.  . S LDT=$O(BKMT("HEPB",""),-1)\1
  1.  . I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
  1.  . ; Print results
  1.  . D PRTHEP(LDT,"HEPB")
  1.  ; If no results found check refusal file
  1.  I '$D(BKMT("HEPB")) D
  1.  . S GLOBAL="BKMT(""HEPB"",VSTDT,TEST,""LAB"")"
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP B LOINC CODES","","",GLOBAL)
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP B TAX","","",GLOBAL)
  1.  . S LDT=$O(BKMT("HEPB",""),-1)\1
  1.  . I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
  1.  . ; Print results
  1.  . D LTAXPRT^BKMVSUP1("HEPB",1,1,1)
  1.  K BKMT("HEPB")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. HEPC(DFN) ; EP - Retrieve Hep C taxonomies
  1.  N LAST,TYP,GLOBAL1,GLOBAL2,LABT,LDT,VDT,TST,RESULT,Y,TEST,END
  1.  S LINE="     Hep C: "
  1.  K BKMT("HEPC"),BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
  1.  S GLOBAL1="BKMT(""HEPC-EIA"",VSTDT,TEST,""LAB"")"
  1.  S GLOBAL2="BKMT(""HEPC-RIBA"",VSTDT,TEST,""LAB"")"
  1.  D LABTAX^BKMIXX(DFN,"BKM HEP C SCREENING TAX","","",GLOBAL1)
  1.  D LABTAX^BKMIXX(DFN,"BKM HEP C CONFIRMATORY TAX","","",GLOBAL2)
  1.  D LOINC^BKMIXX(DFN,"BKM HEP C SCREEN LOINC CODES","","",GLOBAL1)
  1.  D LOINC^BKMIXX(DFN,"BKM HEP C CONFIRM LOINC CODES","","",GLOBAL2)
  1.  F TYP="HEPC-EIA","HEPC-RIBA" D MULT(TYP)
  1.  S GLOBAL1="LABT(""HEPC-EIA"",LSTDT\1,TEST)"
  1.  S GLOBAL2="LABT(""HEPC-RIBA"",LSTDT\1,TEST)"
  1.  S RESULT=$$GETLAB("BKM HEP C SCREEN TESTS CPTS",DFN,GLOBAL1)
  1.  I RESULT]"" D
  1.  . S VDT=+RESULT,TST=$P(RESULT,U,2),RESULT=$P(RESULT,U,3)
  1.  . I TST]"" S BKMT("HEPC-EIA",VDT,TST,"LAB")=RESULT
  1.  S RESULT=$$GETLAB("BKM HEP C CONFIRM TESTS CPTS",DFN,GLOBAL2)
  1.  I RESULT]"" D
  1.  . S VDT=+RESULT,TST=$P(RESULT,U,2),RESULT=$P(RESULT,U,3)
  1.  . I TST]"" S BKMT("HEPC-RIBA",VDT,TST,"CPT")=RESULT
  1.  ; BKMT("HEPC") is consolidated list of results
  1.  M BKMT("HEPC")=BKMT("HEPC-EIA")
  1.  M BKMT("HEPC")=BKMT("HEPC-RIBA")
  1.  D HEPCMP("HEPC") ;Compare BKMT("HEPC" with BKMT("HPNL" and delete overlaps
  1.  ; Determine if result (last test) is EIA or RIBA
  1.  I $D(BKMT("HEPC")),$O(BKMT("HEPC",""),-1) D
  1.  . S LAST=$Q(BKMT("HEPC",""),-1)
  1.  . ; Only print results if last HEP C is more recent than last Hep Panel
  1.  . S LDT=$O(BKMT("HEPC",""),-1)\1
  1.  . I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
  1.  . I $D(@("BKMT(""HEPC-EIA"","_$P(LAST,",",2)_")")) S LINE=LINE_"[EIA] " D
  1.  .. D PRTHEP(LDT,"HEPC-EIA")
  1.  .. I '$D(@("BKMT(""HEPC-RIBA"","_$P(LAST,",",2)_")")) Q
  1.  .. ; If EIA and Confirm on same day print both
  1.  .. D UPD^BKMVSUP S LINE="     Hep C: "
  1.  . I $D(@("BKMT(""HEPC-RIBA"","_$P(LAST,",",2)_")")) D
  1.  .. S LINE=LINE_"[Confirm] " D PRTHEP(LDT,"HEPC-RIBA")
  1.  K BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
  1.  ; If no results found check refusal file
  1.  I '$D(BKMT("HEPC")) D
  1.  . S GLOBAL1="BKMT(""HEPC-EIA"",VSTDT,TEST,""LAB"")"
  1.  . S GLOBAL2="BKMT(""HEPC-RIBA"",VSTDT,TEST,""LAB"")"
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP C SCREEN LOINC CODES","","",GLOBAL1)
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP C CONFIRM LOINC CODES","","",GLOBAL2)
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP C SCREENING TAX","","",GLOBAL1)
  1.  . D REFUSAL^BKMIXX2(DFN,60,"BKM HEP C CONFIRMATORY TAX","","",GLOBAL2)
  1.  . ; BKMT("HEPC") is consolidated list of results
  1.  . M BKMT("HEPC")=BKMT("HEPC-EIA")
  1.  . M BKMT("HEPC")=BKMT("HEPC-RIBA")
  1.  . ; Is refusal EIA or RIBA
  1.  . I $D(BKMT("HEPC")),$O(BKMT("HEPC",""),-1) D
  1.  .. S LAST=$Q(BKMT("HEPC",""),-1)
  1.  .. S LDT=$O(BKMT("HEPC",""),-1)\1
  1.  .. I LDT'>($O(BKMT("HPNL",""),-1)\1) Q
  1.  .. I $D(@("BKMT(""HEPC-EIA"","_$P(LAST,",",2,9999))) S LINE=LINE_"[SCREENING] " Q
  1.  .. S LINE=LINE_"[CONFIRMATORY] "
  1.  . K BKMT("HEPC-EIA"),BKMT("HEPC-RIBA")
  1.  . ; Print results
  1.  . D LTAXPRT^BKMVSUP1("HEPC",1,1,1)
  1.  K BKMT("HEPC")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. PANEL ; EP - Get panel of tests associated with lab and print
  1.  N PDT,REVDT,TEST,LAB,PNL,LABIEN,OLABIEN,OLAB,VISIT,VSTDT
  1.  K ^TMP("BKMSUPP",$J,"LAB"),^TMP("BKMSUPP",$J,"PANEL"),^TMP("BKMSUPP",$J,"HPNL")
  1.  ;
  1.  ; Get most recent lab test
  1.  S PDT=$O(BKMT("HPNL",""),-1) Q:PDT=""
  1.  S REVDT=9999999-$P(PDT,"."),TEST=""
  1.  F  S TEST=$O(BKMT("HPNL",PDT,TEST)) Q:TEST=""  D
  1.  . I $D(BKMT("HPNL",PDT,TEST,"LAB")) D  Q:LAB]""
  1.  .. S LAB=$$GET1^DIQ(9000010.09,TEST,.01,"I") Q:LAB=""
  1.  .. S ^TMP("BKMSUPP",$J,"LAB",LAB)=BKMT("HPNL",PDT,TEST,"LAB")
  1.  Q:'$D(^TMP("BKMSUPP",$J,"LAB"))  ; No lab tests found
  1.  ;
  1.  ; get panels associated with lab tests
  1.  S (LAB,PNL)=""
  1.  F  S LAB=$O(^TMP("BKMSUPP",$J,"LAB",LAB)) Q:LAB=""  D
  1.  . F  S PNL=$O(^LAB(60,"AB",LAB,PNL)) Q:PNL=""  D
  1.  .. ; Check if patient has lab panel on lab date
  1.  .. S LABIEN=$O(^AUPNVLAB("AA",DFN,PNL,REVDT,"")) Q:'LABIEN
  1.  .. S ^TMP("BKMSUPP",$J,"PANEL",PNL,LAB)=^TMP("BKMSUPP",$J,"LAB",LAB)
  1.  .. ;
  1.  .. ; Check other lab tests in panel
  1.  .. D PANLD(PNL,DFN,REVDT,LAB)
  1.  . I $D(^LAB(60,LAB,2)) D PANLD(LAB,DFN,REVDT) ; Test is itself a panel
  1.  ;
  1.  ; If no panel of tests for most recent lab do not print Hep Panel info
  1.  I '$D(^TMP("BKMSUPP",$J,"PANEL")) K BKMT("HPNL"),^TMP("BKMSUPP",$J,"HPNL") D UPD^BKMVSUP:LINE'="" Q
  1.  ;
  1.  ; Print panel of tests associated with most recent lab
  1.  S PNL=""
  1.  F  S PNL=$O(^TMP("BKMSUPP",$J,"PANEL",PNL)) Q:PNL=""  D
  1.  . S LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_$P($$FMTE^XLFDT(PDT,"5Z"),"@")
  1.  . I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  . D UPD^BKMVSUP S LINE="     "_$$GET1^DIQ(60,PNL,.01,"E")
  1.  . S LAB=""
  1.  . F  S LAB=$O(^TMP("BKMSUPP",$J,"PANEL",PNL,LAB)) Q:LAB=""  D
  1.  .. I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  .. D UPD^BKMVSUP S LINE="       "_$$GET1^DIQ(60,LAB,.01,"E")
  1.  .. S LINE=$$LINE^BKMVSUP(LINE,"Result: ",43)_^TMP("BKMSUPP",$J,"PANEL",PNL,LAB)
  1.  ;
  1.  ; Copy related lab tests into BKMT("HPNL") for HEPCMP to ensure
  1.  ; that any tests printed here will not be duplicated in the Hep B or C sections
  1.  I $D(^TMP("BKMSUPP",$J,"HPNL")) D
  1.  . M BKMT("HPNL")=^TMP("BKMSUPP",$J,"HPNL") K ^TMP("BKMSUPP",$J,"HPNL")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1.  ;
  1. PANLD(PANEL,DFN,REVDT,OTHER) ; EP
  1.  ; Load lab tests associated with panel in ^TMP
  1.  ; If lab test in taxonomy is part of a panel, OTHER is the original lab test 
  1.  N LABTST,LAB,LABIEN,VISIT,VSTDT
  1.  S OTHER=$G(OTHER)
  1.  S LABTST=0
  1.  F  S LABTST=$O(^LAB(60,PANEL,2,LABTST)) Q:'LABTST  D
  1.  . S LAB=$G(^LAB(60,PANEL,2,LABTST,0)) Q:LAB=""!(LAB=OTHER)
  1.  . S LABIEN=$O(^AUPNVLAB("AA",DFN,LAB,REVDT,"")) Q:'LABIEN
  1.  . S ^TMP("BKMSUPP",$J,"PANEL",PANEL,LAB)=$$GET1^DIQ(9000010.09,LABIEN,.04,"I")
  1.  . S VISIT=$$GET1^DIQ(9000010.09,LABIEN,.03,"I")
  1.  . S VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
  1.  . I VSTDT]"" S ^TMP("BKMSUPP",$J,"HPNL",VSTDT,LABIEN,"LAB")=""
  1.  Q
  1.  ;
  1. GETLAB(TAX,DFN,TARGET) ; EP
  1.  ; Get most recent lab result associated with a CPT taxonomy for a patient
  1.  ; To return all lab tests for most recent date, TARGET (Target root - global or local)
  1.  ;    can be passed and will return this data; this is an optional parameter
  1.  N CPT,BCPTR,LAB,LAST,LSTDT,TEST,VISIT,VSTDT,RESULT
  1.  K ^TMP("BKMCPT",$J)
  1.  S (LAST,LSTDT,RESULT)=""
  1.  D BLDTAX^BKMIXX5(TAX,"^TMP(""BKMCPT"",$J)")
  1.  S CPT="" F  S CPT=$O(^TMP("BKMCPT",$J,CPT)) Q:CPT=""  D
  1.  . S BCPTR=0 F  S BCPTR=$O(^BLRCPT(BCPTR)) Q:'BCPTR  D
  1.  .. Q:'$D(^BLRCPT(BCPTR,11,"B",CPT))
  1.  .. S LAB=$P($G(^BLRCPT(BCPTR,1)),U) Q:LAB=""
  1.  .. S LAB(LAB)=""
  1.  I $O(LAB("")) D
  1.  . N LABR
  1.  . S TEST=""
  1.  . F  S TEST=$O(^AUPNVLAB("AC",DFN,TEST),-1) Q:TEST=""  D  Q:LAST]""
  1.  .. S LAB=$$GET1^DIQ(9000010.09,TEST,.01,"I") Q:LAB=""  Q:'$D(LAB(LAB))
  1.  .. S VISIT=$$GET1^DIQ(9000010.09,TEST,.03,"I")
  1.  .. S VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
  1.  .. I VSTDT>LSTDT S LAST=TEST,LSTDT=VSTDT,LABR(LSTDT\1,TEST)=""
  1.  . I $G(TARGET)]"" D
  1.  .. Q:'$D(LABR)
  1.  .. S TEST="" F  S TEST=$O(LABR(LSTDT\1,TEST)) Q:TEST=""  D
  1.  ... S @TARGET=$$GET1^DIQ(9000010.09,TEST,.04,"I")_U_$$GET1^DIQ(9000010.09,TEST,.01,"E")
  1.  . I LAST S RESULT=$$GET1^DIQ(9000010.09,LAST,.04,"I")
  1.  Q LSTDT_U_LAST_U_RESULT
  1.  ;
  1. MULT(TYP) ; Load multiple results in LABT array
  1.  N HEPDT,HEPIEN
  1.  S HEPDT=$O(BKMT(TYP,""),-1) I HEPDT  D
  1.  . S HEPIEN=""
  1.  . F  S HEPIEN=$O(BKMT(TYP,HEPDT,HEPIEN)) Q:'HEPIEN  D
  1.  .. S LABT(TYP,HEPDT\1,HEPIEN)=$$GET1^DIQ(9000010.09,HEPIEN,.04,"I")_U_$$GET1^DIQ(9000010.09,HEPIEN,.01,"E")
  1.  Q
  1.  ;
  1. HEPCMP(TYPE) ; Compare Hep Panel results with Hep B or Hep C (TYPE determines which one)
  1.  N STOP,OTHER,PANEL
  1.  S STOP="BKMT("""_TYPE_"""",OTHER=STOP_")",PANEL="BKMT(""HPNL"","
  1.  F  S OTHER=$Q(@OTHER) Q:$P(OTHER,",")'=STOP  I $D(@(PANEL_$P(OTHER,",",2,99))) K @OTHER
  1.  Q
  1.  ;
  1. PRTHEP(LDT,TYP) ; For Hep B and C print all results for last date using LABT array
  1.  S Y=$$FMTE^XLFDT(LDT,"5Z")
  1.  S LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_Y
  1.  I TYP]"" D
  1.  . S END="LABT("""_TYP_""","_LDT,TEST=END_")"
  1.  . F  S TEST=$Q(@TEST) Q:$P(TEST,",",1,2)'=END  D
  1.  .. D UPD^BKMVSUP S LINE="       "_$P(@TEST,U,2)
  1.  .. S LINE=$$LINE^BKMVSUP(LINE," Result: ",42)_$P(@TEST,U)
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. XIT ; QUIT POINT
  1.  Q