APSPCDI1 ; IHS/MSC/PLS - CRITICAL DRUG INTERACTION REPORT ;28-Nov-2011 14:53;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1013**;Sep 23, 2004;Build 33
;
Q
PRINT ;EP
N APSPPG,DFLG,NEWPG
S (APSPPG,DFLG,NEWPG)=0
D HDR
D PRINT1
W:'DFLG !,"No data found..."
Q
;
PRINT1 ;EP
N DIV,SUB1,SUB2,SUB3,SUB4,SUB5,VAL,LP,LSTFDT
S LSTFDT=0
S DIV=0 F S DIV=$O(^TMP($J,"XREF",DIV)) Q:'DIV D
.I APSPDIV="*" W !!!,"Pharmacy Division: "_$$GET1^DIQ(59,DIV,.01),! ;W !,"|"_$$GET1^DIQ(59,DIV,.01)_"|" D PRINT3()
.I APSPSORT=1 D ; Drug Name
..S SUB1="" F S SUB1=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1)) Q:SUB1="" D ; Drug Name
...S SUB2=0 F S SUB2=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1,SUB2)) Q:'SUB2 D ; Fill Date
....S SUB3=0 F S SUB3=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1,SUB2,SUB3)) Q:'SUB3 D ; Data node
.....D PRINT2(^TMP($J,"DATA",SUB3))
.....S DFLG=1
.I APSPSORT=2 D ; Fill Date
..S SUB1=0 F S SUB1=$O(^TMP($J,"XREF",DIV,"FDT",SUB1)) Q:'SUB1 D ; Fill Date
...S SUB2="" F S SUB2=$O(^TMP($J,"XREF",DIV,"FDT",SUB1,SUB2)) Q:SUB2="" D ; Drug Name
....S SUB3=0 F S SUB3=$O(^TMP($J,"XREF",DIV,"FDT",SUB1,SUB2,SUB3)) Q:'SUB3 D ; Data node
.....D PRINT2(^TMP($J,"DATA",SUB3))
.....S DFLG=1
.I APSPSORT=3 D ; Patient Name
..S SUB1="" F S SUB1=$O(^TMP($J,"XREF",DIV,"PAT",SUB1)) Q:'$L(SUB1) D ; Patient Name
...S SUB2=0 F S SUB2=$O(^TMP($J,"XREF",DIV,"PAT",SUB1,SUB2)) Q:'SUB2 D ; Fill Date
....S SUB3="" F S SUB3=$O(^TMP($J,"XREF",DIV,"PAT",SUB1,SUB2,SUB3)) Q:'$L(SUB3) D ; Drug Name
.....S SUB4=0 F S SUB4=$O(^TMP($J,"XREF",DIV,"PAT",SUB1,SUB2,SUB3,SUB4)) Q:'SUB4 D ; Data node
......D PRINT2(^TMP($J,"DATA",SUB4))
......S DFLG=1
.I APSPSORT=4 D ; Provider
..S SUB1="" F S SUB1=$O(^TMP($J,"XREF",DIV,"PRV",SUB1)) Q:'$L(SUB1) D ; Provider
...S SUB2="" F S SUB2=$O(^TMP($J,"XREF",DIV,"PRV",SUB1,SUB2)) Q:'$L(SUB2) D ; Drug Name
....S SUB3=0 F S SUB3=$O(^TMP($J,"XREF",DIV,"PRV",SUB1,SUB2,SUB3)) Q:'SUB3 D ; Fill Date
.....S SUB4=0 F S SUB4=$O(^TMP($J,"XREF",DIV,"PRV",SUB1,SUB2,SUB3,SUB4)) Q:'SUB4 D ; Data node
......D PRINT2(^TMP($J,"DATA",SUB4))
......S DFLG=1
Q
; Print the line
PRINT2(DATA) ; EP -
N RX,DFN,HRN
I $P(DATA,U,3)="APSP" D
.D APSPINV(+DATA)
E D
.S RX=+DATA
.S DFN=$$GET1^DIQ(52,RX,2,"I")
.S HRN=$$HRN^AUPNPAT(DFN,DUZ(2))
.D PRINT3($P(DATA,U,16)+1)
.W !,$P($TR($$FMTE^XLFDT($P(DATA,U,2),"5Z"),"@"," "),":",1,2),?14,$P(DATA,U,9),?20,$E($$GET1^DIQ(2,DFN,.01),1,16),?38,HRN,?48,$$GET1^DIQ(52,RX,.01),?60,$P(DATA,U,8)
.D INTOUT(RX)
D PRINT3() ;check page length
Q
; Check page length and optionally print blank line
;
PRINT3(ADD) ;EP
S ADD=$G(ADD,0)
D:($Y+9+ADD)>IOSL HDR
Q
;
HDR ;EP
W:APSPPG @IOF
S APSPPG=APSPPG+1,NEWPG=1
W !,"Critical Drug Interaction Report",?(IOM-28),$P($TR($$FMTE^XLFDT($$NOW^XLFDT,"5Z"),"@"," "),":",1,2),?(IOM-10),"Page: "_APSPPG
W !,"Report Criteria:"
W !,?5,"Inclusive Dates: "_APSPBDF_" to "_APSPEDF
W !,?5,"Pharmacy Division: "_$S(APSPDIV:$$GET1^DIQ(59,APSPDIV,.01),1:"All")
W !,?5,"Sorted by: "_$S(APSPSORT=1:"Drug Name, Fill Date",APSPSORT=2:"Fill Date then Drug Name",APSPSORT=3:"Patient then Fill Date",4:"Prescriber then Drug Name, Fill Date",1:"Unknown")
I APSPSORT=3,APSPPAT W !,?7,"Patient sort restricted to ",$$GET1^DIQ(2,APSPPAT,.01)
I APSPSORT=4,APSPPRV W !,?7,"Prescriber sort restricted to ",$$GET1^DIQ(200,APSPPRV,.01)
D HDR1
Q
;
HDR1 ;EP
D DASH
W "Date Disp.",?14,"Type",?20,"Patient",?40,"HRN",?48,"Rx Number",?60,"Drug Name"
W !,?37,"Overriding Provider"
W !,?7,"Overriding Reason"
W !,"Cause"
D DASH
Q
;
DASH ;EP
N DASH
W ! F DASH=1:1:IOM W "-"
W !
Q
; Output order check information
INTOUT(RX) ;EP-
N IEN,CNT,ORDID,IENS,CAUSE
S (IEN,CNT)=0
S ORDID=$P(^PSRX(RX,"OR1"),U,2)
F S IEN=$O(^OR(100,ORDID,9,IEN)) Q:'IEN D
.Q:$$GET1^DIQ(100.8,$P($G(^OR(100,+ORDID,9,IEN,0)),U),.01)'="CRITICAL DRUG INTERACTION"
.S IENS=IEN_","_ORDID_","
.W !,?5,$$GET1^DIQ(100.09,IENS,.01),?37,$$GET1^DIQ(100.09,IENS,.05)
.W !,?7,$$GET1^DIQ(100.09,IENS,.04)
.S CAUSE=$P($G(^OR(100,+ORDID,9,IEN,1)),":",2)
.I $L(CAUSE) D
..W !,$S($L(CAUSE)>IOM:$E(CAUSE,1,IOM-3)_"...",1:CAUSE)
Q
; Output APSP Intervention
APSPINV(IEN) ;EP-
N FN,DFN,NODE0
S FN=9009032.4
S NODE0=^APSPQA(32.4,IEN,0)
S DFN=$P(NODE0,U,2)
W !,?5,$P($TR($$FMTE^XLFDT($P(NODE0,U),"5Z"),"@"," "),":",1,2),?21,$$GET1^DIQ(2,DFN,.01),?51,$$HRN^AUPNPAT(DFN,$$GET1^DIQ(59,$P(NODE0,U,16),100,"I")),?58,$$GET1^DIQ(FN,IEN,.05)
W !,?7,$$GET1^DIQ(200,$P(NODE0,U,4),.01),?49,$$GET1^DIQ(FN,IEN,.08)
W !,"Critical Drug Interaction over-ridden in RPMS Pharmacy Package"
Q
APSPCDI1 ; IHS/MSC/PLS - CRITICAL DRUG INTERACTION REPORT ;28-Nov-2011 14:53;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1013**;Sep 23, 2004;Build 33
+2 ;
+3 QUIT
PRINT ;EP
+1 NEW APSPPG,DFLG,NEWPG
+2 SET (APSPPG,DFLG,NEWPG)=0
+3 DO HDR
+4 DO PRINT1
+5 IF 'DFLG
WRITE !,"No data found..."
+6 QUIT
+7 ;
PRINT1 ;EP
+1 NEW DIV,SUB1,SUB2,SUB3,SUB4,SUB5,VAL,LP,LSTFDT
+2 SET LSTFDT=0
+3 SET DIV=0
FOR
SET DIV=$ORDER(^TMP($JOB,"XREF",DIV))
IF 'DIV
QUIT
Begin DoDot:1
+4 ;W !,"|"_$$GET1^DIQ(59,DIV,.01)_"|" D PRINT3()
IF APSPDIV="*"
WRITE !!!,"Pharmacy Division: "_$$GET1^DIQ(59,DIV,.01),!
+5 ; Drug Name
IF APSPSORT=1
Begin DoDot:2
+6 ; Drug Name
SET SUB1=""
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1))
IF SUB1=""
QUIT
Begin DoDot:3
+7 ; Fill Date
SET SUB2=0
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1,SUB2))
IF 'SUB2
QUIT
Begin DoDot:4
+8 ; Data node
SET SUB3=0
FOR
SET SUB3=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1,SUB2,SUB3))
IF 'SUB3
QUIT
Begin DoDot:5
+9 DO PRINT2(^TMP($JOB,"DATA",SUB3))
+10 SET DFLG=1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+11 ; Fill Date
IF APSPSORT=2
Begin DoDot:2
+12 ; Fill Date
SET SUB1=0
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"FDT",SUB1))
IF 'SUB1
QUIT
Begin DoDot:3
+13 ; Drug Name
SET SUB2=""
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"FDT",SUB1,SUB2))
IF SUB2=""
QUIT
Begin DoDot:4
+14 ; Data node
SET SUB3=0
FOR
SET SUB3=$ORDER(^TMP($JOB,"XREF",DIV,"FDT",SUB1,SUB2,SUB3))
IF 'SUB3
QUIT
Begin DoDot:5
+15 DO PRINT2(^TMP($JOB,"DATA",SUB3))
+16 SET DFLG=1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+17 ; Patient Name
IF APSPSORT=3
Begin DoDot:2
+18 ; Patient Name
SET SUB1=""
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"PAT",SUB1))
IF '$LENGTH(SUB1)
QUIT
Begin DoDot:3
+19 ; Fill Date
SET SUB2=0
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"PAT",SUB1,SUB2))
IF 'SUB2
QUIT
Begin DoDot:4
+20 ; Drug Name
SET SUB3=""
FOR
SET SUB3=$ORDER(^TMP($JOB,"XREF",DIV,"PAT",SUB1,SUB2,SUB3))
IF '$LENGTH(SUB3)
QUIT
Begin DoDot:5
+21 ; Data node
SET SUB4=0
FOR
SET SUB4=$ORDER(^TMP($JOB,"XREF",DIV,"PAT",SUB1,SUB2,SUB3,SUB4))
IF 'SUB4
QUIT
Begin DoDot:6
+22 DO PRINT2(^TMP($JOB,"DATA",SUB4))
+23 SET DFLG=1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+24 ; Provider
IF APSPSORT=4
Begin DoDot:2
+25 ; Provider
SET SUB1=""
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"PRV",SUB1))
IF '$LENGTH(SUB1)
QUIT
Begin DoDot:3
+26 ; Drug Name
SET SUB2=""
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"PRV",SUB1,SUB2))
IF '$LENGTH(SUB2)
QUIT
Begin DoDot:4
+27 ; Fill Date
SET SUB3=0
FOR
SET SUB3=$ORDER(^TMP($JOB,"XREF",DIV,"PRV",SUB1,SUB2,SUB3))
IF 'SUB3
QUIT
Begin DoDot:5
+28 ; Data node
SET SUB4=0
FOR
SET SUB4=$ORDER(^TMP($JOB,"XREF",DIV,"PRV",SUB1,SUB2,SUB3,SUB4))
IF 'SUB4
QUIT
Begin DoDot:6
+29 DO PRINT2(^TMP($JOB,"DATA",SUB4))
+30 SET DFLG=1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+31 QUIT
+32 ; Print the line
PRINT2(DATA) ; EP -
+1 NEW RX,DFN,HRN
+2 IF $PIECE(DATA,U,3)="APSP"
Begin DoDot:1
+3 DO APSPINV(+DATA)
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET RX=+DATA
+6 SET DFN=$$GET1^DIQ(52,RX,2,"I")
+7 SET HRN=$$HRN^AUPNPAT(DFN,DUZ(2))
+8 DO PRINT3($PIECE(DATA,U,16)+1)
+9 WRITE !,$PIECE($TRANSLATE($$FMTE^XLFDT($PIECE(DATA,U,2),"5Z"),"@"," "),":",1,2),?14,$PIECE(DATA,U,9),?20,$EXTRACT($$GET1^DIQ(2,DFN,.01),1,16),?38,HRN,?48,$$GET1^DIQ(52,RX,.01),?60,$PIECE(DATA,U,8)
+10 DO INTOUT(RX)
End DoDot:1
+11 ;check page length
DO PRINT3()
+12 QUIT
+13 ; Check page length and optionally print blank line
+14 ;
PRINT3(ADD) ;EP
+1 SET ADD=$GET(ADD,0)
+2 IF ($Y+9+ADD)>IOSL
DO HDR
+3 QUIT
+4 ;
HDR ;EP
+1 IF APSPPG
WRITE @IOF
+2 SET APSPPG=APSPPG+1
SET NEWPG=1
+3 WRITE !,"Critical Drug Interaction Report",?(IOM-28),$PIECE($TRANSLATE($$FMTE^XLFDT($$NOW^XLFDT,"5Z"),"@"," "),":",1,2),?(IOM-10),"Page: "_APSPPG
+4 WRITE !,"Report Criteria:"
+5 WRITE !,?5,"Inclusive Dates: "_APSPBDF_" to "_APSPEDF
+6 WRITE !,?5,"Pharmacy Division: "_$SELECT(APSPDIV:$$GET1^DIQ(59,APSPDIV,.01),1:"All")
+7 WRITE !,?5,"Sorted by: "_$SELECT(APSPSORT=1:"Drug Name, Fill Date",APSPSORT=2:"Fill Date then Drug Name",APSPSORT=3:"Patient then Fill Date",4:"Prescriber then Drug Name, Fill Date",1:"Unknown")
+8 IF APSPSORT=3
IF APSPPAT
WRITE !,?7,"Patient sort restricted to ",$$GET1^DIQ(2,APSPPAT,.01)
+9 IF APSPSORT=4
IF APSPPRV
WRITE !,?7,"Prescriber sort restricted to ",$$GET1^DIQ(200,APSPPRV,.01)
+10 DO HDR1
+11 QUIT
+12 ;
HDR1 ;EP
+1 DO DASH
+2 WRITE "Date Disp.",?14,"Type",?20,"Patient",?40,"HRN",?48,"Rx Number",?60,"Drug Name"
+3 WRITE !,?37,"Overriding Provider"
+4 WRITE !,?7,"Overriding Reason"
+5 WRITE !,"Cause"
+6 DO DASH
+7 QUIT
+8 ;
DASH ;EP
+1 NEW DASH
+2 WRITE !
FOR DASH=1:1:IOM
WRITE "-"
+3 WRITE !
+4 QUIT
+5 ; Output order check information
INTOUT(RX) ;EP-
+1 NEW IEN,CNT,ORDID,IENS,CAUSE
+2 SET (IEN,CNT)=0
+3 SET ORDID=$PIECE(^PSRX(RX,"OR1"),U,2)
+4 FOR
SET IEN=$ORDER(^OR(100,ORDID,9,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(100.8,$PIECE($GET(^OR(100,+ORDID,9,IEN,0)),U),.01)'="CRITICAL DRUG INTERACTION"
QUIT
+6 SET IENS=IEN_","_ORDID_","
+7 WRITE !,?5,$$GET1^DIQ(100.09,IENS,.01),?37,$$GET1^DIQ(100.09,IENS,.05)
+8 WRITE !,?7,$$GET1^DIQ(100.09,IENS,.04)
+9 SET CAUSE=$PIECE($GET(^OR(100,+ORDID,9,IEN,1)),":",2)
+10 IF $LENGTH(CAUSE)
Begin DoDot:2
+11 WRITE !,$SELECT($LENGTH(CAUSE)>IOM:$EXTRACT(CAUSE,1,IOM-3)_"...",1:CAUSE)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ; Output APSP Intervention
APSPINV(IEN) ;EP-
+1 NEW FN,DFN,NODE0
+2 SET FN=9009032.4
+3 SET NODE0=^APSPQA(32.4,IEN,0)
+4 SET DFN=$PIECE(NODE0,U,2)
+5 WRITE !,?5,$PIECE($TRANSLATE($$FMTE^XLFDT($PIECE(NODE0,U),"5Z"),"@"," "),":",1,2),?21,$$GET1^DIQ(2,DFN,.01),?51,$$HRN^AUPNPAT(DFN,$$GET1^DIQ(59,$PIECE(NODE0,U,16),100,"I")),?58,$$GET1^DIQ(FN,IEN,.05)
+6 WRITE !,?7,$$GET1^DIQ(200,$PIECE(NODE0,U,4),.01),?49,$$GET1^DIQ(FN,IEN,.08)
+7 WRITE !,"Critical Drug Interaction over-ridden in RPMS Pharmacy Package"
+8 QUIT
