APCHS72.m

APCHS72 ; 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))

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

 ..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) ;EP

 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),T=$P(%,U,7)_" days"

 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=$$LOW^XLFSTR(Z)

 D SITE ;I S]"" S G=G_"  ["_S_"]"

 S X="",$E(X,2)=K,X=X_" "_G_" "_" # "_$S(Q:Q,1:"?")_"  "_T_" "_D_" "_B D S(X)

 I S]"" S X="",$E(X,5)="Dispensed at: "_S D S(X)

 Q

SETNVA ;

 S D=$P(N,U,6)

 I 'D S D="<???>"

 I D S D=$$FMTE^XLFDT(D,"2D")

 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=$$LOW^XLFSTR(Z)

 S X="",$E(X,2)=K,X=X_" "_G_" "_D_" "_B D S(X)

 S X="",$E(X,5)="Dispensed at: (EHR Outside Medication)" 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

APCHS72   ; 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                       IF $DATA(^TMP($JOB,"APCHSBCM",$PIECE(^AUPNVMED(X,0),U)))

                               QUIT 

 +26      ;not marked as chronic in prescription file

                           IF '$$CHRONIC(X)

                               QUIT 

 +27                       SET ^TMP($JOB,"APCHSBCM",$PIECE(^AUPNVMED(X,0),U))=X

 +28                       QUIT 

                       End DoDot:2

 +29               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                        IF $DATA(^TMP($JOB,"APCHSAOM",$PIECE(^AUPNVMED(X,0),U)))

                               QUIT 

 +5                        IF $$CHRONIC(X)

                               QUIT 

 +6                        SET ^TMP($JOB,"APCHSAOM",$PIECE(^AUPNVMED(X,0),U))=X

 +7                        QUIT 

                       End DoDot:2

 +8                QUIT 

               End DoDot:1

 +9       ;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) ;EP

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

           SET T=$PIECE(%,U,7)_" days"

 +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=$$LOW^XLFSTR(Z)

 +12      ;I S]"" S G=G_"  ["_S_"]"

           DO SITE

 +13       SET X=""

           SET $EXTRACT(X,2)=K

           SET X=X_" "_G_" "_" # "_$SELECT(Q:Q,1:"?")_"  "_T_" "_D_" "_B

           DO S(X)

 +14       IF S]""

               SET X=""

               SET $EXTRACT(X,5)="Dispensed at: "_S

               DO S(X)

 +15       QUIT 

SETNVA    ;

 +1        SET D=$PIECE(N,U,6)

 +2        IF 'D

               SET D="<???>"

 +3        IF D

               SET D=$$FMTE^XLFDT(D,"2D")

 +4        SET E=$PIECE(N,U,5)

 +5        SET G=$PIECE(N,U,4)

 +6        SET K=$PIECE(N,U,7)

 +7        SET B=""

           IF E

               SET B="-- D/C"_$$FMTE^XLFDT(E,"2D")

 +8        DO SIG

           SET G=$$LOW^XLFSTR(Z)

 +9        SET X=""

           SET $EXTRACT(X,2)=K

           SET X=X_" "_G_" "_D_" "_B

           DO S(X)

 +10       SET X=""

           SET $EXTRACT(X,5)="Dispensed at: (EHR Outside Medication)"

           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