BHSPOS ;IHS/MSC/MGH - Routine to select meds for selected med health summary compoenent;27-Oct-2009 17:53;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**3**; March 17,2006
;==================================================================
;Copy of PSOHCSUM to be used for health summary
;;7.0;OUTPATIENT PHARMACY;**4,35,42,48,54,46,103,132,1005**;DEC 1997
;External reference to File ^PS(55 supported by DBIA 2228
;External reference to File ^PSDRUG supported by DBIA 221
;External reference to File ^PS(50.7 supported by DBIA 2223
;External reference ^PS(50.606 supported by DBIA 2174
;External reference to ^SC supported by DBIA 10040
;Accepts DFN (assumed to be valid)
;Looks for PSOBEGIN as earliest expiration/cancel date for search
;If $D(PSOBEGIN)=0 use DT as earliest expiration/cancel date
;returns data in ^TMP("BHS",$J,Inverse last fill date,0)
;data is ISSUE DATE^LAST FILL DATE^DRUG^PROVIDER^STATUS^RX#^QTY^#REFILLS^IFN^COST/FILL^EXP/CANC DATE
;and ^TMP("BHS",$J,Inverse last fill date,n,0)=SIG
;NON-VA Meds: ^TMP("BHS",$J,"NVA",n,0)=orderable item_" "_dose form^status (active or discontinued)^start date(fm format)^cprs order # (ptr to 100)^date/time documented (fm format)^documented by (ptr to 200_";"_.01)^dc date/time(fm format)
;^TMP("BHS",$J,"NVA",n,1,0)=dosage^med route^schedule^drug (file #50_";"_.01)^clinic (file #44_";"_.01)
;^TMP("BHS",$J,"NVA",n,"DSC",nn,0)=statement/explanation/comments
;
;returns PSOBEGIN (if sent or equal DT if not sent)
;
;If $D(PSOACT) loop thru PS(55,DFN,"P","A") from PSOBEGIN to get actives only
;otherwise loop through entire "P" multiple to get all Rx's
;
SEL(MEDSEG) ;Use selected meds only
; Modified - IHS/CIA/PLS - 08/20/04 - Line GET+16
K ^TMP("BHS",$J),PSONV
N S
S PSOBEGIN=$S($D(PSOBEGIN):PSOBEGIN,1:DT)
I $D(PSOACT) F PSODT=PSOBEGIN-1:0 S PSODT=$O(^PS(55,DFN,"P","A",PSODT)) Q:'PSODT F PSORXX=0:0 S PSORXX=$O(^PS(55,DFN,"P","A",PSODT,PSORXX)) Q:'PSORXX D:$G(^PSRX(PSORXX,0))]"" GET
I '$D(PSOACT) F PSOI=0:0 S PSOI=$O(^PS(55,DFN,"P",PSOI)) Q:'PSOI S PSORXX=+^(PSOI,0) D:$G(^PSRX(PSORXX,0))]"" GET
F I=0:0 S I=$O(^PS(55,DFN,"NVA",I)) Q:'I S NVA=^PS(55,DFN,"NVA",I,0) Q:'$P(NVA,"^") D
.S PSOSEL=$P(NVA,U,2)
.Q:PSOSEL=""
.S PSONDF=$P($G(^PSDRUG(PSOSEL,"ND")),U,1)
.Q:'$D(MEDSEG(PSOSEL))&('$D(GENERIC(PSONDF)))
.S PSONV=$G(PSONV)+1
.S ^TMP("BHS",$J,"NVA",PSONV,0)=$S($D(^PS(50.7,$P(+NVA,"^"),0)):$P(^PS(50.7,$P(+NVA,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"")_"^"
.S ^TMP("BHS",$J,"NVA",PSONV,0)=^TMP("BHS",$J,"NVA",PSONV,0)_$S($P(NVA,"^",6):"DISCONTINUED",1:"ACTIVE")_"^"_$P(NVA,"^",9)_"^"_$P(NVA,"^",8)_"^"_$P(NVA,"^",10)_"^"_$P(NVA,"^",11)_";"_$P($G(^VA(200,$P(NVA,"^",11),0)),"^")_"^"_$P(NVA,"^",7)
.S ^TMP("BHS",$J,"NVA",PSONV,1,0)=$P(NVA,"^",3)_"^"_$P(NVA,"^",4)_"^"_$P(NVA,"^",5)_"^"_$S($P(NVA,"^",2):$P(NVA,"^",2)_";"_$P(^PSDRUG($P(NVA,"^",2),0),"^"),1:"")_"^"
.S ^TMP("BHS",$J,"NVA",PSONV,1,0)=^TMP("BHS",$J,"NVA",PSONV,1,0)_$S($D(^SC(+$P(NVA,"^",12),0)):$P(NVA,"^",12)_";"_$P(^SC($P(NVA,"^",12),0),"^"),1:"")
.F S=0:0 S S=$O(^PS(55,DFN,"NVA",I,"DSC",S)) Q:'S S ^TMP("BHS",$J,"NVA",PSONV,"DSC",S,0)=^PS(55,DFN,"NVA",I,"DSC",S,0)
;
END K PSODT,PSOST,PSORXX,PSO0,PSO2,PSOIDD,PSOFD,PSOSEL,PSODR,PSOPR,PSOREF,PSORFL,PSOI,PSOJ,PSOX,PSOCF,I,PSONV,NVA,PSONDF,INS1
Q
CHECK ;
Q
;
GET N PSOSEL,PSONDF
S PSOSEL=$P($G(^PSRX(PSORXX,0)),U,6)
Q:PSOSEL=""
S PSONDF=$P($G(^PSDRUG(PSOSEL,"ND")),U,1) I PSONDF="" S PSONDF=0
Q:'$D(MEDSEG(PSOSEL))&('$D(GENERIC(PSONDF)))
Q:$P($G(^PSRX(PSORXX,"STA")),"^")=13 S PSO0=^PSRX(PSORXX,0),PSO2=$G(^(2)),PSOFD=+$G(^(3)),PSODR=$P(PSO0,"^",6),PSOPR=$P(PSO0,"^",4),PSOREF=$P(PSO0,"^",9),PSOIDD=$P(PSO0,"^",13)
I '$P(PSO0,"^",2)!('PSODR)!('PSOPR) Q
I $D(^PS(55,$P(PSO0,"^",2),0)) D:$P($G(^PS(55,$P(PSO0,"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(PSO0,"^",2))
S PSOST=$P($G(^PSRX(PSORXX,"STA")),"^")
I '$D(PSOACT) D ODT I PSODT<PSOBEGIN Q
I $D(PSOACT) Q:PSOST>10&(PSOST<16)
I 'PSOFD S PSOFD=$P(PSO0,"^",13) F PSOJ=0:0 S PSOJ=$O(^PSRX(PSORXX,1,PSOJ)) Q:'PSOJ I $D(^(PSOJ,0)),^(0)>PSOFD S PSOFD=+^(0)
S PSOX=$S($D(^PSDRUG(PSODR,0)):$P(^(0),"^"),1:"NOT ON FILE"),PSODR=PSODR_";"_PSOX
S PSOX=$G(^VA(200,PSOPR,0)) S PSOPR=PSOPR_";"_$P(PSOX,"^")
S PSOX="A;ACTIVE" S:$D(^PS(52.4,PSORXX,0)) PSOX="N;NON-VERIFIED" S:$O(^PS(52.5,"B",PSORXX,0))&($G(^PS(52.5,+$O(^PS(52.5,"B",PSORXX,0)),"P"))'=1) PSOX="S;SUSPENDED"
S:PSODT<DT PSOX="E;EXPIRED" S:PSOST=4 PSOX="N;NON-VERIFIED" S:PSOST=3!(PSOST=16) PSOX="H;HOLD"
S:PSOST=12!(PSOST=14)!(PSOST=15) PSOX="DC;DISCONTINUED"
S PSOCF=+$P(PSO0,"^",17)*(+$P(PSO0,"^",7)) ; Cost/Fill
S PSORFL=0 F PSOJ=0:0 S PSORFL=$O(^PSRX(PSORXX,1,PSORFL)) Q:PSORFL'>0 S PSOREF=PSOREF-1
F PSOJ=9999999-PSOFD:.0001 Q:'$D(^TMP("BHS",$J,PSOJ))
S ^TMP("BHS",$J,PSOJ,0)=PSOIDD_"^"_PSOFD_"^"_PSODR_"^"_PSOPR_"^"_PSOX_"^"_$P(PSO0,"^")_"^"_$P(PSO0,"^",7)_"^"_PSOREF_"^"_PSORXX_"^"_PSOCF_"^"_PSODT
; IHS/CIA/PLS - 08/20/04 - Quit if SIG node doesn't exist.
Q:'$D(^PSRX(PSORXX,"SIG"))
I '$P(^PSRX(PSORXX,"SIG"),"^",2) D SIG Q
F I=0:0 S I=$O(^PSRX(PSORXX,"SIG1",I)) Q:'I S ^TMP("BHS",$J,PSOJ,I,0)=^PSRX(PSORXX,"SIG1",I,0)
Q
SIG ;formats backdoor SIG
S X=$P(^PSRX(PSORXX,"SIG"),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250),ENT=1
F SG=1:1:$L(SIG) S:$L($G(^TMP("BHS",$J,PSOJ,ENT,0))_" "_$P(SIG," ",SG))>80 ENT=ENT+1 S:$P(SIG," ",SG)'="" ^TMP("BHS",$J,PSOJ,ENT,0)=$G(^TMP("BHS",$J,PSOJ,ENT,0))_" "_$P(SIG," ",SG)
K SIG,ENT,SG,X Q
ODT ;canceled or expiration date
I +PSOST=12!(PSOST=14)!(PSOST=15) D Q
.I $P(^PSRX(PSORXX,3),"^",5) S PSODT=$P(^PSRX(PSORXX,3),"^",5) Q
.S PSODT=0 F PSOJ=0:0 S PSOJ=$O(^PSRX(PSORXX,"A",PSOJ)) Q:PSOJ'>0 I $D(^(PSOJ,0)),$P(^(0),"^",2)="C",+$P(^(0),"^")>PSODT S PSODT=+$P(^(0),"^")
S PSODT=+$P(PSO2,"^",6)
Q
BHSPOS ;IHS/MSC/MGH - Routine to select meds for selected med health summary compoenent;27-Oct-2009 17:53;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**3**; March 17,2006
+2 ;==================================================================
+3 ;Copy of PSOHCSUM to be used for health summary
+4 ;;7.0;OUTPATIENT PHARMACY;**4,35,42,48,54,46,103,132,1005**;DEC 1997
+5 ;External reference to File ^PS(55 supported by DBIA 2228
+6 ;External reference to File ^PSDRUG supported by DBIA 221
+7 ;External reference to File ^PS(50.7 supported by DBIA 2223
+8 ;External reference ^PS(50.606 supported by DBIA 2174
+9 ;External reference to ^SC supported by DBIA 10040
+10 ;Accepts DFN (assumed to be valid)
+11 ;Looks for PSOBEGIN as earliest expiration/cancel date for search
+12 ;If $D(PSOBEGIN)=0 use DT as earliest expiration/cancel date
+13 ;returns data in ^TMP("BHS",$J,Inverse last fill date,0)
+14 ;data is ISSUE DATE^LAST FILL DATE^DRUG^PROVIDER^STATUS^RX#^QTY^#REFILLS^IFN^COST/FILL^EXP/CANC DATE
+15 ;and ^TMP("BHS",$J,Inverse last fill date,n,0)=SIG
+16 ;NON-VA Meds: ^TMP("BHS",$J,"NVA",n,0)=orderable item_" "_dose form^status (active or discontinued)^start date(fm format)^cprs order # (ptr to 100)^date/time documented (fm format)^documented by (ptr to 200_";"_.01)^dc date/time(fm format)
+17 ;^TMP("BHS",$J,"NVA",n,1,0)=dosage^med route^schedule^drug (file #50_";"_.01)^clinic (file #44_";"_.01)
+18 ;^TMP("BHS",$J,"NVA",n,"DSC",nn,0)=statement/explanation/comments
+19 ;
+20 ;returns PSOBEGIN (if sent or equal DT if not sent)
+21 ;
+22 ;If $D(PSOACT) loop thru PS(55,DFN,"P","A") from PSOBEGIN to get actives only
+23 ;otherwise loop through entire "P" multiple to get all Rx's
+24 ;
SEL(MEDSEG) ;Use selected meds only
+1 ; Modified - IHS/CIA/PLS - 08/20/04 - Line GET+16
+2 KILL ^TMP("BHS",$JOB),PSONV
+3 NEW S
+4 SET PSOBEGIN=$SELECT($DATA(PSOBEGIN):PSOBEGIN,1:DT)
+5 IF $DATA(PSOACT)
FOR PSODT=PSOBEGIN-1:0
SET PSODT=$ORDER(^PS(55,DFN,"P","A",PSODT))
IF 'PSODT
QUIT
FOR PSORXX=0:0
SET PSORXX=$ORDER(^PS(55,DFN,"P","A",PSODT,PSORXX))
IF 'PSORXX
QUIT
IF $GET(^PSRX(PSORXX,0))]""
DO GET
+6 IF '$DATA(PSOACT)
FOR PSOI=0:0
SET PSOI=$ORDER(^PS(55,DFN,"P",PSOI))
IF 'PSOI
QUIT
SET PSORXX=+^(PSOI,0)
IF $GET(^PSRX(PSORXX,0))]""
DO GET
+7 FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"NVA",I))
IF 'I
QUIT
SET NVA=^PS(55,DFN,"NVA",I,0)
IF '$PIECE(NVA,"^")
QUIT
Begin DoDot:1
+8 SET PSOSEL=$PIECE(NVA,U,2)
+9 IF PSOSEL=""
QUIT
+10 SET PSONDF=$PIECE($GET(^PSDRUG(PSOSEL,"ND")),U,1)
+11 IF '$DATA(MEDSEG(PSOSEL))&('$DATA(GENERIC(PSONDF)))
QUIT
+12 SET PSONV=$GET(PSONV)+1
+13 SET ^TMP("BHS",$JOB,"NVA",PSONV,0)=$SELECT($DATA(^PS(50.7,$PIECE(+NVA,"^"),0)):$PIECE(^PS(50.7,$PIECE(+NVA,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^"),1:"")_"^"
+14 SET ^TMP("BHS",$JOB,"NVA",PSONV,0)=^TMP("BHS",$JOB,"NVA",PSONV,0)_$SELECT($PIECE(NVA,"^",6):"DISCONTINUED",1:"ACTIVE")_"^"_...
... $PIECE(NVA,"^",9)_"^"_$PIECE(NVA,"^",8)_"^"_$PIECE(NVA,"^",10)_"^"_$PIECE(NVA,"^",11)_";"_$PIECE($GET(^VA(200,$PIECE(NVA,"^",11),0)),"^")_"^"_$PIECE(NVA,"^",7)
+15 SET ^TMP("BHS",$JOB,"NVA",PSONV,1,0)=$PIECE(NVA,"^",3)_"^"_$PIECE(NVA,"^",4)_"^"_$PIECE(NVA,"^",5)_"^"_$SELECT($PIECE(NVA,"^",2):$PIECE(NVA,"^",2)_";"_$PIECE(^PSDRUG($PIECE(NVA,"^",2),0),"^"),1:"")_"^"
+16 SET ^TMP("BHS",$JOB,"NVA",PSONV,1,0)=^TMP("BHS",$JOB,"NVA",PSONV,1,0)_$SELECT($DATA(^SC(+$PIECE(NVA,"^",12),0)):$PIECE(NVA,"^",12)_";"_$PIECE(^SC($PIECE(NVA,"^",12),0),"^"),1:"")
+17 FOR S=0:0
SET S=$ORDER(^PS(55,DFN,"NVA",I,"DSC",S))
IF 'S
QUIT
SET ^TMP("BHS",$JOB,"NVA",PSONV,"DSC",S,0)=^PS(55,DFN,"NVA",I,"DSC",S,0)
End DoDot:1
+18 ;
END KILL PSODT,PSOST,PSORXX,PSO0,PSO2,PSOIDD,PSOFD,PSOSEL,PSODR,PSOPR,PSOREF,PSORFL,PSOI,PSOJ,PSOX,PSOCF,I,PSONV,NVA,PSONDF,INS1
+1 QUIT
CHECK ;
+1 QUIT
+2 ;
GET NEW PSOSEL,PSONDF
+1 SET PSOSEL=$PIECE($GET(^PSRX(PSORXX,0)),U,6)
+2 IF PSOSEL=""
QUIT
+3 SET PSONDF=$PIECE($GET(^PSDRUG(PSOSEL,"ND")),U,1)
IF PSONDF=""
SET PSONDF=0
+4 IF '$DATA(MEDSEG(PSOSEL))&('$DATA(GENERIC(PSONDF)))
QUIT
+5 IF $PIECE($GET(^PSRX(PSORXX,"STA")),"^")=13
QUIT
SET PSO0=^PSRX(PSORXX,0)
SET PSO2=$GET(^(2))
SET PSOFD=+$GET(^(3))
SET PSODR=$PIECE(PSO0,"^",6)
SET PSOPR=$PIECE(PSO0,"^",4)
SET PSOREF=$PIECE(PSO0,"^",9)
SET PSOIDD=$PIECE(PSO0,"^",13)
+6 IF '$PIECE(PSO0,"^",2)!('PSODR)!('PSOPR)
QUIT
+7 IF $DATA(^PS(55,$PIECE(PSO0,"^",2),0))
IF $PIECE($GET(^PS(55,$PIECE(PSO0,"^",2),0)),"^",6)'=2
DO EN^PSOHLUP($PIECE(PSO0,"^",2))
+8 SET PSOST=$PIECE($GET(^PSRX(PSORXX,"STA")),"^")
+9 IF '$DATA(PSOACT)
DO ODT
IF PSODT<PSOBEGIN
QUIT
+10 IF $DATA(PSOACT)
IF PSOST>10&(PSOST<16)
QUIT
+11 IF 'PSOFD
SET PSOFD=$PIECE(PSO0,"^",13)
FOR PSOJ=0:0
SET PSOJ=$ORDER(^PSRX(PSORXX,1,PSOJ))
IF 'PSOJ
QUIT
IF $DATA(^(PSOJ,0))
IF ^(0)>PSOFD
SET PSOFD=+^(0)
+12 SET PSOX=$SELECT($DATA(^PSDRUG(PSODR,0)):$PIECE(^(0),"^"),1:"NOT ON FILE")
SET PSODR=PSODR_";"_PSOX
+13 SET PSOX=$GET(^VA(200,PSOPR,0))
SET PSOPR=PSOPR_";"_$PIECE(PSOX,"^")
+14 SET PSOX="A;ACTIVE"
IF $DATA(^PS(52.4,PSORXX,0))
SET PSOX="N;NON-VERIFIED"
IF $ORDER(^PS(52.5,"B",PSORXX,0))&($GET(^PS(52.5,+$ORDER(^PS(52.5,"B",PSORXX,0)),"P"))'=1)
SET PSOX="S;SUSPENDED"
+15 IF PSODT<DT
SET PSOX="E;EXPIRED"
IF PSOST=4
SET PSOX="N;NON-VERIFIED"
IF PSOST=3!(PSOST=16)
SET PSOX="H;HOLD"
+16 IF PSOST=12!(PSOST=14)!(PSOST=15)
SET PSOX="DC;DISCONTINUED"
+17 ; Cost/Fill
SET PSOCF=+$PIECE(PSO0,"^",17)*(+$PIECE(PSO0,"^",7))
+18 SET PSORFL=0
FOR PSOJ=0:0
SET PSORFL=$ORDER(^PSRX(PSORXX,1,PSORFL))
IF PSORFL'>0
QUIT
SET PSOREF=PSOREF-1
+19 FOR PSOJ=9999999-PSOFD:.0001
IF '$DATA(^TMP("BHS",$JOB,PSOJ))
QUIT
+20 SET ^TMP("BHS",$JOB,PSOJ,0)=PSOIDD_"^"_PSOFD_"^"_PSODR_"^"_PSOPR_"^"_PSOX_"^"_$PIECE(PSO0,"^")_"^"_$PIECE(PSO0,"^",7)_"^"_PSOREF_"^"_PSORXX_"^"_PSOCF_"^"_PSODT
+21 ; IHS/CIA/PLS - 08/20/04 - Quit if SIG node doesn't exist.
+22 IF '$DATA(^PSRX(PSORXX,"SIG"))
QUIT
+23 IF '$PIECE(^PSRX(PSORXX,"SIG"),"^",2)
DO SIG
QUIT
+24 FOR I=0:0
SET I=$ORDER(^PSRX(PSORXX,"SIG1",I))
IF 'I
QUIT
SET ^TMP("BHS",$JOB,PSOJ,I,0)=^PSRX(PSORXX,"SIG1",I,0)
+25 QUIT
SIG ;formats backdoor SIG
+1 SET X=$PIECE(^PSRX(PSORXX,"SIG"),"^")
DO SIGONE^PSOHELP
SET SIG=$EXTRACT($GET(INS1),2,250)
SET ENT=1
+2 FOR SG=1:1:$LENGTH(SIG)
IF $LENGTH($GET(^TMP("BHS",$JOB,PSOJ,ENT,0))_" "_$PIECE(SIG," ",SG))>80
SET ENT=ENT+1
IF $PIECE(SIG," ",SG)'=""
SET ^TMP("BHS",$JOB,PSOJ,ENT,0)=$GET(^TMP("BHS",$JOB,PSOJ,ENT,0))_" "_$PIECE(SIG," ",SG)
+3 KILL SIG,ENT,SG,X
QUIT
ODT ;canceled or expiration date
+1 IF +PSOST=12!(PSOST=14)!(PSOST=15)
Begin DoDot:1
+2 IF $PIECE(^PSRX(PSORXX,3),"^",5)
SET PSODT=$PIECE(^PSRX(PSORXX,3),"^",5)
QUIT
+3 SET PSODT=0
FOR PSOJ=0:0
SET PSOJ=$ORDER(^PSRX(PSORXX,"A",PSOJ))
IF PSOJ'>0
QUIT
IF $DATA(^(PSOJ,0))
IF $PIECE(^(0),"^",2)="C"
IF +$PIECE(^(0),"^")>PSODT
SET PSODT=+$PIECE(^(0),"^")
End DoDot:1
QUIT
+4 SET PSODT=+$PIECE(PSO2,"^",6)
+5 QUIT
