APCHSACG ; IHS/CMI/LAB - ; ANTI-COAG SUPPLEMENT
;;2.0;IHS PCC SUITE;**2,8,10**;MAY 14, 2009;Build 88
;
;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("APCHACG",$J,"DCS",0),U)+1,$P(^TMP("APCHACG",$J,"DCS",0),U)=%
S ^TMP("APCHACG",$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 APCHX,APCHQUIT,APCHSX,APCHEDUC,APCHV,APCHSS
NEW X,Y,Z,A,I,B,E,T
D EP2(DFN)
W ;write out array
W:$D(IOF) @IOF
K APCHQUIT
S APCHPG=0
S APCHX=0 F S APCHX=$O(^TMP("APCHACG",$J,"DCS",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT)) D
.I $Y>(IOSL-3) D HEADER Q:$D(APCHQUIT)
.W !,^TMP("APCHACG",$J,"DCS",APCHX)
.Q
K ^TMP("APCHACG",$J,"DCS")
I $D(APCHQUIT) S APCHSQIT=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
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
S APCHPG=APCHPG+1
W !,APCHSHDR,!
W $$CTR("ANTICOAGULATION PATIENT CARE SUPPLEMENT",80),!
W "Report Date: ",$$FMTE^XLFDT(DT),?70,"Page: ",APCHPG,!
Q
EP2(DFN) ;EP - PASS DFN get back array of patient care summary
;at this point you are stuck with ^TMP("APCHACG",$J,"DCS"
K ^TMP("APCHACG",$J,"DCS")
S ^TMP("APCHACG",$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 APCHSDX,APCHV,APCHEDS,APCHSS,APCHSSGY,APCHMEDS,APCHCOMB,APCHD,APCHY
S X=APCHSHDR D S(X)
S X=$$CTR("ANTICOAGULATION PATIENT CARE SUPPLEMENT",80) D S(X)
S X="Report Date: "_$$FMTE^XLFDT(DT),$E(X,70)="Page 1" 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 APCHSDX
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,"APCHSDX(")
S X=0 F S X=$O(APCHSDX(X)) Q:X'=+X S D=$P(APCHSDX(X),U),APCHSDX("I",(9999999-D),+$P(APCHSDX(X),U,4))=APCHSDX(X) ;reorder by date
S D=0 F S D=$O(APCHSDX("I",D)) Q:D'=+D D
.S I=0 F S I=$O(APCHSDX("I",D,I)) Q:I'=+I D
..S C=$P(APCHSDX("I",D,I),U,2)
..Q:$D(APCHSDX("D",C)) ;already had that dx
..S APCHSDX("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 ;
;display comments if there are any
S APCHX=$$MRCOM(DFN)
I APCHX]"" D
.D S(" ")
.NEW P S P=$$VAL^XBDIQ1(9000010.51,$P(APCHX,U,3),1204)
.S X="PROVIDER COMMENTS ("_P_$S(P]"":", ",1:"")_$$D1^APCHSMU($P(APCHX,U))_") "_$P(APCHX,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 APCHV
S APCHV="APCHV"
D ALLV^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,.APCHV)
S X="ANTICOAGULATION CLINIC VISITS (LAST 100 DAYS):" D S(X,1)
I '$O(APCHV(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(APCHV(C)) Q:C'=+C D
.S V=$P(APCHV(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 APCHV
S APCHV="APCHV"
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",.APCHV)
;get all INR meds in APCHM
K APCHMEDS
D GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-160),DT,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCHMEDS)
;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
S X=0,C=0 F S X=$O(APCHV(X)) Q:X'=+X D
.S D=$P(APCHV(X),U)
.S C=C+1
.S V=$P(APCHV(X),U,3)
.S I=$P(APCHV(X),U,4)
.S O="???"
.I I S O=$$VAL^XBDIQ1(9000010.09,I,1202)
.S APCHCOMB((9999999-D),C)=D_U_V_U_U_O
;get any meds on this date
S X=0,C=0 F S X=$O(APCHMEDS(X)) Q:X'=+X D
.S D=$P(APCHMEDS(X),U)
.S C=C+1
.S M=$P(APCHMEDS(X),U,4)
.S V=$E($P(APCHMEDS(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(APCHCOMB((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(APCHCOMB((9999999-D),Y),U,3)="" S $P(APCHCOMB((9999999-D),Y),U,3)=V,$P(APCHCOMB((9999999-D),Y),U,5)=O
.E S APCHCOMB((9999999-D),C)=D_U_U_V_U_U_O
;now write it out to tmp
K APCHV,APCHMEDS
S APCHD=0 F S APCHD=$O(APCHCOMB(APCHD)) Q:APCHD'=+APCHD D
.S APCHY=0 F S APCHY=$O(APCHCOMB(APCHD,APCHY)) Q:APCHY'=+APCHY D
..S APCHVV=APCHCOMB(APCHD,APCHY)
..S APCHSS=""
..S APCHSS=$$D1^APCHSMU($P(APCHVV,U,1))
..S $E(APCHSS,13)=$P(APCHVV,U,2)
..;S $E(APCHSS,64)=$E($P(V,U,5),1,15)
..;get med in strings of 34 characters
..S X=$P(APCHVV,U,3)
..I X]"" D I 1
...K ^UTILITY($J,"W") S DIWL=0,DIWR=38 D ^DIWP
...S X="",$E(APCHSS,24)=^UTILITY($J,"W",0,1,0),$E(APCHSS,64)=$E($P(APCHVV,U,5),1,15) D S(APCHSS)
...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(APCHSS,64)=$E($P(APCHVV,U,5),1,15) D S(APCHSS)
..K ^UTILITY($J,"W")
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 APCHV,APCHMEDS
;S APCHV=$$LASTACUR(APCHSPAT,$$DOB^AUPNPAT(APCHSPAT),DT)
;I APCHV="" S X="No Urinalysis Tests on File" D S(X) G CBC
;I $P(APCHV,U,2)["CPT" D G CBC ;display date of cpt
;.S X=$$D1^APCHSMU($P(APCHV,U)),$E(X,15)=$P(APCHV,U,2)_" "_$P(APCHV,U,3) D S(X)
;NOW DISPLAY ALL TESTS ON THIS ACCESSION
;S L=$P(APCHV,U,6),A=$P($G(^AUPNVLAB(L,0)),U,6)
;I A]"" D I 1
;.S X=$$D1^APCHSMU($P(APCHV,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(APCHV,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 APCHV
;S APCHV=$$LASTACCB(APCHSPAT,$$DOB^AUPNPAT(APCHSPAT),DT)
;I APCHV="" S X="No CBC Tests on File" D S(X) G FOBT
;I $P(APCHV,U,2)["CPT" D G FOBT ;display date of cpt
;.S X=$$D1^APCHSMU($P(APCHV,U)),$E(X,15)=$P(APCHV,U,2)_" "_$P(APCHV,U,3) D S(X)
;NOW DISPLAY ALL TESTS ON THIS ACCESSION
;S L=$P(APCHV,U,6),A=$P($G(^AUPNVLAB(L,0)),U,6)
;I A]"" D I 1
;.S X=$$D1^APCHSMU($P(APCHV,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(APCHV,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 APCHV
;S APCHV=$$LASTACFO(APCHSPAT,$$DOB^AUPNPAT(APCHSPAT),DT)
;I APCHV="" S X="No FOBT Tests on File" D S(X) G VITK
;I $P(APCHV,U,2)["CPT" D G VITK ;display date of cpt
;.S X=$$D1^APCHSMU($P(APCHV,U)),$E(X,15)=$P(APCHV,U,2)_" "_$P(APCHV,U,3) D S(X)
;NOW DISPLAY ALL TESTS ON THIS ACCESSION
;S L=$P(APCHV,U,6)
;S X=$$D1^APCHSMU($P(APCHV,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 APCHMEDS
D GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-365),DT,,,,"PHYTONADIONE",.APCHMEDS)
I '$O(APCHMEDS(0)) S X="No Vitamin K medications dispensed in the past 365 days" D S(X) G PTED
S APCHY=999999 F S APCHY=$O(APCHMEDS(APCHY),-1) Q:APCHY="" S M=$P(APCHMEDS(APCHY),U,4) D
.S X=$$D1^APCHSMU($P(APCHMEDS(APCHY),U)),$E(X,15)=$E($P(APCHMEDS(APCHY),U,2),1,30),$E(X,50)=$$VAL^XBDIQ1(9000010.14,M,1202) D S(X)
.S APCHSIG=$P(^AUPNVMED(M,0),U,5) D SIG
.S X=APCHSSGY
.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 APCHEDUC
D EDUC(DFN,$$FMADD^XLFDT(DT,-365),DT,.APCHEDUC)
S Y=0 F S Y=$O(APCHEDUC(Y)) Q:Y'=+Y D
.S X=$$D1^APCHSMU($P(APCHEDUC(Y),U)),$E(X,15)=$$VAL^XBDIQ1(9000010.16,$P(APCHEDUC(Y),U,2),.01),$E(X,50)=$$EDPRV($P(APCHEDUC(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 APCHSSGY="" F APCHSP=1:1:$L(APCHSIG," ") S X=$P(APCHSIG," ",APCHSP) 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(APCHSIG," ",APCHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S APCHSSGY=APCHSSGY_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,1)),U,1) ;entered in error
...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,1)),U,1) ;entered in error
...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_"^"_I
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,1)),U,1) ;entered in error
...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,1)),U,1) ;entered in error
...;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 anti coag educ topics
K DATA
I '$G(P) Q
NEW APCHE,X,E,%,G,A,N,D,I,APCHX
K APCHE
S A="APCHE("
S X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,A)
I '$D(APCHE) Q
S %=0 F S %=$O(APCHE(%)) Q:%'=+% D
.S D=$P(APCHE(%),U,1)
.S I=+$P(APCHE(%),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 APCHX(9999999-D,+$P(APCHE(%),U,4))=""
S N="",C=0 F S N=$O(APCHX(N)) Q:N="" D
.S X=0 F S X=$O(APCHX(N,X)) Q:X'=+X S C=C+1 S DATA(C)=(9999999-N)_U_X
K APCHE
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(APCHSPAT,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(APCHSPAT,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(APCHSPAT,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
APCHSACG ; IHS/CMI/LAB - ; ANTI-COAG SUPPLEMENT
+1 ;;2.0;IHS PCC SUITE;**2,8,10**;MAY 14, 2009;Build 88
+2 ;
+3 ;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("APCHACG",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("APCHACG",$JOB,"DCS",0),U)=%
+2 SET ^TMP("APCHACG",$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 APCHX,APCHQUIT,APCHSX,APCHEDUC,APCHV,APCHSS
+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 APCHQUIT
+3 SET APCHPG=0
+4 SET APCHX=0
FOR
SET APCHX=$ORDER(^TMP("APCHACG",$JOB,"DCS",APCHX))
IF APCHX'=+APCHX!($DATA(APCHQUIT))
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(APCHQUIT)
QUIT
+6 WRITE !,^TMP("APCHACG",$JOB,"DCS",APCHX)
+7 QUIT
End DoDot:1
+8 KILL ^TMP("APCHACG",$JOB,"DCS")
+9 IF $DATA(APCHQUIT)
SET APCHSQIT=1
+10 DO EOJ
+11 QUIT
+12 ;
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
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCHQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 SET APCHPG=APCHPG+1
+3 WRITE !,APCHSHDR,!
+4 WRITE $$CTR("ANTICOAGULATION PATIENT CARE SUPPLEMENT",80),!
+5 WRITE "Report Date: ",$$FMTE^XLFDT(DT),?70,"Page: ",APCHPG,!
+6 QUIT
EP2(DFN) ;EP - PASS DFN get back array of patient care summary
+1 ;at this point you are stuck with ^TMP("APCHACG",$J,"DCS"
+2 KILL ^TMP("APCHACG",$JOB,"DCS")
+3 SET ^TMP("APCHACG",$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 APCHSDX,APCHV,APCHEDS,APCHSS,APCHSSGY,APCHMEDS,APCHCOMB,APCHD,APCHY
+3 SET X=APCHSHDR
DO S(X)
+4 SET X=$$CTR("ANTICOAGULATION PATIENT CARE SUPPLEMENT",80)
DO S(X)
+5 SET X="Report Date: "_$$FMTE^XLFDT(DT)
SET $EXTRACT(X,70)="Page 1"
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 APCHSDX
+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,"APCHSDX(")
+4 ;reorder by date
SET X=0
FOR
SET X=$ORDER(APCHSDX(X))
IF X'=+X
QUIT
SET D=$PIECE(APCHSDX(X),U)
SET APCHSDX("I",(9999999-D),+$PIECE(APCHSDX(X),U,4))=APCHSDX(X)
+5 SET D=0
FOR
SET D=$ORDER(APCHSDX("I",D))
IF D'=+D
QUIT
Begin DoDot:1
+6 SET I=0
FOR
SET I=$ORDER(APCHSDX("I",D,I))
IF I'=+I
QUIT
Begin DoDot:2
+7 SET C=$PIECE(APCHSDX("I",D,I),U,2)
+8 ;already had that dx
IF $DATA(APCHSDX("D",C))
QUIT
+9 SET APCHSDX("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 ;display comments if there are any
+2 SET APCHX=$$MRCOM(DFN)
+3 IF APCHX]""
Begin DoDot:1
+4 DO S(" ")
+5 NEW P
SET P=$$VAL^XBDIQ1(9000010.51,$PIECE(APCHX,U,3),1204)
+6 SET X="PROVIDER COMMENTS ("_P_$SELECT(P]"":", ",1:"")_$$D1^APCHSMU($PIECE(APCHX,U))_") "_$PIECE(APCHX,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 APCHV
+12 SET APCHV="APCHV"
+13 DO ALLV^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,.APCHV)
+14 SET X="ANTICOAGULATION CLINIC VISITS (LAST 100 DAYS):"
DO S(X,1)
+15 IF '$ORDER(APCHV(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(APCHV(C))
IF C'=+C
QUIT
Begin DoDot:1
+17 SET V=$PIECE(APCHV(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 APCHV
+4 SET APCHV="APCHV"
+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",.APCHV)
+6 ;get all INR meds in APCHM
+7 KILL APCHMEDS
+8 DO GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-160),DT,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCHMEDS)
+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 SET X=0
SET C=0
FOR
SET X=$ORDER(APCHV(X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET D=$PIECE(APCHV(X),U)
+4 SET C=C+1
+5 SET V=$PIECE(APCHV(X),U,3)
+6 SET I=$PIECE(APCHV(X),U,4)
+7 SET O="???"
+8 IF I
SET O=$$VAL^XBDIQ1(9000010.09,I,1202)
+9 SET APCHCOMB((9999999-D),C)=D_U_V_U_U_O
End DoDot:1
+10 ;get any meds on this date
+11 SET X=0
SET C=0
FOR
SET X=$ORDER(APCHMEDS(X))
IF X'=+X
QUIT
Begin DoDot:1
+12 SET D=$PIECE(APCHMEDS(X),U)
+13 SET C=C+1
+14 SET M=$PIECE(APCHMEDS(X),U,4)
+15 SET V=$EXTRACT($PIECE(APCHMEDS(X),U,2),1,30)_" Qty: "_$PIECE(^AUPNVMED(M,0),U,6)_" Days: "_$PIECE(^AUPNVMED(M,0),U,7)
+16 SET O="???"
+17 IF M
SET O=$$VAL^XBDIQ1(9000010.14,M,1202)
+18 IF $DATA(APCHCOMB((9999999-D)))
Begin DoDot:2
+19 ;FIND 1st empty one and use it
+20 SET Y=0
SET G=0
FOR
SET Y=$ORDER(APCHCOMB((9999999-D),Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+21 IF $PIECE(APCHCOMB((9999999-D),Y),U,3)=""
SET $PIECE(APCHCOMB((9999999-D),Y),U,3)=V
SET $PIECE(APCHCOMB((9999999-D),Y),U,5)=O
End DoDot:3
End DoDot:2
IF 1
+22 IF '$TEST
SET APCHCOMB((9999999-D),C)=D_U_U_V_U_U_O
End DoDot:1
+23 ;now write it out to tmp
+24 KILL APCHV,APCHMEDS
+25 SET APCHD=0
FOR
SET APCHD=$ORDER(APCHCOMB(APCHD))
IF APCHD'=+APCHD
QUIT
Begin DoDot:1
+26 SET APCHY=0
FOR
SET APCHY=$ORDER(APCHCOMB(APCHD,APCHY))
IF APCHY'=+APCHY
QUIT
Begin DoDot:2
+27 SET APCHVV=APCHCOMB(APCHD,APCHY)
+28 SET APCHSS=""
+29 SET APCHSS=$$D1^APCHSMU($PIECE(APCHVV,U,1))
+30 SET $EXTRACT(APCHSS,13)=$PIECE(APCHVV,U,2)
+31 ;S $E(APCHSS,64)=$E($P(V,U,5),1,15)
+32 ;get med in strings of 34 characters
+33 SET X=$PIECE(APCHVV,U,3)
+34 IF X]""
Begin DoDot:3
+35 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=38
DO ^DIWP
+36 SET X=""
SET $EXTRACT(APCHSS,24)=^UTILITY($JOB,"W",0,1,0)
SET $EXTRACT(APCHSS,64)=$EXTRACT($PIECE(APCHVV,U,5),1,15)
DO S(APCHSS)
+37 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
+38 IF '$TEST
SET $EXTRACT(APCHSS,64)=$EXTRACT($PIECE(APCHVV,U,5),1,15)
DO S(APCHSS)
+39 KILL ^UTILITY($JOB,"W")
End DoDot:2
End DoDot:1
LAB ;
+1 ;S X="MOST RECENT RELATED LAB TESTS:" D S(X,1)
+2 ;S X="Date",$E(X,15)="Test",$E(X,50)="Results" D S(X)
URIN ;last urinalysis on file and its children
+1 ;K APCHV,APCHMEDS
+2 ;S APCHV=$$LASTACUR(APCHSPAT,$$DOB^AUPNPAT(APCHSPAT),DT)
+3 ;I APCHV="" S X="No Urinalysis Tests on File" D S(X) G CBC
+4 ;I $P(APCHV,U,2)["CPT" D G CBC ;display date of cpt
+5 ;.S X=$$D1^APCHSMU($P(APCHV,U)),$E(X,15)=$P(APCHV,U,2)_" "_$P(APCHV,U,3) D S(X)
+6 ;NOW DISPLAY ALL TESTS ON THIS ACCESSION
+7 ;S L=$P(APCHV,U,6),A=$P($G(^AUPNVLAB(L,0)),U,6)
+8 ;I A]"" D I 1
+9 ;.S X=$$D1^APCHSMU($P(APCHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
+10 ;.S Y=0 F S Y=$O(^AUPNVLAB("ALR0",A,Y)) Q:Y'=+Y D
+11 ;..Q:$P($G(^AUPNVLAB(Y,12)),U,8)'=L ;not a child of the urinalysis
+12 ;..S X="",$E(X,15)=$$VAL^XBDIQ1(9000010.09,Y,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,Y,.04) D S(X)
+13 ;E S X=$$D1^APCHSMU($P(APCHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
CBC ;
+1 ;D S(" ")
+2 ;K APCHV
+3 ;S APCHV=$$LASTACCB(APCHSPAT,$$DOB^AUPNPAT(APCHSPAT),DT)
+4 ;I APCHV="" S X="No CBC Tests on File" D S(X) G FOBT
+5 ;I $P(APCHV,U,2)["CPT" D G FOBT ;display date of cpt
+6 ;.S X=$$D1^APCHSMU($P(APCHV,U)),$E(X,15)=$P(APCHV,U,2)_" "_$P(APCHV,U,3) D S(X)
+7 ;NOW DISPLAY ALL TESTS ON THIS ACCESSION
+8 ;S L=$P(APCHV,U,6),A=$P($G(^AUPNVLAB(L,0)),U,6)
+9 ;I A]"" D I 1
+10 ;.S X=$$D1^APCHSMU($P(APCHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
+11 ;.S Y=0 F S Y=$O(^AUPNVLAB("ALR0",A,Y)) Q:Y'=+Y D
+12 ;..Q:$P($G(^AUPNVLAB(Y,12)),U,8)'=L ;not a child of the urinalysis
+13 ;..S X="",$E(X,15)=$$VAL^XBDIQ1(9000010.09,Y,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,Y,.04) D S(X)
+14 ;E S X=$$D1^APCHSMU($P(APCHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D S(X)
FOBT ;
+1 ;D S(" ")
+2 ;K APCHV
+3 ;S APCHV=$$LASTACFO(APCHSPAT,$$DOB^AUPNPAT(APCHSPAT),DT)
+4 ;I APCHV="" S X="No FOBT Tests on File" D S(X) G VITK
+5 ;I $P(APCHV,U,2)["CPT" D G VITK ;display date of cpt
+6 ;.S X=$$D1^APCHSMU($P(APCHV,U)),$E(X,15)=$P(APCHV,U,2)_" "_$P(APCHV,U,3) D S(X)
+7 ;NOW DISPLAY ALL TESTS ON THIS ACCESSION
+8 ;S L=$P(APCHV,U,6)
+9 ;S X=$$D1^APCHSMU($P(APCHV,U,1)),$E(X,15)=$$VAL^XBDIQ1(9000010.09,L,.01),$E(X,50)=$$VAL^XBDIQ1(9000010.09,L,.04) D 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 APCHMEDS
+4 DO GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(DT,-365),DT,,,,"PHYTONADIONE",.APCHMEDS)
+5 IF '$ORDER(APCHMEDS(0))
SET X="No Vitamin K medications dispensed in the past 365 days"
DO S(X)
GOTO PTED
+6 SET APCHY=999999
FOR
SET APCHY=$ORDER(APCHMEDS(APCHY),-1)
IF APCHY=""
QUIT
SET M=$PIECE(APCHMEDS(APCHY),U,4)
Begin DoDot:1
+7 SET X=$$D1^APCHSMU($PIECE(APCHMEDS(APCHY),U))
SET $EXTRACT(X,15)=$EXTRACT($PIECE(APCHMEDS(APCHY),U,2),1,30)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000010.14,M,1202)
DO S(X)
+8 SET APCHSIG=$PIECE(^AUPNVMED(M,0),U,5)
DO SIG
+9 SET X=APCHSSGY
+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 APCHEDUC
+4 DO EDUC(DFN,$$FMADD^XLFDT(DT,-365),DT,.APCHEDUC)
+5 SET Y=0
FOR
SET Y=$ORDER(APCHEDUC(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+6 SET X=$$D1^APCHSMU($PIECE(APCHEDUC(Y),U))
SET $EXTRACT(X,15)=$$VAL^XBDIQ1(9000010.16,$PIECE(APCHEDUC(Y),U,2),.01)
SET $EXTRACT(X,50)=$$EDPRV($PIECE(APCHEDUC(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 APCHSSGY=""
FOR APCHSP=1:1:$LENGTH(APCHSIG," ")
SET X=$PIECE(APCHSIG," ",APCHSP)
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(APCHSIG," ",APCHSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+3 SET APCHSSGY=APCHSSGY_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 ;entered in error
IF $PIECE($GET(^AUPNVACG(I,1)),U,1)
QUIT
+9 IF $PIECE($GET(^AUPNVACG(I,0)),U,4)=""
QUIT
+10 SET Z=$PIECE(^AUPNVACG(I,0),U,4)
+11 IF Z=3
SET S=$PIECE(^AUPNVACG(I,0),U,5)_" - "_$PIECE(^AUPNVACG(I,0),U,6)
+12 IF Z'=3
SET S=$$VAL^XBDIQ1(9000010.51,I,.04)
+13 SET R=$$VD^APCLV($PIECE(^AUPNVACG(I,0),U,3))_"^"_S
End DoDot:3
End DoDot:2
End DoDot:1
+14 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 ;entered in error
IF $PIECE($GET(^AUPNVACG(I,1)),U,1)
QUIT
+9 IF $PIECE($GET(^AUPNVACG(I,0)),U,7)=""
QUIT
+10 SET Z=$$VAL^XBDIQ1(9000010.51,I,.07)
+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
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 ;entered in error
IF $PIECE($GET(^AUPNVACG(I,1)),U,1)
QUIT
+9 IF $PIECE($GET(^AUPNVACG(I,0)),U,8)=""
QUIT
+10 SET Z=$$VAL^XBDIQ1(9000010.51,I,.08)
+11 SET R=$PIECE(^AUPNVACG(I,0),U,8)_"^"_Z
End DoDot:3
End DoDot:2
End DoDot:1
+12 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 ;entered in error
IF $PIECE($GET(^AUPNVACG(I,1)),U,1)
QUIT
+9 ;Q:$P($G(^AUPNVACG(I,0)),U,9)=""
+10 SET Z=$$VAL^XBDIQ1(9000010.51,I,.09)
+11 SET R=$PIECE(^AUPNVACG(I,0),U,9)_"^"_Z
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT R
EDUC(P,BDATE,EDATE,DATA) ;EP pass back array of all anti coag educ topics
+1 KILL DATA
+2 IF '$GET(P)
QUIT
+3 NEW APCHE,X,E,%,G,A,N,D,I,APCHX
+4 KILL APCHE
+5 SET A="APCHE("
+6 SET X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,A)
+7 IF '$DATA(APCHE)
QUIT
+8 SET %=0
FOR
SET %=$ORDER(APCHE(%))
IF %'=+%
QUIT
Begin DoDot:1
+9 SET D=$PIECE(APCHE(%),U,1)
+10 SET I=+$PIECE(APCHE(%),U,4)
+11 SET N=$PIECE(^AUPNVPED(I,0),U)
+12 IF 'N
QUIT
+13 SET N=$PIECE($GET(^AUTTEDT(N,0)),U,2)
+14 IF $PIECE(N,"-")="ACC"
Begin DoDot:2
+15 SET APCHX(9999999-D,+$PIECE(APCHE(%),U,4))=""
End DoDot:2
End DoDot:1
+16 SET N=""
SET C=0
FOR
SET N=$ORDER(APCHX(N))
IF N=""
QUIT
Begin DoDot:1
+17 SET X=0
FOR
SET X=$ORDER(APCHX(N,X))
IF X'=+X
QUIT
SET C=C+1
SET DATA(C)=(9999999-N)_U_X
End DoDot:1
+18 KILL APCHE
+19 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(APCHSPAT,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(APCHSPAT,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(APCHSPAT,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
