BSDX41G ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
;
MEDSCURR ; ************** CURRENT MEDICATIONS * 9000010.14 ********
S APCHSMTY="CURR" G CONT
MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
S APCHSMTY="ALL" G CONT
MEDSCHRN ; ************* CHRONIC MEDCICATIONS ************
S APCHSMTY="CHRONIC" G CONT
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
S APCHSMTY="NODUP" G CONT
MEDSCHR1 ; ******* CHRONIC MEDICATIONS, W/O D/C'ED *******
S APCHSMTY="CHRONIC",APCHSDCP=1 G CONT
;
CONT ; <SETUP>
Q:'$D(^AUPNVMED("AC",APCHSPAT))
;X APCHSCKP Q:$D(APCHSQIT)
I 'APCHSNPG S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30) X APCHSBRK
; <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>
;now display all meds on hold
D HOLDDSP
;now display MED refusals
S APCHST="MEDICATION",APCHSFN=50 D DISPREF^BSDX41F
K APCHST,APCHSFN
MEDX K APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP,APCHORTS,APCHSDCP
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
Q:'$D(^AUPNVMED(APCHSMX,0))
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=+APCHSN
S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSMFX=$S($P(APCHSN,U,4)="":+APCHSN,1:$P(APCHSN,U,4))
;I $D(^TMP($J,"APCHSMTB",APCHSMFX)),^TMP($J,"APCHSMTB",APCHSMFX)="" Q
S:APCHSDYS="" APCHSDYS=30
;SCREENS OUT MEDS NOT CURRENT; APCHSALL FORCES INCLUSION OF ALL MEDS
;I 'APCHSALL 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
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 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,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)) S ^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
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
I $G(APCHSDCP),APCHSDC]"" Q ;IHS/CMI/LAB - new component patch 9
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=""
I X>APCHSDYS S X1=APCHSDTM,X2=APCHSDYS D C^%DTC S Y=X X APCHSCVD S APCHSEXP="-- Ran out "_Y
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
;CHANGE IT AROUND A BIT LOOK FOR RETURNED TO STOCK IHS/OKCAO/POC 2/14/2000
S APCHORTS=$G(^AUPNVMED(APCHSMX,11))
I APCHORTS["RETURNED TO STOCK",APCHSDC S APCHSEXP="--RTS "_Y
;END OF LOCAL CHANGES IHS/OKCAO/POC 2/14/2000
D SIG S APCHSIG=APCHSSGY
D REF I APCHSREF S APCHSIG=APCHSIG_" "_APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
D SITE ;I APCHSITE]"" S APCHSIG=APCHSIG_" ["_APCHSITE_"]"
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXTMP=APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_$S(APCHSCRN:"(C)",1:"")
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(14-$L(BSDXTMP))_APCHSMED_" #"_APCHSQTY_" ("_APCHSDYS_" days) "_APCHSEXP
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
I APCHSITE]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(14)_"Dispensed at: "_APCHSITE_$C(30)
;X APCHSCKP Q:$D(APCHSQIT)
S APCHSICL=14,APCHSNRQ="",APCHSTXT=APCHSIG D PRTTXT^BSDX41F K APCHSICL,APCHSNRQ,APCHSP
Q
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
I $$VALI^XBDIQ1(9001015,APCHSTYP,3.5)="S" S APCHSSGY=APCHSIG Q
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
S APCHSRFL=$P($G(^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
Q:$P($G(^AUPNVSIT(APCHSVDF,0)),U,6)=""
I $P(^AUPNVSIT(APCHSVDF,0),U,6)'=DUZ(2) S APCHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(APCHSVDF,0),U,6),0),U),1,30)
Q
;
HOLDMEDS(P,R) ;EP - get meds on hold for display
;return array of med iens of all meds for this patient that are on hold
I '$G(P) Q
NEW D,C,N
S D=DT
F S D=$O(^PS(55,P,"P","A",D)) Q:D'=+D D
.S N=0 F S N=$O(^PS(55,P,"P","A",D,N)) Q:'N D
..Q:'$$HOLD(N)
..S R(N)=""
..Q
Q
;
HOLD(S) ;EP - is this prescription on hold?
NEW X
S X=$P($G(^PSRX(S,"STA")),U,1)
I X=3 Q 1
I X=5 Q 1
I X=16 Q 1
;version 6
S X=$P($G(^PSRX(S,0)),U,15)
I X=3 Q 1
I X=5 Q 1
I X=16 Q 1
Q 0
;
HOLDDSP ;EP - display all meds on hold
K APCHHMED
D HOLDMEDS(APCHSPAT,.APCHHMED)
Q:'$D(APCHHMED)
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="The following medications have been processed in the Pharmacy "_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="system, and are currently active but not dispensed:"_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S APCHSRX=0 F S APCHSRX=$O(APCHHMED(APCHSRX)) Q:APCHSRX'=+APCHSRX!($D(APCHSQIT)) D
.D HOLDDSP1
.Q
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Medications may be active but not dispensed for several reasons including: "_$C(30)
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Too early for refill, patient has sufficient amount on hand, pharmacy"_$C(30)
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="resolving issue with prescriber, etc. Contact Pharmacy staff for "_$C(30)
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="details or view prescription details in Pharmacy system."_$C(30)
K APCHHMED
Q
HOLDDSP1 ;write out med
S APCHSCRN=$S(+APCHSRX:$D(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
S (Y,APCHSDTM)=$P(^PSRX(APCHSRX,0),U,13) X APCHSCVD S APCHSDAT=Y ;issue or fill??
S APCHSDYS=$P(^PSRX(APCHSRX,0),U,8)
S APCHSQTY=$P(^PSRX(APCHSRX,0),U,7)
S APCHSIG=$P(^PSRX(APCHSRX,0),U,10)
D SIG S APCHSIG=APCHSSGY
D REF I APCHSREF S APCHSIG=APCHSIG_" "_APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
;D SITE ;I APCHSITE]"" S APCHSIG=APCHSIG_" ["_APCHSITE_"]"
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXTMP=APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_$S(APCHSCRN:"(C)",1:"")
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(14-$L(BSDXTMP))_$$VAL^XBDIQ1(52,APCHSRX,6)_" #"_APCHSQTY_" ("_APCHSDYS_" days) "
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
;I APCHSITE]"" W ?14,"Dispensed at: ",APCHSITE,!
;X APCHSCKP Q:$D(APCHSQIT)
S APCHSICL=14,APCHSNRQ="",APCHSTXT=APCHSIG D PRTTXT^BSDX41F K APCHSICL,APCHSNRQ,APCHSP
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(14)_"Ordering Provider: "_$$VAL^XBDIQ1(52,APCHSRX,4)_$C(30)
;X APCHSCKP Q:$D(APCHSQIT)
S APCHSTXT=$$VAL^XBDIQ1(52,APCHSRX,100)_" Reason: "_$$VAL^XBDIQ1(52,APCHSRX,99)_" - "_$$VAL^XBDIQ1(52,APCHSRX,99.1)_" ("_$$VAL^XBDIQ1(52,APCHSRX,99.2)_")",APCHSICL=14,APCHSNRQ=""
D PRTTXT^BSDX41F K APCHSICL,APCHSNRQ,APCHSP
Q
BSDX41G ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
+3 ;
MEDSCURR ; ************** CURRENT MEDICATIONS * 9000010.14 ********
+1 SET APCHSMTY="CURR"
GOTO CONT
MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
+1 SET APCHSMTY="ALL"
GOTO CONT
MEDSCHRN ; ************* CHRONIC MEDCICATIONS ************
+1 SET APCHSMTY="CHRONIC"
GOTO CONT
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
+1 SET APCHSMTY="NODUP"
GOTO CONT
MEDSCHR1 ; ******* CHRONIC MEDICATIONS, W/O D/C'ED *******
+1 SET APCHSMTY="CHRONIC"
SET APCHSDCP=1
GOTO CONT
+2 ;
CONT ; <SETUP>
+1 IF '$DATA(^AUPNVMED("AC",APCHSPAT))
QUIT
+2 ;X APCHSCKP Q:$D(APCHSQIT)
+3 IF 'APCHSNPG
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
XECUTE APCHSBRK
+4 ; <BUILD>
+5 KILL ^TMP($JOB,"APCHSMTB"),^TMP($JOB,"APCHSMTP")
+6 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
+7 ; <DISPLAY>
+8 SET APCHSIVD=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSMTP",APCHSIVD))
IF 'APCHSIVD
QUIT
DO MEDDSP
+9 ; <CLEANUP>
+10 ;now display all meds on hold
+11 DO HOLDDSP
+12 ;now display MED refusals
+13 SET APCHST="MEDICATION"
SET APCHSFN=50
DO DISPREF^BSDX41F
+14 KILL APCHST,APCHSFN
MEDX KILL APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP,APCHORTS,APCHSDCP
+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 IF '$DATA(^AUPNVMED(APCHSMX,0))
QUIT
+4 SET APCHSN=^AUPNVMED(APCHSMX,0)
+5 IF '$DATA(^PSDRUG($PIECE(APCHSN,U,1)))
QUIT
+6 SET APCHSDTM=-APCHSIVD\1+9999999
+7 ;S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSMFX=+APCHSN
+8 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))
+9 ;I $D(^TMP($J,"APCHSMTB",APCHSMFX)),^TMP($J,"APCHSMTB",APCHSMFX)="" Q
+10 IF APCHSDYS=""
SET APCHSDYS=30
+11 ;SCREENS OUT MEDS NOT CURRENT; APCHSALL FORCES INCLUSION OF ALL MEDS
+12 ;I 'APCHSALL S X1=DT,X2=APCHSDTM D ^%DTC Q:X>60&(X>(2*APCHSDYS))
+13 ;S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
+14 DO @APCHSMTY
+15 QUIT
+16 ;
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 ;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,"APCHSMTP",APCHSIVD_"-"_APCHSMFX))
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
+4 IF $DATA(^TMP($JOB,"APCHSMTB",APCHSMFX))
QUIT
+5 SET ^TMP($JOB,"APCHSMTB",APCHSMFX)=APCHSDC
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
+6 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 ;IHS/CMI/LAB - new component patch 9
IF $GET(APCHSDCP)
IF APCHSDC]""
QUIT
+6 SET ^TMP($JOB,"APCHSMTB",APCHSMFX)=APCHSDC
SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
+7 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 IF X>APCHSDYS
SET X1=APCHSDTM
SET X2=APCHSDYS
DO C^%DTC
SET Y=X
XECUTE APCHSCVD
SET APCHSEXP="-- Ran out "_Y
+12 SET APCHSMED=$SELECT($PIECE(APCHSN,U,4)="":$PIECE(^PSDRUG(APCHSMFX,0),U,1),1:$PIECE(APCHSN,U,4))
+13 IF APCHSDC
SET Y=APCHSDC
XECUTE APCHSCVD
SET APCHSEXP="-- D/C "_Y
+14 ;CHANGE IT AROUND A BIT LOOK FOR RETURNED TO STOCK IHS/OKCAO/POC 2/14/2000
+15 SET APCHORTS=$GET(^AUPNVMED(APCHSMX,11))
+16 IF APCHORTS["RETURNED TO STOCK"
IF APCHSDC
SET APCHSEXP="--RTS "_Y
+17 ;END OF LOCAL CHANGES IHS/OKCAO/POC 2/14/2000
+18 DO SIG
SET APCHSIG=APCHSSGY
+19 DO REF
IF APCHSREF
SET APCHSIG=APCHSIG_" "_APCHSREF_$SELECT(APCHSREF=1:" refill",1:" refills")_" left."
+20 ;I APCHSITE]"" S APCHSIG=APCHSIG_" ["_APCHSITE_"]"
DO SITE
+21 ;X APCHSCKP Q:$D(APCHSQIT)
+22 SET BSDXTMP=APCHSDAT_$$FILL^BSDX41(10-$LENGTH(APCHSDAT))_$SELECT(APCHSCRN:"(C)",1:"")
+23 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(14-$LENGTH(BSDXTMP))_APCHSMED_" #"_APCHSQTY_" ("_APCHSDYS_" days) "_APCHSEXP
+24 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+25 IF APCHSITE]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(14)_"Dispensed at: "_APCHSITE_$CHAR(30)
+26 ;X APCHSCKP Q:$D(APCHSQIT)
+27 SET APCHSICL=14
SET APCHSNRQ=""
SET APCHSTXT=APCHSIG
DO PRTTXT^BSDX41F
KILL APCHSICL,APCHSNRQ,APCHSP
+28 QUIT
+29 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 IF $$VALI^XBDIQ1(9001015,APCHSTYP,3.5)="S"
SET APCHSSGY=APCHSIG
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 SET APCHSRFL=$PIECE($GET(^PSRX(APCHSRX,0)),U,9)
SET APCHSREF=0
FOR
SET APCHSREF=$ORDER(^PSRX(APCHSRX,1,APCHSREF))
IF 'APCHSREF
QUIT
SET APCHSRFL=APCHSRFL-1
+3 SET APCHSREF=APCHSRFL
+4 QUIT
+5 ;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
+1 SET APCHSITE=""
+2 IF $DATA(^AUPNVSIT(APCHSVDF,21))#2
SET APCHSITE=$PIECE(^(21),U)
QUIT
+3 IF $PIECE($GET(^AUPNVSIT(APCHSVDF,0)),U,6)=""
QUIT
+4 IF $PIECE(^AUPNVSIT(APCHSVDF,0),U,6)'=DUZ(2)
SET APCHSITE=$EXTRACT($PIECE(^DIC(4,$PIECE(^AUPNVSIT(APCHSVDF,0),U,6),0),U),1,30)
+5 QUIT
+6 ;
HOLDMEDS(P,R) ;EP - get meds on hold for display
+1 ;return array of med iens of all meds for this patient that are on hold
+2 IF '$GET(P)
QUIT
+3 NEW D,C,N
+4 SET D=DT
+5 FOR
SET D=$ORDER(^PS(55,P,"P","A",D))
IF D'=+D
QUIT
Begin DoDot:1
+6 SET N=0
FOR
SET N=$ORDER(^PS(55,P,"P","A",D,N))
IF 'N
QUIT
Begin DoDot:2
+7 IF '$$HOLD(N)
QUIT
+8 SET R(N)=""
+9 QUIT
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
HOLD(S) ;EP - is this prescription on hold?
+1 NEW X
+2 SET X=$PIECE($GET(^PSRX(S,"STA")),U,1)
+3 IF X=3
QUIT 1
+4 IF X=5
QUIT 1
+5 IF X=16
QUIT 1
+6 ;version 6
+7 SET X=$PIECE($GET(^PSRX(S,0)),U,15)
+8 IF X=3
QUIT 1
+9 IF X=5
QUIT 1
+10 IF X=16
QUIT 1
+11 QUIT 0
+12 ;
HOLDDSP ;EP - display all meds on hold
+1 KILL APCHHMED
+2 DO HOLDMEDS(APCHSPAT,.APCHHMED)
+3 IF '$DATA(APCHHMED)
QUIT
+4 ;X APCHSCKP Q:$D(APCHSQIT)
+5 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+6 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="The following medications have been processed in the Pharmacy "_$CHAR(30)
+7 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="system, and are currently active but not dispensed:"_$CHAR(30)
+8 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+9 SET APCHSRX=0
FOR
SET APCHSRX=$ORDER(APCHHMED(APCHSRX))
IF APCHSRX'=+APCHSRX!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+10 DO HOLDDSP1
+11 QUIT
End DoDot:1
+12 ;X APCHSCKP Q:$D(APCHSQIT)
+13 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+14 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="Medications may be active but not dispensed for several reasons including: "_$CHAR(30)
+15 ;X APCHSCKP Q:$D(APCHSQIT)
+16 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="Too early for refill, patient has sufficient amount on hand, pharmacy"_$CHAR(30)
+17 ;X APCHSCKP Q:$D(APCHSQIT)
+18 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="resolving issue with prescriber, etc. Contact Pharmacy staff for "_$CHAR(30)
+19 ;X APCHSCKP Q:$D(APCHSQIT)
+20 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="details or view prescription details in Pharmacy system."_$CHAR(30)
+21 KILL APCHHMED
+22 QUIT
HOLDDSP1 ;write out med
+1 SET APCHSCRN=$SELECT(+APCHSRX:$DATA(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
+2 ;issue or fill??
SET (Y,APCHSDTM)=$PIECE(^PSRX(APCHSRX,0),U,13)
XECUTE APCHSCVD
SET APCHSDAT=Y
+3 SET APCHSDYS=$PIECE(^PSRX(APCHSRX,0),U,8)
+4 SET APCHSQTY=$PIECE(^PSRX(APCHSRX,0),U,7)
+5 SET APCHSIG=$PIECE(^PSRX(APCHSRX,0),U,10)
+6 DO SIG
SET APCHSIG=APCHSSGY
+7 DO REF
IF APCHSREF
SET APCHSIG=APCHSIG_" "_APCHSREF_$SELECT(APCHSREF=1:" refill",1:" refills")_" left."
+8 ;D SITE ;I APCHSITE]"" S APCHSIG=APCHSIG_" ["_APCHSITE_"]"
+9 ;X APCHSCKP Q:$D(APCHSQIT)
+10 SET BSDXTMP=APCHSDAT_$$FILL^BSDX41(10-$LENGTH(APCHSDAT))_$SELECT(APCHSCRN:"(C)",1:"")
+11 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(14-$LENGTH(BSDXTMP))_$$VAL^XBDIQ1(52,APCHSRX,6)_" #"_APCHSQTY_" ("_APCHSDYS_" days) "
+12 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+13 ;I APCHSITE]"" W ?14,"Dispensed at: ",APCHSITE,!
+14 ;X APCHSCKP Q:$D(APCHSQIT)
+15 SET APCHSICL=14
SET APCHSNRQ=""
SET APCHSTXT=APCHSIG
DO PRTTXT^BSDX41F
KILL APCHSICL,APCHSNRQ,APCHSP
+16 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(14)_"Ordering Provider: "_$$VAL^XBDIQ1(52,APCHSRX,4)_$CHAR(30)
+17 ;X APCHSCKP Q:$D(APCHSQIT)
+18 SET APCHSTXT=$$VAL^XBDIQ1(52,APCHSRX,100)_" Reason: "_$$VAL^XBDIQ1(52,APCHSRX,99)_" - "_$$VAL^XBDIQ1(52,APCHSRX,99.1)_" ("_$$VAL^XBDIQ1(52,APCHSRX,99.2)_")"
SET APCHSICL=14
SET APCHSNRQ=""
+19 DO PRTTXT^BSDX41F
KILL APCHSICL,APCHSNRQ,APCHSP
+20 QUIT
