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

BHSMEDCS.m

Go to the documentation of this file. 
  1. BHSMEDCS ;IHS/MSC/MGH - Health summary V Meds controlled substances;01-May-2014 11:10;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**3,6,9**;March 17, 2006;Build 16
  1.  ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ; Patch 6 for non-VA and medical review
  1.  ;
  1. MEDSNDUP ; ************* ALL, NON DUPLICATED *************
  1.  N BHSPAT,X,Y,Z
  1.  S BHSMTY="NODUP"
  1.  S BHSPAT=DFN
  1.  ;
  1. CONT ; <SETUP>
  1.  Q:'$D(^AUPNVMED("AC",BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ; <BUILD>
  1.  K ^TMP($J,"BHSMED")
  1.  S BHSIVD=0 F  S BHSIVD=$O(^AUPNVMED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM)  S BHSMX=0 F  S BHSMX=$O(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMX)) Q:BHSMX=""  D
  1.  .S M=+^AUPNVMED(BHSMX,0)
  1.  .Q:'$D(^PSDRUG(M,0))
  1.  .Q:'$$CS(M)  ;controlled substances only
  1.  .S $P(^TMP($J,"BHSMED",M),U)=$P($G(^TMP($J,"BHSMED",M)),U)+1
  1.  .S X=$P(^TMP($J,"BHSMED",M),U)
  1.  .I X<99 S $P(^TMP($J,"BHSMED",M),U,(X+1))=$$FMTE^XLFDT((9999999-BHSIVD),5)_";"_$$VAL^XBDIQ1(9000010.14,BHSMX,1202)_";"_$$VAL^XBDIQ1(9000010,$P(^AUPNVMED(BHSMX,0),U,3),.06)
  1.  K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP"),^TMP($J,"BHSNO")
  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^BHSMED    ;Get outside meds not in PCC
  1.  ; <DISPLAY>
  1.  ;REBUILD LIST BY NAME (TRADE OR GENERIC) AND DATE
  1.  S (BHSIVD,BHSCC,BHSCRX)=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD  I $P(^TMP($J,"BHSMTP",BHSIVD),U,2)="C",$P(^TMP($J,"BHSMTP",BHSIVD),U,3)=0 D
  1.  .S BHSCC=BHSCC+1 D MEDDSP
  1.  S (BHSIVD)=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD  I $P(^TMP($J,"BHSMTP",BHSIVD),U,2)="C",$P(^TMP($J,"BHSMTP",BHSIVD),U,3)=1 D
  1.  .S BHSCC=BHSCC+1 D MEDDSP
  1.  S (BHSIVD,BHSCC)=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD  I $P(^TMP($J,"BHSMTP",BHSIVD),U,2)'="C",$P(^TMP($J,"BHSMTP",BHSIVD),U,3)=0 D
  1.  .S BHSCC=BHSCC+1 D MEDDSP
  1.  S (BHSIVD)=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD  I $P(^TMP($J,"BHSMTP",BHSIVD),U,2)'="C",$P(^TMP($J,"BHSMTP",BHSIVD),U,3)=1 D
  1.  .S BHSCC=BHSCC+1 D MEDDSP
  1.  ;CLEANUP
  1.  ;Patch 6
  1.  D MEDRU^BHSMED  ;display last date reviewed/updated/nam
  1.  K BHST,BHSFN
  1. MEDX K BHSIVD,BHSMX,BHSMFX,BHSQTY,BHSIG,BHSSGY,BHSEXP,BHSMTS,BHSMED,BHSDTM,BHSDAT,BHSDYS,BHSN,BHSDC,BHSVDF,BHSP,BHSNON,BHSDLU,BHSIEN,RXNORM
  1.  K BHSNFL,BHI,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSRX,BHSORD,BHSDRG,BHSCRN,BHSREF,BHSRFL,BHSALL,BHSTXT,BHSMTY,BHSALT,BHSCRX,BHSCHR,BHSQ,M,Z,BHEXPD
  1.  K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP"),^TMP($J,"BHSNO"),^TMP($J,"BHSMED")
  1.  K X1,X2,X,Y,BHSCC
  1.  Q
  1. MEDBLD ;BUILD ARRAY OF MEDICATIONS
  1.  ;APCHSDC=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.  Q:'$$CS($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,$P(BHSN,U,4)=$P(^PSDRUG(+BHSN,0),U):+BHSN,1:$P(BHSN,U,4)),BHSCHR=$$CHRONIC^BHSMEDG(BHSMX),BHSCHR=$S(BHSCHR=1:"C",1:"Z")
  1.  S BHSCRX=$$CS($P(BHSN,U))
  1.  D @BHSMTY
  1.  Q
  1. NODUP ;
  1.  ;I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
  1.  ;S X="" F  S X=$O(^TMP($J,"APCHSMTP",X)) Q:X=""  I $P(X,"-",2)=APCHSMFX K ^TMP($J,"APCHSMTP",X)
  1.  I $D(^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)) S ^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX_"^"_BHSCHR_"^"_BHSCRX
  1.  I $D(^TMP($J,"BHSMTB",BHSMFX)) Q
  1.  S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX_"^"_BHSCHR_"^"_BHSCRX
  1.  Q
  1. MEDDSP ;DISPLAY MEDICATION
  1.  ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
  1.  S BHSMX=$P(^TMP($J,"BHSMTP",BHSIVD),U)
  1.  I 'BHSMX D NVADSP Q
  1.  S BHSCRX=$P(^TMP($J,"BHSMTP",BHSIVD),U,3)
  1.  S BHSN=^AUPNVMED(BHSMX,0)
  1.  S BHSIEN=+BHSN
  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 X1=DT,X2=BHSDTM D ^%DTC ;Q:X>60&(X>(2*BHSDYS))
  1.  S BHSEXP=""
  1.  S BHSMED=$S($P(BHSN,U,4)="":$P(^PSDRUG(BHSMFX,0),U,1),1:$P(BHSN,U,4))
  1.  S BHSALT=$P($G(^AUPNVMED(BHSMX,12)),U,12)  ;IHS/CMI/GRL
  1.  S BHEXPD=$$VALI^XBDIQ1(52,BHSRX,26) S BHEXPD=$$FMTE^XLFDT(BHEXPD,5)
  1.  I BHSDC S X=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_X
  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
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W BHSDAT,?10,?14,BHSMED W:BHSQTY " #",BHSQTY
  1.  W:BHSDYS " (",BHSDYS," days) " W BHSEXP
  1.  I BHEXPD]"" W "(expires "_BHEXPD_")"
  1.  W !
  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.  I $G(BHSALT)]"" I $E($G(BHSALT),1,6)'=$E($G(BHSMED),1,6) W ?14,"("_BHSALT_")",!  ;IHS/CMI/GRL
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSICL=14,BHSNRQ="",BHSTXT="  "_BHSIG D PRTTXT^BHSUTL K BHSICL,BHSNRQ,BHSP
  1.  S Y=$P(^TMP($J,"BHSMED",BHSIEN),U)
  1.  Q:Y<2
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W ?16,"Previous fill dates:",!
  1.  F BHI=3:1 Q:$P($G(^TMP($J,"BHSMED",BHSIEN)),U,BHI)=""  D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W ?16,$P($P($G(^TMP($J,"BHSMED",BHSIEN)),U,BHI),";",1)
  1.  .W ?27,$P($P($G(^TMP($J,"BHSMED",BHSIEN)),U,BHI),";",2)
  1.  .W ?57,$P($P($G(^TMP($J,"BHSMED",BHSIEN)),U,BHI),";",3),!
  1.  S BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
  1.  I +BHSORD D RECON^BHSMED(BHSORD,"M")
  1.  E  D
  1.  .N NVA
  1.  .S NVA=+$P(APCHORTS,U,8)
  1.  .I NVA'="" D
  1.  ..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
  1.  ..D RECON^BHSMED(BHSORD,"M")
  1.  W !
  1.  Q
  1.  ;
  1. SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
  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(^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.  ;
  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.  ;
  1. CS(D) ;
  1.  I $P(^PSDRUG(D,0),U,3)="" Q 0
  1.  NEW Y S Y=$P(^PSDRUG(D,0),U,3)
  1.  ;I Y[1 Q 1
  1.  I Y[2 Q 1
  1.  I Y[3 Q 1
  1.  I Y[4 Q 1
  1.  I Y[5 Q 1
  1.  ;I Y["C" Q 1
  1.  ;I Y["A" Q 1
  1.  Q 0
  1.  ;
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  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.  Q