Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRAPAUA

LRAPAUA.m

Go to the documentation of this file.
LRAPAUA ; IHS/DIR/AAB - AUTOPSY LIST 2/9/98 10:26 ; [ 07/08/1998 9:43 AM ]
 ;;5.2;LR;**1002,1006**;SEP 01, 1998
 ;
 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
 S LRDICS="AU" D ^LRAP G:'$D(Y) END D XR^LRU,B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99,ZTRTN="QUE^LRAPAUA" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D L^LRU,S^LRU,H S LR("F")=1
 F LRSDT=LRSDT:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT)  F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN  D SET
 D W,END^LRUTL,END Q
SET Q:'$D(^LR(LRDFN,"AU"))!('$D(^(0))#2)  S Z=^("AU"),LRAC=$P(Z,U,6) Q:$P(LRAC," ")'=LRABV  S X=^(0),DFN=$P(X,"^",3),(LRDPF,X)=+$P(X,"^",2) Q:'X  S P(0)=$P(^DIC(X,0),"^"),X=^DIC(X,0,"GL") D PT^LRX Q:$G(VAERR)  S LRP=PNM
 ;I $L(LRP),LRDFN S ^TMP($J,LRP,LRDFN)=SSN_"^"_+Z_"^"_LRAC_"^"_$S(P(0)="PATIENT":"",1:P(0))
 I $L(LRP),LRDFN S ^TMP($J,LRP,LRDFN)=HRCN_"^"_+Z_"^"_LRAC_"^"_$S(P(0)="PATIENT":"",1:P(0))  ;IHS/ANMC/CLS 11/1/95
 Q
 ;
W S LRP="" F A=0:0 S LRP=$O(^TMP($J,LRP)) Q:LRP=""!(LR("Q"))  F LRDFN=0:0 S LRDFN=$O(^TMP($J,LRP,LRDFN)) Q:'LRDFN!(LR("Q"))  S LRX=^(LRDFN) D:$Y>(IOSL-6) H Q:LR("Q")  D W1
 Q
W1 S LRAUDT=$P(LRX,"^",2),LRAUDT=$P(LRAUDT,".") W !,LRP,?31,$P(LRX,"^"),?46,$P(LRX,"^",3),?58,$$Y2K^LRX(LRAUDT),?70,$E($P(LRX,"^",4),1,10) Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
 ;D F^LRU W !,LRO(68)," list from ",LRSTR," to ",LRLST,!,"Patient",?35,"SSN",?46,"Autopsy#",?58,"Autopsy Date",!,LR("%") Q
 D F^LRU W !,LRO(68)," list from ",LRSTR," to ",LRLST,!,"Patient",?35,"HRCN",?46,"Autopsy#",?58,"Autopsy Date",!,LR("%") Q  ;IHS/ANMC/CLS 11/1/95
 ;
END K LRAUDT D V^LRU Q