- 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
