BHSMEDR ;IHS/MSC/MGH - Health Summary for MED RECONCILIATION ;01-May-2014 11:12;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**4,6,8,9**;March 17, 2006;Build 16
;;---------------------------------------------------------------
; IHS/CMI/LAB - APCHS7R -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;
;Patch 6 for non-VA meds
SET ;
S BHSRX=P,BHSREF=0 D REF
S BHSTAT(C,N,D,(9999999-F),M)=$S(P:$P(^PSRX(P,0),U),1:"")_U_BHSREF
S $P(BHSTAT(C,N,D,(9999999-F),M),U,10)=P
S BHMDSP(D,N,F)=""
Q
MEDRCON ; ************* MEDS BY PRESCRIPTION STATUS *************
;
CONT ; <SETUP>
N BHSPAT,BHSQ
S BHSPAT=DFN
I '$D(^AUPNVMED("AC",BHSPAT)),'$D(^PS(52.41,"P",BHSPAT)) Q
D CKP^GMTSUP Q:$D(GMTSQIT)
; <BUILD>
NEW BHMEDS,BHSTAT,BHCNT,BHMDSP,BHDI,BHDT,BHM,BHN,BHSSGY,BHSIG,BHZ,BHSN,BHST,BHI,BHD,BHS11
NEW X,F,M,V,D,N,P,C,E,S,R,J,BHSITE,BHSORT,BHSP,BHSREF,BHSRFL,BHSRX,BHSVDF,BHT,BHSNVA
S BHCNT=0
K BHMEDS,BHMDSP
D GETMEDS^APCHSMU1(BHSPAT,$$FMADD^XLFDT(DT,-395),DT,,,,,.BHMEDS)
;I '$D(APCHMEDS) D MEDX Q
;NOW REORDER THEM BY STATUS
K BHSTAT
S X=0 F S X=$O(BHMEDS(X)) Q:X'=+X D
.S P=""
.S F=$P(BHMEDS(X),U,1) ;FILL DATE
.S M=$P(BHMEDS(X),U,4) ;vmed ien
.S V=$P(BHMEDS(X),U,5) ;visit ien
.S D=$P(^AUPNVMED(M,0),U) ;drug ien
.S N=$P(^AUPNVMED(M,0),U,4) ;non table drug name
.I N="" S N=$P(^PSDRUG(D,0),U) ;drug name
.I $P($G(^AUPNVSIT(X,0)),U,7)="E" S C="OUTSIDE MEDICATIONS" D SET Q
.I $P($G(^AUPNVSIT(X,11)),U,8) S C="OUTSIDE MEDICATIONS" D SET Q
.S P=$O(^PSRX("APCC",M,0))
.I 'P S C="OUTSIDE MEDICATIONS" D SET Q
.I '$D(^PSRX(P,0)) S P="",C="OUTSIDE MEDICATIONS" D SET Q
.;Patch 8 for autofinished meds
.I $$VALI^XBDIQ1(52,P,9999999.23)=1 S C="OUTSIDE PHARMACY MEDS" D SET Q
.S S=$$VALI^XBDIQ1(52,P,100) ;GET STATUS
.I S=0 S C="ACTIVE MEDICATIONS" D SET Q
.I S=3 S C="HOLD" D SET Q
.I S=5 S C="SUSPENDED" D SET Q
.I S=11 D Q
..;get expiration date
..S E=$P($G(^PSRX(P,3)),U,6)
..S R=$$CHRONIC^APCHS72(M) ;chronic flag
..I 'R D Q
...;not chronic, check to see if expired in past 14 days, if not quit
...S J=$$FMDIFF^XLFDT(DT,E)
...Q:J>14 ;more than 14 days ago so don't display
...;check to see if same drug is already listed somewhere
...Q:$O(BHMDSP(D,N,F)) ;another of same drug after this date
...S C="EXPIRED" D SET Q
..;chronic = check 120 days
..S J=$$FMDIFF^XLFDT(DT,E)
..Q:J>120 ;expired more than 120 days ago
..Q:$O(BHMDSP(D,N,F)) ;another one there so don't display this one
..S C="EXPIRED" D SET Q
.I S=12!(S=14) D
..S E=$P(^AUPNVMED(M,0),U,8) ;discontinued date in v med
..I E="" S E=$P($G(^PSRX(P,3)),U,5) ;canceled date in 52
..I $$FMDIFF^XLFDT(DT,E)>30 Q ;only discontinueds in past 30 days
..Q:$O(BHMDSP(D,N,F))
..S C="DISCONTINUED MEDICATIONS" D SET Q
GETNVA ;NVA from file 55
N L,D,N,X,DC
S X=0 F S X=$O(^PS(55,BHSPAT,"NVA",X)) Q:X'=+X D
.S DC=0
.I $P($G(^PS(55,BHSPAT,"NVA",X,999999911)),U,1) D Q:DC=1
..I $D(^AUPNVMED($P(^PS(55,BHSPAT,"NVA",X,999999911),U,1),0)) D
...I $P($G(^PS(55,BHSPAT,"NVA",X,0)),U,6)'="" S DC=1
.S L=$P($P($G(^PS(55,BHSPAT,"NVA",X,0)),U,10),".")
.S L=9999999-L
.S D=$P(^PS(55,BHSPAT,"NVA",X,0),U,2)
.I D="" S D="NO DRUG IEN"
.S N=$S(D:$P(^PSDRUG(D,0),U,1),1:$P(^PS(50.7,$P(^PS(55,BHSPAT,"NVA",X,0),U,1),0),U,1))
.S BHSTAT("NVA",N,D,(9999999-L))=U_"N",$P(BHSTAT("NVA",N,D,(9999999-L)),U,8)=$P(^PS(55,BHSPAT,"NVA",X,0),U,4)_" "_$P(^PS(55,BHSPAT,"NVA",X,0),U,5)_U_$P(^PS(55,BHSPAT,"NVA",X,0),U,7)
.S $P(BHSTAT("NVA",N,D,(9999999-L)),U,10)=X
GETPEND ;
NEW PEN,ORD
F PEN=0:0 S PEN=$O(^PS(52.41,"P",BHSPAT,PEN)) Q:'PEN S ORD=^PS(52.41,PEN,0),BHI=$P(ORD,"^",8),BHD=+$P(ORD,"^",9) D:$P(ORD,"^",3)'="DC"&($P(ORD,"^",3)'="DE")&($P(ORD,"^",3)'="HD")
.S BHN=$S(BHD:$P($G(^PSDRUG(BHD,0)),"^"),+BHI&('BHD):$P(^PS(50.7,BHI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,BHI,0),"^",2),0),"^"),1:"") Q:BHN']""
.S BHSTAT("PENDING",BHN,PEN)=$$VAL^XBDIQ1(52.41,PEN,13)
.S C=0,X="" F S C=$O(^PS(52.41,PEN,"SIG",C)) Q:'C S X=X_$S(X]"":" ",1:"")_^PS(52.41,PEN,"SIG",C,0)
.S $P(BHSTAT("PENDING",BHN,PEN),U,2)=X
DISP ;DISPLAY MEDS
;ACTIVE MEDS FIRST - ALL OF THEM
D CKP^GMTSUP Q:$D(GMTSQIT)
I '$D(BHSTAT("ACTIVE MEDICATIONS")) G OUT
W "ACTIVE MEDICATIONS",!
S BHCNT=0
S BHT=1
S BHN="" F S BHN=$O(BHSTAT("ACTIVE MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHDT=0 F S BHDT=$O(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
...S BHM=0 F S BHM=$O(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
D CKP^GMTSUP Q:$D(GMTSQIT)
I '$D(BHSTAT("OUTSIDE PHARMACY MEDS")) G OUT
W "OUTSIDE PHARMACY MEDS",!
S BHCNT=0
S BHT=1
S BHN="" F S BHN=$O(BHSTAT("OUTSIDE PHARMACY MEDS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHDT=0 F S BHDT=$O(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
...S BHM=0 F S BHM=$O(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT,BHM) D MEDDSP
OUT ;OUTSIDE MEDICATIONS
I '$D(BHSTAT("OUTSIDE MEDICATIONS"))&('$D(BHSTAT("NVA"))) G HOLD
W "--------------------",!
W "OUTSIDE MEDICATIONS",!
S BHN="" F S BHN=$O(BHSTAT("OUTSIDE MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHDT=0 S BHDT=$O(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
...S BHM=0 S BHM=$O(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSPO
;now display nva
S BHN="" F S BHN=$O(BHSTAT("NVA",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("NVA",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHDT=0 S BHDT=$O(BHSTAT("NVA",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
...S BHZ=BHSTAT("NVA",BHN,BHDI,BHDT) D MEDDSPN
HOLD ;HOLD MEDICATIONS
I '$D(BHSTAT("HOLD MEDICATIONS")) G SUSPEND
S BHT=3
W "--------------------",!
W "ACTIVE NOT DISPENSED MEDICATIONS",!
S BHN="" F S BHN=$O(BHSTAT("HOLD MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("HOLD MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHDT=0 F S BHDT=$O(BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
...S BHM=0 F S BHM=$O(BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
SUSPEND ;
I '$D(BHSTAT("SUSPEND MEDICATIONS")) G PENDING
S BHT=4
W !,"--------------------",!
W "SUSPENDED MEDICATIONS",!
S BHN="" F S BHN=$O(BHSTAT("SUSPEND MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHDT=0 F S BHDT=$O(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
...S BHM=0 F S BHM=$O(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
PENDING ;
I '$D(BHSTAT("PENDING")) G EXPIRED
W "--------------------",!
W "PENDING MEDICATIONS",!
S BHN="" F S BHN=$O(BHSTAT("PENDING",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("PENDING",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHZ=BHSTAT("PENDING",BHN,BHDI) D MEDDSPP
EXPIRED ;
I '$D(BHSTAT("EXPIRED MEDICATIONS")) G DISCONT
S BHT=6
W "--------------------",!
W "CHRONIC AND RECENTLY EXPIRED MEDICATIONS",!
S BHN="" F S BHN=$O(BHSTAT("EXPIRED MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHDT=0 F S BHDT=$O(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
...S BHM=0 F S BHM=$O(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
DISCONT ;
I '$D(BHSTAT("DISCONTINUED MEDICATIONS")) G MEDX
S BHT=7
W "--------------------",!
W "RECENTLY DISCONTINUED MEDICATIONS",!
S BHN="" F S BHN=$O(BHSTAT("DISCONTINUED MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
.S BHDI="" F S BHDI=$O(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
..S BHDT=0 F S BHDT=$O(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
...S BHM=0 F S BHM=$O(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
MEDX ;
Q
MEDDSPP ;DISPLAY MEDICATION
N BHSRX,BHSORD
S BHCNT=BHCNT+1
S BHS11=$G(^AUPNVMED(BHZ,11))
D CKP^GMTSUP Q:$D(GMTSQIT)
W BHCNT,".",?6,BHN W:$P(BHZ,U,2) ?60,"Refills: ",$S('$P(BHZ,U,1):"NONE",1:$P(BHZ,U,1)) W !
D CKP^GMTSUP Q:$D(GMTSQIT)
K ^UTILITY($J,"W") S X=$P(BHZ,U,2),DIWL=0,DIWR=60 D ^DIWP
W ?6,"Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" "),!
I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(GMTSQIT) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?19,$G(^UTILITY($J,"W",0,F,0)),!
K ^UTILITY($J,"W")
S BHSORD=$$GET1^DIQ(52.41,BHDI,.01,"I")
I +BHSORD D RECON^BHSMED(BHSORD,"M")
E D
.N NVA
.S NVA=+$P(BHS11,U,8)
.I NVA'="" D
..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
..D RECON^BHSMED(BHSORD,"M")
Q
MEDDSPO ;DISPLAY MEDICATION
N BHSRX,BHSORD
S BHSN=^AUPNVMED(BHM,0)
S BHCNT=BHCNT+1
D CKP^GMTSUP Q:$D(GMTSQIT)
W BHCNT,".",?6,BHN W:$P(BHZ,U,2) ?60,"Refills left: ",$S('$P(BHZ,U,2):"NONE",1:$P(BHZ,U,2)) W !
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSIG=$P(^AUPNVMED(BHM,0),U,5) D SIG
S X=BHSSGY
K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?6,"Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" "),!
I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(GMTSQIT) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?19,$G(^UTILITY($J,"W",0,F,0)),!
K ^UTILITY($J,"W")
S BHSRX=$P(BHZ,U,10)
S BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
I +BHSORD D RECON^BHSMED(BHSORD,"M")
E D
.N NVA
.S NVA=BHSRX
.I NVA'="" D
..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
..D RECON^BHSMED(BHSORD,"M")
Q
MEDDSP ;DISPLAY MEDICATION
N BHSRX,BHSORD
S BHSN=^AUPNVMED(BHM,0)
S BHS11=^AUPNVMED(BHM,11)
S BHCNT=BHCNT+1
D CKP^GMTSUP Q:$D(GMTSQIT)
W BHCNT,".",?6,BHN,?40,"Rx #:",$P(BHZ,U,1),?60,"Refills left: ",$S('$P(BHZ,U,2):"NONE",1:$P(BHZ,U,2)),!
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSIG=$P(^AUPNVMED(BHM,0),U,5) D SIG
S X=BHSSGY
K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?6,"Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" "),!
I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(GMTSQIT) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?19,$G(^UTILITY($J,"W",0,F,0)),!
K ^UTILITY($J,"W")
D CKP^GMTSUP Q:$D(GMTSQIT)
I BHT=1!(BHT=6) W ?6,"Last Filled: ",$$D(9999999-BHDT) D
.S BHSORT="" I BHT=1 S BHSORT=$P($G(^AUPNVMED(BHM,11)),U)
.I BHSORT["RETURNED TO STOCK" W " ---",BHSORT," ",$$FMTE^XLFDT($P(^AUPNVMED(BHM,0),U,8),"2D")
I BHT=6 I $P(BHZ,U,1) S E=$P($G(^PSRX($P(BHZ,U,1),3)),U,6) W ?30,"Expired: ",$$D(E)
W !
I BHT=3 W ?6,"Hold Reason: " I $P(BHZ,U,1) W $P($G(^PSRX($P(BHZ,U,1),"H")),U,1)
I BHT=7 W ?6,"Discontinued: " D
.S E=$P(^AUPNVMED(BHM,0),U,8) ;discontinued date in v med
.I E="",$P(BHZ,U,1) S E=$P($G(^PSRX($P(BHZ,U,1),3)),U,5) ;canceled date in 52
.W $$D(E),!
S BHSRX=$P(BHZ,U,10)
S BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
I +BHSORD D RECON^BHSMED(BHSORD,"M")
E D
.N NVA
.S NVA=BHSRX
.I NVA'="" D
..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
..D RECON^BHSMED(BHSORD,"M")
Q
MEDDSPN ;
S BHCNT=BHCNT+1
D CKP^GMTSUP Q:$D(GMTSQIT)
W BHCNT,".",?6,BHN,! ;W:$P(APCHZ,U,2) ?60,"Refills left: ",$S('$P(APCHZ,U,2):"NONE",1:$P(APCHZ,U,2)) W !
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSIG=$P(BHZ,U,8) D SIG
S X=BHSSGY
K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?6,"Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" "),!
I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(GMTSQIT) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?19,$G(^UTILITY($J,"W",0,F,0)),!
I $P(BHZ,U,9) W !?19,"DATE DISCONTINUED: ",$$FMTE^XLFDT($P(BHZ,U,9))
K ^UTILITY($J,"W")
S BHSNVA=$P(BHZ,U,10)
S BHSORD=$P($G(^PS(55,DFN,"NVA",BHSNVA,0)),U,8)
I +BHSORD D RECON^BHSMED(BHSORD,"M")
E D
.N NVA
.S NVA=BHSNVA
.I NVA'="" D
..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
..D RECON^BHSMED(BHSORD,"M")
Q
D(D) ;
I D="" Q ""
Q $E(D,4,5)_"-"_$E(D,6,7)_"-"_$E(D,2,3)
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
S BHSSGY="" F BHSP=1:1:$L(BHSIG," ") S X=$P(BHSIG," ",BHSP) 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(BHSIG," ",BHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S BHSSGY=BHSSGY_X_" "
Q
;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
I 'BHSRX S BHSREF=$P($G(^AUPNVMED(M,11)),U,7) S:BHSREF="" BHSREF=0 Q
S BHSRFL=$P(^PSRX(BHSRX,0),U,9) S BHSREF=0 F S BHSREF=$O(^PSRX(BHSRX,1,BHSREF)) Q:'BHSREF S BHSRFL=BHSRFL-1
S BHSREF=BHSRFL
Q
;
;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
S BHSITE=""
I $D(^AUPNVSIT(BHSVDF,21))#2 S BHSITE=$P(^(21),U) Q
Q:$P(^AUPNVSIT(BHSVDF,0),U,6)=""
I $P(^AUPNVSIT(BHSVDF,0),U,6)'=DUZ(2) S BHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(BHSVDF,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
BHSMEDR ;IHS/MSC/MGH - Health Summary for MED RECONCILIATION ;01-May-2014 11:12;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**4,6,8,9**;March 17, 2006;Build 16
+2 ;;---------------------------------------------------------------
+3 ; IHS/CMI/LAB - APCHS7R -- SUMMARY PRODUCTION COMPONENTS ;
+4 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+5 ;
+6 ;Patch 6 for non-VA meds
SET ;
+1 SET BHSRX=P
SET BHSREF=0
DO REF
+2 SET BHSTAT(C,N,D,(9999999-F),M)=$SELECT(P:$PIECE(^PSRX(P,0),U),1:"")_U_BHSREF
+3 SET $PIECE(BHSTAT(C,N,D,(9999999-F),M),U,10)=P
+4 SET BHMDSP(D,N,F)=""
+5 QUIT
MEDRCON ; ************* MEDS BY PRESCRIPTION STATUS *************
+1 ;
CONT ; <SETUP>
+1 NEW BHSPAT,BHSQ
+2 SET BHSPAT=DFN
+3 IF '$DATA(^AUPNVMED("AC",BHSPAT))
IF '$DATA(^PS(52.41,"P",BHSPAT))
QUIT
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 ; <BUILD>
+6 NEW BHMEDS,BHSTAT,BHCNT,BHMDSP,BHDI,BHDT,BHM,BHN,BHSSGY,BHSIG,BHZ,BHSN,BHST,BHI,BHD,BHS11
+7 NEW X,F,M,V,D,N,P,C,E,S,R,J,BHSITE,BHSORT,BHSP,BHSREF,BHSRFL,BHSRX,BHSVDF,BHT,BHSNVA
+8 SET BHCNT=0
+9 KILL BHMEDS,BHMDSP
+10 DO GETMEDS^APCHSMU1(BHSPAT,$$FMADD^XLFDT(DT,-395),DT,,,,,.BHMEDS)
+11 ;I '$D(APCHMEDS) D MEDX Q
+12 ;NOW REORDER THEM BY STATUS
+13 KILL BHSTAT
+14 SET X=0
FOR
SET X=$ORDER(BHMEDS(X))
IF X'=+X
QUIT
Begin DoDot:1
+15 SET P=""
+16 ;FILL DATE
SET F=$PIECE(BHMEDS(X),U,1)
+17 ;vmed ien
SET M=$PIECE(BHMEDS(X),U,4)
+18 ;visit ien
SET V=$PIECE(BHMEDS(X),U,5)
+19 ;drug ien
SET D=$PIECE(^AUPNVMED(M,0),U)
+20 ;non table drug name
SET N=$PIECE(^AUPNVMED(M,0),U,4)
+21 ;drug name
IF N=""
SET N=$PIECE(^PSDRUG(D,0),U)
+22 IF $PIECE($GET(^AUPNVSIT(X,0)),U,7)="E"
SET C="OUTSIDE MEDICATIONS"
DO SET
QUIT
+23 IF $PIECE($GET(^AUPNVSIT(X,11)),U,8)
SET C="OUTSIDE MEDICATIONS"
DO SET
QUIT
+24 SET P=$ORDER(^PSRX("APCC",M,0))
+25 IF 'P
SET C="OUTSIDE MEDICATIONS"
DO SET
QUIT
+26 IF '$DATA(^PSRX(P,0))
SET P=""
SET C="OUTSIDE MEDICATIONS"
DO SET
QUIT
+27 ;Patch 8 for autofinished meds
+28 IF $$VALI^XBDIQ1(52,P,9999999.23)=1
SET C="OUTSIDE PHARMACY MEDS"
DO SET
QUIT
+29 ;GET STATUS
SET S=$$VALI^XBDIQ1(52,P,100)
+30 IF S=0
SET C="ACTIVE MEDICATIONS"
DO SET
QUIT
+31 IF S=3
SET C="HOLD"
DO SET
QUIT
+32 IF S=5
SET C="SUSPENDED"
DO SET
QUIT
+33 IF S=11
Begin DoDot:2
+34 ;get expiration date
+35 SET E=$PIECE($GET(^PSRX(P,3)),U,6)
+36 ;chronic flag
SET R=$$CHRONIC^APCHS72(M)
+37 IF 'R
Begin DoDot:3
+38 ;not chronic, check to see if expired in past 14 days, if not quit
+39 SET J=$$FMDIFF^XLFDT(DT,E)
+40 ;more than 14 days ago so don't display
IF J>14
QUIT
+41 ;check to see if same drug is already listed somewhere
+42 ;another of same drug after this date
IF $ORDER(BHMDSP(D,N,F))
QUIT
+43 SET C="EXPIRED"
DO SET
QUIT
End DoDot:3
QUIT
+44 ;chronic = check 120 days
+45 SET J=$$FMDIFF^XLFDT(DT,E)
+46 ;expired more than 120 days ago
IF J>120
QUIT
+47 ;another one there so don't display this one
IF $ORDER(BHMDSP(D,N,F))
QUIT
+48 SET C="EXPIRED"
DO SET
QUIT
End DoDot:2
QUIT
+49 IF S=12!(S=14)
Begin DoDot:2
+50 ;discontinued date in v med
SET E=$PIECE(^AUPNVMED(M,0),U,8)
+51 ;canceled date in 52
IF E=""
SET E=$PIECE($GET(^PSRX(P,3)),U,5)
+52 ;only discontinueds in past 30 days
IF $$FMDIFF^XLFDT(DT,E)>30
QUIT
+53 IF $ORDER(BHMDSP(D,N,F))
QUIT
+54 SET C="DISCONTINUED MEDICATIONS"
DO SET
QUIT
End DoDot:2
End DoDot:1
GETNVA ;NVA from file 55
+1 NEW L,D,N,X,DC
+2 SET X=0
FOR
SET X=$ORDER(^PS(55,BHSPAT,"NVA",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET DC=0
+4 IF $PIECE($GET(^PS(55,BHSPAT,"NVA",X,999999911)),U,1)
Begin DoDot:2
+5 IF $DATA(^AUPNVMED($PIECE(^PS(55,BHSPAT,"NVA",X,999999911),U,1),0))
Begin DoDot:3
+6 IF $PIECE($GET(^PS(55,BHSPAT,"NVA",X,0)),U,6)'=""
SET DC=1
End DoDot:3
End DoDot:2
IF DC=1
QUIT
+7 SET L=$PIECE($PIECE($GET(^PS(55,BHSPAT,"NVA",X,0)),U,10),".")
+8 SET L=9999999-L
+9 SET D=$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,2)
+10 IF D=""
SET D="NO DRUG IEN"
+11 SET N=$SELECT(D:$PIECE(^PSDRUG(D,0),U,1),1:$PIECE(^PS(50.7,$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,1),0),U,1))
+12 SET BHSTAT("NVA",N,D,(9999999-L))=U_"N"
SET $PIECE(BHSTAT("NVA",N,D,(9999999-L)),U,8)=$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,4)_" "_$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,5)_U_$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,7)
+13 SET $PIECE(BHSTAT("NVA",N,D,(9999999-L)),U,10)=X
End DoDot:1
GETPEND ;
+1 NEW PEN,ORD
+2 FOR PEN=0:0
SET PEN=$ORDER(^PS(52.41,"P",BHSPAT,PEN))
IF 'PEN
QUIT
SET ORD=^PS(52.41,PEN,0)
SET BHI=$PIECE(ORD,"^",8)
SET BHD=+$PIECE(ORD,"^",9)
IF $PIECE(ORD,"^",3)'="DC"&($PIECE(ORD,"^",3)'="DE")&($PIECE(ORD,"^",3)'="HD")
Begin DoDot:1
+3 SET BHN=$SELECT(BHD:$PIECE($GET(^PSDRUG(BHD,0)),"^"),+BHI&('BHD):$PIECE(^PS(50.7,BHI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,BHI,0),"^",2),0),"^"),1:"")
IF BHN']""
QUIT
+4 SET BHSTAT("PENDING",BHN,PEN)=$$VAL^XBDIQ1(52.41,PEN,13)
+5 SET C=0
SET X=""
FOR
SET C=$ORDER(^PS(52.41,PEN,"SIG",C))
IF 'C
QUIT
SET X=X_$SELECT(X]"":" ",1:"")_^PS(52.41,PEN,"SIG",C,0)
+6 SET $PIECE(BHSTAT("PENDING",BHN,PEN),U,2)=X
End DoDot:1
DISP ;DISPLAY MEDS
+1 ;ACTIVE MEDS FIRST - ALL OF THEM
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 IF '$DATA(BHSTAT("ACTIVE MEDICATIONS"))
GOTO OUT
+4 WRITE "ACTIVE MEDICATIONS",!
+5 SET BHCNT=0
+6 SET BHT=1
+7 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("ACTIVE MEDICATIONS",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+8 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+9 SET BHDT=0
FOR
SET BHDT=$ORDER(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT))
IF BHDT'=+BHDT!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+10 SET BHM=0
FOR
SET BHM=$ORDER(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT,BHM))
IF BHM'=+BHM!($DATA(GMTSQIT))
QUIT
SET BHZ=BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT,BHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+12 IF '$DATA(BHSTAT("OUTSIDE PHARMACY MEDS"))
GOTO OUT
+13 WRITE "OUTSIDE PHARMACY MEDS",!
+14 SET BHCNT=0
+15 SET BHT=1
+16 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("OUTSIDE PHARMACY MEDS",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+17 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+18 SET BHDT=0
FOR
SET BHDT=$ORDER(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT))
IF BHDT'=+BHDT!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+19 SET BHM=0
FOR
SET BHM=$ORDER(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT,BHM))
IF BHM'=+BHM!($DATA(GMTSQIT))
QUIT
SET BHZ=BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT,BHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
OUT ;OUTSIDE MEDICATIONS
+1 IF '$DATA(BHSTAT("OUTSIDE MEDICATIONS"))&('$DATA(BHSTAT("NVA")))
GOTO HOLD
+2 WRITE "--------------------",!
+3 WRITE "OUTSIDE MEDICATIONS",!
+4 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("OUTSIDE MEDICATIONS",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+5 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+6 SET BHDT=0
SET BHDT=$ORDER(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT))
IF BHDT'=+BHDT!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+7 SET BHM=0
SET BHM=$ORDER(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT,BHM))
IF BHM'=+BHM!($DATA(GMTSQIT))
QUIT
SET BHZ=BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT,BHM)
DO MEDDSPO
End DoDot:3
End DoDot:2
End DoDot:1
+8 ;now display nva
+9 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("NVA",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+10 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("NVA",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+11 SET BHDT=0
SET BHDT=$ORDER(BHSTAT("NVA",BHN,BHDI,BHDT))
IF BHDT'=+BHDT!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+12 SET BHZ=BHSTAT("NVA",BHN,BHDI,BHDT)
DO MEDDSPN
End DoDot:3
End DoDot:2
End DoDot:1
HOLD ;HOLD MEDICATIONS
+1 IF '$DATA(BHSTAT("HOLD MEDICATIONS"))
GOTO SUSPEND
+2 SET BHT=3
+3 WRITE "--------------------",!
+4 WRITE "ACTIVE NOT DISPENSED MEDICATIONS",!
+5 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("HOLD MEDICATIONS",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+6 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("HOLD MEDICATIONS",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+7 SET BHDT=0
FOR
SET BHDT=$ORDER(BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT))
IF BHDT'=+BHDT!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+8 SET BHM=0
FOR
SET BHM=$ORDER(BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT,BHM))
IF BHM'=+BHM!($DATA(GMTSQIT))
QUIT
SET BHZ=BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT,BHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
SUSPEND ;
+1 IF '$DATA(BHSTAT("SUSPEND MEDICATIONS"))
GOTO PENDING
+2 SET BHT=4
+3 WRITE !,"--------------------",!
+4 WRITE "SUSPENDED MEDICATIONS",!
+5 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("SUSPEND MEDICATIONS",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+6 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+7 SET BHDT=0
FOR
SET BHDT=$ORDER(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT))
IF BHDT'=+BHDT!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+8 SET BHM=0
FOR
SET BHM=$ORDER(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT,BHM))
IF BHM'=+BHM!($DATA(GMTSQIT))
QUIT
SET BHZ=BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT,BHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
PENDING ;
+1 IF '$DATA(BHSTAT("PENDING"))
GOTO EXPIRED
+2 WRITE "--------------------",!
+3 WRITE "PENDING MEDICATIONS",!
+4 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("PENDING",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+5 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("PENDING",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+6 SET BHZ=BHSTAT("PENDING",BHN,BHDI)
DO MEDDSPP
End DoDot:2
End DoDot:1
EXPIRED ;
+1 IF '$DATA(BHSTAT("EXPIRED MEDICATIONS"))
GOTO DISCONT
+2 SET BHT=6
+3 WRITE "--------------------",!
+4 WRITE "CHRONIC AND RECENTLY EXPIRED MEDICATIONS",!
+5 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("EXPIRED MEDICATIONS",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+6 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+7 SET BHDT=0
FOR
SET BHDT=$ORDER(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT))
IF BHDT'=+BHDT!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+8 SET BHM=0
FOR
SET BHM=$ORDER(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT,BHM))
IF BHM'=+BHM!($DATA(GMTSQIT))
QUIT
SET BHZ=BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT,BHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
DISCONT ;
+1 IF '$DATA(BHSTAT("DISCONTINUED MEDICATIONS"))
GOTO MEDX
+2 SET BHT=7
+3 WRITE "--------------------",!
+4 WRITE "RECENTLY DISCONTINUED MEDICATIONS",!
+5 SET BHN=""
FOR
SET BHN=$ORDER(BHSTAT("DISCONTINUED MEDICATIONS",BHN))
IF BHN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+6 SET BHDI=""
FOR
SET BHDI=$ORDER(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI))
IF BHDI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+7 SET BHDT=0
FOR
SET BHDT=$ORDER(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT))
IF BHDT'=+BHDT!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+8 SET BHM=0
FOR
SET BHM=$ORDER(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT,BHM))
IF BHM'=+BHM!($DATA(GMTSQIT))
QUIT
SET BHZ=BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT,BHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
MEDX ;
+1 QUIT
MEDDSPP ;DISPLAY MEDICATION
+1 NEW BHSRX,BHSORD
+2 SET BHCNT=BHCNT+1
+3 SET BHS11=$GET(^AUPNVMED(BHZ,11))
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 WRITE BHCNT,".",?6,BHN
IF $PIECE(BHZ,U,2)
WRITE ?60,"Refills: ",$SELECT('$PIECE(BHZ,U,1):"NONE",1:$PIECE(BHZ,U,1))
WRITE !
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(BHZ,U,2)
SET DIWL=0
SET DIWR=60
DO ^DIWP
+8 WRITE ?6,"Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" "),!
+9 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
IF $DATA(GMTSQIT)
QUIT
Begin DoDot:1
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+11 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
End DoDot:1
+12 KILL ^UTILITY($JOB,"W")
+13 SET BHSORD=$$GET1^DIQ(52.41,BHDI,.01,"I")
+14 IF +BHSORD
DO RECON^BHSMED(BHSORD,"M")
+15 IF '$TEST
Begin DoDot:1
+16 NEW NVA
+17 SET NVA=+$PIECE(BHS11,U,8)
+18 IF NVA'=""
Begin DoDot:2
+19 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
+20 DO RECON^BHSMED(BHSORD,"M")
End DoDot:2
End DoDot:1
+21 QUIT
MEDDSPO ;DISPLAY MEDICATION
+1 NEW BHSRX,BHSORD
+2 SET BHSN=^AUPNVMED(BHM,0)
+3 SET BHCNT=BHCNT+1
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 WRITE BHCNT,".",?6,BHN
IF $PIECE(BHZ,U,2)
WRITE ?60,"Refills left: ",$SELECT('$PIECE(BHZ,U,2):"NONE",1:$PIECE(BHZ,U,2))
WRITE !
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 SET BHSIG=$PIECE(^AUPNVMED(BHM,0),U,5)
DO SIG
+8 SET X=BHSSGY
+9 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=60
DO ^DIWP
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+11 WRITE ?6,"Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" "),!
+12 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
IF $DATA(GMTSQIT)
QUIT
Begin DoDot:1
+13 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+14 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
End DoDot:1
+15 KILL ^UTILITY($JOB,"W")
+16 SET BHSRX=$PIECE(BHZ,U,10)
+17 SET BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
+18 IF +BHSORD
DO RECON^BHSMED(BHSORD,"M")
+19 IF '$TEST
Begin DoDot:1
+20 NEW NVA
+21 SET NVA=BHSRX
+22 IF NVA'=""
Begin DoDot:2
+23 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
+24 DO RECON^BHSMED(BHSORD,"M")
End DoDot:2
End DoDot:1
+25 QUIT
MEDDSP ;DISPLAY MEDICATION
+1 NEW BHSRX,BHSORD
+2 SET BHSN=^AUPNVMED(BHM,0)
+3 SET BHS11=^AUPNVMED(BHM,11)
+4 SET BHCNT=BHCNT+1
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 WRITE BHCNT,".",?6,BHN,?40,"Rx #:",$PIECE(BHZ,U,1),?60,"Refills left: ",$SELECT('$PIECE(BHZ,U,2):"NONE",1:$PIECE(BHZ,U,2)),!
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 SET BHSIG=$PIECE(^AUPNVMED(BHM,0),U,5)
DO SIG
+9 SET X=BHSSGY
+10 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=60
DO ^DIWP
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+12 WRITE ?6,"Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" "),!
+13 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
IF $DATA(GMTSQIT)
QUIT
Begin DoDot:1
+14 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+15 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
End DoDot:1
+16 KILL ^UTILITY($JOB,"W")
+17 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+18 IF BHT=1!(BHT=6)
WRITE ?6,"Last Filled: ",$$D(9999999-BHDT)
Begin DoDot:1
+19 SET BHSORT=""
IF BHT=1
SET BHSORT=$PIECE($GET(^AUPNVMED(BHM,11)),U)
+20 IF BHSORT["RETURNED TO STOCK"
WRITE " ---",BHSORT," ",$$FMTE^XLFDT($PIECE(^AUPNVMED(BHM,0),U,8),"2D")
End DoDot:1
+21 IF BHT=6
IF $PIECE(BHZ,U,1)
SET E=$PIECE($GET(^PSRX($PIECE(BHZ,U,1),3)),U,6)
WRITE ?30,"Expired: ",$$D(E)
+22 WRITE !
+23 IF BHT=3
WRITE ?6,"Hold Reason: "
IF $PIECE(BHZ,U,1)
WRITE $PIECE($GET(^PSRX($PIECE(BHZ,U,1),"H")),U,1)
+24 IF BHT=7
WRITE ?6,"Discontinued: "
Begin DoDot:1
+25 ;discontinued date in v med
SET E=$PIECE(^AUPNVMED(BHM,0),U,8)
+26 ;canceled date in 52
IF E=""
IF $PIECE(BHZ,U,1)
SET E=$PIECE($GET(^PSRX($PIECE(BHZ,U,1),3)),U,5)
+27 WRITE $$D(E),!
End DoDot:1
+28 SET BHSRX=$PIECE(BHZ,U,10)
+29 SET BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
+30 IF +BHSORD
DO RECON^BHSMED(BHSORD,"M")
+31 IF '$TEST
Begin DoDot:1
+32 NEW NVA
+33 SET NVA=BHSRX
+34 IF NVA'=""
Begin DoDot:2
+35 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
+36 DO RECON^BHSMED(BHSORD,"M")
End DoDot:2
End DoDot:1
+37 QUIT
MEDDSPN ;
+1 SET BHCNT=BHCNT+1
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 ;W:$P(APCHZ,U,2) ?60,"Refills left: ",$S('$P(APCHZ,U,2):"NONE",1:$P(APCHZ,U,2)) W !
WRITE BHCNT,".",?6,BHN,!
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 SET BHSIG=$PIECE(BHZ,U,8)
DO SIG
+6 SET X=BHSSGY
+7 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=60
DO ^DIWP
+8 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+9 WRITE ?6,"Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" "),!
+10 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
IF $DATA(GMTSQIT)
QUIT
Begin DoDot:1
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+12 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
End DoDot:1
+13 IF $PIECE(BHZ,U,9)
WRITE !?19,"DATE DISCONTINUED: ",$$FMTE^XLFDT($PIECE(BHZ,U,9))
+14 KILL ^UTILITY($JOB,"W")
+15 SET BHSNVA=$PIECE(BHZ,U,10)
+16 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",BHSNVA,0)),U,8)
+17 IF +BHSORD
DO RECON^BHSMED(BHSORD,"M")
+18 IF '$TEST
Begin DoDot:1
+19 NEW NVA
+20 SET NVA=BHSNVA
+21 IF NVA'=""
Begin DoDot:2
+22 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
+23 DO RECON^BHSMED(BHSORD,"M")
End DoDot:2
End DoDot:1
+24 QUIT
D(D) ;
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"-"_$EXTRACT(D,6,7)_"-"_$EXTRACT(D,2,3)
+3 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 SET BHSSGY=""
FOR BHSP=1:1:$LENGTH(BHSIG," ")
SET X=$PIECE(BHSIG," ",BHSP)
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(BHSIG," ",BHSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+3 SET BHSSGY=BHSSGY_X_" "
End DoDot:1
+4 QUIT
+5 ;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
+1 IF 'BHSRX
SET BHSREF=$PIECE($GET(^AUPNVMED(M,11)),U,7)
IF BHSREF=""
SET BHSREF=0
QUIT
+2 SET BHSRFL=$PIECE(^PSRX(BHSRX,0),U,9)
SET BHSREF=0
FOR
SET BHSREF=$ORDER(^PSRX(BHSRX,1,BHSREF))
IF 'BHSREF
QUIT
SET BHSRFL=BHSRFL-1
+3 SET BHSREF=BHSRFL
+4 QUIT
+5 ;
+6 ;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
+1 SET BHSITE=""
+2 IF $DATA(^AUPNVSIT(BHSVDF,21))#2
SET BHSITE=$PIECE(^(21),U)
QUIT
+3 IF $PIECE(^AUPNVSIT(BHSVDF,0),U,6)=""
QUIT
+4 IF $PIECE(^AUPNVSIT(BHSVDF,0),U,6)'=DUZ(2)
SET BHSITE=$EXTRACT($PIECE(^DIC(4,$PIECE(^AUPNVSIT(BHSVDF,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
