BKMVSUP3 ;PRXM/HC/WOM - Continuation of BKMVSUP, HIV SUPPLEMENT; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 12:46 PM
;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
Q
RET(DFN) ; EP - Retrieve Eye taxonomies (P.03)
; Several calls below used to use $H-360.
; Replaced with BKMCKDT (FileMan format date).
N BKMCKDT,PRV,CLN
S BKMCKDT=$$FMADD^XLFDT(DT,-360)
K BKMT("EYE")
S GLOBAL="BKMT(""EYE"",VSTDT,TEST,""CPT"")"
D CPTTAX^BKMIXX(DFN,"BGP DM EYE EXAM CPTS","",BKMCKDT,GLOBAL)
D CPTTAX^BKMIXX(DFN,"BGP RETINAL EXAM CPTS","",BKMCKDT,GLOBAL)
S GLOBAL="BKMT(""EYE"",VSTDT,TEST,""EXAM"")"
D EXAMTAX^BKMIXX1(DFN,"03","",BKMCKDT,GLOBAL)
; Added provider, clinic code and procedure checks
S GLOBAL="BKMT(""EYE"",VSTDT,TEST,""PRV"")"
; Check provider codes
F PRV="79","24","08" D
. D PRVTAX^BKMIXX2(DFN,PRV,"",BKMCKDT,GLOBAL)
S GLOBAL="BKMT(""EYE"",VSTDT,TEST,""CLN"")"
; Check clinic codes
F CLN="17","18","64","A2" D
. D CLNTAX^BKMIXX2(DFN,CLN,"",BKMCKDT,GLOBAL)
; Check procedure code
;D PROCTAX^BKMIXX2(DFN,95.02,"",BKMCKDT,GLOBAL)
D PRCTAX^BKMIXX1(DFN,"BQI EYE EXAM PROCS","",BKMCKDT,GLOBAL)
; Check POVs
;D POVTAX^BKMIXX2(DFN,"V72.0","",BKMCKDT,GLOBAL)
D ICDTAX^BKMIXX1(DFN,"BQI EYE EXAM DXS","",BKMCKDT,GLOBAL)
; Print results
S LINE=" Dilated eye exam: "
D LTAXPRT^BKMVSUP1("EYE",1)
I $D(BKMT("EYE")) K BKMT("EYE") D UPD^BKMVSUP D UPD^BKMVSUP:LINE'="" Q
; If no eye exams found check refusals
; The following has been replaced with D REFUSAL^BKMIXX2 call
; S EXIEN=$O(^AUTTEXAM("C","03",""))
; I EXIEN S TST(EXIEN)="" W $$REF^BKMVSUP2(DFN,9999999.15,.TST)
D REFUSAL^BKMIXX2(DFN,9999999.15,"03","",BKMCKDT,GLOBAL)
; Print results
D LTAXPRT^BKMVSUP1("EYE",1,1,1)
I '$D(BKMT("EYE")) S LINE=$$LINE^BKMVSUP(LINE,"Date:",24)
D UPD^BKMVSUP
I LNCNT>MAXCT D NEWPG^BKMVSUP
Q
MAM(DFN) ; EP - Retrieve mammogram taxonomies
; Several calls below used to use $H-360.
; Replaced with BKMCKDT (FileMan format date).
N BKMCKDT
S BKMCKDT=$$FMADD^XLFDT(DT,-360)
; *** Examine V Rad and V CPT; if others are needed will have to add
; Q:$P(^DPT(DFN,0),U,2)'="F" ; - removed and replaced with N/A as per IHS
S LINE=" Mammogram: "
I $P(^DPT(DFN,0),U,2)'="F" S LINE=LINE_"Not Applicable" Q ;Females only
K BKMT("MAM")
S GLOBAL="BKMT(""MAM"",VSTDT,TEST,""PROC"")"
D PRCTAX^BKMIXX1(DFN,"BGP MAMMOGRAM PROCEDURES","",BKMCKDT,GLOBAL)
S GLOBAL="BKMT(""MAM"",VSTDT,TEST,""ICD"")"
D ICDTAX^BKMIXX1(DFN,"BGP MAMMOGRAM ICDS","",BKMCKDT,GLOBAL)
S GLOBAL="BKMT(""MAM"",VSTDT,TEST,""CPT"")"
D CPTTAX^BKMIXX(DFN,"BGP CPT MAMMOGRAM","",BKMCKDT,GLOBAL)
; Additional check of V-Rad file for mammography.
S GLOBAL="BKMT(""MAM"",VSTDT,TEST,""RAD"")"
D RADTAX^BKMIXX1(DFN,"BGP CPT MAMMOGRAM","",BKMCKDT,GLOBAL)
I $D(BKMT("MAM")) D LTAXPRT^BKMVSUP1("MAM",1) K BKMT("MAM") D UPD^BKMVSUP:LINE'="" Q
D REFUSAL^BKMIXX2(DFN,71,"BGP CPT MAMMOGRAM","",BKMCKDT,GLOBAL)
; Print results
D LTAXPRT^BKMVSUP1("MAM",1,1,1)
I '$D(BKMT("MAM")) S LINE=$$LINE^BKMVSUP(LINE,"Date:",24)
K BKMT("MAM")
I LINE'="" D UPD^BKMVSUP
Q
DEN(DFN) ; EP - Dental exam
; Several calls below used to use $H-360.
; Replaced with BKMCKDT (FileMan format date).
N BKMCKDT
S BKMCKDT=$$FMADD^XLFDT(DT,-360)
K BKMT("DEN")
S GLOBAL="BKMT(""DEN"",VSTDT,TEST,""PRC"")"
D ICDTAX^BKMIXX1(DFN,"BKM DENTAL EXAMINATION","",BKMCKDT,GLOBAL)
S GLOBAL="BKMT(""DEN"",VSTDT,TEST,""ADA"")"
D ADATAX^BKMIXX(DFN,"BGP DENTAL EXAM DENTAL CODE","",BKMCKDT,GLOBAL)
S GLOBAL="BKMT(""DEN"",VSTDT,TEST,""EXAM"")"
D EXAMTAX^BKMIXX1(DFN,"30","",BKMCKDT,GLOBAL)
; Print results
S LINE=" Dental exam: "
D LTAXPRT^BKMVSUP1("DEN",1)
I $D(BKMT("DEN")) K BKMT("DEN") D UPD^BKMVSUP D UPD^BKMVSUP:LINE'="" Q
; If no dental exams found check refusals
; The following has been replaced with D REFUSAL^BKMIXX2 call
; S EXIEN=$O(^AUTTEXAM("C","30",""))
; I EXIEN S TST(EXIEN)="" W $$REF^BKMVSUP2(DFN,9999999.15,.TST)
D REFUSAL^BKMIXX2(DFN,9999999.15,"30","",BKMCKDT,GLOBAL)
; Print results
D LTAXPRT^BKMVSUP1("DEN",1,1,1)
I '$D(BKMT("DEN")) S LINE=$$LINE^BKMVSUP(LINE,"Date:",24)
D UPD^BKMVSUP
I LNCNT>MAXCT D NEWPG^BKMVSUP
Q
DRUGS(DFN) ; EP - Get medications
D HAART(DFN)
D MAC(DFN)
D PCP(DFN)
D PRTMP(DFN)
D NEW(DFN)
F TYPE="MAC","PCP","NEW" K ^TMP("BKMSUPP",$J,TYPE)
Q
HAART(DFN) ; GATHER HAART DRUG DATA (using Taxonomy)
N MEDDT,MEDIEN,DISC,STDT,SIG,QTY,DISPDT,RXNAME
K ^TMP("BKMSUPP",$J,"HAART") ;,^TMP("BKMSUPP",$J,"HAARTD")
S LINE=" Current ARV Medications (past 6 months): " D UPD^BKMVSUP
S GLOBAL="^TMP(""BKMSUPP"",$J,""HAART"",VSTDT,TEST)"
D NDCTAX^BKMIXX1(DFN,"BKMV EI MED NDCS","","",GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV EI MEDS","","",GLOBAL)
D NDCTAX^BKMIXX1(DFN,"BKMV NNRTI MED NDCS","","",GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV NNRTI MEDS","","",GLOBAL)
D NDCTAX^BKMIXX1(DFN,"BKMV NRTI MED NDCS","","",GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV NRTI MEDS","","",GLOBAL)
D NDCTAX^BKMIXX1(DFN,"BKMV PI MED NDCS","","",GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV PI MEDS","","",GLOBAL)
D NDCTAX^BKMIXX1(DFN,"BKMV II MED NDCS","","",GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV II MEDS","","",GLOBAL)
D NDCTAX^BKMIXX1(DFN,"BKMV NRTI/NNRTI MED NDCS","","",GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV NRTI/NNRTI MEDS","","",GLOBAL)
D NDCTAX^BKMIXX1(DFN,"BKMV NRTI COMBO MED NDCS","","",GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV NRTI COMBO MEDS","","",GLOBAL)
D NDCTAX^BKMIXX1(DFN,"BKMV PI BOOSTER MED NDCS","","",GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV PI BOOSTER MEDS","","",GLOBAL)
; *** separate list into active and discontinued
; *** NOTE: last 6 months for active HAART; **ALL** disc'd HAART
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 DISC=$$GET1^DIQ(9000010.14,MEDIEN,.08,"I")
.. I DISC D
... S BKMT("HAARTD",DISC,MEDDT,MEDIEN)="" ;Needed for flow sheet
... ;S ^TMP("BKMSUPP",$J,"HAARTD",MEDDT,MEDIEN)=^TMP("BKMSUPP",$J,"HAART",MEDDT,MEDIEN)
... K ^TMP("BKMSUPP",$J,"HAART",MEDDT,MEDIEN)
D DRPRT("HAART",$$FMADD^XLFDT(DT,-183))
I '$D(^TMP("BKMSUPP",$J,"HAART")) D
. ; Check refusals
. S GLOBAL="BKMT(""HAART"",VSTDT,TEST)"
. D REFUSAL^BKMIXX2(DFN,50,"BKMV EI MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV EI MEDS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV NNRTI MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV NNRTI MEDS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI MEDS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV PI MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV PI MEDS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV II MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV II MEDS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI/NNRTI MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI/NNRTI MEDS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI COMBO MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI COMBO MEDS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV PI BOOSTER MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV PI BOOSTER MEDS","","",GLOBAL)
. ; Print results
. D DRFPRT("HAART",1) K BKMT("HAART")
D UPD^BKMVSUP
; Discontinued drugs were disabled as per IHS
; S LINE=" Discontinued ARV Medications: [Data not currently available]"; ***
; D UPD^BKMVSUP ;***
; D DRPRT("HAARTD") ;inactivated print as per IHS
; keep drugs to identify "other" drugs
Q
MAC(DFN) ; GATHER MAC Prophylaxis DRUG DATA (using Taxonomy)
; Several calls below used to use $H-183.
; Replaced with BKMCKDT (FileMan format date).
N BKMCKDT
S BKMCKDT=$$FMADD^XLFDT(DT,-183)
I LNCNT>MAXCT D NEWPG^BKMVSUP
S GLOBAL="^TMP(""BKMSUPP"",$J,""MAC"",VSTDT,TEST)"
D NDCTAX^BKMIXX1(DFN,"BKMV MAC PROPH MED NDCS","",BKMCKDT,GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV MAC PROPH MEDS","",BKMCKDT,GLOBAL)
I '$D(^TMP("BKMSUPP",$J,"MAC")) D
. ; Check refusals
. S GLOBAL="BKMT(""MAC"",VSTDT,TEST)"
. D REFUSAL^BKMIXX2(DFN,50,"BKMV MAC PROPH MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV MAC PROPH MEDS","","",GLOBAL)
; keep drugs to identify "other" drugs
I LNCNT>MAXCT D NEWPG^BKMVSUP
Q
PCP(DFN) ; GATHER PCP Prophylaxis DRUG DATA (using Taxonomy)
; Several calls below used to use $H-183.
; Replaced with BKMCKDT (FileMan format date).
N BKMCKDT
S BKMCKDT=$$FMADD^XLFDT(DT,-183)
S GLOBAL="^TMP(""BKMSUPP"",$J,""PCP"",VSTDT,TEST)"
D NDCTAX^BKMIXX1(DFN,"BKMV PCP PROPH MED NDCS","",BKMCKDT,GLOBAL)
D MEDTAX^BKMIXX(DFN,"BKMV PCP PROPH MEDS","",BKMCKDT,GLOBAL)
I '$D(^TMP("BKMSUPP",$J,"PCP")) D
. ; Check refusals
. S GLOBAL="BKMT(""PCP"",VSTDT,TEST)"
. D REFUSAL^BKMIXX2(DFN,50,"BKMV PCP PROPH MED NDCS","","",GLOBAL)
. D REFUSAL^BKMIXX2(DFN,50,"BKMV PCP PROPH MEDS","","",GLOBAL)
; keep drugs to identify "new" drugs
I LNCNT>MAXCT D NEWPG^BKMVSUP
Q
PRTMP(DFN) ; Combine MAC and PCP results for printing purposes
K ^TMP("BKMSUPP",$J,"MACPCP"),BKMT("MACPCP")
M ^TMP("BKMSUPP",$J,"MACPCP")=^TMP("BKMSUPP",$J,"MAC")
M ^TMP("BKMSUPP",$J,"MACPCP")=^TMP("BKMSUPP",$J,"PCP")
D UPD^BKMVSUP S LINE=" Prophylaxis Medications for MAC and/or PCP (past 6 months): "
D UPD^BKMVSUP
I $D(^TMP("BKMSUPP",$J,"MACPCP")) D DRPRT("MACPCP",$$FMADD^XLFDT(DT,-183))
I '$D(^TMP("BKMSUPP",$J,"MACPCP")) D
. M BKMT("MACPCP")=BKMT("MAC")
. M BKMT("MACPCP")=BKMT("PCP")
. D DRFPRT("MACPCP",1)
. K BKMT("PCP"),BKMT("MAC"),BKMT("MACPCP")
K ^TMP("BKMSUPP",$J,"MACPCP")
Q
NEW(DFN) ; GATHER "New" DRUG DATA (drugs dispensed during last 6 mos excluding previously listed drugs)
; Disabled as per IHS ***
Q
N TEST,VISIT,VSTDT,OLD,TYPE
S TEST=""
F S TEST=$O(^AUPNVMED("AC",DFN,TEST)) Q:TEST="" D
. S VISIT=$$GET1^DIQ(9000010.14,TEST,.03,"I")
. S VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
. S OLD=""
. F TYPE="HAART","HAARTD","MAC","PCP" I $D(^TMP("BKMSUPP",$J,TYPE,VSTDT,TEST)) S OLD=1 Q
. Q:OLD
. ; Build same data string as BKMIXX* routines used in other sections.
. N MED,SIG,QTY,DAY
. S MED=$$GET1^DIQ(9000010.14,TEST,.01,"E")
. S SIG=$$GET1^DIQ(9000010.14,TEST,.05,"E")
. S QTY=$$GET1^DIQ(9000010.14,TEST,.06,"E")
. S DAY=$$GET1^DIQ(9000010.14,TEST,.07,"E")
. S ^TMP("BKMSUPP",$J,"NEW",VSTDT,TEST)=MED_U_SIG_U_QTY_U_DAY
D UPD^BKMVSUP
S LINE=" Any Other Medications prescribed (past 6 months): " D UPD^BKMVSUP
D DRPRT("NEW",$$FMADD^XLFDT(DT,-183))
I LNCNT>MAXCT D NEWPG^BKMVSUP
Q
DRPRT(TYPE,STDT) ; Print Drugs
Q:'$D(^TMP("BKMSUPP",$J,TYPE))
N MEDDT,DISPDT,MEDIEN,SIG,QTY,RXIEN,RXNAME
S STDT=$G(STDT)
I STDT,'$O(^TMP("BKMSUPP",$J,TYPE,STDT-.01)) Q
I LNCNT>(MAXCT-2) D NEWPG^BKMVSUP
D UPD^BKMVSUP
S LINE=" [Date]",LINE=$$LINE^BKMVSUP(LINE,"[Med Name]",18)
S LINE=$$LINE^BKMVSUP(LINE,"[SIG]",50),LINE=$$LINE^BKMVSUP(LINE,"[Qty]",66)
S MEDDT="" F S MEDDT=$O(^TMP("BKMSUPP",$J,TYPE,MEDDT),-1) Q:MEDDT<STDT!'MEDDT D
. ; PRXM/HC/BHS - 11/01/2005 - Modified external date format to MM/DD/CCYY to eliminate time
. S DISPDT=$$FMTE^XLFDT(MEDDT\1,"5Z")
. S MEDIEN="" F S MEDIEN=$O(^TMP("BKMSUPP",$J,TYPE,MEDDT,MEDIEN)) Q:MEDIEN="" D
.. N TEMP
.. S TEMP=^TMP("BKMSUPP",$J,TYPE,MEDDT,MEDIEN)
.. S RXNAME=$P(TEMP,U,1),SIG=$P(TEMP,U,2),QTY=$P(TEMP,U,3)
.. D UPD^BKMVSUP
.. S LINE=" "_DISPDT,LINE=$$LINE^BKMVSUP(LINE,$E(RXNAME,1,30),18)
.. S LINE=$$LINE^BKMVSUP(LINE,$E(SIG,1,14),50),LINE=$$LINE^BKMVSUP(LINE,QTY,66)
.. I LNCNT>MAXCT D NEWPG^BKMVSUP
D UPD^BKMVSUP
I LNCNT>MAXCT D NEWPG^BKMVSUP
Q
;
DRFPRT(TYP,MAX) ; Print Drug Refusals
; TYP = Type of test (subscript in BKMT array)
; MAX = Maximum number of results to print
N DDT,CNT,Y,TST
S MAX=$G(MAX,1)
S (DDT,CNT)=""
F S DDT=$O(BKMT(TYP,DDT),-1) Q:'DDT D Q:CNT>MAX
. S Y=$P($$FMTE^XLFDT(DDT,"5Z"),"@")
. S TST=""
. F S TST=$O(BKMT(TYP,DDT,TST)) Q:TST="" D Q:CNT>MAX
.. S LINE=" Date: "_Y,LINE=$$LINE^BKMVSUP(LINE,"[Refusal Type: ",22)_$P(BKMT(TYP,DDT,TST),U)_"]"
.. S CNT=CNT+1
.. D UPD^BKMVSUP
.. I LNCNT>MAXCT D NEWPG^BKMVSUP
Q
;
PAUSE() ; EP - For screen displays pause and allow user to stop
; Returns a 1 if the user elected to stop
; Matches Health Summary
I IOST'["C-" Q 0
N READ
R !,"<>",READ:DTIME I '$T Q 1
I READ="^" Q 1
Q 0
;
XIT ; QUIT POINT
Q
BKMVSUP3 ;PRXM/HC/WOM - Continuation of BKMVSUP, HIV SUPPLEMENT; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 12:46 PM
+1 ;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
+2 QUIT
RET(DFN) ; EP - Retrieve Eye taxonomies (P.03)
+1 ; Several calls below used to use $H-360.
+2 ; Replaced with BKMCKDT (FileMan format date).
+3 NEW BKMCKDT,PRV,CLN
+4 SET BKMCKDT=$$FMADD^XLFDT(DT,-360)
+5 KILL BKMT("EYE")
+6 SET GLOBAL="BKMT(""EYE"",VSTDT,TEST,""CPT"")"
+7 DO CPTTAX^BKMIXX(DFN,"BGP DM EYE EXAM CPTS","",BKMCKDT,GLOBAL)
+8 DO CPTTAX^BKMIXX(DFN,"BGP RETINAL EXAM CPTS","",BKMCKDT,GLOBAL)
+9 SET GLOBAL="BKMT(""EYE"",VSTDT,TEST,""EXAM"")"
+10 DO EXAMTAX^BKMIXX1(DFN,"03","",BKMCKDT,GLOBAL)
+11 ; Added provider, clinic code and procedure checks
+12 SET GLOBAL="BKMT(""EYE"",VSTDT,TEST,""PRV"")"
+13 ; Check provider codes
+14 FOR PRV="79","24","08"
Begin DoDot:1
+15 DO PRVTAX^BKMIXX2(DFN,PRV,"",BKMCKDT,GLOBAL)
End DoDot:1
+16 SET GLOBAL="BKMT(""EYE"",VSTDT,TEST,""CLN"")"
+17 ; Check clinic codes
+18 FOR CLN="17","18","64","A2"
Begin DoDot:1
+19 DO CLNTAX^BKMIXX2(DFN,CLN,"",BKMCKDT,GLOBAL)
End DoDot:1
+20 ; Check procedure code
+21 ;D PROCTAX^BKMIXX2(DFN,95.02,"",BKMCKDT,GLOBAL)
+22 DO PRCTAX^BKMIXX1(DFN,"BQI EYE EXAM PROCS","",BKMCKDT,GLOBAL)
+23 ; Check POVs
+24 ;D POVTAX^BKMIXX2(DFN,"V72.0","",BKMCKDT,GLOBAL)
+25 DO ICDTAX^BKMIXX1(DFN,"BQI EYE EXAM DXS","",BKMCKDT,GLOBAL)
+26 ; Print results
+27 SET LINE=" Dilated eye exam: "
+28 DO LTAXPRT^BKMVSUP1("EYE",1)
+29 IF $DATA(BKMT("EYE"))
KILL BKMT("EYE")
DO UPD^BKMVSUP
IF LINE'=""
DO UPD^BKMVSUP
QUIT
+30 ; If no eye exams found check refusals
+31 ; The following has been replaced with D REFUSAL^BKMIXX2 call
+32 ; S EXIEN=$O(^AUTTEXAM("C","03",""))
+33 ; I EXIEN S TST(EXIEN)="" W $$REF^BKMVSUP2(DFN,9999999.15,.TST)
+34 DO REFUSAL^BKMIXX2(DFN,9999999.15,"03","",BKMCKDT,GLOBAL)
+35 ; Print results
+36 DO LTAXPRT^BKMVSUP1("EYE",1,1,1)
+37 IF '$DATA(BKMT("EYE"))
SET LINE=$$LINE^BKMVSUP(LINE,"Date:",24)
+38 DO UPD^BKMVSUP
+39 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+40 QUIT
MAM(DFN) ; EP - Retrieve mammogram taxonomies
+1 ; Several calls below used to use $H-360.
+2 ; Replaced with BKMCKDT (FileMan format date).
+3 NEW BKMCKDT
+4 SET BKMCKDT=$$FMADD^XLFDT(DT,-360)
+5 ; *** Examine V Rad and V CPT; if others are needed will have to add
+6 ; Q:$P(^DPT(DFN,0),U,2)'="F" ; - removed and replaced with N/A as per IHS
+7 SET LINE=" Mammogram: "
+8 ;Females only
IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET LINE=LINE_"Not Applicable"
QUIT
+9 KILL BKMT("MAM")
+10 SET GLOBAL="BKMT(""MAM"",VSTDT,TEST,""PROC"")"
+11 DO PRCTAX^BKMIXX1(DFN,"BGP MAMMOGRAM PROCEDURES","",BKMCKDT,GLOBAL)
+12 SET GLOBAL="BKMT(""MAM"",VSTDT,TEST,""ICD"")"
+13 DO ICDTAX^BKMIXX1(DFN,"BGP MAMMOGRAM ICDS","",BKMCKDT,GLOBAL)
+14 SET GLOBAL="BKMT(""MAM"",VSTDT,TEST,""CPT"")"
+15 DO CPTTAX^BKMIXX(DFN,"BGP CPT MAMMOGRAM","",BKMCKDT,GLOBAL)
+16 ; Additional check of V-Rad file for mammography.
+17 SET GLOBAL="BKMT(""MAM"",VSTDT,TEST,""RAD"")"
+18 DO RADTAX^BKMIXX1(DFN,"BGP CPT MAMMOGRAM","",BKMCKDT,GLOBAL)
+19 IF $DATA(BKMT("MAM"))
DO LTAXPRT^BKMVSUP1("MAM",1)
KILL BKMT("MAM")
IF LINE'=""
DO UPD^BKMVSUP
QUIT
+20 DO REFUSAL^BKMIXX2(DFN,71,"BGP CPT MAMMOGRAM","",BKMCKDT,GLOBAL)
+21 ; Print results
+22 DO LTAXPRT^BKMVSUP1("MAM",1,1,1)
+23 IF '$DATA(BKMT("MAM"))
SET LINE=$$LINE^BKMVSUP(LINE,"Date:",24)
+24 KILL BKMT("MAM")
+25 IF LINE'=""
DO UPD^BKMVSUP
+26 QUIT
DEN(DFN) ; EP - Dental exam
+1 ; Several calls below used to use $H-360.
+2 ; Replaced with BKMCKDT (FileMan format date).
+3 NEW BKMCKDT
+4 SET BKMCKDT=$$FMADD^XLFDT(DT,-360)
+5 KILL BKMT("DEN")
+6 SET GLOBAL="BKMT(""DEN"",VSTDT,TEST,""PRC"")"
+7 DO ICDTAX^BKMIXX1(DFN,"BKM DENTAL EXAMINATION","",BKMCKDT,GLOBAL)
+8 SET GLOBAL="BKMT(""DEN"",VSTDT,TEST,""ADA"")"
+9 DO ADATAX^BKMIXX(DFN,"BGP DENTAL EXAM DENTAL CODE","",BKMCKDT,GLOBAL)
+10 SET GLOBAL="BKMT(""DEN"",VSTDT,TEST,""EXAM"")"
+11 DO EXAMTAX^BKMIXX1(DFN,"30","",BKMCKDT,GLOBAL)
+12 ; Print results
+13 SET LINE=" Dental exam: "
+14 DO LTAXPRT^BKMVSUP1("DEN",1)
+15 IF $DATA(BKMT("DEN"))
KILL BKMT("DEN")
DO UPD^BKMVSUP
IF LINE'=""
DO UPD^BKMVSUP
QUIT
+16 ; If no dental exams found check refusals
+17 ; The following has been replaced with D REFUSAL^BKMIXX2 call
+18 ; S EXIEN=$O(^AUTTEXAM("C","30",""))
+19 ; I EXIEN S TST(EXIEN)="" W $$REF^BKMVSUP2(DFN,9999999.15,.TST)
+20 DO REFUSAL^BKMIXX2(DFN,9999999.15,"30","",BKMCKDT,GLOBAL)
+21 ; Print results
+22 DO LTAXPRT^BKMVSUP1("DEN",1,1,1)
+23 IF '$DATA(BKMT("DEN"))
SET LINE=$$LINE^BKMVSUP(LINE,"Date:",24)
+24 DO UPD^BKMVSUP
+25 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+26 QUIT
DRUGS(DFN) ; EP - Get medications
+1 DO HAART(DFN)
+2 DO MAC(DFN)
+3 DO PCP(DFN)
+4 DO PRTMP(DFN)
+5 DO NEW(DFN)
+6 FOR TYPE="MAC","PCP","NEW"
KILL ^TMP("BKMSUPP",$JOB,TYPE)
+7 QUIT
HAART(DFN) ; GATHER HAART DRUG DATA (using Taxonomy)
+1 NEW MEDDT,MEDIEN,DISC,STDT,SIG,QTY,DISPDT,RXNAME
+2 ;,^TMP("BKMSUPP",$J,"HAARTD")
KILL ^TMP("BKMSUPP",$JOB,"HAART")
+3 SET LINE=" Current ARV Medications (past 6 months): "
DO UPD^BKMVSUP
+4 SET GLOBAL="^TMP(""BKMSUPP"",$J,""HAART"",VSTDT,TEST)"
+5 DO NDCTAX^BKMIXX1(DFN,"BKMV EI MED NDCS","","",GLOBAL)
+6 DO MEDTAX^BKMIXX(DFN,"BKMV EI MEDS","","",GLOBAL)
+7 DO NDCTAX^BKMIXX1(DFN,"BKMV NNRTI MED NDCS","","",GLOBAL)
+8 DO MEDTAX^BKMIXX(DFN,"BKMV NNRTI MEDS","","",GLOBAL)
+9 DO NDCTAX^BKMIXX1(DFN,"BKMV NRTI MED NDCS","","",GLOBAL)
+10 DO MEDTAX^BKMIXX(DFN,"BKMV NRTI MEDS","","",GLOBAL)
+11 DO NDCTAX^BKMIXX1(DFN,"BKMV PI MED NDCS","","",GLOBAL)
+12 DO MEDTAX^BKMIXX(DFN,"BKMV PI MEDS","","",GLOBAL)
+13 DO NDCTAX^BKMIXX1(DFN,"BKMV II MED NDCS","","",GLOBAL)
+14 DO MEDTAX^BKMIXX(DFN,"BKMV II MEDS","","",GLOBAL)
+15 DO NDCTAX^BKMIXX1(DFN,"BKMV NRTI/NNRTI MED NDCS","","",GLOBAL)
+16 DO MEDTAX^BKMIXX(DFN,"BKMV NRTI/NNRTI MEDS","","",GLOBAL)
+17 DO NDCTAX^BKMIXX1(DFN,"BKMV NRTI COMBO MED NDCS","","",GLOBAL)
+18 DO MEDTAX^BKMIXX(DFN,"BKMV NRTI COMBO MEDS","","",GLOBAL)
+19 DO NDCTAX^BKMIXX1(DFN,"BKMV PI BOOSTER MED NDCS","","",GLOBAL)
+20 DO MEDTAX^BKMIXX(DFN,"BKMV PI BOOSTER MEDS","","",GLOBAL)
+21 ; *** separate list into active and discontinued
+22 ; *** NOTE: last 6 months for active HAART; **ALL** disc'd HAART
+23 SET MEDDT=""
+24 FOR
SET MEDDT=$ORDER(^TMP("BKMSUPP",$JOB,"HAART",MEDDT))
IF MEDDT=""
QUIT
Begin DoDot:1
+25 SET MEDIEN=""
FOR
SET MEDIEN=$ORDER(^TMP("BKMSUPP",$JOB,"HAART",MEDDT,MEDIEN))
IF MEDIEN=""
QUIT
Begin DoDot:2
+26 SET DISC=$$GET1^DIQ(9000010.14,MEDIEN,.08,"I")
+27 IF DISC
Begin DoDot:3
+28 ;Needed for flow sheet
SET BKMT("HAARTD",DISC,MEDDT,MEDIEN)=""
+29 ;S ^TMP("BKMSUPP",$J,"HAARTD",MEDDT,MEDIEN)=^TMP("BKMSUPP",$J,"HAART",MEDDT,MEDIEN)
+30 KILL ^TMP("BKMSUPP",$JOB,"HAART",MEDDT,MEDIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+31 DO DRPRT("HAART",$$FMADD^XLFDT(DT,-183))
+32 IF '$DATA(^TMP("BKMSUPP",$JOB,"HAART"))
Begin DoDot:1
+33 ; Check refusals
+34 SET GLOBAL="BKMT(""HAART"",VSTDT,TEST)"
+35 DO REFUSAL^BKMIXX2(DFN,50,"BKMV EI MED NDCS","","",GLOBAL)
+36 DO REFUSAL^BKMIXX2(DFN,50,"BKMV EI MEDS","","",GLOBAL)
+37 DO REFUSAL^BKMIXX2(DFN,50,"BKMV NNRTI MED NDCS","","",GLOBAL)
+38 DO REFUSAL^BKMIXX2(DFN,50,"BKMV NNRTI MEDS","","",GLOBAL)
+39 DO REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI MED NDCS","","",GLOBAL)
+40 DO REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI MEDS","","",GLOBAL)
+41 DO REFUSAL^BKMIXX2(DFN,50,"BKMV PI MED NDCS","","",GLOBAL)
+42 DO REFUSAL^BKMIXX2(DFN,50,"BKMV PI MEDS","","",GLOBAL)
+43 DO REFUSAL^BKMIXX2(DFN,50,"BKMV II MED NDCS","","",GLOBAL)
+44 DO REFUSAL^BKMIXX2(DFN,50,"BKMV II MEDS","","",GLOBAL)
+45 DO REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI/NNRTI MED NDCS","","",GLOBAL)
+46 DO REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI/NNRTI MEDS","","",GLOBAL)
+47 DO REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI COMBO MED NDCS","","",GLOBAL)
+48 DO REFUSAL^BKMIXX2(DFN,50,"BKMV NRTI COMBO MEDS","","",GLOBAL)
+49 DO REFUSAL^BKMIXX2(DFN,50,"BKMV PI BOOSTER MED NDCS","","",GLOBAL)
+50 DO REFUSAL^BKMIXX2(DFN,50,"BKMV PI BOOSTER MEDS","","",GLOBAL)
+51 ; Print results
+52 DO DRFPRT("HAART",1)
KILL BKMT("HAART")
End DoDot:1
+53 DO UPD^BKMVSUP
+54 ; Discontinued drugs were disabled as per IHS
+55 ; S LINE=" Discontinued ARV Medications: [Data not currently available]"; ***
+56 ; D UPD^BKMVSUP ;***
+57 ; D DRPRT("HAARTD") ;inactivated print as per IHS
+58 ; keep drugs to identify "other" drugs
+59 QUIT
MAC(DFN) ; GATHER MAC Prophylaxis DRUG DATA (using Taxonomy)
+1 ; Several calls below used to use $H-183.
+2 ; Replaced with BKMCKDT (FileMan format date).
+3 NEW BKMCKDT
+4 SET BKMCKDT=$$FMADD^XLFDT(DT,-183)
+5 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+6 SET GLOBAL="^TMP(""BKMSUPP"",$J,""MAC"",VSTDT,TEST)"
+7 DO NDCTAX^BKMIXX1(DFN,"BKMV MAC PROPH MED NDCS","",BKMCKDT,GLOBAL)
+8 DO MEDTAX^BKMIXX(DFN,"BKMV MAC PROPH MEDS","",BKMCKDT,GLOBAL)
+9 IF '$DATA(^TMP("BKMSUPP",$JOB,"MAC"))
Begin DoDot:1
+10 ; Check refusals
+11 SET GLOBAL="BKMT(""MAC"",VSTDT,TEST)"
+12 DO REFUSAL^BKMIXX2(DFN,50,"BKMV MAC PROPH MED NDCS","","",GLOBAL)
+13 DO REFUSAL^BKMIXX2(DFN,50,"BKMV MAC PROPH MEDS","","",GLOBAL)
End DoDot:1
+14 ; keep drugs to identify "other" drugs
+15 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+16 QUIT
PCP(DFN) ; GATHER PCP Prophylaxis DRUG DATA (using Taxonomy)
+1 ; Several calls below used to use $H-183.
+2 ; Replaced with BKMCKDT (FileMan format date).
+3 NEW BKMCKDT
+4 SET BKMCKDT=$$FMADD^XLFDT(DT,-183)
+5 SET GLOBAL="^TMP(""BKMSUPP"",$J,""PCP"",VSTDT,TEST)"
+6 DO NDCTAX^BKMIXX1(DFN,"BKMV PCP PROPH MED NDCS","",BKMCKDT,GLOBAL)
+7 DO MEDTAX^BKMIXX(DFN,"BKMV PCP PROPH MEDS","",BKMCKDT,GLOBAL)
+8 IF '$DATA(^TMP("BKMSUPP",$JOB,"PCP"))
Begin DoDot:1
+9 ; Check refusals
+10 SET GLOBAL="BKMT(""PCP"",VSTDT,TEST)"
+11 DO REFUSAL^BKMIXX2(DFN,50,"BKMV PCP PROPH MED NDCS","","",GLOBAL)
+12 DO REFUSAL^BKMIXX2(DFN,50,"BKMV PCP PROPH MEDS","","",GLOBAL)
End DoDot:1
+13 ; keep drugs to identify "new" drugs
+14 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+15 QUIT
PRTMP(DFN) ; Combine MAC and PCP results for printing purposes
+1 KILL ^TMP("BKMSUPP",$JOB,"MACPCP"),BKMT("MACPCP")
+2 MERGE ^TMP("BKMSUPP",$JOB,"MACPCP")=^TMP("BKMSUPP",$JOB,"MAC")
+3 MERGE ^TMP("BKMSUPP",$JOB,"MACPCP")=^TMP("BKMSUPP",$JOB,"PCP")
+4 DO UPD^BKMVSUP
SET LINE=" Prophylaxis Medications for MAC and/or PCP (past 6 months): "
+5 DO UPD^BKMVSUP
+6 IF $DATA(^TMP("BKMSUPP",$JOB,"MACPCP"))
DO DRPRT("MACPCP",$$FMADD^XLFDT(DT,-183))
+7 IF '$DATA(^TMP("BKMSUPP",$JOB,"MACPCP"))
Begin DoDot:1
+8 MERGE BKMT("MACPCP")=BKMT("MAC")
+9 MERGE BKMT("MACPCP")=BKMT("PCP")
+10 DO DRFPRT("MACPCP",1)
+11 KILL BKMT("PCP"),BKMT("MAC"),BKMT("MACPCP")
End DoDot:1
+12 KILL ^TMP("BKMSUPP",$JOB,"MACPCP")
+13 QUIT
NEW(DFN) ; GATHER "New" DRUG DATA (drugs dispensed during last 6 mos excluding previously listed drugs)
+1 ; Disabled as per IHS ***
+2 QUIT
+3 NEW TEST,VISIT,VSTDT,OLD,TYPE
+4 SET TEST=""
+5 FOR
SET TEST=$ORDER(^AUPNVMED("AC",DFN,TEST))
IF TEST=""
QUIT
Begin DoDot:1
+6 SET VISIT=$$GET1^DIQ(9000010.14,TEST,.03,"I")
+7 SET VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
+8 SET OLD=""
+9 FOR TYPE="HAART","HAARTD","MAC","PCP"
IF $DATA(^TMP("BKMSUPP",$JOB,TYPE,VSTDT,TEST))
SET OLD=1
QUIT
+10 IF OLD
QUIT
+11 ; Build same data string as BKMIXX* routines used in other sections.
+12 NEW MED,SIG,QTY,DAY
+13 SET MED=$$GET1^DIQ(9000010.14,TEST,.01,"E")
+14 SET SIG=$$GET1^DIQ(9000010.14,TEST,.05,"E")
+15 SET QTY=$$GET1^DIQ(9000010.14,TEST,.06,"E")
+16 SET DAY=$$GET1^DIQ(9000010.14,TEST,.07,"E")
+17 SET ^TMP("BKMSUPP",$JOB,"NEW",VSTDT,TEST)=MED_U_SIG_U_QTY_U_DAY
End DoDot:1
+18 DO UPD^BKMVSUP
+19 SET LINE=" Any Other Medications prescribed (past 6 months): "
DO UPD^BKMVSUP
+20 DO DRPRT("NEW",$$FMADD^XLFDT(DT,-183))
+21 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+22 QUIT
DRPRT(TYPE,STDT) ; Print Drugs
+1 IF '$DATA(^TMP("BKMSUPP",$JOB,TYPE))
QUIT
+2 NEW MEDDT,DISPDT,MEDIEN,SIG,QTY,RXIEN,RXNAME
+3 SET STDT=$GET(STDT)
+4 IF STDT
IF '$ORDER(^TMP("BKMSUPP",$JOB,TYPE,STDT-.01))
QUIT
+5 IF LNCNT>(MAXCT-2)
DO NEWPG^BKMVSUP
+6 DO UPD^BKMVSUP
+7 SET LINE=" [Date]"
SET LINE=$$LINE^BKMVSUP(LINE,"[Med Name]",18)
+8 SET LINE=$$LINE^BKMVSUP(LINE,"[SIG]",50)
SET LINE=$$LINE^BKMVSUP(LINE,"[Qty]",66)
+9 SET MEDDT=""
FOR
SET MEDDT=$ORDER(^TMP("BKMSUPP",$JOB,TYPE,MEDDT),-1)
IF MEDDT<STDT!'MEDDT
QUIT
Begin DoDot:1
+10 ; PRXM/HC/BHS - 11/01/2005 - Modified external date format to MM/DD/CCYY to eliminate time
+11 SET DISPDT=$$FMTE^XLFDT(MEDDT\1,"5Z")
+12 SET MEDIEN=""
FOR
SET MEDIEN=$ORDER(^TMP("BKMSUPP",$JOB,TYPE,MEDDT,MEDIEN))
IF MEDIEN=""
QUIT
Begin DoDot:2
+13 NEW TEMP
+14 SET TEMP=^TMP("BKMSUPP",$JOB,TYPE,MEDDT,MEDIEN)
+15 SET RXNAME=$PIECE(TEMP,U,1)
SET SIG=$PIECE(TEMP,U,2)
SET QTY=$PIECE(TEMP,U,3)
+16 DO UPD^BKMVSUP
+17 SET LINE=" "_DISPDT
SET LINE=$$LINE^BKMVSUP(LINE,$EXTRACT(RXNAME,1,30),18)
+18 SET LINE=$$LINE^BKMVSUP(LINE,$EXTRACT(SIG,1,14),50)
SET LINE=$$LINE^BKMVSUP(LINE,QTY,66)
+19 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
End DoDot:2
End DoDot:1
+20 DO UPD^BKMVSUP
+21 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
+22 QUIT
+23 ;
DRFPRT(TYP,MAX) ; Print Drug Refusals
+1 ; TYP = Type of test (subscript in BKMT array)
+2 ; MAX = Maximum number of results to print
+3 NEW DDT,CNT,Y,TST
+4 SET MAX=$GET(MAX,1)
+5 SET (DDT,CNT)=""
+6 FOR
SET DDT=$ORDER(BKMT(TYP,DDT),-1)
IF 'DDT
QUIT
Begin DoDot:1
+7 SET Y=$PIECE($$FMTE^XLFDT(DDT,"5Z"),"@")
+8 SET TST=""
+9 FOR
SET TST=$ORDER(BKMT(TYP,DDT,TST))
IF TST=""
QUIT
Begin DoDot:2
+10 SET LINE=" Date: "_Y
SET LINE=$$LINE^BKMVSUP(LINE,"[Refusal Type: ",22)_$PIECE(BKMT(TYP,DDT,TST),U)_"]"
+11 SET CNT=CNT+1
+12 DO UPD^BKMVSUP
+13 IF LNCNT>MAXCT
DO NEWPG^BKMVSUP
End DoDot:2
IF CNT>MAX
QUIT
End DoDot:1
IF CNT>MAX
QUIT
+14 QUIT
+15 ;
PAUSE() ; EP - For screen displays pause and allow user to stop
+1 ; Returns a 1 if the user elected to stop
+2 ; Matches Health Summary
+3 IF IOST'["C-"
QUIT 0
+4 NEW READ
+5 READ !,"<>",READ:DTIME
IF '$TEST
QUIT 1
+6 IF READ="^"
QUIT 1
+7 QUIT 0
+8 ;
XIT ; QUIT POINT
+1 QUIT
