BKMVSUP6 ;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
W @IOF
;I PAGE=1 S $X=0
;E W @IOF
W !?1,$$CONF(""),!?(IOM-41\2),"****** HMS PATIENT CARE SUPPLEMENT ******"
W !!?1,"Report Date: ",XNOW,?69,"Page: ",PAGE,!!
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
;
CONF(END) ; EP - Print confidential message
; END is set if final page and ending message is being printed.
N X,Y,TIM,AP,HDR
S Y=$$FMTE^XLFDT($$NOW^XLFDT()) S TIM=$P(Y,"@",2)
S AP="AM" S:+TIM=12 AP="PM"
S:+TIM>12 TIM=TIM-12_":"_$P(TIM,":",2),AP="PM" S TIM=TIM_" "_AP
; ***** CONFIDENTIAL PATIENT INFORMATION -- DATE/TIME **************
S HDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,"5Z")_" "_$J(TIM,9)_" ["_$P(^VA(200,DUZ,0),U,2)_"]"
S X="",$P(X,"*",((IOM-6-$L(HDR))\2)+1)="*"
S HDR=$S($G(END):$E("**** END *",$L(X)-4,12),1:X)_" "_HDR_" "_X
Q HDR
;
GETALL(DFN) ; EP - Gather patient information
; Code taken from BKMVC6 but revised to limit search to Problem List and to capture problem status
NEW IENDA0,IENDA,IENS,TARGET,HTARGET
NEW ATAX,ATAX1,STAT,OTHERDT,DATE,ICD9,POVDATE,REVDATE,VPOV
K ICD9S
S ATAX=$O(^ATXAX("B","BKMV AIDS DEF ILL DXS","")) ; DX.1
S ATAX1=$O(^ATXAX("B","BKMV HIV OPP INF DXS","")) ; DX.8
;
S VPOV=""
F S VPOV=$O(^AUPNPROB("AC",DFN,VPOV)) Q:VPOV="" D
. S IENS=$$IENS^DILF(VPOV)
. S POVDATE=$$PROB^BKMVUTL(IENS)
. Q:POVDATE'?1.N
. S REVDATE=9999999-POVDATE
. S ICD9=$P($G(^AUPNPROB(VPOV,0)),"^",1)
. I ICD9="" Q
. I $$PATCH^XPDUTL("ATX*5.1*11") I $$ICD^ATXAPI(ICD9,ATAX,9)=0,$$ICD^ATXAPI(ICD9,ATAX1,9)=0 Q
. E I $$ICD^BKMIXX5(ICD9,ATAX,9)=0,$$ICD^BKMIXX5(ICD9,ATAX1,9)=0 Q
. S NAR=$$GET1^DIQ(9000011,IENS,.05,"E")
. S STAT=$$GET1^DIQ(9000011,IENS,.12,"E")
. S DATE=REVDATE,OTHERDT="" ;ICD9S(REVDATE,ICD9)=STAT_U_NAR
. ;List date entered/last modified if different from date of onset
. I POVDATE'=$$GET1^DIQ(9000011,IENS,.13,"I") D
.. ;N OTHERDT
.. S OTHERDT=$$GET1^DIQ(9000011,IENS,.13,"I")
.. ;I OTHERDT="" S OTHERDT=$$GET1^DIQ(9000011,IENS,.03,"I")
.. Q:POVDATE=OTHERDT!(OTHERDT="")
.. S DATE=9999999-OTHERDT
.. ;S ICD9S(REVDATE,ICD9)=STAT_U_NAR_U_OTHERDT
. I OTHERDT=POVDATE S POVDATE=""
. S ICD9S(DATE,ICD9)=STAT_U_NAR_U_POVDATE
QUIT
;
LIPID(DFN) ; EP - Retrieve Lipid taxonomies
N LAST,GLOBAL
N CPTTAX,LOINTAX,SITETAX
S LINE=" Lipid Profile:"
;D UPD^BKMVSUP
K BKMT("LIP"),BKMT("LIPID")
S GLOBAL="BKMT(""LIP"",VSTDT,TEST,""LAB"")"
S CPTTAX="BGP LIPID PROFILE CPTS"
S LOINTAX="BGP LIPID PROFILE LOINC CODES"
S SITETAX="DM AUDIT LIPID PROFILE TAX"
D LIPPRO(LOINTAX,DFN,"","",GLOBAL)
D LIPPRO(SITETAX,DFN,"","",GLOBAL)
D CPTTAX^BKMIXX(DFN,CPTTAX,"","",GLOBAL)
I $D(BKMT("LIP")) D Q
. S LAST=$O(BKMT("LIP",""),-1)
. M BKMT("LIPID",LAST)=BKMT("LIP",LAST) K BKMT("LIP")
. D LTAXPRT^BKMVSUP1("LIPID",1000,1)
S GLOBAL="BKMT(""LIPID"",VSTDT,TEST,""LAB"")"
D REFUSAL^BKMIXX2(DFN,60,LOINTAX,"","",GLOBAL)
D REFUSAL^BKMIXX2(DFN,60,SITETAX,"","",GLOBAL)
; Print results
D LTAXPRT^BKMVSUP1("LIPID",1,1,1)
I LINE'="" D UPD^BKMVSUP
Q
LIPPRO(TAX,DFN,EDATE,SDATE,TARGET) ; EP
; Get lab result associated with a lipid profile for a patient
;
N RESULT,LAB,LB,IEN,TEST,VISIT,VSTDT
S RESULT=""
D BLDTAX^BKMIXX5(TAX,"LAB")
S LAB=""
F S LAB=$O(LAB(LAB)) Q:LAB="" D ;I $O(^LAB(60,LAB,2)) D
. S IEN=0
. F S IEN=$O(^LAB(60,LAB,2,IEN)) Q:'IEN S LB=$G(^(IEN,0)) I LB'="" S LAB(LB)=""
S TEST="" ;,LDATE=$G(LDATE,""),LIEN=$G(LIEN,"")
F S TEST=$O(^AUPNVLAB("AC",DFN,TEST),-1) Q:TEST="" D
.S LAB=$$GET1^DIQ(9000010.09,TEST,.01,"I")
.I LAB="" Q
.I '$D(LAB(LAB)) Q
.S VISIT=$$GET1^DIQ(9000010.09,TEST,.03,"I")
.S VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I") Q:VSTDT=""
.I $G(SDATE)'="",(VSTDT<SDATE) Q
.I $G(EDATE)'="",(VSTDT\1>EDATE) Q
.;I VSTDT>LDATE S LDATE=VSTDT,LIEN=TEST
.;I VSTDT=LDATE,TEST>LIEN S LDATE=VSTDT,LIEN=TEST
.S RESULT=$$GET1^DIQ(9000010.09,TEST,.04,"I")
.I $G(TARGET)]"" S @TARGET=RESULT
Q
;
HIVTAG(DFN) ;Retrieve HIV/AIDS Diagnostic Tag Information
N DCIEN,TAGIEN,TAG,TAGDT
S TAG=""
S DCIEN=$O(^BQI(90506.2,"B","HIV/AIDS",""))
I DCIEN'="" D
. S TAGIEN=$O(^BQIREG("C",DFN,DCIEN,""))
. I TAGIEN'="" D
.. S TAG=$$GET1^DIQ(90509,TAGIEN_",",.03,"E")
.. S TAG=$$LOWER^VALM1(TAG) ;Change to mixed case
.. S TAGDT=$$GET1^DIQ(90509,TAGIEN_",",.04,"I")
.. I TAGDT S TAG=TAG_" "_$$FMTE^XLFDT(TAGDT\1,"5Z")
Q TAG
;
XIT ; QUIT POINT
Q
BKMVSUP6 ;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
+1 WRITE @IOF
+2 ;I PAGE=1 S $X=0
+3 ;E W @IOF
+4 WRITE !?1,$$CONF(""),!?(IOM-41\2),"****** HMS PATIENT CARE SUPPLEMENT ******"
+5 WRITE !!?1,"Report Date: ",XNOW,?69,"Page: ",PAGE,!!
+6 QUIT
+7 ;
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 ;
CONF(END) ; EP - Print confidential message
+1 ; END is set if final page and ending message is being printed.
+2 NEW X,Y,TIM,AP,HDR
+3 SET Y=$$FMTE^XLFDT($$NOW^XLFDT())
SET TIM=$PIECE(Y,"@",2)
+4 SET AP="AM"
IF +TIM=12
SET AP="PM"
+5 IF +TIM>12
SET TIM=TIM-12_":"_$PIECE(TIM,":",2)
SET AP="PM"
SET TIM=TIM_" "_AP
+6 ; ***** CONFIDENTIAL PATIENT INFORMATION -- DATE/TIME **************
+7 SET HDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,"5Z")_" "_$JUSTIFY(TIM,9)_" ["_$PIECE(^VA(200,DUZ,0),U,2)_"]"
+8 SET X=""
SET $PIECE(X,"*",((IOM-6-$LENGTH(HDR))\2)+1)="*"
+9 SET HDR=$SELECT($GET(END):$EXTRACT("**** END *",$LENGTH(X)-4,12),1:X)_" "_HDR_" "_X
+10 QUIT HDR
+11 ;
GETALL(DFN) ; EP - Gather patient information
+1 ; Code taken from BKMVC6 but revised to limit search to Problem List and to capture problem status
+2 NEW IENDA0,IENDA,IENS,TARGET,HTARGET
+3 NEW ATAX,ATAX1,STAT,OTHERDT,DATE,ICD9,POVDATE,REVDATE,VPOV
+4 KILL ICD9S
+5 ; DX.1
SET ATAX=$ORDER(^ATXAX("B","BKMV AIDS DEF ILL DXS",""))
+6 ; DX.8
SET ATAX1=$ORDER(^ATXAX("B","BKMV HIV OPP INF DXS",""))
+7 ;
+8 SET VPOV=""
+9 FOR
SET VPOV=$ORDER(^AUPNPROB("AC",DFN,VPOV))
IF VPOV=""
QUIT
Begin DoDot:1
+10 SET IENS=$$IENS^DILF(VPOV)
+11 SET POVDATE=$$PROB^BKMVUTL(IENS)
+12 IF POVDATE'?1.N
QUIT
+13 SET REVDATE=9999999-POVDATE
+14 SET ICD9=$PIECE($GET(^AUPNPROB(VPOV,0)),"^",1)
+15 IF ICD9=""
QUIT
+16 IF $$PATCH^XPDUTL("ATX*5.1*11")
IF $$ICD^ATXAPI(ICD9,ATAX,9)=0
IF $$ICD^ATXAPI(ICD9,ATAX1,9)=0
QUIT
+17 IF '$TEST
IF $$ICD^BKMIXX5(ICD9,ATAX,9)=0
IF $$ICD^BKMIXX5(ICD9,ATAX1,9)=0
QUIT
+18 SET NAR=$$GET1^DIQ(9000011,IENS,.05,"E")
+19 SET STAT=$$GET1^DIQ(9000011,IENS,.12,"E")
+20 ;ICD9S(REVDATE,ICD9)=STAT_U_NAR
SET DATE=REVDATE
SET OTHERDT=""
+21 ;List date entered/last modified if different from date of onset
+22 IF POVDATE'=$$GET1^DIQ(9000011,IENS,.13,"I")
Begin DoDot:2
+23 ;N OTHERDT
+24 SET OTHERDT=$$GET1^DIQ(9000011,IENS,.13,"I")
+25 ;I OTHERDT="" S OTHERDT=$$GET1^DIQ(9000011,IENS,.03,"I")
+26 IF POVDATE=OTHERDT!(OTHERDT="")
QUIT
+27 SET DATE=9999999-OTHERDT
+28 ;S ICD9S(REVDATE,ICD9)=STAT_U_NAR_U_OTHERDT
End DoDot:2
+29 IF OTHERDT=POVDATE
SET POVDATE=""
+30 SET ICD9S(DATE,ICD9)=STAT_U_NAR_U_POVDATE
End DoDot:1
+31 QUIT
+32 ;
LIPID(DFN) ; EP - Retrieve Lipid taxonomies
+1 NEW LAST,GLOBAL
+2 NEW CPTTAX,LOINTAX,SITETAX
+3 SET LINE=" Lipid Profile:"
+4 ;D UPD^BKMVSUP
+5 KILL BKMT("LIP"),BKMT("LIPID")
+6 SET GLOBAL="BKMT(""LIP"",VSTDT,TEST,""LAB"")"
+7 SET CPTTAX="BGP LIPID PROFILE CPTS"
+8 SET LOINTAX="BGP LIPID PROFILE LOINC CODES"
+9 SET SITETAX="DM AUDIT LIPID PROFILE TAX"
+10 DO LIPPRO(LOINTAX,DFN,"","",GLOBAL)
+11 DO LIPPRO(SITETAX,DFN,"","",GLOBAL)
+12 DO CPTTAX^BKMIXX(DFN,CPTTAX,"","",GLOBAL)
+13 IF $DATA(BKMT("LIP"))
Begin DoDot:1
+14 SET LAST=$ORDER(BKMT("LIP",""),-1)
+15 MERGE BKMT("LIPID",LAST)=BKMT("LIP",LAST)
KILL BKMT("LIP")
+16 DO LTAXPRT^BKMVSUP1("LIPID",1000,1)
End DoDot:1
QUIT
+17 SET GLOBAL="BKMT(""LIPID"",VSTDT,TEST,""LAB"")"
+18 DO REFUSAL^BKMIXX2(DFN,60,LOINTAX,"","",GLOBAL)
+19 DO REFUSAL^BKMIXX2(DFN,60,SITETAX,"","",GLOBAL)
+20 ; Print results
+21 DO LTAXPRT^BKMVSUP1("LIPID",1,1,1)
+22 IF LINE'=""
DO UPD^BKMVSUP
+23 QUIT
LIPPRO(TAX,DFN,EDATE,SDATE,TARGET) ; EP
+1 ; Get lab result associated with a lipid profile for a patient
+2 ;
+3 NEW RESULT,LAB,LB,IEN,TEST,VISIT,VSTDT
+4 SET RESULT=""
+5 DO BLDTAX^BKMIXX5(TAX,"LAB")
+6 SET LAB=""
+7 ;I $O(^LAB(60,LAB,2)) D
FOR
SET LAB=$ORDER(LAB(LAB))
IF LAB=""
QUIT
Begin DoDot:1
+8 SET IEN=0
+9 FOR
SET IEN=$ORDER(^LAB(60,LAB,2,IEN))
IF 'IEN
QUIT
SET LB=$GET(^(IEN,0))
IF LB'=""
SET LAB(LB)=""
End DoDot:1
+10 ;,LDATE=$G(LDATE,""),LIEN=$G(LIEN,"")
SET TEST=""
+11 FOR
SET TEST=$ORDER(^AUPNVLAB("AC",DFN,TEST),-1)
IF TEST=""
QUIT
Begin DoDot:1
+12 SET LAB=$$GET1^DIQ(9000010.09,TEST,.01,"I")
+13 IF LAB=""
QUIT
+14 IF '$DATA(LAB(LAB))
QUIT
+15 SET VISIT=$$GET1^DIQ(9000010.09,TEST,.03,"I")
+16 SET VSTDT=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
IF VSTDT=""
QUIT
+17 IF $GET(SDATE)'=""
IF (VSTDT<SDATE)
QUIT
+18 IF $GET(EDATE)'=""
IF (VSTDT\1>EDATE)
QUIT
+19 ;I VSTDT>LDATE S LDATE=VSTDT,LIEN=TEST
+20 ;I VSTDT=LDATE,TEST>LIEN S LDATE=VSTDT,LIEN=TEST
+21 SET RESULT=$$GET1^DIQ(9000010.09,TEST,.04,"I")
+22 IF $GET(TARGET)]""
SET @TARGET=RESULT
End DoDot:1
+23 QUIT
+24 ;
HIVTAG(DFN) ;Retrieve HIV/AIDS Diagnostic Tag Information
+1 NEW DCIEN,TAGIEN,TAG,TAGDT
+2 SET TAG=""
+3 SET DCIEN=$ORDER(^BQI(90506.2,"B","HIV/AIDS",""))
+4 IF DCIEN'=""
Begin DoDot:1
+5 SET TAGIEN=$ORDER(^BQIREG("C",DFN,DCIEN,""))
+6 IF TAGIEN'=""
Begin DoDot:2
+7 SET TAG=$$GET1^DIQ(90509,TAGIEN_",",.03,"E")
+8 ;Change to mixed case
SET TAG=$$LOWER^VALM1(TAG)
+9 SET TAGDT=$$GET1^DIQ(90509,TAGIEN_",",.04,"I")
+10 IF TAGDT
SET TAG=TAG_" "_$$FMTE^XLFDT(TAGDT\1,"5Z")
End DoDot:2
End DoDot:1
+11 QUIT TAG
+12 ;
XIT ; QUIT POINT
+1 QUIT
