BTIUPV2 ; IHS/MSC/MGH - Problem Objects ;16-Aug-2016 12:00;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1014,1016,1017**;MAR 20, 2013;Build 7
;4/13/13
;IHS/MSC/MGH Patch 1016 added normal/abnormal qualifier
;
Q
VPOV(TARGET) ; returns diagnoses for current vuecentric visit context
;I $T(GETVAR^CIAVMEVT)="" S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)
NEW VST,I,X,CNT,RESULT
S VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
I VST="" S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
S X="BEHOENCX" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^BEHOENCX(DFN,VST) I VST<1 S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
D GETPOV(.RESULT,VST)
;
K @TARGET S CNT=0
S I=0 F S I=$O(RESULT(I)) Q:'I D
.S CNT=CNT+1
.S @TARGET@(CNT,0)=RESULT(I)
I 'CNT S @TARGET@(1,0)="No Diagnoses Found"
Q "~@"_$NA(@TARGET)
;
GETPOV(RETURN,VIEN) ;return every diagnosis for current visit
; VISIT=Visit IEN
;
NEW IEN,AIEN,FNUM,STAT,STRING,CNT,BTIU,LINE,ASTHMA,PCNT,CODE,PAT,CON,NARR,IEN2,Q,ARRAY,ENTER,SNO
K RETURN
;
S IEN=0 F S IEN=$O(^AUPNVPOV("AD",VIEN,IEN)) Q:'IEN D
. S ASTHMA=0
. S NARR=$$GET1^DIQ(9000010.07,IEN,.04)
. I $P(NARR,"|",1)["*" S NARR=$P(NARR,"|",2)
. I $P(NARR,"|",2)=" " S NARR=$P(NARR,"|",1)
. S STAT=$$GET1^DIQ(9000010.07,IEN,.12,"I")
. S ENTER=$$GET1^DIQ(9000010.07,IEN,1216,"I")
. S ARRAY(STAT,ENTER,NARR,IEN)=""
S STAT="",IEN=0
F S STAT=$O(ARRAY(STAT)) Q:STAT="" D
.S ENTER="" F S ENTER=$O(ARRAY(STAT,ENTER)) Q:ENTER="" D
..S NARR="" F S NARR=$O(ARRAY(STAT,ENTER,NARR)) Q:NARR="" D
...S IEN=0 S IEN=$O(ARRAY(STAT,ENTER,NARR,IEN)) Q:IEN="" D ;Only get the first one
.... S CNT=$G(CNT)+1,PCNT=$G(PCNT)+1
.... K BTIU D ENP^XBDIQ1(9000010.07,IEN,".01:.29;1102","BTIU(","IE")
.... S LINE=""
.... I (BTIU(.12)="PRIMARY") S LINE=" [P] " ;mark if primary dx
.... S CODE=$G(BTIU(.01))
.... S SNO=$G(BTIU(1102))
.... S ASTHMA=$$CHECK^BGOASLK(CODE,SNO)
.... I +ASTHMA D
..... S PAT=BTIU(.02,"I")
..... S CON=$$ACONTROL^BTIULO5(PAT)
..... I CON'="" S LINE=LINE_" Control: "_CON
.... F I=.06,.05,.09,.13,.11,.29 D ;check for other fields
..... I (I=.09),BTIU(.09)]"" S LINE=LINE_"; "_$$ECODE^BTIULO5(IEN) Q
..... I BTIU(I)]"" S LINE=LINE_"; "_BTIU(I)
.... S RETURN(CNT)=$J(PCNT,2)_") "_NARR_LINE
.... ;Return qualifiers
....F X=13,17,18,14 D
.....S STRING=""
.....S IEN2=0 F S IEN2=$O(^AUPNVPOV(IEN,X,IEN2)) Q:'+IEN2 D
......S Q=""
......S FNUM=$S(X=13:9000010.0713,X=17:9000010.0717,X=18:9000010.0718,X=14:9000010.0714)
......S AIEN=IEN2_","_IEN_","
......S Q=$$GET1^DIQ(FNUM,AIEN,.01)
......S Q=$P($$CONC^BSTSAPI(Q_"^^^1"),U,4)
......S STRING=$S(STRING="":Q,1:STRING_" "_Q)
.....I STRING'="" D
......S CNT=CNT+1
......S RETURN(CNT)=" "_STRING
Q
;
VOB(DFN,PRIEN,VIEN,CNT) ; V OB notes by date
N INVDT,IEN,EDATE,SIGN,STAT,FOUND,SDATE,EIE,SIGNDT,VSCNT
S FOUND=0,SDATE="",VSCNT=0
S VIEN=$G(VIEN)
S INVDT="" F S INVDT=$O(^AUPNVOB("AE",DFN,PRIEN,INVDT)) Q:INVDT=""!(FOUND=1) D
.I +SDATE,SDATE'=$P(INVDT,".",1) S FOUND=1
.S IEN="" F S IEN=$O(^AUPNVOB("AE",DFN,PRIEN,INVDT,IEN)) Q:IEN="" D
..S EIE=$$GET1^DIQ(9000010.43,IEN,.06,"I")
..Q:EIE=1
..S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
..Q:STAT="D"
..Q:+VIEN&(VIEN'=$P($G(^AUPNVOB(IEN,0)),U,3))
..I VSCNT=0 S VSCNT=VSCNT+1 D ADD(" -OB NOTE:")
..S EDATE=9999999-INVDT
..S EDATE=$$FMTE^XLFDT($P(EDATE,".",1),5)
..S SIGNDT=$$GET1^DIQ(9000010.43,IEN,.05,"I")
..S SIGNDT=$$FMTE^XLFDT($P(SIGNDT,".",1),5)
..S SIGN=$$GET1^DIQ(9000010.43,IEN,.04,"E")
..D TEXT2(IEN)
Q
ADD(DATA) ;add to list
S CNT=CNT+1
S @TARGET@(CNT,0)=DATA
Q
TEXT2(IEN) ;do the text
N TXTIEN,WRAP,TXT,PRNT2,PRNT
S (PRNT,PRNT2,WRAP)=""
S TXTIEN=0 F S TXTIEN=$O(^AUPNVOB(IEN,11,TXTIEN)) Q:'+TXTIEN D
.S TXT=$G(^AUPNVOB(IEN,11,TXTIEN,0))
.S PRNT=PRNT2_TXT S PRNT2=""
.I $L(PRNT)>500 S PRNT2=$E(PRNT,501,$L(PRNT))
.D WRAP^BTIUPV1(.WRAP,PRNT,70)
;Process each wrapped line
I $D(WRAP)>1 D PROC(.WRAP)
Q
PROC(WRAP) ;Process the word wrap
N I,LINE
F I=1:1:WRAP D
.I I=WRAP D
..I $L(WRAP(I))<45 D
...S LINE=" "_$G(WRAP(I))_" ("_SIGNDT_" by "_SIGN_")"
...D ADD(LINE)
..E D
...D ADD(" "_$G(WRAP(I)))
...D ADD(" ("_SIGNDT_" by "_SIGN_")")
.E D ADD(" "_$G(WRAP(I)))
Q
BTIUPV2 ; IHS/MSC/MGH - Problem Objects ;16-Aug-2016 12:00;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1014,1016,1017**;MAR 20, 2013;Build 7
+2 ;4/13/13
+3 ;IHS/MSC/MGH Patch 1016 added normal/abnormal qualifier
+4 ;
+5 QUIT
VPOV(TARGET) ; returns diagnoses for current vuecentric visit context
+1 ;I $T(GETVAR^CIAVMEVT)="" S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)
+2 NEW VST,I,X,CNT,RESULT
+3 SET VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
+4 IF VST=""
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+5 SET X="BEHOENCX"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET VST=+$$VSTR2VIS^BEHOENCX(DFN,VST)
IF VST<1
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+6 DO GETPOV(.RESULT,VST)
+7 ;
+8 KILL @TARGET
SET CNT=0
+9 SET I=0
FOR
SET I=$ORDER(RESULT(I))
IF 'I
QUIT
Begin DoDot:1
+10 SET CNT=CNT+1
+11 SET @TARGET@(CNT,0)=RESULT(I)
End DoDot:1
+12 IF 'CNT
SET @TARGET@(1,0)="No Diagnoses Found"
+13 QUIT "~@"_$NAME(@TARGET)
+14 ;
GETPOV(RETURN,VIEN) ;return every diagnosis for current visit
+1 ; VISIT=Visit IEN
+2 ;
+3 NEW IEN,AIEN,FNUM,STAT,STRING,CNT,BTIU,LINE,ASTHMA,PCNT,CODE,PAT,CON,NARR,IEN2,Q,ARRAY,ENTER,SNO
+4 KILL RETURN
+5 ;
+6 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNVPOV("AD",VIEN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+7 SET ASTHMA=0
+8 SET NARR=$$GET1^DIQ(9000010.07,IEN,.04)
+9 IF $PIECE(NARR,"|",1)["*"
SET NARR=$PIECE(NARR,"|",2)
+10 IF $PIECE(NARR,"|",2)=" "
SET NARR=$PIECE(NARR,"|",1)
+11 SET STAT=$$GET1^DIQ(9000010.07,IEN,.12,"I")
+12 SET ENTER=$$GET1^DIQ(9000010.07,IEN,1216,"I")
+13 SET ARRAY(STAT,ENTER,NARR,IEN)=""
End DoDot:1
+14 SET STAT=""
SET IEN=0
+15 FOR
SET STAT=$ORDER(ARRAY(STAT))
IF STAT=""
QUIT
Begin DoDot:1
+16 SET ENTER=""
FOR
SET ENTER=$ORDER(ARRAY(STAT,ENTER))
IF ENTER=""
QUIT
Begin DoDot:2
+17 SET NARR=""
FOR
SET NARR=$ORDER(ARRAY(STAT,ENTER,NARR))
IF NARR=""
QUIT
Begin DoDot:3
+18 ;Only get the first one
SET IEN=0
SET IEN=$ORDER(ARRAY(STAT,ENTER,NARR,IEN))
IF IEN=""
QUIT
Begin DoDot:4
+19 SET CNT=$GET(CNT)+1
SET PCNT=$GET(PCNT)+1
+20 KILL BTIU
DO ENP^XBDIQ1(9000010.07,IEN,".01:.29;1102","BTIU(","IE")
+21 SET LINE=""
+22 ;mark if primary dx
IF (BTIU(.12)="PRIMARY")
SET LINE=" [P] "
+23 SET CODE=$GET(BTIU(.01))
+24 SET SNO=$GET(BTIU(1102))
+25 SET ASTHMA=$$CHECK^BGOASLK(CODE,SNO)
+26 IF +ASTHMA
Begin DoDot:5
+27 SET PAT=BTIU(.02,"I")
+28 SET CON=$$ACONTROL^BTIULO5(PAT)
+29 IF CON'=""
SET LINE=LINE_" Control: "_CON
End DoDot:5
+30 ;check for other fields
FOR I=.06,.05,.09,.13,.11,.29
Begin DoDot:5
+31 IF (I=.09)
IF BTIU(.09)]""
SET LINE=LINE_"; "_$$ECODE^BTIULO5(IEN)
QUIT
+32 IF BTIU(I)]""
SET LINE=LINE_"; "_BTIU(I)
End DoDot:5
+33 SET RETURN(CNT)=$JUSTIFY(PCNT,2)_") "_NARR_LINE
+34 ;Return qualifiers
+35 FOR X=13,17,18,14
Begin DoDot:5
+36 SET STRING=""
+37 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNVPOV(IEN,X,IEN2))
IF '+IEN2
QUIT
Begin DoDot:6
+38 SET Q=""
+39 SET FNUM=$SELECT(X=13:9000010.0713,X=17:9000010.0717,X=18:9000010.0718,X=14:9000010.0714)
+40 SET AIEN=IEN2_","_IEN_","
+41 SET Q=$$GET1^DIQ(FNUM,AIEN,.01)
+42 SET Q=$PIECE($$CONC^BSTSAPI(Q_"^^^1"),U,4)
+43 SET STRING=$SELECT(STRING="":Q,1:STRING_" "_Q)
End DoDot:6
+44 IF STRING'=""
Begin DoDot:6
+45 SET CNT=CNT+1
+46 SET RETURN(CNT)=" "_STRING
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+47 QUIT
+48 ;
VOB(DFN,PRIEN,VIEN,CNT) ; V OB notes by date
+1 NEW INVDT,IEN,EDATE,SIGN,STAT,FOUND,SDATE,EIE,SIGNDT,VSCNT
+2 SET FOUND=0
SET SDATE=""
SET VSCNT=0
+3 SET VIEN=$GET(VIEN)
+4 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVOB("AE",DFN,PRIEN,INVDT))
IF INVDT=""!(FOUND=1)
QUIT
Begin DoDot:1
+5 IF +SDATE
IF SDATE'=$PIECE(INVDT,".",1)
SET FOUND=1
+6 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVOB("AE",DFN,PRIEN,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+7 SET EIE=$$GET1^DIQ(9000010.43,IEN,.06,"I")
+8 IF EIE=1
QUIT
+9 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+10 IF STAT="D"
QUIT
+11 IF +VIEN&(VIEN'=$PIECE($GET(^AUPNVOB(IEN,0)),U,3))
QUIT
+12 IF VSCNT=0
SET VSCNT=VSCNT+1
DO ADD(" -OB NOTE:")
+13 SET EDATE=9999999-INVDT
+14 SET EDATE=$$FMTE^XLFDT($PIECE(EDATE,".",1),5)
+15 SET SIGNDT=$$GET1^DIQ(9000010.43,IEN,.05,"I")
+16 SET SIGNDT=$$FMTE^XLFDT($PIECE(SIGNDT,".",1),5)
+17 SET SIGN=$$GET1^DIQ(9000010.43,IEN,.04,"E")
+18 DO TEXT2(IEN)
End DoDot:2
End DoDot:1
+19 QUIT
ADD(DATA) ;add to list
+1 SET CNT=CNT+1
+2 SET @TARGET@(CNT,0)=DATA
+3 QUIT
TEXT2(IEN) ;do the text
+1 NEW TXTIEN,WRAP,TXT,PRNT2,PRNT
+2 SET (PRNT,PRNT2,WRAP)=""
+3 SET TXTIEN=0
FOR
SET TXTIEN=$ORDER(^AUPNVOB(IEN,11,TXTIEN))
IF '+TXTIEN
QUIT
Begin DoDot:1
+4 SET TXT=$GET(^AUPNVOB(IEN,11,TXTIEN,0))
+5 SET PRNT=PRNT2_TXT
SET PRNT2=""
+6 IF $LENGTH(PRNT)>500
SET PRNT2=$EXTRACT(PRNT,501,$LENGTH(PRNT))
+7 DO WRAP^BTIUPV1(.WRAP,PRNT,70)
End DoDot:1
+8 ;Process each wrapped line
+9 IF $DATA(WRAP)>1
DO PROC(.WRAP)
+10 QUIT
PROC(WRAP) ;Process the word wrap
+1 NEW I,LINE
+2 FOR I=1:1:WRAP
Begin DoDot:1
+3 IF I=WRAP
Begin DoDot:2
+4 IF $LENGTH(WRAP(I))<45
Begin DoDot:3
+5 SET LINE=" "_$GET(WRAP(I))_" ("_SIGNDT_" by "_SIGN_")"
+6 DO ADD(LINE)
End DoDot:3
+7 IF '$TEST
Begin DoDot:3
+8 DO ADD(" "_$GET(WRAP(I)))
+9 DO ADD(" ("_SIGNDT_" by "_SIGN_")")
End DoDot:3
End DoDot:2
+10 IF '$TEST
DO ADD(" "_$GET(WRAP(I)))
End DoDot:1
+11 QUIT
