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