APCHS7R ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,5**;MAY 14, 2009
;
SET ;
;S APCHCNT=APCHCNT+1
S APCHSRX=P,APCHSREF=0 D REF
S APCHSTAT(C,N,D,(9999999-F),M)=$S(P:$P(^PSRX(P,0),U),1:"")_U_APCHSREF
S APCHMDSP(D,N,F)=""
Q
MEDRCON ; ************* MEDS BY PRESCRIPTION STATUS *************
;
CONT ; <SETUP>
I '$D(^AUPNVMED("AC",APCHSPAT)),'$D(^PS(52.41,"P",APCHSPAT)),'$D(^PS(55,APCHSPAT,"NVA")) Q
X APCHSCKP Q:$D(APCHSQIT) I 'APCHSNPG W ! X APCHSBRK
; <BUILD>
NEW APCHMEDS,APCHSTAT,APCHCNT,APCHMDSP,APCHDI,APCHDT,APCHM,APCHN,APCHSSGY,APCHSIG,APCHZ,APCHSN,APCHST,APCHI,APCHD
NEW X,F,M,V,D,N,P,C,E,S,R,J
S APCHCNT=0
K APCHMEDS,APCHMDSP
D GETMEDS^APCHSMU1(APCHSPAT,$$FMADD^XLFDT(DT,-395),DT,,,,,.APCHMEDS)
;I '$D(APCHMEDS) D MEDX Q
;NOW REORDER THEM BY STATUS
K APCHSTAT
S X=0 F S X=$O(APCHMEDS(X)) Q:X'=+X D
.S P=""
.S F=$P(APCHMEDS(X),U,1) ;FILL DATE
.S M=$P(APCHMEDS(X),U,4) ;vmed ien
.S V=$P(APCHMEDS(X),U,5) ;visit ien
.S D=$P(^AUPNVMED(M,0),U) ;drug ien
.S N=$P(^AUPNVMED(M,0),U,4) ;non table drug name
.I N="" S N=$P(^PSDRUG(D,0),U) ;drug name
.I $P($G(^AUPNVSIT(X,0)),U,7)="E" S C="OUTSIDE MEDICATIONS" D SET Q
.;I $P($G(^AUPNVMED(X,11)),U,8)]"" Q ;we will get EHR outside meds from the NVA multiple later S C="OUTSIDE MEDICATIONS" D SET Q
.S P=$O(^PSRX("APCC",M,0))
.I 'P S C="OUTSIDE MEDICATIONS" D SET Q
.I '$D(^PSRX(P,0)) S P="",C="OUTSIDE MEDICATIONS" D SET Q
.S S=$$VALI^XBDIQ1(52,P,100) ;GET STATUS
.I S=0 S C="ACTIVE MEDICATIONS" D SET Q
.I S=3 S C="HOLD" D SET Q
.I S=5 S C="SUSPENDED" D SET Q
.I S=11 D Q
..;get expiration date
..S E=$P($G(^PSRX(P,3)),U,6)
..S R=$$CHRONIC^APCHS72(M) ;chronic flag
..I 'R D Q
...;not chronic, check to see if expired in past 14 days, if not quit
...S J=$$FMDIFF^XLFDT(DT,E)
...Q:J>14 ;more than 14 days ago so don't display
...;check to see if same drug is already listed somewhere
...Q:$O(APCHMDSP(D,N,F)) ;another of same drug after this date
...S C="EXPIRED" D SET Q
..;chronic = check 120 days
..S J=$$FMDIFF^XLFDT(DT,E)
..Q:J>120 ;expired more than 120 days ago
..Q:$O(APCHMDSP(D,N,F)) ;another one there so don't display this one
..S C="EXPIRED" D SET Q
.I S=12!(S=14) D
..S E=$P(^AUPNVMED(M,0),U,8) ;discontinued date in v med
..I E="" S E=$P($G(^PSRX(P,3)),U,5) ;canceled date in 52
..I $$FMDIFF^XLFDT(DT,E)>30 Q ;only discontinueds in past 30 days
..Q:$O(APCHMDSP(D,N,F))
..S C="DISCONTINUED MEDICATIONS" D SET Q
GETNVA ;NVA from file 55
S X=0 F S X=$O(^PS(55,APCHSPAT,"NVA",X)) Q:X'=+X D
.I $P($G(^PS(55,APCHSPAT,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,APCHSPAT,"NVA",X,999999911),U,1),0)) Q ;got this with V MED
.;S L=$P(^PS(55,APCHSPAT,"NVA",X,0),U,9)
.;:'L
.S L=$P($P($G(^PS(55,APCHSPAT,"NVA",X,0)),U,10),".")
.S L=9999999-L
.;Q:$P(^PS(55,APCHSPAT,"NVA",X,0),U,6)=1 ;discontinued
.;I $P(^PS(55,APCHSPAT,"NVA",X,0),U,7)]"" ;discontinued date
.S D=$P(^PS(55,APCHSPAT,"NVA",X,0),U,2)
.I D="" S D="NO DRUG IEN"
.S N=$S(D:$P(^PSDRUG(D,0),U,1),1:$P(^PS(50.7,$P(^PS(55,APCHSPAT,"NVA",X,0),U,1),0),U,1))
.S APCHSTAT("NVA",N,D,(9999999-L))=U_"N",$P(APCHSTAT("NVA",N,D,(9999999-L)),U,8)=$P(^PS(55,APCHSPAT,"NVA",X,0),U,4)_" "_$P(^PS(55,APCHSPAT,"NVA",X,0),U,5)_U_$P(^PS(55,APCHSPAT,"NVA",X,0),U,7)
GETPEND ;
NEW PEN,ORD
F PEN=0:0 S PEN=$O(^PS(52.41,"P",APCHSPAT,PEN)) Q:'PEN S ORD=^PS(52.41,PEN,0),APCHI=$P(ORD,"^",8),APCHD=+$P(ORD,"^",9) D:$P(ORD,"^",3)'="DC"&($P(ORD,"^",3)'="DE")&($P(ORD,"^",3)'="HD")
.S APCHN=$S(APCHD:$P($G(^PSDRUG(APCHD,0)),"^"),+APCHI&('APCHD):$P(^PS(50.7,APCHI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,APCHI,0),"^",2),0),"^"),1:"") Q:APCHN']""
.S APCHSTAT("PENDING",APCHN,PEN)=$$VAL^XBDIQ1(52.41,PEN,13)
.S C=0,X="" F S C=$O(^PS(52.41,PEN,"SIG",C)) Q:'C S X=X_$S(X]"":" ",1:"")_^PS(52.41,PEN,"SIG",C,0)
.S $P(APCHSTAT("PENDING",APCHN,PEN),U,2)=X
DISP ;DISPLAY MEDS
;ACTIVE MEDS FIRST - ALL OF THEM
X APCHSCKP Q:$D(APCHSQIT)
I '$D(APCHSTAT("ACTIVE MEDICATIONS")) G OUT
W "ACTIVE MEDICATIONS",!
S APCHCNT=0
S APCHT=1
S APCHN="" F S APCHN=$O(APCHSTAT("ACTIVE MEDICATIONS",APCHN)) Q:APCHN=""!($D(APCHSQIT)) D
.S APCHDI="" F S APCHDI=$O(APCHSTAT("ACTIVE MEDICATIONS",APCHN,APCHDI)) Q:APCHDI=""!($D(APCHSQIT)) D
..S APCHDT=0 F S APCHDT=$O(APCHSTAT("ACTIVE MEDICATIONS",APCHN,APCHDI,APCHDT)) Q:APCHDT'=+APCHDT!($D(APCHSQIT)) D
...S APCHM=0 F S APCHM=$O(APCHSTAT("ACTIVE MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)) Q:APCHM'=+APCHM!($D(APCHSQIT)) S APCHZ=APCHSTAT("ACTIVE MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM) D MEDDSP
OUT ;OUTSIDE MEDICATIONS
I '$D(APCHSTAT("OUTSIDE MEDICATIONS")),'$D(APCHSTAT("NVA")) G HOLD
W "--------------------",!
W "OUTSIDE MEDICATIONS",!
S APCHN="" F S APCHN=$O(APCHSTAT("OUTSIDE MEDICATIONS",APCHN)) Q:APCHN=""!($D(APCHSQIT)) D
.S APCHDI="" F S APCHDI=$O(APCHSTAT("OUTSIDE MEDICATIONS",APCHN,APCHDI)) Q:APCHDI=""!($D(APCHSQIT)) D
..S APCHDT=0 S APCHDT=$O(APCHSTAT("OUTSIDE MEDICATIONS",APCHN,APCHDI,APCHDT)) Q:APCHDT'=+APCHDT!($D(APCHSQIT)) D
...S APCHM=0 S APCHM=$O(APCHSTAT("OUTSIDE MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)) Q:APCHM'=+APCHM!($D(APCHSQIT)) S APCHZ=APCHSTAT("OUTSIDE MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM) D MEDDSPO
;now display nva
S APCHN="" F S APCHN=$O(APCHSTAT("NVA",APCHN)) Q:APCHN=""!($D(APCHSQIT)) D
.S APCHDI="" F S APCHDI=$O(APCHSTAT("NVA",APCHN,APCHDI)) Q:APCHDI=""!($D(APCHSQIT)) D
..S APCHDT=0 S APCHDT=$O(APCHSTAT("NVA",APCHN,APCHDI,APCHDT)) Q:APCHDT'=+APCHDT!($D(APCHSQIT)) D
...S APCHZ=APCHSTAT("NVA",APCHN,APCHDI,APCHDT) D MEDDSPN
HOLD ;HOLD MEDICATIONS
I '$D(APCHSTAT("HOLD MEDICATIONS")) G SUSPEND
S APCHT=3
W "--------------------",!
W "ACTIVE NOT DISPENSED MEDICATIONS",!
S APCHN="" F S APCHN=$O(APCHSTAT("HOLD MEDICATIONS",APCHN)) Q:APCHN=""!($D(APCHSQIT)) D
.S APCHDI="" F S APCHDI=$O(APCHSTAT("HOLD MEDICATIONS",APCHN,APCHDI)) Q:APCHDI=""!($D(APCHSQIT)) D
..S APCHDT=0 F S APCHDT=$O(APCHSTAT("HOLD MEDICATIONS",APCHN,APCHDI,APCHDT)) Q:APCHDT'=+APCHDT!($D(APCHSQIT)) D
...S APCHM=0 F S APCHM=$O(APCHSTAT("HOLD MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)) Q:APCHM'=+APCHM!($D(APCHSQIT)) S APCHZ=APCHSTAT("HOLD MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM) D MEDDSP
SUSPEND ;
I '$D(APCHSTAT("SUSPEND MEDICATIONS")) G PENDING
S APCHT=4
W !,"--------------------",!
W "SUSPENDED MEDICATIONS",!
S APCHN="" F S APCHN=$O(APCHSTAT("SUSPEND MEDICATIONS",APCHN)) Q:APCHN=""!($D(APCHSQIT)) D
.S APCHDI="" F S APCHDI=$O(APCHSTAT("SUSPEND MEDICATIONS",APCHN,APCHDI)) Q:APCHDI=""!($D(APCHSQIT)) D
..S APCHDT=0 F S APCHDT=$O(APCHSTAT("SUSPEND MEDICATIONS",APCHN,APCHDI,APCHDT)) Q:APCHDT'=+APCHDT!($D(APCHSQIT)) D
...S APCHM=0 F S APCHM=$O(APCHSTAT("SUSPEND MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)) Q:APCHM'=+APCHM!($D(APCHSQIT)) S APCHZ=APCHSTAT("SUSPEND MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM) D MEDDSP
PENDING ;
I '$D(APCHSTAT("PENDING")) G EXPIRED
W "--------------------",!
W "PENDING MEDICATIONS",!
S APCHN="" F S APCHN=$O(APCHSTAT("PENDING",APCHN)) Q:APCHN=""!($D(APCHSQIT)) D
.S APCHDI="" F S APCHDI=$O(APCHSTAT("PENDING",APCHN,APCHDI)) Q:APCHDI=""!($D(APCHSQIT)) D
..S APCHZ=APCHSTAT("PENDING",APCHN,APCHDI) D MEDDSPP
EXPIRED ;
I '$D(APCHSTAT("EXPIRED MEDICATIONS")) G DISCONT
S APCHT=6
W "--------------------",!
W "CHRONIC AND RECENTLY EXPIRED MEDICATIONS",!
S APCHN="" F S APCHN=$O(APCHSTAT("EXPIRED MEDICATIONS",APCHN)) Q:APCHN=""!($D(APCHSQIT)) D
.S APCHDI="" F S APCHDI=$O(APCHSTAT("EXPIRED MEDICATIONS",APCHN,APCHDI)) Q:APCHDI=""!($D(APCHSQIT)) D
..S APCHDT=0 F S APCHDT=$O(APCHSTAT("EXPIRED MEDICATIONS",APCHN,APCHDI,APCHDT)) Q:APCHDT'=+APCHDT!($D(APCHSQIT)) D
...S APCHM=0 F S APCHM=$O(APCHSTAT("EXPIRED MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)) Q:APCHM'=+APCHM!($D(APCHSQIT)) S APCHZ=APCHSTAT("EXPIRED MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM) D MEDDSP
DISCONT ;
I '$D(APCHSTAT("DISCONTINUED MEDICATIONS")) G MEDX
S APCHT=7
W "--------------------",!
W "RECENTLY DISCONTINUED MEDICATIONS",!
S APCHN="" F S APCHN=$O(APCHSTAT("DISCONTINUED MEDICATIONS",APCHN)) Q:APCHN=""!($D(APCHSQIT)) D
.S APCHDI="" F S APCHDI=$O(APCHSTAT("DISCONTINUED MEDICATIONS",APCHN,APCHDI)) Q:APCHDI=""!($D(APCHSQIT)) D
..S APCHDT=0 F S APCHDT=$O(APCHSTAT("DISCONTINUED MEDICATIONS",APCHN,APCHDI,APCHDT)) Q:APCHDT'=+APCHDT!($D(APCHSQIT)) D
...S APCHM=0 F S APCHM=$O(APCHSTAT("DISCONTINUED MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)) Q:APCHM'=+APCHM!($D(APCHSQIT)) S APCHZ=APCHSTAT("DISCONTINUED MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM) D MEDDSP
MEDX ;
Q
MEDDSPP ;DISPLAY MEDICATION
S APCHCNT=APCHCNT+1
X APCHSCKP Q:$D(APCHSQIT)
W APCHCNT,".",?6,APCHN W:$P(APCHZ,U,2) ?60,"Refills: ",$S('$P(APCHZ,U,1):"NONE",1:$P(APCHZ,U,1)) W !
X APCHSCKP Q:$D(APCHSQIT)
K ^UTILITY($J,"W") S X=$P(APCHZ,U,2),DIWL=0,DIWR=60 D ^DIWP
W ?6,"Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" "),!
I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(APCHSQIT) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?19,$G(^UTILITY($J,"W",0,F,0)),!
K ^UTILITY($J,"W")
Q
MEDDSPO ;DISPLAY MEDICATION
S APCHSN=^AUPNVMED(APCHM,0)
S APCHCNT=APCHCNT+1
X APCHSCKP Q:$D(APCHSQIT)
W APCHCNT,".",?6,APCHN W:$P(APCHZ,U,2) ?60,"Refills left: ",$S('$P(APCHZ,U,2):"NONE",1:$P(APCHZ,U,2)) W !
X APCHSCKP Q:$D(APCHSQIT)
S APCHSIG=$P(^AUPNVMED(APCHM,0),U,5) D SIG
S X=APCHSSGY
K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
X APCHSCKP Q:$D(APCHSQIT)
W ?6,"Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" "),!
I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(APCHSQIT) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?19,$G(^UTILITY($J,"W",0,F,0)),!
K ^UTILITY($J,"W")
Q
MEDDSPN ;
S APCHCNT=APCHCNT+1
X APCHSCKP Q:$D(APCHSQIT)
W APCHCNT,".",?6,APCHN,! ;W:$P(APCHZ,U,2) ?60,"Refills left: ",$S('$P(APCHZ,U,2):"NONE",1:$P(APCHZ,U,2)) W !
X APCHSCKP Q:$D(APCHSQIT)
S APCHSIG=$P(APCHZ,U,8) D SIG
S X=APCHSSGY
K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
X APCHSCKP Q:$D(APCHSQIT)
W ?6,"Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" "),!
I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(APCHSQIT) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?19,$G(^UTILITY($J,"W",0,F,0)),!
I $P(APCHZ,U,9) W !?19,"DATE DISCONTINUED: ",$$FMTE^XLFDT($P(APCHZ,U,9))
K ^UTILITY($J,"W")
Q
MEDDSP ;DISPLAY MEDICATION
S APCHSN=^AUPNVMED(APCHM,0)
S APCHCNT=APCHCNT+1
X APCHSCKP Q:$D(APCHSQIT)
W APCHCNT,".",?6,APCHN,?40,"Rx #:",$P(APCHZ,U,1),?60,"Refills left: ",$S('$P(APCHZ,U,2):"NONE",1:$P(APCHZ,U,2)),!
X APCHSCKP Q:$D(APCHSQIT)
S APCHSIG=$P(^AUPNVMED(APCHM,0),U,5) D SIG
S X=APCHSSGY
K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
X APCHSCKP Q:$D(APCHSQIT)
W ?6,"Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" "),!
I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(APCHSQIT) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?19,$G(^UTILITY($J,"W",0,F,0)),!
K ^UTILITY($J,"W")
X APCHSCKP Q:$D(APCHSQIT)
I APCHT=1!(APCHT=6) W ?6,"Last Filled: ",$$D(9999999-APCHDT) D
.S APCHSORT="" I APCHT=1 S APCHSORT=$P($G(^AUPNVMED(APCHM,11)),U)
.I APCHSORT["RETURNED TO STOCK" W " ---",APCHSORT," ",$$FMTE^XLFDT($P(^AUPNVMED(APCHM,0),U,8),"2D")
I APCHT=6 I $P(APCHZ,U,1) S E=$P($G(^PSRX($P(APCHZ,U,1),3)),U,6) W ?30,"Expired: ",$$D(E)
W !
I APCHT=3 W ?6,"Hold Reason: " I $P(APCHZ,U,1) W $P($G(^PSRX($P(APCHZ,U,1),"H")),U,1)
I APCHT=7 W ?6,"Discontinued: " D
.S E=$P(^AUPNVMED(APCHM,0),U,8) ;discontinued date in v med
.I E="",$P(APCHZ,U,1) S E=$P($G(^PSRX($P(APCHZ,U,1),3)),U,5) ;canceled date in 52
.W $$D(E),!
Q
D(D) ;
I D="" Q ""
Q $E(D,4,5)_"-"_$E(D,6,7)_"-"_$E(D,2,3)
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
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=$P($G(^AUPNVMED(M,11)),U,7) S:APCHSREF="" 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
Q:$P(^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
;
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
APCHS7R ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,5**;MAY 14, 2009
+2 ;
SET ;
+1 ;S APCHCNT=APCHCNT+1
+2 SET APCHSRX=P
SET APCHSREF=0
DO REF
+3 SET APCHSTAT(C,N,D,(9999999-F),M)=$SELECT(P:$PIECE(^PSRX(P,0),U),1:"")_U_APCHSREF
+4 SET APCHMDSP(D,N,F)=""
+5 QUIT
MEDRCON ; ************* MEDS BY PRESCRIPTION STATUS *************
+1 ;
CONT ; <SETUP>
+1 IF '$DATA(^AUPNVMED("AC",APCHSPAT))
IF '$DATA(^PS(52.41,"P",APCHSPAT))
IF '$DATA(^PS(55,APCHSPAT,"NVA"))
QUIT
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
WRITE !
XECUTE APCHSBRK
+3 ; <BUILD>
+4 NEW APCHMEDS,APCHSTAT,APCHCNT,APCHMDSP,APCHDI,APCHDT,APCHM,APCHN,APCHSSGY,APCHSIG,APCHZ,APCHSN,APCHST,APCHI,APCHD
+5 NEW X,F,M,V,D,N,P,C,E,S,R,J
+6 SET APCHCNT=0
+7 KILL APCHMEDS,APCHMDSP
+8 DO GETMEDS^APCHSMU1(APCHSPAT,$$FMADD^XLFDT(DT,-395),DT,,,,,.APCHMEDS)
+9 ;I '$D(APCHMEDS) D MEDX Q
+10 ;NOW REORDER THEM BY STATUS
+11 KILL APCHSTAT
+12 SET X=0
FOR
SET X=$ORDER(APCHMEDS(X))
IF X'=+X
QUIT
Begin DoDot:1
+13 SET P=""
+14 ;FILL DATE
SET F=$PIECE(APCHMEDS(X),U,1)
+15 ;vmed ien
SET M=$PIECE(APCHMEDS(X),U,4)
+16 ;visit ien
SET V=$PIECE(APCHMEDS(X),U,5)
+17 ;drug ien
SET D=$PIECE(^AUPNVMED(M,0),U)
+18 ;non table drug name
SET N=$PIECE(^AUPNVMED(M,0),U,4)
+19 ;drug name
IF N=""
SET N=$PIECE(^PSDRUG(D,0),U)
+20 IF $PIECE($GET(^AUPNVSIT(X,0)),U,7)="E"
SET C="OUTSIDE MEDICATIONS"
DO SET
QUIT
+21 ;I $P($G(^AUPNVMED(X,11)),U,8)]"" Q ;we will get EHR outside meds from the NVA multiple later S C="OUTSIDE MEDICATIONS" D SET Q
+22 SET P=$ORDER(^PSRX("APCC",M,0))
+23 IF 'P
SET C="OUTSIDE MEDICATIONS"
DO SET
QUIT
+24 IF '$DATA(^PSRX(P,0))
SET P=""
SET C="OUTSIDE MEDICATIONS"
DO SET
QUIT
+25 ;GET STATUS
SET S=$$VALI^XBDIQ1(52,P,100)
+26 IF S=0
SET C="ACTIVE MEDICATIONS"
DO SET
QUIT
+27 IF S=3
SET C="HOLD"
DO SET
QUIT
+28 IF S=5
SET C="SUSPENDED"
DO SET
QUIT
+29 IF S=11
Begin DoDot:2
+30 ;get expiration date
+31 SET E=$PIECE($GET(^PSRX(P,3)),U,6)
+32 ;chronic flag
SET R=$$CHRONIC^APCHS72(M)
+33 IF 'R
Begin DoDot:3
+34 ;not chronic, check to see if expired in past 14 days, if not quit
+35 SET J=$$FMDIFF^XLFDT(DT,E)
+36 ;more than 14 days ago so don't display
IF J>14
QUIT
+37 ;check to see if same drug is already listed somewhere
+38 ;another of same drug after this date
IF $ORDER(APCHMDSP(D,N,F))
QUIT
+39 SET C="EXPIRED"
DO SET
QUIT
End DoDot:3
QUIT
+40 ;chronic = check 120 days
+41 SET J=$$FMDIFF^XLFDT(DT,E)
+42 ;expired more than 120 days ago
IF J>120
QUIT
+43 ;another one there so don't display this one
IF $ORDER(APCHMDSP(D,N,F))
QUIT
+44 SET C="EXPIRED"
DO SET
QUIT
End DoDot:2
QUIT
+45 IF S=12!(S=14)
Begin DoDot:2
+46 ;discontinued date in v med
SET E=$PIECE(^AUPNVMED(M,0),U,8)
+47 ;canceled date in 52
IF E=""
SET E=$PIECE($GET(^PSRX(P,3)),U,5)
+48 ;only discontinueds in past 30 days
IF $$FMDIFF^XLFDT(DT,E)>30
QUIT
+49 IF $ORDER(APCHMDSP(D,N,F))
QUIT
+50 SET C="DISCONTINUED MEDICATIONS"
DO SET
QUIT
End DoDot:2
End DoDot:1
GETNVA ;NVA from file 55
+1 SET X=0
FOR
SET X=$ORDER(^PS(55,APCHSPAT,"NVA",X))
IF X'=+X
QUIT
Begin DoDot:1
+2 ;got this with V MED
IF $PIECE($GET(^PS(55,APCHSPAT,"NVA",X,999999911)),U,1)
IF $DATA(^AUPNVMED($PIECE(^PS(55,APCHSPAT,"NVA",X,999999911),U,1),0))
QUIT
+3 ;S L=$P(^PS(55,APCHSPAT,"NVA",X,0),U,9)
+4 ;:'L
+5 SET L=$PIECE($PIECE($GET(^PS(55,APCHSPAT,"NVA",X,0)),U,10),".")
+6 SET L=9999999-L
+7 ;Q:$P(^PS(55,APCHSPAT,"NVA",X,0),U,6)=1 ;discontinued
+8 ;I $P(^PS(55,APCHSPAT,"NVA",X,0),U,7)]"" ;discontinued date
+9 SET D=$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,2)
+10 IF D=""
SET D="NO DRUG IEN"
+11 SET N=$SELECT(D:$PIECE(^PSDRUG(D,0),U,1),1:$PIECE(^PS(50.7,$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,1),0),U,1))
+12 SET APCHSTAT("NVA",N,D,(9999999-L))=U_"N"
SET $PIECE(APCHSTAT("NVA",N,D,(9999999-L)),U,8)=$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,4)_" "_$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,5)_U_$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,7)
End DoDot:1
GETPEND ;
+1 NEW PEN,ORD
+2 FOR PEN=0:0
SET PEN=$ORDER(^PS(52.41,"P",APCHSPAT,PEN))
IF 'PEN
QUIT
SET ORD=^PS(52.41,PEN,0)
SET APCHI=$PIECE(ORD,"^",8)
SET APCHD=+$PIECE(ORD,"^",9)
IF $PIECE(ORD,"^",3)'="DC"&($PIECE(ORD,"^",3)'="DE")&($PIECE(ORD,"^",3)'="HD")
Begin DoDot:1
+3 SET APCHN=$SELECT(APCHD:$PIECE($GET(^PSDRUG(APCHD,0)),"^"),+APCHI&('APCHD):$PIECE(^PS(50.7,APCHI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,APCHI,0),"^",2),0),"^"),1:"")
IF APCHN']""
QUIT
+4 SET APCHSTAT("PENDING",APCHN,PEN)=$$VAL^XBDIQ1(52.41,PEN,13)
+5 SET C=0
SET X=""
FOR
SET C=$ORDER(^PS(52.41,PEN,"SIG",C))
IF 'C
QUIT
SET X=X_$SELECT(X]"":" ",1:"")_^PS(52.41,PEN,"SIG",C,0)
+6 SET $PIECE(APCHSTAT("PENDING",APCHN,PEN),U,2)=X
End DoDot:1
DISP ;DISPLAY MEDS
+1 ;ACTIVE MEDS FIRST - ALL OF THEM
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 IF '$DATA(APCHSTAT("ACTIVE MEDICATIONS"))
GOTO OUT
+4 WRITE "ACTIVE MEDICATIONS",!
+5 SET APCHCNT=0
+6 SET APCHT=1
+7 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHSTAT("ACTIVE MEDICATIONS",APCHN))
IF APCHN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+8 SET APCHDI=""
FOR
SET APCHDI=$ORDER(APCHSTAT("ACTIVE MEDICATIONS",APCHN,APCHDI))
IF APCHDI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+9 SET APCHDT=0
FOR
SET APCHDT=$ORDER(APCHSTAT("ACTIVE MEDICATIONS",APCHN,APCHDI,APCHDT))
IF APCHDT'=+APCHDT!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+10 SET APCHM=0
FOR
SET APCHM=$ORDER(APCHSTAT("ACTIVE MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM))
IF APCHM'=+APCHM!($DATA(APCHSQIT))
QUIT
SET APCHZ=APCHSTAT("ACTIVE MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
OUT ;OUTSIDE MEDICATIONS
+1 IF '$DATA(APCHSTAT("OUTSIDE MEDICATIONS"))
IF '$DATA(APCHSTAT("NVA"))
GOTO HOLD
+2 WRITE "--------------------",!
+3 WRITE "OUTSIDE MEDICATIONS",!
+4 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHSTAT("OUTSIDE MEDICATIONS",APCHN))
IF APCHN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+5 SET APCHDI=""
FOR
SET APCHDI=$ORDER(APCHSTAT("OUTSIDE MEDICATIONS",APCHN,APCHDI))
IF APCHDI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+6 SET APCHDT=0
SET APCHDT=$ORDER(APCHSTAT("OUTSIDE MEDICATIONS",APCHN,APCHDI,APCHDT))
IF APCHDT'=+APCHDT!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+7 SET APCHM=0
SET APCHM=$ORDER(APCHSTAT("OUTSIDE MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM))
IF APCHM'=+APCHM!($DATA(APCHSQIT))
QUIT
SET APCHZ=APCHSTAT("OUTSIDE MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)
DO MEDDSPO
End DoDot:3
End DoDot:2
End DoDot:1
+8 ;now display nva
+9 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHSTAT("NVA",APCHN))
IF APCHN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+10 SET APCHDI=""
FOR
SET APCHDI=$ORDER(APCHSTAT("NVA",APCHN,APCHDI))
IF APCHDI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+11 SET APCHDT=0
SET APCHDT=$ORDER(APCHSTAT("NVA",APCHN,APCHDI,APCHDT))
IF APCHDT'=+APCHDT!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+12 SET APCHZ=APCHSTAT("NVA",APCHN,APCHDI,APCHDT)
DO MEDDSPN
End DoDot:3
End DoDot:2
End DoDot:1
HOLD ;HOLD MEDICATIONS
+1 IF '$DATA(APCHSTAT("HOLD MEDICATIONS"))
GOTO SUSPEND
+2 SET APCHT=3
+3 WRITE "--------------------",!
+4 WRITE "ACTIVE NOT DISPENSED MEDICATIONS",!
+5 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHSTAT("HOLD MEDICATIONS",APCHN))
IF APCHN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+6 SET APCHDI=""
FOR
SET APCHDI=$ORDER(APCHSTAT("HOLD MEDICATIONS",APCHN,APCHDI))
IF APCHDI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+7 SET APCHDT=0
FOR
SET APCHDT=$ORDER(APCHSTAT("HOLD MEDICATIONS",APCHN,APCHDI,APCHDT))
IF APCHDT'=+APCHDT!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+8 SET APCHM=0
FOR
SET APCHM=$ORDER(APCHSTAT("HOLD MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM))
IF APCHM'=+APCHM!($DATA(APCHSQIT))
QUIT
SET APCHZ=APCHSTAT("HOLD MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
SUSPEND ;
+1 IF '$DATA(APCHSTAT("SUSPEND MEDICATIONS"))
GOTO PENDING
+2 SET APCHT=4
+3 WRITE !,"--------------------",!
+4 WRITE "SUSPENDED MEDICATIONS",!
+5 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHSTAT("SUSPEND MEDICATIONS",APCHN))
IF APCHN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+6 SET APCHDI=""
FOR
SET APCHDI=$ORDER(APCHSTAT("SUSPEND MEDICATIONS",APCHN,APCHDI))
IF APCHDI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+7 SET APCHDT=0
FOR
SET APCHDT=$ORDER(APCHSTAT("SUSPEND MEDICATIONS",APCHN,APCHDI,APCHDT))
IF APCHDT'=+APCHDT!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+8 SET APCHM=0
FOR
SET APCHM=$ORDER(APCHSTAT("SUSPEND MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM))
IF APCHM'=+APCHM!($DATA(APCHSQIT))
QUIT
SET APCHZ=APCHSTAT("SUSPEND MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
PENDING ;
+1 IF '$DATA(APCHSTAT("PENDING"))
GOTO EXPIRED
+2 WRITE "--------------------",!
+3 WRITE "PENDING MEDICATIONS",!
+4 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHSTAT("PENDING",APCHN))
IF APCHN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+5 SET APCHDI=""
FOR
SET APCHDI=$ORDER(APCHSTAT("PENDING",APCHN,APCHDI))
IF APCHDI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+6 SET APCHZ=APCHSTAT("PENDING",APCHN,APCHDI)
DO MEDDSPP
End DoDot:2
End DoDot:1
EXPIRED ;
+1 IF '$DATA(APCHSTAT("EXPIRED MEDICATIONS"))
GOTO DISCONT
+2 SET APCHT=6
+3 WRITE "--------------------",!
+4 WRITE "CHRONIC AND RECENTLY EXPIRED MEDICATIONS",!
+5 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHSTAT("EXPIRED MEDICATIONS",APCHN))
IF APCHN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+6 SET APCHDI=""
FOR
SET APCHDI=$ORDER(APCHSTAT("EXPIRED MEDICATIONS",APCHN,APCHDI))
IF APCHDI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+7 SET APCHDT=0
FOR
SET APCHDT=$ORDER(APCHSTAT("EXPIRED MEDICATIONS",APCHN,APCHDI,APCHDT))
IF APCHDT'=+APCHDT!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+8 SET APCHM=0
FOR
SET APCHM=$ORDER(APCHSTAT("EXPIRED MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM))
IF APCHM'=+APCHM!($DATA(APCHSQIT))
QUIT
SET APCHZ=APCHSTAT("EXPIRED MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
DISCONT ;
+1 IF '$DATA(APCHSTAT("DISCONTINUED MEDICATIONS"))
GOTO MEDX
+2 SET APCHT=7
+3 WRITE "--------------------",!
+4 WRITE "RECENTLY DISCONTINUED MEDICATIONS",!
+5 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHSTAT("DISCONTINUED MEDICATIONS",APCHN))
IF APCHN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+6 SET APCHDI=""
FOR
SET APCHDI=$ORDER(APCHSTAT("DISCONTINUED MEDICATIONS",APCHN,APCHDI))
IF APCHDI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+7 SET APCHDT=0
FOR
SET APCHDT=$ORDER(APCHSTAT("DISCONTINUED MEDICATIONS",APCHN,APCHDI,APCHDT))
IF APCHDT'=+APCHDT!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+8 SET APCHM=0
FOR
SET APCHM=$ORDER(APCHSTAT("DISCONTINUED MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM))
IF APCHM'=+APCHM!($DATA(APCHSQIT))
QUIT
SET APCHZ=APCHSTAT("DISCONTINUED MEDICATIONS",APCHN,APCHDI,APCHDT,APCHM)
DO MEDDSP
End DoDot:3
End DoDot:2
End DoDot:1
MEDX ;
+1 QUIT
MEDDSPP ;DISPLAY MEDICATION
+1 SET APCHCNT=APCHCNT+1
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 WRITE APCHCNT,".",?6,APCHN
IF $PIECE(APCHZ,U,2)
WRITE ?60,"Refills: ",$SELECT('$PIECE(APCHZ,U,1):"NONE",1:$PIECE(APCHZ,U,1))
WRITE !
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+5 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(APCHZ,U,2)
SET DIWL=0
SET DIWR=60
DO ^DIWP
+6 WRITE ?6,"Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" "),!
+7 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
IF $DATA(APCHSQIT)
QUIT
Begin DoDot:1
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
End DoDot:1
+10 KILL ^UTILITY($JOB,"W")
+11 QUIT
MEDDSPO ;DISPLAY MEDICATION
+1 SET APCHSN=^AUPNVMED(APCHM,0)
+2 SET APCHCNT=APCHCNT+1
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 WRITE APCHCNT,".",?6,APCHN
IF $PIECE(APCHZ,U,2)
WRITE ?60,"Refills left: ",$SELECT('$PIECE(APCHZ,U,2):"NONE",1:$PIECE(APCHZ,U,2))
WRITE !
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 SET APCHSIG=$PIECE(^AUPNVMED(APCHM,0),U,5)
DO SIG
+7 SET X=APCHSSGY
+8 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=60
DO ^DIWP
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 WRITE ?6,"Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" "),!
+11 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
IF $DATA(APCHSQIT)
QUIT
Begin DoDot:1
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
End DoDot:1
+14 KILL ^UTILITY($JOB,"W")
+15 QUIT
MEDDSPN ;
+1 SET APCHCNT=APCHCNT+1
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 ;W:$P(APCHZ,U,2) ?60,"Refills left: ",$S('$P(APCHZ,U,2):"NONE",1:$P(APCHZ,U,2)) W !
WRITE APCHCNT,".",?6,APCHN,!
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+5 SET APCHSIG=$PIECE(APCHZ,U,8)
DO SIG
+6 SET X=APCHSSGY
+7 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=60
DO ^DIWP
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE ?6,"Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" "),!
+10 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
IF $DATA(APCHSQIT)
QUIT
Begin DoDot:1
+11 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+12 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
End DoDot:1
+13 IF $PIECE(APCHZ,U,9)
WRITE !?19,"DATE DISCONTINUED: ",$$FMTE^XLFDT($PIECE(APCHZ,U,9))
+14 KILL ^UTILITY($JOB,"W")
+15 QUIT
MEDDSP ;DISPLAY MEDICATION
+1 SET APCHSN=^AUPNVMED(APCHM,0)
+2 SET APCHCNT=APCHCNT+1
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 WRITE APCHCNT,".",?6,APCHN,?40,"Rx #:",$PIECE(APCHZ,U,1),?60,"Refills left: ",$SELECT('$PIECE(APCHZ,U,2):"NONE",1:$PIECE(APCHZ,U,2)),!
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 SET APCHSIG=$PIECE(^AUPNVMED(APCHM,0),U,5)
DO SIG
+7 SET X=APCHSSGY
+8 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=60
DO ^DIWP
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 WRITE ?6,"Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" "),!
+11 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
IF $DATA(APCHSQIT)
QUIT
Begin DoDot:1
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
End DoDot:1
+14 KILL ^UTILITY($JOB,"W")
+15 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+16 IF APCHT=1!(APCHT=6)
WRITE ?6,"Last Filled: ",$$D(9999999-APCHDT)
Begin DoDot:1
+17 SET APCHSORT=""
IF APCHT=1
SET APCHSORT=$PIECE($GET(^AUPNVMED(APCHM,11)),U)
+18 IF APCHSORT["RETURNED TO STOCK"
WRITE " ---",APCHSORT," ",$$FMTE^XLFDT($PIECE(^AUPNVMED(APCHM,0),U,8),"2D")
End DoDot:1
+19 IF APCHT=6
IF $PIECE(APCHZ,U,1)
SET E=$PIECE($GET(^PSRX($PIECE(APCHZ,U,1),3)),U,6)
WRITE ?30,"Expired: ",$$D(E)
+20 WRITE !
+21 IF APCHT=3
WRITE ?6,"Hold Reason: "
IF $PIECE(APCHZ,U,1)
WRITE $PIECE($GET(^PSRX($PIECE(APCHZ,U,1),"H")),U,1)
+22 IF APCHT=7
WRITE ?6,"Discontinued: "
Begin DoDot:1
+23 ;discontinued date in v med
SET E=$PIECE(^AUPNVMED(APCHM,0),U,8)
+24 ;canceled date in 52
IF E=""
IF $PIECE(APCHZ,U,1)
SET E=$PIECE($GET(^PSRX($PIECE(APCHZ,U,1),3)),U,5)
+25 WRITE $$D(E),!
End DoDot:1
+26 QUIT
D(D) ;
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"-"_$EXTRACT(D,6,7)_"-"_$EXTRACT(D,2,3)
+3 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 SET APCHSSGY=""
FOR APCHSP=1:1:$LENGTH(APCHSIG," ")
SET X=$PIECE(APCHSIG," ",APCHSP)
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(APCHSIG," ",APCHSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+3 SET APCHSSGY=APCHSSGY_X_" "
End DoDot:1
+4 QUIT
+5 ;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
+1 IF 'APCHSRX
SET APCHSREF=$PIECE($GET(^AUPNVMED(M,11)),U,7)
IF APCHSREF=""
SET APCHSREF=0
QUIT
+2 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
+3 SET APCHSREF=APCHSRFL
+4 QUIT
+5 ;
+6 ;
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(^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 ;
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
