Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHSTP1

APCHSTP1.m

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