BHSMEDCS ;IHS/MSC/MGH - Health summary V Meds controlled substances;01-May-2014 11:10;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**3,6,9**;March 17, 2006;Build 16
; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
; Patch 6 for non-VA and medical review
;
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
N BHSPAT,X,Y,Z
S BHSMTY="NODUP"
S BHSPAT=DFN
;
CONT ; <SETUP>
Q:'$D(^AUPNVMED("AC",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <BUILD>
K ^TMP($J,"BHSMED")
S BHSIVD=0 F S BHSIVD=$O(^AUPNVMED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) S BHSMX=0 F S BHSMX=$O(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMX)) Q:BHSMX="" D
.S M=+^AUPNVMED(BHSMX,0)
.Q:'$D(^PSDRUG(M,0))
.Q:'$$CS(M) ;controlled substances only
.S $P(^TMP($J,"BHSMED",M),U)=$P($G(^TMP($J,"BHSMED",M)),U)+1
.S X=$P(^TMP($J,"BHSMED",M),U)
.I X<99 S $P(^TMP($J,"BHSMED",M),U,(X+1))=$$FMTE^XLFDT((9999999-BHSIVD),5)_";"_$$VAL^XBDIQ1(9000010.14,BHSMX,1202)_";"_$$VAL^XBDIQ1(9000010,$P(^AUPNVMED(BHSMX,0),U,3),.06)
K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP"),^TMP($J,"BHSNO")
S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^AUPNVMED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) S BHSMX=0 F BHSQ=0:0 S BHSMX=$O(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMX)) Q:BHSMX="" D MEDBLD
D NONVA^BHSMED ;Get outside meds not in PCC
; <DISPLAY>
;REBUILD LIST BY NAME (TRADE OR GENERIC) AND DATE
S (BHSIVD,BHSCC,BHSCRX)=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD I $P(^TMP($J,"BHSMTP",BHSIVD),U,2)="C",$P(^TMP($J,"BHSMTP",BHSIVD),U,3)=0 D
.S BHSCC=BHSCC+1 D MEDDSP
S (BHSIVD)=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD I $P(^TMP($J,"BHSMTP",BHSIVD),U,2)="C",$P(^TMP($J,"BHSMTP",BHSIVD),U,3)=1 D
.S BHSCC=BHSCC+1 D MEDDSP
S (BHSIVD,BHSCC)=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD I $P(^TMP($J,"BHSMTP",BHSIVD),U,2)'="C",$P(^TMP($J,"BHSMTP",BHSIVD),U,3)=0 D
.S BHSCC=BHSCC+1 D MEDDSP
S (BHSIVD)=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD I $P(^TMP($J,"BHSMTP",BHSIVD),U,2)'="C",$P(^TMP($J,"BHSMTP",BHSIVD),U,3)=1 D
.S BHSCC=BHSCC+1 D MEDDSP
;CLEANUP
;Patch 6
D MEDRU^BHSMED ;display last date reviewed/updated/nam
K BHST,BHSFN
MEDX K BHSIVD,BHSMX,BHSMFX,BHSQTY,BHSIG,BHSSGY,BHSEXP,BHSMTS,BHSMED,BHSDTM,BHSDAT,BHSDYS,BHSN,BHSDC,BHSVDF,BHSP,BHSNON,BHSDLU,BHSIEN,RXNORM
K BHSNFL,BHI,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSRX,BHSORD,BHSDRG,BHSCRN,BHSREF,BHSRFL,BHSALL,BHSTXT,BHSMTY,BHSALT,BHSCRX,BHSCHR,BHSQ,M,Z,BHEXPD
K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP"),^TMP($J,"BHSNO"),^TMP($J,"BHSMED")
K X1,X2,X,Y,BHSCC
Q
MEDBLD ;BUILD ARRAY OF MEDICATIONS
;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
;VDF=VISIT FILE DATE
Q:'$D(^AUPNVMED(BHSMX,0))
S BHSN=^AUPNVMED(BHSMX,0)
Q:'$D(^PSDRUG($P(BHSN,U,1)))
Q:'$$CS($P(BHSN,U,1))
S BHSDTM=-BHSIVD\1+9999999
S BHSDC=$P(BHSN,U,8),BHSDYS=$P(BHSN,U,7),BHSMFX=$S($P(BHSN,U,4)="":+BHSN,$P(BHSN,U,4)=$P(^PSDRUG(+BHSN,0),U):+BHSN,1:$P(BHSN,U,4)),BHSCHR=$$CHRONIC^BHSMEDG(BHSMX),BHSCHR=$S(BHSCHR=1:"C",1:"Z")
S BHSCRX=$$CS($P(BHSN,U))
D @BHSMTY
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,"BHSMTP",BHSIVD_"-"_BHSMFX)) S ^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX_"^"_BHSCHR_"^"_BHSCRX
I $D(^TMP($J,"BHSMTB",BHSMFX)) Q
S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX_"^"_BHSCHR_"^"_BHSCRX
Q
MEDDSP ;DISPLAY MEDICATION
;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
S BHSMX=$P(^TMP($J,"BHSMTP",BHSIVD),U)
I 'BHSMX D NVADSP Q
S BHSCRX=$P(^TMP($J,"BHSMTP",BHSIVD),U,3)
S BHSN=^AUPNVMED(BHSMX,0)
S BHSIEN=+BHSN
S BHSRX=$S($D(^PSRX("APCC",BHSMX)):$O(^(BHSMX,0)),1:0)
S BHSCRN=$S(+BHSRX:$D(^PS(55,BHSPAT,"P","CP",BHSRX)),1:0)
S (X,BHSDTM)=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDC=$P(BHSN,U,8),BHSDYS=$P(BHSN,U,7),BHSQTY=$P(BHSN,U,6),BHSIG=$P(BHSN,U,5),BHSVDF=$P(BHSN,U,3),BHSMFX=+BHSN
S X1=DT,X2=BHSDTM D ^%DTC ;Q:X>60&(X>(2*BHSDYS))
S BHSEXP=""
S BHSMED=$S($P(BHSN,U,4)="":$P(^PSDRUG(BHSMFX,0),U,1),1:$P(BHSN,U,4))
S BHSALT=$P($G(^AUPNVMED(BHSMX,12)),U,12) ;IHS/CMI/GRL
S BHEXPD=$$VALI^XBDIQ1(52,BHSRX,26) S BHEXPD=$$FMTE^XLFDT(BHEXPD,5)
I BHSDC S X=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_X
D SIG S BHSIG=BHSSGY
D REF I BHSREF S BHSIG=BHSIG_" "_BHSREF_$S(BHSREF=1:" refill",1:" refills")_" left."
D SITE
D CKP^GMTSUP Q:$D(GMTSQIT)
W BHSDAT,?10,?14,BHSMED W:BHSQTY " #",BHSQTY
W:BHSDYS " (",BHSDYS," days) " W BHSEXP
I BHEXPD]"" W "(expires "_BHEXPD_")"
W !
;Patch 8 Add Rxnorm code here
S RXNORM=$$GET1^DIQ(50,BHSMFX,9999999.27)
I RXNORM'="" W ?14,"RxNorm: ",RXNORM,!
I BHSITE]"" W ?14,"Dispensed at: ",BHSITE,!
I $G(BHSALT)]"" I $E($G(BHSALT),1,6)'=$E($G(BHSMED),1,6) W ?14,"("_BHSALT_")",! ;IHS/CMI/GRL
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSICL=14,BHSNRQ="",BHSTXT=" "_BHSIG D PRTTXT^BHSUTL K BHSICL,BHSNRQ,BHSP
S Y=$P(^TMP($J,"BHSMED",BHSIEN),U)
Q:Y<2
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?16,"Previous fill dates:",!
F BHI=3:1 Q:$P($G(^TMP($J,"BHSMED",BHSIEN)),U,BHI)="" D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?16,$P($P($G(^TMP($J,"BHSMED",BHSIEN)),U,BHI),";",1)
.W ?27,$P($P($G(^TMP($J,"BHSMED",BHSIEN)),U,BHI),";",2)
.W ?57,$P($P($G(^TMP($J,"BHSMED",BHSIEN)),U,BHI),";",3),!
S BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
I +BHSORD D RECON^BHSMED(BHSORD,"M")
E D
.N NVA
.S NVA=+$P(APCHORTS,U,8)
.I NVA'="" D
..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
..D RECON^BHSMED(BHSORD,"M")
W !
Q
;
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=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
NVADSP ;
S BHSEXP=""
S (X,BHSDTM)=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDC=$P(^TMP($J,"BHSMTP",BHSIVD),U,5)
S BHSMED=$P(^TMP($J,"BHSMTP",BHSIVD),U,3)
I BHSDC S Y=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_Y
S BHSIG=$P(^TMP($J,"BHSMTP",BHSIVD),U,4)
D CKP^GMTSUP Q:$D(GMTSQIT)
W BHSDAT,?14,BHSMED," ",BHSEXP,!
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSICL=14,BHSNRQ="",BHSTXT=BHSIG_" (EHR OUTSIDE MEDICATION)" D PRTTXT^BHSUTL K BHSICL,BHSNRQ,BHSP
Q
BHSMEDCS ;IHS/MSC/MGH - Health summary V Meds controlled substances;01-May-2014 11:10;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**3,6,9**;March 17, 2006;Build 16
+2 ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+3 ; Patch 6 for non-VA and medical review
+4 ;
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
+1 NEW BHSPAT,X,Y,Z
+2 SET BHSMTY="NODUP"
+3 SET BHSPAT=DFN
+4 ;
CONT ; <SETUP>
+1 IF '$DATA(^AUPNVMED("AC",BHSPAT))
QUIT
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 ; <BUILD>
+4 KILL ^TMP($JOB,"BHSMED")
+5 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(^AUPNVMED("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
SET BHSMX=0
FOR
SET BHSMX=$ORDER(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMX))
IF BHSMX=""
QUIT
Begin DoDot:1
+6 SET M=+^AUPNVMED(BHSMX,0)
+7 IF '$DATA(^PSDRUG(M,0))
QUIT
+8 ;controlled substances only
IF '$$CS(M)
QUIT
+9 SET $PIECE(^TMP($JOB,"BHSMED",M),U)=$PIECE($GET(^TMP($JOB,"BHSMED",M)),U)+1
+10 SET X=$PIECE(^TMP($JOB,"BHSMED",M),U)
+11 IF X<99
SET $PIECE(^TMP($JOB,"BHSMED",M),U,(X+1))=$$FMTE^XLFDT((9999999-BHSIVD),5)_";"_$$VAL^XBDIQ1(9000010.14,BHSMX,1202)_";"_$$VAL^XBDIQ1(9000010,$PIECE(^AUPNVMED(BHSMX,0),U,3),.06)
End DoDot:1
+12 KILL ^TMP($JOB,"BHSMTB"),^TMP($JOB,"BHSMTP"),^TMP($JOB,"BHSNO")
+13 SET BHSIVD=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVMED("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
SET BHSMX=0
FOR BHSQ=0:0
SET BHSMX=$ORDER(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMX))
IF BHSMX=""
QUIT
DO MEDBLD
+14 ;Get outside meds not in PCC
DO NONVA^BHSMED
+15 ; <DISPLAY>
+16 ;REBUILD LIST BY NAME (TRADE OR GENERIC) AND DATE
+17 SET (BHSIVD,BHSCC,BHSCRX)=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^TMP($JOB,"BHSMTP",BHSIVD))
IF 'BHSIVD
QUIT
IF $PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,2)="C"
IF $PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,3)=0
Begin DoDot:1
+18 SET BHSCC=BHSCC+1
DO MEDDSP
End DoDot:1
+19 SET (BHSIVD)=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^TMP($JOB,"BHSMTP",BHSIVD))
IF 'BHSIVD
QUIT
IF $PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,2)="C"
IF $PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,3)=1
Begin DoDot:1
+20 SET BHSCC=BHSCC+1
DO MEDDSP
End DoDot:1
+21 SET (BHSIVD,BHSCC)=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^TMP($JOB,"BHSMTP",BHSIVD))
IF 'BHSIVD
QUIT
IF $PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,2)'="C"
IF $PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,3)=0
Begin DoDot:1
+22 SET BHSCC=BHSCC+1
DO MEDDSP
End DoDot:1
+23 SET (BHSIVD)=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^TMP($JOB,"BHSMTP",BHSIVD))
IF 'BHSIVD
QUIT
IF $PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,2)'="C"
IF $PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,3)=1
Begin DoDot:1
+24 SET BHSCC=BHSCC+1
DO MEDDSP
End DoDot:1
+25 ;CLEANUP
+26 ;Patch 6
+27 ;display last date reviewed/updated/nam
DO MEDRU^BHSMED
+28 KILL BHST,BHSFN
MEDX KILL BHSIVD,BHSMX,BHSMFX,BHSQTY,BHSIG,BHSSGY,BHSEXP,BHSMTS,BHSMED,BHSDTM,BHSDAT,BHSDYS,BHSN,BHSDC,BHSVDF,BHSP,BHSNON,BHSDLU,BHSIEN,RXNORM
+1 KILL BHSNFL,BHI,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSRX,BHSORD,BHSDRG,BHSCRN,BHSREF,BHSRFL,BHSALL,BHSTXT,BHSMTY,BHSALT,BHSCRX,BHSCHR,BHSQ,M,Z,BHEXPD
+2 KILL ^TMP($JOB,"BHSMTB"),^TMP($JOB,"BHSMTP"),^TMP($JOB,"BHSNO"),^TMP($JOB,"BHSMED")
+3 KILL X1,X2,X,Y,BHSCC
+4 QUIT
MEDBLD ;BUILD ARRAY OF MEDICATIONS
+1 ;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
+2 ;VDF=VISIT FILE DATE
+3 IF '$DATA(^AUPNVMED(BHSMX,0))
QUIT
+4 SET BHSN=^AUPNVMED(BHSMX,0)
+5 IF '$DATA(^PSDRUG($PIECE(BHSN,U,1)))
QUIT
+6 IF '$$CS($PIECE(BHSN,U,1))
QUIT
+7 SET BHSDTM=-BHSIVD\1+9999999
+8 SET BHSDC=$PIECE(BHSN,U,8)
SET BHSDYS=$PIECE(BHSN,U,7)
SET BHSMFX=$SELECT($PIECE(BHSN,U,4)="":+BHSN,$PIECE(BHSN,U,4)=$PIECE(^PSDRUG(+BHSN,0),U):+BHSN,1:$PIECE(BHSN,U,4))
SET BHSCHR=$$CHRONIC^BHSMEDG(BHSMX)
SET BHSCHR=$SELECT(BHSCHR=1:"C",1:"Z")
+9 SET BHSCRX=$$CS($PIECE(BHSN,U))
+10 DO @BHSMTY
+11 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,"BHSMTP",BHSIVD_"-"_BHSMFX))
SET ^TMP($JOB,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX_"^"_BHSCHR_"^"_BHSCRX
+4 IF $DATA(^TMP($JOB,"BHSMTB",BHSMFX))
QUIT
+5 SET ^TMP($JOB,"BHSMTB",BHSMFX)=BHSDC
SET ^TMP($JOB,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX_"^"_BHSCHR_"^"_BHSCRX
+6 QUIT
MEDDSP ;DISPLAY MEDICATION
+1 ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
+2 SET BHSMX=$PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U)
+3 IF 'BHSMX
DO NVADSP
QUIT
+4 SET BHSCRX=$PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,3)
+5 SET BHSN=^AUPNVMED(BHSMX,0)
+6 SET BHSIEN=+BHSN
+7 SET BHSRX=$SELECT($DATA(^PSRX("APCC",BHSMX)):$ORDER(^(BHSMX,0)),1:0)
+8 SET BHSCRN=$SELECT(+BHSRX:$DATA(^PS(55,BHSPAT,"P","CP",BHSRX)),1:0)
+9 SET (X,BHSDTM)=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+10 SET BHSDC=$PIECE(BHSN,U,8)
SET BHSDYS=$PIECE(BHSN,U,7)
SET BHSQTY=$PIECE(BHSN,U,6)
SET BHSIG=$PIECE(BHSN,U,5)
SET BHSVDF=$PIECE(BHSN,U,3)
SET BHSMFX=+BHSN
+11 ;Q:X>60&(X>(2*BHSDYS))
SET X1=DT
SET X2=BHSDTM
DO ^%DTC
+12 SET BHSEXP=""
+13 SET BHSMED=$SELECT($PIECE(BHSN,U,4)="":$PIECE(^PSDRUG(BHSMFX,0),U,1),1:$PIECE(BHSN,U,4))
+14 ;IHS/CMI/GRL
SET BHSALT=$PIECE($GET(^AUPNVMED(BHSMX,12)),U,12)
+15 SET BHEXPD=$$VALI^XBDIQ1(52,BHSRX,26)
SET BHEXPD=$$FMTE^XLFDT(BHEXPD,5)
+16 IF BHSDC
SET X=BHSDC
DO REGDT4^GMTSU
SET BHSEXP="-- D/C "_X
+17 DO SIG
SET BHSIG=BHSSGY
+18 DO REF
IF BHSREF
SET BHSIG=BHSIG_" "_BHSREF_$SELECT(BHSREF=1:" refill",1:" refills")_" left."
+19 DO SITE
+20 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+21 WRITE BHSDAT,?10,?14,BHSMED
IF BHSQTY
WRITE " #",BHSQTY
+22 IF BHSDYS
WRITE " (",BHSDYS," days) "
WRITE BHSEXP
+23 IF BHEXPD]""
WRITE "(expires "_BHEXPD_")"
+24 WRITE !
+25 ;Patch 8 Add Rxnorm code here
+26 SET RXNORM=$$GET1^DIQ(50,BHSMFX,9999999.27)
+27 IF RXNORM'=""
WRITE ?14,"RxNorm: ",RXNORM,!
+28 IF BHSITE]""
WRITE ?14,"Dispensed at: ",BHSITE,!
+29 ;IHS/CMI/GRL
IF $GET(BHSALT)]""
IF $EXTRACT($GET(BHSALT),1,6)'=$EXTRACT($GET(BHSMED),1,6)
WRITE ?14,"("_BHSALT_")",!
+30 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+31 SET BHSICL=14
SET BHSNRQ=""
SET BHSTXT=" "_BHSIG
DO PRTTXT^BHSUTL
KILL BHSICL,BHSNRQ,BHSP
+32 SET Y=$PIECE(^TMP($JOB,"BHSMED",BHSIEN),U)
+33 IF Y<2
QUIT
+34 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+35 WRITE ?16,"Previous fill dates:",!
+36 FOR BHI=3:1
IF $PIECE($GET(^TMP($JOB,"BHSMED",BHSIEN)),U,BHI)=""
QUIT
Begin DoDot:1
+37 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+38 WRITE ?16,$PIECE($PIECE($GET(^TMP($JOB,"BHSMED",BHSIEN)),U,BHI),";",1)
+39 WRITE ?27,$PIECE($PIECE($GET(^TMP($JOB,"BHSMED",BHSIEN)),U,BHI),";",2)
+40 WRITE ?57,$PIECE($PIECE($GET(^TMP($JOB,"BHSMED",BHSIEN)),U,BHI),";",3),!
End DoDot:1
+41 SET BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
+42 IF +BHSORD
DO RECON^BHSMED(BHSORD,"M")
+43 IF '$TEST
Begin DoDot:1
+44 NEW NVA
+45 SET NVA=+$PIECE(APCHORTS,U,8)
+46 IF NVA'=""
Begin DoDot:2
+47 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
+48 DO RECON^BHSMED(BHSORD,"M")
End DoDot:2
End DoDot:1
+49 WRITE !
+50 QUIT
+51 ;
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=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
NVADSP ;
+1 SET BHSEXP=""
+2 SET (X,BHSDTM)=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+3 SET BHSDC=$PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,5)
+4 SET BHSMED=$PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,3)
+5 IF BHSDC
SET Y=BHSDC
DO REGDT4^GMTSU
SET BHSEXP="-- D/C "_Y
+6 SET BHSIG=$PIECE(^TMP($JOB,"BHSMTP",BHSIVD),U,4)
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 WRITE BHSDAT,?14,BHSMED," ",BHSEXP,!
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 SET BHSICL=14
SET BHSNRQ=""
SET BHSTXT=BHSIG_" (EHR OUTSIDE MEDICATION)"
DO PRTTXT^BHSUTL
KILL BHSICL,BHSNRQ,BHSP
+11 QUIT
