APCHSTP1 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
;;2.0;IHS PCC SUITE;**2,5,8**;MAY 14, 2009;Build 2
;IHS/CMI/LAB - uncommented age limit on pap smear
;
;
;
INRGOAL ;EP called from hmr
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
Q:'$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT) ;not a candidate for this reminder, not active prescription for warfarin
Q:$$MRGOAL^APCHSACG(APCHSPAT)]"" ;has had an INR goal ever
S APCHLAST="",APCHNEXT="" K APCHSTEX
I $G(APCHCOLW)="" S APCHCOLW=48
D GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
D WRITETP^APCHSTP
Q
INRDUR ;EP called from hmr
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
Q:'$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT) ;not a candidate for this reminder, not active prescription for warfarin
Q:$$MRDUR^APCHSACG(APCHSPAT)]"" ;has had an INR goal ever
S APCHLAST="",APCHNEXT="" K APCHSTEX
I $G(APCHCOLW)="" S APCHCOLW=48
D GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
D WRITETP^APCHSTP
Q
;
INREND ;EP called from hmr
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
Q:'$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT) ;not a candidate for this reminder, not active prescription for warfarin
NEW X,G
S X=$P($$MREND^APCHSACG(APCHSPAT),U,1) ;END DATE
I X="" Q ;no end date less than t+45
S G=0
S X=$P(X,U,1)
I X<$$FMADD^XLFDT(DT,45) S G=1
Q:'G ;not a candidate
S APCHLAST="",APCHNEXT="" K APCHSTEX
I $G(APCHCOLW)="" S APCHCOLW=48
D GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
D WRITETP^APCHSTP
Q
ACURIN ;EP - called from hmr
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
Q:'$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT) ;not a candidate for this reminder, not active prescription for warfarin
NEW X,G
S X=$$LASTACUR^APCHSACG(APCHSPAT)
I $P(X,U,1)'<$$FMADD^XLFDT(DT,-365) Q ;had one in past year
S APCHLAST="",APCHNEXT="" K APCHSTEX
I $G(APCHCOLW)="" S APCHCOLW=48
D GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
D WRITETP^APCHSTP
Q
ACCBC ;EP - called from hmr
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
Q:'$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT) ;not a candidate for this reminder, not active prescription for warfarin
NEW X,G
S X=$$LASTACCB^APCHSACG(APCHSPAT)
I $P(X,U,1)'<$$FMADD^XLFDT(DT,-365) Q ;had one in past year
S APCHLAST="",APCHNEXT="" K APCHSTEX
I $G(APCHCOLW)="" S APCHCOLW=48
D GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
D WRITETP^APCHSTP
Q
ACFOBT ;EP - called from hmr
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
Q:'$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT) ;not a candidate for this reminder, not active prescription for warfarin
NEW X,G
S X=$$LASTACFO^APCHSACG(APCHSPAT)
I $P(X,U,1)'<$$FMADD^XLFDT(DT,-365) Q ;had one in past year
S APCHLAST="",APCHNEXT="" K APCHSTEX
I $G(APCHCOLW)="" S APCHCOLW=48
D GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
D WRITETP^APCHSTP
Q
ACTWARF(P,BD,ED) ;EP - does patient have active presciption for warfarin, status=A in prescription file.
NEW APCHMEDS,X,Y,Z,S,M,V,J,APCHMEDD,D
I $G(BD)="" S BD=$$FMADD^XLFDT(DT,-365)
I $G(ED)="" S ED=DT
D GETMEDS^APCHSMU1(P,BD,ED,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCHMEDS)
;now loop through all the meds and check status, if not A then kill out of array
;S Z=0 F S Z=$O(APCHMEDS(Z)) Q:Z'=+Z D
;.S M=$P(APCHMEDS(Z),U,4)
;.S V=$P(^AUPNVMED(M,0),U,3)
;.I $P(^AUPNVSIT(V,0),U,7)="E" Q ;count all outside meds as we don't know if active or not so error on side of active
;.I $P($G(^AUPNVMED(M,11)),U,8)]"" Q ;count EHR outside meds for now, may need to change later
;.;I $P($G(^AUPNVMED(M,0)),U,8)="" Q ;NOT discontinued before beginning date
;.;K APCHMEDS(Z)
;.Q
;REORDER BY DATE OF VISIT (OR 1201 IF IT EXISTS)
S X=0 F S X=$O(APCHMEDS(X)) Q:X'=+X D
.S D=$P($P($G(^AUPNVMED($P(APCHMEDS(X),U,4),12)),U),".")
.S APCHMEDD(9999999-$S(D]"":D,1:$P(APCHMEDS(X),U,1)))=APCHMEDS(X)
I '$O(APCHMEDD(0)) Q 0
S D=$O(APCHMEDD(0))
I $P(^AUPNVMED($P(APCHMEDD(D),U,4),0),U,8)]"" Q 0
Q 1
;
HOLDTHIS ;FOR LATER MAYBE
D
.S X=$O(^PSRX("APCC",M,0))
.I 'X Q ; FOR NOW CONSIDER IT AN OUTSIDE MED K APCHMEDS(Z) ;no prescription to check status
.S S=$$VALI^XBDIQ1(52,X,100)
.I S=0 Q ;active
.I S=3 Q ;hold
.I S=5 Q ;SUSPENSE
.;recently expired?
.I S=11 D Q
..;get expiration date
..S K=0
..S E=$P($G(^PSRX(P,3)),U,6)
..S R=$$CHRONIC^APCHS72(M) ;chronic flag
..I 'R D Q
...;not chronic, check to see if expired in past 14 days, if not quit
...S J=$$FMDIFF^XLFDT(DT,E)
...I J>14 K APCHMEDS(Z) Q ;more than 14 days ago so don't display
..;chronic = check 120 days
..S J=$$FMDIFF^XLFDT(DT,E)
..I J>120 K APCHMEDS(Z) ;expired more than 120 days ago
.I S=12!(S=14) D
..S E=$P(^AUPNVMED(M,0),U,8) ;discontinued date in v med
..I E="" S E=$P($G(^PSRX(P,3)),U,5) ;canceled date in 52
..I $$FMDIFF^XLFDT(DT,E)>30 K APCHMEDS(Z) Q ;only discontinueds in past 30 days
.K APCHMEDS(Z)
.Q
I $O(APCHMEDS(0)) Q 1
Q 0
APCHSTP1 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
+1 ;;2.0;IHS PCC SUITE;**2,5,8**;MAY 14, 2009;Build 2
+2 ;IHS/CMI/LAB - uncommented age limit on pap smear
+3 ;
+4 ;
+5 ;
INRGOAL ;EP called from hmr
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 ;not a candidate for this reminder, not active prescription for warfarin
IF '$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT)
QUIT
+3 ;has had an INR goal ever
IF $$MRGOAL^APCHSACG(APCHSPAT)]""
QUIT
+4 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+5 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+6 DO GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
+7 DO WRITETP^APCHSTP
+8 QUIT
INRDUR ;EP called from hmr
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 ;not a candidate for this reminder, not active prescription for warfarin
IF '$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT)
QUIT
+3 ;has had an INR goal ever
IF $$MRDUR^APCHSACG(APCHSPAT)]""
QUIT
+4 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+5 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+6 DO GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
+7 DO WRITETP^APCHSTP
+8 QUIT
+9 ;
INREND ;EP called from hmr
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 ;not a candidate for this reminder, not active prescription for warfarin
IF '$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT)
QUIT
+3 NEW X,G
+4 ;END DATE
SET X=$PIECE($$MREND^APCHSACG(APCHSPAT),U,1)
+5 ;no end date less than t+45
IF X=""
QUIT
+6 SET G=0
+7 SET X=$PIECE(X,U,1)
+8 IF X<$$FMADD^XLFDT(DT,45)
SET G=1
+9 ;not a candidate
IF 'G
QUIT
+10 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+11 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+12 DO GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
+13 DO WRITETP^APCHSTP
+14 QUIT
ACURIN ;EP - called from hmr
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 ;not a candidate for this reminder, not active prescription for warfarin
IF '$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT)
QUIT
+3 NEW X,G
+4 SET X=$$LASTACUR^APCHSACG(APCHSPAT)
+5 ;had one in past year
IF $PIECE(X,U,1)'<$$FMADD^XLFDT(DT,-365)
QUIT
+6 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+7 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+8 DO GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
+9 DO WRITETP^APCHSTP
+10 QUIT
ACCBC ;EP - called from hmr
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 ;not a candidate for this reminder, not active prescription for warfarin
IF '$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT)
QUIT
+3 NEW X,G
+4 SET X=$$LASTACCB^APCHSACG(APCHSPAT)
+5 ;had one in past year
IF $PIECE(X,U,1)'<$$FMADD^XLFDT(DT,-365)
QUIT
+6 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+7 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+8 DO GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
+9 DO WRITETP^APCHSTP
+10 QUIT
ACFOBT ;EP - called from hmr
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 ;not a candidate for this reminder, not active prescription for warfarin
IF '$$ACTWARF(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT)
QUIT
+3 NEW X,G
+4 SET X=$$LASTACFO^APCHSACG(APCHSPAT)
+5 ;had one in past year
IF $PIECE(X,U,1)'<$$FMADD^XLFDT(DT,-365)
QUIT
+6 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+7 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+8 DO GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX)
+9 DO WRITETP^APCHSTP
+10 QUIT
ACTWARF(P,BD,ED) ;EP - does patient have active presciption for warfarin, status=A in prescription file.
+1 NEW APCHMEDS,X,Y,Z,S,M,V,J,APCHMEDD,D
+2 IF $GET(BD)=""
SET BD=$$FMADD^XLFDT(DT,-365)
+3 IF $GET(ED)=""
SET ED=DT
+4 DO GETMEDS^APCHSMU1(P,BD,ED,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCHMEDS)
+5 ;now loop through all the meds and check status, if not A then kill out of array
+6 ;S Z=0 F S Z=$O(APCHMEDS(Z)) Q:Z'=+Z D
+7 ;.S M=$P(APCHMEDS(Z),U,4)
+8 ;.S V=$P(^AUPNVMED(M,0),U,3)
+9 ;.I $P(^AUPNVSIT(V,0),U,7)="E" Q ;count all outside meds as we don't know if active or not so error on side of active
+10 ;.I $P($G(^AUPNVMED(M,11)),U,8)]"" Q ;count EHR outside meds for now, may need to change later
+11 ;.;I $P($G(^AUPNVMED(M,0)),U,8)="" Q ;NOT discontinued before beginning date
+12 ;.;K APCHMEDS(Z)
+13 ;.Q
+14 ;REORDER BY DATE OF VISIT (OR 1201 IF IT EXISTS)
+15 SET X=0
FOR
SET X=$ORDER(APCHMEDS(X))
IF X'=+X
QUIT
Begin DoDot:1
+16 SET D=$PIECE($PIECE($GET(^AUPNVMED($PIECE(APCHMEDS(X),U,4),12)),U),".")
+17 SET APCHMEDD(9999999-$SELECT(D]"":D,1:$PIECE(APCHMEDS(X),U,1)))=APCHMEDS(X)
End DoDot:1
+18 IF '$ORDER(APCHMEDD(0))
QUIT 0
+19 SET D=$ORDER(APCHMEDD(0))
+20 IF $PIECE(^AUPNVMED($PIECE(APCHMEDD(D),U,4),0),U,8)]""
QUIT 0
+21 QUIT 1
+22 ;
HOLDTHIS ;FOR LATER MAYBE
+1 Begin DoDot:1
+2 SET X=$ORDER(^PSRX("APCC",M,0))
+3 ; FOR NOW CONSIDER IT AN OUTSIDE MED K APCHMEDS(Z) ;no prescription to check status
IF 'X
QUIT
+4 SET S=$$VALI^XBDIQ1(52,X,100)
+5 ;active
IF S=0
QUIT
+6 ;hold
IF S=3
QUIT
+7 ;SUSPENSE
IF S=5
QUIT
+8 ;recently expired?
+9 IF S=11
Begin DoDot:2
+10 ;get expiration date
+11 SET K=0
+12 SET E=$PIECE($GET(^PSRX(P,3)),U,6)
+13 ;chronic flag
SET R=$$CHRONIC^APCHS72(M)
+14 IF 'R
Begin DoDot:3
+15 ;not chronic, check to see if expired in past 14 days, if not quit
+16 SET J=$$FMDIFF^XLFDT(DT,E)
+17 ;more than 14 days ago so don't display
IF J>14
KILL APCHMEDS(Z)
QUIT
End DoDot:3
QUIT
+18 ;chronic = check 120 days
+19 SET J=$$FMDIFF^XLFDT(DT,E)
+20 ;expired more than 120 days ago
IF J>120
KILL APCHMEDS(Z)
End DoDot:2
QUIT
+21 IF S=12!(S=14)
Begin DoDot:2
+22 ;discontinued date in v med
SET E=$PIECE(^AUPNVMED(M,0),U,8)
+23 ;canceled date in 52
IF E=""
SET E=$PIECE($GET(^PSRX(P,3)),U,5)
+24 ;only discontinueds in past 30 days
IF $$FMDIFF^XLFDT(DT,E)>30
KILL APCHMEDS(Z)
QUIT
End DoDot:2
+25 KILL APCHMEDS(Z)
+26 QUIT
End DoDot:1
+27 IF $ORDER(APCHMEDS(0))
QUIT 1
+28 QUIT 0
