BKMVSUP5 ;PRXM/HC/WOM - Continuation of BKMVSUP, HIV SUPPLEMENT; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 12:31 PM
;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
Q
FLOW(DFN) ; EP - Generate Flow Sheet
I LNCNT>(MAXCT-4) D NEWPG^BKMVSUP
D UPD^BKMVSUP S LINE=" HIV FLOW SHEET" D UPD^BKMVSUP
N FLTST,FLDT,FLIEN,FLTYP,CNT,LAST,STOP,MAX,MEDNM,MEDDT,DISDT
K BKMT("FLOW"),BKMT("PRT")
F FLTST="VL","CD4ABS" S CNT=0 D
. S FLDT=""
. F S FLDT=$O(BKMT(FLTST,FLDT),-1) Q:FLDT="" D Q:CNT=6
.. S FLIEN=""
.. F S FLIEN=$O(BKMT(FLTST,FLDT,FLIEN)) Q:FLIEN="" D Q:CNT=6
... S FLTYP=""
... F S FLTYP=$O(BKMT(FLTST,FLDT,FLIEN,FLTYP)) Q:FLTYP="" D Q:CNT=6
.... I $P(BKMT(FLTST,FLDT,FLIEN,FLTYP),U)]"" D ;Only include if results are present
..... S BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP)=BKMT(FLTST,FLDT,FLIEN,FLTYP),CNT=CNT+1
K BKMT("VL"),BKMT("CD4ABS")
Q:'$D(BKMT("FLOW"))
;
S STOP="" K BKMT("FLOWD")
; Only print 6 dates; combine if dates are w/in 7 days
S LAST=$O(BKMT("FLOW",""),-1),FLDT=LAST,CNT=1,FLDT(LAST)="",BKMT("FLOWD",LAST,LAST)=""
F S FLDT=$O(BKMT("FLOW",FLDT),-1) Q:FLDT="" D Q:STOP
. I $$FMDIFF^XLFDT(LAST,FLDT,1)<8 D Q
.. M BKMT("FLOW",LAST)=BKMT("FLOW",FLDT) K BKMT("FLOW",FLDT) S BKMT("FLOWD",LAST,FLDT)=""
. I CNT=6 S STOP=1 Q
. S LAST=FLDT,FLDT(LAST)="",CNT=CNT+1,BKMT("FLOWD",LAST,LAST)=""
;
; Reorder array for printing
S FLDT="",MAX("VL")="",MAX("CD4ABS")=""
F S FLDT=$O(BKMT("FLOW",FLDT)) Q:FLDT="" D
. S FLTST="" F S FLTST=$O(BKMT("FLOW",FLDT,FLTST)) Q:FLTST="" D
.. S FLIEN="" F S FLIEN=$O(BKMT("FLOW",FLDT,FLTST,FLIEN)) Q:FLIEN="" D
... S FLTYP="" F S FLTYP=$O(BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP)) Q:FLTYP="" D
.... S CNT=$G(BKMT("PRT",FLTST,FLDT))+1,BKMT("PRT",FLTST,FLDT)=CNT
.... I CNT>MAX(FLTST) S MAX(FLTST)=CNT
.... S BKMT("PRT",FLTST,FLDT,CNT)=BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP)
;
; Print results
N MEDDYS,FIRST,MEDDSPDT,MEDISSDT
K BKMT("FLOW")
S FLDT=""
F CNT=0:1:5 S FLDT=$O(FLDT(FLDT)) Q:FLDT="" S FLDT(FLDT)=18+(CNT*10)
D PRTDT ; Print dates
S LINE=" Viral Load"
D PRTFL("VL",MAX("VL"))
D UPD^BKMVSUP S LINE=" CD4 Count"
D PRTFL("CD4ABS",MAX("CD4ABS"))
; Get HAART Medication
; Loop through currently active medications
K BKMT("MED")
S MEDDT=""
F S MEDDT=$O(^TMP("BKMSUPP",$J,"HAART",MEDDT)) Q:MEDDT="" D
. S MEDIEN=""
. F S MEDIEN=$O(^TMP("BKMSUPP",$J,"HAART",MEDDT,MEDIEN)) Q:MEDIEN="" D
.. S MEDDYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"I") ; Get days prescribed
.. I MEDDYS="" S MEDDYS=30 ; Using Health Summary logic
.. Q:'MEDDYS
.. S MEDDSPDT=$$RX(MEDIEN,MEDDT,101) ; Get last dispensed date
.. S MEDISSDT=$$RX(MEDIEN,MEDDT,1) ; Get issue date
.. S MEDNM=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E") ; Get med name
.. I MEDNM="" S MEDNM="Unknown"
.. S FLDT=""
.. F S FLDT=$O(FLDT(FLDT)) Q:FLDT="" D
... ; If Last Dispensed Date (or Visit Date if no PCC LINK) + DAYS is earlier than the lab date, skip this med
... I $$FMADD^XLFDT(MEDDSPDT,MEDDYS)<(FLDT\1) Q
... ; Medication must be active prior to the first date of the test
... S FIRST=$O(BKMT("FLOWD",FLDT,"")) Q:'FIRST
... I MEDISSDT'<(FIRST\1) Q
... S BKMT("MED",MEDNM,FLDT)=""
;
; Loop through inactive medications
S DISDT=""
F S DISDT=$O(BKMT("HAARTD",DISDT)) Q:DISDT="" D
. S MEDDT=""
. F S MEDDT=$O(BKMT("HAARTD",DISDT,MEDDT)) Q:MEDDT="" D
.. S MEDIEN=""
.. F S MEDIEN=$O(BKMT("HAARTD",DISDT,MEDDT,MEDIEN)) Q:MEDIEN="" D
... S MEDDYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"I") ; Get days prescribed
... I MEDDYS="" S MEDDYS=30 ; Using Health Summary logic
... Q:'MEDDYS
... S MEDDSPDT=$$RX(MEDIEN,MEDDT,101) ; Get last dispensed date
... S MEDISSDT=$$RX(MEDIEN,MEDDT,1) ; Get issue date
... S MEDNM=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E") ; Get med name
... I MEDNM="" S MEDNM="Unknown"
... S FLDT=""
... F S FLDT=$O(FLDT(FLDT)) Q:FLDT="" D ;I DISDT\1>(FLDT\1) D; IHS removed discontinued date check 04/27/06
.... ; If Last Dispensed Date (or Visit Date if no PCC LINK) + DAYS is earlier than the lab date, skip this med
.... S FIRST=$O(BKMT("FLOWD",FLDT,"")) Q:'FIRST
.... I $$FMADD^XLFDT(MEDDSPDT,MEDDYS)<(FIRST\1) Q
.... ; Medication must be active prior to the first date of the test
.... I MEDISSDT\1'<(FIRST\1) Q
.... S BKMT("MED",MEDNM,FLDT)=""
D UPD^BKMVSUP
;
; Print medications for listed dates
S MEDNM=""
F S MEDNM=$O(BKMT("MED",MEDNM)) Q:MEDNM="" D
. D UPD^BKMVSUP S LINE=" "_$E(MEDNM,1,16)
. S MEDDT="" F S MEDDT=$O(BKMT("MED",MEDNM,MEDDT)) Q:MEDDT="" D
.. S LINE=$$LINE^BKMVSUP(LINE," x",FLDT(MEDDT))
. I LNCNT>MAXCT D NEWPG^BKMVSUP
I LINE'="" D UPD^BKMVSUP
Q
RX(MEDIEN,DFLTDT,FLD) ; Get date from prescription file if PCC LINK exists
; FLD = field for desired date
I '$D(^PSRX("APCC",MEDIEN)) Q DFLTDT\1
N PSRXIEN,PSRXDT
S PSRXIEN=$O(^PSRX("APCC",MEDIEN,""))
I PSRXIEN S PSRXDT=$$GET1^DIQ(52,PSRXIEN,FLD,"I") I PSRXDT S DFLTDT=PSRXDT
Q DFLTDT\1
PRTDT ; Print dates for subheader
N FIRST
S FLDT="" F S FLDT=$O(FLDT(FLDT)) Q:FLDT="" D
. S FIRST=$O(BKMT("FLOWD",FLDT,"")) I 'FIRST S FIRST=FLDT
. S LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT(FIRST,"2Z"),"@"),FLDT(FLDT))
D UPD^BKMVSUP,BLANK^BKMVSUP(1)
Q
PRTFL(TYPE,MAX) ;
N LCNT,RESULT
F LCNT=1:1:MAX D D UPD^BKMVSUP
.S FLDT=""
.F S FLDT=$O(FLDT(FLDT)) Q:FLDT="" D
.. S RESULT=$E($G(BKMT("PRT",TYPE,FLDT,LCNT)),1,8)
.. S LINE=$$LINE^BKMVSUP(LINE,$E(" ",1,8-$L(RESULT)\2),FLDT(FLDT))_RESULT
.. I LNCNT>MAXCT D NEWPG^BKMVSUP
Q
REM(DFN) ; EP - List Reminders
; Remove message since this will be handled during processing not printing
; I IOST["C-" W !!?1,"Calculating HIV-RELATED REMINDERS - Please wait."
D UPD^BKMVSUP,BLANK^BKMVSUP(1) S LINE=" HIV-RELATED REMINDERS: " D UPD^BKMVSUP
N PRT,A1,B1,DUE,OVERDUE,REMTXT,DXDT
K REMLIST D REMIND^BKMVF3(DFN,NOW,.REMLIST)
I LNCNT>(MAXCT-1) D NEWPG^BKMVSUP
I $O(REMLIST("")) D
. D UPD^BKMVSUP S LINE=" Reminder",LINE=$$LINE^BKMVSUP(LINE,"Last",26)
. S LINE=$$LINE^BKMVSUP(LINE,"Due",41) D UPD^BKMVSUP
. S A1="" F S A1=$O(REMLIST(A1)) Q:A1="" D
.. S B1="" F S B1=$O(REMLIST(A1,B1)) Q:B1="" D
... S DUE=$G(REMLIST(A1,B1,"DUE")) ;S:DUE="" DUE="Unknown" this is not on the Clinical Rem, they must be the same
... I LNCNT>MAXCT D NEWPG^BKMVSUP
... I 'DUE,'$G(REMLIST(A1,B1,"LAST")) Q
... S REMTXT=$G(REMLIST(A1,B1,0))
... S OVERDUE=0
... I DUE'="" S:DUE<DT OVERDUE=1 S DUE=$P($$FMTE^XLFDT(+DUE,"5Z"),"@",1)
... I OVERDUE=0,$G(REMLIST(A1,B1,"LAST"))="" S DUE="("_DUE_")"
... I OVERDUE=1 S DUE=$S($G(REMLIST(A1,B1,"LAST"))="":"("_DUE_")",1:DUE)
... ;I OVERDUE=1 S DUE="May Be Due Now (Was due "_DUE_")"
... S LINE=" "_$E(REMTXT,1,25)
... S LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT($G(REMLIST(A1,B1,"LAST")),"5Z"),"@"),26)
... I $G(REMLIST(A1,B1,"LASTTXT"))]"" S LINE=LINE_REMLIST(A1,B1,"LASTTXT")
... S LINE=$$LINE^BKMVSUP(LINE,DUE,42) D UPD^BKMVSUP
... I REMTXT["Viral Load"!(REMTXT["Trichomoniasis Test")!(REMTXT["Tetanus IZ")!(REMTXT["Dental Exam") D UPD^BKMVSUP
... I LNCNT>MAXCT D NEWPG^BKMVSUP
;
; Check for a history of Tuberculosis diagnosis (DX.14) or history of positive PPD test (T.21)
; Preferentially list TB dx over positive PPD
I '$D(REMLIST("REM.T.05")) D
. ; *** Need to new variables ***
. ; *** 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?
. ; Check for history of Tuberculosis diagnosis
. ; DX.14
. S GLOBAL="BKMT(""PPDDX"",VSTDT,TEST,""LAB"")"
. S GLOBAL1="BKMT(""PPDTEST"",VSTDT,TEST,""LAB"")" ; *** Is this needed? ***
. S GLOBAL2="BKMT(""PPDPOS"",VSTDT,TEST,""LAB"")"
. D ICDTAX^BKMIXX1(DFN,"DM AUDIT PROBLEM TB DXS","","",GLOBAL)
. S DXDT=$O(BKMT("PPDDX",""),-1)
. I DXDT S LINE=" PPD Diagnosis ",LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT(DXDT,"5Z"),"@"),26) D UPD^BKMVSUP Q
. ;
. ; Check for history of positive PPD
. ; T.21
. S GLOBAL="BKMT(""PPDDX"",VSTDT,TEST,""LAB"")"
. D LABTAX^BKMIXX(DFN,"BKM PPD TAX","","",GLOBAL1) ;***
. D LOINC^BKMIXX(DFN,"BKM PPD LOINC CODES","","",GLOBAL2)
. S GLOBAL="BKMT(""PPD"",VSTDT,TEST,""CPT"")"
. D CPTTAX^BKMIXX(DFN,"BKM PPD CPTS","","",GLOBAL1)
. S GLOBAL="BKMT(""PPD"",VSTDT,TEST,""CVX"")"
. D CVXTAX^BKMIXX1(DFN,"BKM PPD CVX CODES","","",GLOBAL1)
. S GLOBAL="BKMT(""PPD"",VSTDT,TEST,""ICD"")"
. D ICDTAX^BKMIXX1(DFN,"BKM PPD ICDS","","",GLOBAL1)
. S GLOBAL="BKMT(""PPD"",VSTDT,TEST,""SKIN"")"
. D SKNTAX^BKMIXX1(DFN,"21","","",GLOBAL2)
. M BKMT("PPDTEST")=BKMT("PPDPOS")
. S VSTDT=$O(BKMT("PPDPOS",""),-1)
. S POS=""
. I VSTDT D
.. S TEST=$O(BKMT("PPDPOS",VSTDT,""),-1) Q:'TEST
.. S RESULT=BKMT("PPDPOS",VSTDT,TEST,"LAB"),POS=$$POS^BKMQQCR7(RESULT)
. I POS D
.. S LINE=" PPD ",LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT(VSTDT,"5Z"),"@"),26)
.. S LINE=$$LINE^BKMVSUP(LINE,"Positive Test Result",42)
.. D UPD^BKMVSUP
;S LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT($G(LIST(A1,B1,"LAST")),"5Z"),"@"),26) . ;
K LIST
I LNCNT>MAXCT D NEWPG^BKMVSUP
D UPD^BKMVSUP,BLANK^BKMVSUP(1)
Q
ED(DFN) ; EP - Retrieve Education data.
N BKMCKDT
S BKMCKDT=$$FMADD^XLFDT(DT,-360)
D UPD^BKMVSUP,BLANK^BKMVSUP(1)
S LINE=" Last HIV-related education given (past 12 months): " D UPD^BKMVSUP
I LNCNT>MAXCT D NEWPG^BKMVSUP
K BKMT("ED")
S GLOBAL="BKMT(""ED"",VSTDT,TEST,""ICD"")"
D ICDTAX^BKMIXX1(DFN,"BKM FAMILY PLANNING POV","",BKMCKDT,GLOBAL)
D ICDTAX^BKMIXX1(DFN,"BKMV HIV ED DXS","",BKMCKDT,GLOBAL)
D ICDTAX^BKMIXX1(DFN,"BKMV STD ED DXS","",BKMCKDT,GLOBAL)
S GLOBAL="BKMT(""ED"",VSTDT,TEST,""ED"")"
; Patient Education Codes can use two different formats
D PTEDTAX^BKMIXX(DFN,"FP-","",BKMCKDT,GLOBAL) ; Family Planning
D PTEDTAX^BKMIXX(DFN,"HIV-,-HIV,*BGP HIV/AIDS DXS","",BKMCKDT,GLOBAL) ; HIV Counseling/Education
D PTEDTAX^BKMIXX1(DFN,"BKM STD ED CODES","",BKMCKDT,GLOBAL)
D PTEDTAX^BKMIXX1(DFN,"BKM SAFE SEX ED CODES","",BKMCKDT,GLOBAL)
I '$D(BKMT("ED")) D EDREF Q ; Get refusals if no data found
I LNCNT>(MAXCT-2) D NEWPG^BKMVSUP
S LINE=$$LINE^BKMVSUP(" [Topic]","[Date]",35)
S LINE=$$LINE^BKMVSUP(LINE,"[Provider initials]",47)
N EDDT,EDTST,DISPDT,PROV
S EDDT="" F S EDDT=$O(BKMT("ED",EDDT),-1) Q:EDDT="" D
. S EDTST="" F S EDTST=$O(BKMT("ED",EDDT,EDTST)) Q:EDTST="" D
.. S DISPDT=$P($$FMTE^XLFDT(EDDT,"5Z"),"@")
.. I $D(BKMT("ED",EDDT,EDTST,"ICD")) D
... D UPD^BKMVSUP S LINE=" "_$E($$GET1^DIQ(9000010.07,EDTST,.01,"E"),1,30)
... S LINE=$$LINE^BKMVSUP(LINE,DISPDT,35)
... S LINE=$$LINE^BKMVSUP(LINE,$E($$GET1^DIQ(9000010.07,EDTST,.04,"E"),1,30),47)
... I LNCNT>MAXCT D NEWPG^BKMVSUP
.. I $D(BKMT("ED",EDDT,EDTST,"ED")) D
... D UPD^BKMVSUP S LINE=" "_$E($$GET1^DIQ(9000010.16,EDTST,.01,"E"),1,30)
... S LINE=$$LINE^BKMVSUP(LINE,DISPDT,35)
... S PROV=$$GET1^DIQ(9000010.16,EDTST,.05,"I") Q:PROV=""
... S LINE=$$LINE^BKMVSUP(LINE,$$GET1^DIQ(200,PROV,1,"E"),47)
... I LNCNT>MAXCT D NEWPG^BKMVSUP
K BKMT("ED")
I LINE'="" D UPD^BKMVSUP
Q
EDREF ; Check refusals for education
S GLOBAL="BKMT(""ED"",VSTDT,TEST,""ED"")"
; Patient Education Codes can use two different formats
D REFUSAL^BKMIXX2(DFN,9999999.09,"FP-","","",GLOBAL) ; Family Planning
D REFUSAL^BKMIXX2(DFN,9999999.09,"HIV-,-HIV,*BGP HIV/AIDS DXS","","",GLOBAL) ; HIV Counseling/Education
D REFUSAL^BKMIXX2(DFN,9999999.09,"BKM STD ED CODES","","",GLOBAL)
D REFUSAL^BKMIXX2(DFN,9999999.09,"BKM SAFE SEX ED CODES","","",GLOBAL)
D LTAXPRT^BKMVSUP1("ED",1,1,1)
K BKMT("ED")
I LINE'="" D UPD^BKMVSUP
Q
XIT ; QUIT POINT
Q
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
+2 QUIT
FLOW(DFN) ; EP - Generate Flow Sheet
+1 IF LNCNT>(MAXCT-4)
DO NEWPG^BKMVSUP
+2 DO UPD^BKMVSUP
SET LINE=" HIV FLOW SHEET"
DO UPD^BKMVSUP
+3 NEW FLTST,FLDT,FLIEN,FLTYP,CNT,LAST,STOP,MAX,MEDNM,MEDDT,DISDT
+4 KILL BKMT("FLOW"),BKMT("PRT")
+5 FOR FLTST="VL","CD4ABS"
SET CNT=0
Begin DoDot:1
+6 SET FLDT=""
+7 FOR
SET FLDT=$ORDER(BKMT(FLTST,FLDT),-1)
IF FLDT=""
QUIT
Begin DoDot:2
+8 SET FLIEN=""
+9 FOR
SET FLIEN=$ORDER(BKMT(FLTST,FLDT,FLIEN))
IF FLIEN=""
QUIT
Begin DoDot:3
+10 SET FLTYP=""
+11 FOR
SET FLTYP=$ORDER(BKMT(FLTST,FLDT,FLIEN,FLTYP))
IF FLTYP=""
QUIT
Begin DoDot:4
+12 ;Only include if results are present
IF $PIECE(BKMT(FLTST,FLDT,FLIEN,FLTYP),U)]""
Begin DoDot:5
+13 SET BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP)=BKMT(FLTST,FLDT,FLIEN,FLTYP)
SET CNT=CNT+1
End DoDot:5
End DoDot:4
IF CNT=6
QUIT
End DoDot:3
IF CNT=6
QUIT
End DoDot:2
IF CNT=6
QUIT
End DoDot:1
+14 KILL BKMT("VL"),BKMT("CD4ABS")
+15 IF '$DATA(BKMT("FLOW"))
QUIT
+16 ;
+17 SET STOP=""
KILL BKMT("FLOWD")
+18 ; Only print 6 dates; combine if dates are w/in 7 days
+19 SET LAST=$ORDER(BKMT("FLOW",""),-1)
SET FLDT=LAST
SET CNT=1
SET FLDT(LAST)=""
SET BKMT("FLOWD",LAST,LAST)=""
+20 FOR
SET FLDT=$ORDER(BKMT("FLOW",FLDT),-1)
IF FLDT=""
QUIT
Begin DoDot:1
+21 IF $$FMDIFF^XLFDT(LAST,FLDT,1)<8
Begin DoDot:2
+22 MERGE BKMT("FLOW",LAST)=BKMT("FLOW",FLDT)
KILL BKMT("FLOW",FLDT)
SET BKMT("FLOWD",LAST,FLDT)=""
End DoDot:2
QUIT
+23 IF CNT=6
SET STOP=1
QUIT
+24 SET LAST=FLDT
SET FLDT(LAST)=""
SET CNT=CNT+1
SET BKMT("FLOWD",LAST,LAST)=""
End DoDot:1
IF STOP
QUIT
+25 ;
+26 ; Reorder array for printing
+27 SET FLDT=""
SET MAX("VL")=""
SET MAX("CD4ABS")=""
+28 FOR
SET FLDT=$ORDER(BKMT("FLOW",FLDT))
IF FLDT=""
QUIT
Begin DoDot:1
+29 SET FLTST=""
FOR
SET FLTST=$ORDER(BKMT("FLOW",FLDT,FLTST))
IF FLTST=""
QUIT
Begin DoDot:2
+30 SET FLIEN=""
FOR
SET FLIEN=$ORDER(BKMT("FLOW",FLDT,FLTST,FLIEN))
IF FLIEN=""
QUIT
Begin DoDot:3
+31 SET FLTYP=""
FOR
SET FLTYP=$ORDER(BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP))
IF FLTYP=""
QUIT
Begin DoDot:4
+32 SET CNT=$GET(BKMT("PRT",FLTST,FLDT))+1
SET BKMT("PRT",FLTST,FLDT)=CNT
+33 IF CNT>MAX(FLTST)
SET MAX(FLTST)=CNT
+34 SET BKMT("PRT",FLTST,FLDT,CNT)=BKMT("FLOW",FLDT,FLTST,FLIEN,FLTYP)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;
+36 ; Print results
+37 NEW MEDDYS,FIRST,MEDDSPDT,MEDISSDT
+38 KILL BKMT("FLOW")
+39 SET FLDT=""
+40 FOR CNT=0:1:5
SET FLDT=$ORDER(FLDT(FLDT))
IF FLDT=""
QUIT
SET FLDT(FLDT)=18+(CNT*10)
+41 ; Print dates
DO PRTDT
+42 SET LINE=" Viral Load"
+43 DO PRTFL("VL",MAX("VL"))
+44 DO UPD^BKMVSUP
SET LINE=" CD4 Count"
+45 DO PRTFL("CD4ABS",MAX("CD4ABS"))
+46 ; Get HAART Medication
+47 ; Loop through currently active medications
+48 KILL BKMT("MED")
+49 SET MEDDT=""
+50 FOR
SET MEDDT=$ORDER(^TMP("BKMSUPP",$JOB,"HAART",MEDDT))
IF MEDDT=""
QUIT
Begin DoDot:1
+51 SET MEDIEN=""
+52 FOR
SET MEDIEN=$ORDER(^TMP("BKMSUPP",$JOB,"HAART",MEDDT,MEDIEN))
IF MEDIEN=""
QUIT
Begin DoDot:2
+53 ; Get days prescribed
SET MEDDYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"I")
+54 ; Using Health Summary logic
IF MEDDYS=""
SET MEDDYS=30
+55 IF 'MEDDYS
QUIT
+56 ; Get last dispensed date
SET MEDDSPDT=$$RX(MEDIEN,MEDDT,101)
+57 ; Get issue date
SET MEDISSDT=$$RX(MEDIEN,MEDDT,1)
+58 ; Get med name
SET MEDNM=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E")
+59 IF MEDNM=""
SET MEDNM="Unknown"
+60 SET FLDT=""
+61 FOR
SET FLDT=$ORDER(FLDT(FLDT))
IF FLDT=""
QUIT
Begin DoDot:3
+62 ; If Last Dispensed Date (or Visit Date if no PCC LINK) + DAYS is earlier than the lab date, skip this med
+63 IF $$FMADD^XLFDT(MEDDSPDT,MEDDYS)<(FLDT\1)
QUIT
+64 ; Medication must be active prior to the first date of the test
+65 SET FIRST=$ORDER(BKMT("FLOWD",FLDT,""))
IF 'FIRST
QUIT
+66 IF MEDISSDT'<(FIRST\1)
QUIT
+67 SET BKMT("MED",MEDNM,FLDT)=""
End DoDot:3
End DoDot:2
End DoDot:1
+68 ;
+69 ; Loop through inactive medications
+70 SET DISDT=""
+71 FOR
SET DISDT=$ORDER(BKMT("HAARTD",DISDT))
IF DISDT=""
QUIT
Begin DoDot:1
+72 SET MEDDT=""
+73 FOR
SET MEDDT=$ORDER(BKMT("HAARTD",DISDT,MEDDT))
IF MEDDT=""
QUIT
Begin DoDot:2
+74 SET MEDIEN=""
+75 FOR
SET MEDIEN=$ORDER(BKMT("HAARTD",DISDT,MEDDT,MEDIEN))
IF MEDIEN=""
QUIT
Begin DoDot:3
+76 ; Get days prescribed
SET MEDDYS=$$GET1^DIQ(9000010.14,MEDIEN,.07,"I")
+77 ; Using Health Summary logic
IF MEDDYS=""
SET MEDDYS=30
+78 IF 'MEDDYS
QUIT
+79 ; Get last dispensed date
SET MEDDSPDT=$$RX(MEDIEN,MEDDT,101)
+80 ; Get issue date
SET MEDISSDT=$$RX(MEDIEN,MEDDT,1)
+81 ; Get med name
SET MEDNM=$$GET1^DIQ(9000010.14,MEDIEN,.01,"E")
+82 IF MEDNM=""
SET MEDNM="Unknown"
+83 SET FLDT=""
+84 ;I DISDT\1>(FLDT\1) D; IHS removed discontinued date check 04/27/06
FOR
SET FLDT=$ORDER(FLDT(FLDT))
IF FLDT=""
QUIT
Begin DoDot:4
+85 ; If Last Dispensed Date (or Visit Date if no PCC LINK) + DAYS is earlier than the lab date, skip this med
+86 SET FIRST=$ORDER(BKMT("FLOWD",FLDT,""))
IF 'FIRST
QUIT
+87 IF $$FMADD^XLFDT(MEDDSPDT,MEDDYS)<(FIRST\1)
QUIT
+88 ; Medication must be active prior to the first date of the test
+89 IF MEDISSDT\1'<(FIRST\1)
QUIT
+90 SET BKMT("MED",MEDNM,FLDT)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+91 DO UPD^BKMVSUP
+92 ;
+93 ; Print medications for listed dates
+94 SET MEDNM=""
+95 FOR
SET MEDNM=$ORDER(BKMT("MED",MEDNM))
IF MEDNM=""
QUIT
Begin DoDot:1
+96 DO UPD^BKMVSUP
SET LINE=" "_$EXTRACT(MEDNM,1,16)
+97 SET MEDDT=""
FOR
SET MEDDT=$ORDER(BKMT("MED",MEDNM,MEDDT))
IF MEDDT=""
QUIT
Begin DoDot:2
+98 SET LINE=$$LINE^BKMVSUP(LINE," x",FLDT(MEDDT))
End DoDot:2
+99 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
End DoDot:1
+100 IF LINE'=""
DO UPD^BKMVSUP
+101 QUIT
RX(MEDIEN,DFLTDT,FLD) ; Get date from prescription file if PCC LINK exists
+1 ; FLD = field for desired date
+2 IF '$DATA(^PSRX("APCC",MEDIEN))
QUIT DFLTDT\1
+3 NEW PSRXIEN,PSRXDT
+4 SET PSRXIEN=$ORDER(^PSRX("APCC",MEDIEN,""))
+5 IF PSRXIEN
SET PSRXDT=$$GET1^DIQ(52,PSRXIEN,FLD,"I")
IF PSRXDT
SET DFLTDT=PSRXDT
+6 QUIT DFLTDT\1
PRTDT ; Print dates for subheader
+1 NEW FIRST
+2 SET FLDT=""
FOR
SET FLDT=$ORDER(FLDT(FLDT))
IF FLDT=""
QUIT
Begin DoDot:1
+3 SET FIRST=$ORDER(BKMT("FLOWD",FLDT,""))
IF 'FIRST
SET FIRST=FLDT
+4 SET LINE=$$LINE^BKMVSUP(LINE,$PIECE($$FMTE^XLFDT(FIRST,"2Z"),"@"),FLDT(FLDT))
End DoDot:1
+5 DO UPD^BKMVSUP
DO BLANK^BKMVSUP(1)
+6 QUIT
PRTFL(TYPE,MAX) ;
+1 NEW LCNT,RESULT
+2 FOR LCNT=1:1:MAX
Begin DoDot:1
+3 SET FLDT=""
+4 FOR
SET FLDT=$ORDER(FLDT(FLDT))
IF FLDT=""
QUIT
Begin DoDot:2
+5 SET RESULT=$EXTRACT($GET(BKMT("PRT",TYPE,FLDT,LCNT)),1,8)
+6 SET LINE=$$LINE^BKMVSUP(LINE,$EXTRACT(" ",1,8-$LENGTH(RESULT)\2),FLDT(FLDT))_RESULT
+7 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
End DoDot:2
End DoDot:1
DO UPD^BKMVSUP
+8 QUIT
REM(DFN) ; EP - List Reminders
+1 ; Remove message since this will be handled during processing not printing
+2 ; I IOST["C-" W !!?1,"Calculating HIV-RELATED REMINDERS - Please wait."
+3 DO UPD^BKMVSUP
DO BLANK^BKMVSUP(1)
SET LINE=" HIV-RELATED REMINDERS: "
DO UPD^BKMVSUP
+4 NEW PRT,A1,B1,DUE,OVERDUE,REMTXT,DXDT
+5 KILL REMLIST
DO REMIND^BKMVF3(DFN,NOW,.REMLIST)
+6 IF LNCNT>(MAXCT-1)
DO NEWPG^BKMVSUP
+7 IF $ORDER(REMLIST(""))
Begin DoDot:1
+8 DO UPD^BKMVSUP
SET LINE=" Reminder"
SET LINE=$$LINE^BKMVSUP(LINE,"Last",26)
+9 SET LINE=$$LINE^BKMVSUP(LINE,"Due",41)
DO UPD^BKMVSUP
+10 SET A1=""
FOR
SET A1=$ORDER(REMLIST(A1))
IF A1=""
QUIT
Begin DoDot:2
+11 SET B1=""
FOR
SET B1=$ORDER(REMLIST(A1,B1))
IF B1=""
QUIT
Begin DoDot:3
+12 ;S:DUE="" DUE="Unknown" this is not on the Clinical Rem, they must be the same
SET DUE=$GET(REMLIST(A1,B1,"DUE"))
+13 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+14 IF 'DUE
IF '$GET(REMLIST(A1,B1,"LAST"))
QUIT
+15 SET REMTXT=$GET(REMLIST(A1,B1,0))
+16 SET OVERDUE=0
+17 IF DUE'=""
IF DUE<DT
SET OVERDUE=1
SET DUE=$PIECE($$FMTE^XLFDT(+DUE,"5Z"),"@",1)
+18 IF OVERDUE=0
IF $GET(REMLIST(A1,B1,"LAST"))=""
SET DUE="("_DUE_")"
+19 IF OVERDUE=1
SET DUE=$SELECT($GET(REMLIST(A1,B1,"LAST"))="":"("_DUE_")",1:DUE)
+20 ;I OVERDUE=1 S DUE="May Be Due Now (Was due "_DUE_")"
+21 SET LINE=" "_$EXTRACT(REMTXT,1,25)
+22 SET LINE=$$LINE^BKMVSUP(LINE,$PIECE($$FMTE^XLFDT($GET(REMLIST(A1,B1,"LAST")),"5Z"),"@"),26)
+23 IF $GET(REMLIST(A1,B1,"LASTTXT"))]""
SET LINE=LINE_REMLIST(A1,B1,"LASTTXT")
+24 SET LINE=$$LINE^BKMVSUP(LINE,DUE,42)
DO UPD^BKMVSUP
+25 IF REMTXT["Viral Load"!(REMTXT["Trichomoniasis Test")!(REMTXT["Tetanus IZ")!(REMTXT["Dental Exam")
DO UPD^BKMVSUP
+26 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;
+28 ; Check for a history of Tuberculosis diagnosis (DX.14) or history of positive PPD test (T.21)
+29 ; Preferentially list TB dx over positive PPD
+30 IF '$DATA(REMLIST("REM.T.05"))
Begin DoDot:1
+31 ; *** Need to new variables ***
+32 ; *** 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?
+33 ; Check for history of Tuberculosis diagnosis
+34 ; DX.14
+35 SET GLOBAL="BKMT(""PPDDX"",VSTDT,TEST,""LAB"")"
+36 ; *** Is this needed? ***
SET GLOBAL1="BKMT(""PPDTEST"",VSTDT,TEST,""LAB"")"
+37 SET GLOBAL2="BKMT(""PPDPOS"",VSTDT,TEST,""LAB"")"
+38 DO ICDTAX^BKMIXX1(DFN,"DM AUDIT PROBLEM TB DXS","","",GLOBAL)
+39 SET DXDT=$ORDER(BKMT("PPDDX",""),-1)
+40 IF DXDT
SET LINE=" PPD Diagnosis "
SET LINE=$$LINE^BKMVSUP(LINE,$PIECE($$FMTE^XLFDT(DXDT,"5Z"),"@"),26)
DO UPD^BKMVSUP
QUIT
+41 ;
+42 ; Check for history of positive PPD
+43 ; T.21
+44 SET GLOBAL="BKMT(""PPDDX"",VSTDT,TEST,""LAB"")"
+45 ;***
DO LABTAX^BKMIXX(DFN,"BKM PPD TAX","","",GLOBAL1)
+46 DO LOINC^BKMIXX(DFN,"BKM PPD LOINC CODES","","",GLOBAL2)
+47 SET GLOBAL="BKMT(""PPD"",VSTDT,TEST,""CPT"")"
+48 DO CPTTAX^BKMIXX(DFN,"BKM PPD CPTS","","",GLOBAL1)
+49 SET GLOBAL="BKMT(""PPD"",VSTDT,TEST,""CVX"")"
+50 DO CVXTAX^BKMIXX1(DFN,"BKM PPD CVX CODES","","",GLOBAL1)
+51 SET GLOBAL="BKMT(""PPD"",VSTDT,TEST,""ICD"")"
+52 DO ICDTAX^BKMIXX1(DFN,"BKM PPD ICDS","","",GLOBAL1)
+53 SET GLOBAL="BKMT(""PPD"",VSTDT,TEST,""SKIN"")"
+54 DO SKNTAX^BKMIXX1(DFN,"21","","",GLOBAL2)
+55 MERGE BKMT("PPDTEST")=BKMT("PPDPOS")
+56 SET VSTDT=$ORDER(BKMT("PPDPOS",""),-1)
+57 SET POS=""
+58 IF VSTDT
Begin DoDot:2
+59 SET TEST=$ORDER(BKMT("PPDPOS",VSTDT,""),-1)
IF 'TEST
QUIT
+60 SET RESULT=BKMT("PPDPOS",VSTDT,TEST,"LAB")
SET POS=$$POS^BKMQQCR7(RESULT)
End DoDot:2
+61 IF POS
Begin DoDot:2
+62 SET LINE=" PPD "
SET LINE=$$LINE^BKMVSUP(LINE,$PIECE($$FMTE^XLFDT(VSTDT,"5Z"),"@"),26)
+63 SET LINE=$$LINE^BKMVSUP(LINE,"Positive Test Result",42)
+64 DO UPD^BKMVSUP
End DoDot:2
End DoDot:1
+65 ;S LINE=$$LINE^BKMVSUP(LINE,$P($$FMTE^XLFDT($G(LIST(A1,B1,"LAST")),"5Z"),"@"),26) . ;
+66 KILL LIST
+67 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+68 DO UPD^BKMVSUP
DO BLANK^BKMVSUP(1)
+69 QUIT
ED(DFN) ; EP - Retrieve Education data.
+1 NEW BKMCKDT
+2 SET BKMCKDT=$$FMADD^XLFDT(DT,-360)
+3 DO UPD^BKMVSUP
DO BLANK^BKMVSUP(1)
+4 SET LINE=" Last HIV-related education given (past 12 months): "
DO UPD^BKMVSUP
+5 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+6 KILL BKMT("ED")
+7 SET GLOBAL="BKMT(""ED"",VSTDT,TEST,""ICD"")"
+8 DO ICDTAX^BKMIXX1(DFN,"BKM FAMILY PLANNING POV","",BKMCKDT,GLOBAL)
+9 DO ICDTAX^BKMIXX1(DFN,"BKMV HIV ED DXS","",BKMCKDT,GLOBAL)
+10 DO ICDTAX^BKMIXX1(DFN,"BKMV STD ED DXS","",BKMCKDT,GLOBAL)
+11 SET GLOBAL="BKMT(""ED"",VSTDT,TEST,""ED"")"
+12 ; Patient Education Codes can use two different formats
+13 ; Family Planning
DO PTEDTAX^BKMIXX(DFN,"FP-","",BKMCKDT,GLOBAL)
+14 ; HIV Counseling/Education
DO PTEDTAX^BKMIXX(DFN,"HIV-,-HIV,*BGP HIV/AIDS DXS","",BKMCKDT,GLOBAL)
+15 DO PTEDTAX^BKMIXX1(DFN,"BKM STD ED CODES","",BKMCKDT,GLOBAL)
+16 DO PTEDTAX^BKMIXX1(DFN,"BKM SAFE SEX ED CODES","",BKMCKDT,GLOBAL)
+17 ; Get refusals if no data found
IF '$DATA(BKMT("ED"))
DO EDREF
QUIT
+18 IF LNCNT>(MAXCT-2)
DO NEWPG^BKMVSUP
+19 SET LINE=$$LINE^BKMVSUP(" [Topic]","[Date]",35)
+20 SET LINE=$$LINE^BKMVSUP(LINE,"[Provider initials]",47)
+21 NEW EDDT,EDTST,DISPDT,PROV
+22 SET EDDT=""
FOR
SET EDDT=$ORDER(BKMT("ED",EDDT),-1)
IF EDDT=""
QUIT
Begin DoDot:1
+23 SET EDTST=""
FOR
SET EDTST=$ORDER(BKMT("ED",EDDT,EDTST))
IF EDTST=""
QUIT
Begin DoDot:2
+24 SET DISPDT=$PIECE($$FMTE^XLFDT(EDDT,"5Z"),"@")
+25 IF $DATA(BKMT("ED",EDDT,EDTST,"ICD"))
Begin DoDot:3
+26 DO UPD^BKMVSUP
SET LINE=" "_$EXTRACT($$GET1^DIQ(9000010.07,EDTST,.01,"E"),1,30)
+27 SET LINE=$$LINE^BKMVSUP(LINE,DISPDT,35)
+28 SET LINE=$$LINE^BKMVSUP(LINE,$EXTRACT($$GET1^DIQ(9000010.07,EDTST,.04,"E"),1,30),47)
+29 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
End DoDot:3
+30 IF $DATA(BKMT("ED",EDDT,EDTST,"ED"))
Begin DoDot:3
+31 DO UPD^BKMVSUP
SET LINE=" "_$EXTRACT($$GET1^DIQ(9000010.16,EDTST,.01,"E"),1,30)
+32 SET LINE=$$LINE^BKMVSUP(LINE,DISPDT,35)
+33 SET PROV=$$GET1^DIQ(9000010.16,EDTST,.05,"I")
IF PROV=""
QUIT
+34 SET LINE=$$LINE^BKMVSUP(LINE,$$GET1^DIQ(200,PROV,1,"E"),47)
+35 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
End DoDot:3
End DoDot:2
End DoDot:1
+36 KILL BKMT("ED")
+37 IF LINE'=""
DO UPD^BKMVSUP
+38 QUIT
EDREF ; Check refusals for education
+1 SET GLOBAL="BKMT(""ED"",VSTDT,TEST,""ED"")"
+2 ; Patient Education Codes can use two different formats
+3 ; Family Planning
DO REFUSAL^BKMIXX2(DFN,9999999.09,"FP-","","",GLOBAL)
+4 ; HIV Counseling/Education
DO REFUSAL^BKMIXX2(DFN,9999999.09,"HIV-,-HIV,*BGP HIV/AIDS DXS","","",GLOBAL)
+5 DO REFUSAL^BKMIXX2(DFN,9999999.09,"BKM STD ED CODES","","",GLOBAL)
+6 DO REFUSAL^BKMIXX2(DFN,9999999.09,"BKM SAFE SEX ED CODES","","",GLOBAL)
+7 DO LTAXPRT^BKMVSUP1("ED",1,1,1)
+8 KILL BKMT("ED")
+9 IF LINE'=""
DO UPD^BKMVSUP
+10 QUIT
XIT ; QUIT POINT
+1 QUIT
