BHSACG ;IHS/CIA/MGH - Supplement for anti-coag ;14-Jan-2014 15:03;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**4,9**;March 17, 2006;Build 16
;===================================================================
; IHS/CMI/LAB - ; ANTI-COAG SUPPLEMENT
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;Copy of APCHSACG
;
;BJPC v2.0 patch 1
S(Y,F,C,T) ;EP - set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("BHSACG",$J,"DCS",0),U)+1,$P(^TMP("BHSACG",$J,"DCS",0),U)=%
S ^TMP("BHSACG",$J,"DCS",%)=X
Q
CTR(X,Y) ;EP - Center
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EP(DFN) ;PEP - ANTI-COAG supplement
NEW BHX,BHQUIT,BHSX,BHEDUC,BHV,BHSS,BHPG,BHSIG,BHSP,BHSQUIT
NEW X,Y,Z,A,I,B,E,T
D EP2(DFN)
W ;write out array
W:$D(IOF) @IOF
K BHQUIT
S BHPG=0
S BHX=0 F S BHX=$O(^TMP("BHSACG",$J,"DCS",BHX)) Q:BHX'=+BHX!($D(BHSQUIT)) D
.W !,^TMP("BHSACG",$J,"DCS",BHX)
.Q
K ^TMP("BHSACG",$J,"DCS")
I $D(BHSQUIT) S GMTSQIT=1
D EOJ
Q
;
EOJ ;
K N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W,M,T,T1,T2,T3
Q
EP2(DFN) ;EP - PASS DFN get back array of patient care summary
;at this point you are stuck with ^TMP("BHSACG",$J,"DCS"
K ^TMP("BHSACG",$J,"DCS")
S ^TMP("BHSACG",$J,"DCS",0)=0
D SETARRAY
Q
SETARRAY ;set up array
NEW A,B,C,D,E,G,S,T,V,Y,Z,X,D,N,C,F,I
NEW BHSDX,BHV,BHEDS,BHSS,BHSSGY,BHMEDS,BHCOMB,BHD,BHY
;S X=BHSHDR D S(X)
S X=$$CTR("ANTICOAGULATION PATIENT CARE SUPPLEMENT",80) D S(X)
S X="Report Date: "_$$FMTE^XLFDT(DT) D S(X)
S X="Patient's Name: "_$P(^DPT(DFN,0),U),$E(X,50)="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2)) D S(X,1)
S X="Sex: "_$$SEX^AUPNPAT(DFN),$E(X,15)="DOB: "_$$DOB^AUPNPAT(DFN,"E")_" Age: "_$$AGE^AUPNPAT(DFN) D S(X) ;S Y=$$VAL^XBDIQ1(90181.01,DFN,.02)
S X="DESIGNATED PRIMARY CARE PROVIDER: "_$$VAL^XBDIQ1(9000001,DFN,.14) D S(X)
INDIC ;get all dxs
K BHSDX,DIWL,DIWR
S X="Indication for Anticoagulation Therapy: " D S(X,1)
S X=DFN_"^ALL DX [BJPC AC THRPY INDIC DXS"_";DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(DFN))_"-"_DT S E=$$START1^APCLDF(X,"BHSDX(")
S X=0 F S X=$O(BHSDX(X)) Q:X'=+X S D=$P(BHSDX(X),U),BHSDX("I",(9999999-D),+$P(BHSDX(X),U,4))=BHSDX(X) ;reorder by date
S D=0 F S D=$O(BHSDX("I",D)) Q:D'=+D D
.S I=0 F S I=$O(BHSDX("I",D,I)) Q:I'=+I D
..S C=$P(BHSDX("I",D,I),U,2)
..Q:$D(BHSDX("D",C)) ;already had that dx
..S BHSDX("D",C)=""
..S N=$$VAL^XBDIQ1(9000010.07,I,.04)
..K ^UTILITY($J,"W") S X=N,DIWL=0,DIWR=55 D ^DIWP
..S X=" "_C,$E(X,13)=^UTILITY($J,"W",0,1,0),$E(X,70)=$$D1^APCHSMU((9999999-D)) D S(X)
.I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,13)=^UTILITY($J,"W",0,F,0) D S(X)
INRGOAL ;most recent goal from V ANTICOAG
S X="INR Goal "_$P($$MRGOAL(DFN),U,2) D S(X,1) ;_" (noted: "_$$D1^APCHSMU($P($$MRGOAL(DFN),U,1))_")" D S(X,1)
S X=" Duration of Anticoagulation Therapy",$E(X,60)=$P($$MRDUR(DFN),U,2) D S(X) ;_" (noted: "_$$D1^APCHSMU($P($$MRDUR(DFN),U,1))_")" D S(X)
S X=" Duration of Anticoagulation Therapy Start Date",$E(X,60)=$$D1^APCHSMU($P($$MRSTART(DFN),U,1)) D S(X)
S X=" Duration of Anticoagulation Therapy End Date",$E(X,60)=$$D1^APCHSMU($P($$MREND(DFN),U,1)) D S(X)
CLN ;
N BHSX
S BHSX=$$MRCOM(DFN)
I BHSX]"" D
.D S(" ")
.NEW P S P=$$VAL^XBDIQ1(9000010.51,$P(BHSX,U,3),1204)
.S X="PROVIDER COMMENTS ("_P_$S(P]"":", ",1:"")_$$D1^APCHSMU($P(BHSX,U))_") "_$P(BHSX,U,2)
.K ^UTILITY($J,"W") S DIWL=0,DIWR=70 D ^DIWP
.S P=^UTILITY($J,"W",0,1,0) D S(P)
.I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,3)=^UTILITY($J,"W",0,F,0) D S(X)
.K ^UTILITY($J,"W")
K BHV
S BHV="BHV"
D ALLV^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,.BHV)
S X="ANTICOAGULATION CLINIC VISITS (LAST 100 DAYS):" D S(X,1)
I '$O(BHV(0)) S X="No Anticoagulation clinic visits on file in the past 100 days" D S(X) G INR
S C=0,G=0 F S C=$O(BHV(C)) Q:C'=+C D
.S V=$P(BHV(C),U,5)
.S S=$$CLINIC^APCLV(V,"C")
.Q:S'="D1"
.S G=G+1
.S X=$$D1^APCHSMU($$VD^APCLV(V)),$E(X,20)=$$PRIMPROV^APCLV(V,"N") D S(X)
I 'G S X="No Anticoagulation clinic visits on file in the past 100 days" D S(X)
INR ;get all INR lab tests
S X="INR VALUES AND MEDICATIONS: (LAST 100 DAYS)" D S(X,1)
S X="Date",$E(X,13)="INR Value",$E(X,24)="Medication",$E(X,64)="Provider" D S(X)
K BHV
S BHV="BHV"
D ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,$O(^ATXLAB("B","BJPC INR LAB TESTS",0)),$O(^ATXAX("B","BJPC INR LAB LOINCS",0)),"INR",.BHV)
;get all INR meds in APCHM
K BHMEDS
D GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-160),DT,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.BHMEDS)
;now to list the INR tests in inverse order and try to figure out if they were on a med at that time
COMBBYDT ;combine the inrs and meds inverse by date
K APCHCOMB
N X,C,D,V,I,BHVV,M,O
S X=0,C=0 F S X=$O(BHV(X)) Q:X'=+X D
.S D=$P(BHV(X),U)
.S C=C+1
.S V=$P(BHV(X),U,3)
.S I=$P(BHV(X),U,4)
.S O="???"
.I I S O=$$VAL^XBDIQ1(9000010.09,I,1202)
.S BHCOMB((9999999-D),C)=D_U_V_U_U_O
;get any meds on this date
S X=0,C=0 F S X=$O(BHMEDS(X)) Q:X'=+X D
.S D=$P(BHMEDS(X),U)
.S C=C+1
.S M=$P(BHMEDS(X),U,4)
.S V=$E($P(BHMEDS(X),U,2),1,30)_" Qty: "_$P(^AUPNVMED(M,0),U,6)_" Days: "_$P(^AUPNVMED(M,0),U,7)
.S O="???"
.I M S O=$$VAL^XBDIQ1(9000010.14,M,1202)
.I $D(BHCOMB((9999999-D))) D I 1
..;FIND 1st empty one and use it
..S Y=0,G=0 F S Y=$O(APCHCOMB((9999999-D),Y)) Q:Y'=+Y!(G) D
...I $P(BHCOMB((9999999-D),Y),U,3)="" S $P(BHCOMB((9999999-D),Y),U,3)=V,$P(BHCOMB((9999999-D),Y),U,5)=O
.E S BHCOMB((9999999-D),C)=D_U_U_V_U_U_O
;now write it out to tmp
K BHV,BHMEDS
S BHD=0 F S BHD=$O(BHCOMB(BHD)) Q:BHD'=+BHD D
.S BHY=0 F S BHY=$O(BHCOMB(BHD,BHY)) Q:BHY'=+BHY D
..S BHVV=BHCOMB(BHD,BHY)
..S BHSS=""
..S BHSS=$$D1^APCHSMU($P(BHVV,U,1))
..S $E(BHSS,13)=$P(BHVV,U,2)
..;S $E(BHSS,64)=$E($P(V,U,5),1,15)
..;get med in strings of 34 characters
..S X=$P(BHVV,U,3)
..I X]"" D I 1
...K ^UTILITY($J,"W") S DIWL=0,DIWR=38 D ^DIWP
...S X="",$E(BHSS,24)=^UTILITY($J,"W",0,1,0),$E(BHSS,64)=$E($P(BHVV,U,5),1,15) D S(BHSS)
...I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,24)=^UTILITY($J,"W",0,F,0) D S(X)
..E S $E(BHSS,64)=$E($P(BHVV,U,5),1,15) D S(BHSS)
LAB ;
S X="MOST RECENT RELATED LAB TESTS:" D S(X,1)
S X="Date",$E(X,15)="Test",$E(X,50)="Results" D S(X)
URIN ;last urinalysis on file and its children
K BHV,BHMEDS
S BHV=$$LASTACUR(BHSPAT,$$DOB^AUPNPAT(BHSPAT),DT)
I BHV="" S X="No Urinalysis Tests on File" D S(X) G CBC
I $P(BHV,U,2)["CPT" D G CBC ;display date of cpt
.S X=$$D1^APCHSMU($P(BHV,U)),$E(X,15)=$P(BHV,U,2)_" "_$P(BHV,U,3) D S(X)
;NOW DISPLAY ALL TESTS ON THIS ACCESSION
S L=$P(BHV,U,6),A=$P($G(^AUPNVLAB(L,0)),U,6)
I A]"" D I 1
.S X=$$D1^APCHSMU($P(BHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
.S Y=0 F S Y=$O(^AUPNVLAB("ALR0",A,Y)) Q:Y'=+Y D
..Q:$P($G(^AUPNVLAB(Y,12)),U,8)'=L ;not a child of the urinalysis
..S X="",$E(X,15)=$$VAL^XBDIQ1(9000010.09,Y,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,Y,.04) D S(X)
E S X=$$D1^APCHSMU($P(BHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
CBC ;
D S(" ")
K BHV
S BHV=$$LASTACCB(BHSPAT,$$DOB^AUPNPAT(BHSPAT),DT)
I BHV="" S X="No CBC Tests on File" D S(X) G FOBT
I $P(BHV,U,2)["CPT" D G FOBT ;display date of cpt
.S X=$$D1^APCHSMU($P(BHV,U)),$E(X,15)=$P(BHV,U,2)_" "_$P(BHV,U,3) D S(X)
;NOW DISPLAY ALL TESTS ON THIS ACCESSION
S L=$P(BHV,U,6),A=$P($G(^AUPNVLAB(L,0)),U,6)
I A]"" D I 1
.S X=$$D1^APCHSMU($P(BHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
.S Y=0 F S Y=$O(^AUPNVLAB("ALR0",A,Y)) Q:Y'=+Y D
..Q:$P($G(^AUPNVLAB(Y,12)),U,8)'=L ;not a child of the urinalysis
..S X="",$E(X,15)=$$VAL^XBDIQ1(9000010.09,Y,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,Y,.04) D S(X)
E S X=$$D1^APCHSMU($P(BHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
FOBT ;
D S(" ")
K BHV
S BHV=$$LASTACFO(BHSPAT,$$DOB^AUPNPAT(BHSPAT),DT)
I BHV="" S X="No FOBT Tests on File" D S(X) G VITK
I $P(BHV,U,2)["CPT" D G VITK ;display date of cpt
.S X=$$D1^APCHSMU($P(BHV,U)),$E(X,15)=$P(BHV,U,2)_" "_$P(BHV,U,3) D S(X)
;NOW DISPLAY ALL TESTS ON THIS ACCESSION
S L=$P(BHV,U,6)
S X=$$D1^APCHSMU($P(BHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
VITK ;
S X="VITAMIN K PRESCRIPTION IN THE PAST YEAR:" D S(X,1)
S X="Date",$E(X,15)="Medication/Sig",$E(X,50)="Provider" D S(X)
K BHMEDS
D GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-365),DT,,,,"PHYTONADIONE",.BHMEDS)
I '$O(BHMEDS(0)) S X="No Vitamin K medications dispensed in the past 365 days" D S(X) G PTED
S BHY=999999 F S BHY=$O(BHMEDS(BHY),-1) Q:BHY="" S M=$P(BHMEDS(BHY),U,4) D
.S X=$$D1^APCHSMU($P(BHMEDS(BHY),U)),$E(X,15)=$E($P(BHMEDS(BHY),U,2),1,30),$E(X,50)=$$VAL^XBDIQ1(9000010.14,M,1202) D S(X)
.S BHSIG=$P(^AUPNVMED(M,0),U,5) D SIG
.S X=BHSSGY
.K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
.S X="",$E(X,15)=^UTILITY($J,"W",0,1,0) D S(X)
.I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,15)=^UTILITY($J,"W",0,F,0) D S(X)
PTED ;
S X="PATIENT EDUCATION RELATED TO ANTICOAGULATION IN THE PAST YEAR:" D S(X,1)
S X="Date",$E(X,15)="Topic",$E(X,50)="Provider" D S(X)
K BHEDUC
D EDUC(DFN,$$FMADD^XLFDT(DT,-365),DT,.BHEDUC)
S Y=0 F S Y=$O(BHEDUC(Y)) Q:Y'=+Y D
.S X=$$D1^APCHSMU($P(BHEDUC(Y),U)),$E(X,15)=$$VAL^XBDIQ1(9000010.16,$P(BHEDUC(Y),U,2),.01),$E(X,50)=$$EDPRV($P(BHEDUC(Y),U,2)) D S(X)
D S(" ")
Q
EDPRV(I) ;
NEW Z,V
S Z=$$VAL^XBDIQ1(9000010.16,I,.05) I Z]"" Q Z
S Z=$$VAL^XBDIQ1(9000010.16,I,1204) I Z]"" Q Z
S V=$P(^AUPNVPED(I,0),U,3)
Q $$PRIMPROV^APCLV(V,"N")
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
S BHSSGY="" F BHSP=1:1:$L(BHSIG," ") S X=$P(BHSIG," ",BHSP) I X]"" D
. S Y=$O(^PS(51,"B",X,0)) I Y>0 S X=$P(^PS(51,Y,0),"^",2) I $D(^(9)) S Y=$P(BHSIG," ",BHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S BHSSGY=BHSSGY_X_" "
Q
MRGOAL(P) ;PEP - most recent INR goal and date
I $G(P)="" Q ""
I '$D(^AUPNVACG("AA",P)) Q ""
NEW X,Y,D,R,I,Z,S
S R=""
S D=0 F S D=$O(^AUPNVACG("AA",P,D)) Q:D'=+D!(R]"") D
.S X=0 F S X=$O(^AUPNVACG("AA",P,D,X)) Q:X'=+X!(R]"") D
..S I=0 F S I=$O(^AUPNVACG("AA",P,D,X,I)) Q:I'=+I D
...Q:$P($G(^AUPNVACG(I,0)),U,4)=""
...S Z=$P(^AUPNVACG(I,0),U,4)
...I Z=3 S S=$P(^AUPNVACG(I,0),U,5)_" - "_$P(^AUPNVACG(I,0),U,6)
...I Z'=3 S S=$$VAL^XBDIQ1(9000010.51,I,.04)
...S R=$$VD^APCLV($P(^AUPNVACG(I,0),U,3))_"^"_S
Q R
MRCOM(P) ;PEP - most recent INR goal and date
I $G(P)="" Q ""
I '$D(^AUPNVACG("AA",P)) Q ""
NEW X,Y,D,R,I,Z,S
S R=""
S D=0 F S D=$O(^AUPNVACG("AA",P,D)) Q:D'=+D!(R]"") D
.S X=0 F S X=$O(^AUPNVACG("AA",P,D,X)) Q:X'=+X!(R]"") D
..S I=0 F S I=$O(^AUPNVACG("AA",P,D,X,I)) Q:I'=+I D
...Q:$P($G(^AUPNVACG(I,1)),U,1) ;entered in error
...Q:$P($G(^AUPNVACG(I,11)),U,1)=""
...S Z=$P(^AUPNVACG(I,11),U,1)
...S R=$$VD^APCLV($P(^AUPNVACG(I,0),U,3))_"^"_Z_"^"_I
Q R
MRDUR(P) ;PEP - most recent duration and date
I $G(P)="" Q ""
I '$D(^AUPNVACG("AA",P)) Q ""
NEW X,Y,D,R,I,Z
S R=""
S D=0 F S D=$O(^AUPNVACG("AA",P,D)) Q:D'=+D!(R]"") D
.S X=0 F S X=$O(^AUPNVACG("AA",P,D,X)) Q:X'=+X!(R]"") D
..S I=0 F S I=$O(^AUPNVACG("AA",P,D,X,I)) Q:I'=+I D
...Q:$P($G(^AUPNVACG(I,0)),U,7)=""
...S Z=$$VAL^XBDIQ1(9000010.51,I,.07)
...S R=$$VD^APCLV($P(^AUPNVACG(I,0),U,3))_"^"_Z
Q R
MRSTART(P) ;PEP - most recent duration and date
I $G(P)="" Q ""
I '$D(^AUPNVACG("AA",P)) Q ""
NEW X,Y,D,R,I,Z
S R=""
S D=0 F S D=$O(^AUPNVACG("AA",P,D)) Q:D'=+D!(R]"") D
.S X=0 F S X=$O(^AUPNVACG("AA",P,D,X)) Q:X'=+X!(R]"") D
..S I=0 F S I=$O(^AUPNVACG("AA",P,D,X,I)) Q:I'=+I D
...Q:$P($G(^AUPNVACG(I,0)),U,8)=""
...S Z=$$VAL^XBDIQ1(9000010.51,I,.08)
...S R=$P(^AUPNVACG(I,0),U,8)_"^"_Z
Q R
MREND(P) ;PEP - most recent duration and date
I $G(P)="" Q ""
I '$D(^AUPNVACG("AA",P)) Q ""
NEW X,Y,D,R,I,Z
S R=""
S D=0 F S D=$O(^AUPNVACG("AA",P,D)) Q:D'=+D!(R]"") D
.S X=0 F S X=$O(^AUPNVACG("AA",P,D,X)) Q:X'=+X!(R]"") D
..S I=0 F S I=$O(^AUPNVACG("AA",P,D,X,I)) Q:I'=+I D
...;Q:$P($G(^AUPNVACG(I,0)),U,9)=""
...S Z=$$VAL^XBDIQ1(9000010.51,I,.09)
...S R=$P(^AUPNVACG(I,0),U,9)_"^"_Z
Q R
EDUC(P,BDATE,EDATE,DATA) ;EP pass back array of all asthma educ topics
;any topic that begins with ASM or 493
K DATA
I '$G(P) Q
NEW BHE,X,E,%,G,A,N,D,I,BHX
K BHE
S A="BHE("
S X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,A)
I '$D(BHE) Q
S %=0 F S %=$O(BHE(%)) Q:%'=+% D
.S D=$P(BHE(%),U,1)
.S I=+$P(BHE(%),U,4)
.S N=$P(^AUPNVPED(I,0),U)
.Q:'N
.S N=$P($G(^AUTTEDT(N,0)),U,2)
.I $P(N,"-")="ACC" D
..S BHX(9999999-D,+$P(BHE(%),U,4))=""
S N="",C=0 F S N=$O(BHX(N)) Q:N="" D
.S X=0 F S X=$O(BHX(N,X)) Q:X'=+X S C=C+1 S DATA(C)=(9999999-N)_U_X
K BHE
Q
LASTACUR(P,BD,ED) ;EP
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
NEW R,C
S R=$$LASTLAB^APCLAPIU(BHSPAT,BD,ED,,$O(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0)),,$O(^ATXAX("B","DM AUDIT URINALYSIS LOINC",0)),"A")
S C=$$LASTCPTT^APCLAPIU(DFN,,DT,"BJPC URINALYSIS CPT","A")
I C]"",$P(C,U,1)>$P(R,U,1) Q C
Q R
LASTACCB(P,BD,ED) ;EP
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
NEW R,C
S R=$$LASTLAB^APCLAPIU(BHSPAT,BD,ED,,$O(^ATXLAB("B","BGP CBC TESTS",0)),,$O(^ATXAX("B","BGP CBC LOINC",0)),"A")
S C=$$LASTCPTT^APCLAPIU(DFN,,DT,"BGP CBC CPT","A")
I C]"",$P(C,U,1)>$P(R,U,1) Q C
Q R
LASTACFO(P,BD,ED) ;EP
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
NEW R,C
S R=$$LASTLAB^APCLAPIU(BHSPAT,BD,ED,,$O(^ATXLAB("B","BGP GPRA FOB TESTS",0)),,$O(^ATXAX("B","BGP FOBT LOINC CODES",0)),"A")
S C=$$LASTCPTT^APCLAPIU(DFN,,DT,"BGP FOBT CPTS","A")
I C]"",$P(C,U,1)>$P(R,U,1) Q C
Q R
BHSACG ;IHS/CIA/MGH - Supplement for anti-coag ;14-Jan-2014 15:03;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**4,9**;March 17, 2006;Build 16
+2 ;===================================================================
+3 ; IHS/CMI/LAB - ; ANTI-COAG SUPPLEMENT
+4 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+5 ;Copy of APCHSACG
+6 ;
+7 ;BJPC v2.0 patch 1
S(Y,F,C,T) ;EP - set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW %,X
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("BHSACG",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("BHSACG",$JOB,"DCS",0),U)=%
+2 SET ^TMP("BHSACG",$JOB,"DCS",%)=X
+3 QUIT
CTR(X,Y) ;EP - Center
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EP(DFN) ;PEP - ANTI-COAG supplement
+1 NEW BHX,BHQUIT,BHSX,BHEDUC,BHV,BHSS,BHPG,BHSIG,BHSP,BHSQUIT
+2 NEW X,Y,Z,A,I,B,E,T
+3 DO EP2(DFN)
W ;write out array
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL BHQUIT
+3 SET BHPG=0
+4 SET BHX=0
FOR
SET BHX=$ORDER(^TMP("BHSACG",$JOB,"DCS",BHX))
IF BHX'=+BHX!($DATA(BHSQUIT))
QUIT
Begin DoDot:1
+5 WRITE !,^TMP("BHSACG",$JOB,"DCS",BHX)
+6 QUIT
End DoDot:1
+7 KILL ^TMP("BHSACG",$JOB,"DCS")
+8 IF $DATA(BHSQUIT)
SET GMTSQIT=1
+9 DO EOJ
+10 QUIT
+11 ;
EOJ ;
+1 KILL N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W,M,T,T1,T2,T3
+2 QUIT
EP2(DFN) ;EP - PASS DFN get back array of patient care summary
+1 ;at this point you are stuck with ^TMP("BHSACG",$J,"DCS"
+2 KILL ^TMP("BHSACG",$JOB,"DCS")
+3 SET ^TMP("BHSACG",$JOB,"DCS",0)=0
+4 DO SETARRAY
+5 QUIT
SETARRAY ;set up array
+1 NEW A,B,C,D,E,G,S,T,V,Y,Z,X,D,N,C,F,I
+2 NEW BHSDX,BHV,BHEDS,BHSS,BHSSGY,BHMEDS,BHCOMB,BHD,BHY
+3 ;S X=BHSHDR D S(X)
+4 SET X=$$CTR("ANTICOAGULATION PATIENT CARE SUPPLEMENT",80)
DO S(X)
+5 SET X="Report Date: "_$$FMTE^XLFDT(DT)
DO S(X)
+6 SET X="Patient's Name: "_$PIECE(^DPT(DFN,0),U)
SET $EXTRACT(X,50)="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))
DO S(X,1)
+7 ;S Y=$$VAL^XBDIQ1(90181.01,DFN,.02)
SET X="Sex: "_$$SEX^AUPNPAT(DFN)
SET $EXTRACT(X,15)="DOB: "_$$DOB^AUPNPAT(DFN,"E")_" Age: "_$$AGE^AUPNPAT(DFN)
DO S(X)
+8 SET X="DESIGNATED PRIMARY CARE PROVIDER: "_$$VAL^XBDIQ1(9000001,DFN,.14)
DO S(X)
INDIC ;get all dxs
+1 KILL BHSDX,DIWL,DIWR
+2 SET X="Indication for Anticoagulation Therapy: "
DO S(X,1)
+3 SET X=DFN_"^ALL DX [BJPC AC THRPY INDIC DXS"_";DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(DFN))_"-"_DT
SET E=$$START1^APCLDF(X,"BHSDX(")
+4 ;reorder by date
SET X=0
FOR
SET X=$ORDER(BHSDX(X))
IF X'=+X
QUIT
SET D=$PIECE(BHSDX(X),U)
SET BHSDX("I",(9999999-D),+$PIECE(BHSDX(X),U,4))=BHSDX(X)
+5 SET D=0
FOR
SET D=$ORDER(BHSDX("I",D))
IF D'=+D
QUIT
Begin DoDot:1
+6 SET I=0
FOR
SET I=$ORDER(BHSDX("I",D,I))
IF I'=+I
QUIT
Begin DoDot:2
+7 SET C=$PIECE(BHSDX("I",D,I),U,2)
+8 ;already had that dx
IF $DATA(BHSDX("D",C))
QUIT
+9 SET BHSDX("D",C)=""
+10 SET N=$$VAL^XBDIQ1(9000010.07,I,.04)
+11 KILL ^UTILITY($JOB,"W")
SET X=N
SET DIWL=0
SET DIWR=55
DO ^DIWP
+12 SET X=" "_C
SET $EXTRACT(X,13)=^UTILITY($JOB,"W",0,1,0)
SET $EXTRACT(X,70)=$$D1^APCHSMU((9999999-D))
DO S(X)
End DoDot:2
+13 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,13)=^UTILITY($JOB,"W",0,F,0)
DO S(X)
End DoDot:1
INRGOAL ;most recent goal from V ANTICOAG
+1 ;_" (noted: "_$$D1^APCHSMU($P($$MRGOAL(DFN),U,1))_")" D S(X,1)
SET X="INR Goal "_$PIECE($$MRGOAL(DFN),U,2)
DO S(X,1)
+2 ;_" (noted: "_$$D1^APCHSMU($P($$MRDUR(DFN),U,1))_")" D S(X)
SET X=" Duration of Anticoagulation Therapy"
SET $EXTRACT(X,60)=$PIECE($$MRDUR(DFN),U,2)
DO S(X)
+3 SET X=" Duration of Anticoagulation Therapy Start Date"
SET $EXTRACT(X,60)=$$D1^APCHSMU($PIECE($$MRSTART(DFN),U,1))
DO S(X)
+4 SET X=" Duration of Anticoagulation Therapy End Date"
SET $EXTRACT(X,60)=$$D1^APCHSMU($PIECE($$MREND(DFN),U,1))
DO S(X)
CLN ;
+1 NEW BHSX
+2 SET BHSX=$$MRCOM(DFN)
+3 IF BHSX]""
Begin DoDot:1
+4 DO S(" ")
+5 NEW P
SET P=$$VAL^XBDIQ1(9000010.51,$PIECE(BHSX,U,3),1204)
+6 SET X="PROVIDER COMMENTS ("_P_$SELECT(P]"":", ",1:"")_$$D1^APCHSMU($PIECE(BHSX,U))_") "_$PIECE(BHSX,U,2)
+7 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=70
DO ^DIWP
+8 SET P=^UTILITY($JOB,"W",0,1,0)
DO S(P)
+9 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,3)=^UTILITY($JOB,"W",0,F,0)
DO S(X)
+10 KILL ^UTILITY($JOB,"W")
End DoDot:1
+11 KILL BHV
+12 SET BHV="BHV"
+13 DO ALLV^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,.BHV)
+14 SET X="ANTICOAGULATION CLINIC VISITS (LAST 100 DAYS):"
DO S(X,1)
+15 IF '$ORDER(BHV(0))
SET X="No Anticoagulation clinic visits on file in the past 100 days"
DO S(X)
GOTO INR
+16 SET C=0
SET G=0
FOR
SET C=$ORDER(BHV(C))
IF C'=+C
QUIT
Begin DoDot:1
+17 SET V=$PIECE(BHV(C),U,5)
+18 SET S=$$CLINIC^APCLV(V,"C")
+19 IF S'="D1"
QUIT
+20 SET G=G+1
+21 SET X=$$D1^APCHSMU($$VD^APCLV(V))
SET $EXTRACT(X,20)=$$PRIMPROV^APCLV(V,"N")
DO S(X)
End DoDot:1
+22 IF 'G
SET X="No Anticoagulation clinic visits on file in the past 100 days"
DO S(X)
INR ;get all INR lab tests
+1 SET X="INR VALUES AND MEDICATIONS: (LAST 100 DAYS)"
DO S(X,1)
+2 SET X="Date"
SET $EXTRACT(X,13)="INR Value"
SET $EXTRACT(X,24)="Medication"
SET $EXTRACT(X,64)="Provider"
DO S(X)
+3 KILL BHV
+4 SET BHV="BHV"
+5 DO ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,$ORDER(^ATXLAB("B","BJPC INR LAB TESTS",0)),$ORDER(^ATXAX("B","BJPC INR LAB LOINCS",0)),"INR",.BHV)
+6 ;get all INR meds in APCHM
+7 KILL BHMEDS
+8 DO GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-160),DT,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.BHMEDS)
+9 ;now to list the INR tests in inverse order and try to figure out if they were on a med at that time
COMBBYDT ;combine the inrs and meds inverse by date
+1 KILL APCHCOMB
+2 NEW X,C,D,V,I,BHVV,M,O
+3 SET X=0
SET C=0
FOR
SET X=$ORDER(BHV(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET D=$PIECE(BHV(X),U)
+5 SET C=C+1
+6 SET V=$PIECE(BHV(X),U,3)
+7 SET I=$PIECE(BHV(X),U,4)
+8 SET O="???"
+9 IF I
SET O=$$VAL^XBDIQ1(9000010.09,I,1202)
+10 SET BHCOMB((9999999-D),C)=D_U_V_U_U_O
End DoDot:1
+11 ;get any meds on this date
+12 SET X=0
SET C=0
FOR
SET X=$ORDER(BHMEDS(X))
IF X'=+X
QUIT
Begin DoDot:1
+13 SET D=$PIECE(BHMEDS(X),U)
+14 SET C=C+1
+15 SET M=$PIECE(BHMEDS(X),U,4)
+16 SET V=$EXTRACT($PIECE(BHMEDS(X),U,2),1,30)_" Qty: "_$PIECE(^AUPNVMED(M,0),U,6)_" Days: "_$PIECE(^AUPNVMED(M,0),U,7)
+17 SET O="???"
+18 IF M
SET O=$$VAL^XBDIQ1(9000010.14,M,1202)
+19 IF $DATA(BHCOMB((9999999-D)))
Begin DoDot:2
+20 ;FIND 1st empty one and use it
+21 SET Y=0
SET G=0
FOR
SET Y=$ORDER(APCHCOMB((9999999-D),Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+22 IF $PIECE(BHCOMB((9999999-D),Y),U,3)=""
SET $PIECE(BHCOMB((9999999-D),Y),U,3)=V
SET $PIECE(BHCOMB((9999999-D),Y),U,5)=O
End DoDot:3
End DoDot:2
IF 1
+23 IF '$TEST
SET BHCOMB((9999999-D),C)=D_U_U_V_U_U_O
End DoDot:1
+24 ;now write it out to tmp
+25 KILL BHV,BHMEDS
+26 SET BHD=0
FOR
SET BHD=$ORDER(BHCOMB(BHD))
IF BHD'=+BHD
QUIT
Begin DoDot:1
+27 SET BHY=0
FOR
SET BHY=$ORDER(BHCOMB(BHD,BHY))
IF BHY'=+BHY
QUIT
Begin DoDot:2
+28 SET BHVV=BHCOMB(BHD,BHY)
+29 SET BHSS=""
+30 SET BHSS=$$D1^APCHSMU($PIECE(BHVV,U,1))
+31 SET $EXTRACT(BHSS,13)=$PIECE(BHVV,U,2)
+32 ;S $E(BHSS,64)=$E($P(V,U,5),1,15)
+33 ;get med in strings of 34 characters
+34 SET X=$PIECE(BHVV,U,3)
+35 IF X]""
Begin DoDot:3
+36 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=38
DO ^DIWP
+37 SET X=""
SET $EXTRACT(BHSS,24)=^UTILITY($JOB,"W",0,1,0)
SET $EXTRACT(BHSS,64)=$EXTRACT($PIECE(BHVV,U,5),1,15)
DO S(BHSS)
+38 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,24)=^UTILITY($JOB,"W",0,F,0)
DO S(X)
End DoDot:3
IF 1
+39 IF '$TEST
SET $EXTRACT(BHSS,64)=$EXTRACT($PIECE(BHVV,U,5),1,15)
DO S(BHSS)
End DoDot:2
End DoDot:1
LAB ;
+1 SET X="MOST RECENT RELATED LAB TESTS:"
DO S(X,1)
+2 SET X="Date"
SET $EXTRACT(X,15)="Test"
SET $EXTRACT(X,50)="Results"
DO S(X)
URIN ;last urinalysis on file and its children
+1 KILL BHV,BHMEDS
+2 SET BHV=$$LASTACUR(BHSPAT,$$DOB^AUPNPAT(BHSPAT),DT)
+3 IF BHV=""
SET X="No Urinalysis Tests on File"
DO S(X)
GOTO CBC
+4 ;display date of cpt
IF $PIECE(BHV,U,2)["CPT"
Begin DoDot:1
+5 SET X=$$D1^APCHSMU($PIECE(BHV,U))
SET $EXTRACT(X,15)=$PIECE(BHV,U,2)_" "_$PIECE(BHV,U,3)
DO S(X)
End DoDot:1
GOTO CBC
+6 ;NOW DISPLAY ALL TESTS ON THIS ACCESSION
+7 SET L=$PIECE(BHV,U,6)
SET A=$PIECE($GET(^AUPNVLAB(L,0)),U,6)
+8 IF A]""
Begin DoDot:1
+9 SET X=$$D1^APCHSMU($PIECE(BHV,U,1))
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04)
DO S(X)
+10 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("ALR0",A,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+11 ;not a child of the urinalysis
IF $PIECE($GET(^AUPNVLAB(Y,12)),U,8)'=L
QUIT
+12 SET X=""
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.09,Y,.01)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.09,Y,.04)
DO S(X)
End DoDot:2
End DoDot:1
IF 1
+13 IF '$TEST
SET X=$$D1^APCHSMU($PIECE(BHV,U,1))
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04)
DO S(X)
CBC ;
+1 DO S(" ")
+2 KILL BHV
+3 SET BHV=$$LASTACCB(BHSPAT,$$DOB^AUPNPAT(BHSPAT),DT)
+4 IF BHV=""
SET X="No CBC Tests on File"
DO S(X)
GOTO FOBT
+5 ;display date of cpt
IF $PIECE(BHV,U,2)["CPT"
Begin DoDot:1
+6 SET X=$$D1^APCHSMU($PIECE(BHV,U))
SET $EXTRACT(X,15)=$PIECE(BHV,U,2)_" "_$PIECE(BHV,U,3)
DO S(X)
End DoDot:1
GOTO FOBT
+7 ;NOW DISPLAY ALL TESTS ON THIS ACCESSION
+8 SET L=$PIECE(BHV,U,6)
SET A=$PIECE($GET(^AUPNVLAB(L,0)),U,6)
+9 IF A]""
Begin DoDot:1
+10 SET X=$$D1^APCHSMU($PIECE(BHV,U,1))
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04)
DO S(X)
+11 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("ALR0",A,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+12 ;not a child of the urinalysis
IF $PIECE($GET(^AUPNVLAB(Y,12)),U,8)'=L
QUIT
+13 SET X=""
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.09,Y,.01)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.09,Y,.04)
DO S(X)
End DoDot:2
End DoDot:1
IF 1
+14 IF '$TEST
SET X=$$D1^APCHSMU($PIECE(BHV,U,1))
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04)
DO S(X)
FOBT ;
+1 DO S(" ")
+2 KILL BHV
+3 SET BHV=$$LASTACFO(BHSPAT,$$DOB^AUPNPAT(BHSPAT),DT)
+4 IF BHV=""
SET X="No FOBT Tests on File"
DO S(X)
GOTO VITK
+5 ;display date of cpt
IF $PIECE(BHV,U,2)["CPT"
Begin DoDot:1
+6 SET X=$$D1^APCHSMU($PIECE(BHV,U))
SET $EXTRACT(X,15)=$PIECE(BHV,U,2)_" "_$PIECE(BHV,U,3)
DO S(X)
End DoDot:1
GOTO VITK
+7 ;NOW DISPLAY ALL TESTS ON THIS ACCESSION
+8 SET L=$PIECE(BHV,U,6)
+9 SET X=$$D1^APCHSMU($PIECE(BHV,U,1))
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04)
DO S(X)
VITK ;
+1 SET X="VITAMIN K PRESCRIPTION IN THE PAST YEAR:"
DO S(X,1)
+2 SET X="Date"
SET $EXTRACT(X,15)="Medication/Sig"
SET $EXTRACT(X,50)="Provider"
DO S(X)
+3 KILL BHMEDS
+4 DO GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-365),DT,,,,"PHYTONADIONE",.BHMEDS)
+5 IF '$ORDER(BHMEDS(0))
SET X="No Vitamin K medications dispensed in the past 365 days"
DO S(X)
GOTO PTED
+6 SET BHY=999999
FOR
SET BHY=$ORDER(BHMEDS(BHY),-1)
IF BHY=""
QUIT
SET M=$PIECE(BHMEDS(BHY),U,4)
Begin DoDot:1
+7 SET X=$$D1^APCHSMU($PIECE(BHMEDS(BHY),U))
SET $EXTRACT(X,15)=$EXTRACT($PIECE(BHMEDS(BHY),U,2),1,30)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.14,M,1202)
DO S(X)
+8 SET BHSIG=$PIECE(^AUPNVMED(M,0),U,5)
DO SIG
+9 SET X=BHSSGY
+10 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=60
DO ^DIWP
+11 SET X=""
SET $EXTRACT(X,15)=^UTILITY($JOB,"W",0,1,0)
DO S(X)
+12 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,15)=^UTILITY($JOB,"W",0,F,0)
DO S(X)
End DoDot:1
PTED ;
+1 SET X="PATIENT EDUCATION RELATED TO ANTICOAGULATION IN THE PAST YEAR:"
DO S(X,1)
+2 SET X="Date"
SET $EXTRACT(X,15)="Topic"
SET $EXTRACT(X,50)="Provider"
DO S(X)
+3 KILL BHEDUC
+4 DO EDUC(DFN,$$FMADD^XLFDT(DT,-365),DT,.BHEDUC)
+5 SET Y=0
FOR
SET Y=$ORDER(BHEDUC(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+6 SET X=$$D1^APCHSMU($PIECE(BHEDUC(Y),U))
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.16,$PIECE(BHEDUC(Y),U,2),.01)
SET $EXTRACT(X,50)=$$EDPRV($PIECE(BHEDUC(Y),U,2))
DO S(X)
End DoDot:1
+7 DO S(" ")
+8 QUIT
EDPRV(I) ;
+1 NEW Z,V
+2 SET Z=$$VAL^XBDIQ1(9000010.16,I,.05)
IF Z]""
QUIT Z
+3 SET Z=$$VAL^XBDIQ1(9000010.16,I,1204)
IF Z]""
QUIT Z
+4 SET V=$PIECE(^AUPNVPED(I,0),U,3)
+5 QUIT $$PRIMPROV^APCLV(V,"N")
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 SET BHSSGY=""
FOR BHSP=1:1:$LENGTH(BHSIG," ")
SET X=$PIECE(BHSIG," ",BHSP)
IF X]""
Begin DoDot:1
+2 SET Y=$ORDER(^PS(51,"B",X,0))
IF Y>0
SET X=$PIECE(^PS(51,Y,0),"^",2)
IF $DATA(^(9))
SET Y=$PIECE(BHSIG," ",BHSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+3 SET BHSSGY=BHSSGY_X_" "
End DoDot:1
+4 QUIT
MRGOAL(P) ;PEP - most recent INR goal and date
+1 IF $GET(P)=""
QUIT ""
+2 IF '$DATA(^AUPNVACG("AA",P))
QUIT ""
+3 NEW X,Y,D,R,I,Z,S
+4 SET R=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVACG("AA",P,D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVACG("AA",P,D,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:2
+7 SET I=0
FOR
SET I=$ORDER(^AUPNVACG("AA",P,D,X,I))
IF I'=+I
QUIT
Begin DoDot:3
+8 IF $PIECE($GET(^AUPNVACG(I,0)),U,4)=""
QUIT
+9 SET Z=$PIECE(^AUPNVACG(I,0),U,4)
+10 IF Z=3
SET S=$PIECE(^AUPNVACG(I,0),U,5)_" - "_$PIECE(^AUPNVACG(I,0),U,6)
+11 IF Z'=3
SET S=$$VAL^XBDIQ1(9000010.51,I,.04)
+12 SET R=$$VD^APCLV($PIECE(^AUPNVACG(I,0),U,3))_"^"_S
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT R
MRCOM(P) ;PEP - most recent INR goal and date
+1 IF $GET(P)=""
QUIT ""
+2 IF '$DATA(^AUPNVACG("AA",P))
QUIT ""
+3 NEW X,Y,D,R,I,Z,S
+4 SET R=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVACG("AA",P,D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVACG("AA",P,D,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:2
+7 SET I=0
FOR
SET I=$ORDER(^AUPNVACG("AA",P,D,X,I))
IF I'=+I
QUIT
Begin DoDot:3
+8 ;entered in error
IF $PIECE($GET(^AUPNVACG(I,1)),U,1)
QUIT
+9 IF $PIECE($GET(^AUPNVACG(I,11)),U,1)=""
QUIT
+10 SET Z=$PIECE(^AUPNVACG(I,11),U,1)
+11 SET R=$$VD^APCLV($PIECE(^AUPNVACG(I,0),U,3))_"^"_Z_"^"_I
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT R
MRDUR(P) ;PEP - most recent duration and date
+1 IF $GET(P)=""
QUIT ""
+2 IF '$DATA(^AUPNVACG("AA",P))
QUIT ""
+3 NEW X,Y,D,R,I,Z
+4 SET R=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVACG("AA",P,D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVACG("AA",P,D,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:2
+7 SET I=0
FOR
SET I=$ORDER(^AUPNVACG("AA",P,D,X,I))
IF I'=+I
QUIT
Begin DoDot:3
+8 IF $PIECE($GET(^AUPNVACG(I,0)),U,7)=""
QUIT
+9 SET Z=$$VAL^XBDIQ1(9000010.51,I,.07)
+10 SET R=$$VD^APCLV($PIECE(^AUPNVACG(I,0),U,3))_"^"_Z
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT R
MRSTART(P) ;PEP - most recent duration and date
+1 IF $GET(P)=""
QUIT ""
+2 IF '$DATA(^AUPNVACG("AA",P))
QUIT ""
+3 NEW X,Y,D,R,I,Z
+4 SET R=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVACG("AA",P,D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVACG("AA",P,D,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:2
+7 SET I=0
FOR
SET I=$ORDER(^AUPNVACG("AA",P,D,X,I))
IF I'=+I
QUIT
Begin DoDot:3
+8 IF $PIECE($GET(^AUPNVACG(I,0)),U,8)=""
QUIT
+9 SET Z=$$VAL^XBDIQ1(9000010.51,I,.08)
+10 SET R=$PIECE(^AUPNVACG(I,0),U,8)_"^"_Z
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT R
MREND(P) ;PEP - most recent duration and date
+1 IF $GET(P)=""
QUIT ""
+2 IF '$DATA(^AUPNVACG("AA",P))
QUIT ""
+3 NEW X,Y,D,R,I,Z
+4 SET R=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVACG("AA",P,D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVACG("AA",P,D,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:2
+7 SET I=0
FOR
SET I=$ORDER(^AUPNVACG("AA",P,D,X,I))
IF I'=+I
QUIT
Begin DoDot:3
+8 ;Q:$P($G(^AUPNVACG(I,0)),U,9)=""
+9 SET Z=$$VAL^XBDIQ1(9000010.51,I,.09)
+10 SET R=$PIECE(^AUPNVACG(I,0),U,9)_"^"_Z
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT R
EDUC(P,BDATE,EDATE,DATA) ;EP pass back array of all asthma educ topics
+1 ;any topic that begins with ASM or 493
+2 KILL DATA
+3 IF '$GET(P)
QUIT
+4 NEW BHE,X,E,%,G,A,N,D,I,BHX
+5 KILL BHE
+6 SET A="BHE("
+7 SET X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,A)
+8 IF '$DATA(BHE)
QUIT
+9 SET %=0
FOR
SET %=$ORDER(BHE(%))
IF %'=+%
QUIT
Begin DoDot:1
+10 SET D=$PIECE(BHE(%),U,1)
+11 SET I=+$PIECE(BHE(%),U,4)
+12 SET N=$PIECE(^AUPNVPED(I,0),U)
+13 IF 'N
QUIT
+14 SET N=$PIECE($GET(^AUTTEDT(N,0)),U,2)
+15 IF $PIECE(N,"-")="ACC"
Begin DoDot:2
+16 SET BHX(9999999-D,+$PIECE(BHE(%),U,4))=""
End DoDot:2
End DoDot:1
+17 SET N=""
SET C=0
FOR
SET N=$ORDER(BHX(N))
IF N=""
QUIT
Begin DoDot:1
+18 SET X=0
FOR
SET X=$ORDER(BHX(N,X))
IF X'=+X
QUIT
SET C=C+1
SET DATA(C)=(9999999-N)_U_X
End DoDot:1
+19 KILL BHE
+20 QUIT
LASTACUR(P,BD,ED) ;EP
+1 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+2 IF $GET(ED)=""
SET ED=DT
+3 NEW R,C
+4 SET R=$$LASTLAB^APCLAPIU(BHSPAT,BD,ED,,$ORDER(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0)),,$ORDER(^ATXAX("B","DM AUDIT URINALYSIS LOINC",0)),"A")
+5 SET C=$$LASTCPTT^APCLAPIU(DFN,,DT,"BJPC URINALYSIS CPT","A")
+6 IF C]""
IF $PIECE(C,U,1)>$PIECE(R,U,1)
QUIT C
+7 QUIT R
LASTACCB(P,BD,ED) ;EP
+1 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+2 IF $GET(ED)=""
SET ED=DT
+3 NEW R,C
+4 SET R=$$LASTLAB^APCLAPIU(BHSPAT,BD,ED,,$ORDER(^ATXLAB("B","BGP CBC TESTS",0)),,$ORDER(^ATXAX("B","BGP CBC LOINC",0)),"A")
+5 SET C=$$LASTCPTT^APCLAPIU(DFN,,DT,"BGP CBC CPT","A")
+6 IF C]""
IF $PIECE(C,U,1)>$PIECE(R,U,1)
QUIT C
+7 QUIT R
LASTACFO(P,BD,ED) ;EP
+1 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+2 IF $GET(ED)=""
SET ED=DT
+3 NEW R,C
+4 SET R=$$LASTLAB^APCLAPIU(BHSPAT,BD,ED,,$ORDER(^ATXLAB("B","BGP GPRA FOB TESTS",0)),,$ORDER(^ATXAX("B","BGP FOBT LOINC CODES",0)),"A")
+5 SET C=$$LASTCPTT^APCLAPIU(DFN,,DT,"BGP FOBT CPTS","A")
+6 IF C]""
IF $PIECE(C,U,1)>$PIECE(R,U,1)
QUIT C
+7 QUIT R
