source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRACKL.m@ 724

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1LRACKL ;DALOI/DCM/JMC/RLM-CHUTES & LADDERS; 2/16/88 16:15
2 ;;5.2;LAB SERVICE;**272**;Sep 27, 1994
3 ; Reference to ^%DTC supported by IA # 10000
4 ; Reference to H^%DTC supported by IA # 10000
5 ; Reference to YMD^%DTC supported by IA # 10000
6 ; Reference to ^%RCR supported by IA # 10022
7 ; Reference to IX^DIC supported by IA # 10006
8LR1 K ^LRO(69,DT,1,"AR",LRLLOC,PNM,LRDFN) S ^LRO(69,LRDT,1,"AR",LRLLOC,PNM,LRDFN)=""
9 Q
10SHUF F I=0:0 S LRLLOC=$O(^LRO(69,DT,1,"AR",LRLLOC)) Q:LRLLOC="" S PNM=-1 F J=0:0 S PNM=$O(^LRO(69,DT,1,"AR",LRLLOC,PNM)) Q:PNM="" S LRDFN=0 F S LRDFN=$O(^LRO(69,DT,1,"AR",LRLLOC,PNM,LRDFN)) Q:LRDFN<1 D LR1
11 Q
12PT1 ;
13 I $G(LRLLOC)="UNKNOWN" S LRLLOC=$G(^LR(LRDFN,.1))
14 I $G(LRLLOC)="" S LRLLOC="UNKNOWN"
15 S DIC="^SC(",DIC(0)="XZ",D="C",X=LRLLOC D IX^DIC S LRFLOC=$S(+Y>0:$S($P(Y(0),U,3)="W":LRLLOC,1:""),1:"") K LRLLIN S:+Y>0 LRLLIN=+Y
16 ;I Y'>0 S ^TMP("LR","T-CUME",LRLLOC)=$G(LRDT)_U_$G(LRDFN)_U_$G(LRPPT)
17 I $G(LRLLIN)'>0 D ^LRAC14
18 S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=$P(^(0),U,2) D PT^LRX S LRFLOC=$S(LRDPF=2&($L(LRWRD)):LRWRD,1:LRFLOC),SSN=$S($D(SSN(2)):SSN(2),1:SSN),PNM=$E(PNM,1,20)
19 I $L(LRFLOC) S LRSLOC=LRLLOC,LRLLOC=LRFLOC D DPT^LRWU S LRFLOC=LRLLOC,LRLLOC=LRSLOC
20 I $L(LRFLOC) S:'S1!(S1=1) ^TMP($J,"N",LRFLOC,LRPPT,LRDFN)="" Q
21 Q:S1=1 I S2 D DIC^LRACKL1 Q
22 S ^TMP($J,"N",LRLLOC,LRPPT,LRDFN)=""
23 Q
24PT ;
25 S LRPPT=""
26 F S LRPPT=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRPPT)) Q:LRPPT="" S LRDFN=0 F S LRDFN=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRPPT,LRDFN)) Q:LRDFN<1 Q:'$D(^LR(LRDFN,0))!($D(^TMP($J,LRDFN))) S ^TMP($J,LRDFN)="" D PT1
27 Q
28LRKL2 I $D(^LRO(68,"AC",LRDFN,LRIDTSB,LRKL2)),^(LRKL2)'="" K ^LRO(68,"AC",LRDFN,LRIDTSB,LRKL2)
29 Q
30LRKL1 S LRKL1=0 F S LRKL1=$O(^LAC("LRKILL",LRDFN,LRMH,LRSH,LRKL,LRKL1)) Q:LRKL1<1 S LRKL2=$P(^(LRKL1),U,1) D LRKL2
31 Q
32LRKL S LRKL=0 F S LRKL=$O(^LAC("LRKILL",LRDFN,LRMH,LRSH,LRKL)) Q:LRKL<1 S LRUTKL=$P(^(LRKL,0),U,2),LRIDTSB=$P(^(0),U,3) K ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRUTKL) D LRKL1
33 I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,0))="" K ^(0)
34 I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0))="" K ^(0)
35 Q
36LRMH S LRMH=0 F S LRMH=$O(^LAC("LRKILL",LRDFN,LRMH)) Q:LRMH<1 S LRSH=0 F S LRSH=$O(^LAC("LRKILL",LRDFN,LRMH,LRSH)) Q:LRSH<1 D LRKL
37 I LRMH="MI" D MICRO S LRMH=$O(^LAC("LRKILL",LRDFN,"MI"))
38 I LRMH="MISC" D MISC
39 Q
40SB S LRKL1=0 F S LRKL1=$O(^LAC("LRKILL",LRDFN,LRMH,1,LRKL,LRKL1)) Q:LRKL1<1 S LRKL2=$P(^(LRKL1),U,1) D LRKL2 K ^LAC(LRXLR,LRDFN,"MISC",1,1,LRKL,1,LRKL1)
41 I $O(^LAC(LRXLR,LRDFN,LRMH,1,1,LRKL,1,0))<1 K ^LAC(LRXLR,LRDFN,LRMH,1,1,LRKL)
42 Q
43MISC S LRKL=0 F S LRKL=$O(^LAC("LRKILL",LRDFN,LRMH,1,LRKL)) Q:LRKL<1 S LRIDTSB=$P(^(LRKL,0),U,1) D SB
44 Q
45MICRO S LRKL=0 F S LRKL=$O(^LAC("LRKILL",LRDFN,LRMH,LRKL)) Q:LRKL<1 S LRKL3=0 F S LRKL3=$O(^LAC("LRKILL",LRDFN,LRMH,LRKL,LRKL3)) Q:LRKL3<1 K ^LRO(68,"MI",LRDFN,LRKL,LRKL3)
46 Q
47DFN S LRDFN=0 F S LRDFN=$O(^LAC("LRKILL",LRDFN)) Q:LRDFN<1 D LRMH
48 Q
49AR K ^TMP($J) S S1=$P(^LAB(64.5,1,0),U,6),S2=$P(^(0),U,4) F J=0:0 S LRLLOC=$O(^LRO(69,LRDT,1,"AR",LRLLOC)) Q:LRLLOC="" S LRPPT=-1 D PT
50 K ^LRO(69,LRDT,1,"AR") S %X="^TMP($J,""N"",",%Y="^LRO(69,"_LRDT_",1,""AR""," D %XY^%RCR
51 K LRNLOC,LRLLOC,LRPPT,LRDFN,LRFLOC,DFN,DIC,DIC(0),S1,S2,X,Y,^TMP($J)
52 Q
53LAST Q:'$L(LRLDT) S LRNWT=$P(^LAB(64.5,1,0),U,3)
54 S X1=LRDT,X2=LRNWT D ^%DTC I X>1 S LRCVT=X-1 F I=1:1:LRCVT S X=LRNWT D H^%DTC S %H=%H+1 D YMD^%DTC S LRNWT=X,%X="^LRO(69,LRNWT,1,""AR"",",%Y="^LRO(69,LRDT,1,""AR""," D %XY^%RCR
55 D SHUF K LRNWT,%X,%Y,%H,X,LRCVT
56 Q
57ENT ;from LRAC
58 K ^TMP("TEMPLE") S LRCNTCUM=0
59 S LRLLOC=-1,U="^" D LAST,AR I '$D(^LAC("LRKILL")) D ALGOT K:$D(^LAC("LGOT")) ^LAC("LGOT") D:$D(^LAB(64.5,"AZ")) ENT^LRAC8 Q
60 D DFN
61END D ALGOT K ^LAC("LRKILL"),^LAC("LGOT"),LRDPF,LRDFN,LRMH,LRSH,LRKL,LRKL1,LRKL2,LRKL3,LRIDTSB,LRUTKL,LRSLOC D:$D(^LAB(64.5,"AZ")) ENT^LRAC8
62 ;
63 K ^TMP("LR","T-CUME")
64 K ^TMP("LR","LRCNT-CUME"),^TMP("LR","NO-LRLLIN"),^TMP("LR","LR-NO-LOC")
65 Q
66ALGOT I $D(^LAC("LGOT")) S I="" F S I=$O(^LAC("LGOT",I)) Q:I<1 S K="" F S K=$O(^LAC("LGOT",I,K)) Q:K="" S:K="MISC" ^LAC("LRAC",I,"MISC",1,.5)=0 S:K'="MISC" ^LAC("LRAC",I,1,K,.5)=0
67 Q
Note: See TracBrowser for help on using the repository browser.