LRBLPH ;AVAMC/REG - PATIENT DRUG LIST ;2/18/93 09:44
;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
Q D V^LRU S LRDPAF=1 D ^LRDPA G:LRDFN<1 END I +LRDPF'=2 W $C(7),!,"Must be entry in Patient File (2)" G LRBLPH
W ! S ZTRTN="QUE^LRBLPH" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D L^LRU,S^LRU
D H S LR("F")=1
F X=0:0 S X=$O(^PS(55,DFN,"P",X)) Q:'X I $D(^(X,0)) S Y=+^(0) I $D(^PSRX(Y,0)) S ^TMP($J,+$P(^(0),"^",6))=0
F LRX=0:0 S LRX=$O(^TMP($J,LRX)) Q:'LRX I $D(^PSDRUG(LRX,0)) D:$Y>(IOSL-6) H Q:LR("Q") W !,"OUTPATIENT PHARMACY ITEM: ",$P(^PSDRUG(LRX,0),"^")
G:LR("Q") OUT K ^TMP($J) F X=0:0 S X=$O(^PS(55,DFN,"IV",X)) Q:'X F Y=0:0 S Y=$O(^PS(55,DFN,"IV",X,"AD",Y)) Q:'Y S ^TMP($J,+^(Y,0))=""
F LRX=0:0 S LRX=$O(^TMP($J,LRX)) Q:'LRX I $D(^PS(52.6,LRX,0)) D:$Y>(IOSL-6) H Q:LR("Q") W !,"IV DRUG: ",$P(^PS(52.6,LRX,0),"^")
G:LR("Q") OUT K ^TMP($J) F X=0:0 S X=$O(^PS(55,DFN,5,X)) Q:'X F Y=0:0 S Y=$O(^PS(55,DFN,5,X,1,Y)) Q:'Y S ^TMP($J,+^(Y,0))=""
F LRX=0:0 S LRX=$O(^TMP($J,LRX)) Q:'LRX I $D(^PSDRUG(LRX,0)) D:$Y>(IOSL-6) H Q:LR("Q") W !,"INPATIENT PHARMACY ITEM: ",$P(^PSDRUG(LRX,0),"^")
OUT D END^LRUTL,END Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"Medication List for ",PNM," ",SSN,!,LR("%") Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPH 1385 printed Dec 13, 2024@02:11:55 Page 2
LRBLPH ;AVAMC/REG - PATIENT DRUG LIST ;2/18/93 09:44
+1 ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 QUIT
DO V^LRU
SET LRDPAF=1
DO ^LRDPA
if LRDFN<1
GOTO END
IF +LRDPF'=2
WRITE $CHAR(7),!,"Must be entry in Patient File (2)"
GOTO LRBLPH
+4 WRITE !
SET ZTRTN="QUE^LRBLPH"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
DO L^LRU
DO S^LRU
+1 DO H
SET LR("F")=1
+2 FOR X=0:0
SET X=$ORDER(^PS(55,DFN,"P",X))
if 'X
QUIT
IF $DATA(^(X,0))
SET Y=+^(0)
IF $DATA(^PSRX(Y,0))
SET ^TMP($JOB,+$PIECE(^(0),"^",6))=0
+3 FOR LRX=0:0
SET LRX=$ORDER(^TMP($JOB,LRX))
if 'LRX
QUIT
IF $DATA(^PSDRUG(LRX,0))
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,"OUTPATIENT PHARMACY ITEM: ",$PIECE(^PSDRUG(LRX,0),"^")
+4 if LR("Q")
GOTO OUT
KILL ^TMP($JOB)
FOR X=0:0
SET X=$ORDER(^PS(55,DFN,"IV",X))
if 'X
QUIT
FOR Y=0:0
SET Y=$ORDER(^PS(55,DFN,"IV",X,"AD",Y))
if 'Y
QUIT
SET ^TMP($JOB,+^(Y,0))=""
+5 FOR LRX=0:0
SET LRX=$ORDER(^TMP($JOB,LRX))
if 'LRX
QUIT
IF $DATA(^PS(52.6,LRX,0))
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,"IV DRUG: ",$PIECE(^PS(52.6,LRX,0),"^")
+6 if LR("Q")
GOTO OUT
KILL ^TMP($JOB)
FOR X=0:0
SET X=$ORDER(^PS(55,DFN,5,X))
if 'X
QUIT
FOR Y=0:0
SET Y=$ORDER(^PS(55,DFN,5,X,1,Y))
if 'Y
QUIT
SET ^TMP($JOB,+^(Y,0))=""
+7 FOR LRX=0:0
SET LRX=$ORDER(^TMP($JOB,LRX))
if 'LRX
QUIT
IF $DATA(^PSDRUG(LRX,0))
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,"INPATIENT PHARMACY ITEM: ",$PIECE(^PSDRUG(LRX,0),"^")
OUT DO END^LRUTL
DO END
QUIT
+1 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"Medication List for ",PNM," ",SSN,!,LR("%")
QUIT
+2 ;
END DO V^LRU
QUIT
