AMHLEMD ; IHS/CMI/LAB - PART 7 OF AMHS -- SUMMARY PRODUCTION COMPONENTS ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;
GETMEDS(DFN,Y,Z,SIGT) ;EP - return array of meds for patient P
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,"AMHSAOM"),^TMP("AMHSMEDS",$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=9999999-Y
E S Y=9999999
I Z S Z=9999999-Z
E S Z=9999999
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
..I $D(^TMP($J,"AMHSAOM",$P(^AUPNVMED(X,0),U))) Q
..S ^TMP($J,"AMHSAOM",$P(^AUPNVMED(X,0),U))=X
..S ^TMP($J,"AMHSAOM","DATE ORDER",I,$P(^AUPNVMED(X,0),U))=X
..Q
.Q
REORDER ;
;reorder by NDC or by name
;NEW I,N,O,S,A S (C,I)=0 F S I=$O(^TMP($J,"AMHSAOM",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),A(S,C)=^TMP($J,"AMHSAOM",I)
;NEW AMHSX,AMHSC,I,N S AMHSX=0,I="A" F S AMHSX=$O(A(AMHSX)) Q:AMHSX="" S AMHSC=0 F S AMHSC=$O(A(AMHSX,AMHSC)) Q:AMHSC'=+AMHSC S N=A(AMHSX,AMHSC) D SETARRAY
NEW AMHSC,AMHSX,I,N S I="A" S AMHSX=0 F S AMHSX=$O(^TMP($J,"AMHSAOM","DATE ORDER",AMHSX)) Q:AMHSX="" D
.S AMHSC=0 F S AMHSC=$O(^TMP($J,"AMHSAOM","DATE ORDER",AMHSX,AMHSC)) Q:AMHSC="" S N=^TMP($J,"AMHSAOM","DATE ORDER",AMHSX,AMHSC) D SETARRAY
K ^TMP("AMHSMEDS",$J,"A",0)
K ^TMP($J,"AMHSAOM")
Q
SETARRAY ;DISPLAY MEDICATION
S %=^AUPNVMED(N,0)
I +%,'$D(^PSDRUG(+%,0)) Q ;drug deleted
;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))
I E S E="-- D/C "_$$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,40)="# "_$S(Q:Q,1:"?"),$E(X,58)=D 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($P(%,U,3),21))#2 S S=$P(^(21),U)
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("AMHSMEDS",$J,I,0)) S ^TMP("AMHSMEDS",$J,I,0)=0
S %=$P(^TMP("AMHSMEDS",$J,I,0),U)+1,$P(^TMP("AMHSMEDS",$J,I,0),U)=%
S ^TMP("AMHSMEDS",$J,I,%)=X
Q
AMHLEMD ; IHS/CMI/LAB - PART 7 OF AMHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;
GETMEDS(DFN,Y,Z,SIGT) ;EP - return array of meds for patient P
+1 NEW A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,%
+2 KILL ^TMP($JOB,"AMHSAOM"),^TMP("AMHSMEDS",$JOB)
+3 IF '$GET(DFN)
QUIT
+4 ;not a valid patient
IF '$DATA(^DPT(DFN))
QUIT
+5 IF '$GET(Y)
SET Y=""
+6 IF '$GET(Z)
SET Z=""
+7 ;store dates
+8 IF Y
SET Y=9999999-Y
+9 IF '$TEST
SET Y=9999999
+10 IF Z
SET Z=9999999-Z
+11 IF '$TEST
SET Z=9999999
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(^TMP($JOB,"AMHSAOM",$PIECE(^AUPNVMED(X,0),U)))
QUIT
+4 SET ^TMP($JOB,"AMHSAOM",$PIECE(^AUPNVMED(X,0),U))=X
+5 SET ^TMP($JOB,"AMHSAOM","DATE ORDER",I,$PIECE(^AUPNVMED(X,0),U))=X
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
REORDER ;
+1 ;reorder by NDC or by name
+2 ;NEW I,N,O,S,A S (C,I)=0 F S I=$O(^TMP($J,"AMHSAOM",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),A(S,C)=^TMP($J,"AMHSAOM",I)
+3 ;NEW AMHSX,AMHSC,I,N S AMHSX=0,I="A" F S AMHSX=$O(A(AMHSX)) Q:AMHSX="" S AMHSC=0 F S AMHSC=$O(A(AMHSX,AMHSC)) Q:AMHSC'=+AMHSC S N=A(AMHSX,AMHSC) D SETARRAY
+4 NEW AMHSC,AMHSX,I,N
SET I="A"
SET AMHSX=0
FOR
SET AMHSX=$ORDER(^TMP($JOB,"AMHSAOM","DATE ORDER",AMHSX))
IF AMHSX=""
QUIT
Begin DoDot:1
+5 SET AMHSC=0
FOR
SET AMHSC=$ORDER(^TMP($JOB,"AMHSAOM","DATE ORDER",AMHSX,AMHSC))
IF AMHSC=""
QUIT
SET N=^TMP($JOB,"AMHSAOM","DATE ORDER",AMHSX,AMHSC)
DO SETARRAY
End DoDot:1
+6 KILL ^TMP("AMHSMEDS",$JOB,"A",0)
+7 KILL ^TMP($JOB,"AMHSAOM")
+8 QUIT
SETARRAY ;DISPLAY MEDICATION
+1 SET %=^AUPNVMED(N,0)
+2 ;drug deleted
IF +%
IF '$DATA(^PSDRUG(+%,0))
QUIT
+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 IF E
SET E="-- D/C "_$$FMTE^XLFDT(E,"2D")
+9 DO SIG
SET G=Z
+10 DO SITE
IF S]""
SET G=G_" ["_S_"]"
+11 SET X=""
SET $EXTRACT(X,5)=K
SET $EXTRACT(X,40)="# "_$SELECT(Q:Q,1:"?")
SET $EXTRACT(X,58)=D
DO S(X)
+12 SET X=" Sig: "_G
DO S(X)
+13 QUIT
+14 ;
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($PIECE(%,U,3),21))#2
SET S=$PIECE(^(21),U)
+3 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("AMHSMEDS",$JOB,I,0))
SET ^TMP("AMHSMEDS",$JOB,I,0)=0
+2 SET %=$PIECE(^TMP("AMHSMEDS",$JOB,I,0),U)+1
SET $PIECE(^TMP("AMHSMEDS",$JOB,I,0),U)=%
+3 SET ^TMP("AMHSMEDS",$JOB,I,%)=X
+4 QUIT
