BTIULO1 ; IHS/ITSC/LJF - PHARMACY OBJECTS ;
;;1.0;TEXT INTEGRATION UTILITIES;;NOV 04, 2004
; copied code from APCHS7
;
;
MEDSCURR ;EP; ************** CURRENT MEDICATIONS * 9000010.14 ********
S APCHSMTY="CURR" G CONT
MEDSNOSG ;EP; ************** CURRENT MEDICATIONS * NO SIGS ********
NEW APCHTIU S APCHTIU=""
S APCHSMTY="CURR" G CONT
S APCHSMTY="NODUP" G CONT
;
CONT ; <SETUP>
Q:'$D(^AUPNVMED("AC",APCHSPAT))
; <BUILD>
K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP")
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
; <DISPLAY>
S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHSMTP",APCHSIVD)) Q:'APCHSIVD D MEDDSP
; <CLEANUP>
MEDX K APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT,APCHSMTY
K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP")
K X1,X2,X,Y
Q
MEDBLD ;BUILD ARRAY OF MEDICATIONS
;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
;VDF=VISIT FILE DATE
S APCHSN=^AUPNVMED(APCHSMX,0)
Q:'$D(^PSDRUG($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,1:$P(APCHSN,U,4))
S:APCHSDYS="" APCHSDYS=30
D @APCHSMTY
Q
;
CURR ; current meds only
I $D(^TMP($J,"APCHSMTB",APCHSMFX)),^TMP($J,"APCHSMTB",APCHSMFX)="" Q
S X1=DT,X2=APCHSDTM D ^%DTC Q:X>60&(X>(2*APCHSDYS))
S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
Q
ALL ;all meds included
S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
;
Q
NODUP ;
I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
Q
CHRONIC ;chronic meds only
I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
S X=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0)
S Y=$S(+X:$D(^PS(55,APCHSPAT,"P","CP",X)),1:0)
Q:'Y
S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
Q
MEDDSP ;DISPLAY MEDICATION
;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
S APCHSMX=^TMP($J,"APCHSMTP",APCHSIVD)
S APCHSN=^AUPNVMED(APCHSMX,0)
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:APCHSDYS="" APCHSDYS=30
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))
I APCHSDC S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
D SIG S APCHSIG=APCHSSGY
D SITE I APCHSITE]"" S APCHSIG=APCHSIG_" ["_APCHSITE_"]"
X APCHSCKP Q:$D(APCHSQIT)
W APCHSDAT,?10,$S(APCHSCRN:"(C)",1:""),?14,APCHSMED," #",APCHSQTY," (",APCHSDYS," days) ",APCHSEXP,!
X APCHSCKP Q:$D(APCHSQIT)
S APCHSICL=16,APCHSNRQ="",APCHSTXT=APCHSIG D PRTTXT^APCHSUTL K APCHSICL,APCHSNRQ,APCHSP
Q
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
I $D(APCHTIU) S APCHSSGY="" Q ;IHS/ANMC/LJF 4/20/98
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=0 Q
;
I '$D(^PSRX(APCHSRX,0)) 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
BTIULO1 ; IHS/ITSC/LJF - PHARMACY OBJECTS ;
+1 ;;1.0;TEXT INTEGRATION UTILITIES;;NOV 04, 2004
+2 ; copied code from APCHS7
+3 ;
+4 ;
MEDSCURR ;EP; ************** CURRENT MEDICATIONS * 9000010.14 ********
+1 SET APCHSMTY="CURR"
GOTO CONT
MEDSNOSG ;EP; ************** CURRENT MEDICATIONS * NO SIGS ********
+1 NEW APCHTIU
SET APCHTIU=""
+2 SET APCHSMTY="CURR"
GOTO CONT
+3 SET APCHSMTY="NODUP"
GOTO CONT
+4 ;
CONT ; <SETUP>
+1 IF '$DATA(^AUPNVMED("AC",APCHSPAT))
QUIT
+2 ; <BUILD>
+3 KILL ^TMP($JOB,"APCHSMTB"),^TMP($JOB,"APCHSMTP")
+4 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
+5 ; <DISPLAY>
+6 SET APCHSIVD=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSMTP",APCHSIVD))
IF 'APCHSIVD
QUIT
DO MEDDSP
+7 ; <CLEANUP>
MEDX KILL APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP
+1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT,APCHSMTY
+2 KILL ^TMP($JOB,"APCHSMTB"),^TMP($JOB,"APCHSMTP")
+3 KILL X1,X2,X,Y
+4 QUIT
MEDBLD ;BUILD ARRAY OF MEDICATIONS
+1 ;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
+2 ;VDF=VISIT FILE DATE
+3 SET APCHSN=^AUPNVMED(APCHSMX,0)
+4 IF '$DATA(^PSDRUG($PIECE(APCHSN,U,1)))
QUIT
+5 SET APCHSDTM=-APCHSIVD\1+9999999
+6 SET APCHSDC=$PIECE(APCHSN,U,8)
SET APCHSDYS=$PIECE(APCHSN,U,7)
SET APCHSMFX=$SELECT($PIECE(APCHSN,U,4)="":+APCHSN,1:$PIECE(APCHSN,U,4))
+7 IF APCHSDYS=""
SET APCHSDYS=30
+8 DO @APCHSMTY
+9 QUIT
+10 ;
CURR ; current meds only
+1 IF $DATA(^TMP($JOB,"APCHSMTB",APCHSMFX))
IF ^TMP($JOB,"APCHSMTB",APCHSMFX)=""
QUIT
+2 SET X1=DT
SET X2=APCHSDTM
DO ^%DTC
IF X>60&(X>(2*APCHSDYS))
QUIT
+3 SET ^TMP($JOB,"APCHSMTB",APCHSMFX)=APCHSDC
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
+4 QUIT
ALL ;all meds included
+1 SET ^TMP($JOB,"APCHSMTB",APCHSMFX)=APCHSDC
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
+2 ;
+3 QUIT
NODUP ;
+1 IF $DATA(^TMP($JOB,"APCHSMTB",APCHSMFX))
QUIT
+2 SET ^TMP($JOB,"APCHSMTB",APCHSMFX)=APCHSDC
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
+3 QUIT
CHRONIC ;chronic meds only
+1 IF $DATA(^TMP($JOB,"APCHSMTB",APCHSMFX))
QUIT
+2 SET X=$SELECT($DATA(^PSRX("APCC",APCHSMX)):$ORDER(^(APCHSMX,0)),1:0)
+3 SET Y=$SELECT(+X:$DATA(^PS(55,APCHSPAT,"P","CP",X)),1:0)
+4 IF 'Y
QUIT
+5 SET ^TMP($JOB,"APCHSMTB",APCHSMFX)=APCHSDC
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
+6 QUIT
MEDDSP ;DISPLAY MEDICATION
+1 ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
+2 SET APCHSMX=^TMP($JOB,"APCHSMTP",APCHSIVD)
+3 SET APCHSN=^AUPNVMED(APCHSMX,0)
+4 SET APCHSRX=$SELECT($DATA(^PSRX("APCC",APCHSMX)):$ORDER(^(APCHSMX,0)),1:0)
+5 SET APCHSCRN=$SELECT(+APCHSRX:$DATA(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
+6 SET (Y,APCHSDTM)=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+7 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
+8 IF APCHSDYS=""
SET APCHSDYS=30
+9 ;Q:X>60&(X>(2*APCHSDYS))
SET X1=DT
SET X2=APCHSDTM
DO ^%DTC
+10 SET APCHSEXP=""
+11 SET APCHSMED=$SELECT($PIECE(APCHSN,U,4)="":$PIECE(^PSDRUG(APCHSMFX,0),U,1),1:$PIECE(APCHSN,U,4))
+12 IF APCHSDC
SET Y=APCHSDC
XECUTE APCHSCVD
SET APCHSEXP="-- D/C "_Y
+13 DO SIG
SET APCHSIG=APCHSSGY
+14 DO SITE
IF APCHSITE]""
SET APCHSIG=APCHSIG_" ["_APCHSITE_"]"
+15 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+16 WRITE APCHSDAT,?10,$SELECT(APCHSCRN:"(C)",1:""),?14,APCHSMED," #",APCHSQTY," (",APCHSDYS," days) ",APCHSEXP,!
+17 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+18 SET APCHSICL=16
SET APCHSNRQ=""
SET APCHSTXT=APCHSIG
DO PRTTXT^APCHSUTL
KILL APCHSICL,APCHSNRQ,APCHSP
+19 QUIT
+20 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 ;IHS/ANMC/LJF 4/20/98
IF $DATA(APCHTIU)
SET APCHSSGY=""
QUIT
+2 SET APCHSSGY=""
FOR APCHSP=1:1:$LENGTH(APCHSIG," ")
SET X=$PIECE(APCHSIG," ",APCHSP)
IF X]""
Begin DoDot:1
+3 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)
+4 SET APCHSSGY=APCHSSGY_X_" "
End DoDot:1
+5 QUIT
+6 ;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
+1 IF 'APCHSRX
SET APCHSREF=0
QUIT
+2 ;
+3 IF '$DATA(^PSRX(APCHSRX,0))
SET APCHSREF=0
QUIT
+4 ;
+5 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
+6 SET APCHSREF=APCHSRFL
+7 QUIT
+8 ;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
+1 SET APCHSITE=""
+2 IF $DATA(^AUPNVSIT(APCHSVDF,21))#2
SET APCHSITE=$PIECE(^(21),U)
+3 QUIT
