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

BSDX41G.m

Go to the documentation of this file. 
  1. BSDX41G ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
  1.  ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
  1.  ;
  1.  ;
  1. MEDSCURR ; ************** CURRENT MEDICATIONS * 9000010.14 ********
  1.  S APCHSMTY="CURR" G CONT
  1. MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
  1.  S APCHSMTY="ALL" G CONT
  1. MEDSCHRN ; ************* CHRONIC MEDCICATIONS ************
  1.  S APCHSMTY="CHRONIC" G CONT
  1. MEDSNDUP ; ************* ALL, NON DUPLICATED *************
  1.  S APCHSMTY="NODUP" G CONT
  1. MEDSCHR1 ; ******* CHRONIC MEDICATIONS, W/O D/C'ED *******
  1.  S APCHSMTY="CHRONIC",APCHSDCP=1 G CONT
  1.  ;
  1. CONT ; <SETUP>
  1.  Q:'$D(^AUPNVMED("AC",APCHSPAT))
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  I 'APCHSNPG S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30) X APCHSBRK
  1.  ; <BUILD>
  1.  K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP")
  1.  S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  S APCHSMX=0 F APCHSQ=0:0 S APCHSMX=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD,APCHSMX)) Q:APCHSMX=""  D MEDBLD
  1.  ; <DISPLAY>
  1.  S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHSMTP",APCHSIVD)) Q:'APCHSIVD  D MEDDSP
  1.  ; <CLEANUP>
  1.  ;now display all meds on hold
  1.  D HOLDDSP
  1.  ;now display MED refusals
  1.  S APCHST="MEDICATION",APCHSFN=50 D DISPREF^BSDX41F
  1.  K APCHST,APCHSFN
  1. MEDX K APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP,APCHORTS,APCHSDCP
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT,APCHSMTY
  1.  K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP")
  1.  K X1,X2,X,Y
  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(APCHSMX,0))
  1.  S APCHSN=^AUPNVMED(APCHSMX,0)
  1.  Q:'$D(^PSDRUG($P(APCHSN,U,1)))
  1.  S APCHSDTM=-APCHSIVD\1+9999999
  1.  ;S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSMFX=+APCHSN
  1.  S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSMFX=$S($P(APCHSN,U,4)="":+APCHSN,1:$P(APCHSN,U,4))
  1.  ;I $D(^TMP($J,"APCHSMTB",APCHSMFX)),^TMP($J,"APCHSMTB",APCHSMFX)="" Q
  1.  S:APCHSDYS="" APCHSDYS=30
  1.  ;SCREENS OUT MEDS NOT CURRENT; APCHSALL FORCES INCLUSION OF ALL MEDS
  1.  ;I 'APCHSALL S X1=DT,X2=APCHSDTM D ^%DTC Q:X>60&(X>(2*APCHSDYS))
  1.  ;S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
  1.  D @APCHSMTY
  1.  Q
  1.  ;
  1. CURR ; current meds only
  1.  I $D(^TMP($J,"APCHSMTB",APCHSMFX)),^TMP($J,"APCHSMTB",APCHSMFX)="" Q
  1.  S X1=DT,X2=APCHSDTM D ^%DTC Q:X>60&(X>(2*APCHSDYS))
  1.  S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
  1.  Q
  1. ALL ;all meds included
  1.  S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
  1.  ;
  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,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)) S ^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
  1.  I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
  1.  S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
  1.  Q
  1. CHRONIC ;chronic meds only
  1.  I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
  1.  S X=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0)
  1.  S Y=$S(+X:$D(^PS(55,APCHSPAT,"P","CP",X)),1:0)
  1.  Q:'Y
  1.  I $G(APCHSDCP),APCHSDC]"" Q  ;IHS/CMI/LAB - new component patch 9
  1.  S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
  1.  Q
  1. MEDDSP ;DISPLAY MEDICATION
  1.  ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
  1.  S APCHSMX=^TMP($J,"APCHSMTP",APCHSIVD)
  1.  S APCHSN=^AUPNVMED(APCHSMX,0)
  1.  S APCHSRX=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0)
  1.  S APCHSCRN=$S(+APCHSRX:$D(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
  1.  S (Y,APCHSDTM)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSQTY=$P(APCHSN,U,6),APCHSIG=$P(APCHSN,U,5),APCHSVDF=$P(APCHSN,U,3),APCHSMFX=+APCHSN
  1.  S:APCHSDYS="" APCHSDYS=30
  1.  S X1=DT,X2=APCHSDTM D ^%DTC ;Q:X>60&(X>(2*APCHSDYS))
  1.  S APCHSEXP=""
  1.  I X>APCHSDYS S X1=APCHSDTM,X2=APCHSDYS D C^%DTC S Y=X X APCHSCVD S APCHSEXP="-- Ran out "_Y
  1.  S APCHSMED=$S($P(APCHSN,U,4)="":$P(^PSDRUG(APCHSMFX,0),U,1),1:$P(APCHSN,U,4))
  1.  I APCHSDC S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
  1.  ;CHANGE IT AROUND A BIT LOOK FOR RETURNED TO STOCK IHS/OKCAO/POC 2/14/2000
  1.  S APCHORTS=$G(^AUPNVMED(APCHSMX,11))
  1.  I APCHORTS["RETURNED TO STOCK",APCHSDC S APCHSEXP="--RTS "_Y
  1.  ;END OF LOCAL CHANGES IHS/OKCAO/POC 2/14/2000
  1.  D SIG S APCHSIG=APCHSSGY
  1.  D REF I APCHSREF S APCHSIG=APCHSIG_" "_APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
  1.  D SITE ;I APCHSITE]"" S APCHSIG=APCHSIG_"  ["_APCHSITE_"]"
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXTMP=APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_$S(APCHSCRN:"(C)",1:"")
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(14-$L(BSDXTMP))_APCHSMED_" #"_APCHSQTY_" ("_APCHSDYS_" days) "_APCHSEXP
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  I APCHSITE]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(14)_"Dispensed at: "_APCHSITE_$C(30)
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S APCHSICL=14,APCHSNRQ="",APCHSTXT=APCHSIG D PRTTXT^BSDX41F K APCHSICL,APCHSNRQ,APCHSP
  1.  Q
  1.  ;
  1. SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
  1.  I $$VALI^XBDIQ1(9001015,APCHSTYP,3.5)="S" S APCHSSGY=APCHSIG Q
  1.  S APCHSSGY="" F APCHSP=1:1:$L(APCHSIG," ") S X=$P(APCHSIG," ",APCHSP) 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(APCHSIG," ",APCHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
  1.  . S APCHSSGY=APCHSSGY_X_" "
  1.  Q
  1.  ;
  1. REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
  1.  I 'APCHSRX S APCHSREF=0 Q
  1.  S APCHSRFL=$P($G(^PSRX(APCHSRX,0)),U,9) S APCHSREF=0 F  S APCHSREF=$O(^PSRX(APCHSRX,1,APCHSREF)) Q:'APCHSREF  S APCHSRFL=APCHSRFL-1
  1.  S APCHSREF=APCHSRFL
  1.  Q
  1.  ;
  1. SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
  1.  S APCHSITE=""
  1.  I $D(^AUPNVSIT(APCHSVDF,21))#2 S APCHSITE=$P(^(21),U) Q
  1.  Q:$P($G(^AUPNVSIT(APCHSVDF,0)),U,6)=""
  1.  I $P(^AUPNVSIT(APCHSVDF,0),U,6)'=DUZ(2) S APCHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(APCHSVDF,0),U,6),0),U),1,30)
  1.  Q
  1.  ;
  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.  ;
  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 APCHHMED
  1.  D HOLDMEDS(APCHSPAT,.APCHHMED)
  1.  Q:'$D(APCHHMED)
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="The following medications have been processed in the Pharmacy "_$C(30)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="system, and are currently active but not dispensed:"_$C(30)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  S APCHSRX=0 F  S APCHSRX=$O(APCHHMED(APCHSRX)) Q:APCHSRX'=+APCHSRX!($D(APCHSQIT))  D
  1.  .D HOLDDSP1
  1.  .Q
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Medications may be active but not dispensed for several reasons including: "_$C(30)
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Too early for refill, patient has sufficient amount on hand, pharmacy"_$C(30)
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="resolving issue with prescriber, etc. Contact Pharmacy staff for "_$C(30)
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="details or view prescription details in Pharmacy system."_$C(30)
  1.  K APCHHMED
  1.  Q
  1. HOLDDSP1 ;write out med
  1.  S APCHSCRN=$S(+APCHSRX:$D(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
  1.  S (Y,APCHSDTM)=$P(^PSRX(APCHSRX,0),U,13) X APCHSCVD S APCHSDAT=Y  ;issue or fill??
  1.  S APCHSDYS=$P(^PSRX(APCHSRX,0),U,8)
  1.  S APCHSQTY=$P(^PSRX(APCHSRX,0),U,7)
  1.  S APCHSIG=$P(^PSRX(APCHSRX,0),U,10)
  1.  D SIG S APCHSIG=APCHSSGY
  1.  D REF I APCHSREF S APCHSIG=APCHSIG_" "_APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
  1.  ;D SITE ;I APCHSITE]"" S APCHSIG=APCHSIG_"  ["_APCHSITE_"]"
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXTMP=APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_$S(APCHSCRN:"(C)",1:"")
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(14-$L(BSDXTMP))_$$VAL^XBDIQ1(52,APCHSRX,6)_" #"_APCHSQTY_" ("_APCHSDYS_" days) "
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  ;I APCHSITE]"" W ?14,"Dispensed at: ",APCHSITE,!
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S APCHSICL=14,APCHSNRQ="",APCHSTXT=APCHSIG D PRTTXT^BSDX41F K APCHSICL,APCHSNRQ,APCHSP
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(14)_"Ordering Provider: "_$$VAL^XBDIQ1(52,APCHSRX,4)_$C(30)
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S APCHSTXT=$$VAL^XBDIQ1(52,APCHSRX,100)_" Reason: "_$$VAL^XBDIQ1(52,APCHSRX,99)_" - "_$$VAL^XBDIQ1(52,APCHSRX,99.1)_" ("_$$VAL^XBDIQ1(52,APCHSRX,99.2)_")",APCHSICL=14,APCHSNRQ=""
  1.  D PRTTXT^BSDX41F K APCHSICL,APCHSNRQ,APCHSP
  1.  Q