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

APCHS9M2.m

Go to the documentation of this file. 
  1. APCHS9M2 ; IHS/CMI/LAB - MEDICATION TURN AROUND SUPPLEMENT ;
  1.  ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
  1.  ;
  1.   ;
  1. EP ;EP - called from component
  1.  Q:'$G(APCHSPAT)
  1.  Q:'$D(^AUPNVMED("AC",APCHSPAT))
  1.  I $E(IOST)="C",IO=IO(0) W !! S DIR("A")="MEDICATION RE-ORDER DOCUMENT (^ TO EXIT, RETURN TO CONTINUE)",DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S APCHSQIT=1 Q  ;IHS/CMI/LAB fixed for slave printing
  1. WR ;write out array
  1.  K APCHQUIT
  1.  S APCHPAGE=0,APCHQUIT=0
  1.  D EP2  ;write out document
  1.  I APCHQUIT S APCHSQIT=1
  1.  D EOJ
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K APCHCLN,APCHDATM,APCHDIEN,APCHIPRV,APCHMIEN,APCHNARC,APCHPAGE,APCHPROV,APCHQUIT,APCHRTN,APCHTXRF,APCHSBEG,APCHSCRN,APCHSDC,APCHSDLM,APCHSDOO,APCHSDTM,APCHSDYS,APCHSED,APCHSEXP
  1.  K APCHSICL,APCHSIG,APCHSITE,APCHSIVD,APCHSM0,APCHSNAM,APCHSNRQ,APCHSP,APCHSQTY,APCHSREF,APCHSRFL,APCHSRX,APCHSSGY,APCHSTEX,APCHSTOB,APCHSTOP,APCHSTXT,APCHSUPI,APCHTC,APCHTILN,APCHTOB,APCHTOBN,APCHTQ,APCHTYPE,APCHVIEN,APCHX,APCHXRX,APCHY
  1.  K APCHSMSI,APCHSMSD
  1.  K DIR,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,X,Y,Z,W,X1,X2
  1.  Q
  1.  G:APCHPAGE=0 HEAD1
  1.  K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT=1 Q
  1. HEAD1 ;
  1.  S APCHPAGE=APCHPAGE+1
  1.  W:$D(IOF) @IOF
  1.  W !,APCHSHDR,!
  1.  W !,"MEDICATION REORDER DOCUMENT                Date: "_$$FMTE^XLFDT(DT)_"   Page: "_APCHPAGE
  1.  W !,"Patient: ",$P(^DPT(APCHSPAT,0),U),"  HRN: ",$$HRN^AUPNPAT(APCHSPAT,DUZ(2)),!
  1.  Q
  1. EP2 ;PEP - PASS DFN get back array of patient care summary
  1.  ;at this point you are stuck with ^TMP("APCHS",$J,"DCS"
  1.  K ^TMP($J,"APCHMEDS")
  1.  K ^TMP($J,"APCHCOUNT")
  1.  K ^TMP($J,"APCHMEDSA")
  1.  K ^TMP($J,"APCHMEDSG")
  1.  S APCHSDLM=""
  1.  I $G(APCHSTYP) S APCHSDLM=$P(^APCHSCTL(APCHSTYP,12,APCHSFOR,0),U,3)
  1.  I APCHSDLM="" S APCHSDLM="1Y"
  1.  I APCHSDLM?1N.N!(APCHSDLM?1N.N1"D") S APCHSDLS=+APCHSDLM_" day"
  1.  S:APCHSDLM?1N.N1"M" APCHSDLS=+APCHSDLM_" month",APCHSDLM=+APCHSDLM*30
  1.  S:APCHSDLM?1N.N1"Y" APCHSDLS=+APCHSDLM_" year",APCHSDLM=+APCHSDLM*365
  1.  S APCHSDLM=+APCHSDLM
  1.  S:+APCHSDLS>1 APCHSDLS=APCHSDLS_"s"
  1.  K APCHSDLS
  1.  I APCHSDLM'>0 S APCHSDLM=9999999
  1.  E  S X1=DT,X2=-APCHSDLM D C^%DTC S APCHSDLM=9999999-X K X1,X2
  1.  S APCHSMSD=$$FMTE^XLFDT(X),APCHSMSI=X
  1.  D SETARRAY
  1.  Q
  1. SETARRAY ;set up array containing dm care summary
  1.  D GETMEDS
  1.  Q
  1. GETMEDS ;
  1.  ;gather up in ^TMP all meds in past year that are current or Chronic
  1.  S APCHSTOP=$$FMADD^XLFDT(APCHSMSI,-1030)
  1.  S APCHSTOP=9999999-APCHSTOP
  1.  Q:'$D(^AUPNVMED("AC",APCHSPAT))  ;patient has no meds
  1.  S APCHSIVD=0 F  S APCHSIVD=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSTOP)  D
  1.  .S APCHMIEN=0 F  S APCHMIEN=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD,APCHMIEN)) Q:APCHMIEN'=+APCHMIEN  D
  1.  ..S APCHSM0=^AUPNVMED(APCHMIEN,0)
  1.  ..Q:$P(APCHSM0,U)=""
  1.  ..Q:'$D(^PSDRUG($P(APCHSM0,U),0))
  1.  ..S APCHDATM=9999999-$P(APCHSIVD,".")  ;visit date
  1.  ..S APCHSDC=$P(APCHSM0,U,8)
  1.  ..S APCHSDYS=$P(APCHSM0,U,7) S:APCHSDYS=0 APCHSDYS=30  ;days supply
  1.  ..S APCHSNAM=$S($P(APCHSM0,U,4)]"":$P(APCHSM0,U,4),1:$P(^PSDRUG($P(APCHSM0,U),0),U))  ;free text name if exists
  1.  ..S APCHDIEN=$P(APCHSM0,U,1)  ;drug ien
  1.  ..S $P(^TMP($J,"APCHCOUNT",APCHSNAM,APCHDIEN),U)=$P($G(^TMP($J,"APCHCOUNT",APCHSNAM,APCHDIEN)),U)+1  ;store last of each different drug and keep counter
  1.  ..S X=$P(^TMP($J,"APCHCOUNT",APCHSNAM,APCHDIEN),U)
  1.  ..I X<10 S $P(^TMP($J,"APCHCOUNT",APCHSNAM,APCHDIEN),U,(X+1))=$$DATE((9999999-APCHSIVD))
  1.  ..I $$CHRONIC(APCHMIEN) D  Q
  1.  ...Q:$D(^TMP($J,"APCHMEDSG","CHRONIC",APCHSNAM,APCHDIEN))  ;already have this one
  1.  ...S ^TMP($J,"APCHMEDS","CHRONIC",APCHSIVD,APCHSNAM,APCHDIEN,APCHMIEN)="",^TMP($J,"APCHMEDSG","CHRONIC",APCHSNAM,APCHDIEN)=""
  1.  ..;S X=$$FMDIFF^XLFDT(DT,APCHDATM) Q:X>60&(X>(2*APCHSDYS))
  1.  ..Q:$D(^TMP($J,"APCHMEDSG","CURRENT",APCHSNAM,APCHDIEN))  ;already have this one
  1.  ..S ^TMP($J,"APCHMEDS","CURRENT",APCHSIVD,APCHSNAM,APCHDIEN,APCHMIEN)="",^TMP($J,"APCHMEDSG","CURRENT",APCHSNAM,APCHDIEN)=""
  1.  .Q
  1.  I '$D(^TMP($J,"APCHMEDS","CURRENT")),'$D(^TMP($J,"APCHMEDS","CHRONIC")) Q  ;no meds to display
  1.  ;NOW GET RID OF ALL DISCONTINUED MEDS BY .08 OF VMED OR BY STATUS IN FILE 52
  1.  S I=0 F  S I=$O(^TMP($J,"APCHMEDS","CURRENT",I)) Q:I'=+I  S N="" F  S N=$O(^TMP($J,"APCHMEDS","CURRENT",I,N)) Q:N=""  S D=0 F  S D=$O(^TMP($J,"APCHMEDS","CURRENT",I,N,D)) Q:D'=+D  D
  1.  .S M=0 F  S M=$O(^TMP($J,"APCHMEDS","CURRENT",I,N,D,M)) Q:M'=+M  I $$DC(M) K ^TMP($J,"APCHMEDS","CURRENT",I,N,D,M)
  1.   S I=0 F  S I=$O(^TMP($J,"APCHMEDS","CHRONIC",I)) Q:I'=+I  S N="" F  S N=$O(^TMP($J,"APCHMEDS","CHRONIC",I,N)) Q:N=""  S D=0 F  S D=$O(^TMP($J,"APCHMEDS","CHRONIC",I,N,D)) Q:D'=+D  D
  1.  .S M=0 F  S M=$O(^TMP($J,"APCHMEDS","CHRONIC",I,N,D,M)) Q:M'=+M  I $$DC(M) K ^TMP($J,"APCHMEDS","CHRONIC",I,N,D,M)
  1.  ;S C=1,X=$O(^TMP($J,"APCHMEDS","CHRONIC",0)) D
  1.  ;.I X="" S C=0 Q
  1.  ;.S X=9999999-X I X<$$FMADD^XLFDT(DT,-366) S C=0
  1.  ;S R=1,X=$O(^TMP($J,"APCHMEDS","CURRENT",0)) D
  1.  ;.I X="" S R=0 Q
  1.  ;.S X=9999999-X I X<$$FMADD^XLFDT(DT,-366) S R=0
  1.  ;I 'C,'R Q  ;no meds in past year
  1.  ;REORDER BY NAME AND USE THAT ARRAY
  1.  K ^TMP($J,"APCHMEDSA")
  1.  ;S APCHSTOP=$$FMADD^XLFDT(DT,-366),APCHSTOP=9999999-APCHSTOP
  1.  S X="" F  S X=$O(^TMP($J,"APCHMEDS",X)) Q:X=""  D
  1.  .S D=0 F  S D=$O(^TMP($J,"APCHMEDS",X,D)) Q:D'=+D!(D>APCHSDLM)  D
  1.  ..S N="" F  S N=$O(^TMP($J,"APCHMEDS",X,D,N)) Q:N=""  D
  1.  ...S Y=0 F  S Y=$O(^TMP($J,"APCHMEDS",X,D,N,Y)) Q:Y=""  D
  1.  ....S M=0 F  S M=$O(^TMP($J,"APCHMEDS",X,D,N,Y,M)) Q:M'=+M  S ^TMP($J,"APCHMEDSA",X,N,Y,D,M)=^TMP($J,"APCHMEDS",X,D,N,Y,M)
  1.  D HEADER
  1.  K APCHSCRN S APCHTYPE="CURRENT" D MEDDSP
  1.  S APCHSCRN=1 S APCHTYPE="CHRONIC" D MEDDSP
  1.  I 'APCHQUIT W !!!,"DISPENSE UNTIL NEXT SCHEDULED EVALUATION: ________",!!,"SIGNATURE: _______________________________  DATE: ________________",!
  1.  K ^TMP($J,"APCHMEDS")
  1.  K ^TMP($J,"APCHCOUNT")
  1.  K ^TMP($J,"APCHMEDSA")
  1.  K ^TMP($J,"APCHMEDSG")
  1.  Q
  1. MEDDSP ;
  1.  S X=""
  1.  Q:'$D(^TMP($J,"APCHMEDSA",APCHTYPE))  ;NO MEDS TO DISPLAY
  1.  I APCHTYPE="CURRENT" S X="LAST OF EACH NON-CHRONIC MEDICATION DISPENSED SINCE "_APCHSMSD D W(X,1)
  1.  I APCHTYPE="CHRONIC" S X="LATEST OF EACH CHRONIC MEDICATION DISPENSED SINCE "_APCHSMSD D W(X,1)
  1.  ;S APCHSTOP=$$FMADD^XLFDT(DT,-366),APCHSTOP=9999999-APCHSTOP
  1.  S APCHSNAM=0 F  S APCHSNAM=$O(^TMP($J,"APCHMEDSA",APCHTYPE,APCHSNAM)) Q:APCHSNAM=""!(APCHQUIT)  D
  1.  .S APCHDIEN=0 F  S APCHDIEN=$O(^TMP($J,"APCHMEDSA",APCHTYPE,APCHSNAM,APCHDIEN)) Q:APCHDIEN'=+APCHDIEN!(APCHQUIT)  D
  1.  ..S APCHSIVD=0 S APCHSIVD=$O(^TMP($J,"APCHMEDSA",APCHTYPE,APCHSNAM,APCHDIEN,APCHSIVD)) Q:APCHSIVD=""!(APCHQUIT)  D
  1.  ...S APCHMIEN=0 S APCHMIEN=$O(^TMP($J,"APCHMEDSA",APCHTYPE,APCHSNAM,APCHDIEN,APCHSIVD,APCHMIEN)) D MEDDSP1
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  Q
  1. MEDDSP1 ;
  1.  S APCHSM0=^AUPNVMED(APCHMIEN,0)
  1.  S APCHSRX=$O(^PSRX("APCC",APCHMIEN,0)) I 'APCHSRX S APCHXRX=0
  1.  S APCHRXRF=""
  1.  I APCHSRX S APCHRXRF=$O(^PSRX("APCC",APCHMIEN,APCHSRX,"")) S:APCHRXRF="" APCHRXRF=0
  1.  S (Y,APCHSDTM)=9999999-$P(APCHSIVD,".")
  1.  ;S APCHSDTM=$$DATE(APCHSDTM)
  1.  S APCHSDC=$P(APCHSM0,U,8)
  1.  S APCHSDYS=$P(APCHSM0,U,7) S:APCHSDYS=0 APCHSDYS=30
  1.  S APCHSNAM=$S($P(APCHSM0,U,4)]"":$P(APCHSM0,U,4),1:$P(^PSDRUG($P(APCHSM0,U),0),U))
  1.  S APCHSQTY=$P(APCHSM0,U,6)
  1.  S APCHSIG=$P(APCHSM0,U,5)
  1.  S APCHVIEN=$P(APCHSM0,U,3)
  1.  S APCHDIEN=+APCHSM0
  1.  S X1=DT,X2=APCHSDTM D ^%DTC
  1.  S APCHSEXP=""
  1.  I X>APCHSDYS S X1=APCHSDTM,X2=APCHSDYS D C^%DTC S APCHSEXP="-- Ran out "_$$DATE(X)
  1.  S APCHNARC=+$P(^PSDRUG(APCHDIEN,0),U,3)
  1.  ;ADDED RETURNED TO STOCK FLAG FOR NEXT 4 LINES IHS/OKCAO/POC 12/19/97
  1.  IF $P($G(^AUPNVMED(APCHMIEN,11)),U)="RETURNED TO STOCK" S APCHRTN="R"
  1.  I APCHSDC,$G(APCHRTN)="R" S Y=APCHSDC X APCHSCVD S APCHSEXP="--Returned to Stock "_Y
  1.  I APCHSDC,$G(APCHRTN)="" S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
  1.  K APCHRTN
  1.  D SIG S APCHSIG=APCHSSGY
  1.  D REF
  1.  I APCHSREF S APCHSREF=APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
  1.  S APCHSITE=$P(^AUPNVSIT(APCHVIEN,0),U,6)
  1.  D PROV
  1.  D CLN
  1.  D SITE
  1.  D WRITE
  1.  Q
  1. WRITE ;
  1.  I $Y>(IOSL-10) D  Q:APCHQUIT
  1.  .W !!!,"DISPENSE UNTIL NEXT SCHEDULED EVALUATION: ________"
  1.  .W !!!,"SIGNATURE: ________________________________  DATE: ________________",!
  1.  .D HEADER
  1.  Q:APCHQUIT
  1.  S X=$$DATE(APCHSDTM),$E(X,10)=APCHSNAM_"  "_APCHSEXP D W(X,1)
  1.  S X="",$E(X,10)="QTY: "_APCHSQTY_"   ("_APCHSDYS_" days)   "_APCHPROV_$S(APCHCLN]"":" - "_APCHCLN,1:"") D W(X)
  1.  S APCHSICL=10,APCHSNRQ="",APCHSTXT=APCHSIG D PRTTXT K APCHSICL,APCHSNRQ,APCHSP
  1.  ;ISSUE HISTORY
  1.  ;I APCHSRX,$D(^PSRX(APCHSRX,0)) S X="",$E(X,10)="Most recent issue date:  "_$$FMTE^XLFDT($P(^PSRX(APCHSRX,0),U,13),5) D W(X)
  1.  I APCHSITE]"" S X="",$E(X,10)="Dispensed at: "_APCHSITE D W(X)
  1.  S X=""
  1.  S Y=$P(^TMP($J,"APCHCOUNT",APCHSNAM,APCHDIEN),U)
  1.  I Y>1 S X="" D
  1.  .S X="",$E(X,10)="Previously filled: " F I=3:1:5 S X=X_" "_$P(^TMP($J,"APCHCOUNT",APCHSNAM,APCHDIEN),U,I)
  1.  I X]"" D W(X)
  1.  I APCHSREF S X="",$E(X,10)=APCHSREF D W(X)
  1.  S X=""
  1.  I $G(APCHNARC)=2 S $E(X,10)="------- MUST REWRITE SCHEDULE 2 DRUGS -------" D W(X,1) Q
  1.  I $G(APCHNARC)>2,$G(APCHNARC)<6 S $E(X,10)="RENEW __________ QTY __________ DC __________" D W(X,1) Q
  1.  S $E(X,10)="RENEW __________  DC __________  " D W(X,1)
  1.  Q
  1.  ;
  1. SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
  1.  S APCHSITE=""
  1.  I $D(^AUPNVSIT(APCHVIEN,21))#2 S APCHSITE=$P(^(21),U) Q
  1.  Q:$P(^AUPNVSIT(APCHVIEN,0),U,6)=""
  1.  I $P(^AUPNVSIT(APCHVIEN,0),U,6)'=DUZ(2) S APCHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(APCHVIEN,0),U,6),0),U),1,30)
  1.  Q
  1.  ;
  1. DC(V) ;is this d/c'ed
  1.  I '$D(^AUPNVMED(V,0)) Q 0
  1.  I $P(^AUPNVMED(V,0),U,8)]"" Q 1
  1.  NEW P,S
  1.  S P=$S($D(^PSRX("APCC",N)):$O(^(N,0)),1:0)
  1.  I 'P Q 0
  1.  S X=$P($G(^PSRX(P,0)),U,15)
  1.  I X=12 Q 1
  1.  I X=13 Q 1
  1.  I X=14 Q 1
  1.  I X=15 Q 1
  1.  S X=$P($G(^PSRX(P,"STA")),U,1)
  1.  I X=12 Q 1
  1.  I X=13 Q 1
  1.  I X=14 Q 1
  1.  I X=15 Q 1
  1.  Q 0
  1. SIG ;
  1.  ;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 ;
  1.  ;DETERMINE THE NUMBER OF REFILLS REMAINING
  1.  I 'APCHSRX S APCHSREF="unknown # refills" 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. PROV ;GET THE PROVIDER FOR ORIGINAL RX OR REFILL
  1.  S APCHPROV=""
  1.  I 'APCHSRX S APCHPROV=$$VAL^XBDIQ1(9000010.14,1202,APCHMIEN) Q
  1.  S APCHIPRV=$S(APCHRXRF=0:$P($G(^PSRX(APCHSRX,0)),"^",4),1:$P($G(^PSRX(APCHSRX,1,APCHRXRF,0)),"^",17))
  1.  S APCHPROV=$S('APCHIPRV:"UNKNOWN PROVIDER",1:$P(^VA(200,APCHIPRV,0),"^"))
  1.  Q
  1.  ;
  1. CLN ;GET CLINIC FOR V MEDICATION
  1.  S APCHCLN=$E($$VAL^XBDIQ1(9000010,APCHVIEN,.08),1,10)
  1.  Q
  1. DATE(D) ;EP
  1.  I D="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
  1.  ;
  1. CHRONIC(N) ;
  1.  I '$G(N) Q ""
  1.  I '$D(^AUPNVMED(N)) Q ""
  1.  NEW X,Y,P
  1.  S P=$P(^AUPNVMED(N,0),U,2)
  1.  S X=$S($D(^PSRX("APCC",N)):$O(^(N,0)),1:0)
  1.  S Y=$S(+X:$D(^PS(55,P,"P","CP",X)),1:0)
  1.  I 'Y Q ""
  1.  Q 1
  1. W(Y,F,C,T) ;set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  NEW %,X
  1.  ;blank lines
  1.  F F=1:1:F S X="" W !,X
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  W !,X Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  W !,X
  1.  Q
  1. PRTTXT ; GENERALIZED TEXT PRINTER
  1.  S APCHTDLT=1,APCHTILN=80-APCHSICL-1
  1.  F APCHTQ=0:0 S:APCHSNRQ]""&(($L(APCHSNRQ)+$L(APCHSTXT)+2)<255) APCHSTXT=$S(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ,APCHSNRQ="" Q:APCHSTXT=""  D PRTTXT2
  1.  K APCHTILN,APCHTDLT,APCHTF,APCHTC,APCHSTXT,APCHSDOO
  1.  Q
  1. PRTTXT2 D GETFRAG S X="",$E(X,APCHSICL)=APCHTF D W(X) S APCHSICL=APCHSICL+APCHTDLT,APCHTILN=APCHTILN-APCHTDLT,APCHTDLT=0
  1.  Q
  1. GETFRAG I $L(APCHSTXT)<APCHTILN S APCHTF=APCHSTXT,APCHSTXT="" Q
  1.  F APCHTC=APCHTILN:-1:1 Q:$E(APCHSTXT,APCHTC)=" "
  1.  S APCHTF=$E(APCHSTXT,1,APCHTC-1),APCHSTXT=$E(APCHSTXT,APCHTC+1,255)
  1.  Q
  1.  ;