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

BKMVSUP5.m

Go to the documentation of this file. 
  1. BKMVSUP5 ;PRXM/HC/WOM - Continuation of BKMVSUP, HIV SUPPLEMENT; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005  12:31 PM
  1.  ;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
  1.  Q
  1. FLOW(DFN) ; EP - Generate Flow Sheet
  1.  I LNCNT>(MAXCT-4) D NEWPG^BKMVSUP
  1.  D UPD^BKMVSUP S LINE=" HIV FLOW SHEET" D UPD^BKMVSUP
  1.  N FLTST,FLDT,FLIEN,FLTYP,CNT,LAST,STOP,MAX,MEDNM,MEDDT,DISDT
  1.  K BKMT("FLOW"),BKMT("PRT")
  1.  F FLTST="VL","CD4ABS" S CNT=0 D
  1.  . S FLDT=""
  1.  . F  S FLDT=$O(BKMT(FLTST,FLDT),-1) Q:FLDT=""  D  Q:CNT=6
  1.  .. S FLIEN=""
  1.  .. F  S FLIEN=$O(BKMT(FLTST,FLDT,FLIEN)) Q:FLIEN=""  D  Q:CNT=6
  1.  ... S FLTYP=""
  1.  ... F  S FLTYP=$O(BKMT(FLTST,FLDT,FLIEN,FLTYP)) Q:FLTYP=""  D  Q:CNT=6
  1.  .... I $P(BKMT(FLTST,FLDT,FLIEN,FLTYP),U)]"" D  ;Only include if results are present
  1.  ..... S BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP)=BKMT(FLTST,FLDT,FLIEN,FLTYP),CNT=CNT+1
  1.  K BKMT("VL"),BKMT("CD4ABS")
  1.  Q:'$D(BKMT("FLOW"))
  1.  ;
  1.  S STOP="" K BKMT("FLOWD")
  1.  ; Only print 6 dates; combine if dates are w/in 7 days
  1.  S LAST=$O(BKMT("FLOW",""),-1),FLDT=LAST,CNT=1,FLDT(LAST)="",BKMT("FLOWD",LAST,LAST)=""
  1.  F  S FLDT=$O(BKMT("FLOW",FLDT),-1) Q:FLDT=""  D  Q:STOP
  1.  . I $$FMDIFF^XLFDT(LAST,FLDT,1)<8 D  Q
  1.  .. M BKMT("FLOW",LAST)=BKMT("FLOW",FLDT) K BKMT("FLOW",FLDT) S BKMT("FLOWD",LAST,FLDT)=""
  1.  . I CNT=6 S STOP=1 Q
  1.  . S LAST=FLDT,FLDT(LAST)="",CNT=CNT+1,BKMT("FLOWD",LAST,LAST)=""
  1.  ;
  1.  ; Reorder array for printing
  1.  S FLDT="",MAX("VL")="",MAX("CD4ABS")=""
  1.  F  S FLDT=$O(BKMT("FLOW",FLDT)) Q:FLDT=""  D
  1.  . S FLTST="" F  S FLTST=$O(BKMT("FLOW",FLDT,FLTST)) Q:FLTST=""  D
  1.  .. S FLIEN=""  F  S FLIEN=$O(BKMT("FLOW",FLDT,FLTST,FLIEN)) Q:FLIEN=""  D
  1.  ... S FLTYP="" F  S FLTYP=$O(BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP)) Q:FLTYP=""  D
  1.  .... S CNT=$G(BKMT("PRT",FLTST,FLDT))+1,BKMT("PRT",FLTST,FLDT)=CNT
  1.  .... I CNT>MAX(FLTST) S MAX(FLTST)=CNT
  1.  .... S BKMT("PRT",FLTST,FLDT,CNT)=BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP)
  1.  ;
  1.  ; Print results
  1.  N MEDDYS,FIRST,MEDDSPDT,MEDISSDT
  1.  K BKMT("FLOW")
  1.  S FLDT=""
  1.  F CNT=0:1:5 S FLDT=$O(FLDT(FLDT)) Q:FLDT=""  S FLDT(FLDT)=18+(CNT*10)
  1.  D PRTDT ; Print dates
  1.  S LINE=" Viral Load"
  1.  D PRTFL("VL",MAX("VL"))
  1.  D UPD^BKMVSUP S LINE=" CD4 Count"
  1.  D PRTFL("CD4ABS",MAX("CD4ABS"))
  1.  ; Get HAART Medication
  1.  ; Loop through currently active medications
  1.  K BKMT("MED")
  1.  S MEDDT=""
  1.  F  S MEDDT=$O(^TMP("BKMSUPP",$J,"HAART",MEDDT)) Q:MEDDT=""  D
  1.  . S MEDIEN=""
  1.  . F  S MEDIEN=$O(^TMP("BKMSUPP",$J,"HAART",MEDDT,MEDIEN)) Q:MEDIEN=""  D
  1.  .. S MEDDYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"I") ; Get days prescribed
  1.  .. I MEDDYS="" S MEDDYS=30 ; Using Health Summary logic
  1.  .. Q:'MEDDYS
  1.  .. S MEDDSPDT=$$RX(MEDIEN,MEDDT,101) ; Get last dispensed date
  1.  .. S MEDISSDT=$$RX(MEDIEN,MEDDT,1) ; Get issue date
  1.  .. S MEDNM=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E") ; Get med name
  1.  .. I MEDNM="" S MEDNM="Unknown"
  1.  .. S FLDT=""
  1.  .. F  S FLDT=$O(FLDT(FLDT)) Q:FLDT=""  D
  1.  ... ; If Last Dispensed Date (or Visit Date if no PCC LINK) + DAYS is earlier than the lab date, skip this med
  1.  ... I $$FMADD^XLFDT(MEDDSPDT,MEDDYS)<(FLDT\1) Q
  1.  ... ; Medication must be active prior to the first date of the test
  1.  ... S FIRST=$O(BKMT("FLOWD",FLDT,"")) Q:'FIRST
  1.  ... I MEDISSDT'<(FIRST\1) Q
  1.  ... S BKMT("MED",MEDNM,FLDT)=""
  1.  ;
  1.  ; Loop through inactive medications
  1.  S DISDT=""
  1.  F  S DISDT=$O(BKMT("HAARTD",DISDT)) Q:DISDT=""  D
  1.  . S MEDDT=""
  1.  . F  S MEDDT=$O(BKMT("HAARTD",DISDT,MEDDT)) Q:MEDDT=""  D
  1.  .. S MEDIEN=""
  1.  .. F  S MEDIEN=$O(BKMT("HAARTD",DISDT,MEDDT,MEDIEN)) Q:MEDIEN=""  D
  1.  ... S MEDDYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"I") ; Get days prescribed
  1.  ... I MEDDYS="" S MEDDYS=30 ; Using Health Summary logic
  1.  ... Q:'MEDDYS
  1.  ... S MEDDSPDT=$$RX(MEDIEN,MEDDT,101) ; Get last dispensed date
  1.  ... S MEDISSDT=$$RX(MEDIEN,MEDDT,1) ; Get issue date
  1.  ... S MEDNM=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E") ; Get med name
  1.  ... I MEDNM="" S MEDNM="Unknown"
  1.  ... S FLDT=""
  1.  ... F  S FLDT=$O(FLDT(FLDT)) Q:FLDT=""  D  ;I DISDT\1>(FLDT\1) D; IHS removed discontinued date check 04/27/06
  1.  .... ; If Last Dispensed Date (or Visit Date if no PCC LINK) + DAYS is earlier than the lab date, skip this med
  1.  .... S FIRST=$O(BKMT("FLOWD",FLDT,"")) Q:'FIRST
  1.  .... I $$FMADD^XLFDT(MEDDSPDT,MEDDYS)<(FIRST\1) Q
  1.  .... ; Medication must be active prior to the first date of the test
  1.  .... I MEDISSDT\1'<(FIRST\1) Q
  1.  .... S BKMT("MED",MEDNM,FLDT)=""
  1.  D UPD^BKMVSUP
  1.  ;
  1.  ; Print medications for listed dates
  1.  S MEDNM=""
  1.  F  S MEDNM=$O(BKMT("MED",MEDNM)) Q:MEDNM=""  D
  1.  . D UPD^BKMVSUP S LINE=" "_$E(MEDNM,1,16)
  1.  . S MEDDT="" F  S MEDDT=$O(BKMT("MED",MEDNM,MEDDT)) Q:MEDDT=""  D
  1.  .. S LINE=$$LINE^BKMVSUP(LINE,"   x",FLDT(MEDDT))
  1.  . I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. RX(MEDIEN,DFLTDT,FLD) ; Get date from prescription file if PCC LINK exists
  1.  ; FLD = field for desired date
  1.  I '$D(^PSRX("APCC",MEDIEN)) Q DFLTDT\1
  1.  N PSRXIEN,PSRXDT
  1.  S PSRXIEN=$O(^PSRX("APCC",MEDIEN,""))
  1.  I PSRXIEN S PSRXDT=$$GET1^DIQ(52,PSRXIEN,FLD,"I") I PSRXDT S DFLTDT=PSRXDT
  1.  Q DFLTDT\1
  1. PRTDT ; Print dates for subheader
  1.  N FIRST
  1.  S FLDT="" F  S FLDT=$O(FLDT(FLDT)) Q:FLDT=""  D
  1.  . S FIRST=$O(BKMT("FLOWD",FLDT,"")) I 'FIRST S FIRST=FLDT
  1.  . S LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT(FIRST,"2Z"),"@"),FLDT(FLDT))
  1.  D UPD^BKMVSUP,BLANK^BKMVSUP(1)
  1.  Q
  1. PRTFL(TYPE,MAX) ;
  1.  N LCNT,RESULT
  1.  F LCNT=1:1:MAX D  D UPD^BKMVSUP
  1.  .S FLDT=""
  1.  .F  S FLDT=$O(FLDT(FLDT)) Q:FLDT=""  D
  1.  .. S RESULT=$E($G(BKMT("PRT",TYPE,FLDT,LCNT)),1,8)
  1.  .. S LINE=$$LINE^BKMVSUP(LINE,$E("       ",1,8-$L(RESULT)\2),FLDT(FLDT))_RESULT
  1.  .. I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  Q
  1. REM(DFN) ; EP - List Reminders
  1.  ; Remove message since this will be handled during processing not printing
  1.  ; I IOST["C-" W !!?1,"Calculating HIV-RELATED REMINDERS - Please wait."
  1.  D UPD^BKMVSUP,BLANK^BKMVSUP(1) S LINE=" HIV-RELATED REMINDERS: " D UPD^BKMVSUP
  1.  N PRT,A1,B1,DUE,OVERDUE,REMTXT,DXDT
  1.  K REMLIST D REMIND^BKMVF3(DFN,NOW,.REMLIST)
  1.  I LNCNT>(MAXCT-1) D NEWPG^BKMVSUP
  1.  I $O(REMLIST("")) D
  1.  . D UPD^BKMVSUP S LINE=" Reminder",LINE=$$LINE^BKMVSUP(LINE,"Last",26)
  1.  . S LINE=$$LINE^BKMVSUP(LINE,"Due",41) D UPD^BKMVSUP
  1.  . S A1="" F  S A1=$O(REMLIST(A1)) Q:A1=""  D
  1.  .. S B1="" F  S B1=$O(REMLIST(A1,B1)) Q:B1=""  D
  1.  ... S DUE=$G(REMLIST(A1,B1,"DUE")) ;S:DUE="" DUE="Unknown" this is not on the Clinical Rem, they must be the same
  1.  ... I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  ... I 'DUE,'$G(REMLIST(A1,B1,"LAST")) Q
  1.  ... S REMTXT=$G(REMLIST(A1,B1,0))
  1.  ... S OVERDUE=0
  1.  ... I DUE'="" S:DUE<DT OVERDUE=1 S DUE=$P($$FMTE^XLFDT(+DUE,"5Z"),"@",1)
  1.  ... I OVERDUE=0,$G(REMLIST(A1,B1,"LAST"))="" S DUE="("_DUE_")"
  1.  ... I OVERDUE=1 S DUE=$S($G(REMLIST(A1,B1,"LAST"))="":"("_DUE_")",1:DUE)
  1.  ... ;I OVERDUE=1 S DUE="May Be Due Now (Was due "_DUE_")"
  1.  ... S LINE=" "_$E(REMTXT,1,25)
  1.  ... S LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT($G(REMLIST(A1,B1,"LAST")),"5Z"),"@"),26)
  1.  ... I $G(REMLIST(A1,B1,"LASTTXT"))]"" S LINE=LINE_REMLIST(A1,B1,"LASTTXT")
  1.  ... S LINE=$$LINE^BKMVSUP(LINE,DUE,42) D UPD^BKMVSUP
  1.  ... I REMTXT["Viral Load"!(REMTXT["Trichomoniasis Test")!(REMTXT["Tetanus IZ")!(REMTXT["Dental Exam") D UPD^BKMVSUP
  1.  ... I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  ;
  1.  ; Check for a history of Tuberculosis diagnosis (DX.14) or history of positive PPD test (T.21)
  1.  ; Preferentially list TB dx over positive PPD
  1.  I '$D(REMLIST("REM.T.05")) D
  1.  . ; *** Need to new variables ***
  1.  . ; *** Do we need to examine BKM PPD TAX, BKM PPD CPTS or BKM PPD CVX CODES since they are not used for a positive PPD determination?
  1.  . ; Check for history of Tuberculosis diagnosis
  1.  . ; DX.14
  1.  . S GLOBAL="BKMT(""PPDDX"",VSTDT,TEST,""LAB"")"
  1.  . S GLOBAL1="BKMT(""PPDTEST"",VSTDT,TEST,""LAB"")" ; *** Is this needed? ***
  1.  . S GLOBAL2="BKMT(""PPDPOS"",VSTDT,TEST,""LAB"")"
  1.  . D ICDTAX^BKMIXX1(DFN,"DM AUDIT PROBLEM TB DXS","","",GLOBAL)
  1.  . S DXDT=$O(BKMT("PPDDX",""),-1)
  1.  . I DXDT S LINE=" PPD Diagnosis ",LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT(DXDT,"5Z"),"@"),26) D UPD^BKMVSUP Q
  1.  . ;
  1.  . ; Check for history of positive PPD
  1.  . ; T.21
  1.  . S GLOBAL="BKMT(""PPDDX"",VSTDT,TEST,""LAB"")"
  1.  . D LABTAX^BKMIXX(DFN,"BKM PPD TAX","","",GLOBAL1) ;***
  1.  . D LOINC^BKMIXX(DFN,"BKM PPD LOINC CODES","","",GLOBAL2)
  1.  . S GLOBAL="BKMT(""PPD"",VSTDT,TEST,""CPT"")"
  1.  . D CPTTAX^BKMIXX(DFN,"BKM PPD CPTS","","",GLOBAL1)
  1.  . S GLOBAL="BKMT(""PPD"",VSTDT,TEST,""CVX"")"
  1.  . D CVXTAX^BKMIXX1(DFN,"BKM PPD CVX CODES","","",GLOBAL1)
  1.  . S GLOBAL="BKMT(""PPD"",VSTDT,TEST,""ICD"")"
  1.  . D ICDTAX^BKMIXX1(DFN,"BKM PPD ICDS","","",GLOBAL1)
  1.  . S GLOBAL="BKMT(""PPD"",VSTDT,TEST,""SKIN"")"
  1.  . D SKNTAX^BKMIXX1(DFN,"21","","",GLOBAL2)
  1.  . M BKMT("PPDTEST")=BKMT("PPDPOS")
  1.  . S VSTDT=$O(BKMT("PPDPOS",""),-1)
  1.  . S POS=""
  1.  . I VSTDT D
  1.  .. S TEST=$O(BKMT("PPDPOS",VSTDT,""),-1) Q:'TEST
  1.  .. S RESULT=BKMT("PPDPOS",VSTDT,TEST,"LAB"),POS=$$POS^BKMQQCR7(RESULT)
  1.  . I POS D
  1.  .. S LINE=" PPD ",LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT(VSTDT,"5Z"),"@"),26)
  1.  .. S LINE=$$LINE^BKMVSUP(LINE,"Positive Test Result",42)
  1.  .. D UPD^BKMVSUP
  1.  ;S LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT($G(LIST(A1,B1,"LAST")),"5Z"),"@"),26) . ; 
  1.  K LIST
  1.  I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  D UPD^BKMVSUP,BLANK^BKMVSUP(1)
  1.  Q
  1. ED(DFN) ; EP - Retrieve Education data.
  1.  N BKMCKDT
  1.  S BKMCKDT=$$FMADD^XLFDT(DT,-360)
  1.  D UPD^BKMVSUP,BLANK^BKMVSUP(1)
  1.  S LINE=" Last HIV-related education given (past 12 months): " D UPD^BKMVSUP
  1.  I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  K BKMT("ED")
  1.  S GLOBAL="BKMT(""ED"",VSTDT,TEST,""ICD"")"
  1.  D ICDTAX^BKMIXX1(DFN,"BKM FAMILY PLANNING POV","",BKMCKDT,GLOBAL)
  1.  D ICDTAX^BKMIXX1(DFN,"BKMV HIV ED DXS","",BKMCKDT,GLOBAL)
  1.  D ICDTAX^BKMIXX1(DFN,"BKMV STD ED DXS","",BKMCKDT,GLOBAL)
  1.  S GLOBAL="BKMT(""ED"",VSTDT,TEST,""ED"")"
  1.  ; Patient Education Codes can use two different formats
  1.  D PTEDTAX^BKMIXX(DFN,"FP-","",BKMCKDT,GLOBAL) ; Family Planning
  1.  D PTEDTAX^BKMIXX(DFN,"HIV-,-HIV,*BGP HIV/AIDS DXS","",BKMCKDT,GLOBAL) ; HIV Counseling/Education
  1.  D PTEDTAX^BKMIXX1(DFN,"BKM STD ED CODES","",BKMCKDT,GLOBAL)
  1.  D PTEDTAX^BKMIXX1(DFN,"BKM SAFE SEX ED CODES","",BKMCKDT,GLOBAL)
  1.  I '$D(BKMT("ED")) D EDREF Q  ; Get refusals if no data found
  1.  I LNCNT>(MAXCT-2) D NEWPG^BKMVSUP
  1.  S LINE=$$LINE^BKMVSUP("   [Topic]","[Date]",35)
  1.  S LINE=$$LINE^BKMVSUP(LINE,"[Provider initials]",47)
  1.  N EDDT,EDTST,DISPDT,PROV
  1.  S EDDT="" F  S EDDT=$O(BKMT("ED",EDDT),-1) Q:EDDT=""  D
  1.  . S EDTST="" F  S EDTST=$O(BKMT("ED",EDDT,EDTST)) Q:EDTST=""  D
  1.  .. S DISPDT=$P($$FMTE^XLFDT(EDDT,"5Z"),"@")
  1.  .. I $D(BKMT("ED",EDDT,EDTST,"ICD")) D
  1.  ... D UPD^BKMVSUP S LINE="   "_$E($$GET1^DIQ(9000010.07,EDTST,.01,"E"),1,30)
  1.  ... S LINE=$$LINE^BKMVSUP(LINE,DISPDT,35)
  1.  ... S LINE=$$LINE^BKMVSUP(LINE,$E($$GET1^DIQ(9000010.07,EDTST,.04,"E"),1,30),47)
  1.  ... I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  .. I $D(BKMT("ED",EDDT,EDTST,"ED")) D
  1.  ... D UPD^BKMVSUP S LINE=" "_$E($$GET1^DIQ(9000010.16,EDTST,.01,"E"),1,30)
  1.  ... S LINE=$$LINE^BKMVSUP(LINE,DISPDT,35)
  1.  ... S PROV=$$GET1^DIQ(9000010.16,EDTST,.05,"I") Q:PROV=""
  1.  ... S LINE=$$LINE^BKMVSUP(LINE,$$GET1^DIQ(200,PROV,1,"E"),47)
  1.  ... I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  K BKMT("ED")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. EDREF ; Check refusals for education
  1.  S GLOBAL="BKMT(""ED"",VSTDT,TEST,""ED"")"
  1.  ; Patient Education Codes can use two different formats
  1.  D REFUSAL^BKMIXX2(DFN,9999999.09,"FP-","","",GLOBAL) ; Family Planning
  1.  D REFUSAL^BKMIXX2(DFN,9999999.09,"HIV-,-HIV,*BGP HIV/AIDS DXS","","",GLOBAL) ; HIV Counseling/Education
  1.  D REFUSAL^BKMIXX2(DFN,9999999.09,"BKM STD ED CODES","","",GLOBAL)
  1.  D REFUSAL^BKMIXX2(DFN,9999999.09,"BKM SAFE SEX ED CODES","","",GLOBAL)
  1.  D LTAXPRT^BKMVSUP1("ED",1,1,1)
  1.  K BKMT("ED")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. XIT ; QUIT POINT
  1.  Q