BHSAPRO ;IHS/CIA/MGH - Health Summary for Medication Profile ;17-Mar-2006 10:36;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
;===================================================================
;VA Health summary format of IHS health summary component action profiles
;Taken from AZOPCS7
;IHS/OHPRD/VJM - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 01/23/98 9:01 AM ]
;;1.9;PCC HEALTH SUMMARY;*2*;APR 18, 1995
;
; IHS/OHPRD/LAB changed this routine to accomodate 4 medication
; summary types 11-15-94 patch 2
;
MEDSCURR ; ************** CURRENT MEDICATIONS * 9000010.14 ********
S BHSMTY="CURR" G CONT
MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
S BHSMTY="ALL" G CONT
MEDSCHRN ; ************* CHRONIC MEDCICATIONS ************
S BHSMTY="CHRONIC" G CONT
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
S BHSMTY="NODUP" G CONT
;
CONT ; <SETUP>
N BHSPAT,BHSQ
S BHSPAT=DFN
I GMTSDLM=9999999 S X1=DT,X2=-365 D C^%DTC S GMTSDLM=9999999-X K X1,X2
Q:'$D(^AUPNVMED("AC",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT) I 'GMTSNPG W ! D CKP^GMTSUP
; <BUILD>
K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP")
S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^AUPNVMED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) S BHSMX=0 F BHSQ=0:0 S BHSMX=$O(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMX)) Q:BHSMX="" D MEDBLD
; <DISPLAY>
S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHSMTP",BHSIVD)) Q:'BHSIVD D MEDDSP
; <CLEANUP>
MEDX K BHSIVD,BHSMX,BHSMFX,BHSQTY,BHSIG,BHSSGY,BHSEXP,BHSMTS,BHSMED,BHSDTM,BHSDAT,BHSDYS,BHSN,BHSDC,BHSVDF,BHSP
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSRX,BHSDRG,BHSCRN,BHSREF,BHSRFL,BHSALL,BHSTXT,BHSMTY,BHSNARC
K ^TMP($J,"BHSMTB"),^TMP($J,"BHSMTP")
K X1,X2,X,Y
K BHSRTN ;IHS/OKCAO/POC 12/19/97
Q
MEDBLD ;
;
;BUILD ARRAY OF MEDICATIONS
;BHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
;VDF=VISIT FILE DATE
S BHSN=^AUPNVMED(BHSMX,0)
Q:'$D(^PSDRUG($P(BHSN,U,1)))
S BHSDTM=-BHSIVD\1+9999999
S BHSDC=$P(BHSN,U,8),BHSDYS=$P(BHSN,U,7),BHSMFX=$S($P(BHSN,U,4)="":+BHSN,1:$P(BHSN,U,4)) ;XXXXXXXX
S:BHSDYS="" BHSDYS=30
;SCREENS OUT MEDS NOT CURRENT; BHSALL FORCES INCLUSION OF ALL MED
D @BHSMTY
Q
;
CURR ; current meds only
I $D(^TMP($J,"BHSMTB",BHSMFX)),^TMP($J,"BHSMTB",BHSMFX)="" Q
S X1=DT,X2=BHSDTM D ^%DTC Q:X>60&(X>(2*BHSDYS))
S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
Q
ALL ;all meds included
S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
;
Q
NODUP ;
I $D(^TMP($J,"BHSMTB",BHSMFX)) Q
S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
Q
CHRONIC ;chronic meds only
I $D(^TMP($J,"BHSMTB",BHSMFX)) Q
S X=$S($D(^PSRX("APCC",BHSMX)):$O(^(BHSMX,0)),1:0)
S Y=$S(+X:$D(^PS(55,BHSPAT,"P","CP",X)),1:0)
Q:'Y
S ^TMP($J,"BHSMTB",BHSMFX)=BHSDC,^TMP($J,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
Q
MEDDSP ;
;
;DISPLAY MEDICATION
;BHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
S BHSMX=^TMP($J,"BHSMTP",BHSIVD)
S BHSN=^AUPNVMED(BHSMX,0)
S BHSRX=$S($D(^PSRX("APCC",BHSMX)):$O(^(BHSMX,0)),1:0)
S BHSCRN=$S(+BHSRX:$D(^PS(55,BHSPAT,"P","CP",BHSRX)),1:0)
S (X,BHSDTM)=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDC=$P(BHSN,U,8),BHSDYS=$P(BHSN,U,7),BHSQTY=$P(BHSN,U,6),BHSIG=$P(BHSN,U,5),BHSVDF=$P(BHSN,U,3),BHSMFX=+BHSN
S:BHSDYS="" BHSDYS=30
S X1=DT,X2=BHSDTM D ^%DTC ;Q:X>60&(X>(2*BHSDYS))
S BHSEXP=""
I X>BHSDYS S X1=BHSDTM,X2=BHSDYS D C^%DTC D REGDT4^GMTSU S BHSEXP="-- Ran out "_X
S BHSMED=$S($P(BHSN,U,4)="":$P(^PSDRUG(BHSMFX,0),U,1),1:$P(BHSN,U,4)) ;MODIFIED FOR PHAR 6.0 IHS/OKCAO/POC 6/13/97
;MORE LOCAL CHANCES IHS/OKCAO/POC 10/28/96
S BHSNARC=$P(^PSDRUG(BHSMFX,0),U,3),BHSNARC=+BHSNARC
K BHSNARF I +BHSNARC=2 S BHSNARF=1 ;FOR JUST SCH 2 DRUGS
;END POC
;ADDED RETURNED TO STOCK FLAG FOR NEXT 4 LINES IHS/OKCAO/POC 12/19/97
IF $P($G(^AUPNVMED(BHSMX,11)),U)="RETURNED TO STOCK" S BHSRTN="R"
I BHSDC,$G(BHSRTN)="R" S X=BHSDC D REGDT4^GMTSU S BHSEXP="--RETN STOCK "_X
I BHSDC,$G(BHSRTN)="" S X=BHSDC D REGDT4^GMTSU S BHSEXP="-- D/C "_X
K BHSRTN
;END OF CHANGES
D SIG S BHSIG=BHSSGY
D REF I BHSREF S BHSIG=BHSIG_" "_BHSREF_$S(BHSREF=1:" refill",1:" refills")_" left."
D SITE I BHSITE]"" S BHSIG=BHSIG_" ["_BHSITE_"]"
D CKP^GMTSUP Q:$D(GMTSQIT)
;Q:$D(BHSNARF) ;POC QUIT IF NARCOTIC UNCOMMENT IF DO NOT WANT TO SEE NARCS
;S X="IOINHI;IOINLOW" D ENDR^%ZISS W !,BHSDAT,?10 W:BHSMTY'="CHRONIC" $S(BHSCRN:"(C)",1:"") W ?12,IOINHI,BHSMED," #",BHSQTY,IOINLOW," (",BHSDYS," days) ",BHSEXP,! ;POC DELETE CHRONIC SIGN CHANGE SPACING BOLD DRUGAND SIG
W !,BHSDAT
W ?10 W:BHSMTY'="CHRONIC" $S(BHSCRN:"(C)",1:"")
;S X="IOINHI" D ENDR^%ZISS W IOINHI
W ?12,BHSMED," #",BHSQTY
;S X="IOINLOW" D ENDR^%ZISS W IOINLOW
W " (",BHSDYS," days) ",BHSEXP,!
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSICL=14,BHSNRQ="",BHSTXT=BHSIG D PRTTXT^BHSUTL K BHSICL,BHSNRQ,BHSP
;WRITE LOCAL CHANGES IHS/OKCAO/POC 10/29/96
I $D(BHSNARF) W ?10," ------ MUST REWRITE THIS CONTROLLED DRUG----",!
E W ?14,"PROVIDER INITIALS: ______________________________ DATE_________",!
E W ?14,"REFILL 1______2______3______4______5______NR______DC______",!
;END POC
Q
;
SIG ;
;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
;I $$VALI^XBDIQ1(9001015,GMTSTYP,3.5)="S" S BHSSGY=BHSIG Q
S BHSSGY="" F BHSP=1:1:$L(BHSIG," ") S X=$P(BHSIG," ",BHSP) 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(BHSIG," ",BHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S BHSSGY=BHSSGY_X_" "
Q
;
REF ;
;DETERMINE THE NUMBER OF REFILLS REMAINING
I 'BHSRX S BHSREF=0 Q
S BHSRFL=$P(^PSRX(BHSRX,0),U,9) S BHSREF=0 F S BHSREF=$O(^PSRX(BHSRX,1,BHSREF)) Q:'BHSREF S BHSRFL=BHSRFL-1
S BHSREF=BHSRFL
Q
;
SITE ;
;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
S BHSITE=""
I $D(^AUPNVSIT(BHSVDF,21))#2 S BHSITE=$P(^(21),U)
Q
BHSAPRO ;IHS/CIA/MGH - Health Summary for Medication Profile ;17-Mar-2006 10:36;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
+2 ;===================================================================
+3 ;VA Health summary format of IHS health summary component action profiles
+4 ;Taken from AZOPCS7
+5 ;IHS/OHPRD/VJM - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 01/23/98 9:01 AM ]
+6 ;;1.9;PCC HEALTH SUMMARY;*2*;APR 18, 1995
+7 ;
+8 ; IHS/OHPRD/LAB changed this routine to accomodate 4 medication
+9 ; summary types 11-15-94 patch 2
+10 ;
MEDSCURR ; ************** CURRENT MEDICATIONS * 9000010.14 ********
+1 SET BHSMTY="CURR"
GOTO CONT
MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
+1 SET BHSMTY="ALL"
GOTO CONT
MEDSCHRN ; ************* CHRONIC MEDCICATIONS ************
+1 SET BHSMTY="CHRONIC"
GOTO CONT
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
+1 SET BHSMTY="NODUP"
GOTO CONT
+2 ;
CONT ; <SETUP>
+1 NEW BHSPAT,BHSQ
+2 SET BHSPAT=DFN
+3 IF GMTSDLM=9999999
SET X1=DT
SET X2=-365
DO C^%DTC
SET GMTSDLM=9999999-X
KILL X1,X2
+4 IF '$DATA(^AUPNVMED("AC",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF 'GMTSNPG
WRITE !
DO CKP^GMTSUP
+6 ; <BUILD>
+7 KILL ^TMP($JOB,"BHSMTB"),^TMP($JOB,"BHSMTP")
+8 SET BHSIVD=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVMED("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
SET BHSMX=0
FOR BHSQ=0:0
SET BHSMX=$ORDER(^AUPNVMED("AA",BHSPAT,BHSIVD,BHSMX))
IF BHSMX=""
QUIT
DO MEDBLD
+9 ; <DISPLAY>
+10 SET BHSIVD=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^TMP($JOB,"BHSMTP",BHSIVD))
IF 'BHSIVD
QUIT
DO MEDDSP
+11 ; <CLEANUP>
MEDX KILL BHSIVD,BHSMX,BHSMFX,BHSQTY,BHSIG,BHSSGY,BHSEXP,BHSMTS,BHSMED,BHSDTM,BHSDAT,BHSDYS,BHSN,BHSDC,BHSVDF,BHSP
+1 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSRX,BHSDRG,BHSCRN,BHSREF,BHSRFL,BHSALL,BHSTXT,BHSMTY,BHSNARC
+2 KILL ^TMP($JOB,"BHSMTB"),^TMP($JOB,"BHSMTP")
+3 KILL X1,X2,X,Y
+4 ;IHS/OKCAO/POC 12/19/97
KILL BHSRTN
+5 QUIT
MEDBLD ;
+1 ;
+2 ;BUILD ARRAY OF MEDICATIONS
+3 ;BHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
+4 ;VDF=VISIT FILE DATE
+5 SET BHSN=^AUPNVMED(BHSMX,0)
+6 IF '$DATA(^PSDRUG($PIECE(BHSN,U,1)))
QUIT
+7 SET BHSDTM=-BHSIVD\1+9999999
+8 ;XXXXXXXX
SET BHSDC=$PIECE(BHSN,U,8)
SET BHSDYS=$PIECE(BHSN,U,7)
SET BHSMFX=$SELECT($PIECE(BHSN,U,4)="":+BHSN,1:$PIECE(BHSN,U,4))
+9 IF BHSDYS=""
SET BHSDYS=30
+10 ;SCREENS OUT MEDS NOT CURRENT; BHSALL FORCES INCLUSION OF ALL MED
+11 DO @BHSMTY
+12 QUIT
+13 ;
CURR ; current meds only
+1 IF $DATA(^TMP($JOB,"BHSMTB",BHSMFX))
IF ^TMP($JOB,"BHSMTB",BHSMFX)=""
QUIT
+2 SET X1=DT
SET X2=BHSDTM
DO ^%DTC
IF X>60&(X>(2*BHSDYS))
QUIT
+3 SET ^TMP($JOB,"BHSMTB",BHSMFX)=BHSDC
SET ^TMP($JOB,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
+4 QUIT
ALL ;all meds included
+1 SET ^TMP($JOB,"BHSMTB",BHSMFX)=BHSDC
SET ^TMP($JOB,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
+2 ;
+3 QUIT
NODUP ;
+1 IF $DATA(^TMP($JOB,"BHSMTB",BHSMFX))
QUIT
+2 SET ^TMP($JOB,"BHSMTB",BHSMFX)=BHSDC
SET ^TMP($JOB,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
+3 QUIT
CHRONIC ;chronic meds only
+1 IF $DATA(^TMP($JOB,"BHSMTB",BHSMFX))
QUIT
+2 SET X=$SELECT($DATA(^PSRX("APCC",BHSMX)):$ORDER(^(BHSMX,0)),1:0)
+3 SET Y=$SELECT(+X:$DATA(^PS(55,BHSPAT,"P","CP",X)),1:0)
+4 IF 'Y
QUIT
+5 SET ^TMP($JOB,"BHSMTB",BHSMFX)=BHSDC
SET ^TMP($JOB,"BHSMTP",BHSIVD_"-"_BHSMFX)=BHSMX
+6 QUIT
MEDDSP ;
+1 ;
+2 ;DISPLAY MEDICATION
+3 ;BHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
+4 SET BHSMX=^TMP($JOB,"BHSMTP",BHSIVD)
+5 SET BHSN=^AUPNVMED(BHSMX,0)
+6 SET BHSRX=$SELECT($DATA(^PSRX("APCC",BHSMX)):$ORDER(^(BHSMX,0)),1:0)
+7 SET BHSCRN=$SELECT(+BHSRX:$DATA(^PS(55,BHSPAT,"P","CP",BHSRX)),1:0)
+8 SET (X,BHSDTM)=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+9 SET BHSDC=$PIECE(BHSN,U,8)
SET BHSDYS=$PIECE(BHSN,U,7)
SET BHSQTY=$PIECE(BHSN,U,6)
SET BHSIG=$PIECE(BHSN,U,5)
SET BHSVDF=$PIECE(BHSN,U,3)
SET BHSMFX=+BHSN
+10 IF BHSDYS=""
SET BHSDYS=30
+11 ;Q:X>60&(X>(2*BHSDYS))
SET X1=DT
SET X2=BHSDTM
DO ^%DTC
+12 SET BHSEXP=""
+13 IF X>BHSDYS
SET X1=BHSDTM
SET X2=BHSDYS
DO C^%DTC
DO REGDT4^GMTSU
SET BHSEXP="-- Ran out "_X
+14 ;MODIFIED FOR PHAR 6.0 IHS/OKCAO/POC 6/13/97
SET BHSMED=$SELECT($PIECE(BHSN,U,4)="":$PIECE(^PSDRUG(BHSMFX,0),U,1),1:$PIECE(BHSN,U,4))
+15 ;MORE LOCAL CHANCES IHS/OKCAO/POC 10/28/96
+16 SET BHSNARC=$PIECE(^PSDRUG(BHSMFX,0),U,3)
SET BHSNARC=+BHSNARC
+17 ;FOR JUST SCH 2 DRUGS
KILL BHSNARF
IF +BHSNARC=2
SET BHSNARF=1
+18 ;END POC
+19 ;ADDED RETURNED TO STOCK FLAG FOR NEXT 4 LINES IHS/OKCAO/POC 12/19/97
+20 IF $PIECE($GET(^AUPNVMED(BHSMX,11)),U)="RETURNED TO STOCK"
SET BHSRTN="R"
+21 IF BHSDC
IF $GET(BHSRTN)="R"
SET X=BHSDC
DO REGDT4^GMTSU
SET BHSEXP="--RETN STOCK "_X
+22 IF BHSDC
IF $GET(BHSRTN)=""
SET X=BHSDC
DO REGDT4^GMTSU
SET BHSEXP="-- D/C "_X
+23 KILL BHSRTN
+24 ;END OF CHANGES
+25 DO SIG
SET BHSIG=BHSSGY
+26 DO REF
IF BHSREF
SET BHSIG=BHSIG_" "_BHSREF_$SELECT(BHSREF=1:" refill",1:" refills")_" left."
+27 DO SITE
IF BHSITE]""
SET BHSIG=BHSIG_" ["_BHSITE_"]"
+28 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+29 ;Q:$D(BHSNARF) ;POC QUIT IF NARCOTIC UNCOMMENT IF DO NOT WANT TO SEE NARCS
+30 ;S X="IOINHI;IOINLOW" D ENDR^%ZISS W !,BHSDAT,?10 W:BHSMTY'="CHRONIC" $S(BHSCRN:"(C)",1:"") W ?12,IOINHI,BHSMED," #",BHSQTY,IOINLOW," (",BHSDYS," days) ",BHSEXP,! ;POC DELETE CHRONIC SIGN CHANGE SPACING BOLD DRUGAND SIG
+31 WRITE !,BHSDAT
+32 WRITE ?10
IF BHSMTY'="CHRONIC"
WRITE $SELECT(BHSCRN:"(C)",1:"")
+33 ;S X="IOINHI" D ENDR^%ZISS W IOINHI
+34 WRITE ?12,BHSMED," #",BHSQTY
+35 ;S X="IOINLOW" D ENDR^%ZISS W IOINLOW
+36 WRITE " (",BHSDYS," days) ",BHSEXP,!
+37 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+38 SET BHSICL=14
SET BHSNRQ=""
SET BHSTXT=BHSIG
DO PRTTXT^BHSUTL
KILL BHSICL,BHSNRQ,BHSP
+39 ;WRITE LOCAL CHANGES IHS/OKCAO/POC 10/29/96
+40 IF $DATA(BHSNARF)
WRITE ?10," ------ MUST REWRITE THIS CONTROLLED DRUG----",!
+41 IF '$TEST
WRITE ?14,"PROVIDER INITIALS: ______________________________ DATE_________",!
+42 IF '$TEST
WRITE ?14,"REFILL 1______2______3______4______5______NR______DC______",!
+43 ;END POC
+44 QUIT
+45 ;
SIG ;
+1 ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+2 ;I $$VALI^XBDIQ1(9001015,GMTSTYP,3.5)="S" S BHSSGY=BHSIG Q
+3 SET BHSSGY=""
FOR BHSP=1:1:$LENGTH(BHSIG," ")
SET X=$PIECE(BHSIG," ",BHSP)
IF X]""
Begin DoDot:1
+4 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(BHSIG," ",BHSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+5 SET BHSSGY=BHSSGY_X_" "
End DoDot:1
+6 QUIT
+7 ;
REF ;
+1 ;DETERMINE THE NUMBER OF REFILLS REMAINING
+2 IF 'BHSRX
SET BHSREF=0
QUIT
+3 SET BHSRFL=$PIECE(^PSRX(BHSRX,0),U,9)
SET BHSREF=0
FOR
SET BHSREF=$ORDER(^PSRX(BHSRX,1,BHSREF))
IF 'BHSREF
QUIT
SET BHSRFL=BHSRFL-1
+4 SET BHSREF=BHSRFL
+5 QUIT
+6 ;
SITE ;
+1 ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
+2 SET BHSITE=""
+3 IF $DATA(^AUPNVSIT(BHSVDF,21))#2
SET BHSITE=$PIECE(^(21),U)
+4 QUIT
