source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLPH.m@ 1604

Last change on this file since 1604 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.3 KB
Line 
1LRBLPH ;AVAMC/REG - PATIENT DRUG LIST ;2/18/93 09:44
2 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 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
5 W ! S ZTRTN="QUE^LRBLPH" D BEG^LRUTL G:POP!($D(ZTSK)) END
6QUE U IO K ^TMP($J) D L^LRU,S^LRU
7 D H S LR("F")=1
8 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
9 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),"^")
10 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))=""
11 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),"^")
12 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))=""
13 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),"^")
14OUT D END^LRUTL,END Q
15 ;
16H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
17 D F^LRU W !,"Medication List for ",PNM," ",SSN,!,LR("%") Q
18 ;
19END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.