- 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
