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

APCHS78.m

Go to the documentation of this file. 
  1. APCHS78 ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS PCC SUITE;**2,5**;MAY 14, 2009
  1.  ;
  1.  ;
  1. MEDSNDUP ; ************* ALL, NON DUPLICATED *************
  1.  S APCHSMTY="NODUP"
  1.  ;
  1. CONT ; <SETUP>
  1.  ;Q:'$D(^AUPNVMED("AC",APCHSPAT))
  1.  X APCHSCKP Q:$D(APCHSQIT)  I 'APCHSNPG W ! X APCHSBRK
  1.  ; <BUILD>
  1.  K ^TMP($J,"APCHSMED")
  1.  S APCHSIVD=0 F  S APCHSIVD=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  S APCHSMX=0 F  S APCHSMX=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD,APCHSMX)) Q:APCHSMX=""  D
  1.  .;Q:$P($G(^AUPNVMED(APCHSMX,11)),U,8)]""  ;NON VA, WILL PICK IT UP LATER
  1.  .S M=+^AUPNVMED(APCHSMX,0)
  1.  .S $P(^TMP($J,"APCHSMED",M),U)=$P($G(^TMP($J,"APCHSMED",M)),U)+1
  1.  .S X=$P(^TMP($J,"APCHSMED",M),U)
  1.  .I X<10 S $P(^TMP($J,"APCHSMED",M),U,(X+1))=$$FMTE^XLFDT((9999999-APCHSIVD),5)
  1.  K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP"),^TMP($J,"APCHSNO")
  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.  D NONVA
  1.  ; <DISPLAY>
  1.  ;REBUILD LIST BY NAME (TRADE OR GENERIC) AND DATE
  1.  S (APCHSIVD,APCHSCC,APCHSCRX)=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHSMTP",APCHSIVD)) Q:'APCHSIVD  I $P(^TMP($J,"APCHSMTP",APCHSIVD),U,2)="C",$P(^TMP($J,"APCHSMTP",APCHSIVD),U,3)=0 D
  1.  .S APCHSCC=APCHSCC+1 W:APCHSCC=1 !,$$CTR("Chronic Medications",80),! D MEDDSP
  1.  S (APCHSIVD)=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHSMTP",APCHSIVD)) Q:'APCHSIVD  I $P(^TMP($J,"APCHSMTP",APCHSIVD),U,2)="C",$P(^TMP($J,"APCHSMTP",APCHSIVD),U,3)=1 D
  1.  .S APCHSCC=APCHSCC+1 W:APCHSCC=1 !,$$CTR("Chronic Medications",80),! D MEDDSP
  1.  S (APCHSIVD,APCHSCC)=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHSMTP",APCHSIVD)) Q:'APCHSIVD  I $P(^TMP($J,"APCHSMTP",APCHSIVD),U,2)'="C",$P(^TMP($J,"APCHSMTP",APCHSIVD),U,3)=0 D
  1.  .S APCHSCC=APCHSCC+1 W:APCHSCC=1 !,$$CTR("Acute Medications",80),! D MEDDSP
  1.  S (APCHSIVD)=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHSMTP",APCHSIVD)) Q:'APCHSIVD  I $P(^TMP($J,"APCHSMTP",APCHSIVD),U,2)'="C",$P(^TMP($J,"APCHSMTP",APCHSIVD),U,3)=1 D
  1.  .S APCHSCC=APCHSCC+1 W:APCHSCC=1 !,$$CTR("Acute Medications",80),! D MEDDSP
  1.  ;CLEANUP
  1.  ;hold meds
  1.  D HOLDDSP^APCHS7
  1.  Q:$D(APCHSQIT)
  1.  ;now display MED refusals
  1.  S APCHST="MEDICATION",APCHSFN=50 D DISPREF^APCHS3C
  1.  D MEDRU^APCHS7
  1.  K APCHST,APCHSFN
  1. MEDX K APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM
  1.  K APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP,APCHSNON,APCHSDLU,APCHSIEN
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT,APCHSMTY,APCHSALT
  1.  K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP"),^TMP($J,"APCHSNO"),^TMP($J,"APCHSMED")
  1.  K X1,X2,X,Y
  1.  Q
  1. NONVA ;EP ;quit if chronic
  1.  S X=0 F  S X=$O(^PS(55,APCHSPAT,"NVA",X)) Q:X'=+X  D
  1.  .I $P($G(^PS(55,APCHSPAT,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,APCHSPAT,"NVA",X,999999911),U,1),0)) Q
  1.  .;S L=$P(^PS(55,APCHSPAT,"NVA",X,0),U,9)
  1.  .;:'L
  1.  .S L=$P($P($G(^PS(55,APCHSPAT,"NVA",X,0)),U,10),".")
  1.  .S L=9999999-L
  1.  .Q:L>APCHSDLM
  1.  .;S M=$P($G(^PS(55,APCHSPAT,"NVA",X,999999911)),U,1)  ;passed to PCC so got it already
  1.  .;I M,$D(^AUPNVMED(M)) Q  ;passed to PCC and v med exists so we already got it from V MED
  1.  .S D=$P(^PS(55,APCHSPAT,"NVA",X,0),U,2)
  1.  .I D="" S D="NO DRUG IEN"
  1.  .S APCHSCRX=0 I D S APCHSCRX=$$CRX(D)
  1.  .S N=$S(D:$P(^PSDRUG(D,0),U,1),1:$P(^PS(50.7,$P(^PS(55,APCHSPAT,"NVA",X,0),U,1),0),U,1))
  1.  .;S ^TMP($J,"APCHSMTP",L_"-"_N)=U_$P(^PS(55,APCHSPAT,"NVA",X,0),U,6)_U_N_U_$P(^PS(55,APCHSPAT,"NVA",X,0),U,5)_U_$P(^PS(55,APCHSPAT,"NVA",X,0),U,7)
  1.  .;S ^TMP($J,"APCHSMTB",N)=$P(^PS(55,APCHSPAT,"NVA",X,0),U,6)
  1.  .S ^TMP($J,"APCHSMTP",L_"-"_N)="^"_"Z"_"^"_APCHSCRX_"^"_N_"^"_$P(^PS(55,APCHSPAT,"NVA",X,0),U,7)_U_$P(^PS(55,APCHSPAT,"NVA",X,0),U,4)_" "_$P(^PS(55,APCHSPAT,"NVA",X,0),U,5)
  1.  .I $D(^TMP($J,"APCHSMTB",N)) Q
  1.  .S ^TMP($J,"APCHSMTB",N)=$P(^PS(55,APCHSPAT,"NVA",X,0),U,6)  ;,^TMP($J,"APCHSMTP",L_"-"_N)=APCHSMX_"^"_APCHSCHR_"^"_APCHSCRX
  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.  ;Q:$P($G(^AUPNVMED(APCHSMX,11)),U,8)]""
  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=$S($P(APCHSN,U,4)="":+APCHSN,$P(APCHSN,U,4)=$P(^PSDRUG(+APCHSN,0),U):+APCHSN,1:$P(APCHSN,U,4)),APCHSCHR=$$CHRONIC^APCHS72(APCHSMX),APCHSCHR=$S(APCHSCHR=1:"C",1:"Z")
  1.  S APCHSCRX=$$CRX($P(APCHSN,U))
  1.  D @APCHSMTY
  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_"^"_APCHSCHR_"^"_APCHSCRX
  1.  I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
  1.  S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX_"^"_APCHSCHR_"^"_APCHSCRX
  1.  Q
  1. MEDDSP ;DISPLAY MEDICATION
  1.  ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
  1.  S APCHSMX=$P(^TMP($J,"APCHSMTP",APCHSIVD),U)
  1.  I 'APCHSMX D NVADSP Q
  1.  S APCHSCRX=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,3)
  1.  S APCHSN=^AUPNVMED(APCHSMX,0)
  1.  S APCHSIEN=+APCHSN
  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 X1=DT,X2=APCHSDTM D ^%DTC ;Q:X>60&(X>(2*APCHSDYS))
  1.  S APCHSEXP=""
  1.  S APCHSMED=$S($P(APCHSN,U,4)="":$P(^PSDRUG(APCHSMFX,0),U,1),1:$P(APCHSN,U,4))
  1.  S APCHSALT=$P($G(^AUPNVMED(APCHSMX,12)),U,12)  ;IHS/CMI/GRL
  1.  S APCHEXPD=$$VALI^XBDIQ1(52,APCHSRX,26) S APCHEXPD=$$FMTE^XLFDT(APCHEXPD,5)
  1.  I APCHSDC S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
  1.  S APCHORTS=$P($G(^AUPNVMED(APCHSMX,11)),U)
  1.  I APCHORTS["RETURNED TO STOCK",APCHSDC S APCHSEXP="--RTS "_Y
  1.  D SIG S APCHSIG=APCHSSGY
  1.  D REF I APCHSREF S APCHSIG=APCHSIG_" "_APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
  1.  S V=$P(^AUPNVMED(APCHSMX,0),U,3) I $P($G(^AUPNVSIT(+V,0)),U,7)="E" S APCHSIG=APCHSIG_"  (OUTSIDE MEDICATION)"
  1.  D SITE
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  W APCHSDAT,?10,$S(APCHSCRX:"CRX",1:""),?14,APCHSMED W:APCHSQTY " #",APCHSQTY
  1.  W:APCHSDYS " (",APCHSDYS," days) " W APCHSEXP
  1.  I APCHEXPD]"" W "(expires "_APCHEXPD_")"
  1.  W !
  1.  I APCHSITE]"" W ?14,"Dispensed at: ",APCHSITE,!
  1.  I $G(APCHSALT)]"" I $E($G(APCHSALT),1,6)'=$E($G(APCHSMED),1,6) W ?14,"("_APCHSALT_")",!  ;IHS/CMI/GRL
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S APCHSICL=14,APCHSNRQ="",APCHSTXT="  "_APCHSIG D PRTTXT^APCHSUTL K APCHSICL,APCHSNRQ,APCHSP
  1.  S Y=$P(^TMP($J,"APCHSMED",APCHSIEN),U)
  1.  Q:Y<2
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  W ?16,"# times prev filled: ",Y-1 W "  " F I=3:1:5 W " ",$P(^TMP($J,"APCHSMED",APCHSIEN),U,I)
  1.  W !
  1.  Q
  1.  ;
  1. SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
  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(^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.  ;
  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(^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. CRX(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. 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 APCHSEXP=""
  1.  S (Y,APCHSDTM)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  S APCHSDC=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,5)
  1.  S APCHSCRX=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,3)
  1.  S APCHSMED=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,4)
  1.  I APCHSDC S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
  1.  S APCHSIG=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,6)
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  W APCHSDAT,?10,$S(APCHSCRX:"CRX",1:""),?14,APCHSMED,"  ",APCHSEXP,!
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S APCHSICL=14,APCHSNRQ="",APCHSTXT=APCHSIG_"  (EHR OUTSIDE MEDICATION)" D PRTTXT^APCHSUTL K APCHSICL,APCHSNRQ,APCHSP
  1.  Q