Routine: AMHLEMD

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")

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)

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_" "

SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT

 S S=""

 I $D(^AUPNVSIT($P(%,U,3),21))#2 S S=$P(^(21),U)

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

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

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

AMHLEMD.m