APCHPMH3 ; IHS/CMI/LAB - Patient Wellness Handout ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
;
MEDS ;EP - DISPLAY MEDS
;Suppress original text per Chris Lamer 11/29/07 *17*
;S X="Medicines are important - it helps to know" D S(X,1)
;S X="",$E(X,5)="Why you will take it?" D S(X,1) ;*17*
;S X="",$E(X,5)="When to take it?" D S(X)
;S X="",$E(X,5)="How much to take?" D S(X)
;S X="",$E(X,5)="What to do if you forget to take it?" D S(X)
;S X="",$E(X,5)="What could happen if you forget or take too much." D S(X)
;S X="Knowing these things will help the medicine work best for you." D S(X,1) ;*17*
S X="Medications - here is a list of the medicines you are taking:" D S(X,1)
S X="" D S(X)
;
;get all "active" meds
S APCHSDLM=$$FMADD^XLFDT(DT,-365),APCHSDLM=9999999-APCHSDLM
S APCHSIVD=0,APCHSMCT=0 F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVMED("AA",APCHSDFN,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) S APCHSMX=0 F APCHSQ=0:0 S APCHSMX=$O(^AUPNVMED("AA",APCHSDFN,APCHSIVD,APCHSMX)) Q:APCHSMX="" D MEDBLD
I $G(APCHSMCT)=0 S X="",$E(X,5)="No current meds on file" D S(X)
S APCHSMED=""
F S APCHSMED=$O(APCHSM(APCHSMED)) Q:$G(APCHSMED)']"" D
.S X="",$E(X,5)=APCHSMED D S(X)
.K ^UTILITY($J,"W") S APCHSIG=$P($G(APCHSM(APCHSMED)),U,5),X=APCHSIG,DIWL=0,DIWR=58 D ^DIWP
.S X="",$E(X,7)="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:" ") D S(X)
.I $G(^UTILITY($J,"W",0))>1 F I=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,7)=$G(^UTILITY($J,"W",0,I,0)) D S(X)
.K ^UTILITY($J,"W")
.Q
D HOLD
I '$D(APCHHM) Q
S X="Medications ordered, but not yet dispensed" D S(X,1)
S X="" D S(X)
S APCHHMED=""
F S APCHHMED=$O(APCHHM(APCHHMED)) Q:$G(APCHHMED)']"" D
.S X="",$E(X,5)=APCHHMED D S(X)
Q
MEDBLD ;BUILD ARRAY OF MEDICATIONS
;
K APCHSRXP,APCHSCOT
Q:'$D(^AUPNVMED(APCHSMX,0))
S APCHSN=^AUPNVMED(APCHSMX,0)
Q:'$D(^PSDRUG($P(APCHSN,U,1)))
S APCHSDTM=-APCHSIVD\1+9999999 ;Visit date from V Med .03 field
Q:$P(APCHSN,U,8)]"" ;date discontinued
S APCHSRXP=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0) ;RX IEN
I APCHSRXP>0 S RX0=^PSRX(APCHSRXP,0),RX2=^PSRX(APCHSRXP,2) I '$D(^PSRX(APCHSRXP,"STA")) D RXSTAT Q:ST="EXPIRED"!(ST="CANCELLED")!(ST="DELETED") ;CALCULATE RX STATUS IF V6
I $G(APCHSRXP)'>0 S APCHSCOT=1 ;may be using COTS or med entered via PCC data entry
I $P($G(^AUPNVMED(APCHSMX,12)),U,9)]"" S APCHSCOT=1 ;external key present
S APCHSSTA=$P($G(^PSRX(APCHSRXP,0)),U,15) ;Active? RX File status
Q:$G(APCHSSTA)>10 ;status is expired, deleted or cancelled
I $G(^PSRX(APCHSRXP,"STA"))>10 Q ;Status is in "STA" node in V 7
I $G(^PSRX(APCHSRXP,"STA"))=1 Q ;NON-VERIFIED
I $G(^PSRX(APCHSRXP,"STA"))=4 Q ;DRUG INTERACTION
S APCHSIG=""
S APCHSIG=$P($G(APCHSN),U,5)
D SIG ;get expanded sig
S APCHSDYS=$P($G(APCHSN),U,7) ;days supply
;Q:APCHSDYS=1 ;quit if only 1 day supply
I $G(APCHSCOT)=1,$G(APCHSDYS)]"",$$FMDIFF^XLFDT(DT,APCHSDTM)>$G(APCHSDYS) Q
;Q:$P($G(^AUPNVMED(APCHSMX,0)),U,6)=1 ;quit if qty=1
I $P($G(^AUPNVMED(APCHSMX,0)),U,6)=1,APCHSDYS=1 Q ;quit if qty=1 AND days supply=1 **17**
S APCHSMFX=$P(^PSDRUG(+APCHSN,0),U) D ;compare Drug File .01 field & V Med Name of Non Table Drug
.Q:$P(APCHSN,U,4)=""
.I $P($G(APCHSN),U,4)]"",$P($G(APCHSN),U,4)=$P(^PSDRUG(+APCHSN,0),U) Q
.I $P($G(APCHSN),U,4)]"",$P($G(APCHSN),U,4)'=$P(^PSDRUG(+APCHSN,0),U) S APCHSMFX=$P(APCHSN,U,4)
.Q
I $G(APCHSM(APCHSMFX)) Q ;quit if med already exists
S APCHSM(APCHSMFX)=+APCHSN_U_APCHSDYS ;PSDRUG ien^days supply
I $G(APCHSRXP)>0 S $P(APCHSM(APCHSMFX),U,3)=APCHSRXP ;^PSRX ien
S $P(APCHSM(APCHSMFX),U,4)=$G(ST) ;status from RXSTAT
S $P(APCHSM(APCHSMFX),U,5)=$G(APCHSSGY)
S APCHSMCT=APCHSMCT+1 ;number of active meds
Q
;
RXSTAT ;gets status of rx ... TAKEN FROM PSOFUNC ROUTINE
Q:$D(^PSRX(APCHSRXP,"STA")) ;USING V7
Q:$G(APCHSRXP)'>0
S J=APCHSRXP
S ST0=+$P(RX0,"^",15) I ST0<12,$O(^PS(52.5,"B",J,0)),$D(^PS(52.5,+$O(^(0)),0)),'$G(^("P")) S ST0=5
I ST0<12,$P(RX2,"^",6),$P(RX2,"^",6)'>DT S ST0=11
S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^PENDING DUE TO DRUG INTERACTION^SUSPENDED^^^^^DONE^EXPIRED^CANCELLED^DELETED","^",ST0+2),$P(RX0,"^",15)=ST0
Q
;S ST0=+$P(RX0,"^",15) I ST0<12,$O(^PS(52.5,"B",J,0)),$D(^PS(52.5,+$O(^(0)),0)),'$G(^("P")) S ST0=5
;I ST0<12,$P(RX2,"^",6)<DT S ST0=11
;S ST=$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST0+2),$P(RX0,"^",15)=ST0
;Q
HOLD ;Now get meds in Pharmacy yet to be completed
Q:'APCHSDFN
S APCHSDT=DT
F S APCHSDT=$O(^PS(55,APCHSDFN,"P","A",APCHSDT)) Q:APCHSDT'=+APCHSDT D
.S APCHNMED=0 F S APCHNMED=$O(^PS(55,APCHSDFN,"P","A",APCHSDT,APCHNMED)) Q:'APCHNMED D
..I $G(^PSRX(APCHNMED,"STA"))=3!($G(^PSRX(APCHNMED,"STA"))=5) D
...S APCHHMED=$P(^PSRX(APCHNMED,0),U,6) I $G(APCHHMED)]"" S APCHHMED=$P(^PSDRUG(APCHHMED,0),U)
...S APCHHM(APCHHMED)=APCHNMED
..Q
Q
;
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
;
;
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X
;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 ;
S %=$P(^TMP("APCHPHS",$J,"PMH",0),U)+1,$P(^TMP("APCHPHS",$J,"PMH",0),U)=%
S ^TMP("APCHPHS",$J,"PMH",%)=X
Q
DATE(D) ;EP - convert to slashed date
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
;
CLOSE ;EP - Write closing statement per Chris Lamer 11/29/07 *17*
;
S X="* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *" D S(X,1)
S X="",$E(X,5)="This handout is yours to keep and contains information that is in your" D S(X)
S X="",$E(X,5)="medical record (your chart). You can keep this handout for your records" D S(X)
S X="",$E(X,5)="or share the information with other health care workers. Please let us" D S(X)
S X="",$E(X,5)="know if anything is wrong or missing from your handout - we want to be" D S(X)
S X="",$E(X,5)="sure it is correct." D S(X)
S X="",$E(X,5)="Thank you and have a healthy day!" D S(X,1)
Q
APCHPMH3 ; IHS/CMI/LAB - Patient Wellness Handout ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
+4 ;
MEDS ;EP - DISPLAY MEDS
+1 ;Suppress original text per Chris Lamer 11/29/07 *17*
+2 ;S X="Medicines are important - it helps to know" D S(X,1)
+3 ;S X="",$E(X,5)="Why you will take it?" D S(X,1) ;*17*
+4 ;S X="",$E(X,5)="When to take it?" D S(X)
+5 ;S X="",$E(X,5)="How much to take?" D S(X)
+6 ;S X="",$E(X,5)="What to do if you forget to take it?" D S(X)
+7 ;S X="",$E(X,5)="What could happen if you forget or take too much." D S(X)
+8 ;S X="Knowing these things will help the medicine work best for you." D S(X,1) ;*17*
+9 SET X="Medications - here is a list of the medicines you are taking:"
DO S(X,1)
+10 SET X=""
DO S(X)
+11 ;
+12 ;get all "active" meds
+13 SET APCHSDLM=$$FMADD^XLFDT(DT,-365)
SET APCHSDLM=9999999-APCHSDLM
+14 SET APCHSIVD=0
SET APCHSMCT=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVMED("AA",APCHSDFN,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
SET APCHSMX=0
FOR APCHSQ=0:0
SET APCHSMX=$ORDER(^AUPNVMED("AA",APCHSDFN,APCHSIVD,APCHSMX))
IF APCHSMX=""
QUIT
DO MEDBLD
+15 IF $GET(APCHSMCT)=0
SET X=""
SET $EXTRACT(X,5)="No current meds on file"
DO S(X)
+16 SET APCHSMED=""
+17 FOR
SET APCHSMED=$ORDER(APCHSM(APCHSMED))
IF $GET(APCHSMED)']""
QUIT
Begin DoDot:1
+18 SET X=""
SET $EXTRACT(X,5)=APCHSMED
DO S(X)
+19 KILL ^UTILITY($JOB,"W")
SET APCHSIG=$PIECE($GET(APCHSM(APCHSMED)),U,5)
SET X=APCHSIG
SET DIWL=0
SET DIWR=58
DO ^DIWP
+20 SET X=""
SET $EXTRACT(X,7)="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:" ")
DO S(X)
+21 IF $GET(^UTILITY($JOB,"W",0))>1
FOR I=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,7)=$GET(^UTILITY($JOB,"W",0,I,0))
DO S(X)
+22 KILL ^UTILITY($JOB,"W")
+23 QUIT
End DoDot:1
+24 DO HOLD
+25 IF '$DATA(APCHHM)
QUIT
+26 SET X="Medications ordered, but not yet dispensed"
DO S(X,1)
+27 SET X=""
DO S(X)
+28 SET APCHHMED=""
+29 FOR
SET APCHHMED=$ORDER(APCHHM(APCHHMED))
IF $GET(APCHHMED)']""
QUIT
Begin DoDot:1
+30 SET X=""
SET $EXTRACT(X,5)=APCHHMED
DO S(X)
End DoDot:1
+31 QUIT
MEDBLD ;BUILD ARRAY OF MEDICATIONS
+1 ;
+2 KILL APCHSRXP,APCHSCOT
+3 IF '$DATA(^AUPNVMED(APCHSMX,0))
QUIT
+4 SET APCHSN=^AUPNVMED(APCHSMX,0)
+5 IF '$DATA(^PSDRUG($PIECE(APCHSN,U,1)))
QUIT
+6 ;Visit date from V Med .03 field
SET APCHSDTM=-APCHSIVD\1+9999999
+7 ;date discontinued
IF $PIECE(APCHSN,U,8)]""
QUIT
+8 ;RX IEN
SET APCHSRXP=$SELECT($DATA(^PSRX("APCC",APCHSMX)):$ORDER(^(APCHSMX,0)),1:0)
+9 ;CALCULATE RX STATUS IF V6
IF APCHSRXP>0
SET RX0=^PSRX(APCHSRXP,0)
SET RX2=^PSRX(APCHSRXP,2)
IF '$DATA(^PSRX(APCHSRXP,"STA"))
DO RXSTAT
IF ST="EXPIRED"!(ST="CANCELLED")!(ST="DELETED")
QUIT
+10 ;may be using COTS or med entered via PCC data entry
IF $GET(APCHSRXP)'>0
SET APCHSCOT=1
+11 ;external key present
IF $PIECE($GET(^AUPNVMED(APCHSMX,12)),U,9)]""
SET APCHSCOT=1
+12 ;Active? RX File status
SET APCHSSTA=$PIECE($GET(^PSRX(APCHSRXP,0)),U,15)
+13 ;status is expired, deleted or cancelled
IF $GET(APCHSSTA)>10
QUIT
+14 ;Status is in "STA" node in V 7
IF $GET(^PSRX(APCHSRXP,"STA"))>10
QUIT
+15 ;NON-VERIFIED
IF $GET(^PSRX(APCHSRXP,"STA"))=1
QUIT
+16 ;DRUG INTERACTION
IF $GET(^PSRX(APCHSRXP,"STA"))=4
QUIT
+17 SET APCHSIG=""
+18 SET APCHSIG=$PIECE($GET(APCHSN),U,5)
+19 ;get expanded sig
DO SIG
+20 ;days supply
SET APCHSDYS=$PIECE($GET(APCHSN),U,7)
+21 ;Q:APCHSDYS=1 ;quit if only 1 day supply
+22 IF $GET(APCHSCOT)=1
IF $GET(APCHSDYS)]""
IF $$FMDIFF^XLFDT(DT,APCHSDTM)>$GET(APCHSDYS)
QUIT
+23 ;Q:$P($G(^AUPNVMED(APCHSMX,0)),U,6)=1 ;quit if qty=1
+24 ;quit if qty=1 AND days supply=1 **17**
IF $PIECE($GET(^AUPNVMED(APCHSMX,0)),U,6)=1
IF APCHSDYS=1
QUIT
+25 ;compare Drug File .01 field & V Med Name of Non Table Drug
SET APCHSMFX=$PIECE(^PSDRUG(+APCHSN,0),U)
Begin DoDot:1
+26 IF $PIECE(APCHSN,U,4)=""
QUIT
+27 IF $PIECE($GET(APCHSN),U,4)]""
IF $PIECE($GET(APCHSN),U,4)=$PIECE(^PSDRUG(+APCHSN,0),U)
QUIT
+28 IF $PIECE($GET(APCHSN),U,4)]""
IF $PIECE($GET(APCHSN),U,4)'=$PIECE(^PSDRUG(+APCHSN,0),U)
SET APCHSMFX=$PIECE(APCHSN,U,4)
+29 QUIT
End DoDot:1
+30 ;quit if med already exists
IF $GET(APCHSM(APCHSMFX))
QUIT
+31 ;PSDRUG ien^days supply
SET APCHSM(APCHSMFX)=+APCHSN_U_APCHSDYS
+32 ;^PSRX ien
IF $GET(APCHSRXP)>0
SET $PIECE(APCHSM(APCHSMFX),U,3)=APCHSRXP
+33 ;status from RXSTAT
SET $PIECE(APCHSM(APCHSMFX),U,4)=$GET(ST)
+34 SET $PIECE(APCHSM(APCHSMFX),U,5)=$GET(APCHSSGY)
+35 ;number of active meds
SET APCHSMCT=APCHSMCT+1
+36 QUIT
+37 ;
RXSTAT ;gets status of rx ... TAKEN FROM PSOFUNC ROUTINE
+1 ;USING V7
IF $DATA(^PSRX(APCHSRXP,"STA"))
QUIT
+2 IF $GET(APCHSRXP)'>0
QUIT
+3 SET J=APCHSRXP
+4 SET ST0=+$PIECE(RX0,"^",15)
IF ST0<12
IF $ORDER(^PS(52.5,"B",J,0))
IF $DATA(^PS(52.5,+$ORDER(^(0)),0))
IF '$GET(^("P"))
SET ST0=5
+5 IF ST0<12
IF $PIECE(RX2,"^",6)
IF $PIECE(RX2,"^",6)'>DT
SET ST0=11
+6 SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^PENDING DUE TO DRUG INTERACTION^SUSPENDED^^^^^DONE^EXPIRED^CANCELLED^DELETED","^",ST0+2)
SET $PIECE(RX0,"^",15)=ST0
+7 QUIT
+8 ;S ST0=+$P(RX0,"^",15) I ST0<12,$O(^PS(52.5,"B",J,0)),$D(^PS(52.5,+$O(^(0)),0)),'$G(^("P")) S ST0=5
+9 ;I ST0<12,$P(RX2,"^",6)<DT S ST0=11
+10 ;S ST=$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST0+2),$P(RX0,"^",15)=ST0
+11 ;Q
HOLD ;Now get meds in Pharmacy yet to be completed
+1 IF 'APCHSDFN
QUIT
+2 SET APCHSDT=DT
+3 FOR
SET APCHSDT=$ORDER(^PS(55,APCHSDFN,"P","A",APCHSDT))
IF APCHSDT'=+APCHSDT
QUIT
Begin DoDot:1
+4 SET APCHNMED=0
FOR
SET APCHNMED=$ORDER(^PS(55,APCHSDFN,"P","A",APCHSDT,APCHNMED))
IF 'APCHNMED
QUIT
Begin DoDot:2
+5 IF $GET(^PSRX(APCHNMED,"STA"))=3!($GET(^PSRX(APCHNMED,"STA"))=5)
Begin DoDot:3
+6 SET APCHHMED=$PIECE(^PSRX(APCHNMED,0),U,6)
IF $GET(APCHHMED)]""
SET APCHHMED=$PIECE(^PSDRUG(APCHHMED,0),U)
+7 SET APCHHM(APCHHMED)=APCHNMED
End DoDot:3
+8 QUIT
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
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 ;
+6 ;
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW %,X
+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 SET %=$PIECE(^TMP("APCHPHS",$JOB,"PMH",0),U)+1
SET $PIECE(^TMP("APCHPHS",$JOB,"PMH",0),U)=%
+2 SET ^TMP("APCHPHS",$JOB,"PMH",%)=X
+3 QUIT
DATE(D) ;EP - convert to slashed date
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
+4 ;
CLOSE ;EP - Write closing statement per Chris Lamer 11/29/07 *17*
+1 ;
+2 SET X="* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *"
DO S(X,1)
+3 SET X=""
SET $EXTRACT(X,5)="This handout is yours to keep and contains information that is in your"
DO S(X)
+4 SET X=""
SET $EXTRACT(X,5)="medical record (your chart). You can keep this handout for your records"
DO S(X)
+5 SET X=""
SET $EXTRACT(X,5)="or share the information with other health care workers. Please let us"
DO S(X)
+6 SET X=""
SET $EXTRACT(X,5)="know if anything is wrong or missing from your handout - we want to be"
DO S(X)
+7 SET X=""
SET $EXTRACT(X,5)="sure it is correct."
DO S(X)
+8 SET X=""
SET $EXTRACT(X,5)="Thank you and have a healthy day!"
DO S(X,1)
+9 QUIT
