BTIUPV1 ; IHS/MSC/MGH - Problem Objects ;27-Apr-2016 12:29;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1012,1013,1014,1016**;MAR 20, 2013;Build 10
;4/13/13
;IHS/MSC/MGH Patch 1016 added normal/abnormal qualifier
;
Q
;Get the problems associated with the last visit and only the latest or items updated.
VST(DFN,TARGET) ;Problems updated this visit
N PROB,CNT,RET,PRIEN,I,VST,FOUND
S FOUND=0,CNT=0
K @TARGET
S INVDT="" F S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT)) Q:'+INVDT!(FOUND=1) D
.S VIEN="" F S VIEN=$O(^AUPNVSIT("AA",DFN,INVDT,VIEN)) Q:'+VIEN!(FOUND=1) D
..I "AIH"[$P($G(^AUPNVSIT(VIEN,0)),U,7) D
...D GETPRB(VIEN)
I CNT=0 S @TARGET@(1,0)="No Problems used as POVs in this visit record"
Q "~@"_$NA(@TARGET)
;
GETPRB(VIEN) ;Get problems to update
S PRIEN=0
F S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN D
.;Check for which statuses to return
.S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
.Q:STAT="D"
.I $D(^AUPNPROB(PRIEN,14,"B",VIEN)) S FOUND=1 D GETDATA(PRIEN,VIEN)
Q
GETDATA(PRIEN,VIEN) ;Get data for the problem
N NARR,STATUS,ICD
S NARR=$$GET1^DIQ(9000011,PRIEN,.05)
D ADD("Problem: "_NARR)
S STATUS=$$GET1^DIQ(9000011,PRIEN,.12)
S ICD=$$GET1^DIQ(9000011,PRIEN,.01)
D ADD(" -Mapped ICD:"_ICD_" Status: "_STATUS)
D QUAL(PRIEN,.CNT)
D FINDCP(PRIEN,"G",.CNT)
D FINDCP(PRIEN,"P",.CNT)
D VIDT(PRIEN,VIEN,.CNT)
D ADD("")
Q
ADD(DATA) ;add to list
S CNT=CNT+1
S @TARGET@(CNT,0)=DATA
Q
QUAL(IEN,CNT) ;Get any qualifiers for this problem
N AIEN,IEN2,BY,WHEN,X,FNUM,Q,QUAL
S CNT=$G(CNT)
I $D(^AUPNPROB(IEN,13))!($D(^AUPNPROB(IEN,17)))!($D(^AUPNPROB(IEN,18))) D ADD(" -QUALIFIERS:")
F X=13,17,18 D
.S QUAL=""
.S FNUM=$S(X=13:9000011.13,X=17:9000011.17,X=18:9000011.18)
.S IEN2=0 F S IEN2=$O(^AUPNPROB(IEN,X,IEN2)) Q:'+IEN2 D
..S AIEN=IEN2_","_IEN_","
..S Q=$$GET1^DIQ(FNUM,AIEN,.01)
..S Q=$$CONCEPT^BGOPAUD(Q)
..I QUAL="" S QUAL=Q
..E S QUAL=QUAL_" "_Q
.I QUAL'="" D ADD(" "_QUAL)
Q
FINDCP(PRIEN,TYPE,CNT) ;Find a care plan
N INVDT,STATUS,EDATE,IEN,NODE,PRV,PRVNM,CPIEN,SIGN,NODE,Z,DONE,SIEN,PCNT,ARRAY
S DONE=0,PCNT=0,ARRAY=""
S CPIEN="" F S CPIEN=$O(^AUPNCPL("APT",PRIEN,TYPE,CPIEN)) Q:CPIEN="" D
.S SIEN=$C(0) S SIEN=$O(^AUPNCPL(CPIEN,11,SIEN),-1)
.S STATUS=$P($G(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)
.Q:STATUS'="A"
.S INVDT=9999999-$P($G(^AUPNCPL(CPIEN,0)),U,5)
.S ARRAY(INVDT,CPIEN)=""
Q:$D(ARRAY)<10
S INVDT="" F S INVDT=$O(ARRAY(INVDT)) Q:'+INVDT D
.S CPIEN="" F S CPIEN=$O(ARRAY(INVDT,CPIEN)) Q:'+CPIEN D
..I PCNT=0 S PCNT=1 D
...I TYPE="P" D ADD(" -CARE PLANS:")
...I TYPE="G" D ADD(" -GOALS:")
..S NODE=$G(^AUPNCPL(CPIEN,0))
..S PRV=$$GET1^DIQ(9000092,CPIEN,.03,"I")
..S PRVNM=$$GET1^DIQ(9000092,CPIEN,.03)
..S SIGNDT=$$GET1^DIQ(9000092,CPIEN,.08,"I")
..S SIGNDT=$$FMTE^XLFDT($P(SIGNDT,".",1),5)
..S SIGN=$$GET1^DIQ(9000092,CPIEN,.07)
..S EDATE=$$GET1^DIQ(9000092,CPIEN,.05)
..Q:SIGN=""&(PRV'=DUZ)
..D TEXT(TYPE,CPIEN)
Q
TEXT(TYPE,IEN) ;do the text
N TXTIEN,TXT,PRNT,PRNT2,WRAP,LINE
S (PRNT,PRNT2,WRAP)=""
S TXTIEN=0 F S TXTIEN=$O(^AUPNCPL(IEN,12,TXTIEN)) Q:'+TXTIEN D
.S TXT=$G(^AUPNCPL(IEN,12,TXTIEN,0))
.S PRNT=PRNT2_TXT S PRNT2=""
.I $L(PRNT)>500 S PRNT2=$E(PRNT,501,$L(PRNT))
.D WRAP(.WRAP,PRNT,70)
;Process each wrapped line
I $D(WRAP)>1 D PROC(.WRAP)
Q
VIDT(PRIEN,VIEN,CNT) ; Visit Instructions by date
;Get last date entries for each date of visit instruction
N INVDT,IEN,EDATE,SIGN,STAT,FOUND,SDATE,EIE,SIGNDT
S VCNT=0,FOUND=0,SDATE="",VSCNT=0
S VIEN=$G(VIEN)
S INVDT="" F S INVDT=$O(^AUPNVVI("AE",DFN,PRIEN,INVDT)) Q:INVDT=""!(FOUND=1) D
.I +SDATE,SDATE'=$P(INVDT,".",1) S FOUND=1
.S IEN="" F S IEN=$O(^AUPNVVI("AE",DFN,PRIEN,INVDT,IEN)) Q:IEN="" D
..S EIE=$$GET1^DIQ(9000010.58,IEN,.06,"I")
..Q:EIE=1
..S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
..Q:STAT="D"
..Q:+VIEN&(VIEN'=$P($G(^AUPNVVI(IEN,0)),U,3))
..I VSCNT=0 S VSCNT=VSCNT+1 D ADD(" -INSTRUCTIONS:")
..S EDATE=9999999-INVDT
..S EDATE=$$FMTE^XLFDT($P(EDATE,".",1),5)
..S SIGNDT=$$GET1^DIQ(9000010.58,IEN,.05,"I")
..S SIGNDT=$$FMTE^XLFDT($P(SIGNDT,".",1),5)
..S SIGN=$$GET1^DIQ(9000010.58,IEN,.04,"E")
..D TEXT2(IEN)
..;D ADD(" ("_EDATE_" by "_SIGN_")")
Q
;
TEXT2(IEN) ;do the text
N TXTIEN,WRAP,TXT,PRNT2,PRNT
S (PRNT,PRNT2,WRAP)=""
S TXTIEN=0 F S TXTIEN=$O(^AUPNVVI(IEN,11,TXTIEN)) Q:'+TXTIEN D
.S TXT=$G(^AUPNVVI(IEN,11,TXTIEN,0))
.S PRNT=PRNT2_TXT S PRNT2=""
.;MSC/MGH P1014 matched to TEXT
.I $L(PRNT)>500 S PRNT2=$E(PRNT,501,$L(PRNT))
.D WRAP(.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
VTRDT(PRIEN,VIEN,CNT) ; Visit Treatment/Regimens by date
;Get last (n) date entries for each problem of treatments
;Default is 99
N INVDT,IEN,SNO1,VCNT,EDATE,STAT,IN,OUT,ARR,X,TXT,FOUND,PROB,PRTCT
S VIEN=$G(VIEN)
S FOUND=0,PRTCT=0
S INVDT="" F S INVDT=$O(^AUPNVTXR("AF",DFN,INVDT)) Q:INVDT=""!(FOUND=1) D
.S SNO="" F S SNO=$O(^AUPNVTXR("AF",DFN,INVDT,SNO)) Q:SNO="" D
..S IEN="" F S IEN=$O(^AUPNVTXR("AF",DFN,INVDT,SNO,IEN)) Q:IEN="" D
...S PROB=$P($G(^AUPNVTXR(IEN,0)),U,4)
...Q:PROB'=PRIEN
...S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
...Q:STAT="D"
...Q:+VIEN&(VIEN'=$P($G(^AUPNVTXR(IEN,0)),U,3))
...S FOUND=1
...I PRTCT=0 S PRTCT=1 D ADD(" -TREATMENTS:")
...S EDATE=9999999-INVDT
...S EDATE=$$FMTE^XLFDT(EDATE,5)
...;D ADD(" -Treatment/Regimen Date: "_EDATE)
...S SNO1=$P($G(^AUPNVTXR(IEN,0)),U,1)
...S IN=SNO1_"^^^1",OUT="ARR"
...S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
...I X>0 D
....S TXT=ARR(1,"PRE","TRM")
....D ADD(" "_TXT)
Q
REFDT(PRIEN,VIEN,CNT) ; V referrals by date
;Get last date entries for each problem of visit referrals
N INVDT,IEN,VCNT,EDATE,STAT,SNO,IN,OUT,ARR,X,TXT,FOUND,PRTCT,ARRAY
S FOUND=0,PRTCT=0
S SNO="" F S SNO=$O(^AUPNVREF("AE",DFN,SNO)) Q:SNO="" D
.S INVDT="" F S INVDT=$O(^AUPNVREF("AE",DFN,SNO,INVDT)) Q:INVDT="" D
..S IEN="" F S IEN=$O(^AUPNVREF("AE",DFN,SNO,INVDT,IEN)) Q:IEN="" D
...S PROB=$P($G(^AUPNVREF(IEN,0)),U,4)
...Q:PROB'=PRIEN
...S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
...Q:STAT="D"
...Q:+VIEN&(VIEN'=$P($G(^AUPNVREF(IEN,0)),U,3))
...S ARRAY(INVDT,PRIEN,IEN)=""
I $D(ARRAY)>10 D ADD(" -REFERRALS:")
S INVDT="" F S INVDT=$O(ARRAY(INVDT)) Q:INVDT=""!(FOUND=1) D
.S EDATE=9999999-INVDT
.S EDATE=$P($$FMTE^XLFDT(EDATE,5),".")
.;D ADD(" -Referral Date: "_EDATE)
.S PRIEN="" F S PRIEN=$O(ARRAY(INVDT,PRIEN)) Q:PRIEN="" D
..S IEN="" F S IEN=$O(ARRAY(INVDT,PRIEN,IEN)) Q:IEN="" D
...S SNO=$P($G(^AUPNVREF(IEN,0)),U,1)
...S X=$$CONC^BSTSAPI(SNO_"^^^1")
...I +X D
....S TXT=$P(X,U,4)
....D ADD(" "_TXT)
....S PRV=$$GET1^DIQ(9000010.59,IEN,1202)
....I PRV="" S PRV=$$GET1^DIQ(9000010.59,IEN,1204)
....;D ADD(" -Provider: "_PRV)
Q
EDU(PRIEN,VIEN,CNT) ;V education by date
;Get last date entries for each problem of visit education
N EDU,PRCT
S PRCT=0
S EDU="" F S EDU=$O(^AUPNVPED("AD",VIEN,EDU)) Q:EDU="" D
.I $P($G(^AUPNVPED(EDU,11)),U,3)=PRIEN D
..I PRCT=0 S PRCT=1 D ADD(" -EDUCATION:")
..D ADD(" "_$$GET1^DIQ(9000010.16,EDU,.01))
D ADD("")
Q
CONSULT(PRIEN,DFN,CNT) ;FIND consults
N DATA,STR,CT2,SER,SDATE,SSTAT
S DATA=""
S NUM=99999
D GETCON^BGOVTR(.DATA,DFN,PRIEN,NUM,"")
Q:'$D(^TMP("BGOVIN",$J))
D ADD("")
D ADD(" -CONSULTS:")
S CT2=0
F S CT2=$O(^TMP("BGOVIN",$J,CT2)) Q:'+CT2 D
.S STR=$G(^TMP("BGOVIN",$J,CT2))
.S SER=$P(STR,U,2),SDATE=$P(STR,U,3),SSTAT=$P(STR,U,4)
.D ADD(" "_SER)
.D ADD(" Date Ordered: "_SDATE_" Status: "_SSTAT)
Q
;Get the problems associated with multiple visits and only the latest or items updated.
MVST(DFN,TARGET,NUM) ;Problems updated this visit
N PROB,CNT,RET,PRIEN,I,VST,FOUND,VCNT
S FOUND=0,CNT=0,VCNT=0
I $G(NUM)="" S NUM=999
K @TARGET
S INVDT="" F S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT)) Q:'+INVDT!(NUM>VCNT) D
.S VIEN="" F S VIEN=$O(^AUPNVSIT("AA",DFN,INVDT,VIEN)) Q:'+VIEN!(NUM>VCNT) D
..I "AIH"[$P($G(^AUPNVSIT(VIEN,0)),U,7) D
...S VCNT=VCNT+1
...D GETPRB(VIEN)
I CNT=0 S @TARGET@(1,0)="No Problems used as POVs in this visit record"
Q "~@"_$NA(@TARGET)
;
PBYSTAT(DFN,TARGET) ;Get problems by status
N PRIEN,STAT,ARRAY,CNT,STATO
S CNT=0
K @TARGET
S PRIEN="" F S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN D
.;Check for which statuses to return
.S STATO=$$GET1^DIQ(9000011,PRIEN,.12)
.I STATO="" S STATO="INACTIVE"
.S STAT=$$GET1^DIQ(9000011,PRIEN,.12,"I")
.Q:STAT="D"!(STAT="I")!(STAT="")
.S ARRAY(STATO,PRIEN)=""
S STAT="" F S STAT=$O(ARRAY(STAT)) Q:STAT="" D
.D ADD("Status: "_STAT)
.S PRIEN="" F S PRIEN=$O(ARRAY(STAT,PRIEN)) Q:PRIEN="" D
..D PRDATA(PRIEN)
..D ADD("")
I CNT=0 S @TARGET@(1,0)="No Problems for this patient"
Q "~@"_$NA(@TARGET)
PRDATA(PRIEN) ;Get data for a problem
N NARR,ICD
S NARR=$$GET1^DIQ(9000011,PRIEN,.05)
D ADD(" Problem: "_NARR)
S ICD=$$GET1^DIQ(9000011,PRIEN,.01)
D ADD(" -Mapped ICD:"_ICD)
D QUAL(PRIEN,.CNT)
D FINDCP(PRIEN,"G",.CNT)
D FINDCP(PRIEN,"P",.CNT)
Q
WRAP(OUT,TEXT,RM,IND) ;EP - Wrap the text and insert in array
;
NEW SP
;
I $G(TEXT)="" S OUT=$G(OUT)+1,OUT(OUT)="" Q
I $G(RM)="" Q
I $G(IND)="" S IND=0
S $P(SP," ",80)=" "
;
;Strip out $c(10)
S TEXT=$TR(TEXT,$C(10))
;
F I $L(TEXT)>0 D Q:$L(TEXT)=0
. NEW PIECE,SPACE,LINE
. S PIECE=$E(TEXT,1,RM)
. ;
. ;Handle Line feeds
. I PIECE[$C(13) D Q
.. NEW LINE,I
.. S LINE=$P(PIECE,$C(13)) S:LINE="" LINE=" "
.. S OUT=$G(OUT)+1,OUT(OUT)=LINE
.. F I=1:1:$L(PIECE) I $E(PIECE,I)=$C(13) Q
.. S TEXT=$E(SP,1,IND)_$$STZ($E(TEXT,I+1,9999999999))
. ;
. ;Check if line is less than right margin
. I $L(PIECE)<RM S OUT=$G(OUT)+1,OUT(OUT)=PIECE,TEXT="" Q
. ;
. ;Locate last space in line and handle if no space
. F SPACE=$L(PIECE):-1:(IND+1) I $E(PIECE,SPACE)=" " Q
. I (SPACE=(IND+1)) D S:TEXT]"" TEXT=$E(SP,1,IND)_TEXT Q
.. S LINE=PIECE,OUT=$G(OUT)+1,OUT(OUT)=LINE,TEXT=$$STZ($E(TEXT,RM+1,999999999))
. ;
. ;Handle line with space
. S LINE=$E(PIECE,1,SPACE-1),OUT=$G(OUT)+1,OUT(OUT)=LINE,TEXT=$$STZ($E(TEXT,SPACE+1,999999999))
. S:TEXT]"" TEXT=$E(SP,1,IND)_TEXT
;
Q
;
STZ(TEXT) ;EP - Strip Leading Spaces
NEW START
F START=1:1:$L(TEXT) I $E(TEXT,START)'=" " Q
Q $E(TEXT,START,9999999999)
;
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,STRING,CNT,BTIU,LINE,ASTHMA,PCNT,CODE,PAT,CON,NARR,IEN2,Q,ARRAY,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 ARRAY(NARR,IEN)=""
S NARR="",IEN=0
F S NARR=$O(ARRAY(NARR)) Q:NARR="" D
.S IEN=0 S IEN=$O(ARRAY(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
;
BTIUPV1 ; IHS/MSC/MGH - Problem Objects ;27-Apr-2016 12:29;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1012,1013,1014,1016**;MAR 20, 2013;Build 10
+2 ;4/13/13
+3 ;IHS/MSC/MGH Patch 1016 added normal/abnormal qualifier
+4 ;
+5 QUIT
+6 ;Get the problems associated with the last visit and only the latest or items updated.
VST(DFN,TARGET) ;Problems updated this visit
+1 NEW PROB,CNT,RET,PRIEN,I,VST,FOUND
+2 SET FOUND=0
SET CNT=0
+3 KILL @TARGET
+4 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVSIT("AA",DFN,INVDT))
IF '+INVDT!(FOUND=1)
QUIT
Begin DoDot:1
+5 SET VIEN=""
FOR
SET VIEN=$ORDER(^AUPNVSIT("AA",DFN,INVDT,VIEN))
IF '+VIEN!(FOUND=1)
QUIT
Begin DoDot:2
+6 IF "AIH"[$PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)
Begin DoDot:3
+7 DO GETPRB(VIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+8 IF CNT=0
SET @TARGET@(1,0)="No Problems used as POVs in this visit record"
+9 QUIT "~@"_$NAME(@TARGET)
+10 ;
GETPRB(VIEN) ;Get problems to update
+1 SET PRIEN=0
+2 FOR
SET PRIEN=$ORDER(^AUPNPROB("AC",DFN,PRIEN))
IF 'PRIEN
QUIT
Begin DoDot:1
+3 ;Check for which statuses to return
+4 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+5 IF STAT="D"
QUIT
+6 IF $DATA(^AUPNPROB(PRIEN,14,"B",VIEN))
SET FOUND=1
DO GETDATA(PRIEN,VIEN)
End DoDot:1
+7 QUIT
GETDATA(PRIEN,VIEN) ;Get data for the problem
+1 NEW NARR,STATUS,ICD
+2 SET NARR=$$GET1^DIQ(9000011,PRIEN,.05)
+3 DO ADD("Problem: "_NARR)
+4 SET STATUS=$$GET1^DIQ(9000011,PRIEN,.12)
+5 SET ICD=$$GET1^DIQ(9000011,PRIEN,.01)
+6 DO ADD(" -Mapped ICD:"_ICD_" Status: "_STATUS)
+7 DO QUAL(PRIEN,.CNT)
+8 DO FINDCP(PRIEN,"G",.CNT)
+9 DO FINDCP(PRIEN,"P",.CNT)
+10 DO VIDT(PRIEN,VIEN,.CNT)
+11 DO ADD("")
+12 QUIT
ADD(DATA) ;add to list
+1 SET CNT=CNT+1
+2 SET @TARGET@(CNT,0)=DATA
+3 QUIT
QUAL(IEN,CNT) ;Get any qualifiers for this problem
+1 NEW AIEN,IEN2,BY,WHEN,X,FNUM,Q,QUAL
+2 SET CNT=$GET(CNT)
+3 IF $DATA(^AUPNPROB(IEN,13))!($DATA(^AUPNPROB(IEN,17)))!($DATA(^AUPNPROB(IEN,18)))
DO ADD(" -QUALIFIERS:")
+4 FOR X=13,17,18
Begin DoDot:1
+5 SET QUAL=""
+6 SET FNUM=$SELECT(X=13:9000011.13,X=17:9000011.17,X=18:9000011.18)
+7 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNPROB(IEN,X,IEN2))
IF '+IEN2
QUIT
Begin DoDot:2
+8 SET AIEN=IEN2_","_IEN_","
+9 SET Q=$$GET1^DIQ(FNUM,AIEN,.01)
+10 SET Q=$$CONCEPT^BGOPAUD(Q)
+11 IF QUAL=""
SET QUAL=Q
+12 IF '$TEST
SET QUAL=QUAL_" "_Q
End DoDot:2
+13 IF QUAL'=""
DO ADD(" "_QUAL)
End DoDot:1
+14 QUIT
FINDCP(PRIEN,TYPE,CNT) ;Find a care plan
+1 NEW INVDT,STATUS,EDATE,IEN,NODE,PRV,PRVNM,CPIEN,SIGN,NODE,Z,DONE,SIEN,PCNT,ARRAY
+2 SET DONE=0
SET PCNT=0
SET ARRAY=""
+3 SET CPIEN=""
FOR
SET CPIEN=$ORDER(^AUPNCPL("APT",PRIEN,TYPE,CPIEN))
IF CPIEN=""
QUIT
Begin DoDot:1
+4 SET SIEN=$CHAR(0)
SET SIEN=$ORDER(^AUPNCPL(CPIEN,11,SIEN),-1)
+5 SET STATUS=$PIECE($GET(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)
+6 IF STATUS'="A"
QUIT
+7 SET INVDT=9999999-$PIECE($GET(^AUPNCPL(CPIEN,0)),U,5)
+8 SET ARRAY(INVDT,CPIEN)=""
End DoDot:1
+9 IF $DATA(ARRAY)<10
QUIT
+10 SET INVDT=""
FOR
SET INVDT=$ORDER(ARRAY(INVDT))
IF '+INVDT
QUIT
Begin DoDot:1
+11 SET CPIEN=""
FOR
SET CPIEN=$ORDER(ARRAY(INVDT,CPIEN))
IF '+CPIEN
QUIT
Begin DoDot:2
+12 IF PCNT=0
SET PCNT=1
Begin DoDot:3
+13 IF TYPE="P"
DO ADD(" -CARE PLANS:")
+14 IF TYPE="G"
DO ADD(" -GOALS:")
End DoDot:3
+15 SET NODE=$GET(^AUPNCPL(CPIEN,0))
+16 SET PRV=$$GET1^DIQ(9000092,CPIEN,.03,"I")
+17 SET PRVNM=$$GET1^DIQ(9000092,CPIEN,.03)
+18 SET SIGNDT=$$GET1^DIQ(9000092,CPIEN,.08,"I")
+19 SET SIGNDT=$$FMTE^XLFDT($PIECE(SIGNDT,".",1),5)
+20 SET SIGN=$$GET1^DIQ(9000092,CPIEN,.07)
+21 SET EDATE=$$GET1^DIQ(9000092,CPIEN,.05)
+22 IF SIGN=""&(PRV'=DUZ)
QUIT
+23 DO TEXT(TYPE,CPIEN)
End DoDot:2
End DoDot:1
+24 QUIT
TEXT(TYPE,IEN) ;do the text
+1 NEW TXTIEN,TXT,PRNT,PRNT2,WRAP,LINE
+2 SET (PRNT,PRNT2,WRAP)=""
+3 SET TXTIEN=0
FOR
SET TXTIEN=$ORDER(^AUPNCPL(IEN,12,TXTIEN))
IF '+TXTIEN
QUIT
Begin DoDot:1
+4 SET TXT=$GET(^AUPNCPL(IEN,12,TXTIEN,0))
+5 SET PRNT=PRNT2_TXT
SET PRNT2=""
+6 IF $LENGTH(PRNT)>500
SET PRNT2=$EXTRACT(PRNT,501,$LENGTH(PRNT))
+7 DO WRAP(.WRAP,PRNT,70)
End DoDot:1
+8 ;Process each wrapped line
+9 IF $DATA(WRAP)>1
DO PROC(.WRAP)
+10 QUIT
VIDT(PRIEN,VIEN,CNT) ; Visit Instructions by date
+1 ;Get last date entries for each date of visit instruction
+2 NEW INVDT,IEN,EDATE,SIGN,STAT,FOUND,SDATE,EIE,SIGNDT
+3 SET VCNT=0
SET FOUND=0
SET SDATE=""
SET VSCNT=0
+4 SET VIEN=$GET(VIEN)
+5 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVVI("AE",DFN,PRIEN,INVDT))
IF INVDT=""!(FOUND=1)
QUIT
Begin DoDot:1
+6 IF +SDATE
IF SDATE'=$PIECE(INVDT,".",1)
SET FOUND=1
+7 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVVI("AE",DFN,PRIEN,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+8 SET EIE=$$GET1^DIQ(9000010.58,IEN,.06,"I")
+9 IF EIE=1
QUIT
+10 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+11 IF STAT="D"
QUIT
+12 IF +VIEN&(VIEN'=$PIECE($GET(^AUPNVVI(IEN,0)),U,3))
QUIT
+13 IF VSCNT=0
SET VSCNT=VSCNT+1
DO ADD(" -INSTRUCTIONS:")
+14 SET EDATE=9999999-INVDT
+15 SET EDATE=$$FMTE^XLFDT($PIECE(EDATE,".",1),5)
+16 SET SIGNDT=$$GET1^DIQ(9000010.58,IEN,.05,"I")
+17 SET SIGNDT=$$FMTE^XLFDT($PIECE(SIGNDT,".",1),5)
+18 SET SIGN=$$GET1^DIQ(9000010.58,IEN,.04,"E")
+19 DO TEXT2(IEN)
+20 ;D ADD(" ("_EDATE_" by "_SIGN_")")
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
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(^AUPNVVI(IEN,11,TXTIEN))
IF '+TXTIEN
QUIT
Begin DoDot:1
+4 SET TXT=$GET(^AUPNVVI(IEN,11,TXTIEN,0))
+5 SET PRNT=PRNT2_TXT
SET PRNT2=""
+6 ;MSC/MGH P1014 matched to TEXT
+7 IF $LENGTH(PRNT)>500
SET PRNT2=$EXTRACT(PRNT,501,$LENGTH(PRNT))
+8 DO WRAP(.WRAP,PRNT,70)
End DoDot:1
+9 ;Process each wrapped line
+10 IF $DATA(WRAP)>1
DO PROC(.WRAP)
+11 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
VTRDT(PRIEN,VIEN,CNT) ; Visit Treatment/Regimens by date
+1 ;Get last (n) date entries for each problem of treatments
+2 ;Default is 99
+3 NEW INVDT,IEN,SNO1,VCNT,EDATE,STAT,IN,OUT,ARR,X,TXT,FOUND,PROB,PRTCT
+4 SET VIEN=$GET(VIEN)
+5 SET FOUND=0
SET PRTCT=0
+6 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVTXR("AF",DFN,INVDT))
IF INVDT=""!(FOUND=1)
QUIT
Begin DoDot:1
+7 SET SNO=""
FOR
SET SNO=$ORDER(^AUPNVTXR("AF",DFN,INVDT,SNO))
IF SNO=""
QUIT
Begin DoDot:2
+8 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVTXR("AF",DFN,INVDT,SNO,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+9 SET PROB=$PIECE($GET(^AUPNVTXR(IEN,0)),U,4)
+10 IF PROB'=PRIEN
QUIT
+11 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+12 IF STAT="D"
QUIT
+13 IF +VIEN&(VIEN'=$PIECE($GET(^AUPNVTXR(IEN,0)),U,3))
QUIT
+14 SET FOUND=1
+15 IF PRTCT=0
SET PRTCT=1
DO ADD(" -TREATMENTS:")
+16 SET EDATE=9999999-INVDT
+17 SET EDATE=$$FMTE^XLFDT(EDATE,5)
+18 ;D ADD(" -Treatment/Regimen Date: "_EDATE)
+19 SET SNO1=$PIECE($GET(^AUPNVTXR(IEN,0)),U,1)
+20 SET IN=SNO1_"^^^1"
SET OUT="ARR"
+21 SET X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+22 IF X>0
Begin DoDot:4
+23 SET TXT=ARR(1,"PRE","TRM")
+24 DO ADD(" "_TXT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 QUIT
REFDT(PRIEN,VIEN,CNT) ; V referrals by date
+1 ;Get last date entries for each problem of visit referrals
+2 NEW INVDT,IEN,VCNT,EDATE,STAT,SNO,IN,OUT,ARR,X,TXT,FOUND,PRTCT,ARRAY
+3 SET FOUND=0
SET PRTCT=0
+4 SET SNO=""
FOR
SET SNO=$ORDER(^AUPNVREF("AE",DFN,SNO))
IF SNO=""
QUIT
Begin DoDot:1
+5 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVREF("AE",DFN,SNO,INVDT))
IF INVDT=""
QUIT
Begin DoDot:2
+6 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVREF("AE",DFN,SNO,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+7 SET PROB=$PIECE($GET(^AUPNVREF(IEN,0)),U,4)
+8 IF PROB'=PRIEN
QUIT
+9 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+10 IF STAT="D"
QUIT
+11 IF +VIEN&(VIEN'=$PIECE($GET(^AUPNVREF(IEN,0)),U,3))
QUIT
+12 SET ARRAY(INVDT,PRIEN,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF $DATA(ARRAY)>10
DO ADD(" -REFERRALS:")
+14 SET INVDT=""
FOR
SET INVDT=$ORDER(ARRAY(INVDT))
IF INVDT=""!(FOUND=1)
QUIT
Begin DoDot:1
+15 SET EDATE=9999999-INVDT
+16 SET EDATE=$PIECE($$FMTE^XLFDT(EDATE,5),".")
+17 ;D ADD(" -Referral Date: "_EDATE)
+18 SET PRIEN=""
FOR
SET PRIEN=$ORDER(ARRAY(INVDT,PRIEN))
IF PRIEN=""
QUIT
Begin DoDot:2
+19 SET IEN=""
FOR
SET IEN=$ORDER(ARRAY(INVDT,PRIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+20 SET SNO=$PIECE($GET(^AUPNVREF(IEN,0)),U,1)
+21 SET X=$$CONC^BSTSAPI(SNO_"^^^1")
+22 IF +X
Begin DoDot:4
+23 SET TXT=$PIECE(X,U,4)
+24 DO ADD(" "_TXT)
+25 SET PRV=$$GET1^DIQ(9000010.59,IEN,1202)
+26 IF PRV=""
SET PRV=$$GET1^DIQ(9000010.59,IEN,1204)
+27 ;D ADD(" -Provider: "_PRV)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
EDU(PRIEN,VIEN,CNT) ;V education by date
+1 ;Get last date entries for each problem of visit education
+2 NEW EDU,PRCT
+3 SET PRCT=0
+4 SET EDU=""
FOR
SET EDU=$ORDER(^AUPNVPED("AD",VIEN,EDU))
IF EDU=""
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AUPNVPED(EDU,11)),U,3)=PRIEN
Begin DoDot:2
+6 IF PRCT=0
SET PRCT=1
DO ADD(" -EDUCATION:")
+7 DO ADD(" "_$$GET1^DIQ(9000010.16,EDU,.01))
End DoDot:2
End DoDot:1
+8 DO ADD("")
+9 QUIT
CONSULT(PRIEN,DFN,CNT) ;FIND consults
+1 NEW DATA,STR,CT2,SER,SDATE,SSTAT
+2 SET DATA=""
+3 SET NUM=99999
+4 DO GETCON^BGOVTR(.DATA,DFN,PRIEN,NUM,"")
+5 IF '$DATA(^TMP("BGOVIN",$JOB))
QUIT
+6 DO ADD("")
+7 DO ADD(" -CONSULTS:")
+8 SET CT2=0
+9 FOR
SET CT2=$ORDER(^TMP("BGOVIN",$JOB,CT2))
IF '+CT2
QUIT
Begin DoDot:1
+10 SET STR=$GET(^TMP("BGOVIN",$JOB,CT2))
+11 SET SER=$PIECE(STR,U,2)
SET SDATE=$PIECE(STR,U,3)
SET SSTAT=$PIECE(STR,U,4)
+12 DO ADD(" "_SER)
+13 DO ADD(" Date Ordered: "_SDATE_" Status: "_SSTAT)
End DoDot:1
+14 QUIT
+15 ;Get the problems associated with multiple visits and only the latest or items updated.
MVST(DFN,TARGET,NUM) ;Problems updated this visit
+1 NEW PROB,CNT,RET,PRIEN,I,VST,FOUND,VCNT
+2 SET FOUND=0
SET CNT=0
SET VCNT=0
+3 IF $GET(NUM)=""
SET NUM=999
+4 KILL @TARGET
+5 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVSIT("AA",DFN,INVDT))
IF '+INVDT!(NUM>VCNT)
QUIT
Begin DoDot:1
+6 SET VIEN=""
FOR
SET VIEN=$ORDER(^AUPNVSIT("AA",DFN,INVDT,VIEN))
IF '+VIEN!(NUM>VCNT)
QUIT
Begin DoDot:2
+7 IF "AIH"[$PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)
Begin DoDot:3
+8 SET VCNT=VCNT+1
+9 DO GETPRB(VIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF CNT=0
SET @TARGET@(1,0)="No Problems used as POVs in this visit record"
+11 QUIT "~@"_$NAME(@TARGET)
+12 ;
PBYSTAT(DFN,TARGET) ;Get problems by status
+1 NEW PRIEN,STAT,ARRAY,CNT,STATO
+2 SET CNT=0
+3 KILL @TARGET
+4 SET PRIEN=""
FOR
SET PRIEN=$ORDER(^AUPNPROB("AC",DFN,PRIEN))
IF 'PRIEN
QUIT
Begin DoDot:1
+5 ;Check for which statuses to return
+6 SET STATO=$$GET1^DIQ(9000011,PRIEN,.12)
+7 IF STATO=""
SET STATO="INACTIVE"
+8 SET STAT=$$GET1^DIQ(9000011,PRIEN,.12,"I")
+9 IF STAT="D"!(STAT="I")!(STAT="")
QUIT
+10 SET ARRAY(STATO,PRIEN)=""
End DoDot:1
+11 SET STAT=""
FOR
SET STAT=$ORDER(ARRAY(STAT))
IF STAT=""
QUIT
Begin DoDot:1
+12 DO ADD("Status: "_STAT)
+13 SET PRIEN=""
FOR
SET PRIEN=$ORDER(ARRAY(STAT,PRIEN))
IF PRIEN=""
QUIT
Begin DoDot:2
+14 DO PRDATA(PRIEN)
+15 DO ADD("")
End DoDot:2
End DoDot:1
+16 IF CNT=0
SET @TARGET@(1,0)="No Problems for this patient"
+17 QUIT "~@"_$NAME(@TARGET)
PRDATA(PRIEN) ;Get data for a problem
+1 NEW NARR,ICD
+2 SET NARR=$$GET1^DIQ(9000011,PRIEN,.05)
+3 DO ADD(" Problem: "_NARR)
+4 SET ICD=$$GET1^DIQ(9000011,PRIEN,.01)
+5 DO ADD(" -Mapped ICD:"_ICD)
+6 DO QUAL(PRIEN,.CNT)
+7 DO FINDCP(PRIEN,"G",.CNT)
+8 DO FINDCP(PRIEN,"P",.CNT)
+9 QUIT
WRAP(OUT,TEXT,RM,IND) ;EP - Wrap the text and insert in array
+1 ;
+2 NEW SP
+3 ;
+4 IF $GET(TEXT)=""
SET OUT=$GET(OUT)+1
SET OUT(OUT)=""
QUIT
+5 IF $GET(RM)=""
QUIT
+6 IF $GET(IND)=""
SET IND=0
+7 SET $PIECE(SP," ",80)=" "
+8 ;
+9 ;Strip out $c(10)
+10 SET TEXT=$TRANSLATE(TEXT,$CHAR(10))
+11 ;
+12 FOR
IF $LENGTH(TEXT)>0
Begin DoDot:1
+13 NEW PIECE,SPACE,LINE
+14 SET PIECE=$EXTRACT(TEXT,1,RM)
+15 ;
+16 ;Handle Line feeds
+17 IF PIECE[$CHAR(13)
Begin DoDot:2
+18 NEW LINE,I
+19 SET LINE=$PIECE(PIECE,$CHAR(13))
IF LINE=""
SET LINE=" "
+20 SET OUT=$GET(OUT)+1
SET OUT(OUT)=LINE
+21 FOR I=1:1:$LENGTH(PIECE)
IF $EXTRACT(PIECE,I)=$CHAR(13)
QUIT
+22 SET TEXT=$EXTRACT(SP,1,IND)_$$STZ($EXTRACT(TEXT,I+1,9999999999))
End DoDot:2
QUIT
+23 ;
+24 ;Check if line is less than right margin
+25 IF $LENGTH(PIECE)<RM
SET OUT=$GET(OUT)+1
SET OUT(OUT)=PIECE
SET TEXT=""
QUIT
+26 ;
+27 ;Locate last space in line and handle if no space
+28 FOR SPACE=$LENGTH(PIECE):-1:(IND+1)
IF $EXTRACT(PIECE,SPACE)=" "
QUIT
+29 IF (SPACE=(IND+1))
Begin DoDot:2
+30 SET LINE=PIECE
SET OUT=$GET(OUT)+1
SET OUT(OUT)=LINE
SET TEXT=$$STZ($EXTRACT(TEXT,RM+1,999999999))
End DoDot:2
IF TEXT]""
SET TEXT=$EXTRACT(SP,1,IND)_TEXT
QUIT
+31 ;
+32 ;Handle line with space
+33 SET LINE=$EXTRACT(PIECE,1,SPACE-1)
SET OUT=$GET(OUT)+1
SET OUT(OUT)=LINE
SET TEXT=$$STZ($EXTRACT(TEXT,SPACE+1,999999999))
+34 IF TEXT]""
SET TEXT=$EXTRACT(SP,1,IND)_TEXT
End DoDot:1
IF $LENGTH(TEXT)=0
QUIT
+35 ;
+36 QUIT
+37 ;
STZ(TEXT) ;EP - Strip Leading Spaces
+1 NEW START
+2 FOR START=1:1:$LENGTH(TEXT)
IF $EXTRACT(TEXT,START)'=" "
QUIT
+3 QUIT $EXTRACT(TEXT,START,9999999999)
+4 ;
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,STRING,CNT,BTIU,LINE,ASTHMA,PCNT,CODE,PAT,CON,NARR,IEN2,Q,ARRAY,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 ARRAY(NARR,IEN)=""
End DoDot:1
+12 SET NARR=""
SET IEN=0
+13 FOR
SET NARR=$ORDER(ARRAY(NARR))
IF NARR=""
QUIT
Begin DoDot:1
+14 ;Only get the first one
SET IEN=0
SET IEN=$ORDER(ARRAY(NARR,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+15 SET CNT=$GET(CNT)+1
SET PCNT=$GET(PCNT)+1
+16 KILL BTIU
DO ENP^XBDIQ1(9000010.07,IEN,".01:.29;1102","BTIU(","IE")
+17 SET LINE=""
+18 ;mark if primary dx
IF (BTIU(.12)="PRIMARY")
SET LINE=" [P] "
+19 SET CODE=$GET(BTIU(.01))
+20 SET SNO=$GET(BTIU(1102))
+21 SET ASTHMA=$$CHECK^BGOASLK(CODE,SNO)
+22 IF +ASTHMA
Begin DoDot:3
+23 SET PAT=BTIU(.02,"I")
+24 SET CON=$$ACONTROL^BTIULO5(PAT)
+25 IF CON'=""
SET LINE=LINE_" Control: "_CON
End DoDot:3
+26 ;check for other fields
FOR I=.06,.05,.09,.13,.11,.29
Begin DoDot:3
+27 IF (I=.09)
IF BTIU(.09)]""
SET LINE=LINE_"; "_$$ECODE^BTIULO5(IEN)
QUIT
+28 IF BTIU(I)]""
SET LINE=LINE_"; "_BTIU(I)
End DoDot:3
+29 SET RETURN(CNT)=$JUSTIFY(PCNT,2)_") "_NARR_LINE
+30 ;Return qualifiers
+31 FOR X=13,17,18,14
Begin DoDot:3
+32 SET STRING=""
+33 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNVPOV(IEN,X,IEN2))
IF '+IEN2
QUIT
Begin DoDot:4
+34 SET Q=""
+35 SET FNUM=$SELECT(X=13:9000010.0713,X=17:9000010.0717,X=18:9000010.0718,X=14:9000010.0714)
+36 SET AIEN=IEN2_","_IEN_","
+37 SET Q=$$GET1^DIQ(FNUM,AIEN,.01)
+38 SET Q=$PIECE($$CONC^BSTSAPI(Q_"^^^1"),U,4)
+39 SET STRING=$SELECT(STRING="":Q,1:STRING_" "_Q)
End DoDot:4
+40 IF STRING'=""
Begin DoDot:4
+41 SET CNT=CNT+1
+42 SET RETURN(CNT)=" "_STRING
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 QUIT
+44 ;
