ORKPS1 ; slc/CLA - Order checking support procedures for medications ;12/15/97 [8/2/05 7:46am]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**232**;Dec 17, 1997;Build 19
Q
PROCESS(OI,DFN,ORKDG) ;process data from pharmacy order check API
Q:'$D(^TMP($J))
N II,XX,ZZ,ZZD,ORTYPE,ORMTYPE,ORN,ORZ,RCNT
S II=1,XX=0,ZZ="",ZZD="",RCNT=0
;
;check to determine if inpatient or outpatient:
I $L(ORKDG) S ORTYPE=$S($G(ORKDG)="PSI":"I",$G(ORKDG)="PSO":"O",$G(ORKDG)="PSIV":"I",$G(ORKDG)="PSH":"O",1:"")
I '$L(ORTYPE) D ;if no display group
.D ADM^VADPT2
.S ORTYPE=$S(+$G(VADMVT)>0:"I",1:"O")
.K VADMVT
;
; drug-drug interactions:
F S XX=$O(^TMP($J,"DI",XX)) Q:XX<1 D
.S ZZ=$G(^TMP($J,"DI",XX,0))
.S ORN=$P($P(ZZ,U,7),";"),ORZ=""
.I '$G(ORN),$L($G(^TMP($J,"DI",XX,1))) D Q
..N ORTXT,ORLEN,ORFAC,END
..S RCNT=RCNT+1
..S $P(ZZ,U,7)="R"_RCNT
..S ORFAC=$P(ZZ,U,9)
..S ORTXT=$P(^TMP($J,"DI",XX,1),U)_" "
..I $L(ORTXT)<242 S ORLEN=242-$L(ORTXT),ORTXT=ORTXT_$E(^TMP($J,"DI",XX,1,0),1,ORLEN)
..S OREND="["_$P(^TMP($J,"DI",XX,1),U,2)_" - Last Fill: "_$P(^TMP($J,"DI",XX,1),U,3)_" Quantity Dispensed: "_$P(^TMP($J,"DI",XX,1),U,5)_"] >> "_ORFAC
..N ORMAX S ORMAX=250-$L(OREND)-50-$L($P(ZZ,U,4))-$L($P(ZZ,U,5))-$L($P(ZZ,U,6))-$L($P(ZZ,U,7))
..I ORTXT'=$E(ORTXT,1,ORMAX) S OREND="..."_OREND
..S ORTXT=$E(ORTXT,1,ORMAX)_OREND
..S $P(ZZ,U,2)=ORTXT
..S YY(II)="DI^"_ZZ,II=II+1
.I $L(ORN),$D(^OR(100,ORN,8,0)) S ORZ=^OR(100,ORN,8,0)
.I $L($G(ORZ)),($P(^OR(100,ORN,8,$P(ORZ,U,3),0),U,2)="DC") Q
.I $L(ORN),$P(^ORD(100.01,$P(^OR(100,ORN,3),U,3),0),U)="DISCONTINUED" Q
.I ZZ'="" S YY(II)="DI^"_ZZ,II=II+1
;
; duplicate drugs:
Q:$$SOLUT^ORKPS(OI) ;quit if the orderable item is a solution
;require that we do not perform dup drug/class OCs for solutions)
S XX=0,ZZ=""
F S XX=$O(^TMP($J,"DD",XX)) Q:XX<1 D
.S ZZ=$G(^TMP($J,"DD",XX,0)),ORMTYPE=$P($P(ZZ,U,4),";",2)
.I $G(ORTYPE)'=$G(ORMTYPE),'$L($G(^TMP($J,"DD",XX,1))) Q
.S ORN=$P($P(ZZ,U,3),";"),ORZ=""
.I '$G(ORN),$L($G(^TMP($J,"DD",XX,1))) D Q
..Q:$$SUPPLY^ORKPS(OI) ;quit if the orderable item is a supply and it is against remote data
..N ORTXT,ORLEN,ORFAC,OREND
..S RCNT=RCNT+1
..S $P(ZZ,U,3)="R"_RCNT
..S ORFAC=$P(ZZ,U,5)
..S ORTXT=$P(^TMP($J,"DD",XX,1),U)_" "
..I $L(ORTXT)<242 S ORLEN=242-$L(ORTXT),ORTXT=ORTXT_$E(^TMP($J,"DD",XX,1,0),1,ORLEN)
..S OREND="["_$P(^TMP($J,"DD",XX,1),U,2)_" - Last Fill: "_$P(^TMP($J,"DD",XX,1),U,3)_" Quantity Dispensed: "_$P(^TMP($J,"DD",XX,1),U,5)_"] >> "_ORFAC
..N ORMAX S ORMAX=250-$L(OREND)-40-$L($P(ZZ,U,4))
..I ORTXT'=$E(ORTXT,1,ORMAX) S OREND="..."_OREND
..S ORTXT=$E(ORTXT,1,ORMAX)_OREND
..S $P(ZZ,U,2)=ORTXT
..S YY(II)="DD^"_ZZ,II=II+1
.Q:+$G(ORN)=+$G(ORIFN) ;QUIT if dup med ord # = current ord #
.I $L(ORN),$D(^OR(100,ORN,8,0)) S ORZ=^OR(100,ORN,8,0)
.I $L($G(ORZ)),($P(^OR(100,ORN,8,$P(ORZ,U,3),0),U,2)="DC") Q
.I $L(ORN),$P(^ORD(100.01,$P(^OR(100,ORN,3),U,3),0),U)="DISCONTINUED" Q
.I ZZ'="" S YY(II)="DD^"_ZZ,II=II+1
;
; duplicate classes:
Q:$$SUPPLY^ORKPS(OI) ;quit if the orderable item is a supply
S XX=0,ZZ=""
F S XX=$O(^TMP($J,"DC",XX)) Q:XX<1 D
.S ZZ=$G(^TMP($J,"DC",XX,0)),ORMTYPE=$P($P(ZZ,U,6),";",2)
.I $G(ORTYPE)'=$G(ORMTYPE),'$L($G(^TMP($J,"DC",XX,1))) Q
.S ORN=$P($P(ZZ,U,5),";"),ORZ=""
.I '$G(ORN),$L($G(^TMP($J,"DC",XX,1))) D Q
..N ORTXT,ORLEN,ORFAC,OREND
..S RCNT=RCNT+1
..S $P(ZZ,U,5)="R"_RCNT
..S ORFAC=$P(ZZ,U,7)
..S ORTXT=$P(^TMP($J,"DC",XX,1),U)_" "
..I $L(ORTXT)<242 S ORLEN=242-$L(ORTXT),ORTXT=ORTXT_$E(^TMP($J,"DC",XX,1,0),1,ORLEN)
..S OREND="["_$P(^TMP($J,"DC",XX,1),U,2)_" - Last Fill: "_$P(^TMP($J,"DC",XX,1),U,3)_" Quantity Dispensed: "_$P(^TMP($J,"DC",XX,1),U,5)_"] >> "_ORFAC
..N ORMAX S ORMAX=250-$L(OREND)-50-$L($P(ZZ,U,2))-$L($P(ZZ,U,5))
..I ORTXT'=$E(ORTXT,1,ORMAX) S OREND="..."_OREND
..S ORTXT=$E(ORTXT,1,ORMAX)_OREND
..S $P(ZZ,U,4)=ORTXT
..S YY(II)="DC^"_ZZ,II=II+1
.Q:+$G(ORN)=+$G(ORIFN) ;QUIT if dup class ord # = current ord #
.I $L(ORN),$D(^OR(100,ORN,8,0)) S ORZ=^OR(100,ORN,8,0)
.I $L($G(ORZ)),($P(^OR(100,ORN,8,$P(ORZ,U,3),0),U,2)="DC") Q
.I $L(ORN),$P(^ORD(100.01,$P(^OR(100,ORN,3),U,3),0),U)="DISCONTINUED" Q
.I ZZ'="" S YY(II)="DC^"_ZZ,II=II+1
Q
ORKPS1 ; slc/CLA - Order checking support procedures for medications ;12/15/97 [8/2/05 7:46am]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**232**;Dec 17, 1997;Build 19
+2 QUIT
PROCESS(OI,DFN,ORKDG) ;process data from pharmacy order check API
+1 IF '$DATA(^TMP($JOB))
QUIT
+2 NEW II,XX,ZZ,ZZD,ORTYPE,ORMTYPE,ORN,ORZ,RCNT
+3 SET II=1
SET XX=0
SET ZZ=""
SET ZZD=""
SET RCNT=0
+4 ;
+5 ;check to determine if inpatient or outpatient:
+6 IF $LENGTH(ORKDG)
SET ORTYPE=$SELECT($GET(ORKDG)="PSI":"I",$GET(ORKDG)="PSO":"O",$GET(ORKDG)="PSIV":"I",$GET(ORKDG)="PSH":"O",1:"")
+7 ;if no display group
IF '$LENGTH(ORTYPE)
Begin DoDot:1
+8 DO ADM^VADPT2
+9 SET ORTYPE=$SELECT(+$GET(VADMVT)>0:"I",1:"O")
+10 KILL VADMVT
End DoDot:1
+11 ;
+12 ; drug-drug interactions:
+13 FOR
SET XX=$ORDER(^TMP($JOB,"DI",XX))
IF XX<1
QUIT
Begin DoDot:1
+14 SET ZZ=$GET(^TMP($JOB,"DI",XX,0))
+15 SET ORN=$PIECE($PIECE(ZZ,U,7),";")
SET ORZ=""
+16 IF '$GET(ORN)
IF $LENGTH($GET(^TMP($JOB,"DI",XX,1)))
Begin DoDot:2
+17 NEW ORTXT,ORLEN,ORFAC,END
+18 SET RCNT=RCNT+1
+19 SET $PIECE(ZZ,U,7)="R"_RCNT
+20 SET ORFAC=$PIECE(ZZ,U,9)
+21 SET ORTXT=$PIECE(^TMP($JOB,"DI",XX,1),U)_" "
+22 IF $LENGTH(ORTXT)<242
SET ORLEN=242-$LENGTH(ORTXT)
SET ORTXT=ORTXT_$EXTRACT(^TMP($JOB,"DI",XX,1,0),1,ORLEN)
+23 SET OREND="["_$PIECE(^TMP($JOB,"DI",XX,1),U,2)_" - Last Fill: "_$PIECE(^TMP($JOB,"DI",XX,1),U,3)_" Quantity Dispensed: "_$PIECE(^TMP($JOB,"DI",XX,1),U,5)_"] >> "_ORFAC
+24 NEW ORMAX
SET ORMAX=250-$LENGTH(OREND)-50-$LENGTH($PIECE(ZZ,U,4))-$LENGTH($PIECE(ZZ,U,5))-$LENGTH($PIECE(ZZ,U,6))-$LENGTH($PIECE(ZZ,U,7))
+25 IF ORTXT'=$EXTRACT(ORTXT,1,ORMAX)
SET OREND="..."_OREND
+26 SET ORTXT=$EXTRACT(ORTXT,1,ORMAX)_OREND
+27 SET $PIECE(ZZ,U,2)=ORTXT
+28 SET YY(II)="DI^"_ZZ
SET II=II+1
End DoDot:2
QUIT
+29 IF $LENGTH(ORN)
IF $DATA(^OR(100,ORN,8,0))
SET ORZ=^OR(100,ORN,8,0)
+30 IF $LENGTH($GET(ORZ))
IF ($PIECE(^OR(100,ORN,8,$PIECE(ORZ,U,3),0),U,2)="DC")
QUIT
+31 IF $LENGTH(ORN)
IF $PIECE(^ORD(100.01,$PIECE(^OR(100,ORN,3),U,3),0),U)="DISCONTINUED"
QUIT
+32 IF ZZ'=""
SET YY(II)="DI^"_ZZ
SET II=II+1
End DoDot:1
+33 ;
+34 ; duplicate drugs:
+35 ;quit if the orderable item is a solution
IF $$SOLUT^ORKPS(OI)
QUIT
+36 ;require that we do not perform dup drug/class OCs for solutions)
+37 SET XX=0
SET ZZ=""
+38 FOR
SET XX=$ORDER(^TMP($JOB,"DD",XX))
IF XX<1
QUIT
Begin DoDot:1
+39 SET ZZ=$GET(^TMP($JOB,"DD",XX,0))
SET ORMTYPE=$PIECE($PIECE(ZZ,U,4),";",2)
+40 IF $GET(ORTYPE)'=$GET(ORMTYPE)
IF '$LENGTH($GET(^TMP($JOB,"DD",XX,1)))
QUIT
+41 SET ORN=$PIECE($PIECE(ZZ,U,3),";")
SET ORZ=""
+42 IF '$GET(ORN)
IF $LENGTH($GET(^TMP($JOB,"DD",XX,1)))
Begin DoDot:2
+43 ;quit if the orderable item is a supply and it is against remote data
IF $$SUPPLY^ORKPS(OI)
QUIT
+44 NEW ORTXT,ORLEN,ORFAC,OREND
+45 SET RCNT=RCNT+1
+46 SET $PIECE(ZZ,U,3)="R"_RCNT
+47 SET ORFAC=$PIECE(ZZ,U,5)
+48 SET ORTXT=$PIECE(^TMP($JOB,"DD",XX,1),U)_" "
+49 IF $LENGTH(ORTXT)<242
SET ORLEN=242-$LENGTH(ORTXT)
SET ORTXT=ORTXT_$EXTRACT(^TMP($JOB,"DD",XX,1,0),1,ORLEN)
+50 SET OREND="["_$PIECE(^TMP($JOB,"DD",XX,1),U,2)_" - Last Fill: "_$PIECE(^TMP($JOB,"DD",XX,1),U,3)_" Quantity Dispensed: "_$PIECE(^TMP($JOB,"DD",XX,1),U,5)_"] >> "_ORFAC
+51 NEW ORMAX
SET ORMAX=250-$LENGTH(OREND)-40-$LENGTH($PIECE(ZZ,U,4))
+52 IF ORTXT'=$EXTRACT(ORTXT,1,ORMAX)
SET OREND="..."_OREND
+53 SET ORTXT=$EXTRACT(ORTXT,1,ORMAX)_OREND
+54 SET $PIECE(ZZ,U,2)=ORTXT
+55 SET YY(II)="DD^"_ZZ
SET II=II+1
End DoDot:2
QUIT
+56 ;QUIT if dup med ord # = current ord #
IF +$GET(ORN)=+$GET(ORIFN)
QUIT
+57 IF $LENGTH(ORN)
IF $DATA(^OR(100,ORN,8,0))
SET ORZ=^OR(100,ORN,8,0)
+58 IF $LENGTH($GET(ORZ))
IF ($PIECE(^OR(100,ORN,8,$PIECE(ORZ,U,3),0),U,2)="DC")
QUIT
+59 IF $LENGTH(ORN)
IF $PIECE(^ORD(100.01,$PIECE(^OR(100,ORN,3),U,3),0),U)="DISCONTINUED"
QUIT
+60 IF ZZ'=""
SET YY(II)="DD^"_ZZ
SET II=II+1
End DoDot:1
+61 ;
+62 ; duplicate classes:
+63 ;quit if the orderable item is a supply
IF $$SUPPLY^ORKPS(OI)
QUIT
+64 SET XX=0
SET ZZ=""
+65 FOR
SET XX=$ORDER(^TMP($JOB,"DC",XX))
IF XX<1
QUIT
Begin DoDot:1
+66 SET ZZ=$GET(^TMP($JOB,"DC",XX,0))
SET ORMTYPE=$PIECE($PIECE(ZZ,U,6),";",2)
+67 IF $GET(ORTYPE)'=$GET(ORMTYPE)
IF '$LENGTH($GET(^TMP($JOB,"DC",XX,1)))
QUIT
+68 SET ORN=$PIECE($PIECE(ZZ,U,5),";")
SET ORZ=""
+69 IF '$GET(ORN)
IF $LENGTH($GET(^TMP($JOB,"DC",XX,1)))
Begin DoDot:2
+70 NEW ORTXT,ORLEN,ORFAC,OREND
+71 SET RCNT=RCNT+1
+72 SET $PIECE(ZZ,U,5)="R"_RCNT
+73 SET ORFAC=$PIECE(ZZ,U,7)
+74 SET ORTXT=$PIECE(^TMP($JOB,"DC",XX,1),U)_" "
+75 IF $LENGTH(ORTXT)<242
SET ORLEN=242-$LENGTH(ORTXT)
SET ORTXT=ORTXT_$EXTRACT(^TMP($JOB,"DC",XX,1,0),1,ORLEN)
+76 SET OREND="["_$PIECE(^TMP($JOB,"DC",XX,1),U,2)_" - Last Fill: "_$PIECE(^TMP($JOB,"DC",XX,1),U,3)_" Quantity Dispensed: "_$PIECE(^TMP($JOB,"DC",XX,1),U,5)_"] >> "_ORFAC
+77 NEW ORMAX
SET ORMAX=250-$LENGTH(OREND)-50-$LENGTH($PIECE(ZZ,U,2))-$LENGTH($PIECE(ZZ,U,5))
+78 IF ORTXT'=$EXTRACT(ORTXT,1,ORMAX)
SET OREND="..."_OREND
+79 SET ORTXT=$EXTRACT(ORTXT,1,ORMAX)_OREND
+80 SET $PIECE(ZZ,U,4)=ORTXT
+81 SET YY(II)="DC^"_ZZ
SET II=II+1
End DoDot:2
QUIT
+82 ;QUIT if dup class ord # = current ord #
IF +$GET(ORN)=+$GET(ORIFN)
QUIT
+83 IF $LENGTH(ORN)
IF $DATA(^OR(100,ORN,8,0))
SET ORZ=^OR(100,ORN,8,0)
+84 IF $LENGTH($GET(ORZ))
IF ($PIECE(^OR(100,ORN,8,$PIECE(ORZ,U,3),0),U,2)="DC")
QUIT
+85 IF $LENGTH(ORN)
IF $PIECE(^ORD(100.01,$PIECE(^OR(100,ORN,3),U,3),0),U)="DISCONTINUED"
QUIT
+86 IF ZZ'=""
SET YY(II)="DC^"_ZZ
SET II=II+1
End DoDot:1
+87 QUIT
