- 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
