BTIULO ; IHS/ITSC/LJF - CODE FOR IHS OBJECTS ;16-Sep-2013 15:45;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1001,1004,1006,1012**;NOV 04, 2004;Build 45
;Added EHR 1.1 call for finding a visit
;Added error message if visit not found
;
RELIGION(DFN) ;EP; Patient NAME
Q $$GET1^DIQ(2,DFN,.08)
;
SU(DFN) ;EP; Patient Service Unit of Residence
NEW X
S X=$$GET1^DIQ(9000001,DFN,1117,"I")
I X="" S X=$O(^AUPNPAT(DFN,51,""),-1) I X S X=$P(^AUPNPAT(DFN,51,X,0),U,3)
I X="" Q "??"
Q $$GET1^DIQ(9999999.05,+X,.05)
;
LASTDIFF(DFN,TYPE,VISIT) ;EP; returns last documnt of diff type for patient
;IHS/ITSC/LJF 01/13/2005 PATCH 1001 - code added to accommodate calls from EHR
; TYPE=Title IEN
; if visit not sent, assume called by EHR and look for visit context
I '$G(VISIT) D I $G(VISIT)<1 Q "Invalid visit "
. I $T(GETVAR^CIAVMEVT)="" S VISIT=0 Q
. NEW VST,X
. S VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
. I VST="" S VISIT=0 Q
. S X="BEHOENCX" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^BEHOENCX(DFN,VST) I VST<1 S VISIT=VST Q
. ;S X="CIAVCXEN" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^CIAVCXEN(DFN,VST) I VST<1 Q
. S VISIT=VST
;IHS/ITSC/LJF 01/13/2005 end of new code
;
NEW DATE
S DATE=$$GET1^DIQ(9000010,VISIT,.01,"I") I DATE="" Q ""
S DATE=$O(^TIU(8925,"AA",DFN,TYPE,9999999-(DATE+1))) I DATE="" Q ""
Q $$FMTE^XLFDT(9999999-DATE,"1D")
;
AGE(DFN) ;EP; returns printable age
Q $$LOW^XLFSTR($$GET1^DIQ(9000001,DFN,1102.98)_" old")
;
PTED(VISIT) ;EP; returns all pat ed topics for visit
NEW TIUX,TIUY
S TIUX=0,TIUY="" F S TIUX=$O(^AUPNVPED("AD",VISIT,TIUX)) Q:'TIUX D
. S TIUY=TIUY_$$GET1^DIQ(9000010.16,TIUX,.01)_";"
Q $S(TIUY="":"",1:$P(TIUY_";",";;"))
;
TAXDX(DFN,TAXNM) ;EP; returns dx date and prov narrative
; TAXNM=taxonomy name
NEW TAX,RDT,LINE,IEN,TIUR
S LINE="",TAX=$O(^ATXAX("B",TAXNM,0)) I TAX="" Q ""
S RDT=0 F S RDT=$O(^AUPNVPOV("AA",DFN,RDT)) Q:'RDT!(LINE]"") D
. S IEN=0 F S IEN=$O(^AUPNVPOV("AA",DFN,RDT,IEN)) Q:'IEN!(LINE]"") D
.. Q:'$$ICD^ATXCHK(+$G(^AUPNVPOV(IEN,0)),TAX,9)
.. K TIUR D ENP^XBDIQ1(9000010.07,IEN,".03;.04;.13;.17","TIUR(")
.. S LINE=$S(TIUR(.13)]"":TIUR(.13),TIUR(.17)]"":TIUR(.17),1:TIUR(.03))
.. S LINE=LINE_" "_TIUR(.04)
Q LINE
;
TAXOP(DFN,TAXNM) ;EP; returns op/proc date and prov narrative
; TAXNM=taxonomy name
NEW TAX,RDT,LINE,IEN,TIUR
S LINE="",TAX=$O(^ATXAX("B",TAXNM,0)) I TAX="" Q ""
S RDT=0 F S RDT=$O(^AUPNVPRC("AA",DFN,RDT)) Q:'RDT!(LINE]"") D
. S IEN=0 F S IEN=$O(^AUPNVPRC("AA",DFN,RDT,IEN)) Q:'IEN!(LINE]"") D
.. Q:'$$ICD^ATXCHK(+$G(^AUPNVPRC(IEN,0)),TAX,0)
.. K TIUR D ENP^XBDIQ1(9000010.08,IEN,".03;.04;.06","TIUR(")
.. S LINE=$S(TIUR(.06)]"":TIUR(.06),1:TIUR(.03))
.. S LINE=LINE_" "_TIUR(.04)
Q LINE
;
NEXTAPPT(DFN) ;EP; returns patient's next appt
NEW DATE,YES,DATA,CLN,X,LINE,OI
K ^TMP("BTIULO",$J)
S DATE=$$NOW^XLFDT,YES=0
F S DATE=$O(^DPT(DFN,"S",DATE)) Q:'DATE!(YES) D
. S DATA=$G(^DPT(DFN,"S",DATE,0)) Q:DATA=""
. Q:$P(DATA,U,2)["C" ;cancelled
. S X=0 F S X=$O(^SC(+DATA,"S",DATE,1,X)) Q:'X D
.. Q:+$G(^SC(+DATA,"S",DATE,1,X,0))'=DFN
.. S OI=" "_$P($G(^SC(+DATA,"S",DATE,1,X,0)),U,4) ;other info
.. S YES=DATE_U_+DATA_U_OI
I 'YES Q "Next Appt: None Found"
S LINE="Next Appt: "_$$FMTE^XLFDT(+YES,"1P")_" with "
S LINE=LINE_$$GET1^DIQ(44,$P(YES,U,2),.01)
S ^TMP("BTIULO",$J,1,0)=LINE,^TMP("BTIULO",$J,2,0)=OI
Q "~@^TMP(""BTIULO"",$J)"
;
FUTAPPT(DFN) ;EP; returns patient's future appts
NEW DATE,DATA,CLN,X,LN,CNT,OI
K ^TMP("BTIULO",$J)
S DATE=$$NOW^XLFDT,CNT=1
F S DATE=$O(^DPT(DFN,"S",DATE)) Q:'DATE D
. S DATA=$G(^DPT(DFN,"S",DATE,0)) Q:DATA=""
. Q:$P(DATA,U,2)["C" ;cancelled
. S X=0 F S X=$O(^SC(+DATA,"S",DATE,1,X)) Q:'X D
.. Q:+$G(^SC(+DATA,"S",DATE,1,X,0))'=DFN
.. S OI=$$SP(10)_$P($G(^SC(+DATA,"S",DATE,1,X,0)),U,4) ;other info
.. S LN=$$FMTE^XLFDT(+DATE,"1P")
.. S LN=LN_" ("_$P($G(^SC(+DATA,"S",DATE,1,X,0)),U,2)_" MINUTES)"
.. S LN=LN_" with "_$$GET1^DIQ(44,+DATA,.01)
.. S ^TMP("BTIULO",$J,CNT,0)=LN
.. S ^TMP("BTIULO",$J,CNT+1,0)=OI
.. S CNT=CNT+2
I '$D(^TMP("BTIULO",$J)) Q "Future Appt: None Found"
Q "~@^TMP(""BTIULO"",$J)"
;
VLAB(VISIT,ABN) ;EP; returns all lab results given for a visit
; ABN=1 means return abnormal results only (optional)
NEW TIUX,TIUY,COUNT,TIUA
K ^TMP("BTIULO",$J)
S TIUX=0,TIUY="" F S TIUX=$O(^AUPNVLAB("AD",VISIT,TIUX)) Q:'TIUX D
. K TIUA
. D ENP^XBDIQ1(9000010.09,TIUX,".01;.04;.05;1109","TIUA(")
. I TIUA(.04)="",TIUA(1109)="RESULTED" Q
. I $G(ABN),TIUA(.05)="" Q ;quit if abnormals only requested
. S TIUY=" "_$$PAD(TIUA(.01),25)_" " ;lab test
. S TIUY=TIUY_$$PAD(TIUA(.04),10)_TIUA(.05) ;result
. I TIUA(.04)="" S TIUY=TIUY_TIUA(1109)
. S COUNT=$G(COUNT)+1 S ^TMP("BTIULO",$J,COUNT,0)=TIUY
I '$D(^TMP("BTIULO",$J)) Q "No "_$S($G(ABN):"Abnormal ",1:"")_"Labs Found for Visit"
Q "~@^TMP(""BTIULO"",$J)"
;
VMED(VISIT) ;EP; returns all medications given for a visit
NEW TIUX,TIUY,COUNT
K ^TMP("BTIULO",$J)
S TIUX=0,TIUY="" F S TIUX=$O(^AUPNVMED("AD",VISIT,TIUX)) Q:'TIUX D
. S TIUY=TIUY_$$GET1^DIQ(9000010.14,TIUX,.01)_"; "
S:TIUY]"" TIUY=$$WRAP^TIULS(TIUY,73)
F COUNT=1:1 Q:$P(TIUY,"|",COUNT)="" S ^TMP("BTIULO",$J,COUNT,0)=$P(TIUY,"|",COUNT)
I '$D(^TMP("BTIULO",$J)) Q "No Medications Found for Visit"
Q "~@^TMP(""BTIULO"",$J)"
;
VMEDEX(VISIT) ;EP; returns all medications given for a visit plus sig
NEW TIUX,TIUY,TIUCNT
K ^TMP("BTIULO",$J)
S (TIUCNT,TIUX)=0,TIUY=""
F S TIUX=$O(^AUPNVMED("AD",VISIT,TIUX)) Q:'TIUX D
. NEW BTIU D ENP^XBDIQ1(9000010.14,TIUX,".01;.05:.07","BTIU(")
. S TIUY=BTIU(.01)_" #"_BTIU(.06)_" ("_BTIU(.07)_" days)" D VMSET
. S TIUY=$$SIG(TIUX,BTIU(.05)) D VMSET
I '$D(^TMP("BTIULO",$J)) Q "No Medications Found for Visit"
Q "~@^TMP(""BTIULO"",$J)"
;
VMSET ; -- set string into wrapped line
NEW COUNT
S:TIUY]"" TIUY=$$WRAP^TIULS(TIUY,73)
F COUNT=1:1 Q:$P(TIUY,"|",COUNT)="" D
. S TIUCNT=TIUCNT+1
. S ^TMP("BTIULO",$J,TIUCNT,0)=$P(TIUY,"|",COUNT)
Q
;
SIG(VMED,SSIG) ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
; VMED=ien in v med file; SSIG=short sig
NEW SIG,PIECE,Y,X
S SIG="" F PIECE=1:1:$L(SSIG," ") S X=$P(SSIG," ",PIECE) I X]"" D
. S Y=$O(^PS(51,"B",X,0)) I Y>0 S X=$P(^PS(51,Y,0),U,2) I $D(^(9)) S Y=$P(SSIG," ",PIECE-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),U,1)
. S SIG=SIG_X_" "
Q SIG
;
ALLERGY(DFN) ;EP; returns allergies and ADRs
NEW GMRA,GMRAL,X,ALLRG,ADR,TIUY,Y,Z
K ^TMP("BTIULO",$J)
S GMRA="0^0^111" D EN1^GMRADPT
I GMRAL=0 D Q X
. S Z="Allergies/ADRs: "
. S Y=$O(GMRAL(0)) I Y S X=$P(GMRAL(Y),U,2) I X]"" S X=Z_X Q
. S X=Z_"None found in system"
S (ALLRG,ADR)=""
S X=0 F S X=$O(GMRAL(X)) Q:'X D
. I $P(GMRAL(X),U,5)=0 S ALLRG=ALLRG_$P(GMRAL(X),U,2)_"; " Q
. S ADR=ADR_$P(GMRAL(X),U,2)_"; "
S ALLRG=$S(ALLRG="":"None found",1:$P(ALLRG_";","; ;"))
S ADR=$S(ADR="":"None found",1:$P(ADR_";","; ;"))
S X="Allergies: "_ALLRG_"; ADRs: "_ADR S TIUY=$$WRAP^TIULS(X,73)
F COUNT=1:1 Q:$P(TIUY,"|",COUNT)="" S ^TMP("BTIULO",$J,COUNT,0)=$P(TIUY,"|",COUNT)
Q "~@^TMP(""BTIULO"",$J)"
;
;
UPDATE(DUZ,DFN,VISIT,TIUSUB) ;EP -- called to populate multiple objects
; -- TIUSUB=subrtn for finding data
NEW TIUCNT
K ^TMP("BTIULO",$J)
I '$G(VISIT) Q "" ;visit not set
D @TIUSUB
Q "~@^TMP(""BTIULO"",$J)"
;
;
EDEVAL ; -- subrtn to find pat ed evaluations
NEW TIUX,TIUY,TIUZ,LINE
I '$O(^AUPNVPED("AD",VISIT,0)) S ^TMP("BTIULO",$J,1,0)="None Found" Q
;
S TIUX=0,TIUY="",TIUCNT=1
F S TIUX=$O(^AUPNVPED("AD",VISIT,TIUX)) Q:'TIUX D
. D ENP^XBDIQ1(9000010.16,TIUX,".01;.05:.08","TIUZ(","I")
. S LINE=$$SP(2)_$$EDABBRV(TIUZ(.01,"I"))_": "_TIUZ(.08)_" min.; "
. S LINE=LINE_TIUZ(.07)_"; Understanding-"_TIUZ(.06)
. S ^TMP("BTIULO",$J,TIUCNT,0)=LINE
. S TIUCNT=TIUCNT+1
Q
;
EDABBRV(X) ; -- returns education topic abbreviation
Q $$GET1^DIQ(9999999.09,X,1)
;
HS(APCHSPAT,CODE,APCHSDLM) ;EP; -- calls HS component
; CODE=entry point to call
NEW APCHSTYP,APCHSCKP,APCHSNPG,APCHSBRK,X,CNT,APCHSEGH
NEW APCHSEGL,APCHSCVD
K ^TMP("BTIULO",$J),^TMP("BTIU",$J)
I '$G(APCHSPAT) Q "" ;patient not set
S APCHSCKP="Q:$D(APCHSQIT)",APCHSNPG=0
S APCHSBRK="D BREAK^APCHS",(APCHSEGH,APCHSEGL)=""
S X1=DT,X2=-APCHSDLM D C^%DTC S APCHSDLM=9999999-X K X1,X2
S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_($E(Y,1,3)+1700)"
;
D GUIR^XBLM(CODE,"^TMP(""BTIU"",$J,")
D TERM^VALM0 D KILLHS
;
S X=0 F S X=$O(^TMP("BTIU",$J,X)) Q:'X D
. I ^TMP("BTIU",$J,X)=""!(^(X)?1"--------".E) Q
. S CNT=$G(CNT)+1
. S ^TMP("BTIULO",$J,CNT,0)=^TMP("BTIU",$J,X)
Q "~@^TMP(""BTIULO"",$J)"
;
KILLHS ; kill health summary variables (copied from KILLS^APCHS0)
K APCHSCVD,APCHSICF,APCHSCKP,APCHSNPG,APCHSP,%,APCHSVAR,X,Y,APCHSQIT,APCHSHDR,APCHSHD2,APCHSBRK,APCHSPG
K APCHSEGN,APCHSEGC,APCHSEGT,APCHSEGH,APCHSEGL,APCHSEGP,APCHSDLM,APCHSDLS,APCHSNDM,APCHSN,APCHSQ
Q
;
PAD(D,L) ; -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
DETAIL(DFN,TARGET) ;
N RXN,LP,LP2,LBL,CNT,Y,INIEN,REASON,X1,CAUSE
N GMRA,GMRAL,X,ALLRG,ADR,TIUY,Y,Z,CNT,UNI
K @TARGET
S CNT=0
S GMRA="0^0^111" D EN1^GMRADPT
I $D(GMRAL)'>9 D G ADRX
. S CNT=+$G(CNT)+1
. I $D(GMRAL),GMRAL=0 S @TARGET@(CNT,0)="Patient has answered NKA"
. E S @TARGET@(CNT,0)="No Allergy Assessment" ;
S ADR=0 F S ADR=$O(GMRAL(ADR)) Q:ADR="" D
.D EN1^GMRAOR2(ADR,"RXN")
.S UNI=$$UNI^BEHOARCV(ADR) ;Get the UNI code for this agent if its GMR type
.I $L(UNI) S CAUSE=$P(RXN,U)_"; UNII: "_UNI
.E S CAUSE=$P(RXN,U)
.S CNT=CNT+1
.S @TARGET@(CNT,0)="Causative agent: "_$P(CAUSE,U)
.S CNT=CNT+1
.S @TARGET@(CNT,0)="Event: "_$P(RXN,U,12)
.S CNT=CNT+1
.S @TARGET@(CNT,0)="Source: "_$P(RXN,U,11)
.D:$D(RXN("S",1)) SYM
.D:$D(RXN("I",1)) ING
.D:$D(RXN("V",1)) CLS
.D RECON(ADR)
.S CNT=CNT+1
.S @TARGET@(CNT,0)=""
ADRX Q "~@"_$NA(@TARGET)
;
SYM ;Add symptoms
S CNT=CNT+1
S @TARGET@(CNT,0)="Signs/Symptoms:"
S LP=0 F S LP=$O(RXN("S",LP)) Q:'LP D
.S CNT=CNT+1
.S @TARGET@(CNT,0)=" "_RXN("S",LP)
Q
CLS ;Add classes
S CNT=CNT+1
S @TARGET@(CNT,0)="Drug Classes:"
S LP=0 F S LP=$O(RXN("V",LP)) Q:'LP D
.S CNT=CNT+1
.S @TARGET@(CNT,0)=" "_$P(RXN("V",LP),U,2)
Q
ING ;Add Ingredients
S CNT=CNT+1
S @TARGET@(CNT,0)="Drug Ingredients:"
S LP=0 F S LP=$O(RXN("I",LP)) Q:'LP D
.S CNT=CNT+1
.S @TARGET@(CNT,0)=" "_$P(RXN("I",LP),U,1)
Q
RECON(ADR) ;Get reconciliation data
N REC,IEN,AIEN,WHEN,BY,FROM
S REC=""
F S REC=$O(^BEHOCIR("G","A",ADR,REC)) Q:REC="" D
.S IEN="" F S IEN=$O(^BEHOCIR("G","A",ADR,REC,IEN)) Q:IEN="" D
..S AIEN=IEN_","_REC_","
..S WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
..S BY=$$GET1^DIQ(90461.632,AIEN,.02)
..S WHEN=WHEN_" by "_BY
..S FROM=$$GET1^DIQ(90461.63,REC,.03)
..S CNT=CNT+1
..S @TARGET@(CNT,0)="Reconciled: "_WHEN
..S CNT=CNT+1
..S @TARGET@(CNT,0)="Data Source: "_FROM
Q
BTIULO ; IHS/ITSC/LJF - CODE FOR IHS OBJECTS ;16-Sep-2013 15:45;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1001,1004,1006,1012**;NOV 04, 2004;Build 45
+2 ;Added EHR 1.1 call for finding a visit
+3 ;Added error message if visit not found
+4 ;
RELIGION(DFN) ;EP; Patient NAME
+1 QUIT $$GET1^DIQ(2,DFN,.08)
+2 ;
SU(DFN) ;EP; Patient Service Unit of Residence
+1 NEW X
+2 SET X=$$GET1^DIQ(9000001,DFN,1117,"I")
+3 IF X=""
SET X=$ORDER(^AUPNPAT(DFN,51,""),-1)
IF X
SET X=$PIECE(^AUPNPAT(DFN,51,X,0),U,3)
+4 IF X=""
QUIT "??"
+5 QUIT $$GET1^DIQ(9999999.05,+X,.05)
+6 ;
LASTDIFF(DFN,TYPE,VISIT) ;EP; returns last documnt of diff type for patient
+1 ;IHS/ITSC/LJF 01/13/2005 PATCH 1001 - code added to accommodate calls from EHR
+2 ; TYPE=Title IEN
+3 ; if visit not sent, assume called by EHR and look for visit context
+4 IF '$GET(VISIT)
Begin DoDot:1
+5 IF $TEXT(GETVAR^CIAVMEVT)=""
SET VISIT=0
QUIT
+6 NEW VST,X
+7 SET VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
+8 IF VST=""
SET VISIT=0
QUIT
+9 SET X="BEHOENCX"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET VST=+$$VSTR2VIS^BEHOENCX(DFN,VST)
IF VST<1
SET VISIT=VST
QUIT
+10 ;S X="CIAVCXEN" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^CIAVCXEN(DFN,VST) I VST<1 Q
+11 SET VISIT=VST
End DoDot:1
IF $GET(VISIT)<1
QUIT "Invalid visit "
+12 ;IHS/ITSC/LJF 01/13/2005 end of new code
+13 ;
+14 NEW DATE
+15 SET DATE=$$GET1^DIQ(9000010,VISIT,.01,"I")
IF DATE=""
QUIT ""
+16 SET DATE=$ORDER(^TIU(8925,"AA",DFN,TYPE,9999999-(DATE+1)))
IF DATE=""
QUIT ""
+17 QUIT $$FMTE^XLFDT(9999999-DATE,"1D")
+18 ;
AGE(DFN) ;EP; returns printable age
+1 QUIT $$LOW^XLFSTR($$GET1^DIQ(9000001,DFN,1102.98)_" old")
+2 ;
PTED(VISIT) ;EP; returns all pat ed topics for visit
+1 NEW TIUX,TIUY
+2 SET TIUX=0
SET TIUY=""
FOR
SET TIUX=$ORDER(^AUPNVPED("AD",VISIT,TIUX))
IF 'TIUX
QUIT
Begin DoDot:1
+3 SET TIUY=TIUY_$$GET1^DIQ(9000010.16,TIUX,.01)_";"
End DoDot:1
+4 QUIT $SELECT(TIUY="":"",1:$PIECE(TIUY_";",";;"))
+5 ;
TAXDX(DFN,TAXNM) ;EP; returns dx date and prov narrative
+1 ; TAXNM=taxonomy name
+2 NEW TAX,RDT,LINE,IEN,TIUR
+3 SET LINE=""
SET TAX=$ORDER(^ATXAX("B",TAXNM,0))
IF TAX=""
QUIT ""
+4 SET RDT=0
FOR
SET RDT=$ORDER(^AUPNVPOV("AA",DFN,RDT))
IF 'RDT!(LINE]"")
QUIT
Begin DoDot:1
+5 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNVPOV("AA",DFN,RDT,IEN))
IF 'IEN!(LINE]"")
QUIT
Begin DoDot:2
+6 IF '$$ICD^ATXCHK(+$GET(^AUPNVPOV(IEN,0)),TAX,9)
QUIT
+7 KILL TIUR
DO ENP^XBDIQ1(9000010.07,IEN,".03;.04;.13;.17","TIUR(")
+8 SET LINE=$SELECT(TIUR(.13)]"":TIUR(.13),TIUR(.17)]"":TIUR(.17),1:TIUR(.03))
+9 SET LINE=LINE_" "_TIUR(.04)
End DoDot:2
End DoDot:1
+10 QUIT LINE
+11 ;
TAXOP(DFN,TAXNM) ;EP; returns op/proc date and prov narrative
+1 ; TAXNM=taxonomy name
+2 NEW TAX,RDT,LINE,IEN,TIUR
+3 SET LINE=""
SET TAX=$ORDER(^ATXAX("B",TAXNM,0))
IF TAX=""
QUIT ""
+4 SET RDT=0
FOR
SET RDT=$ORDER(^AUPNVPRC("AA",DFN,RDT))
IF 'RDT!(LINE]"")
QUIT
Begin DoDot:1
+5 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNVPRC("AA",DFN,RDT,IEN))
IF 'IEN!(LINE]"")
QUIT
Begin DoDot:2
+6 IF '$$ICD^ATXCHK(+$GET(^AUPNVPRC(IEN,0)),TAX,0)
QUIT
+7 KILL TIUR
DO ENP^XBDIQ1(9000010.08,IEN,".03;.04;.06","TIUR(")
+8 SET LINE=$SELECT(TIUR(.06)]"":TIUR(.06),1:TIUR(.03))
+9 SET LINE=LINE_" "_TIUR(.04)
End DoDot:2
End DoDot:1
+10 QUIT LINE
+11 ;
NEXTAPPT(DFN) ;EP; returns patient's next appt
+1 NEW DATE,YES,DATA,CLN,X,LINE,OI
+2 KILL ^TMP("BTIULO",$JOB)
+3 SET DATE=$$NOW^XLFDT
SET YES=0
+4 FOR
SET DATE=$ORDER(^DPT(DFN,"S",DATE))
IF 'DATE!(YES)
QUIT
Begin DoDot:1
+5 SET DATA=$GET(^DPT(DFN,"S",DATE,0))
IF DATA=""
QUIT
+6 ;cancelled
IF $PIECE(DATA,U,2)["C"
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^SC(+DATA,"S",DATE,1,X))
IF 'X
QUIT
Begin DoDot:2
+8 IF +$GET(^SC(+DATA,"S",DATE,1,X,0))'=DFN
QUIT
+9 ;other info
SET OI=" "_$PIECE($GET(^SC(+DATA,"S",DATE,1,X,0)),U,4)
+10 SET YES=DATE_U_+DATA_U_OI
End DoDot:2
End DoDot:1
+11 IF 'YES
QUIT "Next Appt: None Found"
+12 SET LINE="Next Appt: "_$$FMTE^XLFDT(+YES,"1P")_" with "
+13 SET LINE=LINE_$$GET1^DIQ(44,$PIECE(YES,U,2),.01)
+14 SET ^TMP("BTIULO",$JOB,1,0)=LINE
SET ^TMP("BTIULO",$JOB,2,0)=OI
+15 QUIT "~@^TMP(""BTIULO"",$J)"
+16 ;
FUTAPPT(DFN) ;EP; returns patient's future appts
+1 NEW DATE,DATA,CLN,X,LN,CNT,OI
+2 KILL ^TMP("BTIULO",$JOB)
+3 SET DATE=$$NOW^XLFDT
SET CNT=1
+4 FOR
SET DATE=$ORDER(^DPT(DFN,"S",DATE))
IF 'DATE
QUIT
Begin DoDot:1
+5 SET DATA=$GET(^DPT(DFN,"S",DATE,0))
IF DATA=""
QUIT
+6 ;cancelled
IF $PIECE(DATA,U,2)["C"
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^SC(+DATA,"S",DATE,1,X))
IF 'X
QUIT
Begin DoDot:2
+8 IF +$GET(^SC(+DATA,"S",DATE,1,X,0))'=DFN
QUIT
+9 ;other info
SET OI=$$SP(10)_$PIECE($GET(^SC(+DATA,"S",DATE,1,X,0)),U,4)
+10 SET LN=$$FMTE^XLFDT(+DATE,"1P")
+11 SET LN=LN_" ("_$PIECE($GET(^SC(+DATA,"S",DATE,1,X,0)),U,2)_" MINUTES)"
+12 SET LN=LN_" with "_$$GET1^DIQ(44,+DATA,.01)
+13 SET ^TMP("BTIULO",$JOB,CNT,0)=LN
+14 SET ^TMP("BTIULO",$JOB,CNT+1,0)=OI
+15 SET CNT=CNT+2
End DoDot:2
End DoDot:1
+16 IF '$DATA(^TMP("BTIULO",$JOB))
QUIT "Future Appt: None Found"
+17 QUIT "~@^TMP(""BTIULO"",$J)"
+18 ;
VLAB(VISIT,ABN) ;EP; returns all lab results given for a visit
+1 ; ABN=1 means return abnormal results only (optional)
+2 NEW TIUX,TIUY,COUNT,TIUA
+3 KILL ^TMP("BTIULO",$JOB)
+4 SET TIUX=0
SET TIUY=""
FOR
SET TIUX=$ORDER(^AUPNVLAB("AD",VISIT,TIUX))
IF 'TIUX
QUIT
Begin DoDot:1
+5 KILL TIUA
+6 DO ENP^XBDIQ1(9000010.09,TIUX,".01;.04;.05;1109","TIUA(")
+7 IF TIUA(.04)=""
IF TIUA(1109)="RESULTED"
QUIT
+8 ;quit if abnormals only requested
IF $GET(ABN)
IF TIUA(.05)=""
QUIT
+9 ;lab test
SET TIUY=" "_$$PAD(TIUA(.01),25)_" "
+10 ;result
SET TIUY=TIUY_$$PAD(TIUA(.04),10)_TIUA(.05)
+11 IF TIUA(.04)=""
SET TIUY=TIUY_TIUA(1109)
+12 SET COUNT=$GET(COUNT)+1
SET ^TMP("BTIULO",$JOB,COUNT,0)=TIUY
End DoDot:1
+13 IF '$DATA(^TMP("BTIULO",$JOB))
QUIT "No "_$SELECT($GET(ABN):"Abnormal ",1:"")_"Labs Found for Visit"
+14 QUIT "~@^TMP(""BTIULO"",$J)"
+15 ;
VMED(VISIT) ;EP; returns all medications given for a visit
+1 NEW TIUX,TIUY,COUNT
+2 KILL ^TMP("BTIULO",$JOB)
+3 SET TIUX=0
SET TIUY=""
FOR
SET TIUX=$ORDER(^AUPNVMED("AD",VISIT,TIUX))
IF 'TIUX
QUIT
Begin DoDot:1
+4 SET TIUY=TIUY_$$GET1^DIQ(9000010.14,TIUX,.01)_"; "
End DoDot:1
+5 IF TIUY]""
SET TIUY=$$WRAP^TIULS(TIUY,73)
+6 FOR COUNT=1:1
IF $PIECE(TIUY,"|",COUNT)=""
QUIT
SET ^TMP("BTIULO",$JOB,COUNT,0)=$PIECE(TIUY,"|",COUNT)
+7 IF '$DATA(^TMP("BTIULO",$JOB))
QUIT "No Medications Found for Visit"
+8 QUIT "~@^TMP(""BTIULO"",$J)"
+9 ;
VMEDEX(VISIT) ;EP; returns all medications given for a visit plus sig
+1 NEW TIUX,TIUY,TIUCNT
+2 KILL ^TMP("BTIULO",$JOB)
+3 SET (TIUCNT,TIUX)=0
SET TIUY=""
+4 FOR
SET TIUX=$ORDER(^AUPNVMED("AD",VISIT,TIUX))
IF 'TIUX
QUIT
Begin DoDot:1
+5 NEW BTIU
DO ENP^XBDIQ1(9000010.14,TIUX,".01;.05:.07","BTIU(")
+6 SET TIUY=BTIU(.01)_" #"_BTIU(.06)_" ("_BTIU(.07)_" days)"
DO VMSET
+7 SET TIUY=$$SIG(TIUX,BTIU(.05))
DO VMSET
End DoDot:1
+8 IF '$DATA(^TMP("BTIULO",$JOB))
QUIT "No Medications Found for Visit"
+9 QUIT "~@^TMP(""BTIULO"",$J)"
+10 ;
VMSET ; -- set string into wrapped line
+1 NEW COUNT
+2 IF TIUY]""
SET TIUY=$$WRAP^TIULS(TIUY,73)
+3 FOR COUNT=1:1
IF $PIECE(TIUY,"|",COUNT)=""
QUIT
Begin DoDot:1
+4 SET TIUCNT=TIUCNT+1
+5 SET ^TMP("BTIULO",$JOB,TIUCNT,0)=$PIECE(TIUY,"|",COUNT)
End DoDot:1
+6 QUIT
+7 ;
SIG(VMED,SSIG) ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 ; VMED=ien in v med file; SSIG=short sig
+2 NEW SIG,PIECE,Y,X
+3 SET SIG=""
FOR PIECE=1:1:$LENGTH(SSIG," ")
SET X=$PIECE(SSIG," ",PIECE)
IF X]""
Begin DoDot:1
+4 SET Y=$ORDER(^PS(51,"B",X,0))
IF Y>0
SET X=$PIECE(^PS(51,Y,0),U,2)
IF $DATA(^(9))
SET Y=$PIECE(SSIG," ",PIECE-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),U,1)
+5 SET SIG=SIG_X_" "
End DoDot:1
+6 QUIT SIG
+7 ;
ALLERGY(DFN) ;EP; returns allergies and ADRs
+1 NEW GMRA,GMRAL,X,ALLRG,ADR,TIUY,Y,Z
+2 KILL ^TMP("BTIULO",$JOB)
+3 SET GMRA="0^0^111"
DO EN1^GMRADPT
+4 IF GMRAL=0
Begin DoDot:1
+5 SET Z="Allergies/ADRs: "
+6 SET Y=$ORDER(GMRAL(0))
IF Y
SET X=$PIECE(GMRAL(Y),U,2)
IF X]""
SET X=Z_X
QUIT
+7 SET X=Z_"None found in system"
End DoDot:1
QUIT X
+8 SET (ALLRG,ADR)=""
+9 SET X=0
FOR
SET X=$ORDER(GMRAL(X))
IF 'X
QUIT
Begin DoDot:1
+10 IF $PIECE(GMRAL(X),U,5)=0
SET ALLRG=ALLRG_$PIECE(GMRAL(X),U,2)_"; "
QUIT
+11 SET ADR=ADR_$PIECE(GMRAL(X),U,2)_"; "
End DoDot:1
+12 SET ALLRG=$SELECT(ALLRG="":"None found",1:$PIECE(ALLRG_";","; ;"))
+13 SET ADR=$SELECT(ADR="":"None found",1:$PIECE(ADR_";","; ;"))
+14 SET X="Allergies: "_ALLRG_"; ADRs: "_ADR
SET TIUY=$$WRAP^TIULS(X,73)
+15 FOR COUNT=1:1
IF $PIECE(TIUY,"|",COUNT)=""
QUIT
SET ^TMP("BTIULO",$JOB,COUNT,0)=$PIECE(TIUY,"|",COUNT)
+16 QUIT "~@^TMP(""BTIULO"",$J)"
+17 ;
+18 ;
UPDATE(DUZ,DFN,VISIT,TIUSUB) ;EP -- called to populate multiple objects
+1 ; -- TIUSUB=subrtn for finding data
+2 NEW TIUCNT
+3 KILL ^TMP("BTIULO",$JOB)
+4 ;visit not set
IF '$GET(VISIT)
QUIT ""
+5 DO @TIUSUB
+6 QUIT "~@^TMP(""BTIULO"",$J)"
+7 ;
+8 ;
EDEVAL ; -- subrtn to find pat ed evaluations
+1 NEW TIUX,TIUY,TIUZ,LINE
+2 IF '$ORDER(^AUPNVPED("AD",VISIT,0))
SET ^TMP("BTIULO",$JOB,1,0)="None Found"
QUIT
+3 ;
+4 SET TIUX=0
SET TIUY=""
SET TIUCNT=1
+5 FOR
SET TIUX=$ORDER(^AUPNVPED("AD",VISIT,TIUX))
IF 'TIUX
QUIT
Begin DoDot:1
+6 DO ENP^XBDIQ1(9000010.16,TIUX,".01;.05:.08","TIUZ(","I")
+7 SET LINE=$$SP(2)_$$EDABBRV(TIUZ(.01,"I"))_": "_TIUZ(.08)_" min.; "
+8 SET LINE=LINE_TIUZ(.07)_"; Understanding-"_TIUZ(.06)
+9 SET ^TMP("BTIULO",$JOB,TIUCNT,0)=LINE
+10 SET TIUCNT=TIUCNT+1
End DoDot:1
+11 QUIT
+12 ;
EDABBRV(X) ; -- returns education topic abbreviation
+1 QUIT $$GET1^DIQ(9999999.09,X,1)
+2 ;
HS(APCHSPAT,CODE,APCHSDLM) ;EP; -- calls HS component
+1 ; CODE=entry point to call
+2 NEW APCHSTYP,APCHSCKP,APCHSNPG,APCHSBRK,X,CNT,APCHSEGH
+3 NEW APCHSEGL,APCHSCVD
+4 KILL ^TMP("BTIULO",$JOB),^TMP("BTIU",$JOB)
+5 ;patient not set
IF '$GET(APCHSPAT)
QUIT ""
+6 SET APCHSCKP="Q:$D(APCHSQIT)"
SET APCHSNPG=0
+7 SET APCHSBRK="D BREAK^APCHS"
SET (APCHSEGH,APCHSEGL)=""
+8 SET X1=DT
SET X2=-APCHSDLM
DO C^%DTC
SET APCHSDLM=9999999-X
KILL X1,X2
+9 SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_($E(Y,1,3)+1700)"
+10 ;
+11 DO GUIR^XBLM(CODE,"^TMP(""BTIU"",$J,")
+12 DO TERM^VALM0
DO KILLHS
+13 ;
+14 SET X=0
FOR
SET X=$ORDER(^TMP("BTIU",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+15 IF ^TMP("BTIU",$JOB,X)=""!(^(X)?1"--------".E)
QUIT
+16 SET CNT=$GET(CNT)+1
+17 SET ^TMP("BTIULO",$JOB,CNT,0)=^TMP("BTIU",$JOB,X)
End DoDot:1
+18 QUIT "~@^TMP(""BTIULO"",$J)"
+19 ;
KILLHS ; kill health summary variables (copied from KILLS^APCHS0)
+1 KILL APCHSCVD,APCHSICF,APCHSCKP,APCHSNPG,APCHSP,%,APCHSVAR,X,Y,APCHSQIT,APCHSHDR,APCHSHD2,APCHSBRK,APCHSPG
+2 KILL APCHSEGN,APCHSEGC,APCHSEGT,APCHSEGH,APCHSEGL,APCHSEGP,APCHSDLM,APCHSDLS,APCHSNDM,APCHSN,APCHSQ
+3 QUIT
+4 ;
PAD(D,L) ; -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
DETAIL(DFN,TARGET) ;
+1 NEW RXN,LP,LP2,LBL,CNT,Y,INIEN,REASON,X1,CAUSE
+2 NEW GMRA,GMRAL,X,ALLRG,ADR,TIUY,Y,Z,CNT,UNI
+3 KILL @TARGET
+4 SET CNT=0
+5 SET GMRA="0^0^111"
DO EN1^GMRADPT
+6 IF $DATA(GMRAL)'>9
Begin DoDot:1
+7 SET CNT=+$GET(CNT)+1
+8 IF $DATA(GMRAL)
IF GMRAL=0
SET @TARGET@(CNT,0)="Patient has answered NKA"
+9 ;
IF '$TEST
SET @TARGET@(CNT,0)="No Allergy Assessment"
End DoDot:1
GOTO ADRX
+10 SET ADR=0
FOR
SET ADR=$ORDER(GMRAL(ADR))
IF ADR=""
QUIT
Begin DoDot:1
+11 DO EN1^GMRAOR2(ADR,"RXN")
+12 ;Get the UNI code for this agent if its GMR type
SET UNI=$$UNI^BEHOARCV(ADR)
+13 IF $LENGTH(UNI)
SET CAUSE=$PIECE(RXN,U)_"; UNII: "_UNI
+14 IF '$TEST
SET CAUSE=$PIECE(RXN,U)
+15 SET CNT=CNT+1
+16 SET @TARGET@(CNT,0)="Causative agent: "_$PIECE(CAUSE,U)
+17 SET CNT=CNT+1
+18 SET @TARGET@(CNT,0)="Event: "_$PIECE(RXN,U,12)
+19 SET CNT=CNT+1
+20 SET @TARGET@(CNT,0)="Source: "_$PIECE(RXN,U,11)
+21 IF $DATA(RXN("S",1))
DO SYM
+22 IF $DATA(RXN("I",1))
DO ING
+23 IF $DATA(RXN("V",1))
DO CLS
+24 DO RECON(ADR)
+25 SET CNT=CNT+1
+26 SET @TARGET@(CNT,0)=""
End DoDot:1
ADRX QUIT "~@"_$NAME(@TARGET)
+1 ;
SYM ;Add symptoms
+1 SET CNT=CNT+1
+2 SET @TARGET@(CNT,0)="Signs/Symptoms:"
+3 SET LP=0
FOR
SET LP=$ORDER(RXN("S",LP))
IF 'LP
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 SET @TARGET@(CNT,0)=" "_RXN("S",LP)
End DoDot:1
+6 QUIT
CLS ;Add classes
+1 SET CNT=CNT+1
+2 SET @TARGET@(CNT,0)="Drug Classes:"
+3 SET LP=0
FOR
SET LP=$ORDER(RXN("V",LP))
IF 'LP
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 SET @TARGET@(CNT,0)=" "_$PIECE(RXN("V",LP),U,2)
End DoDot:1
+6 QUIT
ING ;Add Ingredients
+1 SET CNT=CNT+1
+2 SET @TARGET@(CNT,0)="Drug Ingredients:"
+3 SET LP=0
FOR
SET LP=$ORDER(RXN("I",LP))
IF 'LP
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 SET @TARGET@(CNT,0)=" "_$PIECE(RXN("I",LP),U,1)
End DoDot:1
+6 QUIT
RECON(ADR) ;Get reconciliation data
+1 NEW REC,IEN,AIEN,WHEN,BY,FROM
+2 SET REC=""
+3 FOR
SET REC=$ORDER(^BEHOCIR("G","A",ADR,REC))
IF REC=""
QUIT
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(^BEHOCIR("G","A",ADR,REC,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+5 SET AIEN=IEN_","_REC_","
+6 SET WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
+7 SET BY=$$GET1^DIQ(90461.632,AIEN,.02)
+8 SET WHEN=WHEN_" by "_BY
+9 SET FROM=$$GET1^DIQ(90461.63,REC,.03)
+10 SET CNT=CNT+1
+11 SET @TARGET@(CNT,0)="Reconciled: "_WHEN
+12 SET CNT=CNT+1
+13 SET @TARGET@(CNT,0)="Data Source: "_FROM
End DoDot:2
End DoDot:1
+14 QUIT
