ORQQPS ; slc/CLA - Functions which return patient medication data ;12/15/97 [ 04/02/97 3:52 PM ]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,94**;Dec 17, 1997
Q
LIST(ORY,ORPT,ORSTRTDT,ORSTOPDT) ;return pt's condensed medication list
;id^nameform^stop date^route^schedule/infusion rate^refills remaining
K ^TMP("PS",$J),^TMP("ORPS",$J)
D OCL^PSOORRL(ORPT,ORSTRTDT,ORSTOPDT)
N I,J,K,X,Z,ZZ,NODE,RSORT,NAME,SCH,MDR,RATE,TYPE,ADD,SOL,IVX
S I=0,X=0,NODE=0,SCH="",MDR=""
F S X=$O(^TMP("PS",$J,X)) Q:X<1 D
.Q:+$P(^TMP("PS",$J,X,0),U)<1
.S TYPE=$P(^TMP("PS",$J,X,0),U)
.I +$G(^TMP("PS",$J,X,"MDR",0))>0 D ;get abbrev med route
..S ZZ=^TMP("PS",$J,X,"MDR",0) F Z=1:1:ZZ D
...I Z=1 S MDR=^TMP("PS",$J,X,"MDR",Z,0)
...E S MDR=MDR_", "_^TMP("PS",$J,X,"MDR",Z,0)
.I +$G(^TMP("PS",$J,X,"SCH",0))>0 D ;get schedule
..S ZZ=^TMP("PS",$J,X,"SCH",0) F Z=1:1:ZZ D
...I Z=1 S SCH=$P(^TMP("PS",$J,X,"SCH",Z,0),U)
...E S SCH=SCH_", "_$P(^TMP("PS",$J,X,"SCH",Z,0),U)
.;
.I TYPE["I",+$G(^TMP("PS",$J,X,"B",0))>0 D ;IV meds - get solution
..S ZZ=^TMP("PS",$J,X,"B",0) F Z=1:1:ZZ D
...I Z=1 S SOL=$P(^TMP("PS",$J,X,"B",Z,0),U)_" "_$P(^(0),U,2)
...E S SOL=SOL_", "_$P(^TMP("PS",$J,X,"B",Z,0),U)_" "_$P(^(0),U,2)
..I +$G(^TMP("PS",$J,X,"A",0))>0 D ;get additive
...S ZZ=^TMP("PS",$J,X,"A",0) F Z=1:1:ZZ D
....S ADD=$P(^TMP("PS",$J,X,"A",Z,0),U)_" "_$P(^(0),U,2)
....S NAME=ADD_" in "_$G(SOL)
....S RSORT=9999999-$P(^TMP("PS",$J,X,0),U,4)_$P(^(0),U)_NAME
....S RSORT=$E(RSORT,1,128) ;limit gbl subscript length to 128 chars
....S ^TMP("ORPS",$J,RSORT)=$P(^TMP("PS",$J,X,0),U)_U_NAME_U_$P(^(0),U,4)_U_$G(MDR)_U_$P(^(0),U,3)
..E D
...S NAME=$G(SOL)
...S RSORT=9999999-$P(^TMP("PS",$J,X,0),U,4)_$P(^(0),U)
...S RSORT=$E(RSORT,1,128) ;limit gbl subscript length to 128 chars
...S ^TMP("ORPS",$J,RSORT)=$P(^TMP("PS",$J,X,0),U)_U_NAME_U_$P(^(0),U,4)_U_$G(MDR)_U_$P(^(0),U,3)
.;
.I TYPE["I",'(+$G(^TMP("PS",$J,X,"B",0))>0) D ;unit dose inpatient meds
..S RSORT=9999999-$P(^TMP("PS",$J,X,0),U,4)_$P(^(0),U)_$P(^(0),U,2)
..S RSORT=$E(RSORT,1,128) ;limit gbl subscript length to 128 chars
..S ^TMP("ORPS",$J,RSORT)=$P(^TMP("PS",$J,X,0),U)_U_$P(^(0),U,2)_U_$P(^(0),U,4)_U_$G(MDR)_U_$G(SCH)
.;
.I TYPE["O" D ;outpatient meds
..S RSORT=9999999-$P(^TMP("PS",$J,X,0),U,4)_$P(^(0),U)_$P(^(0),U,2)
..S RSORT=$E(RSORT,1,128) ;limit gbl subscript length to 128 chars
..S ^TMP("ORPS",$J,RSORT)=$P(^TMP("PS",$J,X,0),U)_U_$P(^(0),U,2)_U_$P(^(0),U,4)_U_$G(MDR)_U_$G(SCH)_U_$P(^(0),U,5)
.;
;
F S NODE=$O(^TMP("ORPS",$J,NODE)) Q:NODE<1 D
.S I=I+1
.S ORY(I)=^TMP("ORPS",$J,NODE)
S:+$G(ORY(1))<1 ORY(1)="^No medications found."
K ^TMP("PS",$J),^TMP("ORPS",$J)
Q
DETAIL(ORY,ORPT,ORMED) ; return detailed information for a drug
K ^TMP("PS",$J)
D OEL^PSOORRL(ORPT,ORMED)
N I,J,CR,X,Z,ZZ,MDR,SCH,SIG,COM,ADD,SOL,ORDATE,TYPE
S I=0,J=1,CR=$CHAR(13),ORDATE=""
S TYPE=$P(ORMED,";",2)
S X=$G(^TMP("PS",$J,0))
I '$L($G(X)) S ORY(J)="No detailed information found." Q
S ORY(J)=" "_$P(X,U)
;get abbreviated med route(s):
I +$G(^TMP("PS",$J,"MDR",0))>0 D
.S ZZ=^TMP("PS",$J,"MDR",0) F Z=1:1:ZZ D
..I Z=1 S MDR=^TMP("PS",$J,"MDR",Z,0)
..E S MDR=MDR_", "_^TMP("PS",$J,"MDR",Z,0)
I $L($G(MDR)) S ORY(J)=ORY(J)_" "_MDR
S ORY(J)=ORY(J)_" "_$P(X,U,2)
; get schedule(s):
I +$G(^TMP("PS",$J,"SCH",0))>0 D
.S ZZ=^TMP("PS",$J,"SCH",0) F Z=1:1:ZZ D
..I Z=1 S SCH=$P(^TMP("PS",$J,"SCH",Z,0),U)
..E S SCH=SCH_", "_$P(^TMP("PS",$J,"SCH",Z,0),U)
I $L($G(SCH)) S ORY(J)=ORY(J)_" "_SCH
S ORY(J)=ORY(J),J=J+1
; get SIG(s):
I +$G(^TMP("PS",$J,"SIG",0))>0 D
.S ZZ=^TMP("PS",$J,"SIG",0) F Z=1:1:ZZ D
..I Z=1 S SIG=^TMP("PS",$J,"SIG",Z,0)
..E S SIG=SIG_", "_^TMP("PS",$J,"SIG",Z,0)
I $L($G(SIG)) S ORY(J)=" "_SIG,J=J+1
S ORY(J)=" ",J=J+1
; get solution(s):
I +$G(^TMP("PS",$J,"B",0))>0 D
.S ZZ=^TMP("PS",$J,"B",0) F Z=1:1:ZZ D
..S SOL=^TMP("PS",$J,"B",Z,0),ORY(J)=" "_$P(SOL,U)_" "_$P(SOL,U,2),J=J+1
; get additive(s):
I +$G(^TMP("PS",$J,"A",0))>0 D
.S ZZ=^TMP("PS",$J,"A",0) F Z=1:1:ZZ D
..S ADD=^TMP("PS",$J,"A",Z,0)
..S ORY(J)=" "_$P(ADD,U)
..S IVX=$P(ADD,U,2)
..S ORY(J)=ORY(J)_$S($D(IVX):" "_IVX,1:"")_" "_$P(ADD,U,3),J=J+1
I $L($G(SOL))!($L($G(ADD))) S ORY(J)=" ",J=J+1
; get other information:
S ORY(J)=" Status: "_$P(X,U,6),J=J+1
S ORDATE=$P(X,U,5) I $L($G(ORDATE)) D
.D DT^DILF("ET",ORDATE,.ORDATE,"","")
S ORY(J)=" Start date: "_$G(ORDATE(0)),J=J+1
S ORDATE=$P(X,U,3) I $L($G(ORDATE)) D
.D DT^DILF("ET",ORDATE,.ORDATE,"","")
S ORY(J)=" Stop date: "_$G(ORDATE(0)),J=J+1
I TYPE="O" D ; if outpatient med
.S ORY(J)="Refills remaining: "_$P(X,U,4),J=J+1
.S ORY(J)=" Days supply: "_$P(X,U,7),J=J+1
.S ORY(J)=" Quantity: "_$P(X,U,8),J=J+1
.S ORY(J)=" ",J=J+1
S ORY(J)="Comments:",J=J+1
S I=0 F S I=$O(^TMP("PS",$J,"PC",I)) Q:'I D
.S ORY(J)=^TMP("PS",$J,"PC",I,0),J=J+1
K ^TMP("PS",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQQPS 5014 printed Mar 13, 2025@21:38:44 Page 2
ORQQPS ; slc/CLA - Functions which return patient medication data ;12/15/97 [ 04/02/97 3:52 PM ]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,94**;Dec 17, 1997
+2 QUIT
LIST(ORY,ORPT,ORSTRTDT,ORSTOPDT) ;return pt's condensed medication list
+1 ;id^nameform^stop date^route^schedule/infusion rate^refills remaining
+2 KILL ^TMP("PS",$JOB),^TMP("ORPS",$JOB)
+3 DO OCL^PSOORRL(ORPT,ORSTRTDT,ORSTOPDT)
+4 NEW I,J,K,X,Z,ZZ,NODE,RSORT,NAME,SCH,MDR,RATE,TYPE,ADD,SOL,IVX
+5 SET I=0
SET X=0
SET NODE=0
SET SCH=""
SET MDR=""
+6 FOR
SET X=$ORDER(^TMP("PS",$JOB,X))
if X<1
QUIT
Begin DoDot:1
+7 if +$PIECE(^TMP("PS",$JOB,X,0),U)<1
QUIT
+8 SET TYPE=$PIECE(^TMP("PS",$JOB,X,0),U)
+9 ;get abbrev med route
IF +$GET(^TMP("PS",$JOB,X,"MDR",0))>0
Begin DoDot:2
+10 SET ZZ=^TMP("PS",$JOB,X,"MDR",0)
FOR Z=1:1:ZZ
Begin DoDot:3
+11 IF Z=1
SET MDR=^TMP("PS",$JOB,X,"MDR",Z,0)
+12 IF '$TEST
SET MDR=MDR_", "_^TMP("PS",$JOB,X,"MDR",Z,0)
End DoDot:3
End DoDot:2
+13 ;get schedule
IF +$GET(^TMP("PS",$JOB,X,"SCH",0))>0
Begin DoDot:2
+14 SET ZZ=^TMP("PS",$JOB,X,"SCH",0)
FOR Z=1:1:ZZ
Begin DoDot:3
+15 IF Z=1
SET SCH=$PIECE(^TMP("PS",$JOB,X,"SCH",Z,0),U)
+16 IF '$TEST
SET SCH=SCH_", "_$PIECE(^TMP("PS",$JOB,X,"SCH",Z,0),U)
End DoDot:3
End DoDot:2
+17 ;
+18 ;IV meds - get solution
IF TYPE["I"
IF +$GET(^TMP("PS",$JOB,X,"B",0))>0
Begin DoDot:2
+19 SET ZZ=^TMP("PS",$JOB,X,"B",0)
FOR Z=1:1:ZZ
Begin DoDot:3
+20 IF Z=1
SET SOL=$PIECE(^TMP("PS",$JOB,X,"B",Z,0),U)_" "_$PIECE(^(0),U,2)
+21 IF '$TEST
SET SOL=SOL_", "_$PIECE(^TMP("PS",$JOB,X,"B",Z,0),U)_" "_$PIECE(^(0),U,2)
End DoDot:3
+22 ;get additive
IF +$GET(^TMP("PS",$JOB,X,"A",0))>0
Begin DoDot:3
+23 SET ZZ=^TMP("PS",$JOB,X,"A",0)
FOR Z=1:1:ZZ
Begin DoDot:4
+24 SET ADD=$PIECE(^TMP("PS",$JOB,X,"A",Z,0),U)_" "_$PIECE(^(0),U,2)
+25 SET NAME=ADD_" in "_$GET(SOL)
+26 SET RSORT=9999999-$PIECE(^TMP("PS",$JOB,X,0),U,4)_$PIECE(^(0),U)_NAME
+27 ;limit gbl subscript length to 128 chars
SET RSORT=$EXTRACT(RSORT,1,128)
+28 SET ^TMP("ORPS",$JOB,RSORT)=$PIECE(^TMP("PS",$JOB,X,0),U)_U_NAME_U_$PIECE(^(0),U,4)_U_$GET(MDR)_U_$PIECE(^(0),U,3)
End DoDot:4
End DoDot:3
+29 IF '$TEST
Begin DoDot:3
+30 SET NAME=$GET(SOL)
+31 SET RSORT=9999999-$PIECE(^TMP("PS",$JOB,X,0),U,4)_$PIECE(^(0),U)
+32 ;limit gbl subscript length to 128 chars
SET RSORT=$EXTRACT(RSORT,1,128)
+33 SET ^TMP("ORPS",$JOB,RSORT)=$PIECE(^TMP("PS",$JOB,X,0),U)_U_NAME_U_$PIECE(^(0),U,4)_U_$GET(MDR)_U_$PIECE(^(0),U,3)
End DoDot:3
End DoDot:2
+34 ;
+35 ;unit dose inpatient meds
IF TYPE["I"
IF '(+$GET(^TMP("PS",$JOB,X,"B",0))>0)
Begin DoDot:2
+36 SET RSORT=9999999-$PIECE(^TMP("PS",$JOB,X,0),U,4)_$PIECE(^(0),U)_$PIECE(^(0),U,2)
+37 ;limit gbl subscript length to 128 chars
SET RSORT=$EXTRACT(RSORT,1,128)
+38 SET ^TMP("ORPS",$JOB,RSORT)=$PIECE(^TMP("PS",$JOB,X,0),U)_U_$PIECE(^(0),U,2)_U_$PIECE(^(0),U,4)_U_$GET(MDR)_U_$GET(SCH)
End DoDot:2
+39 ;
+40 ;outpatient meds
IF TYPE["O"
Begin DoDot:2
+41 SET RSORT=9999999-$PIECE(^TMP("PS",$JOB,X,0),U,4)_$PIECE(^(0),U)_$PIECE(^(0),U,2)
+42 ;limit gbl subscript length to 128 chars
SET RSORT=$EXTRACT(RSORT,1,128)
+43 SET ^TMP("ORPS",$JOB,RSORT)=$PIECE(^TMP("PS",$JOB,X,0),U)_U_$PIECE(^(0),U,2)_U_$PIECE(^(0),U,4)_U_$GET(MDR)_U_$GET(SCH)_U_$PIECE(^(0),U,5)
End DoDot:2
+44 ;
End DoDot:1
+45 ;
+46 FOR
SET NODE=$ORDER(^TMP("ORPS",$JOB,NODE))
if NODE<1
QUIT
Begin DoDot:1
+47 SET I=I+1
+48 SET ORY(I)=^TMP("ORPS",$JOB,NODE)
End DoDot:1
+49 if +$GET(ORY(1))<1
SET ORY(1)="^No medications found."
+50 KILL ^TMP("PS",$JOB),^TMP("ORPS",$JOB)
+51 QUIT
DETAIL(ORY,ORPT,ORMED) ; return detailed information for a drug
+1 KILL ^TMP("PS",$JOB)
+2 DO OEL^PSOORRL(ORPT,ORMED)
+3 NEW I,J,CR,X,Z,ZZ,MDR,SCH,SIG,COM,ADD,SOL,ORDATE,TYPE
+4 SET I=0
SET J=1
SET CR=$CHAR(13)
SET ORDATE=""
+5 SET TYPE=$PIECE(ORMED,";",2)
+6 SET X=$GET(^TMP("PS",$JOB,0))
+7 IF '$LENGTH($GET(X))
SET ORY(J)="No detailed information found."
QUIT
+8 SET ORY(J)=" "_$PIECE(X,U)
+9 ;get abbreviated med route(s):
+10 IF +$GET(^TMP("PS",$JOB,"MDR",0))>0
Begin DoDot:1
+11 SET ZZ=^TMP("PS",$JOB,"MDR",0)
FOR Z=1:1:ZZ
Begin DoDot:2
+12 IF Z=1
SET MDR=^TMP("PS",$JOB,"MDR",Z,0)
+13 IF '$TEST
SET MDR=MDR_", "_^TMP("PS",$JOB,"MDR",Z,0)
End DoDot:2
End DoDot:1
+14 IF $LENGTH($GET(MDR))
SET ORY(J)=ORY(J)_" "_MDR
+15 SET ORY(J)=ORY(J)_" "_$PIECE(X,U,2)
+16 ; get schedule(s):
+17 IF +$GET(^TMP("PS",$JOB,"SCH",0))>0
Begin DoDot:1
+18 SET ZZ=^TMP("PS",$JOB,"SCH",0)
FOR Z=1:1:ZZ
Begin DoDot:2
+19 IF Z=1
SET SCH=$PIECE(^TMP("PS",$JOB,"SCH",Z,0),U)
+20 IF '$TEST
SET SCH=SCH_", "_$PIECE(^TMP("PS",$JOB,"SCH",Z,0),U)
End DoDot:2
End DoDot:1
+21 IF $LENGTH($GET(SCH))
SET ORY(J)=ORY(J)_" "_SCH
+22 SET ORY(J)=ORY(J)
SET J=J+1
+23 ; get SIG(s):
+24 IF +$GET(^TMP("PS",$JOB,"SIG",0))>0
Begin DoDot:1
+25 SET ZZ=^TMP("PS",$JOB,"SIG",0)
FOR Z=1:1:ZZ
Begin DoDot:2
+26 IF Z=1
SET SIG=^TMP("PS",$JOB,"SIG",Z,0)
+27 IF '$TEST
SET SIG=SIG_", "_^TMP("PS",$JOB,"SIG",Z,0)
End DoDot:2
End DoDot:1
+28 IF $LENGTH($GET(SIG))
SET ORY(J)=" "_SIG
SET J=J+1
+29 SET ORY(J)=" "
SET J=J+1
+30 ; get solution(s):
+31 IF +$GET(^TMP("PS",$JOB,"B",0))>0
Begin DoDot:1
+32 SET ZZ=^TMP("PS",$JOB,"B",0)
FOR Z=1:1:ZZ
Begin DoDot:2
+33 SET SOL=^TMP("PS",$JOB,"B",Z,0)
SET ORY(J)=" "_$PIECE(SOL,U)_" "_$PIECE(SOL,U,2)
SET J=J+1
End DoDot:2
End DoDot:1
+34 ; get additive(s):
+35 IF +$GET(^TMP("PS",$JOB,"A",0))>0
Begin DoDot:1
+36 SET ZZ=^TMP("PS",$JOB,"A",0)
FOR Z=1:1:ZZ
Begin DoDot:2
+37 SET ADD=^TMP("PS",$JOB,"A",Z,0)
+38 SET ORY(J)=" "_$PIECE(ADD,U)
+39 SET IVX=$PIECE(ADD,U,2)
+40 SET ORY(J)=ORY(J)_$SELECT($DATA(IVX):" "_IVX,1:"")_" "_$PIECE(ADD,U,3)
SET J=J+1
End DoDot:2
End DoDot:1
+41 IF $LENGTH($GET(SOL))!($LENGTH($GET(ADD)))
SET ORY(J)=" "
SET J=J+1
+42 ; get other information:
+43 SET ORY(J)=" Status: "_$PIECE(X,U,6)
SET J=J+1
+44 SET ORDATE=$PIECE(X,U,5)
IF $LENGTH($GET(ORDATE))
Begin DoDot:1
+45 DO DT^DILF("ET",ORDATE,.ORDATE,"","")
End DoDot:1
+46 SET ORY(J)=" Start date: "_$GET(ORDATE(0))
SET J=J+1
+47 SET ORDATE=$PIECE(X,U,3)
IF $LENGTH($GET(ORDATE))
Begin DoDot:1
+48 DO DT^DILF("ET",ORDATE,.ORDATE,"","")
End DoDot:1
+49 SET ORY(J)=" Stop date: "_$GET(ORDATE(0))
SET J=J+1
+50 ; if outpatient med
IF TYPE="O"
Begin DoDot:1
+51 SET ORY(J)="Refills remaining: "_$PIECE(X,U,4)
SET J=J+1
+52 SET ORY(J)=" Days supply: "_$PIECE(X,U,7)
SET J=J+1
+53 SET ORY(J)=" Quantity: "_$PIECE(X,U,8)
SET J=J+1
+54 SET ORY(J)=" "
SET J=J+1
End DoDot:1
+55 SET ORY(J)="Comments:"
SET J=J+1
+56 SET I=0
FOR
SET I=$ORDER(^TMP("PS",$JOB,"PC",I))
if 'I
QUIT
Begin DoDot:1
+57 SET ORY(J)=^TMP("PS",$JOB,"PC",I,0)
SET J=J+1
End DoDot:1
+58 KILL ^TMP("PS",$JOB)
+59 QUIT
