- BHSMEDR ;IHS/MSC/MGH - Health Summary for MED RECONCILIATION ;01-May-2014 11:12;DU
- ;;1.0;HEALTH SUMMARY COMPONENTS;**4,6,8,9**;March 17, 2006;Build 16
- ;;---------------------------------------------------------------
- ; IHS/CMI/LAB - APCHS7R -- SUMMARY PRODUCTION COMPONENTS ;
- ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
- ;
- ;Patch 6 for non-VA meds
- SET ;
- S BHSRX=P,BHSREF=0 D REF
- S BHSTAT(C,N,D,(9999999-F),M)=$S(P:$P(^PSRX(P,0),U),1:"")_U_BHSREF
- S $P(BHSTAT(C,N,D,(9999999-F),M),U,10)=P
- S BHMDSP(D,N,F)=""
- Q
- MEDRCON ; ************* MEDS BY PRESCRIPTION STATUS *************
- ;
- CONT ; <SETUP>
- N BHSPAT,BHSQ
- S BHSPAT=DFN
- I '$D(^AUPNVMED("AC",BHSPAT)),'$D(^PS(52.41,"P",BHSPAT)) Q
- D CKP^GMTSUP Q:$D(GMTSQIT)
- ; <BUILD>
- NEW BHMEDS,BHSTAT,BHCNT,BHMDSP,BHDI,BHDT,BHM,BHN,BHSSGY,BHSIG,BHZ,BHSN,BHST,BHI,BHD,BHS11
- NEW X,F,M,V,D,N,P,C,E,S,R,J,BHSITE,BHSORT,BHSP,BHSREF,BHSRFL,BHSRX,BHSVDF,BHT,BHSNVA
- S BHCNT=0
- K BHMEDS,BHMDSP
- D GETMEDS^APCHSMU1(BHSPAT,$$FMADD^XLFDT(DT,-395),DT,,,,,.BHMEDS)
- ;I '$D(APCHMEDS) D MEDX Q
- ;NOW REORDER THEM BY STATUS
- K BHSTAT
- S X=0 F S X=$O(BHMEDS(X)) Q:X'=+X D
- .S P=""
- .S F=$P(BHMEDS(X),U,1) ;FILL DATE
- .S M=$P(BHMEDS(X),U,4) ;vmed ien
- .S V=$P(BHMEDS(X),U,5) ;visit ien
- .S D=$P(^AUPNVMED(M,0),U) ;drug ien
- .S N=$P(^AUPNVMED(M,0),U,4) ;non table drug name
- .I N="" S N=$P(^PSDRUG(D,0),U) ;drug name
- .I $P($G(^AUPNVSIT(X,0)),U,7)="E" S C="OUTSIDE MEDICATIONS" D SET Q
- .I $P($G(^AUPNVSIT(X,11)),U,8) S C="OUTSIDE MEDICATIONS" D SET Q
- .S P=$O(^PSRX("APCC",M,0))
- .I 'P S C="OUTSIDE MEDICATIONS" D SET Q
- .I '$D(^PSRX(P,0)) S P="",C="OUTSIDE MEDICATIONS" D SET Q
- .;Patch 8 for autofinished meds
- .I $$VALI^XBDIQ1(52,P,9999999.23)=1 S C="OUTSIDE PHARMACY MEDS" D SET Q
- .S S=$$VALI^XBDIQ1(52,P,100) ;GET STATUS
- .I S=0 S C="ACTIVE MEDICATIONS" D SET Q
- .I S=3 S C="HOLD" D SET Q
- .I S=5 S C="SUSPENDED" D SET Q
- .I S=11 D Q
- ..;get expiration date
- ..S E=$P($G(^PSRX(P,3)),U,6)
- ..S R=$$CHRONIC^APCHS72(M) ;chronic flag
- ..I 'R D Q
- ...;not chronic, check to see if expired in past 14 days, if not quit
- ...S J=$$FMDIFF^XLFDT(DT,E)
- ...Q:J>14 ;more than 14 days ago so don't display
- ...;check to see if same drug is already listed somewhere
- ...Q:$O(BHMDSP(D,N,F)) ;another of same drug after this date
- ...S C="EXPIRED" D SET Q
- ..;chronic = check 120 days
- ..S J=$$FMDIFF^XLFDT(DT,E)
- ..Q:J>120 ;expired more than 120 days ago
- ..Q:$O(BHMDSP(D,N,F)) ;another one there so don't display this one
- ..S C="EXPIRED" D SET Q
- .I S=12!(S=14) D
- ..S E=$P(^AUPNVMED(M,0),U,8) ;discontinued date in v med
- ..I E="" S E=$P($G(^PSRX(P,3)),U,5) ;canceled date in 52
- ..I $$FMDIFF^XLFDT(DT,E)>30 Q ;only discontinueds in past 30 days
- ..Q:$O(BHMDSP(D,N,F))
- ..S C="DISCONTINUED MEDICATIONS" D SET Q
- GETNVA ;NVA from file 55
- N L,D,N,X,DC
- S X=0 F S X=$O(^PS(55,BHSPAT,"NVA",X)) Q:X'=+X D
- .S DC=0
- .I $P($G(^PS(55,BHSPAT,"NVA",X,999999911)),U,1) D Q:DC=1
- ..I $D(^AUPNVMED($P(^PS(55,BHSPAT,"NVA",X,999999911),U,1),0)) D
- ...I $P($G(^PS(55,BHSPAT,"NVA",X,0)),U,6)'="" S DC=1
- .S L=$P($P($G(^PS(55,BHSPAT,"NVA",X,0)),U,10),".")
- .S L=9999999-L
- .S D=$P(^PS(55,BHSPAT,"NVA",X,0),U,2)
- .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,BHSPAT,"NVA",X,0),U,1),0),U,1))
- .S BHSTAT("NVA",N,D,(9999999-L))=U_"N",$P(BHSTAT("NVA",N,D,(9999999-L)),U,8)=$P(^PS(55,BHSPAT,"NVA",X,0),U,4)_" "_$P(^PS(55,BHSPAT,"NVA",X,0),U,5)_U_$P(^PS(55,BHSPAT,"NVA",X,0),U,7)
- .S $P(BHSTAT("NVA",N,D,(9999999-L)),U,10)=X
- GETPEND ;
- NEW PEN,ORD
- F PEN=0:0 S PEN=$O(^PS(52.41,"P",BHSPAT,PEN)) Q:'PEN S ORD=^PS(52.41,PEN,0),BHI=$P(ORD,"^",8),BHD=+$P(ORD,"^",9) D:$P(ORD,"^",3)'="DC"&($P(ORD,"^",3)'="DE")&($P(ORD,"^",3)'="HD")
- .S BHN=$S(BHD:$P($G(^PSDRUG(BHD,0)),"^"),+BHI&('BHD):$P(^PS(50.7,BHI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,BHI,0),"^",2),0),"^"),1:"") Q:BHN']""
- .S BHSTAT("PENDING",BHN,PEN)=$$VAL^XBDIQ1(52.41,PEN,13)
- .S C=0,X="" F S C=$O(^PS(52.41,PEN,"SIG",C)) Q:'C S X=X_$S(X]"":" ",1:"")_^PS(52.41,PEN,"SIG",C,0)
- .S $P(BHSTAT("PENDING",BHN,PEN),U,2)=X
- DISP ;DISPLAY MEDS
- ;ACTIVE MEDS FIRST - ALL OF THEM
- D CKP^GMTSUP Q:$D(GMTSQIT)
- I '$D(BHSTAT("ACTIVE MEDICATIONS")) G OUT
- W "ACTIVE MEDICATIONS",!
- S BHCNT=0
- S BHT=1
- S BHN="" F S BHN=$O(BHSTAT("ACTIVE MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHDT=0 F S BHDT=$O(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
- ...S BHM=0 F S BHM=$O(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
- D CKP^GMTSUP Q:$D(GMTSQIT)
- I '$D(BHSTAT("OUTSIDE PHARMACY MEDS")) G OUT
- W "OUTSIDE PHARMACY MEDS",!
- S BHCNT=0
- S BHT=1
- S BHN="" F S BHN=$O(BHSTAT("OUTSIDE PHARMACY MEDS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHDT=0 F S BHDT=$O(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
- ...S BHM=0 F S BHM=$O(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT,BHM) D MEDDSP
- OUT ;OUTSIDE MEDICATIONS
- I '$D(BHSTAT("OUTSIDE MEDICATIONS"))&('$D(BHSTAT("NVA"))) G HOLD
- W "--------------------",!
- W "OUTSIDE MEDICATIONS",!
- S BHN="" F S BHN=$O(BHSTAT("OUTSIDE MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHDT=0 S BHDT=$O(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
- ...S BHM=0 S BHM=$O(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSPO
- ;now display nva
- S BHN="" F S BHN=$O(BHSTAT("NVA",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("NVA",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHDT=0 S BHDT=$O(BHSTAT("NVA",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
- ...S BHZ=BHSTAT("NVA",BHN,BHDI,BHDT) D MEDDSPN
- HOLD ;HOLD MEDICATIONS
- I '$D(BHSTAT("HOLD MEDICATIONS")) G SUSPEND
- S BHT=3
- W "--------------------",!
- W "ACTIVE NOT DISPENSED MEDICATIONS",!
- S BHN="" F S BHN=$O(BHSTAT("HOLD MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("HOLD MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHDT=0 F S BHDT=$O(BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
- ...S BHM=0 F S BHM=$O(BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
- SUSPEND ;
- I '$D(BHSTAT("SUSPEND MEDICATIONS")) G PENDING
- S BHT=4
- W !,"--------------------",!
- W "SUSPENDED MEDICATIONS",!
- S BHN="" F S BHN=$O(BHSTAT("SUSPEND MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHDT=0 F S BHDT=$O(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
- ...S BHM=0 F S BHM=$O(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
- PENDING ;
- I '$D(BHSTAT("PENDING")) G EXPIRED
- W "--------------------",!
- W "PENDING MEDICATIONS",!
- S BHN="" F S BHN=$O(BHSTAT("PENDING",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("PENDING",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHZ=BHSTAT("PENDING",BHN,BHDI) D MEDDSPP
- EXPIRED ;
- I '$D(BHSTAT("EXPIRED MEDICATIONS")) G DISCONT
- S BHT=6
- W "--------------------",!
- W "CHRONIC AND RECENTLY EXPIRED MEDICATIONS",!
- S BHN="" F S BHN=$O(BHSTAT("EXPIRED MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHDT=0 F S BHDT=$O(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
- ...S BHM=0 F S BHM=$O(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
- DISCONT ;
- I '$D(BHSTAT("DISCONTINUED MEDICATIONS")) G MEDX
- S BHT=7
- W "--------------------",!
- W "RECENTLY DISCONTINUED MEDICATIONS",!
- S BHN="" F S BHN=$O(BHSTAT("DISCONTINUED MEDICATIONS",BHN)) Q:BHN=""!($D(GMTSQIT)) D
- .S BHDI="" F S BHDI=$O(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI)) Q:BHDI=""!($D(GMTSQIT)) D
- ..S BHDT=0 F S BHDT=$O(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT)) Q:BHDT'=+BHDT!($D(GMTSQIT)) D
- ...S BHM=0 F S BHM=$O(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT,BHM)) Q:BHM'=+BHM!($D(GMTSQIT)) S BHZ=BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT,BHM) D MEDDSP
- MEDX ;
- Q
- MEDDSPP ;DISPLAY MEDICATION
- N BHSRX,BHSORD
- S BHCNT=BHCNT+1
- S BHS11=$G(^AUPNVMED(BHZ,11))
- D CKP^GMTSUP Q:$D(GMTSQIT)
- W BHCNT,".",?6,BHN W:$P(BHZ,U,2) ?60,"Refills: ",$S('$P(BHZ,U,1):"NONE",1:$P(BHZ,U,1)) W !
- D CKP^GMTSUP Q:$D(GMTSQIT)
- K ^UTILITY($J,"W") S X=$P(BHZ,U,2),DIWL=0,DIWR=60 D ^DIWP
- W ?6,"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:" "),!
- I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(GMTSQIT) D
- .D CKP^GMTSUP Q:$D(GMTSQIT)
- .W ?19,$G(^UTILITY($J,"W",0,F,0)),!
- K ^UTILITY($J,"W")
- S BHSORD=$$GET1^DIQ(52.41,BHDI,.01,"I")
- I +BHSORD D RECON^BHSMED(BHSORD,"M")
- E D
- .N NVA
- .S NVA=+$P(BHS11,U,8)
- .I NVA'="" D
- ..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
- ..D RECON^BHSMED(BHSORD,"M")
- Q
- MEDDSPO ;DISPLAY MEDICATION
- N BHSRX,BHSORD
- S BHSN=^AUPNVMED(BHM,0)
- S BHCNT=BHCNT+1
- D CKP^GMTSUP Q:$D(GMTSQIT)
- W BHCNT,".",?6,BHN W:$P(BHZ,U,2) ?60,"Refills left: ",$S('$P(BHZ,U,2):"NONE",1:$P(BHZ,U,2)) W !
- D CKP^GMTSUP Q:$D(GMTSQIT)
- S BHSIG=$P(^AUPNVMED(BHM,0),U,5) D SIG
- S X=BHSSGY
- K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
- D CKP^GMTSUP Q:$D(GMTSQIT)
- W ?6,"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:" "),!
- I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(GMTSQIT) D
- .D CKP^GMTSUP Q:$D(GMTSQIT)
- .W ?19,$G(^UTILITY($J,"W",0,F,0)),!
- K ^UTILITY($J,"W")
- S BHSRX=$P(BHZ,U,10)
- S BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
- I +BHSORD D RECON^BHSMED(BHSORD,"M")
- E D
- .N NVA
- .S NVA=BHSRX
- .I NVA'="" D
- ..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
- ..D RECON^BHSMED(BHSORD,"M")
- Q
- MEDDSP ;DISPLAY MEDICATION
- N BHSRX,BHSORD
- S BHSN=^AUPNVMED(BHM,0)
- S BHS11=^AUPNVMED(BHM,11)
- S BHCNT=BHCNT+1
- D CKP^GMTSUP Q:$D(GMTSQIT)
- W BHCNT,".",?6,BHN,?40,"Rx #:",$P(BHZ,U,1),?60,"Refills left: ",$S('$P(BHZ,U,2):"NONE",1:$P(BHZ,U,2)),!
- D CKP^GMTSUP Q:$D(GMTSQIT)
- S BHSIG=$P(^AUPNVMED(BHM,0),U,5) D SIG
- S X=BHSSGY
- K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
- D CKP^GMTSUP Q:$D(GMTSQIT)
- W ?6,"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:" "),!
- I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(GMTSQIT) D
- .D CKP^GMTSUP Q:$D(GMTSQIT)
- .W ?19,$G(^UTILITY($J,"W",0,F,0)),!
- K ^UTILITY($J,"W")
- D CKP^GMTSUP Q:$D(GMTSQIT)
- I BHT=1!(BHT=6) W ?6,"Last Filled: ",$$D(9999999-BHDT) D
- .S BHSORT="" I BHT=1 S BHSORT=$P($G(^AUPNVMED(BHM,11)),U)
- .I BHSORT["RETURNED TO STOCK" W " ---",BHSORT," ",$$FMTE^XLFDT($P(^AUPNVMED(BHM,0),U,8),"2D")
- I BHT=6 I $P(BHZ,U,1) S E=$P($G(^PSRX($P(BHZ,U,1),3)),U,6) W ?30,"Expired: ",$$D(E)
- W !
- I BHT=3 W ?6,"Hold Reason: " I $P(BHZ,U,1) W $P($G(^PSRX($P(BHZ,U,1),"H")),U,1)
- I BHT=7 W ?6,"Discontinued: " D
- .S E=$P(^AUPNVMED(BHM,0),U,8) ;discontinued date in v med
- .I E="",$P(BHZ,U,1) S E=$P($G(^PSRX($P(BHZ,U,1),3)),U,5) ;canceled date in 52
- .W $$D(E),!
- S BHSRX=$P(BHZ,U,10)
- S BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
- I +BHSORD D RECON^BHSMED(BHSORD,"M")
- E D
- .N NVA
- .S NVA=BHSRX
- .I NVA'="" D
- ..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
- ..D RECON^BHSMED(BHSORD,"M")
- Q
- MEDDSPN ;
- S BHCNT=BHCNT+1
- D CKP^GMTSUP Q:$D(GMTSQIT)
- W BHCNT,".",?6,BHN,! ;W:$P(APCHZ,U,2) ?60,"Refills left: ",$S('$P(APCHZ,U,2):"NONE",1:$P(APCHZ,U,2)) W !
- D CKP^GMTSUP Q:$D(GMTSQIT)
- S BHSIG=$P(BHZ,U,8) D SIG
- S X=BHSSGY
- K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
- D CKP^GMTSUP Q:$D(GMTSQIT)
- W ?6,"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:" "),!
- I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) Q:$D(GMTSQIT) D
- .D CKP^GMTSUP Q:$D(GMTSQIT)
- .W ?19,$G(^UTILITY($J,"W",0,F,0)),!
- I $P(BHZ,U,9) W !?19,"DATE DISCONTINUED: ",$$FMTE^XLFDT($P(BHZ,U,9))
- K ^UTILITY($J,"W")
- S BHSNVA=$P(BHZ,U,10)
- S BHSORD=$P($G(^PS(55,DFN,"NVA",BHSNVA,0)),U,8)
- I +BHSORD D RECON^BHSMED(BHSORD,"M")
- E D
- .N NVA
- .S NVA=BHSNVA
- .I NVA'="" D
- ..S BHSORD=$P($G(^PS(55,DFN,"NVA",NVA,0)),U,8)
- ..D RECON^BHSMED(BHSORD,"M")
- Q
- D(D) ;
- I D="" Q ""
- Q $E(D,4,5)_"-"_$E(D,6,7)_"-"_$E(D,2,3)
- ;
- SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
- 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=$P($G(^AUPNVMED(M,11)),U,7) S:BHSREF="" 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
- Q:$P(^AUPNVSIT(BHSVDF,0),U,6)=""
- I $P(^AUPNVSIT(BHSVDF,0),U,6)'=DUZ(2) S BHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(BHSVDF,0),U,6),0),U),1,30)
- Q
- ;
- CS(D) ;
- I $P(^PSDRUG(D,0),U,3)="" Q 0
- NEW Y S Y=$P(^PSDRUG(D,0),U,3)
- ;I Y[1 Q 1
- I Y[2 Q 1
- I Y[3 Q 1
- I Y[4 Q 1
- I Y[5 Q 1
- ;I Y["C" Q 1
- ;I Y["A" Q 1
- Q 0
- ;
- CTR(X,Y) ;EP - Center X in a field Y wide.
- Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
- BHSMEDR ;IHS/MSC/MGH - Health Summary for MED RECONCILIATION ;01-May-2014 11:12;DU
- +1 ;;1.0;HEALTH SUMMARY COMPONENTS;**4,6,8,9**;March 17, 2006;Build 16
- +2 ;;---------------------------------------------------------------
- +3 ; IHS/CMI/LAB - APCHS7R -- SUMMARY PRODUCTION COMPONENTS ;
- +4 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
- +5 ;
- +6 ;Patch 6 for non-VA meds
- SET ;
- +1 SET BHSRX=P
- SET BHSREF=0
- DO REF
- +2 SET BHSTAT(C,N,D,(9999999-F),M)=$SELECT(P:$PIECE(^PSRX(P,0),U),1:"")_U_BHSREF
- +3 SET $PIECE(BHSTAT(C,N,D,(9999999-F),M),U,10)=P
- +4 SET BHMDSP(D,N,F)=""
- +5 QUIT
- MEDRCON ; ************* MEDS BY PRESCRIPTION STATUS *************
- +1 ;
- CONT ; <SETUP>
- +1 NEW BHSPAT,BHSQ
- +2 SET BHSPAT=DFN
- +3 IF '$DATA(^AUPNVMED("AC",BHSPAT))
- IF '$DATA(^PS(52.41,"P",BHSPAT))
- QUIT
- +4 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +5 ; <BUILD>
- +6 NEW BHMEDS,BHSTAT,BHCNT,BHMDSP,BHDI,BHDT,BHM,BHN,BHSSGY,BHSIG,BHZ,BHSN,BHST,BHI,BHD,BHS11
- +7 NEW X,F,M,V,D,N,P,C,E,S,R,J,BHSITE,BHSORT,BHSP,BHSREF,BHSRFL,BHSRX,BHSVDF,BHT,BHSNVA
- +8 SET BHCNT=0
- +9 KILL BHMEDS,BHMDSP
- +10 DO GETMEDS^APCHSMU1(BHSPAT,$$FMADD^XLFDT(DT,-395),DT,,,,,.BHMEDS)
- +11 ;I '$D(APCHMEDS) D MEDX Q
- +12 ;NOW REORDER THEM BY STATUS
- +13 KILL BHSTAT
- +14 SET X=0
- FOR
- SET X=$ORDER(BHMEDS(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +15 SET P=""
- +16 ;FILL DATE
- SET F=$PIECE(BHMEDS(X),U,1)
- +17 ;vmed ien
- SET M=$PIECE(BHMEDS(X),U,4)
- +18 ;visit ien
- SET V=$PIECE(BHMEDS(X),U,5)
- +19 ;drug ien
- SET D=$PIECE(^AUPNVMED(M,0),U)
- +20 ;non table drug name
- SET N=$PIECE(^AUPNVMED(M,0),U,4)
- +21 ;drug name
- IF N=""
- SET N=$PIECE(^PSDRUG(D,0),U)
- +22 IF $PIECE($GET(^AUPNVSIT(X,0)),U,7)="E"
- SET C="OUTSIDE MEDICATIONS"
- DO SET
- QUIT
- +23 IF $PIECE($GET(^AUPNVSIT(X,11)),U,8)
- SET C="OUTSIDE MEDICATIONS"
- DO SET
- QUIT
- +24 SET P=$ORDER(^PSRX("APCC",M,0))
- +25 IF 'P
- SET C="OUTSIDE MEDICATIONS"
- DO SET
- QUIT
- +26 IF '$DATA(^PSRX(P,0))
- SET P=""
- SET C="OUTSIDE MEDICATIONS"
- DO SET
- QUIT
- +27 ;Patch 8 for autofinished meds
- +28 IF $$VALI^XBDIQ1(52,P,9999999.23)=1
- SET C="OUTSIDE PHARMACY MEDS"
- DO SET
- QUIT
- +29 ;GET STATUS
- SET S=$$VALI^XBDIQ1(52,P,100)
- +30 IF S=0
- SET C="ACTIVE MEDICATIONS"
- DO SET
- QUIT
- +31 IF S=3
- SET C="HOLD"
- DO SET
- QUIT
- +32 IF S=5
- SET C="SUSPENDED"
- DO SET
- QUIT
- +33 IF S=11
- Begin DoDot:2
- +34 ;get expiration date
- +35 SET E=$PIECE($GET(^PSRX(P,3)),U,6)
- +36 ;chronic flag
- SET R=$$CHRONIC^APCHS72(M)
- +37 IF 'R
- Begin DoDot:3
- +38 ;not chronic, check to see if expired in past 14 days, if not quit
- +39 SET J=$$FMDIFF^XLFDT(DT,E)
- +40 ;more than 14 days ago so don't display
- IF J>14
- QUIT
- +41 ;check to see if same drug is already listed somewhere
- +42 ;another of same drug after this date
- IF $ORDER(BHMDSP(D,N,F))
- QUIT
- +43 SET C="EXPIRED"
- DO SET
- QUIT
- End DoDot:3
- QUIT
- +44 ;chronic = check 120 days
- +45 SET J=$$FMDIFF^XLFDT(DT,E)
- +46 ;expired more than 120 days ago
- IF J>120
- QUIT
- +47 ;another one there so don't display this one
- IF $ORDER(BHMDSP(D,N,F))
- QUIT
- +48 SET C="EXPIRED"
- DO SET
- QUIT
- End DoDot:2
- QUIT
- +49 IF S=12!(S=14)
- Begin DoDot:2
- +50 ;discontinued date in v med
- SET E=$PIECE(^AUPNVMED(M,0),U,8)
- +51 ;canceled date in 52
- IF E=""
- SET E=$PIECE($GET(^PSRX(P,3)),U,5)
- +52 ;only discontinueds in past 30 days
- IF $$FMDIFF^XLFDT(DT,E)>30
- QUIT
- +53 IF $ORDER(BHMDSP(D,N,F))
- QUIT
- +54 SET C="DISCONTINUED MEDICATIONS"
- DO SET
- QUIT
- End DoDot:2
- End DoDot:1
- GETNVA ;NVA from file 55
- +1 NEW L,D,N,X,DC
- +2 SET X=0
- FOR
- SET X=$ORDER(^PS(55,BHSPAT,"NVA",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +3 SET DC=0
- +4 IF $PIECE($GET(^PS(55,BHSPAT,"NVA",X,999999911)),U,1)
- Begin DoDot:2
- +5 IF $DATA(^AUPNVMED($PIECE(^PS(55,BHSPAT,"NVA",X,999999911),U,1),0))
- Begin DoDot:3
- +6 IF $PIECE($GET(^PS(55,BHSPAT,"NVA",X,0)),U,6)'=""
- SET DC=1
- End DoDot:3
- End DoDot:2
- IF DC=1
- QUIT
- +7 SET L=$PIECE($PIECE($GET(^PS(55,BHSPAT,"NVA",X,0)),U,10),".")
- +8 SET L=9999999-L
- +9 SET D=$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,2)
- +10 IF D=""
- SET D="NO DRUG IEN"
- +11 SET N=$SELECT(D:$PIECE(^PSDRUG(D,0),U,1),1:$PIECE(^PS(50.7,$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,1),0),U,1))
- +12 SET BHSTAT("NVA",N,D,(9999999-L))=U_"N"
- SET $PIECE(BHSTAT("NVA",N,D,(9999999-L)),U,8)=$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,4)_" "_$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,5)_U_$PIECE(^PS(55,BHSPAT,"NVA",X,0),U,7)
- +13 SET $PIECE(BHSTAT("NVA",N,D,(9999999-L)),U,10)=X
- End DoDot:1
- GETPEND ;
- +1 NEW PEN,ORD
- +2 FOR PEN=0:0
- SET PEN=$ORDER(^PS(52.41,"P",BHSPAT,PEN))
- IF 'PEN
- QUIT
- SET ORD=^PS(52.41,PEN,0)
- SET BHI=$PIECE(ORD,"^",8)
- SET BHD=+$PIECE(ORD,"^",9)
- IF $PIECE(ORD,"^",3)'="DC"&($PIECE(ORD,"^",3)'="DE")&($PIECE(ORD,"^",3)'="HD")
- Begin DoDot:1
- +3 SET BHN=$SELECT(BHD:$PIECE($GET(^PSDRUG(BHD,0)),"^"),+BHI&('BHD):$PIECE(^PS(50.7,BHI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,BHI,0),"^",2),0),"^"),1:"")
- IF BHN']""
- QUIT
- +4 SET BHSTAT("PENDING",BHN,PEN)=$$VAL^XBDIQ1(52.41,PEN,13)
- +5 SET C=0
- SET X=""
- FOR
- SET C=$ORDER(^PS(52.41,PEN,"SIG",C))
- IF 'C
- QUIT
- SET X=X_$SELECT(X]"":" ",1:"")_^PS(52.41,PEN,"SIG",C,0)
- +6 SET $PIECE(BHSTAT("PENDING",BHN,PEN),U,2)=X
- End DoDot:1
- DISP ;DISPLAY MEDS
- +1 ;ACTIVE MEDS FIRST - ALL OF THEM
- +2 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +3 IF '$DATA(BHSTAT("ACTIVE MEDICATIONS"))
- GOTO OUT
- +4 WRITE "ACTIVE MEDICATIONS",!
- +5 SET BHCNT=0
- +6 SET BHT=1
- +7 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("ACTIVE MEDICATIONS",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +8 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +9 SET BHDT=0
- FOR
- SET BHDT=$ORDER(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT))
- IF BHDT'=+BHDT!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +10 SET BHM=0
- FOR
- SET BHM=$ORDER(BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT,BHM))
- IF BHM'=+BHM!($DATA(GMTSQIT))
- QUIT
- SET BHZ=BHSTAT("ACTIVE MEDICATIONS",BHN,BHDI,BHDT,BHM)
- DO MEDDSP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +11 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +12 IF '$DATA(BHSTAT("OUTSIDE PHARMACY MEDS"))
- GOTO OUT
- +13 WRITE "OUTSIDE PHARMACY MEDS",!
- +14 SET BHCNT=0
- +15 SET BHT=1
- +16 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("OUTSIDE PHARMACY MEDS",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +17 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +18 SET BHDT=0
- FOR
- SET BHDT=$ORDER(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT))
- IF BHDT'=+BHDT!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +19 SET BHM=0
- FOR
- SET BHM=$ORDER(BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT,BHM))
- IF BHM'=+BHM!($DATA(GMTSQIT))
- QUIT
- SET BHZ=BHSTAT("OUTSIDE PHARMACY MEDS",BHN,BHDI,BHDT,BHM)
- DO MEDDSP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- OUT ;OUTSIDE MEDICATIONS
- +1 IF '$DATA(BHSTAT("OUTSIDE MEDICATIONS"))&('$DATA(BHSTAT("NVA")))
- GOTO HOLD
- +2 WRITE "--------------------",!
- +3 WRITE "OUTSIDE MEDICATIONS",!
- +4 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("OUTSIDE MEDICATIONS",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +5 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +6 SET BHDT=0
- SET BHDT=$ORDER(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT))
- IF BHDT'=+BHDT!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +7 SET BHM=0
- SET BHM=$ORDER(BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT,BHM))
- IF BHM'=+BHM!($DATA(GMTSQIT))
- QUIT
- SET BHZ=BHSTAT("OUTSIDE MEDICATIONS",BHN,BHDI,BHDT,BHM)
- DO MEDDSPO
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +8 ;now display nva
- +9 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("NVA",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +10 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("NVA",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +11 SET BHDT=0
- SET BHDT=$ORDER(BHSTAT("NVA",BHN,BHDI,BHDT))
- IF BHDT'=+BHDT!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +12 SET BHZ=BHSTAT("NVA",BHN,BHDI,BHDT)
- DO MEDDSPN
- End DoDot:3
- End DoDot:2
- End DoDot:1
- HOLD ;HOLD MEDICATIONS
- +1 IF '$DATA(BHSTAT("HOLD MEDICATIONS"))
- GOTO SUSPEND
- +2 SET BHT=3
- +3 WRITE "--------------------",!
- +4 WRITE "ACTIVE NOT DISPENSED MEDICATIONS",!
- +5 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("HOLD MEDICATIONS",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +6 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("HOLD MEDICATIONS",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +7 SET BHDT=0
- FOR
- SET BHDT=$ORDER(BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT))
- IF BHDT'=+BHDT!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +8 SET BHM=0
- FOR
- SET BHM=$ORDER(BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT,BHM))
- IF BHM'=+BHM!($DATA(GMTSQIT))
- QUIT
- SET BHZ=BHSTAT("HOLD MEDICATIONS",BHN,BHDI,BHDT,BHM)
- DO MEDDSP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- SUSPEND ;
- +1 IF '$DATA(BHSTAT("SUSPEND MEDICATIONS"))
- GOTO PENDING
- +2 SET BHT=4
- +3 WRITE !,"--------------------",!
- +4 WRITE "SUSPENDED MEDICATIONS",!
- +5 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("SUSPEND MEDICATIONS",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +6 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +7 SET BHDT=0
- FOR
- SET BHDT=$ORDER(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT))
- IF BHDT'=+BHDT!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +8 SET BHM=0
- FOR
- SET BHM=$ORDER(BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT,BHM))
- IF BHM'=+BHM!($DATA(GMTSQIT))
- QUIT
- SET BHZ=BHSTAT("SUSPEND MEDICATIONS",BHN,BHDI,BHDT,BHM)
- DO MEDDSP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- PENDING ;
- +1 IF '$DATA(BHSTAT("PENDING"))
- GOTO EXPIRED
- +2 WRITE "--------------------",!
- +3 WRITE "PENDING MEDICATIONS",!
- +4 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("PENDING",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +5 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("PENDING",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +6 SET BHZ=BHSTAT("PENDING",BHN,BHDI)
- DO MEDDSPP
- End DoDot:2
- End DoDot:1
- EXPIRED ;
- +1 IF '$DATA(BHSTAT("EXPIRED MEDICATIONS"))
- GOTO DISCONT
- +2 SET BHT=6
- +3 WRITE "--------------------",!
- +4 WRITE "CHRONIC AND RECENTLY EXPIRED MEDICATIONS",!
- +5 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("EXPIRED MEDICATIONS",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +6 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +7 SET BHDT=0
- FOR
- SET BHDT=$ORDER(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT))
- IF BHDT'=+BHDT!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +8 SET BHM=0
- FOR
- SET BHM=$ORDER(BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT,BHM))
- IF BHM'=+BHM!($DATA(GMTSQIT))
- QUIT
- SET BHZ=BHSTAT("EXPIRED MEDICATIONS",BHN,BHDI,BHDT,BHM)
- DO MEDDSP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- DISCONT ;
- +1 IF '$DATA(BHSTAT("DISCONTINUED MEDICATIONS"))
- GOTO MEDX
- +2 SET BHT=7
- +3 WRITE "--------------------",!
- +4 WRITE "RECENTLY DISCONTINUED MEDICATIONS",!
- +5 SET BHN=""
- FOR
- SET BHN=$ORDER(BHSTAT("DISCONTINUED MEDICATIONS",BHN))
- IF BHN=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +6 SET BHDI=""
- FOR
- SET BHDI=$ORDER(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI))
- IF BHDI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +7 SET BHDT=0
- FOR
- SET BHDT=$ORDER(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT))
- IF BHDT'=+BHDT!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +8 SET BHM=0
- FOR
- SET BHM=$ORDER(BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT,BHM))
- IF BHM'=+BHM!($DATA(GMTSQIT))
- QUIT
- SET BHZ=BHSTAT("DISCONTINUED MEDICATIONS",BHN,BHDI,BHDT,BHM)
- DO MEDDSP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- MEDX ;
- +1 QUIT
- MEDDSPP ;DISPLAY MEDICATION
- +1 NEW BHSRX,BHSORD
- +2 SET BHCNT=BHCNT+1
- +3 SET BHS11=$GET(^AUPNVMED(BHZ,11))
- +4 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +5 WRITE BHCNT,".",?6,BHN
- IF $PIECE(BHZ,U,2)
- WRITE ?60,"Refills: ",$SELECT('$PIECE(BHZ,U,1):"NONE",1:$PIECE(BHZ,U,1))
- WRITE !
- +6 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +7 KILL ^UTILITY($JOB,"W")
- SET X=$PIECE(BHZ,U,2)
- SET DIWL=0
- SET DIWR=60
- DO ^DIWP
- +8 WRITE ?6,"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:" "),!
- +9 IF $GET(^UTILITY($JOB,"W",0))>1
- FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
- IF $DATA(GMTSQIT)
- QUIT
- Begin DoDot:1
- +10 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +11 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
- End DoDot:1
- +12 KILL ^UTILITY($JOB,"W")
- +13 SET BHSORD=$$GET1^DIQ(52.41,BHDI,.01,"I")
- +14 IF +BHSORD
- DO RECON^BHSMED(BHSORD,"M")
- +15 IF '$TEST
- Begin DoDot:1
- +16 NEW NVA
- +17 SET NVA=+$PIECE(BHS11,U,8)
- +18 IF NVA'=""
- Begin DoDot:2
- +19 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
- +20 DO RECON^BHSMED(BHSORD,"M")
- End DoDot:2
- End DoDot:1
- +21 QUIT
- MEDDSPO ;DISPLAY MEDICATION
- +1 NEW BHSRX,BHSORD
- +2 SET BHSN=^AUPNVMED(BHM,0)
- +3 SET BHCNT=BHCNT+1
- +4 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +5 WRITE BHCNT,".",?6,BHN
- IF $PIECE(BHZ,U,2)
- WRITE ?60,"Refills left: ",$SELECT('$PIECE(BHZ,U,2):"NONE",1:$PIECE(BHZ,U,2))
- WRITE !
- +6 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +7 SET BHSIG=$PIECE(^AUPNVMED(BHM,0),U,5)
- DO SIG
- +8 SET X=BHSSGY
- +9 KILL ^UTILITY($JOB,"W")
- SET DIWL=0
- SET DIWR=60
- DO ^DIWP
- +10 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +11 WRITE ?6,"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:" "),!
- +12 IF $GET(^UTILITY($JOB,"W",0))>1
- FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
- IF $DATA(GMTSQIT)
- QUIT
- Begin DoDot:1
- +13 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +14 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
- End DoDot:1
- +15 KILL ^UTILITY($JOB,"W")
- +16 SET BHSRX=$PIECE(BHZ,U,10)
- +17 SET BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
- +18 IF +BHSORD
- DO RECON^BHSMED(BHSORD,"M")
- +19 IF '$TEST
- Begin DoDot:1
- +20 NEW NVA
- +21 SET NVA=BHSRX
- +22 IF NVA'=""
- Begin DoDot:2
- +23 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
- +24 DO RECON^BHSMED(BHSORD,"M")
- End DoDot:2
- End DoDot:1
- +25 QUIT
- MEDDSP ;DISPLAY MEDICATION
- +1 NEW BHSRX,BHSORD
- +2 SET BHSN=^AUPNVMED(BHM,0)
- +3 SET BHS11=^AUPNVMED(BHM,11)
- +4 SET BHCNT=BHCNT+1
- +5 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +6 WRITE BHCNT,".",?6,BHN,?40,"Rx #:",$PIECE(BHZ,U,1),?60,"Refills left: ",$SELECT('$PIECE(BHZ,U,2):"NONE",1:$PIECE(BHZ,U,2)),!
- +7 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +8 SET BHSIG=$PIECE(^AUPNVMED(BHM,0),U,5)
- DO SIG
- +9 SET X=BHSSGY
- +10 KILL ^UTILITY($JOB,"W")
- SET DIWL=0
- SET DIWR=60
- DO ^DIWP
- +11 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +12 WRITE ?6,"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:" "),!
- +13 IF $GET(^UTILITY($JOB,"W",0))>1
- FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
- IF $DATA(GMTSQIT)
- QUIT
- Begin DoDot:1
- +14 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +15 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
- End DoDot:1
- +16 KILL ^UTILITY($JOB,"W")
- +17 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +18 IF BHT=1!(BHT=6)
- WRITE ?6,"Last Filled: ",$$D(9999999-BHDT)
- Begin DoDot:1
- +19 SET BHSORT=""
- IF BHT=1
- SET BHSORT=$PIECE($GET(^AUPNVMED(BHM,11)),U)
- +20 IF BHSORT["RETURNED TO STOCK"
- WRITE " ---",BHSORT," ",$$FMTE^XLFDT($PIECE(^AUPNVMED(BHM,0),U,8),"2D")
- End DoDot:1
- +21 IF BHT=6
- IF $PIECE(BHZ,U,1)
- SET E=$PIECE($GET(^PSRX($PIECE(BHZ,U,1),3)),U,6)
- WRITE ?30,"Expired: ",$$D(E)
- +22 WRITE !
- +23 IF BHT=3
- WRITE ?6,"Hold Reason: "
- IF $PIECE(BHZ,U,1)
- WRITE $PIECE($GET(^PSRX($PIECE(BHZ,U,1),"H")),U,1)
- +24 IF BHT=7
- WRITE ?6,"Discontinued: "
- Begin DoDot:1
- +25 ;discontinued date in v med
- SET E=$PIECE(^AUPNVMED(BHM,0),U,8)
- +26 ;canceled date in 52
- IF E=""
- IF $PIECE(BHZ,U,1)
- SET E=$PIECE($GET(^PSRX($PIECE(BHZ,U,1),3)),U,5)
- +27 WRITE $$D(E),!
- End DoDot:1
- +28 SET BHSRX=$PIECE(BHZ,U,10)
- +29 SET BHSORD=$$GET1^DIQ(52,BHSRX,39.3,"I")
- +30 IF +BHSORD
- DO RECON^BHSMED(BHSORD,"M")
- +31 IF '$TEST
- Begin DoDot:1
- +32 NEW NVA
- +33 SET NVA=BHSRX
- +34 IF NVA'=""
- Begin DoDot:2
- +35 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
- +36 DO RECON^BHSMED(BHSORD,"M")
- End DoDot:2
- End DoDot:1
- +37 QUIT
- MEDDSPN ;
- +1 SET BHCNT=BHCNT+1
- +2 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +3 ;W:$P(APCHZ,U,2) ?60,"Refills left: ",$S('$P(APCHZ,U,2):"NONE",1:$P(APCHZ,U,2)) W !
- WRITE BHCNT,".",?6,BHN,!
- +4 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +5 SET BHSIG=$PIECE(BHZ,U,8)
- DO SIG
- +6 SET X=BHSSGY
- +7 KILL ^UTILITY($JOB,"W")
- SET DIWL=0
- SET DIWR=60
- DO ^DIWP
- +8 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +9 WRITE ?6,"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:" "),!
- +10 IF $GET(^UTILITY($JOB,"W",0))>1
- FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
- IF $DATA(GMTSQIT)
- QUIT
- Begin DoDot:1
- +11 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +12 WRITE ?19,$GET(^UTILITY($JOB,"W",0,F,0)),!
- End DoDot:1
- +13 IF $PIECE(BHZ,U,9)
- WRITE !?19,"DATE DISCONTINUED: ",$$FMTE^XLFDT($PIECE(BHZ,U,9))
- +14 KILL ^UTILITY($JOB,"W")
- +15 SET BHSNVA=$PIECE(BHZ,U,10)
- +16 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",BHSNVA,0)),U,8)
- +17 IF +BHSORD
- DO RECON^BHSMED(BHSORD,"M")
- +18 IF '$TEST
- Begin DoDot:1
- +19 NEW NVA
- +20 SET NVA=BHSNVA
- +21 IF NVA'=""
- Begin DoDot:2
- +22 SET BHSORD=$PIECE($GET(^PS(55,DFN,"NVA",NVA,0)),U,8)
- +23 DO RECON^BHSMED(BHSORD,"M")
- End DoDot:2
- End DoDot:1
- +24 QUIT
- D(D) ;
- +1 IF D=""
- QUIT ""
- +2 QUIT $EXTRACT(D,4,5)_"-"_$EXTRACT(D,6,7)_"-"_$EXTRACT(D,2,3)
- +3 ;
- SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
- +1 SET BHSSGY=""
- FOR BHSP=1:1:$LENGTH(BHSIG," ")
- SET X=$PIECE(BHSIG," ",BHSP)
- 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(BHSIG," ",BHSP-1)
- SET Y=$EXTRACT(Y,$LENGTH(Y))
- IF Y>1
- SET X=$PIECE(^(9),"^",1)
- +3 SET BHSSGY=BHSSGY_X_" "
- End DoDot:1
- +4 QUIT
- +5 ;
- REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
- +1 IF 'BHSRX
- SET BHSREF=$PIECE($GET(^AUPNVMED(M,11)),U,7)
- IF BHSREF=""
- SET BHSREF=0
- QUIT
- +2 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
- +3 SET BHSREF=BHSRFL
- +4 QUIT
- +5 ;
- +6 ;
- SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
- +1 SET BHSITE=""
- +2 IF $DATA(^AUPNVSIT(BHSVDF,21))#2
- SET BHSITE=$PIECE(^(21),U)
- QUIT
- +3 IF $PIECE(^AUPNVSIT(BHSVDF,0),U,6)=""
- QUIT
- +4 IF $PIECE(^AUPNVSIT(BHSVDF,0),U,6)'=DUZ(2)
- SET BHSITE=$EXTRACT($PIECE(^DIC(4,$PIECE(^AUPNVSIT(BHSVDF,0),U,6),0),U),1,30)
- +5 QUIT
- +6 ;
- CS(D) ;
- +1 IF $PIECE(^PSDRUG(D,0),U,3)=""
- QUIT 0
- +2 NEW Y
- SET Y=$PIECE(^PSDRUG(D,0),U,3)
- +3 ;I Y[1 Q 1
- +4 IF Y[2
- QUIT 1
- +5 IF Y[3
- QUIT 1
- +6 IF Y[4
- QUIT 1
- +7 IF Y[5
- QUIT 1
- +8 ;I Y["C" Q 1
- +9 ;I Y["A" Q 1
- +10 QUIT 0
- +11 ;
- CTR(X,Y) ;EP - Center X in a field Y wide.
- +1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
