ORPR07 ; slc/dcm - Printless in Tuscaloosa ;6/10/97 15:36
;;3.0;ORDER ENTRY/RESULTS REPORTING;**15,11,94,141**;Dec 17, 1997
ORDT(IFN,ACT) ;Get order date
;IFN=ORIFN
;ACT=DA of action
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y
S X="" I $G(ACT) S Y=$$ACT(IFN,ACT) Q +Y
S X=$P(^OR(100,IFN,0),"^",7)
Q X
ACT(IFN,ACT) ;This is an action
N X
Q:'$D(^OR(100,+$G(IFN),8,+$G(ACT),0)) "" S X=^(0)
Q X
VNURSE(IFN,ACT) ;Get verifying nurse data
;Returns 1^name^initials^title^date/time verified if data, "" if not
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y,Z S X=""
I $G(ACT) S Y=$$ACT(IFN,ACT),Z=$G(^VA(200,+$P(Y,"^",8),0)) I $L(Z) S X=1_"^"_$P(Z,"^")_"^"_$P(Z,"^",2)_"^"_$P($G(^DIC(3.1,+$P(Z,"^",9),0)),"^")_"^"_$P(Y,"^",9)
Q X
VCLERK(IFN,ACT) ;Get verifying clerk data
;Returns 1^name^initials^title^date/time verified if data, "" if not
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y,Z S X=""
I $G(ACT) S Y=$$ACT(IFN,ACT),Z=$G(^VA(200,+$P(Y,"^",10),0)) I $L(Z) S X=1_"^"_$P(Z,"^")_"^"_$P(Z,"^",2)_"^"_$P($G(^DIC(3.1,+$P(Z,"^",9),0)),"^")_"^"_$P(Y,"^",11)
Q X
RVIEW(IFN,ACT) ;Get Chart reviewed by data
;Returns 1^name^initials^titel^date/time reviewed, "" if not
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y,Z S X=""
I $G(ACT) S Y=$$ACT(IFN,ACT),Z=$G(^VA(200,+$P(Y,"^",18),0)) I $L(Z) S X=1_"^"_$P(Z,"^")_"^"_$P(Z,"^",2)_"^"_$P($G(^DIC(3.1,+$P(Z,"^",9),0)),"^")_"^"_$P(Y,"^",19)
Q X
ORDOC(IFN,ACT) ;Get Ordering provider
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y,Z
S X=""
I $G(ACT) S Y=$$ACT(IFN,ACT),Z=$G(^VA(200,+$P(Y,"^",3),0)) I $L(Z) S X=$P(Z,"^")
I '$L(X) S Y=$P(^OR(100,IFN,0),"^",4),Z=$G(^VA(200,+Y,0)) I $L(Z) S X=$P(Z,"^")
Q X
PHONE(IFN,ACT,PIECE) ;Get Ordering provider's phone number (multiple choice)
;PIECE=the piece of data to get from node ^VA(200,DUZ,.13)
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
Q:'$G(PIECE)
N X,Y,Z
S X=""
I $G(ACT) S Y=$$ACT(IFN,ACT),Z=$G(^VA(200,+$P(Y,"^",3),.13)) I $L(Z) S X=$P(Z,"^",PIECE) Q X
S Y=$P(^OR(100,IFN,0),"^",4) S:Y X=$P($G(^VA(200,Y,.13)),"^",PIECE)
Q X
NAT(IFN,ACT) ;Get Nature of order
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y
S X=""
I $G(ACT) S Y=$P($$ACT(IFN,ACT),"^",12),X=$S($D(^ORD(100.02,+Y,0)):$P(^(0),"^"),1:"")
Q X
ESNAME(IFN,ACT) ;Get Electronic Sig Name
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y
S X=""
I $G(ACT) S Y=$$ACT(IFN,ACT) D Q X
. I $P(Y,"^",5) S X=$P($G(^VA(200,$P(Y,"^",5),20)),"^",2) S:$L(X) X=$S($P(Y,"^",4)=7:"/ds/",1:"/es/")_X Q
. I $P(Y,"^",4),"42"[$P(Y,"^",4) S X="_______________" Q
Q X
ESTIT(IFN,ACT) ;Get Electronic Sig Title
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y
S X="" I $G(ACT) S Y=$$ACT(IFN,ACT) S:$P(Y,"^",5) X=$E($P($G(^VA(200,$P(Y,"^",5),20)),"^",3),1,20)
Q X
ESDATE(IFN,ACT) ;Get Electronic Sig Date
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X
S X=""
I $G(ACT) S X=$P($$ACT(IFN,ACT),"^",6)
Q X
ESODATE(IFN,ACT) ;Get Date/time Signed online
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X
S X=""
I $G(ACT),$P($$ACT(IFN,ACT),"^",4)=1 S X=$P($$ACT(IFN,ACT),"^",6)
Q X
ENTBY(IFN,ACT) ;Get Entered by
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y
S X="" I $G(ACT) S Y=$$ACT(IFN,ACT) S:$P(Y,"^",13) X=$P($G(^VA(200,$P(Y,"^",13),0)),"^") Q X
S X=$P(^OR(100,IFN,0),"^",6) S:X X=$P(^VA(200,X,0),"^")
Q X
ENTINT(IFN,ACT) ;Get Entered by Initials
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y
S X="" I $G(ACT) S Y=$$ACT(IFN,ACT) S:$P(Y,"^",13) X=$P($G(^VA(200,$P(Y,"^",13),0)),"^",2) Q X
S X=$P(^OR(100,IFN,0),"^",6) S:X X=$P(^VA(200,X,0),"^",2)
Q X
ENTIT(IFN,ACT) ;Get Electronic Sig Title of Entering Person
Q:'$G(IFN) ""
Q:'$D(^OR(100,IFN,0)) ""
N X,Y
S X="" I $G(ACT) S Y=$$ACT(IFN,ACT) S:$P(Y,"^",13) X=$E($P($G(^VA(200,$P(Y,"^",13),20)),"^",3),1,20) Q X
S X=$P(^OR(100,IFN,0),"^",6) S:X X=$E($P(^VA(200,X,20),"^",3),1,20)
Q X
BY(ORIFN) ;Get DC info for DC by & when PRINT FIELD
Q:'$G(ORIFN) ""
N Y,Z,X6,X1,ORDCBY
I $P($G(^OR(100,ORIFN,6)),"^",2) S X6=^(6) D Q ORDCBY
. S Y=+$J($P(X6,"^",3),0,4),Z=$G(^VA(200,+$P(X6,"^",2),0)) I $L(Z) S X1=$P(Z,"^")_$S($P(Z,"^",9):" ("_$E($P(^DIC(3.1,$P(Z,"^",9),0),"^"),1,10)_")",1:""),Y=$$DATE^ORU(Y)_" "_$$TIME^ORU(Y)
. S ORDCBY="DC'ed "_$S(+$P(X6,"^",4):"("_$P(^ORD(100.03,+$P(X6,"^",4),0),"^")_")",1:"")_" by:"_X1_" "_Y
Q ""
WARDREM(ORIFN) ;Get Ward Remarks
N ORI,X
S X=""
I $G(ORIFN) S ORI=$O(^OR(100,ORIFN,4.5,"ID","COMMENT",0)) I ORI S X="^OR(100,"_+ORIFN_",4.5,"_ORI_",2)"
Q X
RX(IFN,FLD,Y) ;Get Pharmacy Fields
;IFN=internal # of 100
;FLD=code for RX field to lookup
;Y=output returned in Y
Q:'$G(IFN) Q:'$L($G(FLD))
Q:'$D(^OR(100,IFN,0))
N X,X4,PKG,DFN,I S X=^OR(100,IFN,0),X4=$G(^(4)) Q:'$L(X4)
S PKG=$P(X,"^",14) Q:'PKG
S PKG=$S($P(^DIC(9.4,PKG,0),"^")="INPATIENT MEDICATIONS":"I",$P(^(0),"^")="OUTPATIENT MEDICATIONS":"O",$P(^(0),"^")="IV MEDICATIONS":"I",$P(^(0),"^")="UNIT DOSE MEDICATIONS":"I",1:"") Q:'$L(PKG)
S DFN=+$P(X,"^",2)
D OEL^PSOORRL(DFN,X4_";"_PKG)
I FLD="SI" S Y=$P($G(^TMP("PS",$J,"SI")),"^",1,99) Q ;Special Instructions
I FLD="SCH" S I=0 D Q ;Schedule & Admin Times
. F S I=$O(^TMP("PS",$J,"SCH",I)) Q:I<1 S Y(I)=$P(^(I,0),"^") ;_" "_$P(^(0),"^",2)
I FLD="OTH" S Y=$P($G(^TMP("PS",$J,"OPI")),1,99) Q ;Other print info
I FLD="DRUG" S Y=$P($G(^TMP("PS",$J,0)),"^") Q ;Drug
I FLD="INF" S Y=$P($G(^TMP("PS",$J,0)),"^",2) Q ;Infusion rate
I FLD="STOP" S Y=$P($G(^TMP("PS",$J,0)),"^",3) Q ;Stop date
I FLD="REFIL" S Y=$P($G(^TMP("PS",$J,0)),"^",4) Q ;Refills
I FLD="MDRT" S I=0 D Q ;Med Route
. F S I=$O(^TMP("PS",$J,"MDR",I)) Q:I<1 S Y(I)=^(I,0)
I FLD="SIG" S I=0 D Q ;SIG (outpat) Instructions (inpat)
. F S I=$O(^TMP("PS",$J,"SIG",I)) Q:I<1 S Y(I)=^(I,0)
I FLD="PC" S I=0 D Q ;Provider comments
. F S I=$O(^TMP("PS",$J,"PC",I)) Q:I<1 S Y(I)=^(I,0)
I FLD="ADD" S I=0 D Q ;Additive, amount, bottle
. F S I=$O(^TMP("PS",$J,"A",I)) Q:I<1 S Y(I)=$P(^(I,0),"^")_" "_$P(^(0),"^",2)_" #"_$P(^(0),"^",3)
I FLD="SOL" S I=0 D Q ;Solution & amount
. F S I=$O(^TMP("PS",$J,"B",I)) Q:I<1 S Y(I)=$P(^(I,0),"^")_" "_$P(^(0),"^",2)
Q
TEST ;Test RX call
W !,"Enter Pharmacy Order # (ORIFN): " R X:DTIME Q:X=""!(X["^") I '$D(^OR(100,+$G(X),0)) W !,$C(7),X_" does not exist" G TEST
S ORIFN=X F ORI="SCH","SI","ADM","OTH","DRUG","INF","STOP","REFIL","MDRT","SIG","PC","ADD","SOL" K TEST D RX(ORIFN,ORI,.TEST) I $D(TEST) W !,ORI_"- " ;ZW TEST
Q
LABEL(Y,ORIFN,QUIET,OACTION) ;Print pharmacy label
I $G(ORTEST) D TEST1 Q
N X,X4,ORC
Q:'$D(^OR(100,+$G(ORIFN),0)) Q:'$L($G(^(4))) S X=^(0),X4=^(4)
I $S($P($G(^DIC(9.4,+$P(X,"^",14),0)),"^")="INPATIENT MEDICATIONS":0,$P($G(^DIC(9.4,+$P(X,"^",14),0)),"^")="IV MEDICATIONS":0,$P($G(^DIC(9.4,+$P(X,"^",14),0)),"^")="UNIT DOSE MEDICATIONS":0,1:1) Q
N LINES,ORXPTMP,I,ACT
I $G(OACTION),$D(^OR(100,+$G(ORIFN),8,OACTION,0)) S ACT=$P(^(0),"^",2)
I $L($T(MAR^PSJORMAR),",")>4 D MAR^PSJORMAR(+$P(X,"^",2),$P(X4,"^"),1,.LINES,$G(ACT))
I $L($T(MAR^PSJORMAR),",")'>4 D MAR^PSJORMAR(+$P(X,"^",2),$P(X4,"^"),1,.LINES)
I $G(QUIET) K Y S (I,Y)=0 D Q
. F S I=$O(LINES(I)) Q:'I S Y(I,0)=LINES(I),ORPICKUP=I
S (ORC,I)=0
I '$D(ORIOSL) N ORIOSL S ORIOSL=$S($D(IOSL):IOSL,1:50)
I '$D(ORIOF) N ORIOF S ORIOF=$S($D(IOF):IOF,1:"!")
F S I=$O(LINES(I)) Q:I<1 S ORC=ORC+1 D
. I $Y>(ORIOSL-2) W @ORIOF S ORC=1
. W:ORC>1 ! W LINES(I)
Q
TEST1 ;Print test label
W !,"03/03 | | (F1990)|"
W !,"Test Pharmacy Label"
W !,"Give: 1GM TOP QD"
W !!," RPH: _____RN: _____|"
Q
ORPR07 ; slc/dcm - Printless in Tuscaloosa ;6/10/97 15:36
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**15,11,94,141**;Dec 17, 1997
ORDT(IFN,ACT) ;Get order date
+1 ;IFN=ORIFN
+2 ;ACT=DA of action
+3 IF '$GET(IFN)
QUIT ""
+4 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+5 NEW X,Y
+6 SET X=""
IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
QUIT +Y
+7 SET X=$PIECE(^OR(100,IFN,0),"^",7)
+8 QUIT X
ACT(IFN,ACT) ;This is an action
+1 NEW X
+2 IF '$DATA(^OR(100,+$GET(IFN),8,+$GET(ACT),0))
QUIT ""
SET X=^(0)
+3 QUIT X
VNURSE(IFN,ACT) ;Get verifying nurse data
+1 ;Returns 1^name^initials^title^date/time verified if data, "" if not
+2 IF '$GET(IFN)
QUIT ""
+3 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+4 NEW X,Y,Z
SET X=""
+5 IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
SET Z=$GET(^VA(200,+$PIECE(Y,"^",8),0))
IF $LENGTH(Z)
SET X=1_"^"_$PIECE(Z,"^")_"^"_$PIECE(Z,"^",2)_"^"_$PIECE($GET(^DIC(3.1,+$PIECE(Z,"^",9),0)),"^")_"^"_$PIECE(Y,"^",9)
+6 QUIT X
VCLERK(IFN,ACT) ;Get verifying clerk data
+1 ;Returns 1^name^initials^title^date/time verified if data, "" if not
+2 IF '$GET(IFN)
QUIT ""
+3 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+4 NEW X,Y,Z
SET X=""
+5 IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
SET Z=$GET(^VA(200,+$PIECE(Y,"^",10),0))
IF $LENGTH(Z)
SET X=1_"^"_$PIECE(Z,"^")_"^"_$PIECE(Z,"^",2)_"^"_$PIECE($GET(^DIC(3.1,+$PIECE(Z,"^",9),0)),"^")_"^"_$PIECE(Y,"^",11)
+6 QUIT X
RVIEW(IFN,ACT) ;Get Chart reviewed by data
+1 ;Returns 1^name^initials^titel^date/time reviewed, "" if not
+2 IF '$GET(IFN)
QUIT ""
+3 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+4 NEW X,Y,Z
SET X=""
+5 IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
SET Z=$GET(^VA(200,+$PIECE(Y,"^",18),0))
IF $LENGTH(Z)
SET X=1_"^"_$PIECE(Z,"^")_"^"_$PIECE(Z,"^",2)_"^"_$PIECE($GET(^DIC(3.1,+$PIECE(Z,"^",9),0)),"^")_"^"_$PIECE(Y,"^",19)
+6 QUIT X
ORDOC(IFN,ACT) ;Get Ordering provider
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X,Y,Z
+4 SET X=""
+5 IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
SET Z=$GET(^VA(200,+$PIECE(Y,"^",3),0))
IF $LENGTH(Z)
SET X=$PIECE(Z,"^")
+6 IF '$LENGTH(X)
SET Y=$PIECE(^OR(100,IFN,0),"^",4)
SET Z=$GET(^VA(200,+Y,0))
IF $LENGTH(Z)
SET X=$PIECE(Z,"^")
+7 QUIT X
PHONE(IFN,ACT,PIECE) ;Get Ordering provider's phone number (multiple choice)
+1 ;PIECE=the piece of data to get from node ^VA(200,DUZ,.13)
+2 IF '$GET(IFN)
QUIT ""
+3 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+4 IF '$GET(PIECE)
QUIT
+5 NEW X,Y,Z
+6 SET X=""
+7 IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
SET Z=$GET(^VA(200,+$PIECE(Y,"^",3),.13))
IF $LENGTH(Z)
SET X=$PIECE(Z,"^",PIECE)
QUIT X
+8 SET Y=$PIECE(^OR(100,IFN,0),"^",4)
IF Y
SET X=$PIECE($GET(^VA(200,Y,.13)),"^",PIECE)
+9 QUIT X
NAT(IFN,ACT) ;Get Nature of order
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X,Y
+4 SET X=""
+5 IF $GET(ACT)
SET Y=$PIECE($$ACT(IFN,ACT),"^",12)
SET X=$SELECT($DATA(^ORD(100.02,+Y,0)):$PIECE(^(0),"^"),1:"")
+6 QUIT X
ESNAME(IFN,ACT) ;Get Electronic Sig Name
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X,Y
+4 SET X=""
+5 IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
Begin DoDot:1
+6 IF $PIECE(Y,"^",5)
SET X=$PIECE($GET(^VA(200,$PIECE(Y,"^",5),20)),"^",2)
IF $LENGTH(X)
SET X=$SELECT($PIECE(Y,"^",4)=7:"/ds/",1:"/es/")_X
QUIT
+7 IF $PIECE(Y,"^",4)
IF "42"[$PIECE(Y,"^",4)
SET X="_______________"
QUIT
End DoDot:1
QUIT X
+8 QUIT X
ESTIT(IFN,ACT) ;Get Electronic Sig Title
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X,Y
+4 SET X=""
IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
IF $PIECE(Y,"^",5)
SET X=$EXTRACT($PIECE($GET(^VA(200,$PIECE(Y,"^",5),20)),"^",3),1,20)
+5 QUIT X
ESDATE(IFN,ACT) ;Get Electronic Sig Date
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X
+4 SET X=""
+5 IF $GET(ACT)
SET X=$PIECE($$ACT(IFN,ACT),"^",6)
+6 QUIT X
ESODATE(IFN,ACT) ;Get Date/time Signed online
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X
+4 SET X=""
+5 IF $GET(ACT)
IF $PIECE($$ACT(IFN,ACT),"^",4)=1
SET X=$PIECE($$ACT(IFN,ACT),"^",6)
+6 QUIT X
ENTBY(IFN,ACT) ;Get Entered by
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X,Y
+4 SET X=""
IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
IF $PIECE(Y,"^",13)
SET X=$PIECE($GET(^VA(200,$PIECE(Y,"^",13),0)),"^")
QUIT X
+5 SET X=$PIECE(^OR(100,IFN,0),"^",6)
IF X
SET X=$PIECE(^VA(200,X,0),"^")
+6 QUIT X
ENTINT(IFN,ACT) ;Get Entered by Initials
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X,Y
+4 SET X=""
IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
IF $PIECE(Y,"^",13)
SET X=$PIECE($GET(^VA(200,$PIECE(Y,"^",13),0)),"^",2)
QUIT X
+5 SET X=$PIECE(^OR(100,IFN,0),"^",6)
IF X
SET X=$PIECE(^VA(200,X,0),"^",2)
+6 QUIT X
ENTIT(IFN,ACT) ;Get Electronic Sig Title of Entering Person
+1 IF '$GET(IFN)
QUIT ""
+2 IF '$DATA(^OR(100,IFN,0))
QUIT ""
+3 NEW X,Y
+4 SET X=""
IF $GET(ACT)
SET Y=$$ACT(IFN,ACT)
IF $PIECE(Y,"^",13)
SET X=$EXTRACT($PIECE($GET(^VA(200,$PIECE(Y,"^",13),20)),"^",3),1,20)
QUIT X
+5 SET X=$PIECE(^OR(100,IFN,0),"^",6)
IF X
SET X=$EXTRACT($PIECE(^VA(200,X,20),"^",3),1,20)
+6 QUIT X
BY(ORIFN) ;Get DC info for DC by & when PRINT FIELD
+1 IF '$GET(ORIFN)
QUIT ""
+2 NEW Y,Z,X6,X1,ORDCBY
+3 IF $PIECE($GET(^OR(100,ORIFN,6)),"^",2)
SET X6=^(6)
Begin DoDot:1
+4 SET Y=+$JUSTIFY($PIECE(X6,"^",3),0,4)
SET Z=$GET(^VA(200,+$PIECE(X6,"^",2),0))
IF $LENGTH(Z)
SET X1=$PIECE(Z,"^")_$SELECT($PIECE(Z,"^",9):" ("_$EXTRACT($PIECE(^DIC(3.1,$PIECE(Z,"^",9),0),"^"),1,10)_")",1:"")
SET Y=$$DATE^ORU(Y)_" "_$$TIME^ORU(Y)
+5 SET ORDCBY="DC'ed "_$SELECT(+$PIECE(X6,"^",4):"("_$PIECE(^ORD(100.03,+$PIECE(X6,"^",4),0),"^")_")",1:"")_" by:"_X1_" "_Y
End DoDot:1
QUIT ORDCBY
+6 QUIT ""
WARDREM(ORIFN) ;Get Ward Remarks
+1 NEW ORI,X
+2 SET X=""
+3 IF $GET(ORIFN)
SET ORI=$ORDER(^OR(100,ORIFN,4.5,"ID","COMMENT",0))
IF ORI
SET X="^OR(100,"_+ORIFN_",4.5,"_ORI_",2)"
+4 QUIT X
RX(IFN,FLD,Y) ;Get Pharmacy Fields
+1 ;IFN=internal # of 100
+2 ;FLD=code for RX field to lookup
+3 ;Y=output returned in Y
+4 IF '$GET(IFN)
QUIT
IF '$LENGTH($GET(FLD))
QUIT
+5 IF '$DATA(^OR(100,IFN,0))
QUIT
+6 NEW X,X4,PKG,DFN,I
SET X=^OR(100,IFN,0)
SET X4=$GET(^(4))
IF '$LENGTH(X4)
QUIT
+7 SET PKG=$PIECE(X,"^",14)
IF 'PKG
QUIT
+8 SET PKG=$SELECT($PIECE(^DIC(9.4,PKG,0),"^")="INPATIENT MEDICATIONS":"I",$PIECE(^(0),"^")="OUTPATIENT MEDICATIONS":"O",$PIECE(^(0),"^")="IV MEDICATIONS":"I",$PIECE(^(0),"^")="UNIT DOSE MEDICATIONS":"I",1:"")
IF '$LENGTH(PKG)
QUIT
+9 SET DFN=+$PIECE(X,"^",2)
+10 DO OEL^PSOORRL(DFN,X4_";"_PKG)
+11 ;Special Instructions
IF FLD="SI"
SET Y=$PIECE($GET(^TMP("PS",$JOB,"SI")),"^",1,99)
QUIT
+12 ;Schedule & Admin Times
IF FLD="SCH"
SET I=0
Begin DoDot:1
+13 ;_" "_$P(^(0),"^",2)
FOR
SET I=$ORDER(^TMP("PS",$JOB,"SCH",I))
IF I<1
QUIT
SET Y(I)=$PIECE(^(I,0),"^")
End DoDot:1
QUIT
+14 ;Other print info
IF FLD="OTH"
SET Y=$PIECE($GET(^TMP("PS",$JOB,"OPI")),1,99)
QUIT
+15 ;Drug
IF FLD="DRUG"
SET Y=$PIECE($GET(^TMP("PS",$JOB,0)),"^")
QUIT
+16 ;Infusion rate
IF FLD="INF"
SET Y=$PIECE($GET(^TMP("PS",$JOB,0)),"^",2)
QUIT
+17 ;Stop date
IF FLD="STOP"
SET Y=$PIECE($GET(^TMP("PS",$JOB,0)),"^",3)
QUIT
+18 ;Refills
IF FLD="REFIL"
SET Y=$PIECE($GET(^TMP("PS",$JOB,0)),"^",4)
QUIT
+19 ;Med Route
IF FLD="MDRT"
SET I=0
Begin DoDot:1
+20 FOR
SET I=$ORDER(^TMP("PS",$JOB,"MDR",I))
IF I<1
QUIT
SET Y(I)=^(I,0)
End DoDot:1
QUIT
+21 ;SIG (outpat) Instructions (inpat)
IF FLD="SIG"
SET I=0
Begin DoDot:1
+22 FOR
SET I=$ORDER(^TMP("PS",$JOB,"SIG",I))
IF I<1
QUIT
SET Y(I)=^(I,0)
End DoDot:1
QUIT
+23 ;Provider comments
IF FLD="PC"
SET I=0
Begin DoDot:1
+24 FOR
SET I=$ORDER(^TMP("PS",$JOB,"PC",I))
IF I<1
QUIT
SET Y(I)=^(I,0)
End DoDot:1
QUIT
+25 ;Additive, amount, bottle
IF FLD="ADD"
SET I=0
Begin DoDot:1
+26 FOR
SET I=$ORDER(^TMP("PS",$JOB,"A",I))
IF I<1
QUIT
SET Y(I)=$PIECE(^(I,0),"^")_" "_$PIECE(^(0),"^",2)_" #"_$PIECE(^(0),"^",3)
End DoDot:1
QUIT
+27 ;Solution & amount
IF FLD="SOL"
SET I=0
Begin DoDot:1
+28 FOR
SET I=$ORDER(^TMP("PS",$JOB,"B",I))
IF I<1
QUIT
SET Y(I)=$PIECE(^(I,0),"^")_" "_$PIECE(^(0),"^",2)
End DoDot:1
QUIT
+29 QUIT
TEST ;Test RX call
+1 WRITE !,"Enter Pharmacy Order # (ORIFN): "
READ X:DTIME
IF X=""!(X["^")
QUIT
IF '$DATA(^OR(100,+$GET(X),0))
WRITE !,$CHAR(7),X_" does not exist"
GOTO TEST
+2 ;ZW TEST
SET ORIFN=X
FOR ORI="SCH","SI","ADM","OTH","DRUG","INF","STOP","REFIL","MDRT","SIG","PC","ADD","SOL"
KILL TEST
DO RX(ORIFN,ORI,.TEST)
IF $DATA(TEST)
WRITE !,ORI_"- "
+3 QUIT
LABEL(Y,ORIFN,QUIET,OACTION) ;Print pharmacy label
+1 IF $GET(ORTEST)
DO TEST1
QUIT
+2 NEW X,X4,ORC
+3 IF '$DATA(^OR(100,+$GET(ORIFN),0))
QUIT
IF '$LENGTH($GET(^(4)))
QUIT
SET X=^(0)
SET X4=^(4)
+4 IF $SELECT($PIECE($GET(^DIC(9.4,+$PIECE(X,"^",14),0)),"^")="INPATIENT MEDICATIONS":0,$PIECE($GET(^DIC(9.4,+$PIECE(X,"^",14),0)),"^")="IV MEDICATIONS":0,$PIECE($GET(^DIC(9.4,+$PIECE(X,"^",14),0)),"^")="UNIT DOSE MEDICATIONS":0,1:1)
QUIT
+5 NEW LINES,ORXPTMP,I,ACT
+6 IF $GET(OACTION)
IF $DATA(^OR(100,+$GET(ORIFN),8,OACTION,0))
SET ACT=$PIECE(^(0),"^",2)
+7 IF $LENGTH($TEXT(MAR^PSJORMAR),",")>4
DO MAR^PSJORMAR(+$PIECE(X,"^",2),$PIECE(X4,"^"),1,.LINES,$GET(ACT))
+8 IF $LENGTH($TEXT(MAR^PSJORMAR),",")'>4
DO MAR^PSJORMAR(+$PIECE(X,"^",2),$PIECE(X4,"^"),1,.LINES)
+9 IF $GET(QUIET)
KILL Y
SET (I,Y)=0
Begin DoDot:1
+10 FOR
SET I=$ORDER(LINES(I))
IF 'I
QUIT
SET Y(I,0)=LINES(I)
SET ORPICKUP=I
End DoDot:1
QUIT
+11 SET (ORC,I)=0
+12 IF '$DATA(ORIOSL)
NEW ORIOSL
SET ORIOSL=$SELECT($DATA(IOSL):IOSL,1:50)
+13 IF '$DATA(ORIOF)
NEW ORIOF
SET ORIOF=$SELECT($DATA(IOF):IOF,1:"!")
+14 FOR
SET I=$ORDER(LINES(I))
IF I<1
QUIT
SET ORC=ORC+1
Begin DoDot:1
+15 IF $Y>(ORIOSL-2)
WRITE @ORIOF
SET ORC=1
+16 IF ORC>1
WRITE !
WRITE LINES(I)
End DoDot:1
+17 QUIT
TEST1 ;Print test label
+1 WRITE !,"03/03 | | (F1990)|"
+2 WRITE !,"Test Pharmacy Label"
+3 WRITE !,"Give: 1GM TOP QD"
+4 WRITE !!," RPH: _____RN: _____|"
+5 QUIT
