BHSMSUP1 ;IHS/CIA/MGH - Health Summary for Supplements ;17-Mar-2006 10:36;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
;===================================================================
;Taken from APCHS9M2
; IHS/TUCSON/LAB - MEDICATION TURN AROUND SUPPLEMENT; [ 05/10/04 2:03 PM ]
;;2.0;IHS RPMS/PCC Health Summary;**12**;JUN 24, 1997
;==================================================================
;
EP ;EP - called from component
N BHSPAT
S BHSPAT=DFN
Q:'$G(BHSPAT)
Q:'$D(^AUPNVMED("AC",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
WR ;write out array
K BHSQUIT
S BHSPAGE=0,BHSQUIT=0
D EP2 ;write out document
I BHSQUIT S GMTSQIT=1
D EOJ
Q
;
EOJ ;
K BHSCLN,BHSDATM,BHSDIEN,BHSIPRV,BHSMIEN,BHSNARC,BHSPAGE,BHSPROV,BHSQUIT,BHSRTN,BHSTXRF,BHSBEG,BHSCRN,BHSDC,BHSDLM,BHSDOO,BHSDTM,BHSDYS,BHSED,BHSEXP,BHSRXRF
K BHSICL,BHSIG,BHSITE,BHSIVD,BHSM0,BHSNAM,BHSNRQ,BHSP,BHSQTY,BHSREF,BHSRFL,BHSRX,BHSSGY,BHSTEX,BHSTOB,BHSTOP,BHSTXT,BHSUPI,BHSTC,BHSTILN,BHSTOB,BHSTOBN,BHSTQ,BHSTYPE,BHSVIEN,BHSX,BHSXRX,BHSY
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
EP2 ;PEP - PASS DFN get back array of patient care summary
;at this point you are stuck with ^TMP("BHS",$J,"DCS"
K ^TMP($J,"BHSMEDS")
K ^TMP($J,"BHSCOUNT")
K ^TMP($J,"BHSMEDSA")
K ^TMP($J,"BHSMEDSG")
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 BHSDLM=$$FMADD^XLFDT(DT,-1030)
S BHSDLM=9999999-BHSDLM
Q:'$D(^AUPNVMED("AC",BHSPAT)) ;patient has no meds
S BHSIVD=0 F S BHSIVD=$O(^AUPNVMED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>BHSDLM) D
.S BHSMIEN=0 F S BHSMIEN=$O(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMIEN)) Q:BHSMIEN'=+BHSMIEN D
..S BHSM0=^AUPNVMED(BHSMIEN,0)
..Q:$P(BHSM0,U)=""
..Q:'$D(^PSDRUG($P(BHSM0,U),0))
..S BHSDATM=9999999-$P(BHSIVD,".") ;visit date
..S BHSDC=$P(BHSM0,U,8)
..S BHSDYS=$P(BHSM0,U,7) S:BHSDYS=0 BHSDYS=30 ;days supply
..S BHSNAM=$S($P(BHSM0,U,4)]"":$P(BHSM0,U,4),1:$P(^PSDRUG($P(BHSM0,U),0),U)) ;free text name if exists
..S BHSDIEN=$P(BHSM0,U,1) ;drug ien
..S $P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),U)=$P($G(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN)),U)+1 ;store last of each different drug and keep counter
..S X=$P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),U)
..I X<10 S $P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),U,(X+1))=$$DATE((9999999-BHSIVD))
..I $$CHRONIC(BHSMIEN) D Q
...Q:$D(^TMP($J,"BHSMEDSG","CHRONIC",BHSNAM,BHSDIEN)) ;already have this one
...S ^TMP($J,"BHSMEDS","CHRONIC",BHSIVD,BHSNAM,BHSDIEN,BHSMIEN)="",^TMP($J,"BHSMEDSG","CHRONIC",BHSNAM,BHSDIEN)=""
..S X=$$FMDIFF^XLFDT(DT,BHSDATM) Q:X>60&(X>(2*BHSDYS))
..Q:$D(^TMP($J,"BHSMEDSG","CURRENT",BHSNAM,BHSDIEN)) ;already have this one
..S ^TMP($J,"BHSMEDS","CURRENT",BHSIVD,BHSNAM,BHSDIEN,BHSMIEN)="",^TMP($J,"BHSMEDSG","CURRENT",BHSNAM,BHSDIEN)=""
.Q
I '$D(^TMP($J,"BHSMEDS","CURRENT")),'$D(^TMP($J,"BHSMEDS","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,"BHSMEDS","CURRENT",I)) Q:I'=+I S N="" F S N=$O(^TMP($J,"BHSMEDS","CURRENT",I,N)) Q:N="" S D=0 F S D=$O(^TMP($J,"BHSMEDS","CURRENT",I,N,D)) Q:D'=+D D
.S M=0 F S M=$O(^TMP($J,"BHSMEDS","CURRENT",I,N,D,M)) Q:M'=+M I $$DC(M) K ^TMP($J,"BHSMEDS","CURRENT",I,N,D,M)
S I=0 F S I=$O(^TMP($J,"BHSMEDS","CHRONIC",I)) Q:I'=+I S N="" F S N=$O(^TMP($J,"BHSMEDS","CHRONIC",I,N)) Q:N="" S D=0 F S D=$O(^TMP($J,"BHSMEDS","CHRONIC",I,N,D)) Q:D'=+D D
.S M=0 F S M=$O(^TMP($J,"BHSMEDS","CHRONIC",I,N,D,M)) Q:M'=+M I $$DC(M) K ^TMP($J,"BHSMEDS","CHRONIC",I,N,D,M)
S C=1,X=$O(^TMP($J,"BHSMEDS","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,"BHSMEDS","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,"BHSMEDSA")
S BHSTOP=$$FMADD^XLFDT(DT,-366),BHSTOP=9999999-BHSTOP
S X="" F S X=$O(^TMP($J,"BHSMEDS",X)) Q:X="" D
.S D=0 F S D=$O(^TMP($J,"BHSMEDS",X,D)) Q:D'=+D!(D>BHSTOP) D
..S N="" F S N=$O(^TMP($J,"BHSMEDS",X,D,N)) Q:N="" D
...S Y=0 F S Y=$O(^TMP($J,"BHSMEDS",X,D,N,Y)) Q:Y="" D
....S M=0 F S M=$O(^TMP($J,"BHSMEDS",X,D,N,Y,M)) Q:M'=+M S ^TMP($J,"BHSMEDSA",X,N,Y,D,M)=^TMP($J,"BHSMEDS",X,D,N,Y,M)
D CKP^GMTSUP Q:$D(GMTSQIT)
K BHSCRN S BHSTYPE="CURRENT" D MEDDSP
S BHSCRN=1 S BHSTYPE="CHRONIC" D MEDDSP
I 'BHSQUIT W !!!,"DISPENSE UNTIL NEXT SCHEDULED EVALUATION: ________",!!,"SIGNATURE: _______________________________ DATE: ________________",!
K ^TMP($J,"BHSMEDS")
K ^TMP($J,"BHSCOUNT")
K ^TMP($J,"BHSMEDSA")
K ^TMP($J,"BHSMEDSG")
Q
MEDDSP ;
S X=""
Q:'$D(^TMP($J,"BHSMEDSA",BHSTYPE)) ;NO MEDS TO DISPLAY
I BHSTYPE="CURRENT" S X="CURRENT MEDICATIONS - (TWICE DURATION OF RX - MINIMUM 60 DAYS)" D W(X,1)
I BHSTYPE="CHRONIC" S X="LATEST OF EACH CHRONIC MEDICATION DISPENSED IN THE PAST YEAR" D W(X,1)
S BHSTOP=$$FMADD^XLFDT(DT,-366),BHSTOP=9999999-BHSTOP
S BHSNAM=0 F S BHSNAM=$O(^TMP($J,"BHSMEDSA",BHSTYPE,BHSNAM)) Q:BHSNAM=""!(BHSQUIT) D
.S BHSDIEN=0 F S BHSDIEN=$O(^TMP($J,"BHSMEDSA",BHSTYPE,BHSNAM,BHSDIEN)) Q:BHSDIEN'=+BHSDIEN!(BHSQUIT) D
..S BHSIVD=0 S BHSIVD=$O(^TMP($J,"BHSMEDSA",BHSTYPE,BHSNAM,BHSDIEN,BHSIVD)) Q:BHSIVD=""!(BHSQUIT) D
...S BHSMIEN=0 S BHSMIEN=$O(^TMP($J,"BHSMEDSA",BHSTYPE,BHSNAM,BHSDIEN,BHSIVD,BHSMIEN)) D MEDDSP1
...Q
..Q
.Q
Q
MEDDSP1 ;
S BHSM0=^AUPNVMED(BHSMIEN,0)
S BHSRX=$O(^PSRX("APCC",BHSMIEN,0)) I 'BHSRX S BHSXRX=0
S BHSRXRF=""
I BHSRX S BHSRXRF=$O(^PSRX("APCC",BHSMIEN,BHSRX,"")) S:BHSRXRF="" BHSRXRF=0
S (Y,BHSDTM)=9999999-$P(BHSIVD,".")
;S BHSDTM=$$DATE(BHSDTM)
S BHSDC=$P(BHSM0,U,8)
S BHSDYS=$P(BHSM0,U,7) S:BHSDYS=0 BHSDYS=30
S BHSNAM=$S($P(BHSM0,U,4)]"":$P(BHSM0,U,4),1:$P(^PSDRUG($P(BHSM0,U),0),U))
S BHSQTY=$P(BHSM0,U,6)
S BHSIG=$P(BHSM0,U,5)
S BHSVIEN=$P(BHSM0,U,3)
S BHSDIEN=+BHSM0
S X1=DT,X2=BHSDTM D ^%DTC
S BHSEXP=""
I X>BHSDYS S X1=BHSDTM,X2=BHSDYS D C^%DTC S BHSEXP="-- Ran out "_$$DATE(X)
S BHSNARC=+$P(^PSDRUG(BHSDIEN,0),U,3)
;ADDED RETURNED TO STOCK FLAG FOR NEXT 4 LINES IHS/OKCAO/POC 12/19/97
IF $P($G(^AUPNVMED(BHSMIEN,11)),U)="RETURNED TO STOCK" S BHSRTN="R"
I BHSDC,$G(BHSRTN)="R" S X=BHSDC D REGDT4^GMTSU S BHSEXP="--Returned to Stock "_X
I BHSDC,$G(BHSRTN)="" S X=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_X
K BHSRTN
D SIG S BHSIG=BHSSGY
D REF
I BHSREF S BHSREF=BHSREF_$S(BHSREF=1:" refill",1:" refills")_" left."
S BHSITE=$P(^AUPNVSIT(BHSVIEN,0),U,6)
D PROV
D CLN
D SITE
D WRITE
Q
WRITE ;
I $Y>(IOSL-10) D Q:BHSQUIT
.W !!!,"DISPENSE UNTIL NEXT SCHEDULED EVALUATION: ________"
.W !!!,"SIGNATURE: ________________________________ DATE: ________________",!
.D CKP^GMTSUP Q:$D(GMTSQIT)
Q:BHSQUIT
S X=$$DATE(BHSDTM),$E(X,10)=BHSNAM_" "_BHSEXP D W(X,1)
S X="",$E(X,10)="QTY: "_BHSQTY_" ("_BHSDYS_" days) "_BHSPROV_$S(BHSCLN]"":" - "_BHSCLN,1:"") D W(X)
S BHSICL=10,BHSNRQ="",BHSTXT=BHSIG D PRTTXT K BHSICL,BHSNRQ,BHSP
;ISSUE HISTORY
;I BHSRX,$D(^PSRX(BHSRX,0)) S X="",$E(X,10)="Most recent issue date: "_$$FMTE^XLFDT($P(^PSRX(BHSRX,0),U,13),5) D W(X)
I BHSITE]"" S X="",$E(X,10)="Prescribed at: "_BHSITE D W(X)
S X=""
S Y=$P(^TMP($J,"BHSCOUNT",BHSNAM,BHSDIEN),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,"BHSCOUNT",BHSNAM,BHSDIEN),U,I)
I X]"" D W(X)
I BHSREF S X="",$E(X,10)=BHSREF D W(X)
S X=""
I $G(BHSNARC)=2 S $E(X,10)="------- MUST REWRITE SCHEDULE 2 DRUGS -------" D W(X,1) Q
I $G(BHSNARC)>2,$G(BHSNARC)<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 BHSITE=""
I $D(^AUPNVSIT(BHSVIEN,21))#2 S BHSITE=$P(^(21),U) Q
Q:$P(^AUPNVSIT(BHSVIEN,0),U,6)=""
I $P(^AUPNVSIT(BHSVIEN,0),U,6)'=DUZ(2) S BHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(BHSVIEN,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
Q 0
SIG ;
;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
;I $$VALI^XBDIQ1(9001015,BHSTYP,3.5)="S" S BHSSGY=BHSIG Q
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="unknown # refills" 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
;
PROV ;GET THE PROVIDER FOR ORIGINAL RX OR REFILL
S BHSPROV=""
I 'BHSRX S BHSPROV=$$VAL^XBDIQ1(9000010.14,1202,BHSMIEN) Q
S BHSIPRV=$S(BHSRXRF=0:$P($G(^PSRX(BHSRX,0)),"^",4),1:$P($G(^PSRX(BHSRX,1,BHSRXRF,0)),"^",17))
S BHSPROV=$S('BHSIPRV:"UNKNOWN PROVIDER",1:$P(^VA(200,BHSIPRV,0),"^"))
Q
;
CLN ;GET CLINIC FOR V MEDICATION
S BHSCLN=$E($$VAL^XBDIQ1(9000010,BHSVIEN,.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 BHSTDLT=1,BHSTILN=80-BHSICL-1
F BHSTQ=0:0 S:BHSNRQ]""&(($L(BHSNRQ)+$L(BHSTXT)+2)<255) BHSTXT=$S(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ,BHSNRQ="" Q:BHSTXT="" D PRTTXT2
K BHSTILN,BHSTDLT,BHSTF,BHSTC,BHSTXT,BHSDOO
Q
PRTTXT2 D GETFRAG S X="",$E(X,BHSICL)=BHSTF D W(X) S BHSICL=BHSICL+BHSTDLT,BHSTILN=BHSTILN-BHSTDLT,BHSTDLT=0
Q
GETFRAG I $L(BHSTXT)<BHSTILN S BHSTF=BHSTXT,BHSTXT="" Q
F BHSTC=BHSTILN:-1:1 Q:$E(BHSTXT,BHSTC)=" "
S BHSTF=$E(BHSTXT,1,BHSTC-1),BHSTXT=$E(BHSTXT,BHSTC+1,255)
Q
;
BHSMSUP1 ;IHS/CIA/MGH - Health Summary for Supplements ;17-Mar-2006 10:36;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
+2 ;===================================================================
+3 ;Taken from APCHS9M2
+4 ; IHS/TUCSON/LAB - MEDICATION TURN AROUND SUPPLEMENT; [ 05/10/04 2:03 PM ]
+5 ;;2.0;IHS RPMS/PCC Health Summary;**12**;JUN 24, 1997
+6 ;==================================================================
+7 ;
EP ;EP - called from component
+1 NEW BHSPAT
+2 SET BHSPAT=DFN
+3 IF '$GET(BHSPAT)
QUIT
+4 IF '$DATA(^AUPNVMED("AC",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WR ;write out array
+1 KILL BHSQUIT
+2 SET BHSPAGE=0
SET BHSQUIT=0
+3 ;write out document
DO EP2
+4 IF BHSQUIT
SET GMTSQIT=1
+5 DO EOJ
+6 QUIT
+7 ;
EOJ ;
+1 KILL BHSCLN,BHSDATM,BHSDIEN,BHSIPRV,BHSMIEN,BHSNARC,BHSPAGE,BHSPROV,BHSQUIT,BHSRTN,BHSTXRF,BHSBEG,BHSCRN,BHSDC,BHSDLM,BHSDOO,BHSDTM,BHSDYS,BHSED,BHSEXP,BHSRXRF
+2 KILL BHSICL,BHSIG,BHSITE,BHSIVD,BHSM0,BHSNAM,BHSNRQ,BHSP,BHSQTY,BHSREF,BHSRFL,BHSRX,BHSSGY,BHSTEX,BHSTOB,BHSTOP,BHSTXT,BHSUPI,BHSTC,BHSTILN,BHSTOB,BHSTOBN,BHSTQ,BHSTYPE,BHSVIEN,BHSX,BHSXRX,BHSY
+3 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
+4 QUIT
EP2 ;PEP - PASS DFN get back array of patient care summary
+1 ;at this point you are stuck with ^TMP("BHS",$J,"DCS"
+2 KILL ^TMP($JOB,"BHSMEDS")
+3 KILL ^TMP($JOB,"BHSCOUNT")
+4 KILL ^TMP($JOB,"BHSMEDSA")
+5 KILL ^TMP($JOB,"BHSMEDSG")
+6 DO SETARRAY
+7 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 BHSDLM=$$FMADD^XLFDT(DT,-1030)
+3 SET BHSDLM=9999999-BHSDLM
+4 ;patient has no meds
IF '$DATA(^AUPNVMED("AC",BHSPAT))
QUIT
+5 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(^AUPNVMED("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>BHSDLM)
QUIT
Begin DoDot:1
+6 SET BHSMIEN=0
FOR
SET BHSMIEN=$ORDER(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMIEN))
IF BHSMIEN'=+BHSMIEN
QUIT
Begin DoDot:2
+7 SET BHSM0=^AUPNVMED(BHSMIEN,0)
+8 IF $PIECE(BHSM0,U)=""
QUIT
+9 IF '$DATA(^PSDRUG($PIECE(BHSM0,U),0))
QUIT
+10 ;visit date
SET BHSDATM=9999999-$PIECE(BHSIVD,".")
+11 SET BHSDC=$PIECE(BHSM0,U,8)
+12 ;days supply
SET BHSDYS=$PIECE(BHSM0,U,7)
IF BHSDYS=0
SET BHSDYS=30
+13 ;free text name if exists
SET BHSNAM=$SELECT($PIECE(BHSM0,U,4)]"":$PIECE(BHSM0,U,4),1:$PIECE(^PSDRUG($PIECE(BHSM0,U),0),U))
+14 ;drug ien
SET BHSDIEN=$PIECE(BHSM0,U,1)
+15 ;store last of each different drug and keep counter
SET $PIECE(^TMP($JOB,"BHSCOUNT",BHSNAM,BHSDIEN),U)=$PIECE($GET(^TMP($JOB,"BHSCOUNT",BHSNAM,BHSDIEN)),U)+1
+16 SET X=$PIECE(^TMP($JOB,"BHSCOUNT",BHSNAM,BHSDIEN),U)
+17 IF X<10
SET $PIECE(^TMP($JOB,"BHSCOUNT",BHSNAM,BHSDIEN),U,(X+1))=$$DATE((9999999-BHSIVD))
+18 IF $$CHRONIC(BHSMIEN)
Begin DoDot:3
+19 ;already have this one
IF $DATA(^TMP($JOB,"BHSMEDSG","CHRONIC",BHSNAM,BHSDIEN))
QUIT
+20 SET ^TMP($JOB,"BHSMEDS","CHRONIC",BHSIVD,BHSNAM,BHSDIEN,BHSMIEN)=""
SET ^TMP($JOB,"BHSMEDSG","CHRONIC",BHSNAM,BHSDIEN)=""
End DoDot:3
QUIT
+21 SET X=$$FMDIFF^XLFDT(DT,BHSDATM)
IF X>60&(X>(2*BHSDYS))
QUIT
+22 ;already have this one
IF $DATA(^TMP($JOB,"BHSMEDSG","CURRENT",BHSNAM,BHSDIEN))
QUIT
+23 SET ^TMP($JOB,"BHSMEDS","CURRENT",BHSIVD,BHSNAM,BHSDIEN,BHSMIEN)=""
SET ^TMP($JOB,"BHSMEDSG","CURRENT",BHSNAM,BHSDIEN)=""
End DoDot:2
+24 QUIT
End DoDot:1
+25 ;no meds to display
IF '$DATA(^TMP($JOB,"BHSMEDS","CURRENT"))
IF '$DATA(^TMP($JOB,"BHSMEDS","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,"BHSMEDS","CURRENT",I))
IF I'=+I
QUIT
SET N=""
FOR
SET N=$ORDER(^TMP($JOB,"BHSMEDS","CURRENT",I,N))
IF N=""
QUIT
SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"BHSMEDS","CURRENT",I,N,D))
IF D'=+D
QUIT
Begin DoDot:1
+28 SET M=0
FOR
SET M=$ORDER(^TMP($JOB,"BHSMEDS","CURRENT",I,N,D,M))
IF M'=+M
QUIT
IF $$DC(M)
KILL ^TMP($JOB,"BHSMEDS","CURRENT",I,N,D,M)
End DoDot:1
+29 SET I=0
FOR
SET I=$ORDER(^TMP($JOB,"BHSMEDS","CHRONIC",I))
IF I'=+I
QUIT
SET N=""
FOR
SET N=$ORDER(^TMP($JOB,"BHSMEDS","CHRONIC",I,N))
IF N=""
QUIT
SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"BHSMEDS","CHRONIC",I,N,D))
IF D'=+D
QUIT
Begin DoDot:1
+30 SET M=0
FOR
SET M=$ORDER(^TMP($JOB,"BHSMEDS","CHRONIC",I,N,D,M))
IF M'=+M
QUIT
IF $$DC(M)
KILL ^TMP($JOB,"BHSMEDS","CHRONIC",I,N,D,M)
End DoDot:1
+31 SET C=1
SET X=$ORDER(^TMP($JOB,"BHSMEDS","CHRONIC",0))
Begin DoDot:1
+32 IF X=""
SET C=0
QUIT
+33 SET X=9999999-X
IF X<$$FMADD^XLFDT(DT,-366)
SET C=0
End DoDot:1
+34 SET R=1
SET X=$ORDER(^TMP($JOB,"BHSMEDS","CURRENT",0))
Begin DoDot:1
+35 IF X=""
SET R=0
QUIT
+36 SET X=9999999-X
IF X<$$FMADD^XLFDT(DT,-366)
SET R=0
End DoDot:1
+37 ;no meds in past year
IF 'C
IF 'R
QUIT
+38 ;REORDER BY NAME AND USE THAT ARRAY
+39 KILL ^TMP($JOB,"BHSMEDSA")
+40 SET BHSTOP=$$FMADD^XLFDT(DT,-366)
SET BHSTOP=9999999-BHSTOP
+41 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"BHSMEDS",X))
IF X=""
QUIT
Begin DoDot:1
+42 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"BHSMEDS",X,D))
IF D'=+D!(D>BHSTOP)
QUIT
Begin DoDot:2
+43 SET N=""
FOR
SET N=$ORDER(^TMP($JOB,"BHSMEDS",X,D,N))
IF N=""
QUIT
Begin DoDot:3
+44 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"BHSMEDS",X,D,N,Y))
IF Y=""
QUIT
Begin DoDot:4
+45 SET M=0
FOR
SET M=$ORDER(^TMP($JOB,"BHSMEDS",X,D,N,Y,M))
IF M'=+M
QUIT
SET ^TMP($JOB,"BHSMEDSA",X,N,Y,D,M)=^TMP($JOB,"BHSMEDS",X,D,N,Y,M)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+46 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+47 KILL BHSCRN
SET BHSTYPE="CURRENT"
DO MEDDSP
+48 SET BHSCRN=1
SET BHSTYPE="CHRONIC"
DO MEDDSP
+49 IF 'BHSQUIT
WRITE !!!,"DISPENSE UNTIL NEXT SCHEDULED EVALUATION: ________",!!,"SIGNATURE: _______________________________ DATE: ________________",!
+50 KILL ^TMP($JOB,"BHSMEDS")
+51 KILL ^TMP($JOB,"BHSCOUNT")
+52 KILL ^TMP($JOB,"BHSMEDSA")
+53 KILL ^TMP($JOB,"BHSMEDSG")
+54 QUIT
MEDDSP ;
+1 SET X=""
+2 ;NO MEDS TO DISPLAY
IF '$DATA(^TMP($JOB,"BHSMEDSA",BHSTYPE))
QUIT
+3 IF BHSTYPE="CURRENT"
SET X="CURRENT MEDICATIONS - (TWICE DURATION OF RX - MINIMUM 60 DAYS)"
DO W(X,1)
+4 IF BHSTYPE="CHRONIC"
SET X="LATEST OF EACH CHRONIC MEDICATION DISPENSED IN THE PAST YEAR"
DO W(X,1)
+5 SET BHSTOP=$$FMADD^XLFDT(DT,-366)
SET BHSTOP=9999999-BHSTOP
+6 SET BHSNAM=0
FOR
SET BHSNAM=$ORDER(^TMP($JOB,"BHSMEDSA",BHSTYPE,BHSNAM))
IF BHSNAM=""!(BHSQUIT)
QUIT
Begin DoDot:1
+7 SET BHSDIEN=0
FOR
SET BHSDIEN=$ORDER(^TMP($JOB,"BHSMEDSA",BHSTYPE,BHSNAM,BHSDIEN))
IF BHSDIEN'=+BHSDIEN!(BHSQUIT)
QUIT
Begin DoDot:2
+8 SET BHSIVD=0
SET BHSIVD=$ORDER(^TMP($JOB,"BHSMEDSA",BHSTYPE,BHSNAM,BHSDIEN,BHSIVD))
IF BHSIVD=""!(BHSQUIT)
QUIT
Begin DoDot:3
+9 SET BHSMIEN=0
SET BHSMIEN=$ORDER(^TMP($JOB,"BHSMEDSA",BHSTYPE,BHSNAM,BHSDIEN,BHSIVD,BHSMIEN))
DO MEDDSP1
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
MEDDSP1 ;
+1 SET BHSM0=^AUPNVMED(BHSMIEN,0)
+2 SET BHSRX=$ORDER(^PSRX("APCC",BHSMIEN,0))
IF 'BHSRX
SET BHSXRX=0
+3 SET BHSRXRF=""
+4 IF BHSRX
SET BHSRXRF=$ORDER(^PSRX("APCC",BHSMIEN,BHSRX,""))
IF BHSRXRF=""
SET BHSRXRF=0
+5 SET (Y,BHSDTM)=9999999-$PIECE(BHSIVD,".")
+6 ;S BHSDTM=$$DATE(BHSDTM)
+7 SET BHSDC=$PIECE(BHSM0,U,8)
+8 SET BHSDYS=$PIECE(BHSM0,U,7)
IF BHSDYS=0
SET BHSDYS=30
+9 SET BHSNAM=$SELECT($PIECE(BHSM0,U,4)]"":$PIECE(BHSM0,U,4),1:$PIECE(^PSDRUG($PIECE(BHSM0,U),0),U))
+10 SET BHSQTY=$PIECE(BHSM0,U,6)
+11 SET BHSIG=$PIECE(BHSM0,U,5)
+12 SET BHSVIEN=$PIECE(BHSM0,U,3)
+13 SET BHSDIEN=+BHSM0
+14 SET X1=DT
SET X2=BHSDTM
DO ^%DTC
+15 SET BHSEXP=""
+16 IF X>BHSDYS
SET X1=BHSDTM
SET X2=BHSDYS
DO C^%DTC
SET BHSEXP="-- Ran out "_$$DATE(X)
+17 SET BHSNARC=+$PIECE(^PSDRUG(BHSDIEN,0),U,3)
+18 ;ADDED RETURNED TO STOCK FLAG FOR NEXT 4 LINES IHS/OKCAO/POC 12/19/97
+19 IF $PIECE($GET(^AUPNVMED(BHSMIEN,11)),U)="RETURNED TO STOCK"
SET BHSRTN="R"
+20 IF BHSDC
IF $GET(BHSRTN)="R"
SET X=BHSDC
DO REGDT4^GMTSU
SET BHSEXP="--Returned to Stock "_X
+21 IF BHSDC
IF $GET(BHSRTN)=""
SET X=BHSDC
DO REGDT4^GMTSU
SET BHSEXP="-- D/C "_X
+22 KILL BHSRTN
+23 DO SIG
SET BHSIG=BHSSGY
+24 DO REF
+25 IF BHSREF
SET BHSREF=BHSREF_$SELECT(BHSREF=1:" refill",1:" refills")_" left."
+26 SET BHSITE=$PIECE(^AUPNVSIT(BHSVIEN,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 CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
End DoDot:1
IF BHSQUIT
QUIT
+5 IF BHSQUIT
QUIT
+6 SET X=$$DATE(BHSDTM)
SET $EXTRACT(X,10)=BHSNAM_" "_BHSEXP
DO W(X,1)
+7 SET X=""
SET $EXTRACT(X,10)="QTY: "_BHSQTY_" ("_BHSDYS_" days) "_BHSPROV_$SELECT(BHSCLN]"":" - "_BHSCLN,1:"")
DO W(X)
+8 SET BHSICL=10
SET BHSNRQ=""
SET BHSTXT=BHSIG
DO PRTTXT
KILL BHSICL,BHSNRQ,BHSP
+9 ;ISSUE HISTORY
+10 ;I BHSRX,$D(^PSRX(BHSRX,0)) S X="",$E(X,10)="Most recent issue date: "_$$FMTE^XLFDT($P(^PSRX(BHSRX,0),U,13),5) D W(X)
+11 IF BHSITE]""
SET X=""
SET $EXTRACT(X,10)="Prescribed at: "_BHSITE
DO W(X)
+12 SET X=""
+13 SET Y=$PIECE(^TMP($JOB,"BHSCOUNT",BHSNAM,BHSDIEN),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,"BHSCOUNT",BHSNAM,BHSDIEN),U,I)
End DoDot:1
+16 IF X]""
DO W(X)
+17 IF BHSREF
SET X=""
SET $EXTRACT(X,10)=BHSREF
DO W(X)
+18 SET X=""
+19 IF $GET(BHSNARC)=2
SET $EXTRACT(X,10)="------- MUST REWRITE SCHEDULE 2 DRUGS -------"
DO W(X,1)
QUIT
+20 IF $GET(BHSNARC)>2
IF $GET(BHSNARC)<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 BHSITE=""
+2 IF $DATA(^AUPNVSIT(BHSVIEN,21))#2
SET BHSITE=$PIECE(^(21),U)
QUIT
+3 IF $PIECE(^AUPNVSIT(BHSVIEN,0),U,6)=""
QUIT
+4 IF $PIECE(^AUPNVSIT(BHSVIEN,0),U,6)'=DUZ(2)
SET BHSITE=$EXTRACT($PIECE(^DIC(4,$PIECE(^AUPNVSIT(BHSVIEN,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 QUIT 0
SIG ;
+1 ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+2 ;I $$VALI^XBDIQ1(9001015,BHSTYP,3.5)="S" S BHSSGY=BHSIG Q
+3 SET BHSSGY=""
FOR BHSP=1:1:$LENGTH(BHSIG," ")
SET X=$PIECE(BHSIG," ",BHSP)
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(BHSIG," ",BHSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+5 SET BHSSGY=BHSSGY_X_" "
End DoDot:1
+6 QUIT
+7 ;
REF ;
+1 ;DETERMINE THE NUMBER OF REFILLS REMAINING
+2 IF 'BHSRX
SET BHSREF="unknown # refills"
QUIT
+3 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
+4 SET BHSREF=BHSRFL
+5 QUIT
+6 ;
PROV ;GET THE PROVIDER FOR ORIGINAL RX OR REFILL
+1 SET BHSPROV=""
+2 IF 'BHSRX
SET BHSPROV=$$VAL^XBDIQ1(9000010.14,1202,BHSMIEN)
QUIT
+3 SET BHSIPRV=$SELECT(BHSRXRF=0:$PIECE($GET(^PSRX(BHSRX,0)),"^",4),1:$PIECE($GET(^PSRX(BHSRX,1,BHSRXRF,0)),"^",17))
+4 SET BHSPROV=$SELECT('BHSIPRV:"UNKNOWN PROVIDER",1:$PIECE(^VA(200,BHSIPRV,0),"^"))
+5 QUIT
+6 ;
CLN ;GET CLINIC FOR V MEDICATION
+1 SET BHSCLN=$EXTRACT($$VAL^XBDIQ1(9000010,BHSVIEN,.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 BHSTDLT=1
SET BHSTILN=80-BHSICL-1
+2 FOR BHSTQ=0:0
IF BHSNRQ]""&(($LENGTH(BHSNRQ)+$LENGTH(BHSTXT)+2)<255)
SET BHSTXT=$SELECT(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ
SET BHSNRQ=""
IF BHSTXT=""
QUIT
DO PRTTXT2
+3 KILL BHSTILN,BHSTDLT,BHSTF,BHSTC,BHSTXT,BHSDOO
+4 QUIT
PRTTXT2 DO GETFRAG
SET X=""
SET $EXTRACT(X,BHSICL)=BHSTF
DO W(X)
SET BHSICL=BHSICL+BHSTDLT
SET BHSTILN=BHSTILN-BHSTDLT
SET BHSTDLT=0
+1 QUIT
GETFRAG IF $LENGTH(BHSTXT)<BHSTILN
SET BHSTF=BHSTXT
SET BHSTXT=""
QUIT
+1 FOR BHSTC=BHSTILN:-1:1
IF $EXTRACT(BHSTXT,BHSTC)=" "
QUIT
+2 SET BHSTF=$EXTRACT(BHSTXT,1,BHSTC-1)
SET BHSTXT=$EXTRACT(BHSTXT,BHSTC+1,255)
+3 QUIT
+4 ;
