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

BHSMED.m

Go to the documentation of this file. 
  1. BHSMED ;IHS/CIA/MGH - Health Summary for V MED file ;01-May-2014 11:04;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,6,8,9**;March 17, 2006;Build 16
  1.  ;===================================================================
  1.  ;Taken from APCHS7 routine
  1.  ; IHS/TUCSON/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;16
  1.  ;;2.0;IHS RPMS/PCC HEALTH SUMMARY;**1,6,9,10**;SEP 23, 1997
  1.  ;Routines to use V MED components in the IHS health summaries
  1.  ;Patch 1 changes prescribed at to dispensed at as in IHS patch 15
  1.  ;Patch 2 changes for meds on hold and refusals
  1.  ;Patch 3 changes wording of on hold
  1.  ;Patch 6 changes for non-VA meds and medication review
  1. MEDSCURR ; ************** CURRENT MEDICATIONS * 9000010.14 ********
  1.  S BHSMTY="CURR" G CONT
  1. MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
  1.  S BHSMTY="ALL" G CONT
  1. MEDSCHRN ; ************* CHRONIC MEDCICATIONS ************
  1.  S BHSMTY="CHRONIC" G CONT
  1. MEDSNDUP ; ************* ALL, NON DUPLICATED *************
  1.  S BHSMTY="NODUP" G CONT
  1. MEDSCHR1 ; ******* CHRONIC MEDICATIONS, W/O D/C'ED *******
  1.  S BHSMTY="CHRONIC",BHSDCP=1 G CONT
  1.  ;
  1. CONT ; <SETUP>
  1.  N BHSPAT,BHSQ
  1.  S BHSPAT=DFN
  1.  I '$D(^AUPNVMED("AC",BHSPAT)) S BHST="MEDICATION",BHSFN=50 D DISPREF^BHSRAD Q
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ; <BUILD>
  1.  K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP")
  1.  S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^AUPNVMED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM)  S BHSMX=0 F BHSQ=0:0 S BHSMX=$O(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMX)) Q:BHSMX=""  D MEDBLD
  1.  D NONVA  ;Patch 6 get all NON-VA meds that didn't pass to PCC
  1.  ; <DISPLAY>
  1.  S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD  D MEDDSP
  1.  ;Patch 2 display meds on hold
  1.  D HOLDDSP
  1.  ;Patch 2 med refusals
  1.  S BHST="MEDICATION",BHSFN=50 D DISPREF^BHSRAD
  1.  ;Patch 6
  1.  D MEDRU  ;display last date reviewed/updated/nam
  1.  K BHST,BHSFN
  1.  ; <CLEANUP>
  1. MEDX K BHSIVD,BHSMX,BHSMFX,BHSQTY,BHSIG,BHSSGY,BHSEXP,BHSMTS,BHSMED,BHSDTM,BHSDAT,BHSDYS,BHSN,BHSDC,BHSVDF,BHSP,APCHORTS,BHSDCP
  1.  K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSRX,BHSDRG,BHSCRN,BHSREF,BHSRFL,BHSALL,BHSTXT,BHSMTY,BHSORD
  1.  K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP")
  1.  K X1,X2,X,Y,NIEN,RXNORM
  1.  Q
  1. MEDBLD ;BUILD ARRAY OF MEDICATIONS
  1.  ;BHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
  1.  ;VDF=VISIT FILE DATE
  1.  Q:'$D(^AUPNVMED(BHSMX,0))
  1.  S BHSN=^AUPNVMED(BHSMX,0)
  1.  Q:'$D(^PSDRUG($P(BHSN,U,1)))
  1.  S BHSDTM=-BHSIVD\1+9999999
  1.  S BHSDC=$P(BHSN,U,8),BHSDYS=$P(BHSN,U,7),BHSMFX=$S($P(BHSN,U,4)="":+BHSN,1:$P(BHSN,U,4))
  1.  S:BHSDYS="" BHSDYS=30
  1.  D @BHSMTY
  1.  Q
  1.  ;
  1. NONVA ;EP - ;NEW DFN,PSOACT S DFN=BHSPAT,PSOACT=1 D ^PSOHCSUM
  1.  ;quit if chronic
  1.  N L,D,N
  1.  Q:BHSMTY="CHRONIC"
  1.  S X=0 F  S X=$O(^PS(55,BHSPAT,"NVA",X)) Q:X'=+X  D
  1.  .I $P($G(^PS(55,BHSPAT,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,BHSPAT,"NVA",X,999999911),U,1),0)) Q
  1.  .S L=$P($P($G(^PS(55,BHSPAT,"NVA",X,0)),U,7),".")
  1.  .S L=9999999-L
  1.  .Q:L>GMTSDLM
  1.  .S D=$P(^PS(55,BHSPAT,"NVA",X,0),U,2)
  1.  .I D="" S D="NO DRUG IEN"
  1.  .S N=$S(D:$P(^PSDRUG(D,0),U,1),1:$P(^PS(50.7,$P(^PS(55,BHSPAT,"NVA",X,0),U,1),0),U,1))
  1.  .S ^TMP($J,"BHSMTP",L_"-"_N)=U_$P(^PS(55,BHSPAT,"NVA",X,0),U,6)_U_N_U_$P(^PS(55,BHSPAT,"NVA",X,0),U,4)_" "_$P(^PS(55,BHSPAT,"NVA",X,0),U,5)_U_$P(^PS(55,BHSPAT,"NVA",X,0),U,7)_U_X
  1.  .S ^TMP($J,"BHSMTB",N)=$P(^PS(55,BHSPAT,"NVA",X,0),U,6)
  1.  Q
  1. CURR ; current meds only
  1.  I $D(^TMP($J,"BHSMTB",BHSMFX)),^TMP($J,"BHSMTB",BHSMFX)="" Q
  1.  S X1=DT,X2=BHSDTM D ^%DTC Q:X>60&(X>(2*BHSDYS))
  1.  S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
  1.  Q
  1. ALL ;all meds included
  1.  S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
  1.  ;
  1.  Q
  1. NODUP ;
  1.  I $D(^TMP($J,"BHSMTB",BHSMFX)) Q
  1.  S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
  1.  Q
  1. CHRONIC ;chronic meds only
  1.  I $D(^TMP($J,"BHSMTB",BHSMFX)) Q
  1.  S X=$S($D(^PSRX("APCC",BHSMX)):$O(^(BHSMX,0)),1:0)
  1.  S Y=$S(+X:$D(^PS(55,BHSPAT,"P","CP",X)),1:0)
  1.  Q:'Y
  1.  I $G(BHSDCP),BHSDC]"" Q  ;IHS/CMI/LAB - new component patch 9
  1.  S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
  1.  Q
  1. MEDDSP ;DISPLAY MEDICATION
  1.  ;BHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
  1.  S BHSMX=^TMP($J,"BHSMTP",BHSIVD)
  1.  I $P(BHSMX,U,1)="" D NVADSP Q
  1.  S BHSN=^AUPNVMED(BHSMX,0)
  1.  S BHSRX=$S($D(^PSRX("APCC",BHSMX)):$O(^(BHSMX,0)),1:0)
  1.  S BHSCRN=$S(+BHSRX:$D(^PS(55,BHSPAT,"P","CP",BHSRX)),1:0)
  1.  S (X,BHSDTM)=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
  1.  S BHSDC=$P(BHSN,U,8),BHSDYS=$P(BHSN,U,7),BHSQTY=$P(BHSN,U,6),BHSIG=$P(BHSN,U,5),BHSVDF=$P(BHSN,U,3),BHSMFX=+BHSN
  1.  S:BHSDYS="" BHSDYS=30
  1.  S X1=DT,X2=BHSDTM D ^%DTC ;Q:X>60&(X>(2*BHSDYS))
  1.  S BHSEXP=""
  1.  I X>BHSDYS S X1=BHSDTM,X2=BHSDYS D C^%DTC D REGDT4^GMTSU S BHSEXP="-- Ran out "_X
  1.  S BHSMED=$S($P(BHSN,U,4)="":$P(^PSDRUG(BHSMFX,0),U,1),1:$P(BHSN,U,4))
  1.  I BHSDC S X=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_X
  1.  ;CHANGE IT AROUND A BIT LOOK FOR RETURNED TO STOCK IHS/OKCAO/POC 2/14/2000
  1.  S APCHORTS=$G(^AUPNVMED(BHSMX,11))
  1.  I APCHORTS["RETURNED TO STOCK",BHSDC S BHSEXP="--RTS "_X
  1.  ;END OF LOCAL CHANGES IHS/OKCAO/POC 2/14/2000
  1.  D SIG S BHSIG=BHSSGY
  1.  D REF I BHSREF S BHSIG=BHSIG_" "_BHSREF_$S(BHSREF=1:" refill",1:" refills")_" left."
  1.  D SITE ;I BHSITE]"" S BHSIG=BHSIG_"  ["_BHSITE_"]"
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W BHSDAT,?10,$S(BHSCRN:"(C)",1:""),?14,BHSMED," #",BHSQTY," (",BHSDYS," days) ",BHSEXP,!
  1.  ;Patch 8 Add Rxnorm code here
  1.  S RXNORM=$$GET1^DIQ(50,BHSMFX,9999999.27)
  1.  I RXNORM'="" W ?14,"RxNorm: ",RXNORM,!
  1.  I BHSITE]"" W ?14,"Dispensed at: ",BHSITE,!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSICL=14,BHSNRQ="",BHSTXT=BHSIG D PRTTXT^BHSUTL K BHSICL,BHSNRQ,BHSP
  1.  S BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
  1.  I BHSORD="" D
  1.  .N NVA
  1.  .S NVA=+$P(APCHORTS,U,8)
  1.  .I NVA'="" S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
  1.  D RECON(BHSORD,"M")
  1.  Q
  1. RECON(RX,TYP) ;Get last date reconciled
  1.  N REC,IEN,AIEN,WHEN,BY
  1.  Q:RX=""
  1.  S REC=""
  1.  S REC=$O(^BEHOCIR("G",TYP,RX,REC),-1) Q:REC=""  D
  1.  .S IEN="" S IEN=$O(^BEHOCIR("G",TYP,RX,REC,IEN),-1) Q:IEN=""  D
  1.  ..S AIEN=IEN_","_REC_","
  1.  ..S WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
  1.  ..S BY=$$GET1^DIQ(90461.632,AIEN,.02)
  1.  ..W ?14,"Reconciled on: "_WHEN_" by "_BY,!
  1.  Q
  1. NVADSP ;
  1.  S BHSEXP=""
  1.  S (X,BHSDTM)=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
  1.  S BHSDC=$P(^TMP($J,"BHSMTP",BHSIVD),U,5)
  1.  S BHSMED=$P(^TMP($J,"BHSMTP",BHSIVD),U,3)
  1.  I BHSDC S Y=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_Y
  1.  S BHSIG=$P(^TMP($J,"BHSMTP",BHSIVD),U,4)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W BHSDAT,?14,BHSMED,"  ",BHSEXP,!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSICL=14,BHSNRQ="",BHSTXT=BHSIG_"  (EHR OUTSIDE MEDICATION)" D PRTTXT^BHSUTL K BHSICL,BHSNRQ,BHSP
  1.  S NIEN=$P(^TMP($J,"BHSMTP",BHSIVD),U,6)
  1.  D RECON(NIEN,"M")
  1.  Q
  1.  ;
  1.  ;
  1. SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
  1.  ;I $$VALI^XBDIQ1(9001015,GMTSTYP,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 ;DETERMINE THE NUMBER OF REFILLS REMAINING
  1.  I 'BHSRX S BHSREF=0 Q
  1.  S BHSRFL=$P($G(^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. SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
  1.  S BHSITE=""
  1.  I $D(^AUPNVSIT(BHSVDF,21))#2 S BHSITE=$P(^(21),U) Q
  1.  Q:$P(^AUPNVSIT(BHSVDF,0),U,6)=""
  1.  I $P(^AUPNVSIT(BHSVDF,0),U,6)'=DUZ(2) S BHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(BHSVDF,0),U,6),0),U),1,30)
  1.  Q
  1. HOLDMEDS(P,R) ;EP - get meds on hold for display
  1.  ;return array of med iens of all meds for this patient that are on hold
  1.  I '$G(P) Q
  1.  NEW D,C,N
  1.  S D=DT
  1.  F  S D=$O(^PS(55,P,"P","A",D)) Q:D'=+D  D
  1.  .S N=0 F  S N=$O(^PS(55,P,"P","A",D,N)) Q:'N  D
  1.  ..Q:'$$HOLD(N)
  1.  ..S R(N)=""
  1.  ..Q
  1.  Q
  1. HOLD(S) ;EP - is this prescription on hold?
  1.  NEW X
  1.  S X=$P($G(^PSRX(S,"STA")),U,1)
  1.  I X=3 Q 1
  1.  I X=5 Q 1
  1.  I X=16 Q 1
  1.  ;version 6
  1.  S X=$P($G(^PSRX(S,0)),U,15)
  1.  I X=3 Q 1
  1.  I X=5 Q 1
  1.  I X=16 Q 1
  1.  Q 0
  1.  ;
  1. HOLDDSP ;EP - display all meds on hold
  1.  K BHHMED
  1.  D HOLDMEDS(BHSPAT,.BHHMED)
  1.  Q:'$D(BHHMED)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"The following medications have been processed in the Pharmacy "
  1.  W !,"system, but are currently active but not dispensed:",!,!
  1.  S BHSRX=0 F  S BHSRX=$O(BHHMED(BHSRX)) Q:BHSRX'=+BHSRX!($D(GMTSQIT))  D
  1.  .D HOLDDSP1
  1.  .Q
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"Medications may be on hold for several reasons including: Too early"
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"for refill, patient has sufficient amount on hand,pharmacy resolving issue"
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"with prescriber, etc. Contact Pharmacy staff for details or view "
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"prescription details in Pharmacy system.",!
  1.  K BHHMED
  1.  Q
  1. HOLDDSP1 ;write out med
  1.  S BHSCRN=$S(+BHSRX:$D(^PS(55,BHSPAT,"P","CP",BHSRX)),1:0)
  1.  S (X,BHSDTM)=$P(^PSRX(BHSRX,0),U,13) D REGDT4^GMTSU S BHSDAT=X  ;issu
  1.  S BHSDYS=$P(^PSRX(BHSRX,0),U,8)
  1.  S BHSQTY=$P(^PSRX(BHSRX,0),U,7)
  1.  S BHSIG=$P(^PSRX(BHSRX,0),U,10)
  1.  D SIG S BHSIG=BHSSGY
  1.  D REF I BHSREF S BHSIG=BHSIG_" "_BHSREF_$S(BHSREF=1:" refill",1:" refills")_" left."
  1.  ;D SITE ;I APCHSITE]"" S APCHSIG=APCHSIG_"  ["_APCHSITE_"]"
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W BHSDAT,?10,$S(BHSCRN:"(C)",1:""),?14,$$VAL^XBDIQ1(52,BHSRX,6)," #",BHSQTY," (",BHSDYS," days) ",!
  1.  ;I APCHSITE]"" W ?14,"Dispensed at: ",APCHSITE,!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSICL=14,BHSNRQ="",BHSTXT=BHSIG D PRTTXT^BHSUTL
  1.  K BHSICL,BHSNRQ,BHSP
  1.  W ?14,"Ordering Provider: ",$$VAL^XBDIQ1(52,BHSRX,4),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSTXT=$$VAL^XBDIQ1(52,BHSRX,100)_" Reason: "_$$VAL^XBDIQ1(52,BHSRX,99)_" - "_$$VAL^XBDIQ1(52,BHSRX,99.1)_" ("_$$VAL^XBDIQ1(52,BHSRX,99.2)_")",BHSICL=14,BHSNRQ=""
  1.  D PRTTXT^BHSUTL K BHSICL,BHSNRQ,BHSP
  1.  Q
  1. MEDRU ;EP
  1.  ;get date last reviewed and display
  1.  N BHSX
  1.  S BHSX=$$LASTMLR^APCLAPI6(BHSPAT,,DT,"A")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"Medication List Reviewed On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?56,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,22),!
  1.  S BHSX=$$LASTMLU^APCLAPI6(BHSPAT,,DT,"A")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "Medication List Updated On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?56,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,22),!
  1.  S BHSX=$$LASTNAM^APCLAPI6(BHSPAT,,DT,"A")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "No Active Medications Documented On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?56,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,22),!
  1.  Q