APCLACG1 ; IHS/CMI/LAB - IHS GPRA 09 SELECTED REPORT DRIVER 21 May 2008 12:10 PM ; 11 Dec 2009 6:32 AM
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;
PROC ;EP
S APCLJOB=$J,APCLBTH=$H,(APCLUPOP,APCLUPWR,APCLUPAC,APCLRPOP,APCLRPWR,APCLRPAC,APCLRPWA,APCLRPIN,APCLRPI9,APCLRPVK,APCLRPMI,APCLRPMN,APCLRPNI,APCLRPNN,APCLRPMU,APCLRPNU)=0
K ^TMP($J)
K APCLEHRL
I APCLGRP="E" D PLSTPTS^BEHOPTP2(.APCLEHRL,$P(APCLICP,U,2)) D
.S X=0 F S X=$O(APCLEHRL(X)) Q:X'=+X S ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",$P(APCLEHRL(X),U,1))="",APCLRPOP=APCLRPOP+1
K APCLEHRL
I APCLGRP="I" D RET^BQIPLDFN(.APCLEHRL,DUZ,$P(APCLICP,U,2)) D
.S X=0 F S X=$O(^TMP("BQIPLDFN",$J,X)) Q:X'=+X I ^TMP("BQIPLDFN",$J,X) S ^XTMP("APCLACG",APCLJOB,APCLBTH,^TMP("BQIPLDFN",$J,X))="",APCLRPOP=APCLRPOP+1
D XTMP^APCLOSUT("APCLACG",DT)
S APCL3YE=$$FMADD^XLFDT(APCLED,(3*-365))
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.Q:'$D(^DPT(DFN,0))
.S (APCLUP,APCLFAC,APCLPTWR,APCLPTAC,APCLWRAC,APCLPINR,APCLPTI9,APCLPTVK,APCLPTMI,APCLPTMN,APCLPTNI,APCLPTNN,APCLPTMU,APCLPTNU)=0
.S APCLUP=0 ;PATIENT USER POP FLAG
.S APCLPTWR=0 ;PATIENT WARFARIN FLAG
.S APCLPTAC=0 ;PATIENT AC CLINIC FLAG
.S APCLWRAC=0 ;patient on warfarin and ac clinic visit
.S APCLUP=$$ACTUP(DFN,APCL3YE,APCLED,APCLTAXI)
.I APCLUP S APCLUPOP=APCLUPOP+1 ;,^XTMP("APCLACG",APCLJ,APCLH,"LIST 1",DFN)="" ;TOTAL USER POP COUNTER
.I 'APCLUP G RPTPOP
.K APCLV
.K APCLMEDS
.D GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(APCLED,-45),APCLED,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCLMEDS)
.I $D(APCLMEDS) S APCLPTWR=1 I APCLUP S APCLUPWR=APCLUPWR+1
.S APCLV="APCLV"
.D ALLV^APCLAPIU(DFN,APCLBD,APCLED,.APCLV)
.;now see if any visit is to one of the anticoag clinics
.S X=0 F S X=$O(APCLV(X)) Q:X'=+X!(APCLPTAC) D
..S V=$P(APCLV(X),U,5)
..S C=$P(^AUPNVSIT(V,0),U,8)
..Q:C=""
..I $D(APCLACCL(C)) S APCLPTAC=1
.I APCLPTAC,APCLPTWR S APCLWRAC=1 I APCLUP S APCLUPAC=APCLUPAC+1
.;
RPTPOP .;
.;GET all patients in the report pop into ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS") and count in APCLRPOP
.I APCLGRP="W",APCLPTWR S ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)="",APCLRPOP=APCLRPOP+1
.I APCLGRP="A",APCLPTAC S ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)="",APCLRPOP=APCLRPOP+1
.I APCLGRP="S",$D(^DIBT(APCLSTMP,1,DFN)) S ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)="",APCLRPOP=APCLRPOP+1
.I $D(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)),APCLPTAC S APCLRPAC=APCLRPAC+1
.I $D(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)),APCLPTWR S APCLRPWR=APCLRPWR+1
.I $D(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)),APCLPTWR,APCLPTAC S APCLRPWA=APCLRPWA+1
.Q:'$D(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)) ;rest is for report pop only
.K APCLINR
.S APCLV="APCLINR"
.D ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(APCLED,-45),APCLED,$O(^ATXLAB("B","BJPC INR LAB TESTS",0)),$O(^ATXAX("B","BJPC INR LAB LOINCS",0)),"INR",.APCLV)
.S X=0 F S X=$O(APCLINR(X)) Q:X'=+X D
..S APCLPINR=1 ;had an INR
..I $P(APCLINR(X),U,3)>9 S APCLPTI9=1
.;if had at least 1 >9 table all of them for display later
.I APCLPTI9 S APCLRPI9=APCLRPI9+1 S X=0 F S X=$O(APCLINR(X)) Q:X'=+X S ^XTMP("APCLACG",APCLJOB,APCLBTH,"INR >9",DFN,$P(APCLINR(X),U,1),$P(APCLINR(X),U,4))=$P(APCLINR(X),U,3)
.I APCLPINR S APCLRPIN=APCLRPIN+1
.;VITAMIN K
.K APCLMEDS
.D GETMEDS^APCHSMU1(DFN,APCLBD,APCLED,,,,"PHYTONADIONE",.APCLMEDS)
.I $D(APCLMEDS) S APCLPTVK=1 S APCLRPVK=APCLRPVK+1
.S X=0,D="" F S X=$O(APCLMEDS(X)) Q:X'=+X S D=$P(APCLMEDS(X),U,1)
.I APCLPTVK S ^XTMP("APCLACG",APCLJOB,APCLBTH,"VITK",DFN)=D
MONT .;THOSE on warfarin and monitored were they within range
.I APCLWRAC D Q
..;get last INR value in date range
..S APCLLINR=$P($$LASTINR^APCLACGM(DFN,APCLBD,APCLED),U,3)
..;get last goal in date range
..S APCLGINR=$$INRGOAL^APCLACGM(DFN,APCLED)
..I APCLLINR=""!(APCLGINR="")!(+APCLLINR=0) S APCLPTMU=1,APCLRPMU=APCLRPMU+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT UNABLE TO ASSESS",DFN)=APCLLINR_U_APCLGINR Q
..S L=$P(APCLGINR," - ",1)
..S H=$P(APCLGINR," - ",2)
..I APCLLINR'<L,APCLLINR'>H S APCLPTMI=1,APCLRPMI=APCLRPMI+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT IN RANGE",DFN)=APCLLINR_U_APCLGINR Q
..S APCLPTMN=1,APCLRPMN=APCLRPMN+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT NOT IN RANGE",DFN)=APCLLINR_U_APCLGINR
NOTMONT .;NOT MONITORED
.I APCLPTWR,'APCLPTAC D
..;get last INR value in date range
..S APCLLINR=$P($$LASTINR^APCLACGM(DFN,APCLBD,APCLED),U,3)
..;get last goal in date range
..S APCLGINR=$$INRGOAL^APCLACGM(DFN,APCLED)
..I APCLLINR=""!(APCLGINR="")!(+APCLLINR=0) S APCLPTNU=1,APCLRPNU=APCLRPNU+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT UNABLE TO ASSESS",DFN)=APCLLINR_U_APCLGINR Q
..S L=$P(APCLGINR," - ",1)
..S H=$P(APCLGINR," - ",2)
..I APCLLINR'<L,APCLLINR'>H S APCLPTNI=1,APCLRPNI=APCLRPNI+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT IN RANGE",DFN)=APCLLINR_U_APCLGINR Q
..S APCLPTNN=1,APCLRPNN=APCLRPNN+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT NOT IN RANGE",DFN)=APCLLINR_U_APCLGINR
Q
ACTUP(P,BDATE,EDATE,T) ;EP - is this patient in user pop?
;I B=1,$$BEN^AUPNPAT(P,"C")'="01" Q 0 ;must be Indian/Alaskan Native
;I B=2,$$BEN^AUPNPAT(P,"C")="01" Q 0 ;must not be I/A
NEW DOD
S DOD=$$DOD^AUPNPAT(P) I DOD]"",DOD<EDATE Q 0
S X=$P($G(^AUPNPAT(P,11)),U,18) I X="" Q 0
I '$D(^ATXAX(T,21,"B",($P(^AUPNPAT(P,11),U,18)))),'$D(^ATXAX(T,21,"AA",$P(^AUPNPAT(P,11),U,18),$P(^AUPNPAT(P,11),U,18))) Q 0
S X=$$LASTVD(P,BDATE,EDATE)
Q $S(X:1,1:0)
;
LASTVD(P,BDATE,EDATE) ;
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW APCHV,A,B,G,X
S APCLV="APCLV"
D ALLV^APCLAPIU(P,BDATE,EDATE,.APCLV)
S (X,G)=0 F S X=$O(APCLV(X)) Q:X'=+X!(G) S V=$P(APCLV(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:"SAHOM"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.S G=1
.Q
Q G
APCLACG1 ; IHS/CMI/LAB - IHS GPRA 09 SELECTED REPORT DRIVER 21 May 2008 12:10 PM ; 11 Dec 2009 6:32 AM
+1 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+2 ;
PROC ;EP
+1 SET APCLJOB=$JOB
SET APCLBTH=$HOROLOG
SET (APCLUPOP,APCLUPWR,APCLUPAC,APCLRPOP,APCLRPWR,APCLRPAC,APCLRPWA,APCLRPIN,APCLRPI9,APCLRPVK,APCLRPMI,APCLRPMN,APCLRPNI,APCLRPNN,APCLRPMU,APCLRPNU)=0
+2 KILL ^TMP($JOB)
+3 KILL APCLEHRL
+4 IF APCLGRP="E"
DO PLSTPTS^BEHOPTP2(.APCLEHRL,$PIECE(APCLICP,U,2))
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(APCLEHRL(X))
IF X'=+X
QUIT
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",$PIECE(APCLEHRL(X),U,1))=""
SET APCLRPOP=APCLRPOP+1
End DoDot:1
+6 KILL APCLEHRL
+7 IF APCLGRP="I"
DO RET^BQIPLDFN(.APCLEHRL,DUZ,$PIECE(APCLICP,U,2))
Begin DoDot:1
+8 SET X=0
FOR
SET X=$ORDER(^TMP("BQIPLDFN",$JOB,X))
IF X'=+X
QUIT
IF ^TMP("BQIPLDFN",$JOB,X)
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,^TMP("BQIPLDFN",$JOB,X))=""
SET APCLRPOP=APCLRPOP+1
End DoDot:1
+9 DO XTMP^APCLOSUT("APCLACG",DT)
+10 SET APCL3YE=$$FMADD^XLFDT(APCLED,(3*-365))
+11 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+12 IF '$DATA(^DPT(DFN,0))
QUIT
+13 SET (APCLUP,APCLFAC,APCLPTWR,APCLPTAC,APCLWRAC,APCLPINR,APCLPTI9,APCLPTVK,APCLPTMI,APCLPTMN,APCLPTNI,APCLPTNN,APCLPTMU,APCLPTNU)=0
+14 ;PATIENT USER POP FLAG
SET APCLUP=0
+15 ;PATIENT WARFARIN FLAG
SET APCLPTWR=0
+16 ;PATIENT AC CLINIC FLAG
SET APCLPTAC=0
+17 ;patient on warfarin and ac clinic visit
SET APCLWRAC=0
+18 SET APCLUP=$$ACTUP(DFN,APCL3YE,APCLED,APCLTAXI)
+19 ;,^XTMP("APCLACG",APCLJ,APCLH,"LIST 1",DFN)="" ;TOTAL USER POP COUNTER
IF APCLUP
SET APCLUPOP=APCLUPOP+1
+20 IF 'APCLUP
GOTO RPTPOP
+21 KILL APCLV
+22 KILL APCLMEDS
+23 DO GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(APCLED,-45),APCLED,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCLMEDS)
+24 IF $DATA(APCLMEDS)
SET APCLPTWR=1
IF APCLUP
SET APCLUPWR=APCLUPWR+1
+25 SET APCLV="APCLV"
+26 DO ALLV^APCLAPIU(DFN,APCLBD,APCLED,.APCLV)
+27 ;now see if any visit is to one of the anticoag clinics
+28 SET X=0
FOR
SET X=$ORDER(APCLV(X))
IF X'=+X!(APCLPTAC)
QUIT
Begin DoDot:2
+29 SET V=$PIECE(APCLV(X),U,5)
+30 SET C=$PIECE(^AUPNVSIT(V,0),U,8)
+31 IF C=""
QUIT
+32 IF $DATA(APCLACCL(C))
SET APCLPTAC=1
End DoDot:2
+33 IF APCLPTAC
IF APCLPTWR
SET APCLWRAC=1
IF APCLUP
SET APCLUPAC=APCLUPAC+1
+34 ;
RPTPOP ;
+1 ;GET all patients in the report pop into ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS") and count in APCLRPOP
+2 IF APCLGRP="W"
IF APCLPTWR
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)=""
SET APCLRPOP=APCLRPOP+1
+3 IF APCLGRP="A"
IF APCLPTAC
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)=""
SET APCLRPOP=APCLRPOP+1
+4 IF APCLGRP="S"
IF $DATA(^DIBT(APCLSTMP,1,DFN))
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)=""
SET APCLRPOP=APCLRPOP+1
+5 IF $DATA(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))
IF APCLPTAC
SET APCLRPAC=APCLRPAC+1
+6 IF $DATA(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))
IF APCLPTWR
SET APCLRPWR=APCLRPWR+1
+7 IF $DATA(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))
IF APCLPTWR
IF APCLPTAC
SET APCLRPWA=APCLRPWA+1
+8 ;rest is for report pop only
IF '$DATA(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))
QUIT
+9 KILL APCLINR
+10 SET APCLV="APCLINR"
+11 DO ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(APCLED,-45),APCLED,$ORDER(^ATXLAB("B","BJPC INR LAB TESTS",0)),$ORDER(^ATXAX("B","BJPC INR LAB LOINCS",0)),"INR",.APCLV)
+12 SET X=0
FOR
SET X=$ORDER(APCLINR(X))
IF X'=+X
QUIT
Begin DoDot:2
+13 ;had an INR
SET APCLPINR=1
+14 IF $PIECE(APCLINR(X),U,3)>9
SET APCLPTI9=1
End DoDot:2
+15 ;if had at least 1 >9 table all of them for display later
+16 IF APCLPTI9
SET APCLRPI9=APCLRPI9+1
SET X=0
FOR
SET X=$ORDER(APCLINR(X))
IF X'=+X
QUIT
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"INR >9",DFN,$PIECE(APCLINR(X),U,1),$PIECE(APCLINR(X),U,4))=$PIECE(APCLINR(X),U,3)
+17 IF APCLPINR
SET APCLRPIN=APCLRPIN+1
+18 ;VITAMIN K
+19 KILL APCLMEDS
+20 DO GETMEDS^APCHSMU1(DFN,APCLBD,APCLED,,,,"PHYTONADIONE",.APCLMEDS)
+21 IF $DATA(APCLMEDS)
SET APCLPTVK=1
SET APCLRPVK=APCLRPVK+1
+22 SET X=0
SET D=""
FOR
SET X=$ORDER(APCLMEDS(X))
IF X'=+X
QUIT
SET D=$PIECE(APCLMEDS(X),U,1)
+23 IF APCLPTVK
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"VITK",DFN)=D
MONT ;THOSE on warfarin and monitored were they within range
+1 IF APCLWRAC
Begin DoDot:2
+2 ;get last INR value in date range
+3 SET APCLLINR=$PIECE($$LASTINR^APCLACGM(DFN,APCLBD,APCLED),U,3)
+4 ;get last goal in date range
+5 SET APCLGINR=$$INRGOAL^APCLACGM(DFN,APCLED)
+6 IF APCLLINR=""!(APCLGINR="")!(+APCLLINR=0)
SET APCLPTMU=1
SET APCLRPMU=APCLRPMU+1
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT UNABLE TO ASSESS",DFN)=APCLLINR_U_APCLGINR
QUIT
+7 SET L=$PIECE(APCLGINR," - ",1)
+8 SET H=$PIECE(APCLGINR," - ",2)
+9 IF APCLLINR'<L
IF APCLLINR'>H
SET APCLPTMI=1
SET APCLRPMI=APCLRPMI+1
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT IN RANGE",DFN)=APCLLINR_U_APCLGINR
QUIT
+10 SET APCLPTMN=1
SET APCLRPMN=APCLRPMN+1
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT NOT IN RANGE",DFN)=APCLLINR_U_APCLGINR
End DoDot:2
QUIT
NOTMONT ;NOT MONITORED
+1 IF APCLPTWR
IF 'APCLPTAC
Begin DoDot:2
+2 ;get last INR value in date range
+3 SET APCLLINR=$PIECE($$LASTINR^APCLACGM(DFN,APCLBD,APCLED),U,3)
+4 ;get last goal in date range
+5 SET APCLGINR=$$INRGOAL^APCLACGM(DFN,APCLED)
+6 IF APCLLINR=""!(APCLGINR="")!(+APCLLINR=0)
SET APCLPTNU=1
SET APCLRPNU=APCLRPNU+1
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT UNABLE TO ASSESS",DFN)=APCLLINR_U_APCLGINR
QUIT
+7 SET L=$PIECE(APCLGINR," - ",1)
+8 SET H=$PIECE(APCLGINR," - ",2)
+9 IF APCLLINR'<L
IF APCLLINR'>H
SET APCLPTNI=1
SET APCLRPNI=APCLRPNI+1
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT IN RANGE",DFN)=APCLLINR_U_APCLGINR
QUIT
+10 SET APCLPTNN=1
SET APCLRPNN=APCLRPNN+1
SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT NOT IN RANGE",DFN)=APCLLINR_U_APCLGINR
End DoDot:2
End DoDot:1
+11 QUIT
ACTUP(P,BDATE,EDATE,T) ;EP - is this patient in user pop?
+1 ;I B=1,$$BEN^AUPNPAT(P,"C")'="01" Q 0 ;must be Indian/Alaskan Native
+2 ;I B=2,$$BEN^AUPNPAT(P,"C")="01" Q 0 ;must not be I/A
+3 NEW DOD
+4 SET DOD=$$DOD^AUPNPAT(P)
IF DOD]""
IF DOD<EDATE
QUIT 0
+5 SET X=$PIECE($GET(^AUPNPAT(P,11)),U,18)
IF X=""
QUIT 0
+6 IF '$DATA(^ATXAX(T,21,"B",($PIECE(^AUPNPAT(P,11),U,18))))
IF '$DATA(^ATXAX(T,21,"AA",$PIECE(^AUPNPAT(P,11),U,18),$PIECE(^AUPNPAT(P,11),U,18)))
QUIT 0
+7 SET X=$$LASTVD(P,BDATE,EDATE)
+8 QUIT $SELECT(X:1,1:0)
+9 ;
LASTVD(P,BDATE,EDATE) ;
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+2 NEW APCHV,A,B,G,X
+3 SET APCLV="APCLV"
+4 DO ALLV^APCLAPIU(P,BDATE,EDATE,.APCLV)
+5 SET (X,G)=0
FOR
SET X=$ORDER(APCLV(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(APCLV(X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+10 IF "SAHOM"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+11 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+13 SET G=1
+14 QUIT
End DoDot:1
+15 QUIT G
