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

BHSMSUP.m

Go to the documentation of this file. 
  1. BHSMSUP ;IHS/CIA/MGH - Health Summary for Medication Supplements ;17-Mar-2006 10:36;MGH
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
  1.  ;===================================================================
  1.  ;Taken from APCHS9M1
  1.  ; IHS/TUCSON/LAB - MEDICATION TURN AROUND SUPPLEMENT;  [ 05/10/04  2:03 PM ]
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**12**;JUN 24, 1997
  1.  ;====================================================================
  1.  ;
  1. EP ;EP - called from component
  1.  N BHSPAT
  1.  S BHSPAT=DFN
  1.  Q:'$G(BHSPAT)
  1.  Q:'$D(^AUPNVMED("AC",BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1. WR ;write out array
  1.  K BHSQUIT
  1.  S BHSPAGE=0,BHSQUIT=0
  1.  D EP2  ;write out document
  1.  I BHSQUIT S GMTSQIT=1
  1.  D EOJ
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K BHSCLN,BHSDATM,BHSDIEN,BHSIPRV,BHSMIEN,BHSNARC,BHSPAGE,BHSPROV,BHSQUIT,BHSRTN,BHSTXRF,BHSBEG,BHSCRN,BHSDC,BHSDLM,BHSDOO,BHSDTM,BHSDYS,BHSED,BHSEXP
  1.  K BHSICL,BHSIG,BHSITE,BHSIVD,BHSM0,BHSNAM,BHSNRQ,BHSP,BHSQTY,BHSREF,BHSRFL,BHSRX,BHSSGY,BHSTEX,BHSTOB,BHSTOP,BHSTXT,BHSUPI,BHSTC,BHSTILN,BHSTOB,BHSTOBN,BHSTQ,BHSTYPE,BHSVIEN,BHSX,BHSXRX,BHSY,BHSRXRF
  1.  K DIR,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,X,Y,Z,W,X1,X2
  1.  Q
  1. EP2 ;PEP - PASS DFN get back array of patient care summary
  1.  ;at this point you are stuck with ^TMP("BHS",$J,"DCS"
  1.  K ^TMP($J,"BHSMEDS")
  1.  K ^TMP($J,"BHSCOUNT")
  1.  K ^TMP($J,"BHSMEDSA")
  1.  K ^TMP($J,"BHSMEDSG")
  1.  D SETARRAY
  1.  Q
  1. SETARRAY ;set up array containing dm care summary
  1.  D GETMEDS
  1.  Q
  1. GETMEDS ;
  1.  ;gather up in ^TMP all meds in past year that are current or Chronic
  1.  S GMTSDLM=$$FMADD^XLFDT(DT,-1030)
  1.  S GMTSDLM=9999999-GMTSDLM
  1.  Q:'$D(^AUPNVMED("AC",BHSPAT))  ;patient has no meds
  1.  S BHSIVD=0 F  S BHSIVD=$O(^AUPNVMED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM)  D
  1.  .S BHSMIEN=0 F  S BHSMIEN=$O(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMIEN)) Q:BHSMIEN'=+BHSMIEN  D
  1.  ..S BHSM0=^AUPNVMED(BHSMIEN,0)
  1.  ..Q:$P(BHSM0,U)=""
  1.  ..Q:'$D(^PSDRUG($P(BHSM0,U),0))
  1.  ..S BHSDATM=9999999-$P(BHSIVD,".")
  1.  ..S BHSDC=$P(BHSM0,U,8)
  1.  ..S BHSDYS=$P(BHSM0,U,7) S:BHSDYS=0 BHSDYS=30
  1.  ..S BHSNAM=$S($P(BHSM0,U,4)]"":$P(BHSM0,U,4),1:$P(^PSDRUG($P(BHSM0,U),0),U))
  1.  ..S BHSDIEN=$P(BHSM0,U,1)
  1.  ..S $P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),U)=$P($G(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN)),U)+1
  1.  ..S X=$P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),U)
  1.  ..I X<10 S $P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),U,(X+1))=$$DATE((9999999-BHSIVD))
  1.  ..I $$CHRONIC(BHSMIEN) D  Q
  1.  ...Q:$D(^TMP($J,"BHSMEDSG","CHRONIC",BHSNAM,BHSDIEN))  ;already have this one
  1.  ...S ^TMP($J,"BHSMEDS","CHRONIC",BHSIVD,BHSNAM,BHSDIEN,BHSMIEN)="",^TMP($J,"BHSMEDSG","CHRONIC",BHSNAM,BHSDIEN)=""
  1.  ..S X=$$FMDIFF^XLFDT(DT,BHSDATM) Q:X>60&(X>(2*BHSDYS))
  1.  ..Q:$D(^TMP($J,"BHSMEDSG","CURRENT",BHSNAM,BHSDIEN))  ;already have this one
  1.  ..S ^TMP($J,"BHSMEDS","CURRENT",BHSIVD,BHSNAM,BHSDIEN,BHSMIEN)="",^TMP($J,"BHSMEDSG","CURRENT",BHSNAM,BHSDIEN)=""
  1.  .Q
  1.  I '$D(^TMP($J,"BHSMEDS","CURRENT")),'$D(^TMP($J,"BHSMEDS","CHRONIC")) Q  ;no meds to display
  1.  ;NOW GET RID OF ALL DISCONTINUED MEDS BY .08 OF VMED OR BY STATUS IN FILE 52
  1.  S I=0 F  S I=$O(^TMP($J,"BHSMEDS","CURRENT",I)) Q:I'=+I  S N="" F  S N=$O(^TMP($J,"BHSMEDS","CURRENT",I,N)) Q:N=""  S D=0 F  S D=$O(^TMP($J,"BHSMEDS","CURRENT",I,N,D)) Q:D'=+D  D
  1.  .S M=0 F  S M=$O(^TMP($J,"BHSMEDS","CURRENT",I,N,D,M)) Q:M'=+M  I $$DC(M) K ^TMP($J,"BHSMEDS","CURRENT",I,N,D,M)
  1.  S I=0 F  S I=$O(^TMP($J,"BHSMEDS","CHRONIC",I)) Q:I'=+I  S N="" F  S N=$O(^TMP($J,"BHSMEDS","CHRONIC",I,N)) Q:N=""  S D=0 F  S D=$O(^TMP($J,"BHSMEDS","CHRONIC",I,N,D)) Q:D'=+D  D
  1.  .S M=0 F  S M=$O(^TMP($J,"BHSMEDS","CHRONIC",I,N,D,M)) Q:M'=+M  I $$DC(M) K ^TMP($J,"BHSMEDS","CHRONIC",I,N,D,M)
  1.  S C=1,X=$O(^TMP($J,"BHSMEDS","CHRONIC",0)) D
  1.  .I X="" S C=0 Q
  1.  .S X=9999999-X I X<$$FMADD^XLFDT(DT,-366) S C=0
  1.  S R=1,X=$O(^TMP($J,"BHSMEDS","CURRENT",0)) D
  1.  .I X="" S R=0 Q
  1.  .S X=9999999-X I X<$$FMADD^XLFDT(DT,-366) S R=0
  1.  I 'C,'R Q  ;no meds in past year
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  K BHSCRN S BHSTYPE="CURRENT" D MEDDSP
  1.  S BHSCRN=1 S BHSTYPE="CHRONIC" D MEDDSP
  1.  I 'BHSQUIT W !!!,"DISPENSE UNTIL NEXT SCHEDULED EVALUATION: ________",!!,"SIGNATURE: ________________________________  DATE: ________________",!
  1.  K ^TMP($J,"BHSMEDS")
  1.  K ^TMP($J,"BHSCOUNT")
  1.  K ^TMP($J,"BHSMEDSA")
  1.  K ^TMP($J,"BHSMEDSG")
  1.  Q
  1. MEDDSP ;
  1.  S X=""
  1.  Q:'$D(^TMP($J,"BHSMEDS",BHSTYPE))  ;NO MEDS TO DISPLAY
  1.  I BHSTYPE="CURRENT" S X="CURRENT MEDICATIONS - (TWICE DURATION OF RX - MINIMUM 60 DAYS)" D W(X,1)
  1.  I BHSTYPE="CHRONIC" S X="LATEST OF EACH CHRONIC MEDICATION DISPENSED IN THE PAST YEAR" D W(X,1)
  1.  S BHSTOP=$$FMADD^XLFDT(DT,-366),BHSTOP=9999999-BHSTOP
  1.  S BHSIVD=0 F  S BHSIVD=$O(^TMP($J,"BHSMEDS",BHSTYPE,BHSIVD)) Q:BHSIVD'=+BHSIVD!(BHSIVD>BHSTOP)!(BHSQUIT)  D
  1.  .S BHSNAM="" F  S BHSNAM=$O(^TMP($J,"BHSMEDS",BHSTYPE,BHSIVD,BHSNAM)) Q:BHSNAM=""!(BHSQUIT)  D
  1.  ..S BHSDIEN=0 F  S BHSDIEN=$O(^TMP($J,"BHSMEDS",BHSTYPE,BHSIVD,BHSNAM,BHSDIEN)) Q:BHSDIEN'=+BHSDIEN!(BHSQUIT)  D
  1.  ...S BHSMIEN=0 S BHSMIEN=$O(^TMP($J,"BHSMEDS",BHSTYPE,BHSIVD,BHSNAM,BHSDIEN,BHSMIEN)) D MEDDSP1
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  Q
  1. MEDDSP1 ;
  1.  S BHSM0=^AUPNVMED(BHSMIEN,0)
  1.  S BHSRX=$O(^PSRX("APCC",BHSMIEN,0)) I 'BHSRX S BHSXRX=0
  1.  S BHSRXRF=""
  1.  I BHSRX S BHSRXRF=$O(^PSRX("APCC",BHSMIEN,BHSRX,"")) S:BHSRXRF="" BHSRXRF=0
  1.  S (Y,BHSDTM)=9999999-$P(BHSIVD,".")
  1.  ;S BHSDTM=$$DATE(BHSDTM)
  1.  S BHSDC=$P(BHSM0,U,8)
  1.  S BHSDYS=$P(BHSM0,U,7) S:BHSDYS=0 BHSDYS=30
  1.  S BHSNAM=$S($P(BHSM0,U,4)]"":$P(BHSM0,U,4),1:$P(^PSDRUG($P(BHSM0,U),0),U))
  1.  S BHSQTY=$P(BHSM0,U,6)
  1.  S BHSIG=$P(BHSM0,U,5)
  1.  S BHSVIEN=$P(BHSM0,U,3)
  1.  S BHSDIEN=+BHSM0
  1.  S X1=DT,X2=BHSDTM D ^%DTC
  1.  S BHSEXP=""
  1.  I X>BHSDYS S X1=BHSDTM,X2=BHSDYS D C^%DTC S BHSEXP="-- Ran out "_$$DATE(X)
  1.  S BHSNARC=+$P(^PSDRUG(BHSDIEN,0),U,3)
  1.  ;ADDED RETURNED TO STOCK FLAG FOR NEXT 4 LINES IHS/OKCAO/POC 12/19/97
  1.  IF $P($G(^AUPNVMED(BHSMIEN,11)),U)="RETURNED TO STOCK" S BHSRTN="R"
  1.  I BHSDC,$G(BHSRTN)="R" S X=BHSDC D REGDT4^GMTSU S BHSEXP="--Returned to Stock "_X
  1.  I BHSDC,$G(BHSRTN)="" S X=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_X
  1.  K BHSRTN
  1.  D SIG S BHSIG=BHSSGY
  1.  D REF
  1.  I BHSREF S BHSREF=BHSREF_$S(BHSREF=1:" refill",1:" refills")_" left."
  1.  S BHSITE=$P(^AUPNVSIT(BHSVIEN,0),U,6)
  1.  D PROV
  1.  D CLN
  1.  D SITE
  1.  D WRITE
  1.  Q
  1. DC(V) ;is this d/c'ed
  1.  I '$D(^AUPNVMED(V,0)) Q 0
  1.  I $P(^AUPNVMED(V,0),U,8)]"" Q 1
  1.  NEW P,S
  1.  S P=$S($D(^PSRX("APCC",N)):$O(^(N,0)),1:0)
  1.  I 'P Q 0
  1.  S X=$P($G(^PSRX(P,0)),U,15)
  1.  I X=12 Q 1
  1.  I X=13 Q 1
  1.  I X=14 Q 1
  1.  I X=15 Q 1
  1.  Q 0
  1. WRITE ;
  1.  I $Y>(IOSL-10) D  Q:BHSQUIT
  1.  .W !!!,"DISPENSE UNTIL NEXT SCHEDULED EVALUATION: ________"
  1.  .W !!!,"SIGNATURE: ________________________________  DATE: ________________",!
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  Q:BHSQUIT
  1.  S X=$$DATE(BHSDTM),$E(X,10)=BHSNAM_"  "_BHSEXP D W(X,1)
  1.  S X="",$E(X,10)="QTY: "_BHSQTY_"   ("_BHSDYS_" days)   "_BHSPROV_$S(BHSCLN]"":" - "_BHSCLN,1:"") D W(X)
  1.  S BHSICL=10,BHSNRQ="",BHSTXT=BHSIG D PRTTXT K BHSICL,BHSNRQ,BHSP
  1.  ;ISSUE HISTORY
  1.  ;I BHSRX,$D(^PSRX(BHSRX,0)) S X="",$E(X,10)="Most recent issue date:  "_$$FMTE^XLFDT($P(^PSRX(BHSRX,0),U,13),5) D W(X)
  1.  I BHSITE]"" S X="",$E(X,10)="Prescribed at: "_BHSITE D W(X)
  1.  S X=""
  1.  S Y=$P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),U)
  1.  I Y>1 S X="" D
  1.  .S X="",$E(X,10)="Previously filled: " F I=3:1:5 S X=X_" "_$P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),U,I)
  1.  I X]"" D W(X)
  1.  I BHSREF S X="",$E(X,10)=BHSREF D W(X)
  1.  S X=""
  1.  I $G(BHSNARC)=2 S $E(X,10)="------- MUST REWRITE SCHEDULE 2 DRUGS -------" D W(X,1) Q
  1.  I $G(BHSNARC)>2,$G(BHSNARC)<6 S $E(X,10)="RENEW __________ QTY __________ DC __________" D W(X,1) Q
  1.  S $E(X,10)="RENEW __________  DC __________ " D W(X,1)
  1.  Q
  1.  ;
  1. SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
  1.  S BHSITE=""
  1.  I $D(^AUPNVSIT(BHSVIEN,21))#2 S BHSITE=$P(^(21),U) Q
  1.  Q:$P(^AUPNVSIT(BHSVIEN,0),U,6)=""
  1.  I $P(^AUPNVSIT(BHSVIEN,0),U,6)'=DUZ(2) S BHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(BHSVIEN,0),U,6),0),U),1,30)
  1.  Q
  1.  ;
  1. SIG ;
  1.  ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
  1.  ;I $$VALI^XBDIQ1(9001015,BHSTYP,3.5)="S" S BHSSGY=BHSIG Q
  1.  S BHSSGY="" F BHSP=1:1:$L(BHSIG," ") S X=$P(BHSIG," ",BHSP) I X]"" D
  1.  . 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)
  1.  . S BHSSGY=BHSSGY_X_" "
  1.  Q
  1.  ;
  1. REF ;
  1.  ;DETERMINE THE NUMBER OF REFILLS REMAINING
  1.  I 'BHSRX S BHSREF=0 Q
  1.  S BHSRFL=$P(^PSRX(BHSRX,0),U,9) S BHSREF=0 F  S BHSREF=$O(^PSRX(BHSRX,1,BHSREF)) Q:'BHSREF  S BHSRFL=BHSRFL-1
  1.  S BHSREF=BHSRFL
  1.  Q
  1.  ;
  1. PROV ;GET THE PROVIDER FOR ORIGINAL RX OR REFILL
  1.  S BHSPROV=""
  1.  I 'BHSRX S BHSPROV=$$VAL^XBDIQ1(9000010.14,1202,BHSMIEN) Q
  1.  S BHSIPRV=$S(BHSRXRF=0:$P($G(^PSRX(BHSRX,0)),"^",4),1:$P($G(^PSRX(BHSRX,1,BHSRXRF,0)),"^",17))
  1.  S BHSPROV=$S('BHSIPRV:"UNKNOWN PROVIDER",1:$P(^VA(200,BHSIPRV,0),"^"))
  1.  Q
  1.  ;
  1. CLN ;GET CLINIC FOR V MEDICATION
  1.  S BHSCLN=$E($$VAL^XBDIQ1(9000010,BHSVIEN,.08),1,10)
  1.  Q
  1. DATE(D) ;EP
  1.  I D="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
  1.  ;
  1. CHRONIC(N) ;
  1.  I '$G(N) Q ""
  1.  I '$D(^AUPNVMED(N)) Q ""
  1.  NEW X,Y,P
  1.  S P=$P(^AUPNVMED(N,0),U,2)
  1.  S X=$S($D(^PSRX("APCC",N)):$O(^(N,0)),1:0)
  1.  S Y=$S(+X:$D(^PS(55,P,"P","CP",X)),1:0)
  1.  I 'Y Q ""
  1.  Q 1
  1. W(Y,F,C,T) ;set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  NEW %,X
  1.  ;blank lines
  1.  F F=1:1:F S X="" W !,X
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  W !,X Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  W !,X
  1.  Q
  1. PRTTXT ; GENERALIZED TEXT PRINTER
  1.  S BHSTDLT=1,BHSTILN=80-BHSICL-1
  1.  F BHSTQ=0:0 S:BHSNRQ]""&(($L(BHSNRQ)+$L(BHSTXT)+2)<255) BHSTXT=$S(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ,BHSNRQ="" Q:BHSTXT=""  D PRTTXT2
  1.  K BHSTILN,BHSTDLT,BHSTF,BHSTC,BHSTXT,BHSDOO
  1.  Q
  1. PRTTXT2 D GETFRAG S X="",$E(X,BHSICL)=BHSTF D W(X) S BHSICL=BHSICL+BHSTDLT,BHSTILN=BHSTILN-BHSTDLT,BHSTDLT=0
  1.  Q
  1. GETFRAG I $L(BHSTXT)<BHSTILN S BHSTF=BHSTXT,BHSTXT="" Q
  1.  F BHSTC=BHSTILN:-1:1 Q:$E(BHSTXT,BHSTC)=" "
  1.  S BHSTF=$E(BHSTXT,1,BHSTC-1),BHSTXT=$E(BHSTXT,BHSTC+1,255)
  1.  Q
  1.  ;