APCHS7C ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,5**;MAY 14, 2009
;
;
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
S APCHSMTY="NODUP"
;
CONT ; <SETUP>
;Q:'$D(^AUPNVMED("AC",APCHSPAT))
X APCHSCKP Q:$D(APCHSQIT) I 'APCHSNPG W ! X APCHSBRK
; <BUILD>
K ^TMP($J,"APCHSMED")
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
.Q:$P($G(^AUPNVMED(APCHSMX,11)),U,8)
.S M=+^AUPNVMED(APCHSMX,0)
.Q:'$D(^PSDRUG(M,0))
.Q:'$$CS(M) ;controlled substances only
.S $P(^TMP($J,"APCHSMED",M),U)=$P($G(^TMP($J,"APCHSMED",M)),U)+1
.S X=$P(^TMP($J,"APCHSMED",M),U)
.I X<99 S $P(^TMP($J,"APCHSMED",M),U,(X+1))=$$FMTE^XLFDT((9999999-APCHSIVD),5)_";"_$$VAL^XBDIQ1(9000010.14,APCHSMX,1202)_";"_$$VAL^XBDIQ1(9000010,$P(^AUPNVMED(APCHSMX,0),U,3),.06)
K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP"),^TMP($J,"APCHSNO")
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
D NONVA
; <DISPLAY>
;REBUILD LIST BY NAME (TRADE OR GENERIC) AND DATE
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
.S APCHSCC=APCHSCC+1 D MEDDSP
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
.S APCHSCC=APCHSCC+1 D MEDDSP
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
.S APCHSCC=APCHSCC+1 D MEDDSP
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
.S APCHSCC=APCHSCC+1 D MEDDSP
;CLEANUP
;hold meds
;D HOLDDSP^APCHS7
;Q:$D(APCHSQIT)
;now display MED refusals
;S APCHST="MEDICATION",APCHSFN=50 D DISPREF^APCHS3C
D MEDRU^APCHS7
K APCHST,APCHSFN
MEDX K APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP,APCHSNON,APCHSDLU,APCHSIEN
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT,APCHSMTY,APCHSALT
K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP"),^TMP($J,"APCHSNO"),^TMP($J,"APCHSMED")
K X1,X2,X,Y
Q
NONVA ;EP ;quit if chronic
S X=0 F S X=$O(^PS(55,APCHSPAT,"NVA",X)) Q:X'=+X D
.;S L=$P(^PS(55,APCHSPAT,"NVA",X,0),U,9)
.I $P($G(^PS(55,APCHSPAT,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,APCHSPAT,"NVA",X,999999911),U,1),0)) Q
.;S L=$P(^PS(55,APCHSPAT,"NVA",X,0),U,9)
.;:'L
.S L=$P($P($G(^PS(55,APCHSPAT,"NVA",X,0)),U,10),".")
.S L=9999999-L
.Q:L>APCHSDLM
.;S M=$P($G(^PS(55,APCHSPAT,"NVA",X,999999911)),U,1) ;passed to PCC so got it already
.;I M,$D(^AUPNVMED(M)) Q ;passed to PCC and v med exists so we already got it from V MED
.S D=$P(^PS(55,APCHSPAT,"NVA",X,0),U,2)
.I D="" S D="NO DRUG IEN" Q
.Q:'$$CS(D)
.S APCHSCRX=0 I D S APCHSCRX=$$CS(D)
.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))
.;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)
.;S ^TMP($J,"APCHSMTB",N)=$P(^PS(55,APCHSPAT,"NVA",X,0),U,6)
.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,5)
.I $D(^TMP($J,"APCHSMTB",N)) Q
.S ^TMP($J,"APCHSMTB",N)=$P(^PS(55,APCHSPAT,"NVA",X,0),U,6) ;,^TMP($J,"APCHSMTP",L_"-"_N)=APCHSMX_"^"_APCHSCHR_"^"_APCHSCRX
Q
MEDBLD ;BUILD ARRAY OF MEDICATIONS
;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
;VDF=VISIT FILE DATE
Q:'$D(^AUPNVMED(APCHSMX,0))
Q:$P($G(^AUPNVMED(APCHSMX,11)),U,8)]""
S APCHSN=^AUPNVMED(APCHSMX,0)
Q:'$D(^PSDRUG($P(APCHSN,U,1)))
Q:'$$CS($P(APCHSN,U,1))
S APCHSDTM=-APCHSIVD\1+9999999
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")
S APCHSCRX=$$CS($P(APCHSN,U))
D @APCHSMTY
Q
NODUP ;
;I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
;S X="" F S X=$O(^TMP($J,"APCHSMTP",X)) Q:X="" I $P(X,"-",2)=APCHSMFX K ^TMP($J,"APCHSMTP",X)
I $D(^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)) S ^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX_"^"_APCHSCHR_"^"_APCHSCRX
I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX_"^"_APCHSCHR_"^"_APCHSCRX
Q
MEDDSP ;DISPLAY MEDICATION
;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
S APCHSMX=$P(^TMP($J,"APCHSMTP",APCHSIVD),U)
I 'APCHSMX D NVADSP Q
S APCHSCRX=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,3)
S APCHSN=^AUPNVMED(APCHSMX,0)
S APCHSIEN=+APCHSN
S APCHSRX=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0)
S APCHSCRN=$S(+APCHSRX:$D(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
S (Y,APCHSDTM)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
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
S X1=DT,X2=APCHSDTM D ^%DTC ;Q:X>60&(X>(2*APCHSDYS))
S APCHSEXP=""
S APCHSMED=$S($P(APCHSN,U,4)="":$P(^PSDRUG(APCHSMFX,0),U,1),1:$P(APCHSN,U,4))
S APCHSALT=$P($G(^AUPNVMED(APCHSMX,12)),U,12) ;IHS/CMI/GRL
S APCHEXPD=$$VALI^XBDIQ1(52,APCHSRX,26) S APCHEXPD=$$FMTE^XLFDT(APCHEXPD,5)
I APCHSDC S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
S APCHORTS=$P($G(^AUPNVMED(APCHSMX,11)),U)
I APCHORTS["RETURNED TO STOCK",APCHSDC S APCHSEXP="--RTS "_Y
D SIG S APCHSIG=APCHSSGY
D REF I APCHSREF S APCHSIG=APCHSIG_" "_APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
S V=$P(^AUPNVMED(APCHSMX,0),U,3) I $P($G(^AUPNVSIT(+V,0)),U,7)="E" S APCHSIG=APCHSIG_" (OUTSIDE MEDICATION)"
D SITE
X APCHSCKP Q:$D(APCHSQIT)
W APCHSDAT,?10,?14,APCHSMED W:APCHSQTY " #",APCHSQTY
W:APCHSDYS " (",APCHSDYS," days) " W APCHSEXP
I APCHEXPD]"" W "(expires "_APCHEXPD_")"
W !
I APCHSITE]"" W ?14,"Dispensed at: ",APCHSITE,!
I $G(APCHSALT)]"" I $E($G(APCHSALT),1,6)'=$E($G(APCHSMED),1,6) W ?14,"("_APCHSALT_")",! ;IHS/CMI/GRL
X APCHSCKP Q:$D(APCHSQIT)
S APCHSICL=14,APCHSNRQ="",APCHSTXT=" "_APCHSIG D PRTTXT^APCHSUTL K APCHSICL,APCHSNRQ,APCHSP
S Y=$P(^TMP($J,"APCHSMED",APCHSIEN),U)
Q:Y<2
X APCHSCKP Q:$D(APCHSQIT)
W ?16,"Previous fill dates:",!
F APCHI=3:1 Q:$P(^TMP($J,"APCHSMED",APCHSIEN),U,APCHI)="" D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?16,$P($P(^TMP($J,"APCHSMED",APCHSIEN),U,APCHI),";",1)
.W ?27,$P($P(^TMP($J,"APCHSMED",APCHSIEN),U,APCHI),";",2)
.W ?57,$P($P(^TMP($J,"APCHSMED",APCHSIEN),U,APCHI),";",3),!
W !
Q
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
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 ;EP - DETERMINE THE NUMBER OF REFILLS REMAINING
I 'APCHSRX S APCHSREF=0 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
;
;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
S APCHSITE=""
I $D(^AUPNVSIT(APCHSVDF,21))#2 S APCHSITE=$P(^(21),U) Q
Q:$P(^AUPNVSIT(APCHSVDF,0),U,6)=""
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)
Q
;
CS(D) ;
I $P(^PSDRUG(D,0),U,3)="" Q 0
NEW Y S Y=$P(^PSDRUG(D,0),U,3)
;I Y[1 Q 1
I Y[2 Q 1
I Y[3 Q 1
I Y[4 Q 1
I Y[5 Q 1
;I Y["C" Q 1
;I Y["A" Q 1
Q 0
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
NVADSP ;
S APCHSEXP=""
S (Y,APCHSDTM)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
S APCHSDC=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,5)
S APCHSCRX=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,3)
S APCHSMED=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,4)
I APCHSDC S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
S APCHSIG=$P(^TMP($J,"APCHSMTP",APCHSIVD),U,6)
X APCHSCKP Q:$D(APCHSQIT)
W APCHSDAT,?10,$S(APCHSCRX:"CRX",1:""),?14,APCHSMED," ",APCHSEXP,!
X APCHSCKP Q:$D(APCHSQIT)
S APCHSICL=14,APCHSNRQ="",APCHSTXT=APCHSIG_" (EHR OUTSIDE MEDICATION)" D PRTTXT^APCHSUTL K APCHSICL,APCHSNRQ,APCHSP
Q
APCHS7C ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,5**;MAY 14, 2009
+2 ;
+3 ;
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
+1 SET APCHSMTY="NODUP"
+2 ;
CONT ; <SETUP>
+1 ;Q:'$D(^AUPNVMED("AC",APCHSPAT))
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
WRITE !
XECUTE APCHSBRK
+3 ; <BUILD>
+4 KILL ^TMP($JOB,"APCHSMED")
+5 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVMED("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
SET APCHSMX=0
FOR
SET APCHSMX=$ORDER(^AUPNVMED("AA",APCHSPAT,APCHSIVD,APCHSMX))
IF APCHSMX=""
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^AUPNVMED(APCHSMX,11)),U,8)
QUIT
+7 SET M=+^AUPNVMED(APCHSMX,0)
+8 IF '$DATA(^PSDRUG(M,0))
QUIT
+9 ;controlled substances only
IF '$$CS(M)
QUIT
+10 SET $PIECE(^TMP($JOB,"APCHSMED",M),U)=$PIECE($GET(^TMP($JOB,"APCHSMED",M)),U)+1
+11 SET X=$PIECE(^TMP($JOB,"APCHSMED",M),U)
+12 IF X<99
SET $PIECE(^TMP($JOB,"APCHSMED",M),U,(X+1))=$$FMTE^XLFDT((9999999-APCHSIVD),5)_";"_$$VAL^XBDIQ1(9000010.14,APCHSMX,1202)_";"_$$VAL^XBDIQ1(9000010,$PIECE(^AUPNVMED(APCHSMX,0),U,3),.06)
End DoDot:1
+13 KILL ^TMP($JOB,"APCHSMTB"),^TMP($JOB,"APCHSMTP"),^TMP($JOB,"APCHSNO")
+14 SET APCHSIVD=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVMED("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
SET APCHSMX=0
FOR APCHSQ=0:0
SET APCHSMX=$ORDER(^AUPNVMED("AA",APCHSPAT,APCHSIVD,APCHSMX))
IF APCHSMX=""
QUIT
DO MEDBLD
+15 DO NONVA
+16 ; <DISPLAY>
+17 ;REBUILD LIST BY NAME (TRADE OR GENERIC) AND DATE
+18 SET (APCHSIVD,APCHSCC,APCHSCRX)=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSMTP",APCHSIVD))
IF 'APCHSIVD
QUIT
IF $PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,2)="C"
IF $PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,3)=0
Begin DoDot:1
+19 SET APCHSCC=APCHSCC+1
DO MEDDSP
End DoDot:1
+20 SET (APCHSIVD)=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSMTP",APCHSIVD))
IF 'APCHSIVD
QUIT
IF $PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,2)="C"
IF $PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,3)=1
Begin DoDot:1
+21 SET APCHSCC=APCHSCC+1
DO MEDDSP
End DoDot:1
+22 SET (APCHSIVD,APCHSCC)=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSMTP",APCHSIVD))
IF 'APCHSIVD
QUIT
IF $PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,2)'="C"
IF $PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,3)=0
Begin DoDot:1
+23 SET APCHSCC=APCHSCC+1
DO MEDDSP
End DoDot:1
+24 SET (APCHSIVD)=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSMTP",APCHSIVD))
IF 'APCHSIVD
QUIT
IF $PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,2)'="C"
IF $PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,3)=1
Begin DoDot:1
+25 SET APCHSCC=APCHSCC+1
DO MEDDSP
End DoDot:1
+26 ;CLEANUP
+27 ;hold meds
+28 ;D HOLDDSP^APCHS7
+29 ;Q:$D(APCHSQIT)
+30 ;now display MED refusals
+31 ;S APCHST="MEDICATION",APCHSFN=50 D DISPREF^APCHS3C
+32 DO MEDRU^APCHS7
+33 KILL APCHST,APCHSFN
MEDX KILL APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP,APCHSNON,APCHSDLU,APCHSIEN
+1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT,APCHSMTY,APCHSALT
+2 KILL ^TMP($JOB,"APCHSMTB"),^TMP($JOB,"APCHSMTP"),^TMP($JOB,"APCHSNO"),^TMP($JOB,"APCHSMED")
+3 KILL X1,X2,X,Y
+4 QUIT
NONVA ;EP ;quit if chronic
+1 SET X=0
FOR
SET X=$ORDER(^PS(55,APCHSPAT,"NVA",X))
IF X'=+X
QUIT
Begin DoDot:1
+2 ;S L=$P(^PS(55,APCHSPAT,"NVA",X,0),U,9)
+3 IF $PIECE($GET(^PS(55,APCHSPAT,"NVA",X,999999911)),U,1)
IF $DATA(^AUPNVMED($PIECE(^PS(55,APCHSPAT,"NVA",X,999999911),U,1),0))
QUIT
+4 ;S L=$P(^PS(55,APCHSPAT,"NVA",X,0),U,9)
+5 ;:'L
+6 SET L=$PIECE($PIECE($GET(^PS(55,APCHSPAT,"NVA",X,0)),U,10),".")
+7 SET L=9999999-L
+8 IF L>APCHSDLM
QUIT
+9 ;S M=$P($G(^PS(55,APCHSPAT,"NVA",X,999999911)),U,1) ;passed to PCC so got it already
+10 ;I M,$D(^AUPNVMED(M)) Q ;passed to PCC and v med exists so we already got it from V MED
+11 SET D=$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,2)
+12 IF D=""
SET D="NO DRUG IEN"
QUIT
+13 IF '$$CS(D)
QUIT
+14 SET APCHSCRX=0
IF D
SET APCHSCRX=$$CS(D)
+15 SET N=$SELECT(D:$PIECE(^PSDRUG(D,0),U,1),1:$PIECE(^PS(50.7,$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,1),0),U,1))
+16 ;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)
+17 ;S ^TMP($J,"APCHSMTB",N)=$P(^PS(55,APCHSPAT,"NVA",X,0),U,6)
+18 SET ^TMP($JOB,"APCHSMTP",L_"-"_N)="^"_"Z"_"^"_APCHSCRX_"^"_N_"^"_$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,7)_U_$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,5)
+19 IF $DATA(^TMP($JOB,"APCHSMTB",N))
QUIT
+20 ;,^TMP($J,"APCHSMTP",L_"-"_N)=APCHSMX_"^"_APCHSCHR_"^"_APCHSCRX
SET ^TMP($JOB,"APCHSMTB",N)=$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,6)
End DoDot:1
+21 QUIT
MEDBLD ;BUILD ARRAY OF MEDICATIONS
+1 ;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
+2 ;VDF=VISIT FILE DATE
+3 IF '$DATA(^AUPNVMED(APCHSMX,0))
QUIT
+4 IF $PIECE($GET(^AUPNVMED(APCHSMX,11)),U,8)]""
QUIT
+5 SET APCHSN=^AUPNVMED(APCHSMX,0)
+6 IF '$DATA(^PSDRUG($PIECE(APCHSN,U,1)))
QUIT
+7 IF '$$CS($PIECE(APCHSN,U,1))
QUIT
+8 SET APCHSDTM=-APCHSIVD\1+9999999
+9 SET APCHSDC=$PIECE(APCHSN,U,8)
SET APCHSDYS=$PIECE(APCHSN,U,7)
SET APCHSMFX=$SELECT($PIECE(APCHSN,U,4)="":+APCHSN,$PIECE(APCHSN,U,4)=$PIECE(^PSDRUG(+APCHSN,0),U):+APCHSN,1:$PIECE(APCHSN,U,4))
SET APCHSCHR=$$CHRONIC^APCHS72(APCHSMX)
SET APCHSCHR=$SELECT(APCHSCHR=1:"C",1:"Z")
+10 SET APCHSCRX=$$CS($PIECE(APCHSN,U))
+11 DO @APCHSMTY
+12 QUIT
NODUP ;
+1 ;I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
+2 ;S X="" F S X=$O(^TMP($J,"APCHSMTP",X)) Q:X="" I $P(X,"-",2)=APCHSMFX K ^TMP($J,"APCHSMTP",X)
+3 IF $DATA(^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX))
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX_"^"_APCHSCHR_"^"_APCHSCRX
+4 IF $DATA(^TMP($JOB,"APCHSMTB",APCHSMFX))
QUIT
+5 SET ^TMP($JOB,"APCHSMTB",APCHSMFX)=APCHSDC
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX_"^"_APCHSCHR_"^"_APCHSCRX
+6 QUIT
MEDDSP ;DISPLAY MEDICATION
+1 ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
+2 SET APCHSMX=$PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U)
+3 IF 'APCHSMX
DO NVADSP
QUIT
+4 SET APCHSCRX=$PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,3)
+5 SET APCHSN=^AUPNVMED(APCHSMX,0)
+6 SET APCHSIEN=+APCHSN
+7 SET APCHSRX=$SELECT($DATA(^PSRX("APCC",APCHSMX)):$ORDER(^(APCHSMX,0)),1:0)
+8 SET APCHSCRN=$SELECT(+APCHSRX:$DATA(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
+9 SET (Y,APCHSDTM)=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+10 SET APCHSDC=$PIECE(APCHSN,U,8)
SET APCHSDYS=$PIECE(APCHSN,U,7)
SET APCHSQTY=$PIECE(APCHSN,U,6)
SET APCHSIG=$PIECE(APCHSN,U,5)
SET APCHSVDF=$PIECE(APCHSN,U,3)
SET APCHSMFX=+APCHSN
+11 ;Q:X>60&(X>(2*APCHSDYS))
SET X1=DT
SET X2=APCHSDTM
DO ^%DTC
+12 SET APCHSEXP=""
+13 SET APCHSMED=$SELECT($PIECE(APCHSN,U,4)="":$PIECE(^PSDRUG(APCHSMFX,0),U,1),1:$PIECE(APCHSN,U,4))
+14 ;IHS/CMI/GRL
SET APCHSALT=$PIECE($GET(^AUPNVMED(APCHSMX,12)),U,12)
+15 SET APCHEXPD=$$VALI^XBDIQ1(52,APCHSRX,26)
SET APCHEXPD=$$FMTE^XLFDT(APCHEXPD,5)
+16 IF APCHSDC
SET Y=APCHSDC
XECUTE APCHSCVD
SET APCHSEXP="-- D/C "_Y
+17 SET APCHORTS=$PIECE($GET(^AUPNVMED(APCHSMX,11)),U)
+18 IF APCHORTS["RETURNED TO STOCK"
IF APCHSDC
SET APCHSEXP="--RTS "_Y
+19 DO SIG
SET APCHSIG=APCHSSGY
+20 DO REF
IF APCHSREF
SET APCHSIG=APCHSIG_" "_APCHSREF_$SELECT(APCHSREF=1:" refill",1:" refills")_" left."
+21 SET V=$PIECE(^AUPNVMED(APCHSMX,0),U,3)
IF $PIECE($GET(^AUPNVSIT(+V,0)),U,7)="E"
SET APCHSIG=APCHSIG_" (OUTSIDE MEDICATION)"
+22 DO SITE
+23 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+24 WRITE APCHSDAT,?10,?14,APCHSMED
IF APCHSQTY
WRITE " #",APCHSQTY
+25 IF APCHSDYS
WRITE " (",APCHSDYS," days) "
WRITE APCHSEXP
+26 IF APCHEXPD]""
WRITE "(expires "_APCHEXPD_")"
+27 WRITE !
+28 IF APCHSITE]""
WRITE ?14,"Dispensed at: ",APCHSITE,!
+29 ;IHS/CMI/GRL
IF $GET(APCHSALT)]""
IF $EXTRACT($GET(APCHSALT),1,6)'=$EXTRACT($GET(APCHSMED),1,6)
WRITE ?14,"("_APCHSALT_")",!
+30 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+31 SET APCHSICL=14
SET APCHSNRQ=""
SET APCHSTXT=" "_APCHSIG
DO PRTTXT^APCHSUTL
KILL APCHSICL,APCHSNRQ,APCHSP
+32 SET Y=$PIECE(^TMP($JOB,"APCHSMED",APCHSIEN),U)
+33 IF Y<2
QUIT
+34 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+35 WRITE ?16,"Previous fill dates:",!
+36 FOR APCHI=3:1
IF $PIECE(^TMP($JOB,"APCHSMED",APCHSIEN),U,APCHI)=""
QUIT
Begin DoDot:1
+37 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+38 WRITE ?16,$PIECE($PIECE(^TMP($JOB,"APCHSMED",APCHSIEN),U,APCHI),";",1)
+39 WRITE ?27,$PIECE($PIECE(^TMP($JOB,"APCHSMED",APCHSIEN),U,APCHI),";",2)
+40 WRITE ?57,$PIECE($PIECE(^TMP($JOB,"APCHSMED",APCHSIEN),U,APCHI),";",3),!
End DoDot:1
+41 WRITE !
+42 QUIT
+43 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 SET APCHSSGY=""
FOR APCHSP=1:1:$LENGTH(APCHSIG," ")
SET X=$PIECE(APCHSIG," ",APCHSP)
IF X]""
Begin DoDot:1
+2 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)
+3 SET APCHSSGY=APCHSSGY_X_" "
End DoDot:1
+4 QUIT
+5 ;
REF ;EP - DETERMINE THE NUMBER OF REFILLS REMAINING
+1 IF 'APCHSRX
SET APCHSREF=0
QUIT
+2 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
+3 SET APCHSREF=APCHSRFL
+4 QUIT
+5 ;
+6 ;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
+1 SET APCHSITE=""
+2 IF $DATA(^AUPNVSIT(APCHSVDF,21))#2
SET APCHSITE=$PIECE(^(21),U)
QUIT
+3 IF $PIECE(^AUPNVSIT(APCHSVDF,0),U,6)=""
QUIT
+4 IF $PIECE(^AUPNVSIT(APCHSVDF,0),U,6)'=DUZ(2)
SET APCHSITE=$EXTRACT($PIECE(^DIC(4,$PIECE(^AUPNVSIT(APCHSVDF,0),U,6),0),U),1,30)
+5 QUIT
+6 ;
CS(D) ;
+1 IF $PIECE(^PSDRUG(D,0),U,3)=""
QUIT 0
+2 NEW Y
SET Y=$PIECE(^PSDRUG(D,0),U,3)
+3 ;I Y[1 Q 1
+4 IF Y[2
QUIT 1
+5 IF Y[3
QUIT 1
+6 IF Y[4
QUIT 1
+7 IF Y[5
QUIT 1
+8 ;I Y["C" Q 1
+9 ;I Y["A" Q 1
+10 QUIT 0
+11 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
NVADSP ;
+1 SET APCHSEXP=""
+2 SET (Y,APCHSDTM)=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+3 SET APCHSDC=$PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,5)
+4 SET APCHSCRX=$PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,3)
+5 SET APCHSMED=$PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,4)
+6 IF APCHSDC
SET Y=APCHSDC
XECUTE APCHSCVD
SET APCHSEXP="-- D/C "_Y
+7 SET APCHSIG=$PIECE(^TMP($JOB,"APCHSMTP",APCHSIVD),U,6)
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE APCHSDAT,?10,$SELECT(APCHSCRX:"CRX",1:""),?14,APCHSMED," ",APCHSEXP,!
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 SET APCHSICL=14
SET APCHSNRQ=""
SET APCHSTXT=APCHSIG_" (EHR OUTSIDE MEDICATION)"
DO PRTTXT^APCHSUTL
KILL APCHSICL,APCHSNRQ,APCHSP
+12 QUIT
