APCHS71 ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,5**;MAY 14, 2009
;
;
MEDS ;EP - called from component - <SETUP>
;Q:'$D(^AUPNVMED("AC",APCHSPAT))
X APCHSCKP Q:$D(APCHSQIT) I 'APCHSNPG W ! X APCHSBRK
; <BUILD>
S Z="",Y=$S(+$P(^APCHSCTL(APCHSTYP,1,APCHSEGT,0),U,4):$P(^APCHSCTL(APCHSTYP,1,APCHSEGT,0),U,4),1:"")
I Y?1N.N!(Y?1N.N1"D") S Y=+Y
I Y?1N.N1"M" S Y=+Y*30
I Y?1N.N1"Y" S Y=Y*365
D GETMEDS(APCHSPAT,Y,Z,$$VALI^XBDIQ1(9001015,APCHSTYP,3.5))
D DISPLAY
;hold meds
D HOLDDSP^APCHS7
Q:$D(APCHSQIT)
;now display MED refusals
S APCHST="MEDICATION",APCHSFN=50 D DISPREF^APCHS3C
D MEDRU^APCHS7
K APCHST,APCHSFN
MEDX ;
K ^TMP($J,"APCHSAOM"),^TMP($J,"APCHSBCM"),^TMP("APCHSMEDS",$J)
K APCHSX
K X1,X2,X,Y
Q
;
DISPLAY ;
I $D(^TMP("APCHSMEDS",$J,"C")) W ?4,"LAST OF EACH CHRONIC MEDICATION (no limit on days)",?57,"Last fill date",!! D
.S APCHSX=0 F S APCHSX=$O(^TMP("APCHSMEDS",$J,"C",APCHSX)) Q:APCHSX'=+APCHSX!($D(APCHSQIT)) X APCHSCKP Q:$D(APCHSQIT) W ^TMP("APCHSMEDS",$J,"C",APCHSX),!
I $D(^TMP("APCHSMEDS",$J,"A")) W !?4,"LAST OF EACH OTHER MEDICATION "_APCHSEGL_"",?57,"Last fill date",!! D
.S APCHSX=0 F S APCHSX=$O(^TMP("APCHSMEDS",$J,"A",APCHSX)) Q:APCHSX'=+APCHSX!($D(APCHSQIT)) X APCHSCKP Q:$D(APCHSQIT) W ^TMP("APCHSMEDS",$J,"A",APCHSX),!
Q
GETMEDS(DFN,Y,Z,SIGT) ;PEP - return array of meds for patient P
;optionally Y is defined as the max # of days back the acute meds
;to be included
;optionally Z is the max # of days of chronic meds to be included
;the array will contain all chronic meds (listed first and ordered
;by NDC class
;and then all acute meds listed in NDC class order
;the array is ^TMP("APCHSMEDS",$J,"C" - chronic
;and ^TMP("APCHSMEDS",$J,"A" - other (non-chronic)
NEW A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,%
K ^TMP($J,"APCHSAOM"),^TMP($J,"APCHSBCM"),^TMP("APCHSMEDS",$J)
I '$G(DFN) Q
I '$D(^DPT(DFN)) Q ;not a valid patient
I '$G(Y) S Y=""
I '$G(Z) S Z=""
;store dates
I Y S Y="-"_Y S Y=9999999-$$FMADD^XLFDT(DT,Y)
E S Y=9999999
I Z S Z="-"_Z S Z=9999999-$$FMADD^XLFDT(DT,Z)
E S Z=9999999
;gather up all chronic meds ever, store last of each 1
NEW I
S I=0 F S I=$O(^AUPNVMED("AA",DFN,I)) Q:I=""!(I>Z) D
.NEW X S X=0 F S X=$O(^AUPNVMED("AA",DFN,I,X)) Q:X'=+X D
..Q:'$D(^AUPNVMED(X,0))
..;Q:$P($G(^AUPNVMED(X,11)),U,8)]""
..I $D(^TMP($J,"APCHSBCM",$P(^AUPNVMED(X,0),U))) Q
..Q:'$$CHRONIC(X) ;not marked as chronic in prescription file
..S ^TMP($J,"APCHSBCM",$P(^AUPNVMED(X,0),U))=X
..Q
.Q
OTH ;gather up all others by date range in components, get last of each
NEW I S I=0 F S I=$O(^AUPNVMED("AA",DFN,I)) Q:I=""!(I>Y) D
.S X=0 F S X=$O(^AUPNVMED("AA",DFN,I,X)) Q:X="" D
..Q:'$D(^AUPNVMED(X,0))
..;Q:$P($G(^AUPNVMED(X,11)),U,8)]""
..I $D(^TMP($J,"APCHSAOM",$P(^AUPNVMED(X,0),U))) Q
..Q:$$CHRONIC(X)
..S ^TMP($J,"APCHSAOM",$P(^AUPNVMED(X,0),U))=X
..Q
.Q
;NOW MERGE IN NON VA MEDS FROM PS(55
NONVA ; S DFN=APCHSPAT,PSOACT=1 D ^PSOHCSUM
;quit if chronic
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
.;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:L>APCHSDLM
.S D=$P(^PS(55,APCHSPAT,"NVA",X,0),U,2) ;DRUG
.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)) ;NAME
.S ^TMP($J,"APCHSAOM",$S(D:D,1:N))=U_$P(^PS(55,APCHSPAT,"NVA",X,0),U,6)_U_N_U_$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)_U_(9999999-L)_U_$S(D:$P(^PSDRUG(D,0),U,1),1:N)
REORDER ;
;reorder by NDC or by name
NEW I,N,O,S,M S (C,I)=0 F S I=$O(^TMP($J,"APCHSBCM",I)) Q:I'=+I S C=C+1,N=$$VAL^XBDIQ1(50,I,25),O="ZZZ-"_$$VAL^XBDIQ1(50,I,.01) S S=$S(N]"":N,1:O),M(S,C)=^TMP($J,"APCHSBCM",I)
NEW I,N,O,S,A S (C,I)=0 F S I=$O(^TMP($J,"APCHSAOM",I)) Q:I="" S C=C+1,N=$S(I:$$VAL^XBDIQ1(50,I,25),1:""),O="ZZZ-"_$S(I:$$VAL^XBDIQ1(50,I,.01),1:I) S S=$S(N]"":N,1:O),A(S,C)=^TMP($J,"APCHSAOM",I)
NEW APCHSX,APCHSC,I,N S APCHSX=0,I="C" F S APCHSX=$O(M(APCHSX)) Q:APCHSX="" S APCHSC=0 F S APCHSC=$O(M(APCHSX,APCHSC)) Q:APCHSC'=+APCHSC S N=M(APCHSX,APCHSC) D SETARRAY
NEW APCHSX,APCHSC,I,N S APCHSX=0,I="A" F S APCHSX=$O(A(APCHSX)) Q:APCHSX="" S APCHSC=0 F S APCHSC=$O(A(APCHSX,APCHSC)) Q:APCHSC'=+APCHSC S N=A(APCHSX,APCHSC) D SETARRAY
K ^TMP("APCHSMEDS",$J,"C",0),^TMP("APCHSMEDS",$J,"A",0)
K ^TMP($J,"APCHSBCM"),^TMP($J,"APCHSAOM")
Q
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
SETARRAY ;DISPLAY MEDICATION
I 'N D SETNVA Q
S %=^AUPNVMED(N,0)
;d = external value of date, t=internal value of date
S V=$P(%,U,3) I V S T=$P($P(^AUPNVSIT(V,0),U),"."),D=$$FMTE^XLFDT(T,"2D")
I 'V S (D,T)="<???>"
S E=$P(%,U,8),Q=$P(%,U,6),G=$P(%,U,5)
S K=$S($P(N,U,4)="":$P(^PSDRUG(+%,0),U,1),1:$P(N,U,4))
S B="" I E S B="-- D/C "_$$FMTE^XLFDT(E,"2D")
S APCHORTS=$P($G(^AUPNVMED(N,11)),U)
I APCHORTS["RETURNED TO STOCK",E S B="--RTS "_$$FMTE^XLFDT(E,"2D")
D SIG S G=Z
D SITE ;I S]"" S G=G_" ["_S_"]"
S X="",$E(X,5)=K,$E(X,47)="# "_$S(Q:Q,1:"?"),$E(X,65)=D D S(X)
S X="",$E(X,5)=$S(S]"":"Dispensed at: "_S,1:"")_" ("_B_")" D S(X)
S X=" Sig: "_G D S(X)
Q
SETNVA ;
S D=$P(N,U,6)
I 'D S D="<???>"
S E=$P(N,U,5)
S G=$P(N,U,4)
S K=$P(N,U,7)
S B="" I E S B="-- D/C"_$$FMTE^XLFDT(E,"2D")
D SIG S G=Z
S X="",$E(X,5)=K,$E(X,65)=$$FMTE^XLFDT(D,"2D") D S(X)
S X="",$E(X,5)="Dispensed at: (EHR Outside Medication) ("_B_")" D S(X)
S X=" Sig: "_G D S(X)
Q
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
I $G(SIGT)="S" S Z=G Q
NEW P S Z="" F P=1:1:$L(G," ") S X=$P(G," ",P) 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(G," ",P-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S Z=Z_X_" "
Q
;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
S S=""
I $D(^AUPNVSIT(V,21))#2 S S=$P(^(21),U) Q
Q:$P(^AUPNVSIT(V,0),U,6)=""
I $P(^AUPNVSIT(V,0),U,6)'=DUZ(2) S S=$E($P(^DIC(4,$P(^AUPNVSIT(V,0),U,6),0),U),1,30)
Q
S(Y,F,C,T) ;set up array
NEW X
I '$G(F) S F=0
I '$G(T) S T=0
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
I '$D(^TMP("APCHSMEDS",$J,I,0)) S ^TMP("APCHSMEDS",$J,I,0)=0
S %=$P(^TMP("APCHSMEDS",$J,I,0),U)+1,$P(^TMP("APCHSMEDS",$J,I,0),U)=%
S ^TMP("APCHSMEDS",$J,I,%)=X
Q
APCHS71 ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,5**;MAY 14, 2009
+2 ;
+3 ;
MEDS ;EP - called from component - <SETUP>
+1 ;Q:'$D(^AUPNVMED("AC",APCHSPAT))
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
WRITE !
XECUTE APCHSBRK
+3 ; <BUILD>
+4 SET Z=""
SET Y=$SELECT(+$PIECE(^APCHSCTL(APCHSTYP,1,APCHSEGT,0),U,4):$PIECE(^APCHSCTL(APCHSTYP,1,APCHSEGT,0),U,4),1:"")
+5 IF Y?1N.N!(Y?1N.N1"D")
SET Y=+Y
+6 IF Y?1N.N1"M"
SET Y=+Y*30
+7 IF Y?1N.N1"Y"
SET Y=Y*365
+8 DO GETMEDS(APCHSPAT,Y,Z,$$VALI^XBDIQ1(9001015,APCHSTYP,3.5))
+9 DO DISPLAY
+10 ;hold meds
+11 DO HOLDDSP^APCHS7
+12 IF $DATA(APCHSQIT)
QUIT
+13 ;now display MED refusals
+14 SET APCHST="MEDICATION"
SET APCHSFN=50
DO DISPREF^APCHS3C
+15 DO MEDRU^APCHS7
+16 KILL APCHST,APCHSFN
MEDX ;
+1 KILL ^TMP($JOB,"APCHSAOM"),^TMP($JOB,"APCHSBCM"),^TMP("APCHSMEDS",$JOB)
+2 KILL APCHSX
+3 KILL X1,X2,X,Y
+4 QUIT
+5 ;
DISPLAY ;
+1 IF $DATA(^TMP("APCHSMEDS",$JOB,"C"))
WRITE ?4,"LAST OF EACH CHRONIC MEDICATION (no limit on days)",?57,"Last fill date",!!
Begin DoDot:1
+2 SET APCHSX=0
FOR
SET APCHSX=$ORDER(^TMP("APCHSMEDS",$JOB,"C",APCHSX))
IF APCHSX'=+APCHSX!($DATA(APCHSQIT))
QUIT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE ^TMP("APCHSMEDS",$JOB,"C",APCHSX),!
End DoDot:1
+3 IF $DATA(^TMP("APCHSMEDS",$JOB,"A"))
WRITE !?4,"LAST OF EACH OTHER MEDICATION "_APCHSEGL_"",?57,"Last fill date",!!
Begin DoDot:1
+4 SET APCHSX=0
FOR
SET APCHSX=$ORDER(^TMP("APCHSMEDS",$JOB,"A",APCHSX))
IF APCHSX'=+APCHSX!($DATA(APCHSQIT))
QUIT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE ^TMP("APCHSMEDS",$JOB,"A",APCHSX),!
End DoDot:1
+5 QUIT
GETMEDS(DFN,Y,Z,SIGT) ;PEP - return array of meds for patient P
+1 ;optionally Y is defined as the max # of days back the acute meds
+2 ;to be included
+3 ;optionally Z is the max # of days of chronic meds to be included
+4 ;the array will contain all chronic meds (listed first and ordered
+5 ;by NDC class
+6 ;and then all acute meds listed in NDC class order
+7 ;the array is ^TMP("APCHSMEDS",$J,"C" - chronic
+8 ;and ^TMP("APCHSMEDS",$J,"A" - other (non-chronic)
+9 NEW A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,%
+10 KILL ^TMP($JOB,"APCHSAOM"),^TMP($JOB,"APCHSBCM"),^TMP("APCHSMEDS",$JOB)
+11 IF '$GET(DFN)
QUIT
+12 ;not a valid patient
IF '$DATA(^DPT(DFN))
QUIT
+13 IF '$GET(Y)
SET Y=""
+14 IF '$GET(Z)
SET Z=""
+15 ;store dates
+16 IF Y
SET Y="-"_Y
SET Y=9999999-$$FMADD^XLFDT(DT,Y)
+17 IF '$TEST
SET Y=9999999
+18 IF Z
SET Z="-"_Z
SET Z=9999999-$$FMADD^XLFDT(DT,Z)
+19 IF '$TEST
SET Z=9999999
+20 ;gather up all chronic meds ever, store last of each 1
+21 NEW I
+22 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",DFN,I))
IF I=""!(I>Z)
QUIT
Begin DoDot:1
+23 NEW X
SET X=0
FOR
SET X=$ORDER(^AUPNVMED("AA",DFN,I,X))
IF X'=+X
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVMED(X,0))
QUIT
+25 ;Q:$P($G(^AUPNVMED(X,11)),U,8)]""
+26 IF $DATA(^TMP($JOB,"APCHSBCM",$PIECE(^AUPNVMED(X,0),U)))
QUIT
+27 ;not marked as chronic in prescription file
IF '$$CHRONIC(X)
QUIT
+28 SET ^TMP($JOB,"APCHSBCM",$PIECE(^AUPNVMED(X,0),U))=X
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
OTH ;gather up all others by date range in components, get last of each
+1 NEW I
SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",DFN,I))
IF I=""!(I>Y)
QUIT
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(^AUPNVMED("AA",DFN,I,X))
IF X=""
QUIT
Begin DoDot:2
+3 IF '$DATA(^AUPNVMED(X,0))
QUIT
+4 ;Q:$P($G(^AUPNVMED(X,11)),U,8)]""
+5 IF $DATA(^TMP($JOB,"APCHSAOM",$PIECE(^AUPNVMED(X,0),U)))
QUIT
+6 IF $$CHRONIC(X)
QUIT
+7 SET ^TMP($JOB,"APCHSAOM",$PIECE(^AUPNVMED(X,0),U))=X
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 ;NOW MERGE IN NON VA MEDS FROM PS(55
NONVA ; S DFN=APCHSPAT,PSOACT=1 D ^PSOHCSUM
+1 ;quit if chronic
+2 SET X=0
FOR
SET X=$ORDER(^PS(55,APCHSPAT,"NVA",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 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
+4 ;S L=$P(^PS(55,APCHSPAT,"NVA",X,0),U,9)
+5 ;:'L
+6 SET L=$PIECE($PIECE($GET(^PS(55,APCHSPAT,"NVA",X,0)),U,10),".")
+7 SET L=9999999-L
+8 IF L>APCHSDLM
QUIT
+9 ;DRUG
SET D=$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,2)
+10 IF D=""
SET D="NO DRUG IEN"
+11 ;NAME
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 ^TMP($JOB,"APCHSAOM",$SELECT(D:D,1:N))=U_$PIECE(^PS(55,APCHSPAT,"NVA",X,0),U,6)_U_N_U_$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)_U_(9999999-L)_U_$SELECT(D:$PIECE(^PSDRUG(D,0),U,1),1:N)
End DoDot:1
REORDER ;
+1 ;reorder by NDC or by name
+2 NEW I,N,O,S,M
SET (C,I)=0
FOR
SET I=$ORDER(^TMP($JOB,"APCHSBCM",I))
IF I'=+I
QUIT
SET C=C+1
SET N=$$VAL^XBDIQ1(50,I,25)
SET O="ZZZ-"_$$VAL^XBDIQ1(50,I,.01)
SET S=$SELECT(N]"":N,1:O)
SET M(S,C)=^TMP($JOB,"APCHSBCM",I)
+3 NEW I,N,O,S,A
SET (C,I)=0
FOR
SET I=$ORDER(^TMP($JOB,"APCHSAOM",I))
IF I=""
QUIT
SET C=C+1
SET N=$SELECT(I:$$VAL^XBDIQ1(50,I,25),1:"")
SET O="ZZZ-"_$SELECT(I:$$VAL^XBDIQ1(50,I,.01),1:I)
SET S=$SELECT(N]"":N,1:O)
SET A(S,C)=^TMP($JOB,"APCHSAOM",I)
+4 NEW APCHSX,APCHSC,I,N
SET APCHSX=0
SET I="C"
FOR
SET APCHSX=$ORDER(M(APCHSX))
IF APCHSX=""
QUIT
SET APCHSC=0
FOR
SET APCHSC=$ORDER(M(APCHSX,APCHSC))
IF APCHSC'=+APCHSC
QUIT
SET N=M(APCHSX,APCHSC)
DO SETARRAY
+5 NEW APCHSX,APCHSC,I,N
SET APCHSX=0
SET I="A"
FOR
SET APCHSX=$ORDER(A(APCHSX))
IF APCHSX=""
QUIT
SET APCHSC=0
FOR
SET APCHSC=$ORDER(A(APCHSX,APCHSC))
IF APCHSC'=+APCHSC
QUIT
SET N=A(APCHSX,APCHSC)
DO SETARRAY
+6 KILL ^TMP("APCHSMEDS",$JOB,"C",0),^TMP("APCHSMEDS",$JOB,"A",0)
+7 KILL ^TMP($JOB,"APCHSBCM"),^TMP($JOB,"APCHSAOM")
+8 QUIT
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
SETARRAY ;DISPLAY MEDICATION
+1 IF 'N
DO SETNVA
QUIT
+2 SET %=^AUPNVMED(N,0)
+3 ;d = external value of date, t=internal value of date
+4 SET V=$PIECE(%,U,3)
IF V
SET T=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=$$FMTE^XLFDT(T,"2D")
+5 IF 'V
SET (D,T)="<???>"
+6 SET E=$PIECE(%,U,8)
SET Q=$PIECE(%,U,6)
SET G=$PIECE(%,U,5)
+7 SET K=$SELECT($PIECE(N,U,4)="":$PIECE(^PSDRUG(+%,0),U,1),1:$PIECE(N,U,4))
+8 SET B=""
IF E
SET B="-- D/C "_$$FMTE^XLFDT(E,"2D")
+9 SET APCHORTS=$PIECE($GET(^AUPNVMED(N,11)),U)
+10 IF APCHORTS["RETURNED TO STOCK"
IF E
SET B="--RTS "_$$FMTE^XLFDT(E,"2D")
+11 DO SIG
SET G=Z
+12 ;I S]"" S G=G_" ["_S_"]"
DO SITE
+13 SET X=""
SET $EXTRACT(X,5)=K
SET $EXTRACT(X,47)="# "_$SELECT(Q:Q,1:"?")
SET $EXTRACT(X,65)=D
DO S(X)
+14 SET X=""
SET $EXTRACT(X,5)=$SELECT(S]"":"Dispensed at: "_S,1:"")_" ("_B_")"
DO S(X)
+15 SET X=" Sig: "_G
DO S(X)
+16 QUIT
SETNVA ;
+1 SET D=$PIECE(N,U,6)
+2 IF 'D
SET D="<???>"
+3 SET E=$PIECE(N,U,5)
+4 SET G=$PIECE(N,U,4)
+5 SET K=$PIECE(N,U,7)
+6 SET B=""
IF E
SET B="-- D/C"_$$FMTE^XLFDT(E,"2D")
+7 DO SIG
SET G=Z
+8 SET X=""
SET $EXTRACT(X,5)=K
SET $EXTRACT(X,65)=$$FMTE^XLFDT(D,"2D")
DO S(X)
+9 SET X=""
SET $EXTRACT(X,5)="Dispensed at: (EHR Outside Medication) ("_B_")"
DO S(X)
+10 SET X=" Sig: "_G
DO S(X)
+11 QUIT
+12 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 IF $GET(SIGT)="S"
SET Z=G
QUIT
+2 NEW P
SET Z=""
FOR P=1:1:$LENGTH(G," ")
SET X=$PIECE(G," ",P)
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(G," ",P-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+4 SET Z=Z_X_" "
End DoDot:1
+5 QUIT
+6 ;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
+1 SET S=""
+2 IF $DATA(^AUPNVSIT(V,21))#2
SET S=$PIECE(^(21),U)
QUIT
+3 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+4 IF $PIECE(^AUPNVSIT(V,0),U,6)'=DUZ(2)
SET S=$EXTRACT($PIECE(^DIC(4,$PIECE(^AUPNVSIT(V,0),U,6),0),U),1,30)
+5 QUIT
S(Y,F,C,T) ;set up array
+1 NEW X
+2 IF '$GET(F)
SET F=0
+3 IF '$GET(T)
SET T=0
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+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
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 IF '$DATA(^TMP("APCHSMEDS",$JOB,I,0))
SET ^TMP("APCHSMEDS",$JOB,I,0)=0
+2 SET %=$PIECE(^TMP("APCHSMEDS",$JOB,I,0),U)+1
SET $PIECE(^TMP("APCHSMEDS",$JOB,I,0),U)=%
+3 SET ^TMP("APCHSMEDS",$JOB,I,%)=X
+4 QUIT
