BHSPMH1A ;IHS/MSC/MGH - Health Summary for Patient wellness handout ;27-May-2008 14:21;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2**;March 17,2006
;===================================================================
;Taken from APCHPMH1 routine
;
;
MEDBLD ; EP - BUILD ARRAY OF MEDICATIONS
;
K APCHSRXP,APCHSCOT
N APCHSN,APCHSDTM,APCHSSTA,APCHSDYS,RX0,RX2,ST,ST0
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^BHSPMH1 Q:ST="EXPIRED"!(ST="CANCELLED")!(ST="DELETED") ;CALCULATE RX STATUS
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 ;D ^BOMB ;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
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
;
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
BHSPMH1A ;IHS/MSC/MGH - Health Summary for Patient wellness handout ;27-May-2008 14:21;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2**;March 17,2006
+2 ;===================================================================
+3 ;Taken from APCHPMH1 routine
+4 ;
+5 ;
MEDBLD ; EP - BUILD ARRAY OF MEDICATIONS
+1 ;
+2 KILL APCHSRXP,APCHSCOT
+3 NEW APCHSN,APCHSDTM,APCHSSTA,APCHSDYS,RX0,RX2,ST,ST0
+4 IF '$DATA(^AUPNVMED(APCHSMX,0))
QUIT
+5 SET APCHSN=^AUPNVMED(APCHSMX,0)
+6 IF '$DATA(^PSDRUG($PIECE(APCHSN,U,1)))
QUIT
+7 ;Visit date from V Med .03 field
SET APCHSDTM=-APCHSIVD\1+9999999
+8 ;date discontinued
IF $PIECE(APCHSN,U,8)]""
QUIT
+9 ;RX IEN
SET APCHSRXP=$SELECT($DATA(^PSRX("APCC",APCHSMX)):$ORDER(^(APCHSMX,0)),1:0)
+10 ;CALCULATE RX STATUS
IF APCHSRXP>0
SET RX0=^PSRX(APCHSRXP,0)
SET RX2=^PSRX(APCHSRXP,2)
IF '$DATA(^PSRX(APCHSRXP,"STA"))
DO RXSTAT^BHSPMH1
IF ST="EXPIRED"!(ST="CANCELLED")!(ST="DELETED")
QUIT
+11 ;may be using COTS or med entered via PCC data entry
IF $GET(APCHSRXP)'>0
SET APCHSCOT=1
+12 ;external key present
IF $PIECE($GET(^AUPNVMED(APCHSMX,12)),U,9)]""
SET APCHSCOT=1
+13 ;Active? RX File status
SET APCHSSTA=$PIECE($GET(^PSRX(APCHSRXP,0)),U,15)
+14 ;status is expired, deleted or cancelled
IF $GET(APCHSSTA)>10
QUIT
+15 ;Status is in "STA" node in V 7
IF $GET(^PSRX(APCHSRXP,"STA"))>10
QUIT
+16 ;NON-VERIFIED
IF $GET(^PSRX(APCHSRXP,"STA"))=1
QUIT
+17 ;DRUG INTERACTION
IF $GET(^PSRX(APCHSRXP,"STA"))=4
QUIT
+18 SET APCHSIG=""
+19 SET APCHSIG=$PIECE($GET(APCHSN),U,5)
+20 ;D ^BOMB ;get expanded sig
DO SIG
+21 ;days supply
SET APCHSDYS=$PIECE($GET(APCHSN),U,7)
+22 ;Q:APCHSDYS=1 ;quit if only 1 day supply
+23 IF $GET(APCHSCOT)=1
IF $GET(APCHSDYS)]""
IF $$FMDIFF^XLFDT(DT,APCHSDTM)>$GET(APCHSDYS)
QUIT
+24 ;quit if qty=1
IF $PIECE($GET(^AUPNVMED(APCHSMX,0)),U,6)=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 ;
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
