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

BHSAPRO.m

Go to the documentation of this file. 
  1. BHSAPRO ;IHS/CIA/MGH - Health Summary for Medication Profile ;17-Mar-2006 10:36;MGH
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
  1.  ;===================================================================
  1.  ;VA Health summary format of IHS health summary component action profiles
  1.  ;Taken from AZOPCS7
  1.  ;IHS/OHPRD/VJM - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 01/23/98  9:01 AM ]
  1.  ;;1.9;PCC HEALTH SUMMARY;*2*;APR 18, 1995
  1.  ;
  1.  ; IHS/OHPRD/LAB changed this routine to accomodate 4 medication
  1.  ; summary types 11-15-94  patch 2
  1.  ;
  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.  ;
  1. CONT ; <SETUP>
  1.  N BHSPAT,BHSQ
  1.  S BHSPAT=DFN
  1.  I GMTSDLM=9999999 S X1=DT,X2=-365 D C^%DTC S GMTSDLM=9999999-X K X1,X2
  1.  Q:'$D(^AUPNVMED("AC",BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  I 'GMTSNPG W ! D CKP^GMTSUP
  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.  ; <DISPLAY>
  1.  S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD  D MEDDSP
  1.  ; <CLEANUP>
  1. MEDX K BHSIVD,BHSMX,BHSMFX,BHSQTY,BHSIG,BHSSGY,BHSEXP,BHSMTS,BHSMED,BHSDTM,BHSDAT,BHSDYS,BHSN,BHSDC,BHSVDF,BHSP
  1.  K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSRX,BHSDRG,BHSCRN,BHSREF,BHSRFL,BHSALL,BHSTXT,BHSMTY,BHSNARC
  1.  K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP")
  1.  K X1,X2,X,Y
  1.  K BHSRTN ;IHS/OKCAO/POC 12/19/97
  1.  Q
  1. MEDBLD ;
  1.  ;
  1.  ;BUILD ARRAY OF MEDICATIONS
  1.  ;BHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
  1.  ;VDF=VISIT FILE DATE
  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)) ;XXXXXXXX
  1.  S:BHSDYS="" BHSDYS=30
  1.  ;SCREENS OUT MEDS NOT CURRENT; BHSALL FORCES INCLUSION OF ALL MED
  1.  D @BHSMTY
  1.  Q
  1.  ;
  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.  S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
  1.  Q
  1. MEDDSP ;
  1.  ;
  1.  ;DISPLAY MEDICATION
  1.  ;BHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
  1.  S BHSMX=^TMP($J,"BHSMTP",BHSIVD)
  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)) ;MODIFIED FOR PHAR 6.0 IHS/OKCAO/POC 6/13/97
  1.  ;MORE LOCAL CHANCES IHS/OKCAO/POC 10/28/96
  1.  S BHSNARC=$P(^PSDRUG(BHSMFX,0),U,3),BHSNARC=+BHSNARC
  1.  K BHSNARF I +BHSNARC=2 S BHSNARF=1 ;FOR JUST SCH 2 DRUGS
  1.  ;END POC
  1.  ;ADDED RETURNED TO STOCK FLAG FOR NEXT 4 LINES IHS/OKCAO/POC 12/19/97
  1.  IF $P($G(^AUPNVMED(BHSMX,11)),U)="RETURNED TO STOCK" S BHSRTN="R"
  1.  I BHSDC,$G(BHSRTN)="R" S X=BHSDC D REGDT4^GMTSU S BHSEXP="--RETN STOCK "_X
  1.  I BHSDC,$G(BHSRTN)="" S X=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_X
  1.  K BHSRTN
  1.  ;END OF CHANGES
  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.  ;Q:$D(BHSNARF) ;POC QUIT IF NARCOTIC UNCOMMENT IF DO NOT WANT TO SEE NARCS
  1.  ;S X="IOINHI;IOINLOW" D ENDR^%ZISS W !,BHSDAT,?10 W:BHSMTY'="CHRONIC" $S(BHSCRN:"(C)",1:"") W ?12,IOINHI,BHSMED," #",BHSQTY,IOINLOW," (",BHSDYS," days) ",BHSEXP,! ;POC DELETE CHRONIC SIGN CHANGE SPACING BOLD DRUGAND SIG
  1.  W !,BHSDAT
  1.  W ?10 W:BHSMTY'="CHRONIC" $S(BHSCRN:"(C)",1:"")
  1.  ;S X="IOINHI" D ENDR^%ZISS W IOINHI
  1.  W ?12,BHSMED," #",BHSQTY
  1.  ;S X="IOINLOW" D ENDR^%ZISS W IOINLOW
  1.  W " (",BHSDYS," days) ",BHSEXP,!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSICL=14,BHSNRQ="",BHSTXT=BHSIG D PRTTXT^BHSUTL K BHSICL,BHSNRQ,BHSP
  1.  ;WRITE LOCAL CHANGES IHS/OKCAO/POC 10/29/96
  1.  I $D(BHSNARF) W ?10," ------ MUST REWRITE THIS CONTROLLED DRUG----",!
  1.  E  W ?14,"PROVIDER INITIALS:  ______________________________ DATE_________",!
  1.  E  W ?14,"REFILL 1______2______3______4______5______NR______DC______",!
  1.  ;END POC
  1.  Q
  1.  ;
  1. SIG ;
  1.  ;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 ;
  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. SITE ;
  1.  ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
  1.  S BHSITE=""
  1.  I $D(^AUPNVSIT(BHSVDF,21))#2 S BHSITE=$P(^(21),U)
  1.  Q